diff --git a/ansi-tests/README b/ansi-tests/README new file mode 100644 index 0000000000000000000000000000000000000000..3d317ef74a5dfe159155ccda3fb03873c305f9b0 --- /dev/null +++ b/ansi-tests/README @@ -0,0 +1,35 @@ +This directory contains a partial Common Lisp standards compliance +test suite. + +To load, edit load.lsp and load it. To run, do this: + + (in-package :cl-test) + (do-tests) + +From GCL, instead just load gclload.lsp. This will automatically +run the tests. + +Individual tests may be run by (do-test '<test name>). + +The tests here cover the CONSes, SYMBOLs and PACKAGEs section of the +hyperspec, as well as fragments of other parts (sequences, types, +lists, arrays, structures, the reader). I intend to add tests for the +other parts of the standard. The package tests are currently disabled +in GCL because of a bug in DEFPACKAGE. + +When I run this I have a copy of the MK defsystem in the ../defsys30 +directory. The .system files use the MK forms (not the defsystem from +ACL). (Note: when gclload.lsp is loaded the defsystem is not used.) + +The tar file contains a modified version of the Waters RT regression +test package, which gets installed in subdirectory rt/. + +Please tell me when you find incorrect test cases. + +There are five test cases that cause very long loops on ACL (ELT-* +tests on type-bogus inputs; I think the system is considering the +pointers to be very large unsigned integers.) + + Paul Dietz + dietz@dls.net + diff --git a/ansi-tests/atom-errors.lsp b/ansi-tests/atom-errors.lsp new file mode 100644 index 0000000000000000000000000000000000000000..130e0ff46dd489d4b7aaae81a13bf2d07d537844 --- /dev/null +++ b/ansi-tests/atom-errors.lsp @@ -0,0 +1,39 @@ +(setf x + (loop + for tp in '(CONDITION +SERIOUS-CONDITION +ERROR +TYPE-ERROR +SIMPLE-TYPE-ERROR +SIMPLE-CONDITION +PARSE-ERROR +CELL-ERROR +UNBOUND-SLOT +WARNING +STYLE-WARNING +STORAGE-CONDITION +SIMPLE-WARNING +UNBOUND-VARIABLE +CONTROL-ERROR +PROGRAM-ERROR +UNDEFINED-FUNCTION +PACKAGE-ERROR +ARITHMETIC-ERROR +DIVISION-BY-ZERO +FLOATING-POINT-INVALID-OPERATION +FLOATING-POINT-INEXACT +FLOATING-POINT-OVERFLOW +FLOATING-POINT-UNDERFLOW +FILE-ERROR +BROADCAST-STREAM +CONCATENATED-STREAM +ECHO-STREAM +FILE-STREAM +STRING-STREAM +SYNONYM-STREAM +TWO-WAY-STREAM +STREAM-ERROR +END-OF-FILE +PRINT-NOT-READABLE + READER-ERROR) + collect (list tp (multiple-value-list (subtypep tp 'atom))))) diff --git a/ansi-tests/aux.lsp b/ansi-tests/aux.lsp new file mode 100644 index 0000000000000000000000000000000000000000..ff37580ae56c3c3ebde49493815ed0ef665bbd59 --- /dev/null +++ b/ansi-tests/aux.lsp @@ -0,0 +1,145 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Mar 28 17:10:18 1998 +;;;; Contains: Aux. functions for CL-TEST + +(in-package :cl-test) +(use-package :rt) + +(declaim (optimize (safety 3))) + +(defun make-int-list (n) + (loop for i from 0 to (1- n) collect i)) + +(declaim (special *universe*)) + +(defun check-type-predicate (P TYPE) + "Check that a predicate P is the same as #'(lambda (x) (typep x TYPE)) + by applying both to all elements of *UNIVERSE*. Print message + when a mismatch is found, and return number of mistakes." + + (loop + for x in *universe* count + (block failed + (let ((p1 (handler-case + (funcall P x) + (error () (format t "(FUNCALL ~S ~S) failed~%" + P x) + (return-from failed t)))) + (p2 (handler-case + (typep x TYPE) + (error () (format t "(TYPEP ~S '~S) failed~%" + x TYPE) + (return-from failed t))))) + (when (or (and p1 (not p2)) + (and (not p1) p2)) + (format t "(FUNCALL ~S ~S) = ~S, (TYPEP ~S '~S) = ~S~%" + P x p1 x TYPE p2) + t))))) + +(declaim (special *catch-error-type*)) + +(defun catch-continue-debugger-hook (condition dbh) + "Function that when used as *debugger-hook*, causes + continuable errors to be continued without user intervention." + (declare (ignore dbh)) + (let ((r (find-restart 'continue condition))) + (cond + ((and *catch-error-type* + (not (typep condition *catch-error-type*))) + (format t "Condition ~S is not a ~A~%" condition *catch-error-type*) + (cond (r (format t "Its continue restart is ~S~%" r)) + (t (format t "It has no continue restart~%"))) + (throw 'continue-failed nil)) + (r (invoke-restart r)) + (t (throw 'continue-failed nil))))) + +#| +(defun safe (fn &rest args) + "Apply fn to args, trapping errors. Convert type-errors to the + symbol type-error." + (declare (optimize (safety 3))) + (handler-case + (apply fn args) + (type-error () 'type-error) + (error (c) c))) +|# + +;; Use the next macro in place of SAFE + +(defmacro catch-type-error (form) +"Evaluate form in safe mode, returning its value if there is no error. +If an error does occur, return type-error on TYPE-ERRORs, or the error +condition itself on other errors." +`(locally (declare (optimize (safety 3))) + (handler-case ,form + (type-error () 'type-error) + (error (c) c)))) + +;; +;; A scaffold is a structure that is used to remember the object +;; identities of the cons cells in a (noncircular) data structure. +;; This lets us check if the data structure has been changed by +;; an operation. +;; + +(defstruct scaffold + node + car + cdr) + +(defun make-scaffold-copy (x) + "Make a tree that will be used to check if a tree has been changed." + (if + (consp x) + (make-scaffold :node x + :car (make-scaffold-copy (car x)) + :cdr (make-scaffold-copy (cdr x))) + (make-scaffold :node x + :car nil + :cdr nil))) + +(defun check-scaffold-copy (x xcopy) + "Return t if xcopy were produced from x by make-scaffold-copy, + and none of the cons cells in the tree rooted at x have been + changed." + + (and (eq x (scaffold-node xcopy)) + (or + (not (consp x)) + (and + (check-scaffold-copy (car x) (scaffold-car xcopy)) + (check-scaffold-copy (cdr x) (scaffold-cdr xcopy)))))) + + +;; +;; The function SUBTYPEP returns two generalized booleans. +;; This auxiliary function returns two booleans instead +;; (which makes it easier to write tests). +;; +(defun subtypep* (obj type) + (multiple-value-bind (result good) + (subtypep obj type) + (values (not (not result)) + (not (not good))))) + +(eval-when (load eval compile) + (unless (fboundp 'complement) + (defun complement (fn) + #'(lambda (&rest args) (not (apply fn args)))))) + +(defun compose (&rest fns) + (let ((rfns (reverse fns))) + #'(lambda (x) (loop for f in rfns do (setf x (funcall f x))) x))) + +(defun evendigitp (c) + (not (not (find c "02468")))) + +(defun odddigitp (c) + (not (not (find c "13579")))) + +(defun nextdigit (c) + (cadr (member c '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)))) + +(defun is-eq-p (x) #'(lambda (y) (eq x y))) +(defun is-not-eq-p (x) #'(lambda (y) (not (eq x y)))) diff --git a/ansi-tests/cases-14-1-arrays.lsp b/ansi-tests/cases-14-1-arrays.lsp new file mode 100644 index 0000000000000000000000000000000000000000..040e5131d4737f4a0c34b35bf8d8c314fca33162 --- /dev/null +++ b/ansi-tests/cases-14-1-arrays.lsp @@ -0,0 +1,642 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Mar 14 09:48:24 1998 +;;;; Contains: Test cases for CL, section 17.1 + +(in-package :cl-test) +(use-package :rt) + +(declaim (optimize (safety 3))) + +;; elt on ordinary vectors + +(defun make-int-array (n &optional (fn #'make-array)) + (let ((a (funcall fn n))) + (loop + for i from 0 to (1- n) do + (setf (aref a i) i)) + a)) + +(deftest elt-v-1 + (handler-case + (elt (make-array '(0)) 0) + (type-error () 'type-error) + (error (c) c)) + type-error) + +;; (deftest elt-v-2 (elt (make-array '(1)) 0) nil) ;; actually undefined +(deftest elt-v-3 (elt (make-array '(5) :initial-contents '(a b c d e)) 0) + a) +(deftest elt-v-4 (elt (make-array '(5) :initial-contents '(a b c d e)) 2) + c) +(deftest elt-v-5 (elt (make-array '(5) :initial-contents '(a b c d e)) 4) + e) + +(defun elt-v-6-body () + (let ((x (make-int-list 1000))) + (let ((a (make-array '(1000) :initial-contents x))) + (loop + for i from 0 to 999 do + (unless (eql i (elt a i)) (return nil)) + finally (return t))))) + +(deftest elt-v-6 + (elt-v-6-body) + t) + +(deftest elt-v-7 + (let* ((x (make-array '(4) :initial-contents (list 'a 'b 'c 'd))) + (y (setf (elt x 0) 'e))) + (list (elt x 0) (elt x 1) (elt x 2) (elt x 3) y)) + (e b c d e)) + +(deftest elt-v-8 + (let* ((x (make-array '(4) :initial-contents (list 'a 'b 'c 'd))) + (y (setf (elt x 1) 'e))) + (list (elt x 0) (elt x 1) (elt x 2) (elt x 3) y)) + (a e c d e)) + +(deftest elt-v-9 + (let* ((x (make-array '(4) :initial-contents (list 'a 'b 'c 'd))) + (y (setf (elt x 3) 'e))) + (list (elt x 0) (elt x 1) (elt x 2) (elt x 3) y)) + (a b c e e)) + +(deftest elt-v-10 + (handler-case + (let ((x (make-array '(3) :initial-contents (list 'a 'b 'c)))) + (setf (elt x 4) 'd)) + (type-error () 'type-error) + (error (c) c)) + type-error) + +(deftest elt-v-11 + (handler-case + (let ((x (make-array '(3) :initial-contents (list 'a 'b 'c)))) + (setf (elt x -100) 'd)) + (type-error () 'type-error) + (error (c) c)) + type-error) + +(deftest elt-v-12 + (let ((x (make-int-array 100000))) + (elt x 90000)) + 90000) + +(deftest elt-v-13 + (let ((x (make-int-array 100000))) + (setf (elt x 80000) 'foo) + (list (elt x 79999) + (elt x 80000) + (elt x 80001))) + (79999 foo 80001)) + +;;; Adjustable arrays + +(defun make-adj-array (n &key initial-contents) + (if initial-contents + (make-array n :adjustable t :initial-contents initial-contents) + (make-array n :adjustable t))) + +(deftest elt-adj-array-1 + (handler-case + (elt (make-adj-array '(0)) 0) + (type-error () 'type-error) + (error (c) c)) + type-error) + +;; (deftest elt-adj-array-2 (elt (make-adj-array '(1)) 0) nil) ;; actually undefined +(deftest elt-adj-array-3 (elt (make-adj-array '(5) :initial-contents '(a b c d e)) 0) + a) +(deftest elt-adj-array-4 (elt (make-adj-array '(5) :initial-contents '(a b c d e)) 2) + c) +(deftest elt-adj-array-5 (elt (make-adj-array '(5) :initial-contents '(a b c d e)) 4) + e) + +(defun elt-adj-array-6-body () + (let ((x (make-int-list 1000))) + (let ((a (make-adj-array '(1000) :initial-contents x))) + (loop + for i from 0 to 999 do + (unless (eql i (elt a i)) (return nil)) + finally (return t))))) + +(deftest elt-adj-array-6 + (elt-adj-array-6-body) + t) + +(deftest elt-adj-array-7 + (let* ((x (make-adj-array '(4) :initial-contents (list 'a 'b 'c 'd))) + (y (setf (elt x 0) 'e))) + (list (elt x 0) (elt x 1) (elt x 2) (elt x 3) y)) + (e b c d e)) + +(deftest elt-adj-array-8 + (let* ((x (make-adj-array '(4) :initial-contents (list 'a 'b 'c 'd))) + (y (setf (elt x 1) 'e))) + (list (elt x 0) (elt x 1) (elt x 2) (elt x 3) y)) + (a e c d e)) + +(deftest elt-adj-array-9 + (let* ((x (make-adj-array '(4) :initial-contents (list 'a 'b 'c 'd))) + (y (setf (elt x 3) 'e))) + (list (elt x 0) (elt x 1) (elt x 2) (elt x 3) y)) + (a b c e e)) + +(deftest elt-adj-array-10 + (handler-case + (let ((x (make-adj-array '(3) :initial-contents (list 'a 'b 'c)))) + (setf (elt x 4) 'd)) + (type-error () 'type-error) + (error (c) c)) + type-error) + +(deftest elt-adj-array-11 + (handler-case + (let ((x (make-adj-array '(3) :initial-contents (list 'a 'b 'c)))) + (setf (elt x -100) 'd)) + (type-error () 'type-error) + (error (c) c)) + type-error) + +(deftest elt-adj-array-12 + (let ((x (make-int-array 100000 #'make-adj-array))) + (elt x 90000)) + 90000) + +(deftest elt-adj-array-13 + (let ((x (make-int-array 100000 #'make-adj-array))) + (setf (elt x 80000) 'foo) + (list (elt x 79999) + (elt x 80000) + (elt x 80001))) + (79999 foo 80001)) + +;; displaced arrays + +(defvar *displaced* nil) +(setf *displaced* (make-int-array 100000)) + +(defun make-displaced-array (n displacement) + (make-array n :displaced-to *displaced* + :displaced-index-offset displacement)) + +(deftest elt-displaced-array-1 + (handler-case + (elt (make-displaced-array '(0) 100) 0) + (type-error () 'type-error) + (error (c) c)) + type-error) + +(deftest elt-displaced-array-2 + (elt (make-displaced-array '(1) 100) 0) + 100) + +(deftest elt-displaced-array-3 + (elt (make-displaced-array '(5) 100) 4) + 104) + +#| +(deftest elt-displaced-array-4 + (handler-case + (make-displaced-array '(100) 100000) + (type-error () 'type-error) + (error (c) c)) + type-error) +|# + +#| +(deftest elt-displaced-array-5 + (handler-case + (make-displaced-array '(100) (- 100000 50)) + (type-error () 'type-error) + (error (c) c)) + type-error) +|# + +;; subseq vectors + +(defun subseq-vector-1-body () + (block nil + (let* ((x (make-sequence 'vector 10 :initial-element 'a)) + (y (subseq x 4 8))) + (unless (every #'(lambda (e) (eq e 'a)) x) + (return 1)) + (unless (every #'(lambda (e) (eq e 'a)) y) + (return 2)) + (unless (eql (length x) 10) (return 3)) + (unless (eql (length y) 4) (return 4)) + (loop for i from 0 to 9 do (setf (aref x i) 'b)) + (unless (every #'(lambda (e) (eq e 'a)) y) + (return 5)) + (loop for i from 0 to 3 do (setf (aref y i) 'c)) + (or + (not (not (every #'(lambda (e) (eq e 'b)) x))) + 6)))) + +(deftest subseq-vector-1 + (subseq-vector-1-body) + t) + +(defun subseq-vector-2-body () + (block nil + (let* ((x (make-sequence '(vector fixnum) 10 :initial-element 1)) + (y (subseq x 4 8))) + (unless (every #'(lambda (e) (eql e 1)) x) + (return 1)) + (unless (every #'(lambda (e) (eql e 1)) y) + (return 2)) + (unless (eql (length x) 10) (return 3)) + (unless (eql (length y) 4) (return 4)) + (loop for i from 0 to 9 do (setf (aref x i) 2)) + (unless (every #'(lambda (e) (eql e 1)) y) + (return 5)) + (loop for i from 0 to 3 do (setf (aref y i) 3)) + (or + (not (not (every #'(lambda (e) (eql e 2)) x))) + 6)))) + +(deftest subseq-vector-2 + (subseq-vector-2-body) + t) + +(defun subseq-vector-3-body () + (block nil + (let* ((x (make-sequence '(vector single-float) 10 :initial-element 1.0)) + (y (subseq x 4 8))) + (unless (every #'(lambda (e) (= e 1.0)) x) + (return 1)) + (unless (every #'(lambda (e) (= e 1.0)) y) + (return 2)) + (unless (eql (length x) 10) (return 3)) + (unless (eql (length y) 4) (return 4)) + (loop for i from 0 to 9 do (setf (aref x i) 2.0)) + (unless (every #'(lambda (e) (= e 1.0)) y) + (return 5)) + (loop for i from 0 to 3 do (setf (aref y i) 3.0)) + (or + (not (not (every #'(lambda (e) (= e 2.0)) x))) + 6)))) + +(deftest subseq-vector-3 + (subseq-vector-3-body) + t) + +(defun subseq-vector-4-body () + (block nil + (let* ((x (make-sequence '(vector double-float) 10 :initial-element 1.0d0)) + (y (subseq x 4 8))) + (unless (every #'(lambda (e) (= e 1.0)) x) + (return 1)) + (unless (every #'(lambda (e) (= e 1.0)) y) + (return 2)) + (unless (eql (length x) 10) (return 3)) + (unless (eql (length y) 4) (return 4)) + (loop for i from 0 to 9 do (setf (aref x i) 2.0d0)) + (unless (every #'(lambda (e) (= e 1.0)) y) + (return 5)) + (loop for i from 0 to 3 do (setf (aref y i) 3.0d0)) + (or + (not (not (every #'(lambda (e) (= e 2.0)) x))) + 6)))) + +(deftest subseq-vector-4 + (subseq-vector-4-body) + t) + +(defun subseq-vector-5-body () + (block nil + (let* ((x (make-sequence '(vector short-float) 10 :initial-element 1.0s0)) + (y (subseq x 4 8))) + (unless (every #'(lambda (e) (= e 1.0)) x) + (return 1)) + (unless (every #'(lambda (e) (= e 1.0)) y) + (return 2)) + (unless (eql (length x) 10) (return 3)) + (unless (eql (length y) 4) (return 4)) + (loop for i from 0 to 9 do (setf (aref x i) 2.0s0)) + (unless (every #'(lambda (e) (= e 1.0)) y) + (return 5)) + (loop for i from 0 to 3 do (setf (aref y i) 3.0s0)) + (or + (not (not (every #'(lambda (e) (= e 2.0)) x))) + 6)))) + +(deftest subseq-vector-5 + (subseq-vector-5-body) + t) + +(defun subseq-vector-6-body () + (block nil + (let* ((x (make-sequence '(vector long-float) 10 :initial-element 1.0l0)) + (y (subseq x 4 8))) + (unless (every #'(lambda (e) (= e 1.0)) x) + (return 1)) + (unless (every #'(lambda (e) (= e 1.0)) y) + (return 2)) + (unless (eql (length x) 10) (return 3)) + (unless (eql (length y) 4) (return 4)) + (loop for i from 0 to 9 do (setf (aref x i) 2.0l0)) + (unless (every #'(lambda (e) (= e 1.0)) y) + (return 5)) + (loop for i from 0 to 3 do (setf (aref y i) 3.0l0)) + (or + (not (not (every #'(lambda (e) (= e 2.0)) x))) + 6)))) + +(deftest subseq-vector-6 + (subseq-vector-6-body) + t) + +(deftest copy-seq-vector-1 + (let* ((x (make-array '(10) :initial-contents '(a b c d e f g h i j))) + (y (copy-seq x))) + (equal-array x y)) + t) + +(deftest subseq-vector-7 + (let* ((x (make-array '(10) :initial-contents '(a b c d e f g h i j))) + (y (subseq x 2 8))) + (equal-array y (make-array '(6) :initial-contents '(c d e f g h)))) + t) + +(deftest subseq-vector-8 + (let* ((x (make-array '(200) :initial-element 107 + :element-type 'fixnum)) + (y (subseq x 17 95))) + (and (eql (length y) (- 95 17)) + (equal-array y + (make-array (list (- 95 17)) + :initial-element 107 + :element-type 'fixnum)))) + t) + +(deftest subseq-vector-9 + (let* ((x (make-array '(1000) :initial-element 17.6e-1 + :element-type 'single-float)) + (lo 164) + (hi 873) + (y (subseq x lo hi))) + (and (eql (length y) (- hi lo)) + (equal-array y + (make-array (list (- hi lo)) + :initial-element 17.6e-1 + :element-type 'single-float)))) + t) + +(deftest subseq-vector-10 + (let* ((x (make-array '(2000) :initial-element 3.1415927d4 + :element-type 'double-float)) + (lo 731) + (hi 1942) + (y (subseq x lo hi))) + (and (eql (length y) (- hi lo)) + (equal-array y + (make-array (list (- hi lo)) + :initial-element 3.1415927d4 + :element-type 'double-float)))) + t) + +;; array reversal + +(defun equal-array (a1 a2) + (and (typep a1 'array) + (typep a2 'array) + (= (array-rank a1) (array-rank a2)) + (let ((ad (array-dimensions a1))) + (and (equal ad (array-dimensions a2)) + (let ((as (array-total-size a1))) + (and (= as (array-total-size a2)) + (loop + for i from 0 to (1- as) do + (unless (equal (row-major-aref a1 i) + (row-major-aref a2 i)) + (return nil)) + finally (return t)))))))) + +;; array length + +(deftest array-length-1 + (length (make-array '(20))) + 20) + +(deftest array-length-2 + (length (make-array '(100001))) + 100001) + +(deftest array-length-3 + (length (make-array '(0))) + 0) + +(deftest array-length-4 + (let ((x (make-array '(100) :fill-pointer 10))) + (length x)) + 10) + +(deftest array-length-5 + (let ((x (make-array '(100) :fill-pointer 10))) + (setf (fill-pointer x) 20) + (length x)) + 20) + +;;; Fill on arrays + +(deftest array-fill-1 + (let* ((a (make-array '(5) :initial-contents '(a b c d e))) + (b (fill a 'x))) + (values (eq a b) + (map 'list #'identity a))) + t (x x x x x)) + +(deftest array-fill-2 + (let* ((a (make-array '(5) :initial-contents '(a b c d e))) + (b (fill a 'x :start 2))) + (values (eq a b) + (map 'list #'identity a))) + t (a b x x x)) + +(deftest array-fill-3 + (let* ((a (make-array '(5) :initial-contents '(a b c d e))) + (b (fill a 'x :end 2))) + (values (eq a b) + (map 'list #'identity a))) + t (x x c d e)) + +(deftest array-fill-4 + (let* ((a (make-array '(5) :initial-contents '(a b c d e))) + (b (fill a 'x :start 1 :end 3))) + (values (eq a b) + (map 'list #'identity a))) + t (a x x x e)) + +(deftest array-fill-5 + (let* ((a (make-array '(5) :initial-contents '(a b c d e))) + (b (fill a 'x :start 1 :end nil))) + (values (eq a b) + (map 'list #'identity a))) + t (a x x x x)) + +(deftest array-fill-6 + (let* ((a (make-array '(5) :initial-contents '(a b c d e))) + (b (fill a 'x :end nil))) + (values (eq a b) + (map 'list #'identity a))) + t (x x x x x)) + +(deftest array-fill-7 + (let* ((a (make-array '(5)))) + (handler-case (fill a 'x :start -1) + (type-error (c) 'type-error) + (error (c) c))) + type-error) + +(deftest array-fill-8 + (let* ((a (make-array '(5)))) + (handler-case (fill a 'x :start 'a) + (type-error (c) 'type-error) + (error (c) c))) + type-error) + +(deftest array-fill-9 + (let* ((a (make-array '(5)))) + (handler-case (fill a 'x :end -1) + (type-error (c) 'type-error) + (error (c) c))) + type-error) + +(deftest array-fill-10 + (let* ((a (make-array '(5)))) + (handler-case (fill a 'x :end 'a) + (type-error (c) 'type-error) + (error (c) c))) + type-error) + +;;; fill on arrays of fixnums + +(deftest array-fixnum-fill-1 + (let* ((a (make-array '(5) :element-type 'fixnum :initial-contents '(1 2 3 4 5))) + (b (fill a 6))) + (values (eq a b) + (map 'list #'identity a))) + t (6 6 6 6 6)) + +(deftest array-fixnum-fill-2 + (let* ((a (make-array '(5) :element-type 'fixnum :initial-contents '(1 2 3 4 5))) + (b (fill a 6 :start 2))) + (values (eq a b) + (map 'list #'identity a))) + t (1 2 6 6 6)) + +(deftest array-fixnum-fill-3 + (let* ((a (make-array '(5) :element-type 'fixnum :initial-contents '(1 2 3 4 5))) + (b (fill a 7 :end 2))) + (values (eq a b) + (map 'list #'identity a))) + t (7 7 3 4 5)) + +(deftest array-fixnum-fill-4 + (let* ((a (make-array '(5) :element-type 'fixnum :initial-contents '(1 2 3 4 5))) + (b (fill a 8 :start 1 :end 3))) + (values (eq a b) + (map 'list #'identity a))) + t (1 8 8 4 5)) + +(deftest array-fixnum-fill-5 + (let* ((a (make-array '(5) :element-type 'fixnum :initial-contents '(1 2 3 4 5))) + (b (fill a 0 :start 1 :end nil))) + (values (eq a b) + (map 'list #'identity a))) + t (1 0 0 0 0)) + +(deftest array-fixnum-fill-6 + (let* ((a (make-array '(5) :element-type 'fixnum :initial-contents '(1 2 3 4 5))) + (b (fill a -1 :end nil))) + (values (eq a b) + (map 'list #'identity a))) + t (-1 -1 -1 -1 -1)) + +(deftest array-fixnum-fill-7 + (let* ((a (make-array '(5) :element-type 'fixnum))) + (handler-case (fill a 10 :start -1) + (type-error (c) 'type-error) + (error (c) c))) + type-error) + +(deftest array-fixnum-fill-8 + (let* ((a (make-array '(5) :element-type 'fixnum))) + (handler-case (fill a 100 :start 'a) + (type-error (c) 'type-error) + (error (c) c))) + type-error) + +(deftest array-fixnum-fill-9 + (let* ((a (make-array '(5) :element-type 'fixnum))) + (handler-case (fill a -5 :end -1) + (type-error (c) 'type-error) + (error (c) c))) + type-error) + +(deftest array-fixnum-fill-10 + (let* ((a (make-array '(5) :element-type 'fixnum))) + (handler-case (fill a 17 :end 'a) + (type-error (c) 'type-error) + (error (c) c))) + type-error) + +;;; fill on arrays of unsigned eight bit bytes + +(defun array-unsigned-byte-fill-test-fn (byte-size &rest fill-args) + (let* ((a (make-array '(5) :element-type (list 'unsigned-byte byte-size) + :initial-contents '(1 2 3 4 5))) + (b (apply #'fill a fill-args))) + (values (eq a b) + (map 'list #'identity a)))) + +(deftest array-unsigned-byte8-fill-1 + (array-unsigned-byte-fill-test-fn 8 6) + t (6 6 6 6 6)) + +(deftest array-unsigned-byte8-fill-2 + (array-unsigned-byte-fill-test-fn 8 6 :start 2) + t (1 2 6 6 6)) + +(deftest array-unsigned-byte8-fill-3 + (array-unsigned-byte-fill-test-fn 8 7 :end 2) + t (7 7 3 4 5)) + +(deftest array-unsigned-byte8-fill-4 + (array-unsigned-byte-fill-test-fn 8 8 :start 1 :end 3) + t (1 8 8 4 5)) + +(deftest array-unsigned-byte8-fill-5 + (array-unsigned-byte-fill-test-fn 8 9 :start 1 :end nil) + t (1 9 9 9 9)) +Z +(deftest array-unsigned-byte8-fill-6 + (array-unsigned-byte-fill-test-fn 8 0 :end nil) + t (0 0 0 0 0)) + +(deftest array-unsigned-byte8-fill-7 + (handler-case (array-unsigned-byte-fill-test-fn 8 0 :start -1) + (type-error (c) 'type-error) + (error (c) c)) + type-error) + +(deftest array-unsigned-byte8-fill-8 + (handler-case (array-unsigned-byte-fill-test-fn 8 100 :start 'a) + (type-error (c) 'type-error) + (error (c) c)) + type-error) + +(deftest array-unsigned-byte8-fill-9 + (handler-case (array-unsigned-byte-fill-test-fn 8 19 :end -1) + (type-error (c) 'type-error) + (error (c) c)) + type-error) + +(deftest array-unsigned-byte8-fill-10 + (handler-case (array-unsigned-byte-fill-test-fn 8 17 :end 'a) + (type-error (c) 'type-error) + (error (c) c)) + type-error) + diff --git a/ansi-tests/cases-14-1-list.lsp b/ansi-tests/cases-14-1-list.lsp new file mode 100644 index 0000000000000000000000000000000000000000..47eaaa04658804abd525768923e2e1b019de1c73 --- /dev/null +++ b/ansi-tests/cases-14-1-list.lsp @@ -0,0 +1,322 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Wed Apr 8 20:05:24 1998 +;;;; Contains: Test cases for CL, section 14.1 of CLtL2, Lists as Sequences + +(in-package :cl-test) +(use-package :rt) + +(declaim (optimize (safety 3))) + +(defun safe-elt (x n) + (handler-case + (elt x n) + (type-error () 'type-error) + (error (c) c))) + +;; elt on lists + +(deftest elt-1 (safe-elt nil 0) type-error) +(deftest elt-1a (safe-elt nil -10) type-error) +(deftest elt-2 (safe-elt nil 1000000) type-error) +(deftest elt-3 (safe-elt '(a b c d e) 0) a) +(deftest elt-4 (safe-elt '(a b c d e) 2) c) +(deftest elt-5 (safe-elt '(a b c d e) 4) e) +(deftest elt-5a (safe-elt '(a b c d e) -4) type-error) +(deftest elt-6 + (let ((x (make-int-list 1000))) + (not (not + (every + #'(lambda (i) + (eql i (safe-elt x i))) + x)))) + t) + +(deftest elt-7 + (let* ((x (list 'a 'b 'c 'd)) + (y (setf (elt x 0) 'e))) + (list x y)) + ((e b c d) e)) + +(deftest elt-8 + (let* ((x (list 'a 'b 'c 'd)) + (y (setf (elt x 1) 'e))) + (list x y)) + ((a e c d) e)) + +(deftest elt-9 + (let* ((x (list 'a 'b 'c 'd)) + (y (setf (elt x 3) 'e))) + (list x y)) + ((a b c e) e)) + +(deftest elt-10 + (handler-case + (let ((x (list 'a 'b 'c))) + (setf (elt x 4) 'd)) + (type-error () 'type-error) + (error (c) c)) + type-error) + +(deftest elt-11 + (let ((x (list 'a 'b 'c 'd 'e))) + (let ((y (loop for c on x collect c))) + (setf (elt x 2) 'f) + (not + (not + (every #'eq + y + (loop for c on x collect c)))))) + t) + +(deftest elt-12 + (let ((x (make-int-list 100000))) + (safe-elt x 90000)) + 90000) + +(deftest elt-13 + (let ((x (make-int-list 100000))) + (setf (elt x 80000) 'foo) + (list (safe-elt x 79999) + (safe-elt x 80000) + (safe-elt x 80001))) + (79999 foo 80001)) + + +;; Special case to test error handling as dictated by new +;; CL standard +(deftest elt-14 + (let ((x (list 'a 'b 'c))) + (safe-elt x 10)) + type-error) + +(deftest elt-15 + (let ((x (list 'a 'b 'c))) + (safe-elt x 'a)) + type-error) + +(deftest elt-16 + (let ((x (list 'a 'b 'c))) + (safe-elt x 10.0)) + type-error) + +(deftest elt-17 + (let ((x (list 'a 'b 'c))) + (safe-elt x -1)) + type-error) + +(deftest elt-18 + (let ((x (list 'a 'b 'c))) + (safe-elt x -100000000000000000)) + type-error) + +(deftest elt-19 + (let ((x (list 'a 'b 'c))) + (safe-elt x #\w)) + type-error) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; subseq, on lists + +(deftest subseq-list-1 + (subseq '(a b c d e) 0 0) + nil) + +(deftest subseq-list-2 + (subseq '(a b c) 0) + (a b c)) + +(deftest subseq-list-3 + (subseq '(a b c) 1) + (b c)) + +(defun subseq-list-4-body () + (block done + (let ((x (loop for i from 0 to 19 collect i))) + (loop + for i from 0 to 20 do + (loop + for j from i to 20 do + (let ((y (subseq x i j))) + (loop + for e in y and k from i to (1- j) do + (unless (eql e k) (return-from done nil))))))) + t)) + +(deftest subseq-list-4 + (subseq-list-4-body) + t) + +(defun subseq-list-5-body () + (block done + (let ((x (loop for i from 0 to 29 collect i))) + (loop + for i from 0 to 30 do + (unless (equal (subseq x i) + (loop for j from i to 29 collect j)) + (return-from done nil)))) + t)) + +(deftest subseq-list-5 + (subseq-list-5-body) + t) + +(defun subseq-list-6-body () + + (let* ((x (make-list 100)) + (z (loop for e on x collect e)) + (y (subseq x 0))) + (loop + for e on x + and f on y + and g in z do + (when (or (not (eq g e)) + (not (eql (car e) (car f))) + (car e) + (eq e f)) + (return nil)) + finally (return t)))) + +(deftest subseq-list-6 ;; check that no structure is shared + (subseq-list-6-body) + t) + +(deftest subseq-list-7 + (let ((x (loop for i from 0 to 9 collect i))) + (setf (subseq x 0 3) (list 'a 'b 'c)) + x) + (a b c 3 4 5 6 7 8 9)) + +(deftest subseq-list-8 + (let* ((x '(a b c d e)) + (y (copy-seq x))) + (setf (subseq y 0) '(f g h)) + (list x y)) + ((a b c d e) (f g h d e))) + +(deftest subseq-list-9 + (let* ((x '(a b c d e)) + (y (copy-seq x))) + (setf (subseq y 1 3) '(1 2 3 4 5)) + (list x y)) + ((a b c d e) (a 1 2 d e))) + +(deftest subseq-list-10 + (let* ((x '(a b c d e)) + (y (copy-seq x))) + (setf (subseq y 5) '(1 2 3 4 5)) + (list x y)) + ((a b c d e) (a b c d e))) + +(deftest subseq-list-11 + (let* ((x '(a b c d e)) + (y (copy-seq x))) + (setf (subseq y 2 5) '(1)) + (list x y)) + ((a b c d e) (a b 1 d e))) + +(deftest subseq-list-12 + (let* ((x '(a b c d e)) + (y (copy-seq x))) + (setf (subseq y 0 0) '(1 2)) + (list x y)) + ((a b c d e) (a b c d e))) + +;; length of lists + +(deftest length-list-1 + (length ()) + 0) + +(deftest length-list-2 + (length '(a b c d e f g)) + 7) + +(deftest length-list-3 + (length (make-list 200000)) + 200000) + +(defun length-list-4-body () + + (let ((x ())) + (loop + for i from 0 to 999 do + (progn + (unless (eql (length x) i) (return nil)) + (push i x)) + finally (return t)))) + +(deftest length-list-4 + (length-list-4-body) + t) + +;; reverse of lists + +(deftest reverse-list-1 + (reverse ()) + ()) + +(deftest reverse-list-2 + (reverse '(a b c d e f)) + (f e d c b a)) + +(defun reverse-list-3-body () + (let* ((x (loop for i from 0 to 999 collect i)) + (z (loop for e on x collect e)) + (y (reverse x))) + (and + (loop + for e on x and f in z do + (unless (eq e f) (return nil)) + finally (return t)) + (every #'eql + y + (loop for i from 999 downto 0 collect i))))) + +(deftest reverse-list-3 + (reverse-list-3-body) + t) + +(deftest nreverse-list-1 + (nreverse nil) + nil) + +(deftest nreverse-list-2 + (nreverse (list 'a)) + (a)) + +(deftest nreverse-list-3 + (nreverse (list 'a 'b 'c 'd)) + (d c b a)) + +(defun nreverse-list-4-body () + (let* ((x (loop for i from 0 to 100000 collect i)) + (y (copy-seq x))) + (equal y (nreverse (nreverse x))))) + +(deftest nreverse-list-4 + (nreverse-list-4-body) + t) + + + +(deftest make-sequence-list-1 + (make-sequence 'list 0) + nil) + +(deftest make-sequence-list-2 + (make-sequence 'list 5 :initial-element 'g) + (g g g g g)) + +(deftest make-sequence-list-3 + (length (make-sequence 'list 100)) + 100) + +(deftest make-sequence-list-4 + (length (make-sequence 'list 123456)) + 123456) + +(deftest make-sequence-list-5 + (let ((x (make-sequence 'list 1000))) + (every #'(lambda (e) (eq (car x) e)) (cdr x))) + t) diff --git a/ansi-tests/cl-symbols.lsp b/ansi-tests/cl-symbols.lsp new file mode 100644 index 0000000000000000000000000000000000000000..a5261bb44e6969a17ee7a7983d99e35b7d302250 --- /dev/null +++ b/ansi-tests/cl-symbols.lsp @@ -0,0 +1,1318 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Mar 15 13:19:57 1998 +;;;; Contains: Test presence of symbols in the CL package, +;;;; and symbol-related functions + +(in-package :cl-test) +(use-package :rt) + +(declaim (optimize (safety 3))) + +(defun test-if-not-in-cl-package (str) + (multiple-value-bind (sym status) + (find-symbol (string-upcase str) 'common-lisp) + (declare (ignore sym)) + (not status))) + +;; Test for the presence of every darned symbol +;; the standard says should be in the CL package. + +(deftest symbol-&allow-other-keys (test-if-not-in-cl-package "&allow-other-keys") nil) +(deftest symbol-&aux (test-if-not-in-cl-package "&aux") nil) +(deftest symbol-&body (test-if-not-in-cl-package "&body") nil) +(deftest symbol-&environment (test-if-not-in-cl-package "&environment") nil) +(deftest symbol-&key (test-if-not-in-cl-package "&key") nil) +(deftest symbol-&optional (test-if-not-in-cl-package "&optional") nil) +(deftest symbol-&rest (test-if-not-in-cl-package "&rest") nil) +(deftest symbol-&whole (test-if-not-in-cl-package "&whole") nil) +(deftest symbol-* (test-if-not-in-cl-package "*") nil) +(deftest symbol-** (test-if-not-in-cl-package "**") nil) +(deftest symbol-*** (test-if-not-in-cl-package "***") nil) +(deftest symbol-*break-on-signals* (test-if-not-in-cl-package "*break-on-signals*") nil) +(deftest symbol-*compile-file-pathname* (test-if-not-in-cl-package "*compile-file-pathname*") nil) +(deftest symbol-*compile-file-truename* (test-if-not-in-cl-package "*compile-file-truename*") nil) +(deftest symbol-*compile-print* (test-if-not-in-cl-package "*compile-print*") nil) +(deftest symbol-*compile-verbose* (test-if-not-in-cl-package "*compile-verbose*") nil) +(deftest symbol-*debug-io* (test-if-not-in-cl-package "*debug-io*") nil) +(deftest symbol-*debugger-hook* (test-if-not-in-cl-package "*debugger-hook*") nil) +(deftest symbol-*default-pathname-defaults* (test-if-not-in-cl-package "*default-pathname-defaults*") nil) +(deftest symbol-*error-output* (test-if-not-in-cl-package "*error-output*") nil) +(deftest symbol-*features* (test-if-not-in-cl-package "*features*") nil) +(deftest symbol-*gensym-counter* (test-if-not-in-cl-package "*gensym-counter*") nil) +(deftest symbol-*load-pathname* (test-if-not-in-cl-package "*load-pathname*") nil) +(deftest symbol-*load-print* (test-if-not-in-cl-package "*load-print*") nil) +(deftest symbol-*load-truename* (test-if-not-in-cl-package "*load-truename*") nil) +(deftest symbol-*load-verbose* (test-if-not-in-cl-package "*load-verbose*") nil) +(deftest symbol-*macroexpand-hook* (test-if-not-in-cl-package "*macroexpand-hook*") nil) +(deftest symbol-*modules* (test-if-not-in-cl-package "*modules*") nil) +(deftest symbol-*package* (test-if-not-in-cl-package "*package*") nil) +(deftest symbol-*print-array* (test-if-not-in-cl-package "*print-array*") nil) +(deftest symbol-*print-base* (test-if-not-in-cl-package "*print-base*") nil) +(deftest symbol-*print-case* (test-if-not-in-cl-package "*print-case*") nil) +(deftest symbol-*print-circle* (test-if-not-in-cl-package "*print-circle*") nil) +(deftest symbol-*print-escape* (test-if-not-in-cl-package "*print-escape*") nil) +(deftest symbol-*print-gensym* (test-if-not-in-cl-package "*print-gensym*") nil) +(deftest symbol-*print-length* (test-if-not-in-cl-package "*print-length*") nil) +(deftest symbol-*print-level* (test-if-not-in-cl-package "*print-level*") nil) +(deftest symbol-*print-lines* (test-if-not-in-cl-package "*print-lines*") nil) +(deftest symbol-*print-miser-width* (test-if-not-in-cl-package "*print-miser-width*") nil) +(deftest symbol-*print-pprint-dispatch* (test-if-not-in-cl-package "*print-pprint-dispatch*") nil) +(deftest symbol-*print-pretty* (test-if-not-in-cl-package "*print-pretty*") nil) +(deftest symbol-*print-radix* (test-if-not-in-cl-package "*print-radix*") nil) +(deftest symbol-*print-readably* (test-if-not-in-cl-package "*print-readably*") nil) +(deftest symbol-*print-right-margin* (test-if-not-in-cl-package "*print-right-margin*") nil) +(deftest symbol-*query-io* (test-if-not-in-cl-package "*query-io*") nil) +(deftest symbol-*random-state* (test-if-not-in-cl-package "*random-state*") nil) +(deftest symbol-*read-base* (test-if-not-in-cl-package "*read-base*") nil) +(deftest symbol-*read-default-float-format* (test-if-not-in-cl-package "*read-default-float-format*") nil) +(deftest symbol-*read-eval* (test-if-not-in-cl-package "*read-eval*") nil) +(deftest symbol-*read-suppress* (test-if-not-in-cl-package "*read-suppress*") nil) +(deftest symbol-*readtable* (test-if-not-in-cl-package "*readtable*") nil) +(deftest symbol-*standard-input* (test-if-not-in-cl-package "*standard-input*") nil) +(deftest symbol-*standard-output* (test-if-not-in-cl-package "*standard-output*") nil) +(deftest symbol-*terminal-io* (test-if-not-in-cl-package "*terminal-io*") nil) +(deftest symbol-*trace-output* (test-if-not-in-cl-package "*trace-output*") nil) +(deftest symbol-+ (test-if-not-in-cl-package "+") nil) +(deftest symbol-++ (test-if-not-in-cl-package "++") nil) +(deftest symbol-+++ (test-if-not-in-cl-package "+++") nil) +(deftest symbol-- (test-if-not-in-cl-package "-") nil) +(deftest symbol-/ (test-if-not-in-cl-package "/") nil) +(deftest symbol-// (test-if-not-in-cl-package "//") nil) +(deftest symbol-/// (test-if-not-in-cl-package "///") nil) +(deftest symbol-/= (test-if-not-in-cl-package "/=") nil) +(deftest symbol-1+ (test-if-not-in-cl-package "1+") nil) +(deftest symbol-1- (test-if-not-in-cl-package "1-") nil) +(deftest symbol-< (test-if-not-in-cl-package "<") nil) +(deftest symbol-<= (test-if-not-in-cl-package "<=") nil) +(deftest symbol-= (test-if-not-in-cl-package "=") nil) +(deftest symbol-> (test-if-not-in-cl-package ">") nil) +(deftest symbol->= (test-if-not-in-cl-package ">=") nil) +(deftest symbol-abort (test-if-not-in-cl-package "abort") nil) +(deftest symbol-abs (test-if-not-in-cl-package "abs") nil) +(deftest symbol-acons (test-if-not-in-cl-package "acons") nil) +(deftest symbol-acos (test-if-not-in-cl-package "acos") nil) +(deftest symbol-acosh (test-if-not-in-cl-package "acosh") nil) +(deftest symbol-add-method (test-if-not-in-cl-package "add-method") nil) +(deftest symbol-adjoin (test-if-not-in-cl-package "adjoin") nil) +(deftest symbol-adjust-array (test-if-not-in-cl-package "adjust-array") nil) +(deftest symbol-adjustable-array-p (test-if-not-in-cl-package "adjustable-array-p") nil) +(deftest symbol-allocate-instance (test-if-not-in-cl-package "allocate-instance") nil) +(deftest symbol-alpha-char-p (test-if-not-in-cl-package "alpha-char-p") nil) +(deftest symbol-alphanumericp (test-if-not-in-cl-package "alphanumericp") nil) +(deftest symbol-and (test-if-not-in-cl-package "and") nil) +(deftest symbol-append (test-if-not-in-cl-package "append") nil) +(deftest symbol-apply (test-if-not-in-cl-package "apply") nil) +(deftest symbol-apropos (test-if-not-in-cl-package "apropos") nil) +(deftest symbol-apropos-list (test-if-not-in-cl-package "apropos-list") nil) +(deftest symbol-aref (test-if-not-in-cl-package "aref") nil) +(deftest symbol-arithmetic-error (test-if-not-in-cl-package "arithmetic-error") nil) +(deftest symbol-arithmetic-error-operands (test-if-not-in-cl-package "arithmetic-error-operands") nil) +(deftest symbol-arithmetic-error-operation (test-if-not-in-cl-package "arithmetic-error-operation") nil) +(deftest symbol-array (test-if-not-in-cl-package "array") nil) +(deftest symbol-array-dimension (test-if-not-in-cl-package "array-dimension") nil) +(deftest symbol-array-dimension-limit (test-if-not-in-cl-package "array-dimension-limit") nil) +(deftest symbol-array-dimensions (test-if-not-in-cl-package "array-dimensions") nil) +(deftest symbol-array-displacement (test-if-not-in-cl-package "array-displacement") nil) +(deftest symbol-array-element-type (test-if-not-in-cl-package "array-element-type") nil) +(deftest symbol-array-has-fill-pointer-p (test-if-not-in-cl-package "array-has-fill-pointer-p") nil) +(deftest symbol-array-in-bounds-p (test-if-not-in-cl-package "array-in-bounds-p") nil) +(deftest symbol-array-rank (test-if-not-in-cl-package "array-rank") nil) +(deftest symbol-array-rank-limit (test-if-not-in-cl-package "array-rank-limit") nil) +(deftest symbol-array-row-major-index (test-if-not-in-cl-package "array-row-major-index") nil) +(deftest symbol-array-total-size (test-if-not-in-cl-package "array-total-size") nil) +(deftest symbol-array-total-size-limit (test-if-not-in-cl-package "array-total-size-limit") nil) +(deftest symbol-arrayp (test-if-not-in-cl-package "arrayp") nil) +(deftest symbol-ash (test-if-not-in-cl-package "ash") nil) +(deftest symbol-asin (test-if-not-in-cl-package "asin") nil) +(deftest symbol-asinh (test-if-not-in-cl-package "asinh") nil) +(deftest symbol-assert (test-if-not-in-cl-package "assert") nil) +(deftest symbol-assoc (test-if-not-in-cl-package "assoc") nil) +(deftest symbol-assoc-if (test-if-not-in-cl-package "assoc-if") nil) +(deftest symbol-assoc-if-not (test-if-not-in-cl-package "assoc-if-not") nil) +(deftest symbol-atan (test-if-not-in-cl-package "atan") nil) +(deftest symbol-atanh (test-if-not-in-cl-package "atanh") nil) +(deftest symbol-atom (test-if-not-in-cl-package "atom") nil) +(deftest symbol-base-char (test-if-not-in-cl-package "base-char") nil) +(deftest symbol-base-string (test-if-not-in-cl-package "base-string") nil) +(deftest symbol-bignum (test-if-not-in-cl-package "bignum") nil) +(deftest symbol-bit (test-if-not-in-cl-package "bit") nil) +(deftest symbol-bit-and (test-if-not-in-cl-package "bit-and") nil) +(deftest symbol-bit-andc1 (test-if-not-in-cl-package "bit-andc1") nil) +(deftest symbol-bit-andc2 (test-if-not-in-cl-package "bit-andc2") nil) +(deftest symbol-bit-eqv (test-if-not-in-cl-package "bit-eqv") nil) +(deftest symbol-bit-ior (test-if-not-in-cl-package "bit-ior") nil) +(deftest symbol-bit-nand (test-if-not-in-cl-package "bit-nand") nil) +(deftest symbol-bit-nor (test-if-not-in-cl-package "bit-nor") nil) +(deftest symbol-bit-not (test-if-not-in-cl-package "bit-not") nil) +(deftest symbol-bit-orc1 (test-if-not-in-cl-package "bit-orc1") nil) +(deftest symbol-bit-orc2 (test-if-not-in-cl-package "bit-orc2") nil) +(deftest symbol-bit-vector (test-if-not-in-cl-package "bit-vector") nil) +(deftest symbol-bit-vector-p (test-if-not-in-cl-package "bit-vector-p") nil) +(deftest symbol-bit-xor (test-if-not-in-cl-package "bit-xor") nil) +(deftest symbol-block (test-if-not-in-cl-package "block") nil) +(deftest symbol-boole (test-if-not-in-cl-package "boole") nil) +(deftest symbol-boole-1 (test-if-not-in-cl-package "boole-1") nil) +(deftest symbol-boole-2 (test-if-not-in-cl-package "boole-2") nil) +(deftest symbol-boole-and (test-if-not-in-cl-package "boole-and") nil) +(deftest symbol-boole-andc1 (test-if-not-in-cl-package "boole-andc1") nil) +(deftest symbol-boole-andc2 (test-if-not-in-cl-package "boole-andc2") nil) +(deftest symbol-boole-c1 (test-if-not-in-cl-package "boole-c1") nil) +(deftest symbol-boole-c2 (test-if-not-in-cl-package "boole-c2") nil) +(deftest symbol-boole-clr (test-if-not-in-cl-package "boole-clr") nil) +(deftest symbol-boole-eqv (test-if-not-in-cl-package "boole-eqv") nil) +(deftest symbol-boole-ior (test-if-not-in-cl-package "boole-ior") nil) +(deftest symbol-boole-nand (test-if-not-in-cl-package "boole-nand") nil) +(deftest symbol-boole-nor (test-if-not-in-cl-package "boole-nor") nil) +(deftest symbol-boole-orc1 (test-if-not-in-cl-package "boole-orc1") nil) +(deftest symbol-boole-orc2 (test-if-not-in-cl-package "boole-orc2") nil) +(deftest symbol-boole-set (test-if-not-in-cl-package "boole-set") nil) +(deftest symbol-boole-xor (test-if-not-in-cl-package "boole-xor") nil) +(deftest symbol-boolean (test-if-not-in-cl-package "boolean") nil) +(deftest symbol-both-case-p (test-if-not-in-cl-package "both-case-p") nil) +(deftest symbol-boundp (test-if-not-in-cl-package "boundp") nil) +(deftest symbol-break (test-if-not-in-cl-package "break") nil) +(deftest symbol-broadcast-stream (test-if-not-in-cl-package "broadcast-stream") nil) +(deftest symbol-broadcast-stream-streams (test-if-not-in-cl-package "broadcast-stream-streams") nil) +(deftest symbol-built-in-class (test-if-not-in-cl-package "built-in-class") nil) +(deftest symbol-butlast (test-if-not-in-cl-package "butlast") nil) +(deftest symbol-byte (test-if-not-in-cl-package "byte") nil) +(deftest symbol-byte-position (test-if-not-in-cl-package "byte-position") nil) +(deftest symbol-byte-size (test-if-not-in-cl-package "byte-size") nil) +(deftest symbol-caaaar (test-if-not-in-cl-package "caaaar") nil) +(deftest symbol-caaadr (test-if-not-in-cl-package "caaadr") nil) +(deftest symbol-caaar (test-if-not-in-cl-package "caaar") nil) +(deftest symbol-caadar (test-if-not-in-cl-package "caadar") nil) +(deftest symbol-caaddr (test-if-not-in-cl-package "caaddr") nil) +(deftest symbol-caadr (test-if-not-in-cl-package "caadr") nil) +(deftest symbol-caar (test-if-not-in-cl-package "caar") nil) +(deftest symbol-cadaar (test-if-not-in-cl-package "cadaar") nil) +(deftest symbol-cadadr (test-if-not-in-cl-package "cadadr") nil) +(deftest symbol-cadar (test-if-not-in-cl-package "cadar") nil) +(deftest symbol-caddar (test-if-not-in-cl-package "caddar") nil) +(deftest symbol-cadddr (test-if-not-in-cl-package "cadddr") nil) +(deftest symbol-caddr (test-if-not-in-cl-package "caddr") nil) +(deftest symbol-cadr (test-if-not-in-cl-package "cadr") nil) +(deftest symbol-call-arguments-limit (test-if-not-in-cl-package "call-arguments-limit") nil) +(deftest symbol-call-method (test-if-not-in-cl-package "call-method") nil) +(deftest symbol-call-next-method (test-if-not-in-cl-package "call-next-method") nil) +(deftest symbol-car (test-if-not-in-cl-package "car") nil) +(deftest symbol-case (test-if-not-in-cl-package "case") nil) +(deftest symbol-catch (test-if-not-in-cl-package "catch") nil) +(deftest symbol-ccase (test-if-not-in-cl-package "ccase") nil) +(deftest symbol-cdaaar (test-if-not-in-cl-package "cdaaar") nil) +(deftest symbol-cdaadr (test-if-not-in-cl-package "cdaadr") nil) +(deftest symbol-cdaar (test-if-not-in-cl-package "cdaar") nil) +(deftest symbol-cdadar (test-if-not-in-cl-package "cdadar") nil) +(deftest symbol-cdaddr (test-if-not-in-cl-package "cdaddr") nil) +(deftest symbol-cdadr (test-if-not-in-cl-package "cdadr") nil) +(deftest symbol-cdar (test-if-not-in-cl-package "cdar") nil) +(deftest symbol-cddaar (test-if-not-in-cl-package "cddaar") nil) +(deftest symbol-cddadr (test-if-not-in-cl-package "cddadr") nil) +(deftest symbol-cddar (test-if-not-in-cl-package "cddar") nil) +(deftest symbol-cdddar (test-if-not-in-cl-package "cdddar") nil) +(deftest symbol-cddddr (test-if-not-in-cl-package "cddddr") nil) +(deftest symbol-cdddr (test-if-not-in-cl-package "cdddr") nil) +(deftest symbol-cddr (test-if-not-in-cl-package "cddr") nil) +(deftest symbol-cdr (test-if-not-in-cl-package "cdr") nil) +(deftest symbol-ceiling (test-if-not-in-cl-package "ceiling") nil) +(deftest symbol-cell-error (test-if-not-in-cl-package "cell-error") nil) +(deftest symbol-cell-error-name (test-if-not-in-cl-package "cell-error-name") nil) +(deftest symbol-cerror (test-if-not-in-cl-package "cerror") nil) +(deftest symbol-change-class (test-if-not-in-cl-package "change-class") nil) +(deftest symbol-char (test-if-not-in-cl-package "char") nil) +(deftest symbol-char-code (test-if-not-in-cl-package "char-code") nil) +(deftest symbol-char-code-limit (test-if-not-in-cl-package "char-code-limit") nil) +(deftest symbol-char-downcase (test-if-not-in-cl-package "char-downcase") nil) +(deftest symbol-char-equal (test-if-not-in-cl-package "char-equal") nil) +(deftest symbol-char-greaterp (test-if-not-in-cl-package "char-greaterp") nil) +(deftest symbol-char-int (test-if-not-in-cl-package "char-int") nil) +(deftest symbol-char-lessp (test-if-not-in-cl-package "char-lessp") nil) +(deftest symbol-char-name (test-if-not-in-cl-package "char-name") nil) +(deftest symbol-char-not-equal (test-if-not-in-cl-package "char-not-equal") nil) +(deftest symbol-char-not-greaterp (test-if-not-in-cl-package "char-not-greaterp") nil) +(deftest symbol-char-not-lessp (test-if-not-in-cl-package "char-not-lessp") nil) +(deftest symbol-char-upcase (test-if-not-in-cl-package "char-upcase") nil) +(deftest symbol-char/= (test-if-not-in-cl-package "char/=") nil) +(deftest symbol-char< (test-if-not-in-cl-package "char<") nil) +(deftest symbol-char<= (test-if-not-in-cl-package "char<=") nil) +(deftest symbol-char= (test-if-not-in-cl-package "char=") nil) +(deftest symbol-char> (test-if-not-in-cl-package "char>") nil) +(deftest symbol-char>= (test-if-not-in-cl-package "char>=") nil) +(deftest symbol-character (test-if-not-in-cl-package "character") nil) +(deftest symbol-characterp (test-if-not-in-cl-package "characterp") nil) +(deftest symbol-check-type (test-if-not-in-cl-package "check-type") nil) +(deftest symbol-cis (test-if-not-in-cl-package "cis") nil) +(deftest symbol-class (test-if-not-in-cl-package "class") nil) +(deftest symbol-class-name (test-if-not-in-cl-package "class-name") nil) +(deftest symbol-class-of (test-if-not-in-cl-package "class-of") nil) +(deftest symbol-clear-input (test-if-not-in-cl-package "clear-input") nil) +(deftest symbol-clear-output (test-if-not-in-cl-package "clear-output") nil) +(deftest symbol-close (test-if-not-in-cl-package "close") nil) +(deftest symbol-clrhash (test-if-not-in-cl-package "clrhash") nil) +(deftest symbol-code-char (test-if-not-in-cl-package "code-char") nil) +(deftest symbol-coerce (test-if-not-in-cl-package "coerce") nil) +(deftest symbol-compilation-speed (test-if-not-in-cl-package "compilation-speed") nil) +(deftest symbol-compile (test-if-not-in-cl-package "compile") nil) +(deftest symbol-compile-file (test-if-not-in-cl-package "compile-file") nil) +(deftest symbol-compile-file-pathname (test-if-not-in-cl-package "compile-file-pathname") nil) +(deftest symbol-compiled-function (test-if-not-in-cl-package "compiled-function") nil) +(deftest symbol-compiled-function-p (test-if-not-in-cl-package "compiled-function-p") nil) +(deftest symbol-compiler-macro (test-if-not-in-cl-package "compiler-macro") nil) +(deftest symbol-compiler-macro-function (test-if-not-in-cl-package "compiler-macro-function") nil) +(deftest symbol-complement (test-if-not-in-cl-package "complement") nil) +(deftest symbol-complex (test-if-not-in-cl-package "complex") nil) +(deftest symbol-complexp (test-if-not-in-cl-package "complexp") nil) +(deftest symbol-compute-applicable-methods (test-if-not-in-cl-package "compute-applicable-methods") nil) +(deftest symbol-compute-restarts (test-if-not-in-cl-package "compute-restarts") nil) +(deftest symbol-concatenate (test-if-not-in-cl-package "concatenate") nil) +(deftest symbol-concatenated-stream (test-if-not-in-cl-package "concatenated-stream") nil) +(deftest symbol-concatenated-stream-streams (test-if-not-in-cl-package "concatenated-stream-streams") nil) +(deftest symbol-cond (test-if-not-in-cl-package "cond") nil) +(deftest symbol-condition (test-if-not-in-cl-package "condition") nil) +(deftest symbol-conjugate (test-if-not-in-cl-package "conjugate") nil) +(deftest symbol-cons (test-if-not-in-cl-package "cons") nil) +(deftest symbol-consp (test-if-not-in-cl-package "consp") nil) +(deftest symbol-constantly (test-if-not-in-cl-package "constantly") nil) +(deftest symbol-constantp (test-if-not-in-cl-package "constantp") nil) +(deftest symbol-continue (test-if-not-in-cl-package "continue") nil) +(deftest symbol-control-error (test-if-not-in-cl-package "control-error") nil) +(deftest symbol-copy-alist (test-if-not-in-cl-package "copy-alist") nil) +(deftest symbol-copy-list (test-if-not-in-cl-package "copy-list") nil) +(deftest symbol-copy-pprint-dispatch (test-if-not-in-cl-package "copy-pprint-dispatch") nil) +(deftest symbol-copy-readtable (test-if-not-in-cl-package "copy-readtable") nil) +(deftest symbol-copy-seq (test-if-not-in-cl-package "copy-seq") nil) +(deftest symbol-copy-structure (test-if-not-in-cl-package "copy-structure") nil) +(deftest symbol-copy-symbol (test-if-not-in-cl-package "copy-symbol") nil) +(deftest symbol-copy-tree (test-if-not-in-cl-package "copy-tree") nil) +(deftest symbol-cos (test-if-not-in-cl-package "cos") nil) +(deftest symbol-cosh (test-if-not-in-cl-package "cosh") nil) +(deftest symbol-count (test-if-not-in-cl-package "count") nil) +(deftest symbol-count-if (test-if-not-in-cl-package "count-if") nil) +(deftest symbol-count-if-not (test-if-not-in-cl-package "count-if-not") nil) +(deftest symbol-ctypecase (test-if-not-in-cl-package "ctypecase") nil) +(deftest symbol-debug (test-if-not-in-cl-package "debug") nil) +(deftest symbol-decf (test-if-not-in-cl-package "decf") nil) +(deftest symbol-declaim (test-if-not-in-cl-package "declaim") nil) +(deftest symbol-declaration (test-if-not-in-cl-package "declaration") nil) +(deftest symbol-declare (test-if-not-in-cl-package "declare") nil) +(deftest symbol-decode-float (test-if-not-in-cl-package "decode-float") nil) +(deftest symbol-decode-universal-time (test-if-not-in-cl-package "decode-universal-time") nil) +(deftest symbol-defclass (test-if-not-in-cl-package "defclass") nil) +(deftest symbol-defconstant (test-if-not-in-cl-package "defconstant") nil) +(deftest symbol-defgeneric (test-if-not-in-cl-package "defgeneric") nil) +(deftest symbol-define-compiler-macro (test-if-not-in-cl-package "define-compiler-macro") nil) +(deftest symbol-define-condition (test-if-not-in-cl-package "define-condition") nil) +(deftest symbol-define-method-combination (test-if-not-in-cl-package "define-method-combination") nil) +(deftest symbol-define-modify-macro (test-if-not-in-cl-package "define-modify-macro") nil) +(deftest symbol-define-setf-expander (test-if-not-in-cl-package "define-setf-expander") nil) +(deftest symbol-define-symbol-macro (test-if-not-in-cl-package "define-symbol-macro") nil) +(deftest symbol-defmacro (test-if-not-in-cl-package "defmacro") nil) +(deftest symbol-defmethod (test-if-not-in-cl-package "defmethod") nil) +(deftest symbol-defpackage (test-if-not-in-cl-package "defpackage") nil) +(deftest symbol-defparameter (test-if-not-in-cl-package "defparameter") nil) +(deftest symbol-defsetf (test-if-not-in-cl-package "defsetf") nil) +(deftest symbol-defstruct (test-if-not-in-cl-package "defstruct") nil) +(deftest symbol-deftype (test-if-not-in-cl-package "deftype") nil) +(deftest symbol-defun (test-if-not-in-cl-package "defun") nil) +(deftest symbol-defvar (test-if-not-in-cl-package "defvar") nil) +(deftest symbol-delete (test-if-not-in-cl-package "delete") nil) +(deftest symbol-delete-duplicates (test-if-not-in-cl-package "delete-duplicates") nil) +(deftest symbol-delete-file (test-if-not-in-cl-package "delete-file") nil) +(deftest symbol-delete-if (test-if-not-in-cl-package "delete-if") nil) +(deftest symbol-delete-if-not (test-if-not-in-cl-package "delete-if-not") nil) +(deftest symbol-delete-package (test-if-not-in-cl-package "delete-package") nil) +(deftest symbol-denominator (test-if-not-in-cl-package "denominator") nil) +(deftest symbol-deposit-field (test-if-not-in-cl-package "deposit-field") nil) +(deftest symbol-describe (test-if-not-in-cl-package "describe") nil) +(deftest symbol-describe-object (test-if-not-in-cl-package "describe-object") nil) +(deftest symbol-destructuring-bind (test-if-not-in-cl-package "destructuring-bind") nil) +(deftest symbol-digit-char (test-if-not-in-cl-package "digit-char") nil) +(deftest symbol-digit-char-p (test-if-not-in-cl-package "digit-char-p") nil) +(deftest symbol-directory (test-if-not-in-cl-package "directory") nil) +(deftest symbol-directory-namestring (test-if-not-in-cl-package "directory-namestring") nil) +(deftest symbol-disassemble (test-if-not-in-cl-package "disassemble") nil) +(deftest symbol-division-by-zero (test-if-not-in-cl-package "division-by-zero") nil) +(deftest symbol-do (test-if-not-in-cl-package "do") nil) +(deftest symbol-do* (test-if-not-in-cl-package "do*") nil) +(deftest symbol-do-all-symbols (test-if-not-in-cl-package "do-all-symbols") nil) +(deftest symbol-do-external-symbols (test-if-not-in-cl-package "do-external-symbols") nil) +(deftest symbol-do-symbols (test-if-not-in-cl-package "do-symbols") nil) +(deftest symbol-documentation (test-if-not-in-cl-package "documentation") nil) +(deftest symbol-dolist (test-if-not-in-cl-package "dolist") nil) +(deftest symbol-dotimes (test-if-not-in-cl-package "dotimes") nil) +(deftest symbol-double-float (test-if-not-in-cl-package "double-float") nil) +(deftest symbol-double-float-epsilon (test-if-not-in-cl-package "double-float-epsilon") nil) +(deftest symbol-double-float-negative-epsilon (test-if-not-in-cl-package "double-float-negative-epsilon") nil) +(deftest symbol-dpb (test-if-not-in-cl-package "dpb") nil) +(deftest symbol-dribble (test-if-not-in-cl-package "dribble") nil) +(deftest symbol-dynamic-extent (test-if-not-in-cl-package "dynamic-extent") nil) +(deftest symbol-ecase (test-if-not-in-cl-package "ecase") nil) +(deftest symbol-echo-stream (test-if-not-in-cl-package "echo-stream") nil) +(deftest symbol-echo-stream-input-stream (test-if-not-in-cl-package "echo-stream-input-stream") nil) +(deftest symbol-echo-stream-output-stream (test-if-not-in-cl-package "echo-stream-output-stream") nil) +(deftest symbol-ed (test-if-not-in-cl-package "ed") nil) +(deftest symbol-eighth (test-if-not-in-cl-package "eighth") nil) +(deftest symbol-elt (test-if-not-in-cl-package "elt") nil) +(deftest symbol-encode-universal-time (test-if-not-in-cl-package "encode-universal-time") nil) +(deftest symbol-end-of-file (test-if-not-in-cl-package "end-of-file") nil) +(deftest symbol-endp (test-if-not-in-cl-package "endp") nil) +(deftest symbol-enough-namestring (test-if-not-in-cl-package "enough-namestring") nil) +(deftest symbol-ensure-directories-exist (test-if-not-in-cl-package "ensure-directories-exist") nil) +(deftest symbol-ensure-generic-function (test-if-not-in-cl-package "ensure-generic-function") nil) +(deftest symbol-eq (test-if-not-in-cl-package "eq") nil) +(deftest symbol-eql (test-if-not-in-cl-package "eql") nil) +(deftest symbol-equal (test-if-not-in-cl-package "equal") nil) +(deftest symbol-equalp (test-if-not-in-cl-package "equalp") nil) +(deftest symbol-error (test-if-not-in-cl-package "error") nil) +(deftest symbol-etypecase (test-if-not-in-cl-package "etypecase") nil) +(deftest symbol-eval (test-if-not-in-cl-package "eval") nil) +(deftest symbol-eval-when (test-if-not-in-cl-package "eval-when") nil) +(deftest symbol-evenp (test-if-not-in-cl-package "evenp") nil) +(deftest symbol-every (test-if-not-in-cl-package "every") nil) +(deftest symbol-exp (test-if-not-in-cl-package "exp") nil) +(deftest symbol-export (test-if-not-in-cl-package "export") nil) +(deftest symbol-expt (test-if-not-in-cl-package "expt") nil) +(deftest symbol-extended-char (test-if-not-in-cl-package "extended-char") nil) +(deftest symbol-fboundp (test-if-not-in-cl-package "fboundp") nil) +(deftest symbol-fceiling (test-if-not-in-cl-package "fceiling") nil) +(deftest symbol-fdefinition (test-if-not-in-cl-package "fdefinition") nil) +(deftest symbol-ffloor (test-if-not-in-cl-package "ffloor") nil) +(deftest symbol-fifth (test-if-not-in-cl-package "fifth") nil) +(deftest symbol-file-author (test-if-not-in-cl-package "file-author") nil) +(deftest symbol-file-error (test-if-not-in-cl-package "file-error") nil) +(deftest symbol-file-error-pathname (test-if-not-in-cl-package "file-error-pathname") nil) +(deftest symbol-file-length (test-if-not-in-cl-package "file-length") nil) +(deftest symbol-file-namestring (test-if-not-in-cl-package "file-namestring") nil) +(deftest symbol-file-position (test-if-not-in-cl-package "file-position") nil) +(deftest symbol-file-stream (test-if-not-in-cl-package "file-stream") nil) +(deftest symbol-file-string-length (test-if-not-in-cl-package "file-string-length") nil) +(deftest symbol-file-write-date (test-if-not-in-cl-package "file-write-date") nil) +(deftest symbol-fill (test-if-not-in-cl-package "fill") nil) +(deftest symbol-fill-pointer (test-if-not-in-cl-package "fill-pointer") nil) +(deftest symbol-find (test-if-not-in-cl-package "find") nil) +(deftest symbol-find-all-symbols (test-if-not-in-cl-package "find-all-symbols") nil) +(deftest symbol-find-class (test-if-not-in-cl-package "find-class") nil) +(deftest symbol-find-if (test-if-not-in-cl-package "find-if") nil) +(deftest symbol-find-if-not (test-if-not-in-cl-package "find-if-not") nil) +(deftest symbol-find-method (test-if-not-in-cl-package "find-method") nil) +(deftest symbol-find-package (test-if-not-in-cl-package "find-package") nil) +(deftest symbol-find-restart (test-if-not-in-cl-package "find-restart") nil) +(deftest symbol-find-symbol (test-if-not-in-cl-package "find-symbol") nil) +(deftest symbol-finish-output (test-if-not-in-cl-package "finish-output") nil) +(deftest symbol-first (test-if-not-in-cl-package "first") nil) +(deftest symbol-fixnum (test-if-not-in-cl-package "fixnum") nil) +(deftest symbol-flet (test-if-not-in-cl-package "flet") nil) +(deftest symbol-float (test-if-not-in-cl-package "float") nil) +(deftest symbol-float-digits (test-if-not-in-cl-package "float-digits") nil) +(deftest symbol-float-precision (test-if-not-in-cl-package "float-precision") nil) +(deftest symbol-float-radix (test-if-not-in-cl-package "float-radix") nil) +(deftest symbol-float-sign (test-if-not-in-cl-package "float-sign") nil) +(deftest symbol-floating-point-inexact (test-if-not-in-cl-package "floating-point-inexact") nil) +(deftest symbol-floating-point-invalid-operation (test-if-not-in-cl-package "floating-point-invalid-operation") nil) +(deftest symbol-floating-point-overflow (test-if-not-in-cl-package "floating-point-overflow") nil) +(deftest symbol-floating-point-underflow (test-if-not-in-cl-package "floating-point-underflow") nil) +(deftest symbol-floatp (test-if-not-in-cl-package "floatp") nil) +(deftest symbol-floor (test-if-not-in-cl-package "floor") nil) +(deftest symbol-fmakunbound (test-if-not-in-cl-package "fmakunbound") nil) +(deftest symbol-force-output (test-if-not-in-cl-package "force-output") nil) +(deftest symbol-format (test-if-not-in-cl-package "format") nil) +(deftest symbol-formatter (test-if-not-in-cl-package "formatter") nil) +(deftest symbol-fourth (test-if-not-in-cl-package "fourth") nil) +(deftest symbol-fresh-line (test-if-not-in-cl-package "fresh-line") nil) +(deftest symbol-fround (test-if-not-in-cl-package "fround") nil) +(deftest symbol-ftruncate (test-if-not-in-cl-package "ftruncate") nil) +(deftest symbol-ftype (test-if-not-in-cl-package "ftype") nil) +(deftest symbol-funcall (test-if-not-in-cl-package "funcall") nil) +(deftest symbol-function (test-if-not-in-cl-package "function") nil) +(deftest symbol-function-keywords (test-if-not-in-cl-package "function-keywords") nil) +(deftest symbol-function-lambda-expression (test-if-not-in-cl-package "function-lambda-expression") nil) +(deftest symbol-functionp (test-if-not-in-cl-package "functionp") nil) +(deftest symbol-gcd (test-if-not-in-cl-package "gcd") nil) +(deftest symbol-generic-function (test-if-not-in-cl-package "generic-function") nil) +(deftest symbol-gensym (test-if-not-in-cl-package "gensym") nil) +(deftest symbol-gentemp (test-if-not-in-cl-package "gentemp") nil) +(deftest symbol-get (test-if-not-in-cl-package "get") nil) +(deftest symbol-get-decoded-time (test-if-not-in-cl-package "get-decoded-time") nil) +(deftest symbol-get-dispatch-macro-character (test-if-not-in-cl-package "get-dispatch-macro-character") nil) +(deftest symbol-get-internal-real-time (test-if-not-in-cl-package "get-internal-real-time") nil) +(deftest symbol-get-internal-run-time (test-if-not-in-cl-package "get-internal-run-time") nil) +(deftest symbol-get-macro-character (test-if-not-in-cl-package "get-macro-character") nil) +(deftest symbol-get-output-stream-string (test-if-not-in-cl-package "get-output-stream-string") nil) +(deftest symbol-get-properties (test-if-not-in-cl-package "get-properties") nil) +(deftest symbol-get-setf-expansion (test-if-not-in-cl-package "get-setf-expansion") nil) +(deftest symbol-get-universal-time (test-if-not-in-cl-package "get-universal-time") nil) +(deftest symbol-getf (test-if-not-in-cl-package "getf") nil) +(deftest symbol-gethash (test-if-not-in-cl-package "gethash") nil) +(deftest symbol-go (test-if-not-in-cl-package "go") nil) +(deftest symbol-graphic-char-p (test-if-not-in-cl-package "graphic-char-p") nil) +(deftest symbol-handler-bind (test-if-not-in-cl-package "handler-bind") nil) +(deftest symbol-handler-case (test-if-not-in-cl-package "handler-case") nil) +(deftest symbol-hash-table (test-if-not-in-cl-package "hash-table") nil) +(deftest symbol-hash-table-count (test-if-not-in-cl-package "hash-table-count") nil) +(deftest symbol-hash-table-p (test-if-not-in-cl-package "hash-table-p") nil) +(deftest symbol-hash-table-rehash-size (test-if-not-in-cl-package "hash-table-rehash-size") nil) +(deftest symbol-hash-table-rehash-threshold (test-if-not-in-cl-package "hash-table-rehash-threshold") nil) +(deftest symbol-hash-table-size (test-if-not-in-cl-package "hash-table-size") nil) +(deftest symbol-hash-table-test (test-if-not-in-cl-package "hash-table-test") nil) +(deftest symbol-host-namestring (test-if-not-in-cl-package "host-namestring") nil) +(deftest symbol-identity (test-if-not-in-cl-package "identity") nil) +(deftest symbol-if (test-if-not-in-cl-package "if") nil) +(deftest symbol-ignorable (test-if-not-in-cl-package "ignorable") nil) +(deftest symbol-ignore (test-if-not-in-cl-package "ignore") nil) +(deftest symbol-ignore-errors (test-if-not-in-cl-package "ignore-errors") nil) +(deftest symbol-imagpart (test-if-not-in-cl-package "imagpart") nil) +(deftest symbol-import (test-if-not-in-cl-package "import") nil) +(deftest symbol-in-package (test-if-not-in-cl-package "in-package") nil) +(deftest symbol-incf (test-if-not-in-cl-package "incf") nil) +(deftest symbol-initialize-instance (test-if-not-in-cl-package "initialize-instance") nil) +(deftest symbol-inline (test-if-not-in-cl-package "inline") nil) +(deftest symbol-input-stream-p (test-if-not-in-cl-package "input-stream-p") nil) +(deftest symbol-inspect (test-if-not-in-cl-package "inspect") nil) +(deftest symbol-integer (test-if-not-in-cl-package "integer") nil) +(deftest symbol-integer-decode-float (test-if-not-in-cl-package "integer-decode-float") nil) +(deftest symbol-integer-length (test-if-not-in-cl-package "integer-length") nil) +(deftest symbol-integerp (test-if-not-in-cl-package "integerp") nil) +(deftest symbol-interactive-stream-p (test-if-not-in-cl-package "interactive-stream-p") nil) +(deftest symbol-intern (test-if-not-in-cl-package "intern") nil) +(deftest symbol-internal-time-units-per-second (test-if-not-in-cl-package "internal-time-units-per-second") nil) +(deftest symbol-intersection (test-if-not-in-cl-package "intersection") nil) +(deftest symbol-invalid-method-error (test-if-not-in-cl-package "invalid-method-error") nil) +(deftest symbol-invoke-debugger (test-if-not-in-cl-package "invoke-debugger") nil) +(deftest symbol-invoke-restart (test-if-not-in-cl-package "invoke-restart") nil) +(deftest symbol-invoke-restart-interactively (test-if-not-in-cl-package "invoke-restart-interactively") nil) +(deftest symbol-isqrt (test-if-not-in-cl-package "isqrt") nil) +(deftest symbol-keyword (test-if-not-in-cl-package "keyword") nil) +(deftest symbol-keywordp (test-if-not-in-cl-package "keywordp") nil) +(deftest symbol-labels (test-if-not-in-cl-package "labels") nil) +(deftest symbol-lambda (test-if-not-in-cl-package "lambda") nil) +(deftest symbol-lambda-list-keywords (test-if-not-in-cl-package "lambda-list-keywords") nil) +(deftest symbol-lambda-parameters-limit (test-if-not-in-cl-package "lambda-parameters-limit") nil) +(deftest symbol-last (test-if-not-in-cl-package "last") nil) +(deftest symbol-lcm (test-if-not-in-cl-package "lcm") nil) +(deftest symbol-ldb (test-if-not-in-cl-package "ldb") nil) +(deftest symbol-ldb-test (test-if-not-in-cl-package "ldb-test") nil) +(deftest symbol-ldiff (test-if-not-in-cl-package "ldiff") nil) +(deftest symbol-least-negative-double-float (test-if-not-in-cl-package "least-negative-double-float") nil) +(deftest symbol-least-negative-long-float (test-if-not-in-cl-package "least-negative-long-float") nil) +(deftest symbol-least-negative-normalized-double-float (test-if-not-in-cl-package "least-negative-normalized-double-float") nil) +(deftest symbol-least-negative-normalized-long-float (test-if-not-in-cl-package "least-negative-normalized-long-float") nil) +(deftest symbol-least-negative-normalized-short-float (test-if-not-in-cl-package "least-negative-normalized-short-float") nil) +(deftest symbol-least-negative-normalized-single-float (test-if-not-in-cl-package "least-negative-normalized-single-float") nil) +(deftest symbol-least-negative-short-float (test-if-not-in-cl-package "least-negative-short-float") nil) +(deftest symbol-least-negative-single-float (test-if-not-in-cl-package "least-negative-single-float") nil) +(deftest symbol-least-positive-double-float (test-if-not-in-cl-package "least-positive-double-float") nil) +(deftest symbol-least-positive-long-float (test-if-not-in-cl-package "least-positive-long-float") nil) +(deftest symbol-least-positive-normalized-double-float (test-if-not-in-cl-package "least-positive-normalized-double-float") nil) +(deftest symbol-least-positive-normalized-long-float (test-if-not-in-cl-package "least-positive-normalized-long-float") nil) +(deftest symbol-least-positive-normalized-short-float (test-if-not-in-cl-package "least-positive-normalized-short-float") nil) +(deftest symbol-least-positive-normalized-single-float (test-if-not-in-cl-package "least-positive-normalized-single-float") nil) +(deftest symbol-least-positive-short-float (test-if-not-in-cl-package "least-positive-short-float") nil) +(deftest symbol-least-positive-single-float (test-if-not-in-cl-package "least-positive-single-float") nil) +(deftest symbol-length (test-if-not-in-cl-package "length") nil) +(deftest symbol-let (test-if-not-in-cl-package "let") nil) +(deftest symbol-let* (test-if-not-in-cl-package "let*") nil) +(deftest symbol-lisp-implementation-type (test-if-not-in-cl-package "lisp-implementation-type") nil) +(deftest symbol-lisp-implementation-version (test-if-not-in-cl-package "lisp-implementation-version") nil) +(deftest symbol-list (test-if-not-in-cl-package "list") nil) +(deftest symbol-list* (test-if-not-in-cl-package "list*") nil) +(deftest symbol-list-all-packages (test-if-not-in-cl-package "list-all-packages") nil) +(deftest symbol-list-length (test-if-not-in-cl-package "list-length") nil) +(deftest symbol-listen (test-if-not-in-cl-package "listen") nil) +(deftest symbol-listp (test-if-not-in-cl-package "listp") nil) +(deftest symbol-load (test-if-not-in-cl-package "load") nil) +(deftest symbol-load-logical-pathname-translations (test-if-not-in-cl-package "load-logical-pathname-translations") nil) +(deftest symbol-load-time-value (test-if-not-in-cl-package "load-time-value") nil) +(deftest symbol-locally (test-if-not-in-cl-package "locally") nil) +(deftest symbol-log (test-if-not-in-cl-package "log") nil) +(deftest symbol-logand (test-if-not-in-cl-package "logand") nil) +(deftest symbol-logandc1 (test-if-not-in-cl-package "logandc1") nil) +(deftest symbol-logandc2 (test-if-not-in-cl-package "logandc2") nil) +(deftest symbol-logbitp (test-if-not-in-cl-package "logbitp") nil) +(deftest symbol-logcount (test-if-not-in-cl-package "logcount") nil) +(deftest symbol-logeqv (test-if-not-in-cl-package "logeqv") nil) +(deftest symbol-logical-pathname (test-if-not-in-cl-package "logical-pathname") nil) +(deftest symbol-logical-pathname-translations (test-if-not-in-cl-package "logical-pathname-translations") nil) +(deftest symbol-logior (test-if-not-in-cl-package "logior") nil) +(deftest symbol-lognand (test-if-not-in-cl-package "lognand") nil) +(deftest symbol-lognor (test-if-not-in-cl-package "lognor") nil) +(deftest symbol-lognot (test-if-not-in-cl-package "lognot") nil) +(deftest symbol-logorc1 (test-if-not-in-cl-package "logorc1") nil) +(deftest symbol-logorc2 (test-if-not-in-cl-package "logorc2") nil) +(deftest symbol-logtest (test-if-not-in-cl-package "logtest") nil) +(deftest symbol-logxor (test-if-not-in-cl-package "logxor") nil) +(deftest symbol-long-float (test-if-not-in-cl-package "long-float") nil) +(deftest symbol-long-float-epsilon (test-if-not-in-cl-package "long-float-epsilon") nil) +(deftest symbol-long-float-negative-epsilon (test-if-not-in-cl-package "long-float-negative-epsilon") nil) +(deftest symbol-long-site-name (test-if-not-in-cl-package "long-site-name") nil) +(deftest symbol-loop (test-if-not-in-cl-package "loop") nil) +(deftest symbol-loop-finish (test-if-not-in-cl-package "loop-finish") nil) +(deftest symbol-lower-case-p (test-if-not-in-cl-package "lower-case-p") nil) +(deftest symbol-machine-instance (test-if-not-in-cl-package "machine-instance") nil) +(deftest symbol-machine-type (test-if-not-in-cl-package "machine-type") nil) +(deftest symbol-machine-version (test-if-not-in-cl-package "machine-version") nil) +(deftest symbol-macro-function (test-if-not-in-cl-package "macro-function") nil) +(deftest symbol-macroexpand (test-if-not-in-cl-package "macroexpand") nil) +(deftest symbol-macroexpand-1 (test-if-not-in-cl-package "macroexpand-1") nil) +(deftest symbol-macrolet (test-if-not-in-cl-package "macrolet") nil) +(deftest symbol-make-array (test-if-not-in-cl-package "make-array") nil) +(deftest symbol-make-broadcast-stream (test-if-not-in-cl-package "make-broadcast-stream") nil) +(deftest symbol-make-concatenated-stream (test-if-not-in-cl-package "make-concatenated-stream") nil) +(deftest symbol-make-condition (test-if-not-in-cl-package "make-condition") nil) +(deftest symbol-make-dispatch-macro-character (test-if-not-in-cl-package "make-dispatch-macro-character") nil) +(deftest symbol-make-echo-stream (test-if-not-in-cl-package "make-echo-stream") nil) +(deftest symbol-make-hash-table (test-if-not-in-cl-package "make-hash-table") nil) +(deftest symbol-make-instance (test-if-not-in-cl-package "make-instance") nil) +(deftest symbol-make-instances-obsolete (test-if-not-in-cl-package "make-instances-obsolete") nil) +(deftest symbol-make-list (test-if-not-in-cl-package "make-list") nil) +(deftest symbol-make-load-form (test-if-not-in-cl-package "make-load-form") nil) +(deftest symbol-make-load-form-saving-slots (test-if-not-in-cl-package "make-load-form-saving-slots") nil) +(deftest symbol-make-method (test-if-not-in-cl-package "make-method") nil) +(deftest symbol-make-package (test-if-not-in-cl-package "make-package") nil) +(deftest symbol-make-pathname (test-if-not-in-cl-package "make-pathname") nil) +(deftest symbol-make-random-state (test-if-not-in-cl-package "make-random-state") nil) +(deftest symbol-make-sequence (test-if-not-in-cl-package "make-sequence") nil) +(deftest symbol-make-string (test-if-not-in-cl-package "make-string") nil) +(deftest symbol-make-string-input-stream (test-if-not-in-cl-package "make-string-input-stream") nil) +(deftest symbol-make-string-output-stream (test-if-not-in-cl-package "make-string-output-stream") nil) +(deftest symbol-make-symbol (test-if-not-in-cl-package "make-symbol") nil) +(deftest symbol-make-synonym-stream (test-if-not-in-cl-package "make-synonym-stream") nil) +(deftest symbol-make-two-way-stream (test-if-not-in-cl-package "make-two-way-stream") nil) +(deftest symbol-makunbound (test-if-not-in-cl-package "makunbound") nil) +(deftest symbol-map (test-if-not-in-cl-package "map") nil) +(deftest symbol-map-into (test-if-not-in-cl-package "map-into") nil) +(deftest symbol-mapc (test-if-not-in-cl-package "mapc") nil) +(deftest symbol-mapcan (test-if-not-in-cl-package "mapcan") nil) +(deftest symbol-mapcar (test-if-not-in-cl-package "mapcar") nil) +(deftest symbol-mapcon (test-if-not-in-cl-package "mapcon") nil) +(deftest symbol-maphash (test-if-not-in-cl-package "maphash") nil) +(deftest symbol-mapl (test-if-not-in-cl-package "mapl") nil) +(deftest symbol-maplist (test-if-not-in-cl-package "maplist") nil) +(deftest symbol-mask-field (test-if-not-in-cl-package "mask-field") nil) +(deftest symbol-max (test-if-not-in-cl-package "max") nil) +(deftest symbol-member (test-if-not-in-cl-package "member") nil) +(deftest symbol-member-if (test-if-not-in-cl-package "member-if") nil) +(deftest symbol-member-if-not (test-if-not-in-cl-package "member-if-not") nil) +(deftest symbol-merge (test-if-not-in-cl-package "merge") nil) +(deftest symbol-merge-pathnames (test-if-not-in-cl-package "merge-pathnames") nil) +(deftest symbol-method (test-if-not-in-cl-package "method") nil) +(deftest symbol-method-combination (test-if-not-in-cl-package "method-combination") nil) +(deftest symbol-method-combination-error (test-if-not-in-cl-package "method-combination-error") nil) +(deftest symbol-method-qualifiers (test-if-not-in-cl-package "method-qualifiers") nil) +(deftest symbol-min (test-if-not-in-cl-package "min") nil) +(deftest symbol-minusp (test-if-not-in-cl-package "minusp") nil) +(deftest symbol-mismatch (test-if-not-in-cl-package "mismatch") nil) +(deftest symbol-mod (test-if-not-in-cl-package "mod") nil) +(deftest symbol-most-negative-double-float (test-if-not-in-cl-package "most-negative-double-float") nil) +(deftest symbol-most-negative-fixnum (test-if-not-in-cl-package "most-negative-fixnum") nil) +(deftest symbol-most-negative-long-float (test-if-not-in-cl-package "most-negative-long-float") nil) +(deftest symbol-most-negative-short-float (test-if-not-in-cl-package "most-negative-short-float") nil) +(deftest symbol-most-negative-single-float (test-if-not-in-cl-package "most-negative-single-float") nil) +(deftest symbol-most-positive-double-float (test-if-not-in-cl-package "most-positive-double-float") nil) +(deftest symbol-most-positive-fixnum (test-if-not-in-cl-package "most-positive-fixnum") nil) +(deftest symbol-most-positive-long-float (test-if-not-in-cl-package "most-positive-long-float") nil) +(deftest symbol-most-positive-short-float (test-if-not-in-cl-package "most-positive-short-float") nil) +(deftest symbol-most-positive-single-float (test-if-not-in-cl-package "most-positive-single-float") nil) +(deftest symbol-muffle-warning (test-if-not-in-cl-package "muffle-warning") nil) +(deftest symbol-multiple-value-bind (test-if-not-in-cl-package "multiple-value-bind") nil) +(deftest symbol-multiple-value-call (test-if-not-in-cl-package "multiple-value-call") nil) +(deftest symbol-multiple-value-list (test-if-not-in-cl-package "multiple-value-list") nil) +(deftest symbol-multiple-value-prog1 (test-if-not-in-cl-package "multiple-value-prog1") nil) +(deftest symbol-multiple-value-setq (test-if-not-in-cl-package "multiple-value-setq") nil) +(deftest symbol-multiple-values-limit (test-if-not-in-cl-package "multiple-values-limit") nil) +(deftest symbol-name-char (test-if-not-in-cl-package "name-char") nil) +(deftest symbol-namestring (test-if-not-in-cl-package "namestring") nil) +(deftest symbol-nbutlast (test-if-not-in-cl-package "nbutlast") nil) +(deftest symbol-nconc (test-if-not-in-cl-package "nconc") nil) +(deftest symbol-next-method-p (test-if-not-in-cl-package "next-method-p") nil) +(deftest symbol-nil (test-if-not-in-cl-package "nil") nil) +(deftest symbol-nintersection (test-if-not-in-cl-package "nintersection") nil) +(deftest symbol-ninth (test-if-not-in-cl-package "ninth") nil) +(deftest symbol-no-applicable-method (test-if-not-in-cl-package "no-applicable-method") nil) +(deftest symbol-no-next-method (test-if-not-in-cl-package "no-next-method") nil) +(deftest symbol-not (test-if-not-in-cl-package "not") nil) +(deftest symbol-notany (test-if-not-in-cl-package "notany") nil) +(deftest symbol-notevery (test-if-not-in-cl-package "notevery") nil) +(deftest symbol-notinline (test-if-not-in-cl-package "notinline") nil) +(deftest symbol-nreconc (test-if-not-in-cl-package "nreconc") nil) +(deftest symbol-nreverse (test-if-not-in-cl-package "nreverse") nil) +(deftest symbol-nset-difference (test-if-not-in-cl-package "nset-difference") nil) +(deftest symbol-nset-exclusive-or (test-if-not-in-cl-package "nset-exclusive-or") nil) +(deftest symbol-nstring-capitalize (test-if-not-in-cl-package "nstring-capitalize") nil) +(deftest symbol-nstring-downcase (test-if-not-in-cl-package "nstring-downcase") nil) +(deftest symbol-nstring-upcase (test-if-not-in-cl-package "nstring-upcase") nil) +(deftest symbol-nsublis (test-if-not-in-cl-package "nsublis") nil) +(deftest symbol-nsubst (test-if-not-in-cl-package "nsubst") nil) +(deftest symbol-nsubst-if (test-if-not-in-cl-package "nsubst-if") nil) +(deftest symbol-nsubst-if-not (test-if-not-in-cl-package "nsubst-if-not") nil) +(deftest symbol-nsubstitute (test-if-not-in-cl-package "nsubstitute") nil) +(deftest symbol-nsubstitute-if (test-if-not-in-cl-package "nsubstitute-if") nil) +(deftest symbol-nsubstitute-if-not (test-if-not-in-cl-package "nsubstitute-if-not") nil) +(deftest symbol-nth (test-if-not-in-cl-package "nth") nil) +(deftest symbol-nth-value (test-if-not-in-cl-package "nth-value") nil) +(deftest symbol-nthcdr (test-if-not-in-cl-package "nthcdr") nil) +(deftest symbol-null (test-if-not-in-cl-package "null") nil) +(deftest symbol-number (test-if-not-in-cl-package "number") nil) +(deftest symbol-numberp (test-if-not-in-cl-package "numberp") nil) +(deftest symbol-numerator (test-if-not-in-cl-package "numerator") nil) +(deftest symbol-nunion (test-if-not-in-cl-package "nunion") nil) +(deftest symbol-oddp (test-if-not-in-cl-package "oddp") nil) +(deftest symbol-open (test-if-not-in-cl-package "open") nil) +(deftest symbol-open-stream-p (test-if-not-in-cl-package "open-stream-p") nil) +(deftest symbol-optimize (test-if-not-in-cl-package "optimize") nil) +(deftest symbol-or (test-if-not-in-cl-package "or") nil) +(deftest symbol-otherwise (test-if-not-in-cl-package "otherwise") nil) +(deftest symbol-output-stream-p (test-if-not-in-cl-package "output-stream-p") nil) +(deftest symbol-package (test-if-not-in-cl-package "package") nil) +(deftest symbol-package-error (test-if-not-in-cl-package "package-error") nil) +(deftest symbol-package-error-package (test-if-not-in-cl-package "package-error-package") nil) +(deftest symbol-package-name (test-if-not-in-cl-package "package-name") nil) +(deftest symbol-package-nicknames (test-if-not-in-cl-package "package-nicknames") nil) +(deftest symbol-package-shadowing-symbols (test-if-not-in-cl-package "package-shadowing-symbols") nil) +(deftest symbol-package-use-list (test-if-not-in-cl-package "package-use-list") nil) +(deftest symbol-package-used-by-list (test-if-not-in-cl-package "package-used-by-list") nil) +(deftest symbol-packagep (test-if-not-in-cl-package "packagep") nil) +(deftest symbol-pairlis (test-if-not-in-cl-package "pairlis") nil) +(deftest symbol-parse-error (test-if-not-in-cl-package "parse-error") nil) +(deftest symbol-parse-integer (test-if-not-in-cl-package "parse-integer") nil) +(deftest symbol-parse-namestring (test-if-not-in-cl-package "parse-namestring") nil) +(deftest symbol-pathname (test-if-not-in-cl-package "pathname") nil) +(deftest symbol-pathname-device (test-if-not-in-cl-package "pathname-device") nil) +(deftest symbol-pathname-directory (test-if-not-in-cl-package "pathname-directory") nil) +(deftest symbol-pathname-host (test-if-not-in-cl-package "pathname-host") nil) +(deftest symbol-pathname-match-p (test-if-not-in-cl-package "pathname-match-p") nil) +(deftest symbol-pathname-name (test-if-not-in-cl-package "pathname-name") nil) +(deftest symbol-pathname-type (test-if-not-in-cl-package "pathname-type") nil) +(deftest symbol-pathname-version (test-if-not-in-cl-package "pathname-version") nil) +(deftest symbol-pathnamep (test-if-not-in-cl-package "pathnamep") nil) +(deftest symbol-peek-char (test-if-not-in-cl-package "peek-char") nil) +(deftest symbol-phase (test-if-not-in-cl-package "phase") nil) +(deftest symbol-pi (test-if-not-in-cl-package "pi") nil) +(deftest symbol-plusp (test-if-not-in-cl-package "plusp") nil) +(deftest symbol-pop (test-if-not-in-cl-package "pop") nil) +(deftest symbol-position (test-if-not-in-cl-package "position") nil) +(deftest symbol-position-if (test-if-not-in-cl-package "position-if") nil) +(deftest symbol-position-if-not (test-if-not-in-cl-package "position-if-not") nil) +(deftest symbol-pprint (test-if-not-in-cl-package "pprint") nil) +(deftest symbol-pprint-dispatch (test-if-not-in-cl-package "pprint-dispatch") nil) +(deftest symbol-pprint-exit-if-list-exhausted (test-if-not-in-cl-package "pprint-exit-if-list-exhausted") nil) +(deftest symbol-pprint-fill (test-if-not-in-cl-package "pprint-fill") nil) +(deftest symbol-pprint-indent (test-if-not-in-cl-package "pprint-indent") nil) +(deftest symbol-pprint-linear (test-if-not-in-cl-package "pprint-linear") nil) +(deftest symbol-pprint-logical-block (test-if-not-in-cl-package "pprint-logical-block") nil) +(deftest symbol-pprint-newline (test-if-not-in-cl-package "pprint-newline") nil) +(deftest symbol-pprint-pop (test-if-not-in-cl-package "pprint-pop") nil) +(deftest symbol-pprint-tab (test-if-not-in-cl-package "pprint-tab") nil) +(deftest symbol-pprint-tabular (test-if-not-in-cl-package "pprint-tabular") nil) +(deftest symbol-prin1 (test-if-not-in-cl-package "prin1") nil) +(deftest symbol-prin1-to-string (test-if-not-in-cl-package "prin1-to-string") nil) +(deftest symbol-princ (test-if-not-in-cl-package "princ") nil) +(deftest symbol-princ-to-string (test-if-not-in-cl-package "princ-to-string") nil) +(deftest symbol-print (test-if-not-in-cl-package "print") nil) +(deftest symbol-print-not-readable (test-if-not-in-cl-package "print-not-readable") nil) +(deftest symbol-print-not-readable-object (test-if-not-in-cl-package "print-not-readable-object") nil) +(deftest symbol-print-object (test-if-not-in-cl-package "print-object") nil) +(deftest symbol-print-unreadable-object (test-if-not-in-cl-package "print-unreadable-object") nil) +(deftest symbol-probe-file (test-if-not-in-cl-package "probe-file") nil) +(deftest symbol-proclaim (test-if-not-in-cl-package "proclaim") nil) +(deftest symbol-prog (test-if-not-in-cl-package "prog") nil) +(deftest symbol-prog* (test-if-not-in-cl-package "prog*") nil) +(deftest symbol-prog1 (test-if-not-in-cl-package "prog1") nil) +(deftest symbol-prog2 (test-if-not-in-cl-package "prog2") nil) +(deftest symbol-progn (test-if-not-in-cl-package "progn") nil) +(deftest symbol-program-error (test-if-not-in-cl-package "program-error") nil) +(deftest symbol-progv (test-if-not-in-cl-package "progv") nil) +(deftest symbol-provide (test-if-not-in-cl-package "provide") nil) +(deftest symbol-psetf (test-if-not-in-cl-package "psetf") nil) +(deftest symbol-psetq (test-if-not-in-cl-package "psetq") nil) +(deftest symbol-push (test-if-not-in-cl-package "push") nil) +(deftest symbol-pushnew (test-if-not-in-cl-package "pushnew") nil) +(deftest symbol-quote (test-if-not-in-cl-package "quote") nil) +(deftest symbol-random (test-if-not-in-cl-package "random") nil) +(deftest symbol-random-state (test-if-not-in-cl-package "random-state") nil) +(deftest symbol-random-state-p (test-if-not-in-cl-package "random-state-p") nil) +(deftest symbol-rassoc (test-if-not-in-cl-package "rassoc") nil) +(deftest symbol-rassoc-if (test-if-not-in-cl-package "rassoc-if") nil) +(deftest symbol-rassoc-if-not (test-if-not-in-cl-package "rassoc-if-not") nil) +(deftest symbol-ratio (test-if-not-in-cl-package "ratio") nil) +(deftest symbol-rational (test-if-not-in-cl-package "rational") nil) +(deftest symbol-rationalize (test-if-not-in-cl-package "rationalize") nil) +(deftest symbol-rationalp (test-if-not-in-cl-package "rationalp") nil) +(deftest symbol-read (test-if-not-in-cl-package "read") nil) +(deftest symbol-read-byte (test-if-not-in-cl-package "read-byte") nil) +(deftest symbol-read-char (test-if-not-in-cl-package "read-char") nil) +(deftest symbol-read-char-no-hang (test-if-not-in-cl-package "read-char-no-hang") nil) +(deftest symbol-read-delimited-list (test-if-not-in-cl-package "read-delimited-list") nil) +(deftest symbol-read-from-string (test-if-not-in-cl-package "read-from-string") nil) +(deftest symbol-read-line (test-if-not-in-cl-package "read-line") nil) +(deftest symbol-read-preserving-whitespace (test-if-not-in-cl-package "read-preserving-whitespace") nil) +(deftest symbol-read-sequence (test-if-not-in-cl-package "read-sequence") nil) +(deftest symbol-reader-error (test-if-not-in-cl-package "reader-error") nil) +(deftest symbol-readtable (test-if-not-in-cl-package "readtable") nil) +(deftest symbol-readtable-case (test-if-not-in-cl-package "readtable-case") nil) +(deftest symbol-readtablep (test-if-not-in-cl-package "readtablep") nil) +(deftest symbol-real (test-if-not-in-cl-package "real") nil) +(deftest symbol-realp (test-if-not-in-cl-package "realp") nil) +(deftest symbol-realpart (test-if-not-in-cl-package "realpart") nil) +(deftest symbol-reduce (test-if-not-in-cl-package "reduce") nil) +(deftest symbol-reinitialize-instance (test-if-not-in-cl-package "reinitialize-instance") nil) +(deftest symbol-rem (test-if-not-in-cl-package "rem") nil) +(deftest symbol-remf (test-if-not-in-cl-package "remf") nil) +(deftest symbol-remhash (test-if-not-in-cl-package "remhash") nil) +(deftest symbol-remove (test-if-not-in-cl-package "remove") nil) +(deftest symbol-remove-duplicates (test-if-not-in-cl-package "remove-duplicates") nil) +(deftest symbol-remove-if (test-if-not-in-cl-package "remove-if") nil) +(deftest symbol-remove-if-not (test-if-not-in-cl-package "remove-if-not") nil) +(deftest symbol-remove-method (test-if-not-in-cl-package "remove-method") nil) +(deftest symbol-remprop (test-if-not-in-cl-package "remprop") nil) +(deftest symbol-rename-file (test-if-not-in-cl-package "rename-file") nil) +(deftest symbol-rename-package (test-if-not-in-cl-package "rename-package") nil) +(deftest symbol-replace (test-if-not-in-cl-package "replace") nil) +(deftest symbol-require (test-if-not-in-cl-package "require") nil) +(deftest symbol-rest (test-if-not-in-cl-package "rest") nil) +(deftest symbol-restart (test-if-not-in-cl-package "restart") nil) +(deftest symbol-restart-bind (test-if-not-in-cl-package "restart-bind") nil) +(deftest symbol-restart-case (test-if-not-in-cl-package "restart-case") nil) +(deftest symbol-restart-name (test-if-not-in-cl-package "restart-name") nil) +(deftest symbol-return (test-if-not-in-cl-package "return") nil) +(deftest symbol-return-from (test-if-not-in-cl-package "return-from") nil) +(deftest symbol-revappend (test-if-not-in-cl-package "revappend") nil) +(deftest symbol-reverse (test-if-not-in-cl-package "reverse") nil) +(deftest symbol-room (test-if-not-in-cl-package "room") nil) +(deftest symbol-rotatef (test-if-not-in-cl-package "rotatef") nil) +(deftest symbol-round (test-if-not-in-cl-package "round") nil) +(deftest symbol-row-major-aref (test-if-not-in-cl-package "row-major-aref") nil) +(deftest symbol-rplaca (test-if-not-in-cl-package "rplaca") nil) +(deftest symbol-rplacd (test-if-not-in-cl-package "rplacd") nil) +(deftest symbol-safety (test-if-not-in-cl-package "safety") nil) +(deftest symbol-satisfies (test-if-not-in-cl-package "satisfies") nil) +(deftest symbol-sbit (test-if-not-in-cl-package "sbit") nil) +(deftest symbol-scale-float (test-if-not-in-cl-package "scale-float") nil) +(deftest symbol-schar (test-if-not-in-cl-package "schar") nil) +(deftest symbol-search (test-if-not-in-cl-package "search") nil) +(deftest symbol-second (test-if-not-in-cl-package "second") nil) +(deftest symbol-sequence (test-if-not-in-cl-package "sequence") nil) +(deftest symbol-serious-condition (test-if-not-in-cl-package "serious-condition") nil) +(deftest symbol-set (test-if-not-in-cl-package "set") nil) +(deftest symbol-set-difference (test-if-not-in-cl-package "set-difference") nil) +(deftest symbol-set-dispatch-macro-character (test-if-not-in-cl-package "set-dispatch-macro-character") nil) +(deftest symbol-set-exclusive-or (test-if-not-in-cl-package "set-exclusive-or") nil) +(deftest symbol-set-macro-character (test-if-not-in-cl-package "set-macro-character") nil) +(deftest symbol-set-pprint-dispatch (test-if-not-in-cl-package "set-pprint-dispatch") nil) +(deftest symbol-set-syntax-from-char (test-if-not-in-cl-package "set-syntax-from-char") nil) +(deftest symbol-setf (test-if-not-in-cl-package "setf") nil) +(deftest symbol-setq (test-if-not-in-cl-package "setq") nil) +(deftest symbol-seventh (test-if-not-in-cl-package "seventh") nil) +(deftest symbol-shadow (test-if-not-in-cl-package "shadow") nil) +(deftest symbol-shadowing-import (test-if-not-in-cl-package "shadowing-import") nil) +(deftest symbol-shared-initialize (test-if-not-in-cl-package "shared-initialize") nil) +(deftest symbol-shiftf (test-if-not-in-cl-package "shiftf") nil) +(deftest symbol-short-float (test-if-not-in-cl-package "short-float") nil) +(deftest symbol-short-float-epsilon (test-if-not-in-cl-package "short-float-epsilon") nil) +(deftest symbol-short-float-negative-epsilon (test-if-not-in-cl-package "short-float-negative-epsilon") nil) +(deftest symbol-short-site-name (test-if-not-in-cl-package "short-site-name") nil) +(deftest symbol-signal (test-if-not-in-cl-package "signal") nil) +(deftest symbol-signed-byte (test-if-not-in-cl-package "signed-byte") nil) +(deftest symbol-signum (test-if-not-in-cl-package "signum") nil) +(deftest symbol-simple-array (test-if-not-in-cl-package "simple-array") nil) +(deftest symbol-simple-base-string (test-if-not-in-cl-package "simple-base-string") nil) +(deftest symbol-simple-bit-vector (test-if-not-in-cl-package "simple-bit-vector") nil) +(deftest symbol-simple-bit-vector-p (test-if-not-in-cl-package "simple-bit-vector-p") nil) +(deftest symbol-simple-condition (test-if-not-in-cl-package "simple-condition") nil) +(deftest symbol-simple-condition-format-arguments (test-if-not-in-cl-package "simple-condition-format-arguments") nil) +(deftest symbol-simple-condition-format-control (test-if-not-in-cl-package "simple-condition-format-control") nil) +(deftest symbol-simple-error (test-if-not-in-cl-package "simple-error") nil) +(deftest symbol-simple-string (test-if-not-in-cl-package "simple-string") nil) +(deftest symbol-simple-string-p (test-if-not-in-cl-package "simple-string-p") nil) +(deftest symbol-simple-type-error (test-if-not-in-cl-package "simple-type-error") nil) +(deftest symbol-simple-vector (test-if-not-in-cl-package "simple-vector") nil) +(deftest symbol-simple-vector-p (test-if-not-in-cl-package "simple-vector-p") nil) +(deftest symbol-simple-warning (test-if-not-in-cl-package "simple-warning") nil) +(deftest symbol-sin (test-if-not-in-cl-package "sin") nil) +(deftest symbol-single-float (test-if-not-in-cl-package "single-float") nil) +(deftest symbol-single-float-epsilon (test-if-not-in-cl-package "single-float-epsilon") nil) +(deftest symbol-single-float-negative-epsilon (test-if-not-in-cl-package "single-float-negative-epsilon") nil) +(deftest symbol-sinh (test-if-not-in-cl-package "sinh") nil) +(deftest symbol-sixth (test-if-not-in-cl-package "sixth") nil) +(deftest symbol-sleep (test-if-not-in-cl-package "sleep") nil) +(deftest symbol-slot-boundp (test-if-not-in-cl-package "slot-boundp") nil) +(deftest symbol-slot-exists-p (test-if-not-in-cl-package "slot-exists-p") nil) +(deftest symbol-slot-makunbound (test-if-not-in-cl-package "slot-makunbound") nil) +(deftest symbol-slot-missing (test-if-not-in-cl-package "slot-missing") nil) +(deftest symbol-slot-unbound (test-if-not-in-cl-package "slot-unbound") nil) +(deftest symbol-slot-value (test-if-not-in-cl-package "slot-value") nil) +(deftest symbol-software-type (test-if-not-in-cl-package "software-type") nil) +(deftest symbol-software-version (test-if-not-in-cl-package "software-version") nil) +(deftest symbol-some (test-if-not-in-cl-package "some") nil) +(deftest symbol-sort (test-if-not-in-cl-package "sort") nil) +(deftest symbol-space (test-if-not-in-cl-package "space") nil) +(deftest symbol-special (test-if-not-in-cl-package "special") nil) +(deftest symbol-special-operator-p (test-if-not-in-cl-package "special-operator-p") nil) +(deftest symbol-speed (test-if-not-in-cl-package "speed") nil) +(deftest symbol-sqrt (test-if-not-in-cl-package "sqrt") nil) +(deftest symbol-stable-sort (test-if-not-in-cl-package "stable-sort") nil) +(deftest symbol-standard (test-if-not-in-cl-package "standard") nil) +(deftest symbol-standard-char (test-if-not-in-cl-package "standard-char") nil) +(deftest symbol-standard-char-p (test-if-not-in-cl-package "standard-char-p") nil) +(deftest symbol-standard-class (test-if-not-in-cl-package "standard-class") nil) +(deftest symbol-standard-generic-function (test-if-not-in-cl-package "standard-generic-function") nil) +(deftest symbol-standard-method (test-if-not-in-cl-package "standard-method") nil) +(deftest symbol-standard-object (test-if-not-in-cl-package "standard-object") nil) +(deftest symbol-step (test-if-not-in-cl-package "step") nil) +(deftest symbol-storage-condition (test-if-not-in-cl-package "storage-condition") nil) +(deftest symbol-store-value (test-if-not-in-cl-package "store-value") nil) +(deftest symbol-stream (test-if-not-in-cl-package "stream") nil) +(deftest symbol-stream-element-type (test-if-not-in-cl-package "stream-element-type") nil) +(deftest symbol-stream-error (test-if-not-in-cl-package "stream-error") nil) +(deftest symbol-stream-error-stream (test-if-not-in-cl-package "stream-error-stream") nil) +(deftest symbol-stream-external-format (test-if-not-in-cl-package "stream-external-format") nil) +(deftest symbol-streamp (test-if-not-in-cl-package "streamp") nil) +(deftest symbol-string (test-if-not-in-cl-package "string") nil) +(deftest symbol-string-capitalize (test-if-not-in-cl-package "string-capitalize") nil) +(deftest symbol-string-downcase (test-if-not-in-cl-package "string-downcase") nil) +(deftest symbol-string-equal (test-if-not-in-cl-package "string-equal") nil) +(deftest symbol-string-greaterp (test-if-not-in-cl-package "string-greaterp") nil) +(deftest symbol-string-left-trim (test-if-not-in-cl-package "string-left-trim") nil) +(deftest symbol-string-lessp (test-if-not-in-cl-package "string-lessp") nil) +(deftest symbol-string-not-equal (test-if-not-in-cl-package "string-not-equal") nil) +(deftest symbol-string-not-greaterp (test-if-not-in-cl-package "string-not-greaterp") nil) +(deftest symbol-string-not-lessp (test-if-not-in-cl-package "string-not-lessp") nil) +(deftest symbol-string-right-trim (test-if-not-in-cl-package "string-right-trim") nil) +(deftest symbol-string-stream (test-if-not-in-cl-package "string-stream") nil) +(deftest symbol-string-trim (test-if-not-in-cl-package "string-trim") nil) +(deftest symbol-string-upcase (test-if-not-in-cl-package "string-upcase") nil) +(deftest symbol-string/= (test-if-not-in-cl-package "string/=") nil) +(deftest symbol-string< (test-if-not-in-cl-package "string<") nil) +(deftest symbol-string<= (test-if-not-in-cl-package "string<=") nil) +(deftest symbol-string= (test-if-not-in-cl-package "string=") nil) +(deftest symbol-string> (test-if-not-in-cl-package "string>") nil) +(deftest symbol-string>= (test-if-not-in-cl-package "string>=") nil) +(deftest symbol-stringp (test-if-not-in-cl-package "stringp") nil) +(deftest symbol-structure (test-if-not-in-cl-package "structure") nil) +(deftest symbol-structure-class (test-if-not-in-cl-package "structure-class") nil) +(deftest symbol-structure-object (test-if-not-in-cl-package "structure-object") nil) +(deftest symbol-style-warning (test-if-not-in-cl-package "style-warning") nil) +(deftest symbol-sublis (test-if-not-in-cl-package "sublis") nil) +(deftest symbol-subseq (test-if-not-in-cl-package "subseq") nil) +(deftest symbol-subsetp (test-if-not-in-cl-package "subsetp") nil) +(deftest symbol-subst (test-if-not-in-cl-package "subst") nil) +(deftest symbol-subst-if (test-if-not-in-cl-package "subst-if") nil) +(deftest symbol-subst-if-not (test-if-not-in-cl-package "subst-if-not") nil) +(deftest symbol-substitute (test-if-not-in-cl-package "substitute") nil) +(deftest symbol-substitute-if (test-if-not-in-cl-package "substitute-if") nil) +(deftest symbol-substitute-if-not (test-if-not-in-cl-package "substitute-if-not") nil) +(deftest symbol-subtypep (test-if-not-in-cl-package "subtypep") nil) +(deftest symbol-svref (test-if-not-in-cl-package "svref") nil) +(deftest symbol-sxhash (test-if-not-in-cl-package "sxhash") nil) +(deftest symbol-symbol (test-if-not-in-cl-package "symbol") nil) +(deftest symbol-symbol-function (test-if-not-in-cl-package "symbol-function") nil) +(deftest symbol-symbol-macrolet (test-if-not-in-cl-package "symbol-macrolet") nil) +(deftest symbol-symbol-name (test-if-not-in-cl-package "symbol-name") nil) +(deftest symbol-symbol-package (test-if-not-in-cl-package "symbol-package") nil) +(deftest symbol-symbol-plist (test-if-not-in-cl-package "symbol-plist") nil) +(deftest symbol-symbol-value (test-if-not-in-cl-package "symbol-value") nil) +(deftest symbol-symbolp (test-if-not-in-cl-package "symbolp") nil) +(deftest symbol-synonym-stream (test-if-not-in-cl-package "synonym-stream") nil) +(deftest symbol-synonym-stream-symbol (test-if-not-in-cl-package "synonym-stream-symbol") nil) +(deftest symbol-t (test-if-not-in-cl-package "t") nil) +(deftest symbol-tagbody (test-if-not-in-cl-package "tagbody") nil) +(deftest symbol-tailp (test-if-not-in-cl-package "tailp") nil) +(deftest symbol-tan (test-if-not-in-cl-package "tan") nil) +(deftest symbol-tanh (test-if-not-in-cl-package "tanh") nil) +(deftest symbol-tenth (test-if-not-in-cl-package "tenth") nil) +(deftest symbol-terpri (test-if-not-in-cl-package "terpri") nil) +(deftest symbol-the (test-if-not-in-cl-package "the") nil) +(deftest symbol-third (test-if-not-in-cl-package "third") nil) +(deftest symbol-throw (test-if-not-in-cl-package "throw") nil) +(deftest symbol-time (test-if-not-in-cl-package "time") nil) +(deftest symbol-trace (test-if-not-in-cl-package "trace") nil) +(deftest symbol-translate-logical-pathname (test-if-not-in-cl-package "translate-logical-pathname") nil) +(deftest symbol-translate-pathname (test-if-not-in-cl-package "translate-pathname") nil) +(deftest symbol-tree-equal (test-if-not-in-cl-package "tree-equal") nil) +(deftest symbol-truename (test-if-not-in-cl-package "truename") nil) +(deftest symbol-truncate (test-if-not-in-cl-package "truncate") nil) +(deftest symbol-two-way-stream (test-if-not-in-cl-package "two-way-stream") nil) +(deftest symbol-two-way-stream-input-stream (test-if-not-in-cl-package "two-way-stream-input-stream") nil) +(deftest symbol-two-way-stream-output-stream (test-if-not-in-cl-package "two-way-stream-output-stream") nil) +(deftest symbol-type (test-if-not-in-cl-package "type") nil) +(deftest symbol-type-error (test-if-not-in-cl-package "type-error") nil) +(deftest symbol-type-error-datum (test-if-not-in-cl-package "type-error-datum") nil) +(deftest symbol-type-error-expected-type (test-if-not-in-cl-package "type-error-expected-type") nil) +(deftest symbol-type-of (test-if-not-in-cl-package "type-of") nil) +(deftest symbol-typecase (test-if-not-in-cl-package "typecase") nil) +(deftest symbol-typep (test-if-not-in-cl-package "typep") nil) +(deftest symbol-unbound-slot (test-if-not-in-cl-package "unbound-slot") nil) +(deftest symbol-unbound-slot-instance (test-if-not-in-cl-package "unbound-slot-instance") nil) +(deftest symbol-unbound-variable (test-if-not-in-cl-package "unbound-variable") nil) +(deftest symbol-undefined-function (test-if-not-in-cl-package "undefined-function") nil) +(deftest symbol-unexport (test-if-not-in-cl-package "unexport") nil) +(deftest symbol-unintern (test-if-not-in-cl-package "unintern") nil) +(deftest symbol-union (test-if-not-in-cl-package "union") nil) +(deftest symbol-unless (test-if-not-in-cl-package "unless") nil) +(deftest symbol-unread-char (test-if-not-in-cl-package "unread-char") nil) +(deftest symbol-unsigned-byte (test-if-not-in-cl-package "unsigned-byte") nil) +(deftest symbol-untrace (test-if-not-in-cl-package "untrace") nil) +(deftest symbol-unuse-package (test-if-not-in-cl-package "unuse-package") nil) +(deftest symbol-unwind-protect (test-if-not-in-cl-package "unwind-protect") nil) +(deftest symbol-update-instance-for-different-class (test-if-not-in-cl-package "update-instance-for-different-class") nil) +(deftest symbol-update-instance-for-redefined-class (test-if-not-in-cl-package "update-instance-for-redefined-class") nil) +(deftest symbol-upgraded-array-element-type (test-if-not-in-cl-package "upgraded-array-element-type") nil) +(deftest symbol-upgraded-complex-part-type (test-if-not-in-cl-package "upgraded-complex-part-type") nil) +(deftest symbol-upper-case-p (test-if-not-in-cl-package "upper-case-p") nil) +(deftest symbol-use-package (test-if-not-in-cl-package "use-package") nil) +(deftest symbol-use-value (test-if-not-in-cl-package "use-value") nil) +(deftest symbol-user-homedir-pathname (test-if-not-in-cl-package "user-homedir-pathname") nil) +(deftest symbol-values (test-if-not-in-cl-package "values") nil) +(deftest symbol-values-list (test-if-not-in-cl-package "values-list") nil) +(deftest symbol-variable (test-if-not-in-cl-package "variable") nil) +(deftest symbol-vector (test-if-not-in-cl-package "vector") nil) +(deftest symbol-vector-pop (test-if-not-in-cl-package "vector-pop") nil) +(deftest symbol-vector-push (test-if-not-in-cl-package "vector-push") nil) +(deftest symbol-vector-push-extend (test-if-not-in-cl-package "vector-push-extend") nil) +(deftest symbol-vectorp (test-if-not-in-cl-package "vectorp") nil) +(deftest symbol-warn (test-if-not-in-cl-package "warn") nil) +(deftest symbol-warning (test-if-not-in-cl-package "warning") nil) +(deftest symbol-when (test-if-not-in-cl-package "when") nil) +(deftest symbol-wild-pathname-p (test-if-not-in-cl-package "wild-pathname-p") nil) +(deftest symbol-with-accessors (test-if-not-in-cl-package "with-accessors") nil) +(deftest symbol-with-compilation-unit (test-if-not-in-cl-package "with-compilation-unit") nil) +(deftest symbol-with-condition-restarts (test-if-not-in-cl-package "with-condition-restarts") nil) +(deftest symbol-with-hash-table-iterator (test-if-not-in-cl-package "with-hash-table-iterator") nil) +(deftest symbol-with-input-from-string (test-if-not-in-cl-package "with-input-from-string") nil) +(deftest symbol-with-open-file (test-if-not-in-cl-package "with-open-file") nil) +(deftest symbol-with-open-stream (test-if-not-in-cl-package "with-open-stream") nil) +(deftest symbol-with-output-to-string (test-if-not-in-cl-package "with-output-to-string") nil) +(deftest symbol-with-package-iterator (test-if-not-in-cl-package "with-package-iterator") nil) +(deftest symbol-with-simple-restart (test-if-not-in-cl-package "with-simple-restart") nil) +(deftest symbol-with-slots (test-if-not-in-cl-package "with-slots") nil) +(deftest symbol-with-standard-io-syntax (test-if-not-in-cl-package "with-standard-io-syntax") nil) +(deftest symbol-write (test-if-not-in-cl-package "write") nil) +(deftest symbol-write-byte (test-if-not-in-cl-package "write-byte") nil) +(deftest symbol-write-char (test-if-not-in-cl-package "write-char") nil) +(deftest symbol-write-line (test-if-not-in-cl-package "write-line") nil) +(deftest symbol-write-sequence (test-if-not-in-cl-package "write-sequence") nil) +(deftest symbol-write-string (test-if-not-in-cl-package "write-string") nil) +(deftest symbol-write-to-string (test-if-not-in-cl-package "write-to-string") nil) +(deftest symbol-y-or-n-p (test-if-not-in-cl-package "y-or-n-p") nil) +(deftest symbol-yes-or-no-p (test-if-not-in-cl-package "yes-or-no-p") nil) +(deftest symbol-zerop (test-if-not-in-cl-package "zerop") nil) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; keywordp + +(deftest keywordp-1 (keywordp 'hefalump) nil) +(deftest keywordp-2 (keywordp 17) nil) +(deftest keywordp-3 (not (not (keywordp :stream))) t) +(deftest keywordp-4 (not (not (keywordp ':stream))) t) +(deftest keywordp-5 (keywordp nil) nil) +(deftest keywordp-6 (not (not (keywordp :nil))) t) +(deftest keywordp-7 (keywordp '(:stream)) nil) +(deftest keywordp-8 (keywordp "rest") nil) +(deftest keywordp-9 (keywordp ":rest") nil) +(deftest keywordp-10 (keywordp '&body) nil) +(deftest keywordp-11 (not (not (keywordp ::foo))) t) +(deftest keywordp-12 (keywordp t) nil) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; symbol-name + +(defun safe-symbol-name (sym) + (catch-type-error (symbol-name sym))) + +(deftest symbol-name-1 + (safe-symbol-name '|ABCD|) + "ABCD") + +(deftest symbol-name-2 + (safe-symbol-name '|1234abcdABCD|) + "1234abcdABCD") + +(deftest symbol-name-3 + (safe-symbol-name 1) + type-error) + +(deftest symbol-name-4 + (safe-symbol-name '(a)) + type-error) + +(deftest symbol-name-5 + (safe-symbol-name "ABCDE") + type-error) + +(deftest symbol-name-6 + (safe-symbol-name 12913.0213) + type-error) + +(deftest symbol-name-7 + (symbol-name :|abcdefg|) + "abcdefg") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; make-symbol + +(deftest make-symbol-1 + (not (not (symbolp (make-symbol "FOO")))) + t) + +(deftest make-symbol-2 + (symbol-package (make-symbol "BAR")) + nil) + +(deftest make-symbol-3 + (symbol-package (make-symbol "CL::FOO")) + nil) + +(deftest make-symbol-4 + (symbol-package (make-symbol "CL:FOO")) + nil) + +(deftest make-symbol-5 + (symbol-name (make-symbol "xyz")) + "xyz") + +(deftest make-symbol-6 + (eq (make-symbol "A") + (make-symbol "A")) + nil) + +(deftest make-symbol-7 + (boundp (make-symbol "B")) + nil) + +(deftest make-symbol-8 + (symbol-plist (make-symbol "C")) + nil) + +(defun safe-make-symbol (name) + (catch-type-error (make-symbol name))) + +(deftest make-symbol-9 + (safe-make-symbol nil) + type-error) + +(deftest make-symbol-10 + (safe-make-symbol 'a) + type-error) + +(deftest make-symbol-11 + (safe-make-symbol 1) + type-error) + +(deftest make-symbol-12 + (safe-make-symbol -1) + type-error) + +(deftest make-symbol-13 + (safe-make-symbol 1.213) + type-error) + +(deftest make-symbol-14 + (safe-make-symbol -1312.2) + type-error) + +(deftest make-symbol-15 + (safe-make-symbol #\w) + type-error) + +(deftest make-symbol-16 + (safe-make-symbol '(a)) + type-error) + +(deftest make-symbol-17 + (fboundp (make-symbol "D")) + nil) + +(deftest make-symbol-18 + (symbol-name (safe-make-symbol "")) + "") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; copy-symbol + +(deftest copy-symbol-1 + (not (not + (every + #'(lambda (x) + (let ((y (copy-symbol x))) + (and (symbolp y) + (not (boundp y)) + (not (fboundp y)) + (null (symbol-package y)) + (equal (symbol-name x) (symbol-name y)) + (null (symbol-plist y)) + (symbolp (copy-symbol y)) + ))) + '(nil t a b |a| |123|)))) + t) + +(deftest copy-symbol-2 + (handler-case + (progn + (setf (symbol-plist '|foo|) '(a b c d)) + (makunbound '|foo|) + (not (not + (every + #'(lambda (x) + (let ((y (copy-symbol x t))) + (and (symbolp y) + (if (boundp x) + (boundp y) + (not (boundp y))) + (not (fboundp y)) + (null (symbol-package y)) + (equal (symbol-name x) (symbol-name y)) + (equal (symbol-plist y) (symbol-plist x)) + ))) + '(nil t a b |foo| |a| |123|))))) + (error (c) c)) + t) + +(deftest copy-symbol-3 + (handler-case + (progn + (setf (symbol-plist '|foo|) '(a b c d)) + (setf (symbol-value '|a|) 12345) + (not (not + (every + #'(lambda (x) + (let ((y (copy-symbol x t))) + (and (symbolp y) + (if (boundp x) + (eq (symbol-value x) + (symbol-value y)) + (not (boundp y))) + (not (fboundp y)) + (null (symbol-package y)) + (equal (symbol-name x) (symbol-name y)) + (eql (length (symbol-plist x)) + (length (symbol-plist y))) + (every #'eq (symbol-plist y) (symbol-plist x)) + ))) + '(nil t a b |foo| |a| |123|))))) + (error (c) c)) + t) + +(deftest copy-symbol-4 + (eq (copy-symbol 'a) (copy-symbol 'a)) + nil) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; gensym + +;; Gensym returns unique symbols +(deftest gensym-1 + (equal (gensym) (gensym)) + nil) + +;; Gensym returns symbols with distinct print names +(deftest gensym-2 + (equal (symbol-name (gensym)) + (symbol-name (gensym))) + nil) + +;; Gensym uses the *gensym-counter* special variable, +;; but does not increment it until after the symbol +;; has been created. +(deftest gensym-3 + (let ((*gensym-counter* 1)) + (declare (special *gensym-counter*)) + (symbol-name (gensym))) + "G1") + +;; Gensym uses the string argument instead of the default +(deftest gensym-4 + (let ((*gensym-counter* 1327)) + (declare (special *gensym-counter*)) + (symbol-name (gensym "FOO"))) + "FOO1327") + +;; The symbol returned by gensym should be unbound +(deftest gensym-5 + (boundp (gensym)) + nil) + +;; The symbol returned by gensym should have no function binding +(deftest gensym-6 + (fboundp (gensym)) + nil) + +;; The symbol returned by gensym should have no property list +(deftest gensym-7 + (symbol-plist (gensym)) + nil) + +;; The symbol returned by gensym should be uninterned +(deftest gensym-8 + (symbol-package (gensym)) + nil) + +;; *gensym-counter* is incremented by gensym +(deftest gensym-9 + (let ((*gensym-counter* 12345)) + (declare (special *gensym-counter*)) + (gensym) + *gensym-counter*) + 12346) + +;; Gensym works when *gensym-counter* is Really Big +;; (and does not increment the counter until after creating +;; the symbol.) +(deftest gensym-10 + (let ((*gensym-counter* 1234567890123456789012345678901234567890)) + (declare (special *gensym-counter*)) + (symbol-name (gensym))) + "G1234567890123456789012345678901234567890") + +;; gensym increments Really Big values of *gensym-counter* +(deftest gensym-11 + (let ((*gensym-counter* 12345678901234567890123456789012345678901234567890)) + (declare (special *gensym-counter*)) + (gensym) + *gensym-counter*) + 12345678901234567890123456789012345678901234567891) + +;; Gensym uses an integer argument instead of the counter +(deftest gensym-12 + (let ((*gensym-counter* 10)) + (declare (special *gensym-counter*)) + (symbol-name (gensym 123))) + "G123") + +;; When given an integer argument, gensym does not increment the +;; *gensym-counter* +(deftest gensym-13 + (let ((*gensym-counter* 10)) + (declare (special *gensym-counter*)) + (gensym 123) + *gensym-counter*) + 10) + +;; Check response to erroneous arguments +;; Note! NIL is not the same as no argument +;; gensym should be implemented so that its only +;; argument defaults to "G", with NIL causing an error. + +(deftest gensym-14 + (catch-type-error (gensym 'aaa)) + type-error) + +(deftest gensym-15 + (catch-type-error (gensym 12.3)) + type-error) + +(deftest gensym-16 + (catch-type-error (gensym t)) + type-error) + +(deftest gensym-17 + (catch-type-error (gensym nil)) + type-error) ;; NIL /= no argument! + +(deftest gensym-18 + (catch-type-error (gensym '(a))) + type-error) + +(deftest gensym-19 + (catch-type-error (gensym #\x)) + type-error) diff --git a/ansi-tests/cl-test-package.lsp b/ansi-tests/cl-test-package.lsp new file mode 100644 index 0000000000000000000000000000000000000000..7b7369460157e36ba2aa6924cfcb04c0e167b3ea --- /dev/null +++ b/ansi-tests/cl-test-package.lsp @@ -0,0 +1,15 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Mar 14 10:13:21 1998 +;;;; Contains: CL test case package definition + +(defpackage :cl-test + (:use :cl :rt) + #+gcl (:use defpackage) + (:nicknames) + (:import-from "COMMON-LISP-USER" "COMPILE-AND-LOAD") + (:export)) + +#+cmu (import 'cl::quit :cl-test) + + diff --git a/ansi-tests/cltest.system b/ansi-tests/cltest.system new file mode 100644 index 0000000000000000000000000000000000000000..5cf027096b45dcb4fe546e73cce032f0707ef5d9 --- /dev/null +++ b/ansi-tests/cltest.system @@ -0,0 +1,117 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Fri Mar 27 09:57:28 1998 +;;;; Contains: MK portable system file for CL test suite + +(mk::defsystem "cltest" + :source-pathname #.(directory-namestring *LOAD-TRUENAME*) + :source-extension "lsp" + :binary-pathname #.(mk::append-directories + (directory-namestring *LOAD-TRUENAME*) + "binary/") + :binary-extension + #+CMU #.(C::BACKEND-FASL-FILE-TYPE C::*TARGET-BACKEND*) + #+ALLEGRO "fasl" + #+(OR AKCL GCL) "o" + :initially-do (progn (load "rt/rt.system") + (mk::compile-system "rt")) + :components + ("cl-test-package" + (:subsystem "cl-test-code" + :source-pathname "" + :binary-pathname "" + :depends-on ("cl-test-package") + :components + ( + "aux" + "universe" + "cons-test-01" + "cons-test-02" + "cons-test-03" + "cons-test-04" + "cons-test-05" + "cons-test-06" + "cons-test-07" + "cons-test-08" + "cons-test-09" + "cons-test-10" + "cons-test-11" + "cons-test-12" + "cons-test-13" + "cons-test-14" + "cons-test-15" + "cons-test-16" + "cons-test-17" + "cons-test-18" + "cons-test-19" + "cons-test-20" + "cons-test-21" + "cons-test-22" + "cons-test-23" + "cons-test-24" + "types-and-class" + "cl-symbols" + "cases-14-1-arrays" + "cases-14-1-list" + "reader-test" + + "packages-00" + "packages-01" + "packages-02" + "packages-03" + "packages-04" + "packages-05" + "packages-06" + "packages-07" + "packages-08" + "packages-09" + "packages-10" + "packages-11" + "packages-12" + "packages-13" + "packages-14" + "packages-15" + "packages-16" + "packages-17" + "packages-18" + + "fill-strings" + "make-sequence" + "map" + "map-into" + "reduce" + "count" + "count-if" + "count-if-not" + "reverse" + "nreverse" + "sort" + "find" + "find-if" + "find-if-not" + "position" + "search-aux" + "search-list" + "search-vector" + "search-bitvector" + "search-string" + "mismatch" + "replace" + "substitute" + "substitute-if" + "substitute-if-not" + "nsubstitute" + "nsubstitute-if" + "nsubstitute-if-not" + "concatenate" + "merge" + "remove" ;; need to extend these tests + + "structure-00" + "structures-01" + "structures-02" + + )))) + + + \ No newline at end of file diff --git a/ansi-tests/compile-and-load.lsp b/ansi-tests/compile-and-load.lsp new file mode 100644 index 0000000000000000000000000000000000000000..fc4dfa9ac9349a99597b9e8d9203f7d9bb8f2232 --- /dev/null +++ b/ansi-tests/compile-and-load.lsp @@ -0,0 +1,19 @@ +(in-package "COMMON-LISP-USER") + +(eval-when (load eval compile) + (unless (fboundp 'compile-file-pathname) + (defun compile-file-pathname (pathname) + (make-pathname :defaults pathname :type "o")))) + +(defun compile-and-load (pathspec) + "Find the file indicated by PATHSPEC, compiling it first if + the associated compiled file is out of date." + (let* ((pathname (pathname pathspec)) + (compile-pathname (compile-file-pathname pathname)) + (source-write-time (file-write-date pathname)) + (target-write-time (and (probe-file compile-pathname) + (file-write-date compile-pathname)))) + (when (or (not target-write-time) + (<= target-write-time source-write-time)) + (compile-file pathname)) + (load compile-pathname))) diff --git a/ansi-tests/concatenate.lsp b/ansi-tests/concatenate.lsp new file mode 100644 index 0000000000000000000000000000000000000000..9d40b930437bc245446314c97c1fe1e33a6ea183 --- /dev/null +++ b/ansi-tests/concatenate.lsp @@ -0,0 +1,131 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Wed Sep 4 22:53:51 2002 +;;;; Contains: Tests for CONCATENATE + +(in-package :cl-test) + +(deftest concatenate.1 + (concatenate 'list) + nil) + +(deftest concatenate.2 + (let* ((orig (list 'a 'b 'c 'd 'e)) + (copy (concatenate 'list orig))) + (values + copy + (intersection (loop for e on orig collect e) + (loop for e on copy collect e) + :test #'eq))) + (a b c d e) + nil) + +(deftest concatenate.3 + (concatenate 'list "") + nil) + +(deftest concatenate.4 + (concatenate 'list "abcd" '(x y z) nil #*1101 #()) + (#\a #\b #\c #\d x y z 1 1 0 1)) + +(deftest concatenate.5 + (concatenate 'vector) + #()) + +(deftest concatenate.6 + (concatenate 'vector nil "abcd" '(x y z) nil #*1101 #()) + #(#\a #\b #\c #\d x y z 1 1 0 1)) + +(deftest concatenate.7 + (let* ((orig (vector 'a 'b 'c 'd 'e)) + (copy (concatenate 'vector orig))) + (values + copy + (eq copy orig))) + #(a b c d e) + nil) + +(deftest concatenate.8 + (concatenate 'simple-vector '(a b c) #(1 2 3)) + #(a b c 1 2 3)) + +(deftest concatenate.9 + (concatenate 'simple-vector) + #()) + +(deftest concatenate.10 + (concatenate 'bit-vector nil) + #*) + +(deftest concatenate.11 + (concatenate 'bit-vector) + #*) + +(deftest concatenate.12 + (concatenate 'bit-vector '(0 1 1) nil #(1 0 1) #()) + #*011101) + +(deftest concatenate.13 + (concatenate 'simple-bit-vector nil) + #*) + +(deftest concatenate.14 + (concatenate 'simple-bit-vector) + #*) + +(deftest concatenate.15 + (concatenate 'simple-bit-vector '(0 1 1) nil #(1 0 1) #()) + #*011101) + +(deftest concatenate.16 + (concatenate 'string "abc" '(#\d #\e) nil #() "fg") + "abcdefg") + +(deftest concatenate.17 + (concatenate 'simple-string "abc" '(#\d #\e) nil #() "fg") + "abcdefg") + +(deftest concatenate.18 + (concatenate '(vector * *) '(a b c) '(d e f) #(g h)) + #(a b c d e f g h)) + +(deftest concatenate.19 + (concatenate '(vector * 8) '(a b c) '(d e f) #(g h)) + #(a b c d e f g h)) + +(deftest concatenate.20 + (concatenate '(vector symbol 8) '(a b c) '(d e f) #(g h)) + #(a b c d e f g h)) + +(deftest concatenate.21 + (concatenate '(vector symbol) '(a b c) '(d e f) #(g h)) + #(a b c d e f g h)) + +(deftest concatenate.22 + (concatenate '(vector symbol *) '(a b c) '(d e f) #(g h)) + #(a b c d e f g h)) + +(deftest concatenate.23 + (concatenate 'cons '(a b c) '(d e f)) + (a b c d e f)) + +(deftest concatenate.24 + (concatenate 'null nil nil) + nil) + +;;; Error tests + +(deftest concatenate-error.1 + (handler-case + (concatenate 'sequence '(a b c)) + (error () :caught)) + :caught) + +(deftest concatenate-error.2 + (handler-case (concatenate 'fixnum '(a b c d e)) + (error () :caught)) + :caught) + +(deftest concatenate-error.3 + (catch-type-error (concatenate '(vector * 3) '(a b c d e))) + type-error) diff --git a/ansi-tests/cons-test-01.lsp b/ansi-tests/cons-test-01.lsp new file mode 100644 index 0000000000000000000000000000000000000000..0d74f107c980cbf46b75964e99518f2d9f9e986e --- /dev/null +++ b/ansi-tests/cons-test-01.lsp @@ -0,0 +1,360 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Mar 28 07:29:48 1998 +;;;; Contains: Testing of CL Features related to "CONS", part 1 + +(in-package :cl-test) +(use-package :rt) + +(declaim (optimize (safety 3))) + +;; +;; Test the subtype relationships between null, list, cons and atom +;; +(deftest subtypep-null-list + (subtypep* 'null 'list) + t t) + +(deftest subtypep-cons-list + (subtypep* 'cons 'list) + t t) + +(deftest subtypep-null-cons + (subtypep* 'null 'cons) + nil t) + +(deftest subtypep-cons-null + (subtypep* 'cons 'null) + nil t) + +(deftest subtypep-null-atom + (subtypep* 'null 'atom) + t t) + +(deftest subtypep-cons-atom + (subtypep* 'cons 'atom) + nil t) + +(deftest subtypep-atom-cons + (subtypep* 'atom 'cons) + nil t) + +(deftest subtypep-atom-list + (subtypep* 'atom 'list) + nil t) + +(deftest subtypep-list-atom + (subtypep* 'list 'atom) + nil t) + +;; +;; Check that the elements of *universe* in type null +;; are those for which the null predice is true. +;; +(deftest null-null-universe + (check-type-predicate 'null 'null) + 0) + +(defvar *cons-fns* + (list 'cons 'consp 'atom 'rplaca 'rplacd + 'car 'cdr 'caar 'cadr 'cdar 'cddr + 'caaar 'caadr 'cadar 'caddr + 'cdaar 'cdadr 'cddar 'cdddr + 'caaaar 'caaadr 'caadar 'caaddr + 'cadaar 'cadadr 'caddar 'cadddr + 'cdaaar 'cdaadr 'cdadar 'cdaddr + 'cddaar 'cddadr 'cdddar 'cddddr + 'copy-tree 'sublis 'nsublis + 'subst 'subst-if 'subst-if-not + 'nsubst 'nsubst-if 'nsubst-if-not + 'tree-equal + 'copy-list + 'list + 'list* + 'list-length + 'listp + 'make-list + 'first 'second 'third 'fourth + 'fifth 'sixth 'seventh 'eighth 'ninth 'tenth + 'nth + 'endp + 'null + 'nconc + 'append + 'revappend 'nreconc + 'butlast 'nbutlast + 'last 'ldiff 'tailp + 'nthcdr 'rest + 'member 'member-if 'member-if-not + 'mapc 'mapcar 'mapcan 'mapl 'maplist 'mapcon + 'acons + 'assoc 'assoc-if 'assoc-if-not + 'copy-alist + 'pairlis + 'rassoc 'rassoc-if 'rassoc-if-not + 'get-properties + 'getf + 'intersection + 'nintersection + 'adjoin + 'set-difference 'nset-difference + 'set-exclusive-or 'nset-exclusive-or + 'subsetp + 'union 'nunion + )) + +;; All the cons functions have a fnuction binding + +(deftest function-bound-cons-fns + (loop + for x in *cons-fns* count + (when (or (not (fboundp x)) + (not (functionp (symbol-function x)))) + (format t "~%~S not bound to a function" x) + t)) + 0) + +;; All the cons-related macros have a macro binding +(deftest macro-bound-cons-macros + (not (every #'macro-function + (list 'push 'pop 'pushnew 'remf))) + nil) + +;; None of the cons-related functions have macro bindings +(deftest no-cons-fns-are-macros + (some #'macro-function *cons-fns*) + nil) + +;; Various easy tests of cons +(deftest cons-of-symbols + (cons 'a 'b) + (a . b)) + +(deftest cons-with-nil + (cons 'a nil) + (a)) + +;; successive calls to cons produces results that are equal, but not eq +(deftest cons-eq-equal + (let ((x (cons 'a 'b)) + (y (cons 'a 'b))) + (and (not (eq x y)) + (equal x y) + t)) + t) + +;; list can be expressed as a bunch of conses (with nil) +(deftest cons-equal-list + (equal (cons 'a (cons 'b (cons 'c nil))) + (list 'a 'b 'c)) + t) + +;; Lists satisfy consp +(deftest consp-list + (not (not (consp '(a)))) + t) + +;; cons satisfies consp +(deftest consp-cons + (not (not (consp (cons nil nil)))) + t) + +;; nil is not a consp +(deftest consp-nil + (consp nil) + nil) + +;; The empty list is not a cons +(deftest consp-empty-list + (consp (list)) + nil) + +;; A single element list is a cons +(deftest consp-single-element-list + (not (not (consp (list 'a)))) + t) + +;; For everything in *universe*, it is either an atom, or satisfies +;; consp, but not both +(deftest consp-xor-atom-universe + (not (not + (every #'(lambda (x) (or (and (consp x) (not (atom x))) + (and (not (consp x)) (atom x)))) + *universe*))) + t) + +;; Everything in type cons satisfies consp, and vice versa +(deftest consp-cons-universe + (check-type-predicate 'consp 'cons) + 0) + +;; Tests of car, cdr and compound forms +(deftest cons-23 + (car '(a)) + a) + +(deftest cons-24 + (cdr '(a . b)) + b) + +(deftest cons-25 + (caar '((a))) + a) + +(deftest cons-26 + (cdar '((a . b))) + b) + +(deftest cons-27 + (cadr '(a b)) + b) + +(deftest cons-28 + (cddr '(a b . c)) + c) + +(deftest cons-29 + (caaar '(((a)))) + a) + +(deftest cons-30 + (cdaar '(((a . b)))) + b) + +(deftest cons-31 + (cadar (cons (cons 'a (cons 'b 'c)) 'd)) + b) + +(deftest cons-32 + (cddar (cons (cons 'a (cons 'b 'c)) 'd)) + c) + +(deftest cons-33 + (caadr (cons 'a (cons (cons 'b 'c) 'd))) + b) + +(deftest cons-34 + (caddr (cons 'a (cons 'b (cons 'c 'd)))) + c) + +(deftest cons-36 + (cdadr (cons 'a (cons (cons 'b 'c) 'd))) + c) + +(deftest cons-37 + (cdddr (cons 'a (cons 'b (cons 'c 'd)))) + d) + +(defvar *cons-test-4* + (cons (cons (cons (cons 'a 'b) + (cons 'c 'd)) + (cons (cons 'e 'f) + (cons 'g 'h))) + (cons (cons (cons 'i 'j) + (cons 'k 'l)) + (cons (cons 'm 'n) + (cons 'o 'p))))) + + +(deftest cons-38 + (caaaar *cons-test-4*) + a) + +(deftest cons-39 + (cdaaar *cons-test-4*) + b) + +(deftest cons-40 + (cadaar *cons-test-4*) + c) + +(deftest cons-41 + (cddaar *cons-test-4*) + d) + +(deftest cons-42 + (caadar *cons-test-4*) + e) + +(deftest cons-43 + (cdadar *cons-test-4*) + f) + +(deftest cons-44 + (caddar *cons-test-4*) + g) + +(deftest cons-45 + (cdddar *cons-test-4*) + h) + +;;; + +(deftest cons-46 + (caaadr *cons-test-4*) + i) + +(deftest cons-47 + (cdaadr *cons-test-4*) + j) + +(deftest cons-48 + (cadadr *cons-test-4*) + k) + +(deftest cons-49 + (cddadr *cons-test-4*) + l) + +(deftest cons-50 + (caaddr *cons-test-4*) + m) + +(deftest cons-51 + (cdaddr *cons-test-4*) + n) + +(deftest cons-52 + (cadddr *cons-test-4*) + o) + +(deftest cons-53 + (cddddr *cons-test-4*) + p) + + +;; Test rplaca, rplacd + +(deftest rplaca-1 + (let ((x (cons 'a 'b))) + (let ((y x)) + (and (eq (rplaca x 'c) y) + (eq x y) + (eq (car x) 'c) + (eq (cdr x) 'b) + t))) + t) + +(deftest rplacd-1 + (let ((x (cons 'a 'b))) + (let ((y x)) + (and (eq (rplacd x 'd) y) + (eq x y) + (eq (car x) 'a) + (eq (cdr x) 'd) + t))) + t) + +;; rplaca on a fixnum is a type error +(deftest rplaca-error-1 + (let ((x 12340131)) + (catch-type-error (rplaca x 1))) + type-error) + +;; rplacd on a fixnum is a type error +(deftest rplacd-error-1 + (let ((x 12340132)) + (catch-type-error (rplacd x 1))) + type-error) + +;; To do: add tests for other invalid arguments diff --git a/ansi-tests/cons-test-02.lsp b/ansi-tests/cons-test-02.lsp new file mode 100644 index 0000000000000000000000000000000000000000..f53fe3331e5dce3727f8cd2916dc2a84ca4ac7d5 --- /dev/null +++ b/ansi-tests/cons-test-02.lsp @@ -0,0 +1,560 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Mar 28 07:30:50 1998 +;;;; Contains: Testing of CL Features related to "CONS", part 2 + +(in-package :cl-test) +(use-package :rt) + +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; copy-tree + +(defun check-cons-copy (x y) + "Check that the tree x is a copy of the tree y, + returning t iff it is." + (cond + ((consp x) + (and (consp y) + (not (eq x y)) + (check-cons-copy (car x) (car y)) + (check-cons-copy (cdr x) (cdr y)))) + ((eq x y) t) + (t nil))) + +;; Try copy-tree on a tree containing elements of various kinds +(deftest copy-tree-1 + (let ((x (cons 'a (list (cons 'b 'c) + (cons 1 1.2) + (list (list "abcde" + (make-array '(10) :initial-element (cons 'e 'f))) + 'g))))) + (let ((y (copy-tree x))) + (check-cons-copy x y))) + t) + +;; Try copy-tree on *universe* +(deftest copy-tree-2 + (let ((x (copy-list *universe*))) + (let ((y (copy-tree x))) + (check-cons-copy x y))) + t) + +;; Check sublis + +(defun check-sublis (a al &key (key 'no-key) test test-not) + "Apply sublis al a with various keys. Check that + the arguments are not themselves changed. Return nil + if the arguments do get changed." + (setf a (copy-tree a)) + (setf al (copy-tree al)) + (let ((acopy (make-scaffold-copy a)) + (alcopy (make-scaffold-copy al))) + (let ((as + (apply #'sublis al a + `(,@(when test `(:test ,test)) + ,@(when test-not `(:test-not ,test-not)) + ,@(unless (eq key 'no-key) `(:key ,key)))))) + (and + (check-scaffold-copy a acopy) + (check-scaffold-copy al alcopy) + as)))) + +(deftest sublis-1 + (check-sublis '((a b) g (d e 10 g h) 15 . g) + '((e . e2) (g . 17))) + ((a b) 17 (d e2 10 17 h) 15 . 17)) + +(deftest sublis-2 + (check-sublis '(f6 10 (f4 (f3 (f1 a b) (f1 a p)) (f2 a b))) + '(((f1 a b) . (f2 a b)) ((f2 a b) . (f1 a b))) + :test #'equal) + (F6 10 (F4 (F3 (F2 A B) (F1 A P)) (F1 A B)))) + +(deftest sublis-3 + (check-sublis '(10 ((10 20 (a b c) 30)) (((10 20 30 40)))) + '((30 . "foo"))) + (10 ((10 20 (a b c) "foo")) (((10 20 "foo" 40))))) + +(deftest sublis-4 + (check-sublis (sublis + (copy-tree '((a . 2) (b . 4) (c . 1))) + (copy-tree '(a b c d e (a b c a d b) f))) + '((t . "yes")) + :key #'(lambda (x) (and (typep x 'integer) + (evenp x)))) + ("yes" "yes" 1 d e ("yes" "yes" 1 "yes" d "yes") f)) + +(deftest sublis-5 + (check-sublis '("fee" (("fee" "Fie" "foo")) + fie ("fee" "fie")) + `((,(copy-seq "fie") . #\f))) + ("fee" (("fee" "Fie" "foo")) fie ("fee" "fie"))) + +(deftest sublis-6 + (check-sublis '("fee" fie (("fee" "Fie" "foo") 1) + ("fee" "fie")) + `((,(copy-seq "fie") . #\f)) + :test 'equal) + ("fee" fie (("fee" "Fie" "foo") 1) ("fee" #\f))) + +(deftest sublis-7 + (check-sublis '(("aa" a b) + (z "bb" d) + ((x . "aa"))) + `((,(copy-seq "aa") . 1) + (,(copy-seq "bb") . 2)) + :test 'equal + :key #'(lambda (x) (if (consp x) (car x) + '*not-present*))) + (1 (z . 2) ((x . "aa")))) + +;; Check that a null key arg is ignored. + +(deftest sublis-8 + (handler-case + (check-sublis + '(1 2 a b) + '((1 . 2) (a . b)) + :key nil) + (error (c) c)) + (2 2 b b)) + +;; nsublis + +(defun check-nsublis (a al &key (key 'no-key) test test-not) + "Apply nsublis al a, copying these arguments first." + (setf a (copy-tree a)) + (setf al (copy-tree al)) + (let ((as + (apply #'sublis (copy-tree al) (copy-tree a) + `(,@(when test `(:test ,test)) + ,@(when test-not `(:test-not ,test-not)) + ,@(unless (eq key 'no-key) `(:key ,key)))))) + as)) + + +(deftest nsublis-1 + (check-nsublis '((a b) g (d e 10 g h) 15 . g) + '((e . e2) (g . 17))) + ((a b) 17 (d e2 10 17 h) 15 . 17)) + +(deftest nsublis-2 + (check-nsublis '(f6 10 (f4 (f3 (f1 a b) (f1 a p)) (f2 a b))) + '(((f1 a b) . (f2 a b)) ((f2 a b) . (f1 a b))) + :test #'equal) + (F6 10 (F4 (F3 (F2 A B) (F1 A P)) (F1 A B)))) + +(deftest nsublis-3 + (check-nsublis '(10 ((10 20 (a b c) 30)) (((10 20 30 40)))) + '((30 . "foo"))) + (10 ((10 20 (a b c) "foo")) (((10 20 "foo" 40))))) + +(deftest nsublis-4 + (check-nsublis + (nsublis (copy-tree '((a . 2) (b . 4) (c . 1))) + (copy-tree '(a b c d e (a b c a d b) f))) + '((t . "yes")) + :key #'(lambda (x) (and (typep x 'integer) + (evenp x)))) + ("yes" "yes" 1 d e ("yes" "yes" 1 "yes" d "yes") f)) + +(deftest nsublis-5 + (check-nsublis '("fee" (("fee" "Fie" "foo")) + fie ("fee" "fie")) + `((,(copy-seq "fie") . #\f))) + ("fee" (("fee" "Fie" "foo")) fie ("fee" "fie"))) + +(deftest nsublis-6 + (check-nsublis '("fee" fie (("fee" "Fie" "foo") 1) + ("fee" "fie")) + `((,(copy-seq "fie") . #\f)) + :test 'equal) + ("fee" fie (("fee" "Fie" "foo") 1) ("fee" #\f))) + +(deftest nsublis-7 + (check-nsublis '(("aa" a b) + (z "bb" d) + ((x . "aa"))) + `((,(copy-seq "aa") . 1) + (,(copy-seq "bb") . 2)) + :test 'equal + :key #'(lambda (x) (if (consp x) (car x) + '*not-present*))) + (1 (z . 2) ((x . "aa")))) + +;; Check that a null key arg is ignored. + +(deftest nsublis-8 + (handler-case + (check-nsublis + '(1 2 a b) + '((1 . 2) (a . b)) + :key nil) + (error (c) c)) + (2 2 b b)) + +(deftest sublis-shared + (let* ((shared-piece (list 'a 'b)) + (a (list shared-piece shared-piece))) + (check-sublis a '((a . b) (b . a)))) + ((b a) (b a))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Check subst + +(defun check-subst (new old tree &key (key 'no-key) test test-not) + "Call subst new old tree, with keyword arguments if present. + Check that the arguments are not changed." + (setf new (copy-tree new)) + (setf old (copy-tree old)) + (setf tree (copy-tree tree)) + (let ((newcopy (make-scaffold-copy new)) + (oldcopy (make-scaffold-copy old)) + (treecopy (make-scaffold-copy tree))) + (let ((result + (apply #'subst new old tree + `(,@(unless (eq key 'no-key) `(:key ,key)) + ,@(when test `(:test ,test)) + ,@(when test-not `(:test-not ,test-not)))))) + (and (check-scaffold-copy new newcopy) + (check-scaffold-copy old oldcopy) + (check-scaffold-copy tree treecopy) + result)))) + + +(defvar *subst-tree-1* '(10 (30 20 10) (20 10) (10 20 30 40))) + +(deftest subst-1 + (check-subst "Z" 30 (copy-tree *subst-tree-1*)) + (10 ("Z" 20 10) (20 10) (10 20 "Z" 40))) + +(deftest subst-2 + (check-subst "A" 0 (copy-tree *subst-tree-1*)) + (10 (30 20 10) (20 10) (10 20 30 40))) + +(deftest subst-3 + (check-subst "Z" 100 (copy-tree *subst-tree-1*) :test-not #'eql) + "Z") + +(deftest subst-4 + (check-subst 'grape 'dick + '(melville wrote (moby dick))) + (MELVILLE WROTE (MOBY GRAPE))) + +(deftest subst-5 + (check-subst 'cha-cha-cha 'nil '(melville wrote (moby dick))) + (MELVILLE WROTE (MOBY DICK . CHA-CHA-CHA) . CHA-CHA-CHA)) + +(deftest subst-6 + (check-subst + '(1 2) '(foo . bar) + '((foo . baz) (foo . bar) (bar . foo) (baz foo . bar)) + :test #'equal) + ((foo . baz) (1 2) (bar . foo) (baz 1 2))) + +(deftest subst-7 + (check-subst + 'foo "aaa" + '((1 . 2) (4 . 5) (6 7 8 9 10 (11 12))) + :key #'(lambda (x) (if (and (numberp x) (evenp x)) + "aaa" + nil)) + :test #'string=) + ((1 . foo) (foo . 5) (foo 7 foo 9 foo (11 foo)))) + +(deftest subst-8 + (check-subst + 'foo nil + '((1 . 2) (4 . 5) (6 7 8 9 10 (11 12))) + :key #'(lambda (x) (if (and (numberp x) (evenp x)) + (copy-seq "aaa") + nil)) + :test-not #'equal) + ((1 . foo) (foo . 5) (foo 7 foo 9 foo (11 foo)))) + +(deftest subst-9 + (handler-case + (check-subst 'a 'b + (copy-tree '(a b c d a b)) + :key nil) + (error (c) c)) + (a a c d a a)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Check subst-if, subst-if-not + +(defun check-subst-if (new pred tree &key (key 'no-key)) + "Call subst-if new pred tree, with various keyword arguments + if present. Check that the arguments are not changed." + (setf new (copy-tree new)) + (setf tree (copy-tree tree)) + (let ((newcopy (make-scaffold-copy new)) + (predcopy (make-scaffold-copy pred)) + (treecopy (make-scaffold-copy tree))) + (let ((result + (apply #'subst-if new pred tree + (unless (eq key 'no-key) `(:key ,key))))) + (and (check-scaffold-copy new newcopy) + (check-scaffold-copy pred predcopy) + (check-scaffold-copy tree treecopy) + result)))) + +(defun check-subst-if-not (new pred tree &key (key 'no-key)) + "Call subst-if-not new pred tree, with various keyword arguments + if present. Check that the arguments are not changed." + (setf new (copy-tree new)) + (setf tree (copy-tree tree)) + (let ((newcopy (make-scaffold-copy new)) + (predcopy (make-scaffold-copy pred)) + (treecopy (make-scaffold-copy tree))) + (let ((result + (apply #'subst-if-not new pred tree + (unless (eq key 'no-key) `(:key ,key))))) + (and (check-scaffold-copy new newcopy) + (check-scaffold-copy pred predcopy) + (check-scaffold-copy tree treecopy) + result)))) + +(deftest subst-if-1 + (check-subst-if 'a #'consp '((100 1) (2 3) (4 3 2 1) (a b c))) + A) + +(deftest subst-if-not-1 + (check-subst-if-not '(x) 'consp '(1 (1 2) (1 2 3) (1 2 3 4))) + ((X) + ((X) (X) X) + ((X) (X) (X) X) + ((X) (X) (X) (X) X) + X)) + +(deftest subst-if-2 + (check-subst-if 17 (complement #'listp) '(a (a b) (a c d) (a nil e f g))) + (17 (17 17) (17 17 17) (17 nil 17 17 17))) + +(deftest subst-if-3 + (check-subst-if '(z) + (complement #'consp) + '(a (a b) (c d e) (f g h i))) + ((Z) + ((Z) (Z) Z) + ((Z) (Z) (Z) Z) + ((Z) (Z) (Z) (Z) Z) + Z)) + +(deftest subst-if-not-2 + (check-subst-if-not 'a (complement #'listp) + '((100 1) (2 3) (4 3 2 1) (a b c))) + A) + +(deftest subst-if-4 + (check-subst-if 'b #'identity '((100 1) (2 3) (4 3 2 1) (a b c)) + :key #'listp) + B) + +(deftest subst-if-not-3 + (check-subst-if-not 'c #'identity + '((100 1) (2 3) (4 3 2 1) (a b c)) + :key (complement #'listp)) + C) + +(deftest subst-if-5 + (check-subst-if 4 #'(lambda (x) (eql x 1)) + '((1 3) (1) (1 10 20 30) (1 3 x y)) + :key #'(lambda (x) + (and (consp x) + (car x)))) + (4 4 4 4)) + +(deftest subst-if-not-4 + (check-subst-if-not + 40 + #'(lambda (x) (not (eql x 17))) + '((17) (17 22) (17 22 31) (17 21 34 54)) + :key #'(lambda (x) + (and (consp x) + (car x)))) + (40 40 40 40)) + +(deftest subst-if-6 + (handler-case + (check-subst-if 'a #'(lambda (x) (eql x 'b)) + '((a) (b) (c) (d)) + :key nil) + (error (c) c)) +((a) (a) (c) (d))) + +(deftest subst-if-not-5 + (handler-case + (check-subst-if-not 'a #'(lambda (x) (not (eql x 'b))) + '((a) (b) (c) (d)) + :key nil) + (error (c) c)) +((a) (a) (c) (d))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Check nsubst + +(defun check-nsubst (new old tree &key (key 'no-key) test test-not) + "Call nsubst new old tree, with keyword arguments if present." + (setf new (copy-tree new)) + (setf old (copy-tree old)) + (setf tree (copy-tree tree)) + (apply #'nsubst new old tree + `(,@(unless (eq key 'no-key) `(:key ,key)) + ,@(when test `(:test ,test)) + ,@(when test-not `(:test-not ,test-not))))) + +(defvar *nsubst-tree-1* '(10 (30 20 10) (20 10) (10 20 30 40))) + +(deftest nsubst-1 + (check-nsubst "Z" 30 (copy-tree *nsubst-tree-1*)) + (10 ("Z" 20 10) (20 10) (10 20 "Z" 40))) + +(deftest nsubst-2 + (check-nsubst "A" 0 (copy-tree *nsubst-tree-1*)) + (10 (30 20 10) (20 10) (10 20 30 40))) + +(deftest nsubst-3 + (check-nsubst "Z" 100 (copy-tree *nsubst-tree-1*) :test-not #'eql) + "Z") + +(deftest nsubst-4 + (check-nsubst 'grape 'dick + '(melville wrote (moby dick))) + (MELVILLE WROTE (MOBY GRAPE))) + +(deftest nsubst-5 + (check-nsubst 'cha-cha-cha 'nil '(melville wrote (moby dick))) + (MELVILLE WROTE (MOBY DICK . CHA-CHA-CHA) . CHA-CHA-CHA)) + +(deftest nsubst-6 + (check-nsubst + '(1 2) '(foo . bar) + '((foo . baz) (foo . bar) (bar . foo) (baz foo . bar)) + :test #'equal) + ((foo . baz) (1 2) (bar . foo) (baz 1 2))) + +(deftest nsubst-7 + (check-nsubst + 'foo "aaa" + '((1 . 2) (4 . 5) (6 7 8 9 10 (11 12))) + :key #'(lambda (x) (if (and (numberp x) (evenp x)) + "aaa" + nil)) + :test #'string=) + ((1 . foo) (foo . 5) (foo 7 foo 9 foo (11 foo)))) + +(deftest nsubst-8 + (check-nsubst + 'foo nil + '((1 . 2) (4 . 5) (6 7 8 9 10 (11 12))) + :key #'(lambda (x) (if (and (numberp x) (evenp x)) + (copy-seq "aaa") + nil)) + :test-not #'equal) + ((1 . foo) (foo . 5) (foo 7 foo 9 foo (11 foo)))) + +(deftest nsubst-9 + (handler-case + (check-nsubst 'a 'b + (copy-tree '(a b c d a b)) + :key nil) + (error (c) c)) + (a a c d a a)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Check nsubst-if, nsubst-if-not + +(defun check-nsubst-if (new pred tree &key (key 'no-key)) + "Call nsubst-if new pred tree, with keyword arguments if present." + (setf new (copy-tree new)) + (setf tree (copy-tree tree)) + (apply #'nsubst-if new pred tree + (unless (eq key 'no-key) `(:key ,key)))) + +(defun check-nsubst-if-not (new pred tree &key (key 'no-key)) + "Call nsubst-if-not new pred tree, with keyword arguments if present." + (setf new (copy-tree new)) + (setf tree (copy-tree tree)) + (apply #'nsubst-if-not new pred tree + (unless (eq key 'no-key) `(:key ,key)))) + +(deftest nsubst-if-1 + (check-nsubst-if 'a #'consp '((100 1) (2 3) (4 3 2 1) (a b c))) + A) + +(deftest nsubst-if-not-1 + (check-nsubst-if-not '(x) 'consp '(1 (1 2) (1 2 3) (1 2 3 4))) + ((X) + ((X) (X) X) + ((X) (X) (X) X) + ((X) (X) (X) (X) X) + X)) + +(deftest nsubst-if-2 + (check-nsubst-if 17 (complement #'listp) '(a (a b) (a c d) (a nil e f g))) + (17 (17 17) (17 17 17) (17 nil 17 17 17))) + +(deftest nsubst-if-3 + (check-nsubst-if '(z) + (complement #'consp) + '(a (a b) (c d e) (f g h i))) + ((Z) + ((Z) (Z) Z) + ((Z) (Z) (Z) Z) + ((Z) (Z) (Z) (Z) Z) + Z)) + +(deftest nsubst-if-not-2 + (check-nsubst-if-not 'a (complement #'listp) + '((100 1) (2 3) (4 3 2 1) (a b c))) + A) + +(deftest nsubst-if-4 + (check-nsubst-if 'b #'identity '((100 1) (2 3) (4 3 2 1) (a b c)) + :key #'listp) + B) + +(deftest nsubst-if-not-3 + (check-nsubst-if-not 'c #'identity + '((100 1) (2 3) (4 3 2 1) (a b c)) + :key (complement #'listp)) + C) + +(deftest nsubst-if-5 + (check-nsubst-if 4 #'(lambda (x) (eql x 1)) + '((1 3) (1) (1 10 20 30) (1 3 x y)) + :key #'(lambda (x) + (and (consp x) + (car x)))) + (4 4 4 4)) + +(deftest nsubst-if-not-4 + (check-nsubst-if-not + 40 + #'(lambda (x) (not (eql x 17))) + '((17) (17 22) (17 22 31) (17 21 34 54)) + :key #'(lambda (x) + (and (consp x) + (car x)))) + (40 40 40 40)) + +(deftest nsubst-if-6 + (handler-case + (check-nsubst-if 'a #'(lambda (x) (eql x 'b)) + '((a) (b) (c) (d)) + :key nil) + (error (c) c)) +((a) (a) (c) (d))) + +(deftest nsubst-if-not-5 + (handler-case + (check-nsubst-if-not 'a #'(lambda (x) (not (eql x 'b))) + '((a) (b) (c) (d)) + :key nil) + (error (c) c)) +((a) (a) (c) (d))) diff --git a/ansi-tests/cons-test-03.lsp b/ansi-tests/cons-test-03.lsp new file mode 100644 index 0000000000000000000000000000000000000000..f83dc34f44193efc3863763ed0bfba219a0e7a3f --- /dev/null +++ b/ansi-tests/cons-test-03.lsp @@ -0,0 +1,197 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Mar 28 07:32:20 1998 +;;;; Contains: Testing of CL Features related to "CONS", part 3 + +(in-package :cl-test) +(use-package :rt) +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; copy-list + +(defun check-copy-list-copy (x y) + "Check that y is a copy of the list x." + (if + (consp x) + (and (consp y) + (not (eq x y)) + (eq (car x) (car y)) + (check-copy-list-copy (cdr x) (cdr y))) + (and (eq x y) t))) + +(defun check-copy-list (x) + "Apply copy-list, checking that it properly copies, + and checking that it does not change its argument." + (let ((xcopy (make-scaffold-copy x))) + (let ((y (copy-list x))) + (and + (check-scaffold-copy x xcopy) + (check-copy-list-copy x y) + y)))) + +(deftest copy-list-1 + (check-copy-list '(a b c d)) + (a b c d)) + +;; Check that copy-list works on dotted lists + +(deftest copy-list-2 + (check-copy-list '(a . b)) + (a . b)) + +(deftest copy-list-3 + (check-copy-list '(a b c . d)) + (a b c . d)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; list, list* + +(deftest list-1 + (list 'a 'b 'c) + (a b c)) + +(deftest list-2 + (list) + nil) + +(deftest list*-1 + (list* 1 2 3) + (1 2 . 3)) + +(deftest list*-2 + (list* 'a) + a) + +(deftest list-list*-1 + (list* 'a 'b 'c (list 'd 'e 'f)) + (a b c d e f)) + +(deftest list*-3 + (list* 1) + 1) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; list-length + +(deftest list-length-nil + (list-length nil) + 0) + +(deftest list-length-list + (list-length '(a b c d e f)) + 6) + + +;; check that list-length returns nil +;; on a circular list + +(deftest list-length-circular-list + (let ((x (cons nil nil))) + (let ((y (list* 1 2 3 4 5 6 7 8 9 x))) + (setf (cdr x) y) + (let ((z (list* 'a 'b 'c 'd 'e y))) + (list-length z)))) + nil) + + +;; Check that list-length produces a type-error +;; on arguments that are not proper lists or circular lists + +(deftest list-length-error + (loop + for x in (list 'a 1 1.0 #\w (make-array '(10)) + '(a b . c) (symbol-package 'cons)) + count (not (eq (catch-type-error (list-length x)) + 'type-error))) + 0) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; listp + +;; Check listp against various simple cases + +(deftest listp-nil + (not (not (listp nil))) + t) + +(deftest listp-symbol + (listp 'a) + nil) + +(deftest listp-singleton-list + (not (not (listp '(a)))) + t) + +(deftest listp-circular-list + (let ((x (cons nil nil))) + (setf (cdr x) x) + (not (not (listp x)))) + t) + +(deftest listp-longer-list + (not (not (listp '(a b c d e f g h)))) + t) + +;; Check that (listp x) == (typep x 'list) + +(deftest listp-universe + (check-type-predicate 'listp 'list) + 0) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; (typep <obj> 'list) + +;; These tests are now somewhat redundant + +(deftest typep-nil-list + (not (not (typep nil 'list))) + t) + +(deftest typep-symbol-list + (typep 'a 'list) + nil) + +(deftest typep-singleton-list-list + (not (not (typep '(a) 'list))) + t) + +(deftest typep-circular-list-list + (let ((x (cons nil nil))) + (setf (cdr x) x) + (not (not (typep x 'list)))) + t) + +(deftest typep-longer-list-list + (not (not (typep '(a b c d e f g h) 'list))) + t) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; make-list + +(deftest make-list-empty-1 + (make-list 0) + nil) + +(deftest make-list-empty-2 + (make-list 0 :initial-element 'a) + nil) + +(deftest make-list-no-initial-element + (make-list 6) + (nil nil nil nil nil nil)) + +(deftest make-list-with-initial-element + (make-list 6 :initial-element 'a) + (a a a a a a)) + +(deftest make-list-type-error-1 + (catch-type-error (make-list -1)) + type-error) + +;; This next test causes ACL 4.3 (Linux) to loop +#-allegro +(deftest make-list-type-error-2 + (catch-type-error (make-list 'a)) + type-error) diff --git a/ansi-tests/cons-test-04.lsp b/ansi-tests/cons-test-04.lsp new file mode 100644 index 0000000000000000000000000000000000000000..01f070939d017a22a2cdb6cccaaf372ef11ffded --- /dev/null +++ b/ansi-tests/cons-test-04.lsp @@ -0,0 +1,259 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Mar 28 07:33:20 1998 +;;;; Contains: Testing of CL Features related to "CONS", part 4 + +(in-package :cl-test) +(use-package :rt) + +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; push +;;; There will be a separate test suite +;;; for ACCESSORS x SETF-like macros + +(deftest push-1 + (let ((x nil)) + (push 'a x)) + (a)) + +(deftest push-2 + (let ((x 'b)) + (push 'a x) + (push 'c x)) + (c a . b)) + +(deftest push-3 + (let ((x (copy-tree '(a)))) + (push x x) + (and + (eq (car x) (cdr x)) + x)) + ((a) a)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; pop + +(deftest pop-1 + (let ((x (copy-tree '(a b c)))) + (let ((y (pop x))) + (list x y))) + ((b c) a)) + +(deftest pop-2 + (let ((x nil)) + (let ((y (pop x))) + (list x y))) + (nil nil)) + +(deftest push-and-pop + (let* ((x (copy-tree '(a b))) + (y x)) + (push 'c x) + (and + (eq (cdr x) y) + (pop x))) + c) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; pushnew + +(deftest pushnew-1 + (let ((x nil)) + (let ((y (pushnew 'a x))) + (and + (eq x y) + (equal x '(a)) + t))) + t) + +(deftest pushnew-2 + (let* ((x (copy-tree '(b c d a k f q))) + (y (pushnew 'a x))) + (and + (eq x y) + x)) + (b c d a k f q)) + +(deftest pushnew-3 + (let* ((x (copy-tree '(1 2 3 4 5 6 7 8))) + (y (pushnew 7 x))) + (and + (eq x y) + x)) + (1 2 3 4 5 6 7 8)) + +(deftest pushnew-4 + (let* ((x (copy-tree '((a b) 1 "and" c d e))) + (y (pushnew (copy-tree '(c d)) x + :test 'equal))) + (and (eq x y) + x)) + ((c d) (a b) 1 "and" c d e)) + +(deftest pushnew-5 + (let* ((x (copy-tree '((a b) 1 "and" c d e))) + (y (pushnew (copy-tree '(a b)) x + :test 'equal))) + (and + (eq x y) + x)) + ((a b) 1 "and" c d e)) + +(deftest pushnew-6 + (let* ((x (copy-tree '((a b) (c e) (d f) (g h)))) + (y (pushnew (copy-tree '(d i)) x :key #'car)) + (z (pushnew (copy-tree '(z 10)) x :key #'car))) + (and (eq y (cdr z)) + (eq z x) + x)) + ((z 10) (a b) (c e) (d f) (g h))) + +(deftest pushnew-7 + (let* ((x (copy-tree '(("abc" 1) ("def" 2) ("ghi" 3)))) + (y (pushnew (copy-tree '("def" 4)) x + :key #'car :test #'string=)) + (z (pushnew (copy-tree '("xyz" 10)) + x + :key #'car :test #'string=))) + (and + (eq y (cdr x)) + (eq x z) + x)) + (("xyz" 10) ("abc" 1) ("def" 2) ("ghi" 3))) + +(deftest pushnew-8 + (let* ((x (copy-tree '(("abc" 1) ("def" 2) ("ghi" 3)))) + (y (pushnew (copy-tree '("def" 4)) x + :key #'car :test-not (complement #'string=))) + (z (pushnew (copy-tree '("xyz" 10)) x + :key #'car :test-not (complement #'string=)))) + (and + (eq y (cdr x)) + (eq x z) + x)) + (("xyz" 10) ("abc" 1) ("def" 2) ("ghi" 3))) + +(deftest pushnew-9 + (let* ((x (copy-tree '(("abc" 1) ("def" 2) ("ghi" 3)))) + (y (pushnew (copy-tree '("def" 4)) x + :key 'car :test-not (complement #'string=))) + (z (pushnew (copy-tree '("xyz" 10)) x + :key 'car :test-not (complement #'string=)))) + (and + (eq y (cdr x)) + (eq x z) + x)) + (("xyz" 10) ("abc" 1) ("def" 2) ("ghi" 3))) + +;; Check that a NIL :key argument is the same as no key argument at all +(deftest pushnew-10 + (handler-case + (let* ((x (list 'a 'b 'c 'd)) + (result (pushnew 'z x :key nil))) + result) + (error (c) c)) + (z a b c d)) + +;; Check that a NIL :key argument is the same as no key argument at all +(deftest pushnew-11 + (handler-case + (let* ((x (copy-tree '((a b) 1 "and" c d e))) + (y (pushnew (copy-tree '(a b)) x + :test 'equal :key nil))) + (and + (eq x y) + x)) + (error (c) c)) + ((a b) 1 "and" c d e)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; adjoin + +(deftest adjoin-1 + (adjoin 'a nil) +(a)) + +(deftest adjoin-2 + (adjoin nil nil) +(nil)) + +(deftest adjoin-3 + (adjoin 'a '(a)) +(a)) + +;; Check that a NIL :key argument is the same as no key argument at all +(deftest adjoin-4 + (handler-case + (adjoin 'a '(a) :key nil) + (error (c) c)) + (a)) + +(deftest adjoin-5 + (adjoin 'a '(a) :key #'identity) + (a)) + +(deftest adjoin-6 + (adjoin 'a '(a) :key 'identity) + (a)) + +(deftest adjoin-7 + (adjoin (1+ 11) '(4 3 12 2 1)) +(4 3 12 2 1)) + +;; Check that the test is EQL, not EQ (by adjoining a bignum) +(deftest adjoin-8 + (adjoin (1+ 999999999999) '(4 1 1000000000000 3816734 a "aa")) + (4 1 1000000000000 3816734 a "aa")) + +(deftest adjoin-9 + (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a)) +("aaa" aaa "AAA" "aaa" #\a)) + +(deftest adjoin-10 + (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) :test #'equal) +(aaa "AAA" "aaa" #\a)) + +(deftest adjoin-11 + (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) :test 'equal) +(aaa "AAA" "aaa" #\a)) + +(deftest adjoin-12 + (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) + :test-not (complement #'equal)) +(aaa "AAA" "aaa" #\a)) + +(deftest adjoin-14 + (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) + :test #'equal :key #'identity) +(aaa "AAA" "aaa" #\a)) + +(deftest adjoin-15 + (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) + :test 'equal :key #'identity) +(aaa "AAA" "aaa" #\a)) + +;; Test that a :key of NIL is the same as no key at all +(deftest adjoin-16 + (handler-case + (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) + :test #'equal :key nil) + (error (c) c)) +(aaa "AAA" "aaa" #\a)) + +;; Test that a :key of NIL is the same as no key at all +(deftest adjoin-17 + (handler-case + (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) + :test 'equal :key nil) + (error (c) c)) +(aaa "AAA" "aaa" #\a)) + +;; Test that a :key of NIL is the same as no key at all +(deftest adjoin-18 + (handler-case + (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) + :test-not (complement #'equal) :key nil) + (error (c) c)) +(aaa "AAA" "aaa" #\a)) diff --git a/ansi-tests/cons-test-05.lsp b/ansi-tests/cons-test-05.lsp new file mode 100644 index 0000000000000000000000000000000000000000..1764c0dc0e6f7cadf83a2960a048fb6193b075cc --- /dev/null +++ b/ansi-tests/cons-test-05.lsp @@ -0,0 +1,137 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Mar 28 07:34:08 1998 +;;;; Contains: Testing of CL Features related to "CONS", part 5 + +(in-package :cl-test) +(use-package :rt) + +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; first, ..., tenth + +(deftest first-etc-1 + (let ((x (loop for i from 1 to 20 collect i))) + (list (first x) + (second x) + (third x) + (fourth x) + (fifth x) + (sixth x) + (seventh x) + (eighth x) + (ninth x) + (tenth x))) + (1 2 3 4 5 6 7 8 9 10)) + +(deftest first-etc-2 + (let ((x (make-list 15 :initial-element 'a))) + (and + (eql (setf (first x) 1) 1) + (eql (setf (second x) 2) 2) + (eql (setf (third x) 3) 3) + (eql (setf (fourth x) 4) 4) + (eql (setf (fifth x) 5) 5) + (eql (setf (sixth x) 6) 6) + (eql (setf (seventh x) 7) 7) + (eql (setf (eighth x) 8) 8) + (eql (setf (ninth x) 9) 9) + (eql (setf (tenth x) 10) 10) + x)) + (1 2 3 4 5 6 7 8 9 10 a a a a a)) + +(deftest rest-set-1 + (let ((x (list 'a 'b 'c))) + (and + (eq (setf (rest x) 'd) 'd) + x)) + (a . d)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; setting of C*R accessors + +(defun create-c*r-test (n) + (cond + ((<= n 0) 'none) + (t + (cons (create-c*r-test (1- n)) + (create-c*r-test (1- n)))))) + +(loop + for fn in '(car cdr caar cadr cdar cddr + caaar caadr cadar caddr cdaar cdadr cddar cdddr + caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr + cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr) + do + (let ((level (- (length (symbol-name fn)) 2))) + (eval `(deftest ,(intern + (concatenate 'string + (symbol-name fn) + "-SET") + :cl-test) + (let ((x (create-c*r-test ,level))) + (and + (setf (,fn x) 'a) + (eql (,fn x) 'a) + (setf (,fn x) 'none) + (equal x (create-c*r-test ,level)) + )) + t)))) + +(loop + for (fn len) in '((first 1) (second 2) (third 3) (fourth 4) + (fifth 5) (sixth 6) (seventh 7) (eighth 8) + (ninth 9) (tenth 10)) + do + (eval + `(deftest ,(intern + (concatenate 'string + (symbol-name fn) + "-SET") + :cl-test) + (let ((x (make-list 20 :initial-element nil))) + (and + (setf (,fn x) 'a) + (loop + for i from 1 to 20 + do (when (and (not (eql i ,len)) + (nth (1- i) x)) + (return nil)) + finally (return t)) + (eql (,fn x) 'a) + (nth ,(1- len) x))) + a))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; nth + +(defun nth-1-body (x) + (loop + for e in x + and i from 0 + count (not (eq e (nth i x))))) + +(deftest nth-1 + (nth-1-body (loop for i from 1 to 2000 collect (* 4 i))) + 0) + +(deftest nth-2 + (handler-case + (let ((x (loop for i from 1 to 2000 collect i))) + (loop + for i from 0 to 1999 do + (setf (nth i x) (- 1999 i))) + (equal x (loop for i from 1999 downto 0 collect i))) + (error (c) c)) + t) + +#| +(deftest nth-3 + (catch-type-error (nth -1 (copy-tree '(a b c)))) + type-error) + +(deftest nth-4 + (catch-type-error (nth 'a (copy-tree '(a b c)))) + type-error) +|# diff --git a/ansi-tests/cons-test-06.lsp b/ansi-tests/cons-test-06.lsp new file mode 100644 index 0000000000000000000000000000000000000000..be286ac7b715666635613f2f8a42c79a37f107ac --- /dev/null +++ b/ansi-tests/cons-test-06.lsp @@ -0,0 +1,67 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Mar 28 07:34:40 1998 +;;;; Contains: Testing of CL Features related to "CONS", part 6 + +(in-package :cl-test) +(use-package :rt) + +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; endp + +(deftest endp-nil + (not (not (endp nil))) + t) + +(deftest endp-cons + (endp (cons 'a 'a)) + nil) + +(deftest endp-singleton-list + (endp '(a)) + nil) + +(deftest endp-symbol-error + (catch-type-error (endp 'a)) + type-error) + +(deftest endp-fixnum-error + (catch-type-error (endp 1)) + type-error) + +(deftest endp-float-error + (catch-type-error (endp 0.9212d4)) + type-error) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; null + +(deftest null-1 + (null nil) + t) + +(deftest null-2 + (not (some #'null + `(1 a 1.2 "a" #\w (a) ,*terminal-io* + #'car (make-array '(10))))) + t) + +(deftest not-1 + (not nil) + t) + +(deftest not-2 + (not (some #'not + `(1 a 1.2 "a" #\w (a) ,*terminal-io* + #'car (make-array '(10))))) + t) + +(deftest typep-nil-null + (not (not (typep nil 'null))) + t) + +(deftest typep-t-null + (typep t 'null) + nil) diff --git a/ansi-tests/cons-test-07.lsp b/ansi-tests/cons-test-07.lsp new file mode 100644 index 0000000000000000000000000000000000000000..e4170a1959aa6b4501c728059911a97a8f7f429c --- /dev/null +++ b/ansi-tests/cons-test-07.lsp @@ -0,0 +1,155 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Mar 28 07:35:15 1998 +;;;; Contains: Testing of CL Features related to "CONS", part 7 + +(in-package :cl-test) +(use-package :rt) + +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; nconc + +(deftest nconc-1 + (nconc) + nil) + +(deftest nconc-2 + (nconc (copy-tree '(a b c d e f))) + (a b c d e f)) + +(deftest nconc-3 + (nconc 1) + 1) + +(deftest nconc-4 + (let ((x (list 'a 'b 'c)) + (y (list 'd 'e 'f))) + (let ((ycopy (make-scaffold-copy y))) + (let ((result (nconc x y))) + (and + (check-scaffold-copy y ycopy) + (eq (cdddr x) y) + result)))) + (a b c d e f)) + +(deftest nconc-5 + (let ((x (list 'a 'b 'c))) + (nconc x x) + (and + (eq (cdddr x) x) + (null (list-length x)))) + t) + +(deftest nconc-6 + (let ((x (list 'a 'b 'c)) + (y (list 'd 'e 'f 'g 'h)) + (z (list 'i 'j 'k))) + (let ((result (nconc x y z 'foo))) + (and + (eq (nthcdr 3 x) y) + (eq (nthcdr 5 y) z) + (eq (nthcdr 3 z) 'foo) + result))) + (a b c d e f g h i j k . foo)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; append + +(deftest append-1 + (append) + nil) + +(deftest append-2 + (append 'x) + x) + +(deftest append-3 + (let ((x (list 'a 'b 'c 'd)) + (y (list 'e 'f 'g))) + (let ((xcopy (make-scaffold-copy x)) + (ycopy (make-scaffold-copy y))) + (let ((result (append x y))) + (and + (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy) + result)))) + (a b c d e f g)) + +(deftest append-4 + (append (list 'a) (list 'b) (list 'c) + (list 'd) (list 'e) (list 'f) + (list 'g) 'h) + (a b c d e f g . h)) + +(deftest append-5 + (append nil nil nil nil nil nil nil nil 'a) + a) + +#| +(defun append-6-body () + (let ((step (max 1 (min 256 (floor (/ call-arguments-limit 64)))))) + (loop + for n from 0 + to call-arguments-limit + by step + count + (not + (equal + (apply #'append (loop for i from 1 to n + collect '(a))) + (make-list n :initial-element 'a)))))) +(deftest append-6 + (cons-178-body) + 0) +|# + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; revappend + +(deftest revappend-1 + (let* ((x (list 'a 'b 'c)) + (y (list 'd 'e 'f)) + (xcopy (make-scaffold-copy x)) + (ycopy (make-scaffold-copy y)) + ) + (let ((result (revappend x y))) + (and + (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy) + (eq (cdddr result) y) + result))) + (c b a d e f)) + +(deftest revappend-2 + (revappend (copy-tree '(a b c d e)) 10) + (e d c b a . 10)) + +(deftest revappend-3 + (revappend nil 'a) + a) + +(deftest revappend-4 + (revappend (copy-tree '(a (b c) d)) nil) + (d (b c) a)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; nreconc + +(deftest nreconc-1 + (let* ((x (list 'a 'b 'c)) + (y (nreverse (loop for e on x collect e)))) + (setf x (nreconc x (copy-tree '(d e f)))) + (and (eq x (car y)) + (eq (cdr x) (cadr y)) + (eq (cddr x) (caddr y)) + x)) + (c b a d e f)) + +(deftest nreconc-2 + (handler-case + (nreconc nil 'a) + (error (c) c)) + a) diff --git a/ansi-tests/cons-test-08.lsp b/ansi-tests/cons-test-08.lsp new file mode 100644 index 0000000000000000000000000000000000000000..8d83eb9a2bed66511dc88a8bbc9afb605d11d36b --- /dev/null +++ b/ansi-tests/cons-test-08.lsp @@ -0,0 +1,48 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Mar 28 07:36:01 1998 +;;;; Contains: Testing of CL Features related to "CONS", part 8 + +(in-package :cl-test) +(use-package :rt) + +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Error checking car, cdr, list-length + +(deftest car-1 + (catch-type-error (car '(a))) + a) + +(deftest car-nil + (catch-type-error (car nil)) + nil) + +(deftest car-symbol-error + (catch-type-error (car 'a)) + type-error) + +(deftest cdr-1 + (catch-type-error (cdr '(a b))) + (b)) + +(deftest cdr-nil + (catch-type-error (cdr ())) + nil) + +(deftest cdr-symbol-error + (catch-type-error (cdr 'a)) + type-error) + +(deftest list-length-4 + (catch-type-error (list-length (copy-tree '(a b c)))) + 3) + +(deftest list-length-symbol + (catch-type-error (list-length 'a)) + type-error) + +(deftest list-length-dotted-list + (catch-type-error (list-length (copy-tree '(a b c d . e)))) + type-error) diff --git a/ansi-tests/cons-test-09.lsp b/ansi-tests/cons-test-09.lsp new file mode 100644 index 0000000000000000000000000000000000000000..fdd50320f2a950aa5bf2ea00ad9eec886e3f6d47 --- /dev/null +++ b/ansi-tests/cons-test-09.lsp @@ -0,0 +1,127 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Mar 28 07:36:30 1998 +;;;; Contains: Testing of CL Features related to "CONS", part 9 + +(in-package :cl-test) +(use-package :rt) +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; butlast, nbutlast + +(deftest butlast-1 + (let ((x (list 'a 'b 'c 'd 'e))) + (let ((xcopy (make-scaffold-copy x))) + (let ((result (butlast x 2))) + (and + (check-scaffold-copy x xcopy) + result)))) + (a b c)) + +(deftest butlast-2 + (let ((x (list 'a 'b 'c 'd 'e))) + (let ((xcopy (make-scaffold-copy x))) + (let ((result (butlast x 0))) + (and + (check-scaffold-copy x xcopy) + result)))) + (a b c d e)) + +(deftest butlast-3 + (let ((x (list 'a 'b 'c 'd 'e))) + (let ((xcopy (make-scaffold-copy x))) + (let ((result (butlast x 5))) + (and + (check-scaffold-copy x xcopy) + result)))) + nil) + +(deftest butlast-4 + (let ((x (list 'a 'b 'c 'd 'e))) + (let ((xcopy (make-scaffold-copy x))) + (let ((result (butlast x 6))) + (and + (check-scaffold-copy x xcopy) + result)))) + nil) + +(deftest butlast-5 + (catch-type-error (butlast (copy-tree '(a b c . d)) 1)) + (a b)) + +(deftest butlast-6 + (catch-type-error (butlast (copy-tree '(a b c d)) 'a)) + type-error) + +(deftest butlast-7 + (catch-type-error (butlast 'a 0)) + type-error) + +(deftest nbutlast-1 + (let ((x (list 'a 'b 'c 'd 'e))) + (let ((y (cdr x)) + (z (cddr x))) + (let ((result (nbutlast x 2))) + (and (eq x result) + (eq (cdr x) y) + (eq (cddr x) z) + result)))) + (a b c)) + +(deftest nbutlast-2 + (let ((x (list 'a 'b 'c 'd 'e))) + (let ((result (nbutlast x 5))) + (list x result))) + ((a b c d e) nil)) + +(deftest nbutlast-3 + (let ((x (list 'a 'b 'c 'd 'e))) + (let ((result (nbutlast x 500))) + (list x result))) + ((a b c d e) nil)) + +(deftest nbutlast-4 + (let ((x (list* 'a 'b 'c 'd))) + (let ((result (catch-type-error (nbutlast x 1)))) + (and (eq result x) + result))) + (a b)) + +(deftest nbutlast-5 + (let ((x (list* 'a 'b 'c 'd))) + (let ((result (catch-type-error (nbutlast x 'a)))) + result)) + type-error) + +(deftest nbutlast-6 + (catch-type-error (nbutlast 'a 10)) + type-error) + +(deftest nbutlast-7 + (catch-type-error (nbutlast 2 10)) + type-error) + +(deftest nbutlast-8 + (catch-type-error (nbutlast #\w 10)) + type-error) + +(deftest nbutlast-9 + (catch-type-error (nbutlast (list 'a 'b 'c 'd) -3)) + type-error) + +(deftest nbutlast-10 + (nbutlast nil) + nil) + +(deftest nbutlast-11 + (nbutlast (list 'a)) + nil) + +(deftest nbutlast-12 + (catch-type-error (nbutlast (list 'a) 20.0)) + type-error) + +(deftest nbutlast-13 + (catch-type-error (nbutlast (list 'a) -100.0)) + type-error) diff --git a/ansi-tests/cons-test-10.lsp b/ansi-tests/cons-test-10.lsp new file mode 100644 index 0000000000000000000000000000000000000000..5acbc1a9a42971a2b396d6d7ed94ec36a19db982 --- /dev/null +++ b/ansi-tests/cons-test-10.lsp @@ -0,0 +1,71 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Mar 28 07:37:21 1998 +;;;; Contains: Testing of CL Features related to "CONS", part 10 + +(in-package :cl-test) +(use-package :rt) +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; last + +(deftest last-1 + (last nil) + nil) + +(deftest last-2 + (last (copy-tree '(a b))) + (b)) + +(deftest last-3 + (last (copy-tree '(a b . c))) + (b . c)) + +(deftest last-4 + (last (copy-tree '(a b c d)) 0) + nil) + +(deftest last-5 + (last (copy-tree '(a b c d)) 1) + (d)) + +(deftest last-6 + (last (copy-tree '(a b c d)) 2) + (c d)) + +(deftest last-7 + (last (copy-tree '(a b c d)) 5) + (a b c d)) + +(deftest last-8 + (last (cons 'a 'b) 0) + b) + +(deftest last-9 + (last (cons 'a 'b) 1) + (a . b)) + +(deftest last-10 + (last (cons 'a 'b) 2) + (a . b)) + +(deftest last-11 + (catch-type-error (last (list 'a 'b 'c) -1)) + type-error) + +(deftest last-12 + (catch-type-error (last (list 'a 'b 'c) 'a)) + type-error) + +(deftest last-13 + (catch-type-error (last (list 'a 'b 'c) 10.0)) + type-error) + +(deftest last-14 + (catch-type-error (last (list 'a 'b 'c) -10.0)) + type-error) + +(deftest last-15 + (catch-type-error (last (list 'a 'b 'c) #\w)) + type-error) diff --git a/ansi-tests/cons-test-11.lsp b/ansi-tests/cons-test-11.lsp new file mode 100644 index 0000000000000000000000000000000000000000..6e536d718ca57ffcec575991ff4725e6f555537f --- /dev/null +++ b/ansi-tests/cons-test-11.lsp @@ -0,0 +1,226 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Mar 28 07:37:56 1998 +;;;; Contains: Testing of CL Features related to "CONS", part 11 + +(in-package :cl-test) +(use-package :rt) +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ldiff, tailp + +(deftest ldiff-1 + (let* ((x (copy-tree '(a b c d e f))) + (xcopy (make-scaffold-copy x))) + (let ((result (ldiff x (cdddr x)))) + (and (check-scaffold-copy x xcopy) + result))) + (a b c)) + +(deftest ldiff-2 + (handler-case + (let* ((x (copy-tree '(a b c d e f))) + (xcopy (make-scaffold-copy x))) + (let ((result (ldiff x 'a))) + (and + (check-scaffold-copy x xcopy) + (zerop + (loop + for a on x and b on result count + (eq a b))) + result))) + (error (c) c)) + (a b c d e f)) + +;; Works when the end of the dotted list is a symbol +(deftest ldiff-3 + (let* ((x (copy-tree '(a b c d e . f))) + (xcopy (make-scaffold-copy x))) + (let ((result (catch-type-error (ldiff x 'a)))) + (and + (check-scaffold-copy x xcopy) + result))) + (a b c d e . f)) + +;; Works when the end of the dotted list is a fixnum +(deftest ldiff-4 + (let* ((n 18) + (x (list* 'a 'b 'c 18)) + (xcopy (make-scaffold-copy x))) + (let ((result (catch-type-error (ldiff x n)))) + (and + (check-scaffold-copy x xcopy) + result))) + (a b c)) + +;; Works when the end of the dotted list is a larger +;; integer (that is eql, but probably not eq). +(deftest ldiff-5 + (let* ((n 18000000000000) + (x (list* 'a 'b 'c (1- 18000000000001))) + (xcopy (make-scaffold-copy x))) + (let ((result (catch-type-error (ldiff x n)))) + (and + (check-scaffold-copy x xcopy) + result))) + (a b c)) + +;; Test works when the end of a dotted list is a string +(deftest ldiff-6 + (let* ((n (copy-seq "abcde")) + (x (list* 'a 'b 'c n)) + (xcopy (make-scaffold-copy x))) + (let ((result (catch-type-error (ldiff x n)))) + (if (equal result (list 'a 'b 'c)) + (check-scaffold-copy x xcopy) + result))) + t) + +;; Check that having the cdr of a dotted list be string-equal, but +;; not eql, does not result in success +(deftest ldiff-6b + (let* ((n (copy-seq "abcde")) + (x (list* 'a 'b 'c n)) + (xcopy (make-scaffold-copy x))) + (let ((result (catch-type-error (ldiff x (copy-seq n))))) + (if (equal result x) + (check-scaffold-copy x xcopy) + result))) + t) + +;; Check that on failure, the list returned by ldiff is +;; a copy of the list, not the list itself. + +(deftest ldiff-6a + (let ((x (list 'a 'b 'c 'd))) + (let ((result (ldiff x '(e)))) + (and (equal x result) + (loop + for c1 on x + for c2 on result + count (eq c1 c2))))) + 0) + + +;; Error checking + +(deftest ldiff-7 + (catch-type-error (ldiff 10 'a)) + type-error) + +;; Single atoms are not dotted lists, so the next +;; case should be a type-error +(deftest ldiff-8 + (catch-type-error (ldiff 'a 'a)) + type-error) + +(deftest ldiff-9 + (catch-type-error (ldiff (make-array '(10) :initial-element 'a) '(a))) + type-error) + +(deftest ldiff-10 + (catch-type-error (ldiff 1.23 t)) + type-error) + +(deftest ldiff-11 + (catch-type-error (ldiff #\w 'a)) + type-error) + +;; Note! The spec is ambiguous on whether this next test +;; is correct. The spec says that ldiff should be prepared +;; to signal an error if the list argument is not a proper +;; list or dotted list. If listp is false, the list argument +;; is neither (atoms are not dotted lists). +;; +;; However, the sample implementation *does* work even if +;; the list argument is an atom. +;; +#| +(defun ldiff-12-body () + (loop + for x in *universe* + count (and (not (listp x)) + (not (eq 'type-error + (catch-type-error (ldiff x x))))))) + +(deftest ldiff-12 + (ldiff-12-body) + 0) +|# + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; tailp + +(deftest tailp-1 + (let ((x (copy-tree '(a b c d e . f)))) + (and + (tailp x x) + (tailp (cdr x) x) + (tailp (cddr x) x) + (tailp (cdddr x) x) + (tailp (cddddr x) x) + t)) + t) + + +;; The next four tests test that tailp handles dotted lists. See +;; TAILP-NIL:T in the X3J13 documentation. + +(deftest tailp-2 + (catch-type-error (not (not (tailp 'e (copy-tree '(a b c d . e)))))) + t) + +(deftest tailp-3 + (catch-type-error (tailp 'z (copy-tree '(a b c d . e)))) + nil) + +(deftest tailp-4 + (catch-type-error (not (not (tailp 10203040506070 + (list* 'a 'b (1- 10203040506071)))))) + t) + +(deftest tailp-5 + (let ((x "abcde")) + (catch-type-error (tailp x + (list* 'a 'b (copy-seq x))))) + nil) + +;; Test that tailp does not modify its arguments + +(deftest tailp-6 + (let* ((x (copy-list '(a b c d e))) + (y (cddr x))) + (let ((xcopy (make-scaffold-copy x)) + (ycopy (make-scaffold-copy y))) + (and + (tailp y x) + (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy)))) + t) + +;; Error checking + +;; Note! The spec is ambiguous on whether this next test +;; is correct. The spec says that tailp should be prepared +;; to signal an error if the list argument is not a proper +;; list or dotted list. If listp is false, the list argument +;; is neither (atoms are not dotted lists). +;; +;; However, the sample implementation *does* work even if +;; the list argument is an atom. +;; + +#| +(defun tailp-7-body () + (loop + for x in *universe* + count (and (not (listp x)) + (eq 'type-error + (catch-type-error (tailp x x)))))) + +(deftest tailp-7 + (tailp-7-body) + 0) +|# + \ No newline at end of file diff --git a/ansi-tests/cons-test-12.lsp b/ansi-tests/cons-test-12.lsp new file mode 100644 index 0000000000000000000000000000000000000000..f96150ae5b94d28b6781eab9739a9a85a88b7b6d --- /dev/null +++ b/ansi-tests/cons-test-12.lsp @@ -0,0 +1,67 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Mar 28 07:38:26 1998 +;;;; Contains: Testing of CL Features related to "CONS", part 12 + +(in-package :cl-test) +(use-package :rt) +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; nthcdr + +(deftest nthcdr-1 + (catch-type-error (nthcdr nil (copy-tree '(a b c d)))) + type-error) + +(deftest nthcdr-2 + (catch-type-error (nthcdr 'a (copy-tree '(a b c d)))) + type-error) + +(deftest nthcdr-3 + (catch-type-error (nthcdr 0.1 (copy-tree '(a b c d)))) + type-error) + +(deftest nthcdr-4 + (catch-type-error (nthcdr #\A (copy-tree '(a b c d)))) + type-error) + +(deftest nthcdr-5 + (catch-type-error (nthcdr '(a) (copy-tree '(a b c d)))) + type-error) + +(deftest nthcdr-6 + (catch-type-error (nthcdr -10 (copy-tree '(a b c d)))) + type-error) + +(deftest nthcdr-7 + (nthcdr 0 (copy-tree '(a b c d . e))) + (a b c d . e)) + +(deftest nthcdr-8 + (nthcdr 1 (copy-tree '(a b c d))) + (b c d)) + +(deftest nthcdr-9 + (nthcdr 10 nil) + nil) + +(deftest nthcdr-10 + (nthcdr 4 (list 'a 'b 'c)) + nil) + +(deftest nthcdr-11 + (nthcdr 1 (cons 'a 'b)) + b) + +(deftest nthcdr-12 + (catch-type-error (nthcdr 3 (cons 'a 'b))) + type-error) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; rest + +(deftest rest-1 + (rest (list 'a 'b 'c)) + (b c)) diff --git a/ansi-tests/cons-test-13.lsp b/ansi-tests/cons-test-13.lsp new file mode 100644 index 0000000000000000000000000000000000000000..58b7ebef2a65b4bb7638e394261705a9d07707a3 --- /dev/null +++ b/ansi-tests/cons-test-13.lsp @@ -0,0 +1,177 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Mar 28 07:38:57 1998 +;;;; Contains: Testing of CL Features related to "CONS", part 13 + +(in-package :cl-test) +(use-package :rt) +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; member + +(deftest member-1 + (let* ((x (copy-tree '(a b c d e f))) + (xcopy (make-scaffold-copy x)) + (result (member 'c x))) + (and + (eq result (cddr x)) + (check-scaffold-copy x xcopy))) + t) + +(deftest member-2 + (let* ((x (copy-tree '(a b c d e f))) + (xcopy (make-scaffold-copy x)) + (result (member 'e x))) + (and + (eq result (cddddr x)) + (check-scaffold-copy x xcopy))) + t) + +(deftest member-3 + (let* ((x (copy-tree '(1 2 3 4 5 6 7))) + (xcopy (make-scaffold-copy x)) + (result (member 4 x))) + (and + (eq result (cdddr x)) + (check-scaffold-copy x xcopy))) + t) + +(deftest member-4 + (let* ((x (copy-tree '(2 4 6 8 10 12))) + (xcopy (make-scaffold-copy x)) + (result (member 9 x :key #'1+))) + (and + (eq result (cdddr x)) + (check-scaffold-copy x xcopy))) + t) + +(deftest member-5 + (let* ((x (copy-tree '((a b) (c d) (e f) (g h)))) + (xcopy (make-scaffold-copy x)) + (result (member '(c d) x :test #'equal))) + (and + (eq result (cdr x)) + (check-scaffold-copy x xcopy))) + t) + +(deftest member-6 + (let* ((x (copy-tree '((a b) (c d) (e f) (g h)))) + (xcopy (make-scaffold-copy x)) + (result (member 'c x :key #'car))) + (and + (eq result (cdr x)) + (check-scaffold-copy x xcopy))) + t) + +(deftest member-7 + (let* ((x (copy-tree '((a b) (c d) (e f) (g h)))) + (xcopy (make-scaffold-copy x)) + (result (member 'c x :key #'car :test #'eq))) + (and + (eq result (cdr x)) + (check-scaffold-copy x xcopy))) + t) + +(deftest member-8 + (let* ((x (copy-tree '((a b) (c d) (e f) (g h)))) + (xcopy (make-scaffold-copy x)) + (result (member 'c x :key #'car :test-not (complement #'eq)))) + (and + (eq result (cdr x)) + (check-scaffold-copy x xcopy))) + t) + +(deftest member-9 + (let* ((x (copy-tree '((a b) (c d) (e f) (g h)))) + (xcopy (make-scaffold-copy x)) + (result (member 'c x :key #'car :test #'eql))) + (and + (eq result (cdr x)) + (check-scaffold-copy x xcopy))) + t) + +(deftest member-10 + (let* ((x (copy-tree '((a b) (c d) (e f) (g h)))) + (xcopy (make-scaffold-copy x)) + (result (member (list 'd) x :key #'cdr :test #'equal))) + (and + (eq result (cdr x)) + (check-scaffold-copy x xcopy))) + t) + +(deftest member-11 + (member (copy-seq "cc") (copy-tree '("aa" "bb" "cc" "dd" "ee"))) + nil) + +(deftest member-12 + (member 1 (copy-tree '(3 4 1 31 423))) + (1 31 423)) + +(deftest member-13 + (member (copy-seq "cc") (copy-tree '("aa" "bb" "cc" "dd" "ee")) + :test #'equal) + ("cc" "dd" "ee")) + +(deftest member-14 + (member 'a nil) + nil) + +(deftest member-15 + (member nil nil) + nil) + +(deftest member-16 + (member nil nil :test #'equal) + nil) + +(deftest member-16-a + (member nil nil :test #'(lambda (x y) (error "Should not call this function"))) + nil) + +(deftest member-17 + (member 'a nil :test #'(lambda (x y) (error "Should not call this function"))) + nil) + +(deftest member-18 + (catch-type-error (member 'a 'b)) + type-error) + +(deftest member-19 + (catch-type-error (member 'a 1.3)) + type-error) + +(deftest member-20 + (catch-type-error (member 'a 1)) + type-error) + +(deftest member-21 + (catch-type-error (member 'a 0)) + type-error) + +(deftest member-22 + (catch-type-error (member 'a "abcde")) + type-error) + +(deftest member-23 + (catch-type-error (member 'a #\w)) + type-error) + +(deftest member-24 + (catch-type-error (member 'a t)) + type-error) + +;; Check that a null key argument is ignored + +(deftest member-25 + (handler-case + (member 'a '(c d a b e) :key nil) + (error (c) c)) + (a b e)) + +(deftest member-26 + (handler-case + (member 'z '(a b c d) :key nil) + (error (c) c)) + nil) + diff --git a/ansi-tests/cons-test-14.lsp b/ansi-tests/cons-test-14.lsp new file mode 100644 index 0000000000000000000000000000000000000000..f7ffb326c7cff16efc9c07f9f04709eb231fda4a --- /dev/null +++ b/ansi-tests/cons-test-14.lsp @@ -0,0 +1,73 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Mar 28 07:39:29 1998 +;;;; Contains: Testing of CL Features related to "CONS", part 14 + +(in-package :cl-test) +(use-package :rt) +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; member-if + +(deftest member-if-1 + (member-if #'listp nil) + nil) + +(deftest member-if-2 + (member-if #'(lambda (x) (eq x 'a)) '(1 2 a 3 4)) + (a 3 4)) + +(deftest member-if-3 + (member-if #'(lambda (x) (eql x 12)) '(4 12 11 73 11) :key #'1+) + (11 73 11)) + +(deftest member-if-4 + (let ((test-inputs + `(1 a 11.3121 11.31s3 1.123f5 -1 0 + 13.13122d34 581.131e-10 + (a b c . d) + ,(make-array '(10)) + "ancadas" #\w))) + (not (every + #'(lambda (x) + (let ((result (catch-type-error (member-if #'listp x)))) + (or (eq result 'type-error) + (progn + (format t "~%On ~S: returned ~%~S" x result) + nil)))) + test-inputs))) + nil) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; member-if-not + +(deftest member-if-not-1 + (member-if-not #'listp nil) + nil) + +(deftest member-if-not-2 + (member-if-not #'(lambda (x) (eq x 'a)) '(a 1 2 a 3 4)) + (1 2 a 3 4)) + +(deftest member-if-not-3 + (member-if-not #'(lambda (x) (not (eql x 12))) '(4 12 11 73 11) :key #'1+) + (11 73 11)) + +(deftest member-if-not-4 + (let ((test-inputs + `(1 a 11.3121 11.31s3 1.123f5 -1 0 + 13.13122d34 581.131e-10 + ((a) (b) (c) . d) + ,(make-array '(10)) + "ancadas" #\w))) + (not (every + #'(lambda (x) + (let ((result (catch-type-error (member-if-not #'listp x)))) + (or (eq result 'type-error) + (progn + (format t "~%On x = ~S, returns: ~%~S" x result) + nil)))) + test-inputs))) + nil) diff --git a/ansi-tests/cons-test-15.lsp b/ansi-tests/cons-test-15.lsp new file mode 100644 index 0000000000000000000000000000000000000000..3ace94fb187c67aad147712e6c1a940c61a89141 --- /dev/null +++ b/ansi-tests/cons-test-15.lsp @@ -0,0 +1,441 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Mar 28 07:40:12 1998 +;;;; Contains: Testing of CL Features related to "CONS", part 15 + +(in-package :cl-test) +(use-package :rt) +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; mapc + +(deftest mapc-1 + (mapc #'list nil) + nil) + +(deftest mapc-2 + (let ((x 0)) + (let ((result + (mapc #'(lambda (y) (incf x y)) + '(1 2 3 4)))) + (list result x))) + ((1 2 3 4) 10)) + +(deftest mapc-3 + (let ((x 0)) + (list + (mapc #'(lambda (y z) (declare (ignore y z)) (incf x)) + (make-list 5 :initial-element 'a) + (make-list 5 )) + x)) + ((a a a a a) 5)) + +(deftest mapc-4 + (let ((x 0)) + (list + (mapc #'(lambda (y z) (declare (ignore y z)) (incf x)) + (make-list 5 :initial-element 'a) + (make-list 10)) + x)) + ((a a a a a) 5)) + +(deftest mapc-5 + (let ((x 0)) + (list + (mapc #'(lambda (y z) (declare (ignore y z)) (incf x)) + (make-list 5 :initial-element 'a) + (make-list 3)) + x)) + ((a a a a a) 3)) + +(defvar *mapc-6-var* nil) +(defun mapc-6-fun (x) + (push x *mapc-6-var*) + x) + +(deftest mapc-6 + (let* ((x (copy-list '(a b c d e f g h))) + (xcopy (make-scaffold-copy x))) + (setf *mapc-6-var* nil) + (let ((result (mapc 'mapc-6-fun x))) + (and (check-scaffold-copy x xcopy) + (eq result x) + *mapc-6-var*))) + (h g f e d c b a)) + +(deftest mapc-7 + (handler-case + (mapc (gensym) '(a b c)) + (error () 'error)) + error) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; mapcar + +(deftest mapcar-1 + (mapcar #'1+ nil) + nil) + +(deftest mapcar-2 + (let* ((x (copy-list '(1 2 3 4))) + (xcopy (make-scaffold-copy x))) + (let ((result (mapcar #'1+ x))) + (and (check-scaffold-copy x xcopy) + result))) + (2 3 4 5)) + +(deftest mapcar-3 + (let* ((n 0) + (x (copy-list '(a b c d))) + (xcopy (make-scaffold-copy x))) + (let ((result + (mapcar #'(lambda (y) (declare (ignore y)) (incf n)) + x))) + (and (check-scaffold-copy x xcopy) + result))) + (1 2 3 4)) + +(deftest mapcar-4 + (let* ((n 0) + (x (copy-list '(a b c d))) + (xcopy (make-scaffold-copy x)) + (x2 (copy-list '(a b c d e f))) + (x2copy (make-scaffold-copy x2)) + (result + (mapcar #'(lambda (y z) (declare (ignore y z)) (incf n)) + x x2))) + (and (check-scaffold-copy x xcopy) + (check-scaffold-copy x2 x2copy) + (list result n))) + ((1 2 3 4) 4)) + +(deftest mapcar-5 + (let* ((n 0) + (x (copy-list '(a b c d))) + (xcopy (make-scaffold-copy x)) + (x2 (copy-list '(a b c d e f))) + (x2copy (make-scaffold-copy x2)) + (result + (mapcar #'(lambda (y z) (declare (ignore y z)) (incf n)) + x2 x))) + (and (check-scaffold-copy x xcopy) + (check-scaffold-copy x2 x2copy) + (list result n))) + ((1 2 3 4) 4)) + +(deftest mapcar-6 + (let* ((x (copy-list '(a b c d e f g h))) + (xcopy (make-scaffold-copy x))) + (setf *mapc-6-var* nil) + (let ((result (mapcar 'mapc-6-fun x))) + (and (check-scaffold-copy x xcopy) + (list *mapc-6-var* result)))) + ((h g f e d c b a) (a b c d e f g h))) + +(deftest mapcar-7 + (handler-case + (mapcar (gensym) '(a b c)) + (error () 'error)) + error) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; mapcan + +(deftest mapcan-1 + (mapcan #'list nil) + nil) + +(deftest mapcan-2 + (mapcan #'list (copy-list '(a b c d e f))) + (a b c d e f)) + +(deftest mapcan-3 + (let* ((x (list 'a 'b 'c 'd)) + (xcopy (make-scaffold-copy x)) + (result (mapcan #'list x))) + (and + (= (length x) (length result)) + (check-scaffold-copy x xcopy) + (loop + for e1 on x + and e2 on result + count (or (eq e1 e2) (not (eql (car e1) (car e2))))))) + 0) + +(deftest mapcan-4 + (mapcan #'list + (copy-list '(1 2 3 4)) + (copy-list '(a b c d))) + (1 a 2 b 3 c 4 d)) + +(deftest mapcan-5 + (mapcan #'(lambda (x y) (make-list y :initial-element x)) + (copy-list '(a b c d)) + (copy-list '(1 2 3 4))) + (a b b c c c d d d d)) + +(defvar *mapcan-6-var* nil) +(defun mapcan-6-fun (x) + (push x *mapcan-6-var*) + (copy-list *mapcan-6-var*)) + +(deftest mapcan-6 + (progn + (setf *mapcan-6-var* nil) + (mapcan 'mapcan-6-fun (copy-list '(a b c d)))) + (a b a c b a d c b a)) + +(deftest mapcan-7 + (mapcan #'(lambda (x y) (make-list y :initial-element x)) + (copy-list '(a b c d)) + (copy-list '(1 2 3 4 5 6))) + (a b b c c c d d d d)) + +(deftest mapcan-8 + (mapcan #'(lambda (x y) (make-list y :initial-element x)) + (copy-list '(a b c d e f)) + (copy-list '(1 2 3 4))) + (a b b c c c d d d d)) + +(deftest mapcan-9 + (mapcan #'list + (copy-list '(a b c d)) + (copy-list '(1 2 3 4)) + nil) + nil) + +(deftest mapcan-10 + (handler-case + (mapcan (gensym) (copy-list '(a b c))) + (error () 'error)) + error) + +(deftest mapcan-11 + (handler-case + (mapcan 1 (copy-list '(a b c))) + (error () 'error)) + error) + +(deftest mapcan-12 + (handler-case + (mapcan 1.234 (copy-list '(a b c))) + (error () 'error)) + error) + +(deftest mapcan-13 + (handler-case + (mapcan "foo" (copy-list '(a b c))) + (error () 'error)) + error) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; mapl + +(deftest mapl-1 + (mapl #'list nil) + nil) + +(deftest mapl-2 + (let* ((a nil) + (x (copy-list '(a b c))) + (xcopy (make-scaffold-copy x)) + (result + (mapl #'(lambda (y) (push y a)) + x))) + (and + (check-scaffold-copy x xcopy) + (eq result x) + a)) + ((c) (b c) (a b c))) + +(deftest mapl-3 + (let* ((a nil) + (x (copy-list '(a b c d))) + (y (copy-list '(1 2 3 4))) + (xcopy (make-scaffold-copy x)) + (ycopy (make-scaffold-copy y)) + (result + (mapl #'(lambda (xtail ytail) + (setf a + (append (mapcar #'list xtail ytail) + a))) + x y))) + (and + (eq result x) + (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy) + a)) + ((d 4) (c 3) (d 4) (b 2) (c 3) (d 4) + (a 1) (b 2) (c 3) (d 4))) + +(deftest mapl-4 + (let* ((a nil) + (x (copy-list '(a b c d))) + (y (copy-list '(1 2 3 4 5 6 7 8))) + (xcopy (make-scaffold-copy x)) + (ycopy (make-scaffold-copy y)) + (result + (mapl #'(lambda (xtail ytail) + (setf a + (append (mapcar #'list xtail ytail) + a))) + x y))) + (and + (eq result x) + (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy) + a)) + ((d 4) (c 3) (d 4) (b 2) (c 3) (d 4) + (a 1) (b 2) (c 3) (d 4))) + +(deftest mapl-5 + (let* ((a nil) + (x (copy-list '(a b c d e f g))) + (y (copy-list '(1 2 3 4))) + (xcopy (make-scaffold-copy x)) + (ycopy (make-scaffold-copy y)) + (result + (mapl #'(lambda (xtail ytail) + (setf a + (append (mapcar #'list xtail ytail) + a))) + x y))) + (and + (eq result x) + (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy) + a)) + ((d 4) (c 3) (d 4) (b 2) (c 3) (d 4) + (a 1) (b 2) (c 3) (d 4))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; maplist + +(deftest maplist-1 + (maplist #'list nil) + nil) + +(deftest maplist-2 + (let* ((x (copy-list '(a b c))) + (xcopy (make-scaffold-copy x)) + (result (maplist #'identity x))) + (and (check-scaffold-copy x xcopy) + result)) + ((a b c) (b c) (c))) + +(deftest maplist-3 + (let* ((x (copy-list '(a b c d))) + (y (copy-list '(1 2 3 4))) + (xcopy (make-scaffold-copy x)) + (ycopy (make-scaffold-copy y)) + (result + (maplist #'append x y))) + (and + (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy) + result)) + ((a b c d 1 2 3 4) + (b c d 2 3 4) + (c d 3 4) + (d 4))) + +(deftest maplist-4 + (let* ((x (copy-list '(a b c d))) + (y (copy-list '(1 2 3 4 5))) + (xcopy (make-scaffold-copy x)) + (ycopy (make-scaffold-copy y)) + (result + (maplist #'append x y))) + (and + (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy) + result)) + ((a b c d 1 2 3 4 5) + (b c d 2 3 4 5) + (c d 3 4 5) + (d 4 5))) + +(deftest maplist-5 + (let* ((x (copy-list '(a b c d e))) + (y (copy-list '(1 2 3 4))) + (xcopy (make-scaffold-copy x)) + (ycopy (make-scaffold-copy y)) + (result + (maplist #'append x y))) + (and + (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy) + result)) + ((a b c d e 1 2 3 4) + (b c d e 2 3 4) + (c d e 3 4) + (d e 4))) + +(deftest maplist-6 + (maplist 'append '(a b c) '(1 2 3)) + ((a b c 1 2 3) (b c 2 3) (c 3))) + +(deftest maplist-7 + (maplist #'(lambda (x y) (nth (car x) y)) + '(0 1 0 1 0 1 0) + '(a b c d e f g) + ) + (a c c e e g g)) + +(deftest maplist-8 + (handler-case + (maplist #'identity 'a) + (error () 'error)) + error) + +(deftest maplist-9 + (handler-case + (maplist #'identity 1) + (error () 'error)) + error) + +(deftest maplist-10 + (handler-case + (maplist #'identity 1.1323) + (error () 'error)) + error) + +(deftest maplist-11 + (handler-case + (maplist #'identity "abcde") + (error () 'error)) + error) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; mapcan + +(deftest mapcon-1 + (mapcon #'(lambda (x) (append '(a) x nil)) nil) + nil) + +(deftest mapcon-2 + (let* ((x (copy-list '(1 2 3 4))) + (xcopy (make-scaffold-copy x)) + (result + (mapcon #'(lambda (y) (append '(a) y nil)) x))) + (and + (check-scaffold-copy x xcopy) + result)) + (a 1 2 3 4 a 2 3 4 a 3 4 a 4)) + +(deftest mapcon-3 + (let* ((x (copy-list '(4 2 3 2 2))) + (y (copy-list '(a b c d e f g h i j k l))) + (xcopy (make-scaffold-copy x)) + (ycopy (make-scaffold-copy y)) + (result + (mapcon #'(lambda (xt yt) + (subseq yt 0 (car xt))) + x y))) + (and + (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy) + result)) + (a b c d b c c d e d e e f)) diff --git a/ansi-tests/cons-test-16.lsp b/ansi-tests/cons-test-16.lsp new file mode 100644 index 0000000000000000000000000000000000000000..ff59832ef09697f07d84ab647731dafae805ec2d --- /dev/null +++ b/ansi-tests/cons-test-16.lsp @@ -0,0 +1,341 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Mar 28 07:41:13 1998 +;;;; Contains: Testing of CL Features related to "CONS", part 16 + +(in-package :cl-test) +(use-package :rt) +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; acons + +(deftest acons-1 + (let* ((x (copy-tree '((c . d) (e . f)))) + (xcopy (make-scaffold-copy x)) + (result (acons 'a 'b x))) + (and + (check-scaffold-copy x xcopy) + (eq (cdr result) x) + result)) + ((a . b) (c . d) (e . f))) + +(deftest acons-2 + (acons 'a 'b nil) + ((a . b))) + +(deftest acons-3 + (acons 'a 'b 'c) + ((a . b) . c)) + +(deftest acons-4 + (acons '((a b)) '(((c d) e) f) '((1 . 2))) + (( ((a b)) . (((c d) e) f)) (1 . 2))) + +(deftest acons-5 + (acons "ancd" 1.143 nil) + (("ancd" . 1.143))) + +(deftest acons-6 + (acons #\R :foo :bar) + ((#\R . :foo) . :bar)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; assoc + +(deftest assoc-1 + (assoc nil nil) + nil) + +(deftest assoc-2 + (assoc nil '(nil)) + nil) + +(deftest assoc-3 + (assoc nil '(nil (nil . 2) (a . b))) + (nil . 2)) + +(deftest assoc-4 + (assoc nil '((a . b) (c . d))) + nil) + +(deftest assoc-5 + (assoc 'a '((a . b))) + (a . b)) + +(deftest assoc-6 + (assoc 'a '((:a . b) (#:a . c) (a . d) (a . e) (z . f))) + (a . d)) + +(deftest assoc-7 + (let* ((x (copy-tree '((a . b) (b . c) (c . d)))) + (xcopy (make-scaffold-copy x)) + (result (assoc 'b x))) + (and + (eq result (second x)) + (check-scaffold-copy x xcopy))) + t) + +(deftest assoc-8 + (assoc 1 '((0 . a) (1 . b) (2 . c))) + (1 . b)) + +(deftest assoc-9 + (assoc (copy-seq "abc") + '((abc . 1) ("abc" . 2) ("abc" . 3))) + nil) + +(deftest assoc-10 + (assoc (copy-list '(a)) (copy-tree '(((a) b) ((a) (c))))) + nil) + +(deftest assoc-11 + (let ((x (list 'a 'b))) + (assoc x `(((a b) c) (,x . d) (,x . e) ((a b) 1)))) + ((a b) . d)) + + +(deftest assoc-12 + (assoc #\e '(("abefd" . 1) ("aevgd" . 2) ("edada" . 3)) + :key #'(lambda (x) (char x 1))) + ("aevgd" . 2)) + +(deftest assoc-13 + (assoc nil '(((a) . b) ( nil . c ) ((nil) . d)) + :key #'car) + (nil . c)) + +(deftest assoc-14 + (assoc (copy-seq "abc") + '((abc . 1) ("abc" . 2) ("abc" . 3)) + :test #'equal) + ("abc" . 2)) + +(deftest assoc-15 + (assoc (copy-seq "abc") + '((abc . 1) ("abc" . 2) ("abc" . 3)) + :test #'equalp) + ("abc" . 2)) + +(deftest assoc-16 + (assoc (copy-list '(a)) (copy-tree '(((a) b) ((a) (c)))) + :test #'equal) + ((a) b)) + +(deftest assoc-17 + (assoc (copy-seq "abc") + '((abc . 1) (a . a) (b . b) ("abc" . 2) ("abc" . 3)) + :test-not (complement #'equalp)) + ("abc" . 2)) + +(deftest assoc-18 + (assoc 'a '((a . d)(b . c)) :test-not #'eq) + (b . c)) + +(deftest assoc-19 + (assoc 'a '((a . d)(b . c)) :test (complement #'eq)) + (b . c)) + +(deftest assoc-20 + (assoc "a" '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)) + :key #'(lambda (x) (and (stringp x) (string-downcase x))) + :test #'equal) + ("A" . 6)) + +(deftest assoc-21 + (assoc "a" '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)) + :key #'(lambda (x) (and (stringp x) x)) + :test #'equal) + ("a" . 3)) + +(deftest assoc-22 + (assoc "a" '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)) + :key #'(lambda (x) (and (stringp x) (string-downcase x))) + :test-not (complement #'equal)) + ("A" . 6)) + +(deftest assoc-23 + (assoc "a" '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)) + :key #'(lambda (x) (and (stringp x) x)) + :test-not (complement #'equal)) + ("a" . 3)) + +;; Check that it works when test returns a true value +;; other than T + +(deftest assoc-24 + (assoc 'a '((b . 1) (a . 2) (c . 3)) + :test #'(lambda (x y) (and (eq x y) 'matched))) + (a . 2)) + +;; Check that the order of the arguments to test is correct + +(deftest assoc-25 + (block fail + (assoc 'a '((b . 1) (c . 2) (a . 3)) + :test #'(lambda (x y) + (unless (eq x 'a) (return-from fail 'fail)) + (eq x y)))) + (A . 3)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; assoc-if + +(deftest assoc-if-1 + (let* ((x (copy-list '((1 . a) (3 . b) (6 . c) (7 . d)))) + (xcopy (make-scaffold-copy x)) + (result (assoc-if #'evenp x))) + (and + (check-scaffold-copy x xcopy) + (eq result (third x)) + result)) + (6 . c)) + +(deftest assoc-if-2 + (handler-case + (let* ((x (copy-list '((1 . a) (3 . b) (6 . c) (7 . d)))) + (xcopy (make-scaffold-copy x)) + (result (assoc-if #'oddp x :key #'1+))) + (and + (check-scaffold-copy x xcopy) + (eq result (third x)) + result)) + (program-error (c) c)) + (6 . c)) + +(deftest assoc-if-3 + (let* ((x (copy-list '((1 . a) nil (3 . b) (6 . c) (7 . d)))) + (xcopy (make-scaffold-copy x)) + (result (assoc-if #'evenp x))) + (and + (check-scaffold-copy x xcopy) + (eq result (fourth x)) + result)) + (6 . c)) + +(deftest assoc-if-4 + (assoc-if #'null '((a . b) nil (c . d) (nil . e) (f . g))) + (nil . e)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; assoc-if-not + +(deftest assoc-if-not-1 + (let* ((x (copy-list '((1 . a) (3 . b) (6 . c) (7 . d)))) + (xcopy (make-scaffold-copy x)) + (result (assoc-if-not #'oddp x))) + (and + (check-scaffold-copy x xcopy) + (eq result (third x)) + result)) + (6 . c)) + +(deftest assoc-if-not-2 + (handler-case + (let* ((x (copy-list '((1 . a) (3 . b) (6 . c) (7 . d)))) + (xcopy (make-scaffold-copy x)) + (result (assoc-if-not #'evenp x :key #'1+))) + (and + (check-scaffold-copy x xcopy) + (eq result (third x)) + result)) + (program-error (c) c)) + (6 . c)) + +(deftest assoc-if-not-3 + (let* ((x (copy-list '((1 . a) nil (3 . b) (6 . c) (7 . d)))) + (xcopy (make-scaffold-copy x)) + (result (assoc-if-not #'oddp x))) + (and + (check-scaffold-copy x xcopy) + (eq result (fourth x)) + result)) + (6 . c)) + +(deftest assoc-if-not-4 + (assoc-if-not #'identity '((a . b) nil (c . d) (nil . e) (f . g))) + (nil . e)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; copy-alist + +(deftest copy-alist-1 + (let* ((x (copy-tree '((a . b) (c . d) nil (e f) ((x) ((y z)) w) + ("foo" . "bar") (#\w . 1.234) + (1/3 . 4123.4d5)))) + (xcopy (make-scaffold-copy x)) + (result (copy-alist x))) + (and + (check-scaffold-copy x xcopy) + (= (length x) (length result)) + (every #'(lambda (p1 p2) + (or (and (null p1) (null p2)) + (and (not (eq p1 p2)) + (eq (car p1) (car p2)) + (eq (cdr p1) (cdr p2))))) + x result) + t)) + t) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; pairlis + +;; Pairlis has two legal behaviors: the pairs +;; can be prepended in the same order, or in the +;; reverse order, that they appear in the first +;; two arguments + +(defun my-pairlis (x y &optional alist) + (if (null x) + alist + (acons (car x) (car y) + (my-pairlis (cdr x) (cdr y) alist)))) + +(deftest pairlis-1 + (pairlis nil nil nil) + nil) + +(deftest pairlis-2 + (pairlis '(a) '(b) nil) + ((a . b))) + +(deftest pairlis-3 + (let* ((x (copy-list '(a b c d e))) + (xcopy (make-scaffold-copy x)) + (y (copy-list '(1 2 3 4 5))) + (ycopy (make-scaffold-copy y)) + (result (pairlis x y)) + (expected (my-pairlis x y))) + (and + (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy) + (or + (equal result expected) + (equal result (reverse expected))) + t)) + t) + +(deftest pairlis-4 + (let* ((x (copy-list '(a b c d e))) + (xcopy (make-scaffold-copy x)) + (y (copy-list '(1 2 3 4 5))) + (ycopy (make-scaffold-copy y)) + (z '((x . 10) (y . 20))) + (zcopy (make-scaffold-copy z)) + (result (pairlis x y z)) + (expected (my-pairlis x y z))) + (and + (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy) + (check-scaffold-copy z zcopy) + (eq (cdr (cddr (cddr result))) z) + (or + (equal result expected) + (equal result (append (reverse (subseq expected 0 5)) + (subseq expected 5)))) + t)) + t) + + + + diff --git a/ansi-tests/cons-test-17.lsp b/ansi-tests/cons-test-17.lsp new file mode 100644 index 0000000000000000000000000000000000000000..394e1a70e569da60d4482a5499e56d7662f3c678 --- /dev/null +++ b/ansi-tests/cons-test-17.lsp @@ -0,0 +1,273 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Mar 28 09:45:22 1998 +;;;; Contains: Testing of CL Features related to "CONS", part 17 + +(in-package :cl-test) +(use-package :rt) +(declaim (optimize (safety 3))) + +(defun rev-assoc-list (x) + (cond + ((null x) nil) + ((null (car x)) + (cons nil (rev-assoc-list (cdr x)))) + (t + (acons (cdar x) (caar x) (rev-assoc-list (cdr x)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; assoc + +(deftest rassoc-1 + (rassoc nil nil) + nil) + +(deftest rassoc-2 + (rassoc nil '(nil)) + nil) + +(deftest rassoc-3 + (rassoc nil (rev-assoc-list '(nil (nil . 2) (a . b)))) + (2 . nil)) + +(deftest rassoc-4 + (rassoc nil '((a . b) (c . d))) + nil) + +(deftest rassoc-5 + (rassoc 'a '((b . a))) + (b . a)) + +(deftest rassoc-6 + (rassoc 'a (rev-assoc-list '((:a . b) (#:a . c) (a . d) (a . e) (z . f)))) + (d . a)) + +(deftest rassoc-7 + (let* ((x (copy-tree (rev-assoc-list '((a . b) (b . c) (c . d))))) + (xcopy (make-scaffold-copy x)) + (result (rassoc 'b x))) + (and + (eq result (second x)) + (check-scaffold-copy x xcopy))) + t) + +(deftest rassoc-8 + (rassoc 1 (rev-assoc-list '((0 . a) (1 . b) (2 . c)))) + (b . 1)) + +(deftest rassoc-9 + (rassoc (copy-seq "abc") + (rev-assoc-list '((abc . 1) ("abc" . 2) ("abc" . 3)))) + nil) + +(deftest rassoc-10 + (rassoc (copy-list '(a)) + (copy-tree (rev-assoc-list '(((a) b) ((a) (c)))))) + nil) + +(deftest rassoc-11 + (let ((x (list 'a 'b))) + (rassoc x + (rev-assoc-list `(((a b) c) (,x . d) (,x . e) ((a b) 1))))) + (d a b)) + + +(deftest rassoc-12 + (rassoc #\e + (copy-tree + (rev-assoc-list '(("abefd" . 1) ("aevgd" . 2) ("edada" . 3)))) + :key #'(lambda (x) (char x 1))) + (2 . "aevgd")) + +(deftest rassoc-13 + (rassoc nil + (copy-tree + (rev-assoc-list + '(((a) . b) ( nil . c ) ((nil) . d)))) + :key #'car) + (c)) + +(deftest rassoc-14 + (rassoc (copy-seq "abc") + (copy-tree + (rev-assoc-list + '((abc . 1) ("abc" . 2) ("abc" . 3)))) + :test #'equal) + (2 . "abc")) + +(deftest rassoc-15 + (rassoc (copy-seq "abc") + (copy-tree + (rev-assoc-list + '((abc . 1) ("abc" . 2) ("abc" . 3)))) + :test #'equalp) + (2 . "abc")) + +(deftest rassoc-16 + (rassoc (copy-list '(a)) + (copy-tree + (rev-assoc-list '(((a) b) ((a) (c))))) + :test #'equal) + ((b) a)) + +(deftest rassoc-17 + (rassoc (copy-seq "abc") + (copy-tree + (rev-assoc-list + '((abc . 1) (a . a) (b . b) ("abc" . 2) ("abc" . 3)))) + :test-not (complement #'equalp)) + (2 . "abc")) + +(deftest rassoc-18 + (rassoc 'a + (copy-tree + (rev-assoc-list + '((a . d)(b . c)))) + :test-not #'eq) + (c . b)) + +(deftest rassoc-19 + (rassoc 'a + (copy-tree + (rev-assoc-list + '((a . d)(b . c)))) + :test (complement #'eq)) + (c . b)) + +(deftest rassoc-20 + (rassoc "a" + (copy-tree + (rev-assoc-list + '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)))) + :key #'(lambda (x) (and (stringp x) (string-downcase x))) + :test #'equal) + (6 . "A")) + +(deftest rassoc-21 + (rassoc "a" + (copy-tree + (rev-assoc-list + '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)))) + :key #'(lambda (x) (and (stringp x) x)) + :test #'equal) + (3 . "a")) + +(deftest rassoc-22 + (rassoc "a" + (copy-tree + (rev-assoc-list + '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)))) + :key #'(lambda (x) (and (stringp x) (string-downcase x))) + :test-not (complement #'equal)) + (6 . "A")) + +(deftest rassoc-23 + (rassoc "a" + (copy-tree + (rev-assoc-list + '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)))) + :key #'(lambda (x) (and (stringp x) x)) + :test-not (complement #'equal)) + (3 . "a")) + +;; Check that it works when test returns a true value +;; other than T + +(deftest rassoc-24 + (rassoc 'a + (copy-tree + (rev-assoc-list + '((b . 1) (a . 2) (c . 3)))) + :test #'(lambda (x y) (and (eq x y) 'matched))) + (2 . a)) + +;; Check that the order of the arguments to :test is correct + +(deftest rassoc-25 + (block fail + (rassoc 'a '((1 . b) (2 . c) (3 . a)) + :test #'(lambda (x y) + (unless (eq x 'a) (return-from fail 'fail)) + (eq x y)))) + (3 . A)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; rassoc-if + +(deftest rassoc-if-1 + (let* ((x (rev-assoc-list '((1 . a) (3 . b) (6 . c) (7 . d)))) + (xcopy (make-scaffold-copy x)) + (result (rassoc-if #'evenp x))) + (and + (check-scaffold-copy x xcopy) + (eq result (third x)) + result)) + (c . 6)) + +(deftest rassoc-if-2 + (handler-case + (let* ((x (rev-assoc-list '((1 . a) (3 . b) (6 . c) (7 . d)))) + (xcopy (make-scaffold-copy x)) + (result (rassoc-if #'oddp x :key #'1+))) + (and + (check-scaffold-copy x xcopy) + (eq result (third x)) + result)) + (program-error (c) c)) + (c . 6)) + +(deftest rassoc-if-3 + (let* ((x (rev-assoc-list '((1 . a) nil (3 . b) (6 . c) (7 . d)))) + (xcopy (make-scaffold-copy x)) + (result (rassoc-if #'evenp x))) + (and + (check-scaffold-copy x xcopy) + (eq result (fourth x)) + result)) + (c . 6)) + +(deftest rassoc-if-4 + (rassoc-if #'null + (rev-assoc-list '((a . b) nil (c . d) (nil . e) (f . g)))) + (e)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; rassoc-if-not + +(deftest rassoc-if-not-1 + (let* ((x (rev-assoc-list '((1 . a) (3 . b) (6 . c) (7 . d)))) + (xcopy (make-scaffold-copy x)) + (result (rassoc-if-not #'oddp x))) + (and + (check-scaffold-copy x xcopy) + (eq result (third x)) + result)) + (c . 6)) + +(deftest rassoc-if-not-2 + (handler-case + (let* ((x (rev-assoc-list '((1 . a) (3 . b) (6 . c) (7 . d)))) + (xcopy (make-scaffold-copy x)) + (result (rassoc-if-not #'evenp x :key #'1+))) + (and + (check-scaffold-copy x xcopy) + (eq result (third x)) + result)) + (program-error (c) c)) + (c . 6)) + +(deftest rassoc-if-not-3 + (let* ((x (rev-assoc-list '((1 . a) nil (3 . b) (6 . c) (7 . d)))) + (xcopy (make-scaffold-copy x)) + (result (rassoc-if-not #'oddp x))) + (and + (check-scaffold-copy x xcopy) + (eq result (fourth x)) + result)) + (c . 6)) + +(deftest rassoc-if-not-4 + (rassoc-if-not #'identity + (rev-assoc-list '((a . b) nil (c . d) (nil . e) (f . g)))) + (e)) + diff --git a/ansi-tests/cons-test-18.lsp b/ansi-tests/cons-test-18.lsp new file mode 100644 index 0000000000000000000000000000000000000000..963ba8af8c74c29eb35a092f4ffcae8d2c844955 --- /dev/null +++ b/ansi-tests/cons-test-18.lsp @@ -0,0 +1,234 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Mar 28 10:23:31 1998 +;;;; Contains: Testing of CL Features related to "CONS", part 18 + +(in-package :cl-test) +(use-package :rt) +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; get-properties + +(deftest get-properties-1 + (get-properties nil nil) + nil nil nil) + +(deftest get-properties-2 + (get-properties '(a b) nil) + nil nil nil) + +(deftest get-properties-3 + (get-properties '(a b c d) '(a)) + a b (a b c d)) + +(deftest get-properties-4 + (get-properties '(a b c d) '(c)) + c d (c d)) + +(deftest get-properties-5 + (get-properties '(a b c d) '(c a)) + a b (a b c d)) + +(deftest get-properties-6 + (get-properties '(a b c d) '(b)) + nil nil nil) + +(deftest get-properties-7 + (get-properties '("aa" b c d) (list (copy-seq "aa"))) + nil nil nil) + +(deftest get-properties-8 + (get-properties '(1000000000000 b c d) (list (1+ 999999999999))) + nil nil nil) + +(deftest get-properties-9 + (let* ((x (copy-list '(a b c d e f g h a c))) + (xcopy (make-scaffold-copy x)) + (y (copy-list '(x y f g))) + (ycopy (make-scaffold-copy y))) + (multiple-value-bind + (indicator value tail) + (get-properties x y) + (and + (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy) + (eq tail (nthcdr 6 x)) + (values indicator value tail)))) + g h (g h a c)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; getf + +(deftest getf-1 + (getf nil 'a) + nil) + +(deftest getf-2 + (getf nil 'a 'b) + b) + +(deftest getf-3 + (getf '(a b) 'a) + b) + +(deftest getf-4 + (getf '(a b) 'a 'c) + b) + +(deftest getf-5 + (let ((x 0)) + (values + (getf '(a b) 'a (incf x)) + x)) + b 1) + +(deftest setf-getf-1 + (let ((p (copy-list '(a 1 b 2)))) + (setf (getf p 'c) 3) + ;; Must check that only a, b, c have properties + (and + (eql (getf p 'a) 1) + (eql (getf p 'b) 2) + (eql (getf p 'c) 3) + (eql + (loop + for ptr on p by #'cddr count + (not (member (car ptr) '(a b c)))) + 0) + t)) + t) + +(deftest setf-getf-2 + (let ((p (copy-list '(a 1 b 2)))) + (setf (getf p 'a) 3) + ;; Must check that only a, b have properties + (and + (eql (getf p 'a) 3) + (eql (getf p 'b) 2) + (eql + (loop + for ptr on p by #'cddr count + (not (member (car ptr) '(a b)))) + 0) + t)) + t) + +(deftest setf-getf-3 + (let ((p (copy-list '(a 1 b 2)))) + (setf (getf p 'c 17) 3) + ;; Must check that only a, b, c have properties + (and + (eql (getf p 'a) 1) + (eql (getf p 'b) 2) + (eql (getf p 'c) 3) + (eql + (loop + for ptr on p by #'cddr count + (not (member (car ptr) '(a b c)))) + 0) + t)) + t) + +(deftest setf-getf-4 + (let ((p (copy-list '(a 1 b 2)))) + (setf (getf p 'a 17) 3) + ;; Must check that only a, b have properties + (and + (eql (getf p 'a) 3) + (eql (getf p 'b) 2) + (eql + (loop + for ptr on p by #'cddr count + (not (member (car ptr) '(a b)))) + 0) + t)) + t) + +(deftest setf-getf-5 + (let ((p (copy-list '(a 1 b 2))) + (foo nil)) + (setf (getf p 'a (progn (setf foo t) 0)) 3) + ;; Must check that only a, b have properties + (and + (eql (getf p 'a) 3) + (eql (getf p 'b) 2) + (eql + (loop + for ptr on p by #'cddr count + (not (member (car ptr) '(a b)))) + 0) + foo)) + t) + +(deftest incf-getf-1 + (let ((p (copy-list '(a 1 b 2)))) + (incf (getf p 'b)) + ;; Must check that only a, b have properties + (and + (eql (getf p 'a) 1) + (eql (getf p 'b) 3) + (eql + (loop + for ptr on p by #'cddr count + (not (member (car ptr) '(a b)))) + 0) + t)) + t) + +(deftest incf-getf-2 + (let ((p (copy-list '(a 1 b 2)))) + (incf (getf p 'c 19)) + ;; Must check that only a, b have properties + (and + (eql (getf p 'a) 1) + (eql (getf p 'b) 2) + (eql (getf p 'c) 20) + (eql + (loop + for ptr on p by #'cddr count + (not (member (car ptr) '(a b c)))) + 0) + t)) + t) + +(deftest push-getf-1 + (let ((p nil)) + (values + (push 'x (getf p 'a)) + p)) + (x) (a (x))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; remf + +(deftest remf-1 + (let ((x nil)) + (values (remf x 'a) x)) + nil ()) + +(deftest remf-2 + (let ((x (list 'a 'b))) + (values (not (null (remf x 'a))) x)) + t ()) + +(deftest remf-3 + (let ((x (list 'a 'b 'a 'c))) + (values (not (null (remf x 'a))) x)) + t (a c)) + +(deftest remf-4 + (let ((x (list 'a 'b 'c 'd))) + (values + (and (remf x 'c) t) + (loop + for ptr on x by #'cddr count + (not (eq (car ptr) 'a))))) + t 0) + + + + + + \ No newline at end of file diff --git a/ansi-tests/cons-test-19.lsp b/ansi-tests/cons-test-19.lsp new file mode 100644 index 0000000000000000000000000000000000000000..841e959a74b513539c252abf56ff3bed8c1a34d3 --- /dev/null +++ b/ansi-tests/cons-test-19.lsp @@ -0,0 +1,515 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Mar 28 11:53:33 1998 +;;;; Contains: Testing of CL Features related to "CONS", part 19 + +(in-package :cl-test) +(use-package :rt) +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; intersection + +(defun is-intersection (x y z) + "Check that z is the intersection of x and y." + (and + (every #'(lambda (e) + (or (not (member e y)) + (member e z))) + x) + (every #'(lambda (e) + (or (not (member e x)) + (member e z))) + y) + (every #'(lambda (e) + (and (member e x) (member e y))) + z))) + +(defun shuffle (x) + (cond + ((null x) nil) + ((null (cdr x)) x) + (t + (multiple-value-bind + (y z) + (split-list x) + (append (shuffle y) (shuffle z)))))) + +(defun split-list (x) + (cond + ((null x) (values nil nil)) + ((null (cdr x)) (values x nil)) + (t + (multiple-value-bind + (y z) + (split-list (cddr x)) + (values (cons (car x) y) (cons (cadr x) z)))))) + + +(deftest intersection-1 + (intersection nil nil) + nil) + +(deftest intersection-2 + (intersection (loop for i from 1 to 100 collect i) nil) + nil) + +(deftest intersection-3 + (intersection nil (loop for i from 1 to 100 collect i)) + nil) + +(deftest intersection-4 + (let* ((x (copy-list '(a 1 c 7 b 4 3 z))) + (xcopy (make-scaffold-copy x)) + (y (copy-list '(3 y c q z a 18))) + (ycopy (make-scaffold-copy y)) + (result (intersection x y))) + (and + (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy) + (+ + (loop + for e in x count + (and (member e y) + (not (member e result)))) + (loop + for e in result count + (or (not (member e x)) + (not (member e y)))) + (loop + for hd on result count + (and (consp hd) + (member (car hd) (cdr hd))))))) + 0) + +(deftest intersection-5 + (let* ((x (copy-list '(a a a))) + (xcopy (make-scaffold-copy x)) + (y (copy-list '(a a a b b b))) + (ycopy (make-scaffold-copy y)) + (result (intersection x y))) + (and + (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy) + (member 'a result) + (not (member 'b result)))) + t) + +(deftest intersection-6 + (intersection (list 1000000000000 'a 'b 'c) + (list (1+ 999999999999) 'd 'e 'f)) + (1000000000000)) + +(deftest intersection-7 + (intersection (list 'a 10 'b 17) + (list 'c 'd 4 'e 'f 10 1 13 'z)) + (10)) + +(deftest intersection-8 + (intersection (list 'a (copy-seq "aaa") 'b) + (list 'd (copy-seq "aaa") 'e)) + nil) + +(deftest intersection-9 + (intersection (list 'a (copy-seq "aaa") 'b) + (list 'd (copy-seq "aaa") 'e) + :test #'equal) + ("aaa")) + +;; Same as 9, but with a symbol function designator for :test +(deftest intersection-9-a + (intersection (list 'a (copy-seq "aaa") 'b) + (list 'd (copy-seq "aaa") 'e) + :test 'equal) + ("aaa")) + +(deftest intersection-9-b + (intersection (list 'a (copy-seq "aaa") 'b) + (list 'd (copy-seq "aaa") 'e) + :test-not #'(lambda (p q) (not (equal p q)))) + ("aaa")) + +(deftest intersection-10 + (not (not + (equal + (sort + (intersection (loop + for i from 0 to 1000 by 3 + collect i) + (loop + for i from 0 to 1000 by 7 + collect i)) + #'<) + (loop for i from 0 to 1000 by 21 collect i)))) + t) + +(deftest intersection-11 + (not (not + (equal + (sort + (intersection (loop + for i from 0 to 999 by 5 + collect i) + (loop + for i from 0 to 999 by 7 + collect i) + :test #'(lambda (a b) + (and (eql a b) + (= (mod a 3) 0)))) + #'<) + (loop + for i from 0 to 999 by (* 3 5 7) collect i)))) + t) + +(deftest intersection-11-a + (not (not + (equal + (sort + (intersection (loop + for i from 0 to 999 by 5 + collect i) + (loop + for i from 0 to 999 by 7 + collect i) + :test-not + #'(lambda (a b) + (not (and (eql a b) + (= (mod a 3) 0))))) + #'<) + (loop + for i from 0 to 999 by (* 3 5 7) + collect i)))) + t) + +;; +;; Do large numbers of random intersection tests +;; + +(deftest intersection-12 + (intersection-12-body 100 100) + nil) + +(defun intersection-12-body (size niters &optional (maxelem (* 2 size))) + (let ((state (make-random-state))) + (loop + for i from 1 to niters do + (let ((x (shuffle (loop for j from 1 to size collect (random maxelem state)))) + (y (shuffle (loop for j from 1 to size collect (random maxelem state))))) + (let ((z (intersection x y))) + (let ((is-good (is-intersection x y z))) + (unless is-good (return (values x y z))))))) + nil)) + + +;; +;; :key argument +;; + +(deftest intersection-13 + (let ((x (copy-list '(0 5 8 13 31 42))) + (y (copy-list '(3 5 42 0 7 100 312 33)))) + (not (not + (equal + (sort (copy-list (intersection x y)) #'<) + (sort (copy-list (intersection x y :key #'1+)) #'<))))) + t) + +;; Same as 13, but with a symbol function designator for :key +(deftest intersection-13-a + (let ((x (copy-list '(0 5 8 13 31 42))) + (y (copy-list '(3 5 42 0 7 100 312 33)))) + (not (not + (equal + (sort (copy-list (intersection x y)) #'<) + (sort (copy-list (intersection x y :key '1+)) #'<))))) + t) + +;; Test that a nil key argument is ignored + +(deftest intersection-14 + (handler-case + (let + ((result (intersection (copy-list '(a b c d)) + (copy-list '(e c f b g)) + :key nil))) + (and + (member 'b result) + (member 'c result) + (every #'(lambda (x) (member x '(b c))) result) + t)) + (error (c) c)) + t) + +;; Test that intersection preserves the order of arguments to :test, :test-not + +(deftest intersection-15 + (let ((list1 (list 1 2 3 4)) + (list2 (list 4 5 6 7))) + (block fail + (intersection + list1 list2 + :test + #'(lambda (x y) + (when (< y x) (return-from fail 'fail)) + (eql x y))))) + (4)) + +(deftest intersection-16 + (let ((list1 (list 1 2 3 4)) + (list2 (list 4 5 6 7))) + (block fail + (intersection + list1 list2 + :key #'identity + :test + #'(lambda (x y) + (when (< y x) (return-from fail 'fail)) + (eql x y))))) + (4)) + +(deftest intersection-17 + (let ((list1 (list 1 2 3 4)) + (list2 (list 4 5 6 7))) + (block fail + (intersection + list1 list2 + :test-not + #'(lambda (x y) + (when (< y x) (return-from fail 'fail)) + (not (eql x y)))))) + (4)) + +(deftest intersection-18 + (let ((list1 (list 1 2 3 4)) + (list2 (list 4 5 6 7))) + (block fail + (intersection + list1 list2 + :key #'identity + :test-not + #'(lambda (x y) + (when (< y x) (return-from fail 'fail)) + (not (eql x y)))))) + (4)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; nintersection + +(defun nintersection-with-check (x y &key test) + (let ((ycopy (make-scaffold-copy y))) + (let ((result (if test + (nintersection x y :test test) + (nintersection x y)))) + (if (check-scaffold-copy y ycopy) + result + 'failed)))) + +(deftest nintersection-1 + (nintersection nil nil) + nil) + +(deftest nintersection-2 + (nintersection (loop for i from 1 to 100 collect i) nil) + nil) + +(deftest nintersection-3 + (nintersection-with-check nil (loop for i from 1 to 100 collect i)) + nil) + +(deftest nintersection-4 + (let* ((x (copy-list '(a 1 c 7 b 4 3 z))) + (xc (copy-list x)) + (y (copy-list '(3 y c q z a 18))) + (result (nintersection-with-check xc y))) + (and + (not (eq result 'failed)) + (+ + (loop + for e in x count + (and (member e y) + (not (member e result)))) + (loop + for e in result count + (or (not (member e x)) + (not (member e y)))) + (loop + for hd on result count + (and (consp hd) + (member (car hd) (cdr hd))))))) + 0) + +(deftest nintersection-5 + (let* ((x (copy-list '(a a a))) + (y (copy-list '(a a a b b b))) + (result (nintersection-with-check x y))) + (and + (not (eq result 'failed)) + (member 'a result) + (not (member 'b result)))) + t) + +(deftest nintersection-6 + (nintersection-with-check + (list 1000000000000 'a 'b 'c) + (list (1+ 999999999999) 'd 'e 'f)) + (1000000000000)) + +(deftest nintersection-7 + (nintersection-with-check (list 'a 10 'b 17) + (list 'c 'd 4 'e 'f 10 1 13 'z)) + (10)) + +(deftest nintersection-8 + (nintersection-with-check + (list 'a (copy-seq "aaa") 'b) + (list 'd (copy-seq "aaa") 'e)) + nil) + +(deftest nintersection-9 + (nintersection-with-check + (list 'a (copy-seq "aaa") 'b) + (list 'd (copy-seq "aaa") 'e) + :test #'equal) + ("aaa")) + +(deftest nintersection-9-a + (nintersection-with-check + (list 'a (copy-seq "aaa") 'b) + (list 'd (copy-seq "aaa") 'e) + :test 'equal) + ("aaa")) + +(deftest nintersection-9-b + (nintersection + (list 'a (copy-seq "aaa") 'b) + (list 'd (copy-seq "aaa") 'e) + :test-not #'(lambda (p q) (not (equal p q)))) + ("aaa")) + +(deftest nintersection-10 + (not (not + (equal + (sort + (let ((result + (nintersection-with-check + (loop for i from 0 to 1000 by 3 collect i) + (loop for i from 0 to 1000 by 7 collect i)))) + (if (eq result 'failed) () result)) + #'<) + (loop for i from 0 to 1000 by 21 collect i)))) + t) + +(deftest nintersection-11 + (not (not + (equal + (sort + (let ((result + (nintersection-with-check + (loop for i from 0 to 999 by 5 collect i) + (loop for i from 0 to 999 by 7 collect i) + :test #'(lambda (a b) + (and (eql a b) + (= (mod a 3) 0)))))) + (if (eq result 'failed) () result)) + #'<) + (loop + for i from 0 to 999 by (* 3 5 7) collect i)))) + t) + +(deftest nintersection-12 + (nintersection-12-body 100 100) + nil) + +(defun nintersection-12-body (size niters &optional (maxelem (* 2 size))) + (let ((state (make-random-state t))) + (loop + for i from 1 to niters do + (let ((x (shuffle (loop for j from 1 to size collect (random maxelem state)))) + (y (shuffle (loop for j from 1 to size collect (random maxelem state))))) + (let ((z (nintersection-with-check (copy-list x) y))) + (when (eq z 'failed) (return (values x y z))) + (let ((is-good (is-intersection x y z))) + (unless is-good (return (values x y z))))))) + nil)) + +;; Key argument + +(deftest nintersection-13 + (let ((x '(0 5 8 13 31 42)) + (y (copy-list '(3 5 42 0 7 100 312 33)))) + (not (not + (equal + (sort (copy-list (nintersection + (copy-list x) y)) #'<) + (sort (copy-list (nintersection + (copy-list x) y :key #'1+)) #'<))))) + t) + +;; Check that a nil key argument is ignored + +(deftest nintersection-14 + (handler-case + (let + ((result (nintersection + (copy-list '(a b c d)) + (copy-list '(e c f b g)) + :key nil))) + (and + (member 'b result) + (member 'c result) + (every #'(lambda (x) (member x '(b c))) result) + t)) + (error (c) c)) + t) + +;; Test that nintersection preserves the order of arguments to :test, :test-not + +(deftest nintersection-15 + (let ((list1 (list 1 2 3 4)) + (list2 (list 4 5 6 7))) + (block fail + (nintersection + list1 list2 + :test + #'(lambda (x y) + (when (< y x) (return-from fail 'fail)) + (eql x y))))) + (4)) + +(deftest nintersection-16 + (let ((list1 (list 1 2 3 4)) + (list2 (list 4 5 6 7))) + (block fail + (nintersection + list1 list2 + :key #'identity + :test + #'(lambda (x y) + (when (< y x) (return-from fail 'fail)) + (eql x y))))) + (4)) + +(deftest nintersection-17 + (let ((list1 (list 1 2 3 4)) + (list2 (list 4 5 6 7))) + (block fail + (nintersection + list1 list2 + :test-not + #'(lambda (x y) + (when (< y x) (return-from fail 'fail)) + (not (eql x y)))))) + (4)) + +(deftest nintersection-18 + (let ((list1 (list 1 2 3 4)) + (list2 (list 4 5 6 7))) + (block fail + (nintersection + list1 list2 + :key #'identity + :test-not + #'(lambda (x y) + (when (< y x) (return-from fail 'fail)) + (not (eql x y)))))) + (4)) diff --git a/ansi-tests/cons-test-20.lsp b/ansi-tests/cons-test-20.lsp new file mode 100644 index 0000000000000000000000000000000000000000..0ecd34d7585a40de66bbb60cf3066c2e3a08119c --- /dev/null +++ b/ansi-tests/cons-test-20.lsp @@ -0,0 +1,317 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Mar 28 22:11:27 1998 +;;;; Contains: Testing of CL Features related to "CONS", part 20 + +(in-package :cl-test) +(use-package :rt) +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; union + +(defun union-with-check (x y &key test test-not) + (let ((xcopy (make-scaffold-copy x)) + (ycopy (make-scaffold-copy y))) + (let ((result (cond + (test (union x y :test test)) + (test-not (union x y :test-not test-not)) + (t (union x y))))) + (if + (and (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy)) + result + 'failed)))) + +(defun union-with-check-and-key (x y key &key test test-not) + (let ((xcopy (make-scaffold-copy x)) + (ycopy (make-scaffold-copy y))) + (let ((result (cond + (test (union x y :key key :test test)) + (test-not (union x y :key key :test-not test-not)) + (t (union x y :key key))))) + (if + (and (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy)) + result + 'failed)))) + +(defun check-union (x y z) + (and (listp x) + (listp y) + (listp z) + (every #'(lambda (e) (or (member e x) + (member e y))) + z) + (every #'(lambda (e) (member e z)) x) + (every #'(lambda (e) (member e z)) y) + t)) + +(deftest union-1 + (union nil nil) + nil) + +(deftest union-2 + (union-with-check (list 'a) nil) + (a)) + +(deftest union-3 + (union-with-check (list 'a) (list 'a)) + (a)) + +(deftest union-4 + (union-with-check (list 1) (list 1)) + (1)) + +(deftest union-5 + (let ((x (list 'a 'b))) + (union-with-check (list x) (list x))) + ((a b))) + +(deftest union-6 + (let ((x (copy-list '(a b c d e f))) + (y (copy-list '(z c y a v b)))) + (let ((result (union-with-check x y))) + (check-union x y result))) + t) + +(deftest union-6-a + (let ((x (copy-list '(a b c d e f))) + (y (copy-list '(z c y a v b)))) + (let ((result (union-with-check x y :test #'eq))) + (check-union x y result))) + t) + +(deftest union-7 + (let ((x (copy-list '(a b c d e f))) + (y (copy-list '(z c y a v b)))) + (let ((result (union-with-check x y :test #'eql))) + (check-union x y result))) + t) + +(deftest union-8 + (let ((x (copy-list '(a b c d e f))) + (y (copy-list '(z c y a v b)))) + (let ((result (union-with-check x y :test #'equal))) + (check-union x y result))) + t) + +(deftest union-9 + (let ((x (copy-list '(a b c d e f))) + (y (copy-list '(z c y a v b)))) + (let ((result (union-with-check x y :test-not (complement #'eql)))) + (check-union x y result))) + t) + +(deftest union-10 + (let ((x (copy-list '(a b c d e f))) + (y (copy-list '(z c y a v b)))) + (let ((result (union-with-check x y :test-not (complement #'equal)))) + (check-union x y result))) + t) + +(deftest union-11 + (let ((x (copy-list '(a b c d e f))) + (y (copy-list '(z c y a v b)))) + (let ((result (union-with-check x y :test-not (complement #'eq)))) + (check-union x y result))) + t) + +(deftest union-12 + (let ((x (copy-list '(1 2 3 4 5 6 7))) + (y (copy-list '(10 19 5 3 17 1001 2)))) + (let ((result (union-with-check x y))) + (check-union x y result))) + t) + +(deftest union-13 + (let ((x (copy-list '(1 2 3 4 5 6 7))) + (y (copy-list '(10 19 5 3 17 1001 2)))) + (let ((result (union-with-check x y :test #'equal))) + (check-union x y result))) + t) + +(deftest union-14 + (let ((x (copy-list '(1 2 3 4 5 6 7))) + (y (copy-list '(10 19 5 3 17 1001 2)))) + (let ((result (union-with-check x y :test #'eql))) + (check-union x y result))) + t) + +(deftest union-15 + (let ((x (copy-list '(1 2 3 4 5 6 7))) + (y (copy-list '(10 19 5 3 17 1001 2)))) + (let ((result (union-with-check x y :test-not (complement #'equal)))) + (check-union x y result))) + t) + +(deftest union-16 + (let ((x (copy-list '(1 2 3 4 5 6 7))) + (y (copy-list '(10 19 5 3 17 1001 2)))) + (let ((result (union-with-check x y :test-not (complement #'eql)))) + (check-union x y result))) + t) + +(deftest union-17 + (let ((x (copy-list '(1 2 3 4 5 6 7))) + (y (copy-list '(10 19 5 3 17 1001 2)))) + (let ((result (union-with-check-and-key x y #'1+))) + (check-union x y result))) + t) + +(deftest union-18 + (let ((x (copy-list '(1 2 3 4 5 6 7))) + (y (copy-list '(10 19 5 3 17 1001 2)))) + (let ((result (union-with-check-and-key x y #'1+ :test #'equal))) + (check-union x y result))) + t) + +(deftest union-19 + (let ((x (copy-list '(1 2 3 4 5 6 7))) + (y (copy-list '(10 19 5 3 17 1001 2)))) + (let ((result (union-with-check-and-key x y #'1+ :test #'eql))) + (check-union x y result))) + t) + +(deftest union-20 + (let ((x (copy-list '(1 2 3 4 5 6 7))) + (y (copy-list '(10 19 5 3 17 1001 2)))) + (let ((result (union-with-check-and-key x y #'1+ + :test-not (complement #'equal)))) + (check-union x y result))) + t) + +(deftest union-21 + (let ((x (copy-list '(1 2 3 4 5 6 7))) + (y (copy-list '(10 19 5 3 17 1001 2)))) + (let ((result (union-with-check-and-key x y #'1+ + :test-not (complement #'equal)))) + (check-union x y result))) + t) + +(deftest union-22 + (handler-case + (let ((x (copy-list '(1 2 3 4 5 6 7))) + (y (copy-list '(10 19 5 3 17 1001 2)))) + (let ((result (union-with-check-and-key x y nil))) + (check-union x y result))) + (error (c) c)) + t) + +(deftest union-23 + (let ((x (copy-list '(1 2 3 4 5 6 7))) + (y (copy-list '(10 19 5 3 17 1001 2)))) + (let ((result (union-with-check-and-key x y '1+))) + (check-union x y result))) + t) + +;; Do large numbers of random units + +(defun do-random-unions (size niters &optional (maxelem (* 2 size))) + (let ((state (make-random-state))) + (loop + for i from 1 to niters do + (let ((x (shuffle (loop for j from 1 to size collect + (random maxelem state)))) + (y (shuffle (loop for j from 1 to size collect + (random maxelem state))))) + (let ((z (union x y))) + (let ((is-good (check-union x y z))) + (unless is-good (return (values x y z))))))) + nil)) + +(deftest union-24 + (do-random-unions 100 100 200) + nil) + +(deftest union-25 + (let ((x (shuffle '(1 4 6 10 45 101))) + (y (copy-list '(102 5 2 11 44 6)))) + (let ((result (union-with-check x y + :test #'(lambda (a b) + (<= (abs (- a b)) 1))))) + (and + (not (eq result 'failed)) + (sort + (sublis + '((2 . 1) (5 . 4) (11 . 10) (45 . 44) (102 . 101)) + (copy-list result)) + #'<)))) + (1 4 6 10 44 101)) + +;; Check that union uses eql, not equal or eq + +(deftest union-26 + (let ((x 1000) + (y 1000)) + (loop + while (not (typep x 'bignum)) + do (progn + (setf x (* x x)) + (setf y (* y y)))) + (not (not + (or + (eq x y) ;; if bignums are eq, the test is worthless + (eql (length + (union-with-check + (list x) (list x))) + 1))))) + t) + +(deftest union-27 + (union-with-check (list (copy-seq "aa")) + (list (copy-seq "aa"))) + ("aa" "aa")) + +;; Check that union does not reverse the arguments to :test, :test-not + +(deftest union-28 + (block fail + (sort + (union-with-check + (list 1 2 3) + (list 4 5 6) + :test #'(lambda (x y) + (when (< y x) (return-from fail 'fail)) + (eql x y))) + #'<)) + (1 2 3 4 5 6)) + +(deftest union-29 + (block fail + (sort + (union-with-check-and-key + (list 1 2 3) + (list 4 5 6) + #'identity + :test #'(lambda (x y) + (when (< y x) (return-from fail 'fail)) + (eql x y))) + #'<)) + (1 2 3 4 5 6)) + +(deftest union-30 + (block fail + (sort + (union-with-check + (list 1 2 3) + (list 4 5 6) + :test-not + #'(lambda (x y) + (when (< y x) (return-from fail 'fail)) + (not (eql x y)))) + #'<)) + (1 2 3 4 5 6)) + +(deftest union-31 + (block fail + (sort + (union-with-check-and-key + (list 1 2 3) + (list 4 5 6) + #'identity + :test-not #'(lambda (x y) + (when (< y x) (return-from fail 'fail)) + (not (eql x y)))) + #'<)) + (1 2 3 4 5 6)) diff --git a/ansi-tests/cons-test-21.lsp b/ansi-tests/cons-test-21.lsp new file mode 100644 index 0000000000000000000000000000000000000000..71bba875eefb5ece0805e050e6d357baf96c3ee7 --- /dev/null +++ b/ansi-tests/cons-test-21.lsp @@ -0,0 +1,296 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Mar 28 22:11:27 1998 +;;;; Contains: Testing of CL Features related to "CONS", part 21 + +(in-package :cl-test) +(use-package :rt) +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; nunion + +(defun nunion-with-copy (x y &key test test-not) + (setf x (copy-list x)) + (setf y (copy-list y)) + (cond + (test (nunion x y :test test)) + (test-not (nunion x y :test-not test-not)) + (t (nunion x y)))) + +(defun nunion-with-copy-and-key (x y key &key test test-not) + (setf x (copy-list x)) + (setf y (copy-list y)) + (cond + (test (nunion x y :key key :test test)) + (test-not (nunion x y :key key :test-not test-not)) + (t (nunion x y :key key)))) + +(deftest nunion-1 + (nunion nil nil) + nil) + +(deftest nunion-2 + (nunion-with-copy (list 'a) nil) + (a)) + +(deftest nunion-3 + (nunion-with-copy (list 'a) (list 'a)) + (a)) + +(deftest nunion-4 + (nunion-with-copy (list 1) (list 1)) + (1)) + +(deftest nunion-5 + (let ((x (list 'a 'b))) + (nunion-with-copy (list x) (list x))) + ((a b))) + +(deftest nunion-6 + (let ((x '(a b c d e f)) + (y '(z c y a v b))) + (let ((result (nunion-with-copy x y))) + (check-union x y result))) + t) + +(deftest nunion-6-a + (let ((x '(a b c d e f)) + (y '(z c y a v b))) + (let ((result (nunion-with-copy x y :test #'eq))) + (check-union x y result))) + t) + +(deftest nunion-7 + (let ((x '(a b c d e f)) + (y '(z c y a v b))) + (let ((result (nunion-with-copy x y :test #'eql))) + (check-union x y result))) + t) + +(deftest nunion-8 + (let ((x '(a b c d e f)) + (y '(z c y a v b))) + (let ((result (nunion-with-copy x y :test #'equal))) + (check-union x y result))) + t) + +(deftest nunion-9 + (let ((x '(a b c d e f)) + (y '(z c y a v b))) + (let ((result (nunion-with-copy x y :test-not (complement #'eql)))) + (check-union x y result))) + t) + +(deftest nunion-10 + (let ((x '(a b c d e f)) + (y '(z c y a v b))) + (let ((result (nunion-with-copy x y :test-not (complement #'equal)))) + (check-union x y result))) + t) + +(deftest nunion-11 + (let ((x '(a b c d e f)) + (y '(z c y a v b))) + (let ((result (nunion-with-copy x y :test-not (complement #'eq)))) + (check-union x y result))) + t) + +(deftest nunion-12 + (let ((x '(1 2 3 4 5 6 7)) + (y '(10 19 5 3 17 1001 2))) + (let ((result (nunion-with-copy x y))) + (check-union x y result))) + t) + +(deftest nunion-13 + (let ((x '(1 2 3 4 5 6 7)) + (y '(10 19 5 3 17 1001 2))) + (let ((result (nunion-with-copy x y :test #'equal))) + (check-union x y result))) + t) + +(deftest nunion-14 + (let ((x '(1 2 3 4 5 6 7)) + (y '(10 19 5 3 17 1001 2))) + (let ((result (nunion-with-copy x y :test #'eql))) + (check-union x y result))) + t) + +(deftest nunion-15 + (let ((x '(1 2 3 4 5 6 7)) + (y '(10 19 5 3 17 1001 2))) + (let ((result (nunion-with-copy x y :test-not (complement #'equal)))) + (check-union x y result))) + t) + +(deftest nunion-16 + (let ((x '(1 2 3 4 5 6 7)) + (y '(10 19 5 3 17 1001 2))) + (let ((result (nunion-with-copy x y :test-not (complement #'eql)))) + (check-union x y result))) + t) + +(deftest nunion-17 + (let ((x '(1 2 3 4 5 6 7)) + (y '(10 19 5 3 17 1001 2))) + (let ((result (nunion-with-copy-and-key x y #'1+))) + (check-union x y result))) + t) + +(deftest nunion-18 + (let ((x '(1 2 3 4 5 6 7)) + (y '(10 19 5 3 17 1001 2))) + (let ((result (nunion-with-copy-and-key x y #'1+ :test #'equal))) + (check-union x y result))) + t) + +(deftest nunion-19 + (let ((x '(1 2 3 4 5 6 7)) + (y '(10 19 5 3 17 1001 2))) + (let ((result (nunion-with-copy-and-key x y #'1+ :test #'eql))) + (check-union x y result))) + t) + +(deftest nunion-20 + (let ((x '(1 2 3 4 5 6 7)) + (y '(10 19 5 3 17 1001 2))) + (let ((result (nunion-with-copy-and-key x y #'1+ + :test-not (complement #'equal)))) + (check-union x y result))) + t) + +(deftest nunion-21 + (let ((x '(1 2 3 4 5 6 7)) + (y '(10 19 5 3 17 1001 2))) + (let ((result (nunion-with-copy-and-key x y #'1+ + :test-not (complement #'equal)))) + (check-union x y result))) + t) + +(deftest nunion-22 + (handler-case + (let ((x '(1 2 3 4 5 6 7)) + (y '(10 19 5 3 17 1001 2))) + (let ((result (nunion-with-copy-and-key x y nil))) + (check-union x y result))) + (error (c) c)) + t) + +(deftest nunion-23 + (let ((x '(1 2 3 4 5 6 7)) + (y '(10 19 5 3 17 1001 2))) + (let ((result (nunion-with-copy-and-key x y '1+))) + (check-union x y result))) + t) + +;; Do large numbers of random units + +(defun do-random-nunions (size niters &optional (maxelem (* 2 size))) + (let ((state (make-random-state))) + (loop + for i from 1 to niters do + (let ((x (shuffle (loop for j from 1 to size collect + (random maxelem state)))) + (y (shuffle (loop for j from 1 to size collect + (random maxelem state))))) + (let ((z (nunion-with-copy x y))) + (let ((is-good (check-union x y z))) + (unless is-good (return (values x y z))))))) + nil)) + +(deftest nunion-24 + (do-random-nunions 100 100 200) + nil) + +(deftest nunion-25 + (let ((x (shuffle '(1 4 6 10 45 101))) + (y '(102 5 2 11 44 6))) + (let ((result (nunion-with-copy x y + :test #'(lambda (a b) + (<= (abs (- a b)) 1))))) + (sort + (sublis + '((2 . 1) (5 . 4) (11 . 10) (45 . 44) (102 . 101)) + (copy-list result)) + #'<))) + (1 4 6 10 44 101)) + +;; Check that nunion uses eql, not equal or eq + +(deftest nunion-26 + (let ((x 1000) + (y 1000)) + (loop + while (not (typep x 'bignum)) + do (progn + (setf x (* x x)) + (setf y (* y y)))) + (not (not + (or + (eq x y) ;; if bignums are eq, the test is worthless + (eql (length + (nunion-with-copy (list x) (list x))) + 1))))) + t) + +(deftest nunion-27 + (nunion-with-copy (list (copy-seq "aa")) + (list (copy-seq "aa"))) + ("aa" "aa")) + + + +;; Check that nunion does not reverse the arguments to :test, :test-not + +(deftest nunion-28 + (block fail + (sort + (nunion-with-copy + '(1 2 3) + '(4 5 6) + :test #'(lambda (x y) + (when (< y x) (return-from fail 'fail)) + (eql x y))) + #'<)) + (1 2 3 4 5 6)) + +(deftest nunion-29 + (block fail + (sort + (nunion-with-copy-and-key + '(1 2 3) + '(4 5 6) + #'identity + :test #'(lambda (x y) + (when (< y x) (return-from fail 'fail)) + (eql x y))) + #'<)) + (1 2 3 4 5 6)) + +(deftest nunion-30 + (block fail + (sort + (nunion-with-copy + '(1 2 3) + '(4 5 6) + :test-not + #'(lambda (x y) + (when (< y x) (return-from fail 'fail)) + (not (eql x y)))) + #'<)) + (1 2 3 4 5 6)) + +(deftest nunion-31 + (block fail + (sort + (nunion-with-copy-and-key + '(1 2 3) + '(4 5 6) + #'identity + :test-not #'(lambda (x y) + (when (< y x) (return-from fail 'fail)) + (not (eql x y)))) + #'<)) + (1 2 3 4 5 6)) + diff --git a/ansi-tests/cons-test-22.lsp b/ansi-tests/cons-test-22.lsp new file mode 100644 index 0000000000000000000000000000000000000000..3ad77a6453bb8d5b395185c6f4bb113d1a88902f --- /dev/null +++ b/ansi-tests/cons-test-22.lsp @@ -0,0 +1,367 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Mon Mar 30 22:10:34 1998 +;;;; Contains: Testing of CL Features related to "CONS", part 22 + +(in-package :cl-test) +(use-package :rt) +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; set-difference + +(defun set-difference-with-check (x y &key (key 'no-key) + test test-not) + (setf x (copy-list x)) + (setf y (copy-list y)) + (let ((xcopy (make-scaffold-copy x)) + (ycopy (make-scaffold-copy y))) + (let ((result (apply #'set-difference + x y + `(,@(unless (eq key 'no-key) `(:key ,key)) + ,@(when test `(:test ,test)) + ,@(when test-not `(:test-not ,test-not)))))) + (cond + ((and (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy)) + result) + (t + 'failed))))) + +(defun check-set-difference (x y z &key (key #'identity) + (test #'eql)) + (and + (not (eq 'failed z)) + (every #'(lambda (e) (member e x :key key :test test)) z) + (every #'(lambda (e) (or (member e y :key key :test test) + (member e z :key key :test test))) x) + (every #'(lambda (e) (not (member e z :key key :test test))) y) + t)) + +(deftest set-difference-1 + (set-difference nil nil) + nil) + +(deftest set-difference-2 + (let ((result + (set-difference-with-check '(a b c) nil))) + (check-set-difference '(a b c) nil result)) + t) + +(deftest set-difference-3 + (let ((result + (set-difference-with-check '(a b c d e f) '(f b d)))) + (check-set-difference '(a b c d e f) '(f b d) result)) + t) + +(deftest set-difference-4 + (sort + (copy-list + (set-difference-with-check (shuffle '(1 2 3 4 5 6 7 8)) + '(10 101 4 74 2 1391 7 17831))) + #'<) + (1 3 5 6 8)) + +(deftest set-difference-5 + (set-difference-with-check nil '(a b c d e f g h)) + nil) + +(deftest set-difference-6 + (handler-case + (set-difference-with-check '(a b c d e) '(d a b e) + :key nil) + (error (c) c)) + (c)) + +(deftest set-difference-7 + (set-difference-with-check '(a b c d e) '(d a b e) :test #'eq) + (c)) + +(deftest set-difference-8 + (set-difference-with-check '(a b c d e) '(d a b e) :test #'eql) + (c)) + +(deftest set-difference-9 + (set-difference-with-check '(a b c d e) '(d a b e) :test #'equal) + (c)) + +(deftest set-difference-10 + (set-difference-with-check '(a b c d e) '(d a b e) + :test 'eq) + (c)) + +(deftest set-difference-11 + (set-difference-with-check '(a b c d e) '(d a b e) + :test 'eql) + (c)) + +(deftest set-difference-12 + (set-difference-with-check '(a b c d e) '(d a b e) + :test 'equal) + (c)) + +(defun do-random-set-differences (size niters &optional (maxelem (* 2 size))) + (let ((state (make-random-state))) + (loop + for i from 1 to niters do + (let ((x (shuffle (loop for j from 1 to size collect + (random maxelem state)))) + (y (shuffle (loop for j from 1 to size collect + (random maxelem state))))) + (let ((z (set-difference-with-check x y))) + (let ((is-good (check-set-difference x y z))) + (unless is-good (return (values x y z))))))) + nil)) + +(deftest set-difference-13 + (do-random-set-differences 100 100) + nil) + +(deftest set-difference-14 + (set-difference-with-check '((a . 1) (b . 2) (c . 3)) + '((a . 1) (c . 3)) + :key 'car) + ((b . 2))) + +(deftest set-difference-15 + (set-difference-with-check '((a . 1) (b . 2) (c . 3)) + '((a . 1) (c . 3)) + :key #'car) + ((b . 2))) + +;; +;; Verify that the :test argument is called with the arguments +;; in the correct order +;; +(deftest set-difference-16 + (block fail + (sort + (copy-list + (set-difference-with-check + '(1 2 3 4) '(e f g h) + :test #'(lambda (x y) + (when (or (member x '(e f g h)) + (member y '(1 2 3 4))) + (return-from fail 'fail)) + (eq x y)))) + #'<)) + (1 2 3 4)) + +(deftest set-difference-17 + (block fail + (sort + (copy-list + (set-difference-with-check + '(1 2 3 4) '(e f g h) + :key #'identity + :test #'(lambda (x y) + (when (or (member x '(e f g h)) + (member y '(1 2 3 4))) + (return-from fail 'fail)) + (eq x y)))) + #'<)) + (1 2 3 4)) + +(deftest set-difference-18 + (block fail + (sort + (copy-list + (set-difference-with-check + '(1 2 3 4) '(e f g h) + :test-not + #'(lambda (x y) + (when (or (member x '(e f g h)) + (member y '(1 2 3 4))) + (return-from fail 'fail)) + (not (eq x y))))) + #'<)) + (1 2 3 4)) + +(deftest set-difference-19 + (block fail + (sort + (copy-list + (set-difference-with-check + '(1 2 3 4) '(e f g h) + :test-not + #'(lambda (x y) + (when (or (member x '(e f g h)) + (member y '(1 2 3 4))) + (return-from fail 'fail)) + (not (eq x y))))) + #'<)) + (1 2 3 4)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; nset-difference + +(defun nset-difference-with-check (x y &key (key 'no-key) + test test-not) + (setf x (copy-list x)) + (setf y (copy-list y)) + (apply #'nset-difference + x y + `(,@(unless (eq key 'no-key) `(:key ,key)) + ,@(when test `(:test ,test)) + ,@(when test-not `(:test-not ,test-not))))) + +(defun check-nset-difference (x y z &key (key #'identity) + (test #'eql)) + (and + (every #'(lambda (e) (member e x :key key :test test)) z) + (every #'(lambda (e) (or (member e y :key key :test test) + (member e z :key key :test test))) x) + (every #'(lambda (e) (not (member e z :key key :test test))) y))) + +(deftest nset-difference-1 + (nset-difference nil nil) + nil) + +(deftest nset-difference-2 + (let ((result + (nset-difference-with-check '(a b c) nil))) + (check-nset-difference '(a b c) nil result)) + t) + +(deftest nset-difference-3 + (let ((result + (nset-difference-with-check '(a b c d e f) '(f b d)))) + (check-nset-difference '(a b c d e f) '(f b d) result)) + t) + +(deftest nset-difference-4 + (sort + (copy-list + (nset-difference-with-check (shuffle '(1 2 3 4 5 6 7 8)) + '(10 101 4 74 2 1391 7 17831))) + #'<) + (1 3 5 6 8)) + +(deftest nset-difference-5 + (nset-difference-with-check nil '(a b c d e f g h)) + nil) + +(deftest nset-difference-6 + (handler-case + (nset-difference-with-check '(a b c d e) '(d a b e) + :key nil) + (error (c) c)) + (c)) + +(deftest nset-difference-7 + (nset-difference-with-check '(a b c d e) '(d a b e) :test #'eq) + (c)) + +(deftest nset-difference-8 + (nset-difference-with-check '(a b c d e) '(d a b e) :test #'eql) + (c)) + +(deftest nset-difference-9 + (nset-difference-with-check '(a b c d e) '(d a b e) :test #'equal) + (c)) + +(deftest nset-difference-10 + (nset-difference-with-check '(a b c d e) '(d a b e) + :test 'eq) + (c)) + +(deftest nset-difference-11 + (nset-difference-with-check '(a b c d e) '(d a b e) + :test 'eql) + (c)) + +(deftest nset-difference-12 + (nset-difference-with-check '(a b c d e) '(d a b e) + :test 'equal) + (c)) + +(defun do-random-nset-differences (size niters &optional (maxelem (* 2 size))) + (let ((state (make-random-state))) + (loop + for i from 1 to niters do + (let ((x (shuffle (loop for j from 1 to size collect + (random maxelem state)))) + (y (shuffle (loop for j from 1 to size collect + (random maxelem state))))) + (let ((z (nset-difference-with-check x y))) + (let ((is-good (check-nset-difference x y z))) + (unless is-good (return (values x y z))))))) + nil)) + +(deftest nset-difference-13 + (do-random-nset-differences 100 100) + nil) + +(deftest nset-difference-14 + (nset-difference-with-check '((a . 1) (b . 2) (c . 3)) + '((a . 1) (c . 3)) + :key 'car) + ((b . 2))) + +(deftest nset-difference-15 + (nset-difference-with-check '((a . 1) (b . 2) (c . 3)) + '((a . 1) (c . 3)) + :key #'car) + ((b . 2))) + +;; +;; Verify that the :test argument is called with the arguments +;; in the correct order +;; +(deftest nset-difference-16 + (block fail + (sort + (copy-list + (nset-difference-with-check + '(1 2 3 4) '(e f g h) + :test #'(lambda (x y) + (when (or (member x '(e f g h)) + (member y '(1 2 3 4))) + (return-from fail 'fail)) + (eq x y)))) + #'<)) + (1 2 3 4)) + +(deftest nset-difference-17 + (block fail + (sort + (copy-list + (nset-difference-with-check + '(1 2 3 4) '(e f g h) + :key #'identity + :test #'(lambda (x y) + (when (or (member x '(e f g h)) + (member y '(1 2 3 4))) + (return-from fail 'fail)) + (eq x y)))) + #'<)) + (1 2 3 4)) + +(deftest nset-difference-18 + (block fail + (sort + (copy-list + (nset-difference-with-check + '(1 2 3 4) '(e f g h) + :test-not + #'(lambda (x y) + (when (or (member x '(e f g h)) + (member y '(1 2 3 4))) + (return-from fail 'fail)) + (not (eq x y))))) + #'<)) + (1 2 3 4)) + +(deftest nset-difference-19 + (block fail + (sort (copy-list + (nset-difference-with-check + '(1 2 3 4) '(e f g h) + :test-not + #'(lambda (x y) + (when (or (member x '(e f g h)) + (member y '(1 2 3 4))) + (return-from fail 'fail)) + (not (eq x y))))) + #'<)) + (1 2 3 4)) \ No newline at end of file diff --git a/ansi-tests/cons-test-23.lsp b/ansi-tests/cons-test-23.lsp new file mode 100644 index 0000000000000000000000000000000000000000..95b0f7ffcc2920fd702f6deae9c2c70b700a09e1 --- /dev/null +++ b/ansi-tests/cons-test-23.lsp @@ -0,0 +1,410 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Wed Apr 1 21:49:43 1998 +;;;; Contains: Testing of CL Features related to "CONS", part 23 + +(in-package :cl-test) +(use-package :rt) +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; set-exclusive-or + +(defun set-exclusive-or-with-check (x y &key (key 'no-key) + test test-not) + (setf x (copy-list x)) + (setf y (copy-list y)) + (let ((xcopy (make-scaffold-copy x)) + (ycopy (make-scaffold-copy y))) + (let ((result (apply #'set-exclusive-or + x y + `(,@(unless (eq key 'no-key) `(:key ,key)) + ,@(when test `(:test ,test)) + ,@(when test-not `(:test-not ,test-not)))))) + (cond + ((and (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy)) + result) + (t + 'failed))))) + +(defun check-set-exclusive-or (x y z &key (key #'identity) + (test #'eql)) + (and + (not (eq 'failed z)) + (every #'(lambda (e) (or (member e x :key key :test test) + (member e y :key key :test test))) + z) + (every #'(lambda (e) (if (member e y :key key :test test) + (not (member e z :key key :test test)) + (member e z :key key :test test))) + x) + (every #'(lambda (e) (if (member e x :key key :test test) + (not (member e z :key key :test test)) + (member e z :key key :test test))) + y) + t)) + +(deftest set-exclusive-or-1 + (set-exclusive-or nil nil) + nil) + +(deftest set-exclusive-or-2 + (let ((result + (set-exclusive-or-with-check '(a b c) nil))) + (check-set-exclusive-or '(a b c) nil result)) + t) + +(deftest set-exclusive-or-3 + (let ((result + (set-exclusive-or-with-check '(a b c d e f) '(f b d)))) + (check-set-exclusive-or '(a b c d e f) '(f b d) result)) + t) + +(deftest set-exclusive-or-4 + (sort + (copy-list + (set-exclusive-or-with-check (shuffle '(1 2 3 4 5 6 7 8)) + '(10 101 4 74 2 1391 7 17831))) + #'<) + (1 3 5 6 8 10 74 101 1391 17831)) + +(deftest set-exclusive-or-5 + (check-set-exclusive-or + nil + '(a b c d e f g h) + (set-exclusive-or-with-check nil '(a b c d e f g h))) + t) + +(deftest set-exclusive-or-6 + (handler-case + (set-exclusive-or-with-check '(a b c d e) '(d a b e) + :key nil) + (error (c) c)) + (c)) + +(deftest set-exclusive-or-7 + (set-exclusive-or-with-check '(a b c d e) '(d a b e) :test #'eq) + (c)) + +(deftest set-exclusive-or-7-a + (set-exclusive-or-with-check '(d a b e) '(a b c d e) :test #'eq) + (c)) + +(deftest set-exclusive-or-8 + (set-exclusive-or-with-check '(a b c d e) '(d a b e) :test #'eql) + (c)) + +(deftest set-exclusive-or-8-a + (set-exclusive-or-with-check '(e d b a) '(a b c d e) :test #'eql) + (c)) + +(deftest set-exclusive-or-8-b + (set-exclusive-or-with-check '(a b c d e) '(d a b e) + :test-not (complement #'eql)) + (c)) + +(deftest set-exclusive-or-9 + (set-exclusive-or-with-check '(a b c d e) '(d a b e) :test #'equal) + (c)) + +(deftest set-exclusive-or-10 + (set-exclusive-or-with-check '(a b c d e) '(d a b e) + :test 'eq) + (c)) + +(deftest set-exclusive-or-11 + (set-exclusive-or-with-check '(a b c d e) '(d a b e) + :test 'eql) + (c)) + +(deftest set-exclusive-or-12 + (set-exclusive-or-with-check '(a b c d e) '(d a b e) + :test 'equal) + (c)) + +(defun do-random-set-exclusive-ors (size niters &optional (maxelem (* 2 size))) + (let ((state (make-random-state))) + (loop + for i from 1 to niters do + (let ((x (shuffle (loop for j from 1 to size collect + (random maxelem state)))) + (y (shuffle (loop for j from 1 to size collect + (random maxelem state))))) + (let ((z (set-exclusive-or-with-check x y))) + (let ((is-good (check-set-exclusive-or x y z))) + (unless is-good (return (values x y z))))))) + nil)) + +(deftest set-exclusive-or-13 + (do-random-set-exclusive-ors 100 100) + nil) + +(deftest set-exclusive-or-14 + (set-exclusive-or-with-check '((a . 1) (b . 2) (c . 3012)) + '((a . 10) (c . 3)) + :key 'car) + ((b . 2))) + +(deftest set-exclusive-or-15 + (set-exclusive-or-with-check '((a . xx) (b . 2) (c . 3)) + '((a . 1) (c . 3313)) + :key #'car) + ((b . 2))) + +(deftest set-exclusive-or-16 + (set-exclusive-or-with-check '((a . xx) (b . 2) (c . 3)) + '((a . 1) (c . 3313)) + :key #'car + :test-not (complement #'eql)) + ((b . 2))) + +;; +;; Check that set-exclusive-or does not invert +;; the order of the arguments to the test function +;; +(deftest set-exclusive-or-17 + (let ((list1 '(a b c d)) + (list2 '(e f g h))) + (block fail + (not (not + (set-exclusive-or-with-check + list1 list2 + :test #'(lambda (s1 s2) + (when (or (member s1 list2) + (member s2 list1)) + (return-from fail 'failed)))))))) + t) + +(deftest set-exclusive-or-17-a + (let ((list1 '(a b c d)) + (list2 '(e f g h))) + (block fail + (not (not + (set-exclusive-or-with-check + list1 list2 + :key #'identity + :test #'(lambda (s1 s2) + (when (or (member s1 list2) + (member s2 list1)) + (return-from fail 'failed)))))))) + t) + +(deftest set-exclusive-or-18 + (let ((list1 '(a b c d)) + (list2 '(e f g h))) + (block fail + (not (not + (set-exclusive-or-with-check + list1 list2 + :test-not + #'(lambda (s1 s2) + (when (or (member s1 list2) + (member s2 list1)) + (return-from fail 'failed)) + t)))))) + t) + +(deftest set-exclusive-or-18-a + (let ((list1 '(a b c d)) + (list2 '(e f g h))) + (block fail + (not (not + (set-exclusive-or-with-check + list1 list2 + :key #'identity + :test-not + #'(lambda (s1 s2) + (when (or (member s1 list2) + (member s2 list1)) + (return-from fail 'failed)) + t)))))) + t) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; nset-exclusive-or + +(defun nset-exclusive-or-with-check (x y &key (key 'no-key) + test test-not) + (setf x (copy-list x)) + (setf y (copy-list y)) + (apply #'nset-exclusive-or + x y + `(,@(unless (eq key 'no-key) `(:key ,key)) + ,@(when test `(:test ,test)) + ,@(when test-not `(:test-not ,test-not))))) + +(deftest nset-exclusive-or-1 + (nset-exclusive-or nil nil) + nil) + +(deftest nset-exclusive-or-2 + (let ((result + (nset-exclusive-or-with-check '(a b c) nil))) + (check-set-exclusive-or '(a b c) nil result)) + t) + +(deftest nset-exclusive-or-3 + (let ((result + (nset-exclusive-or-with-check '(a b c d e f) '(f b d)))) + (check-set-exclusive-or '(a b c d e f) '(f b d) result)) + t) + +(deftest nset-exclusive-or-4 + (sort + (copy-list + (nset-exclusive-or-with-check (shuffle '(1 2 3 4 5 6 7 8)) + '(10 101 4 74 2 1391 7 17831))) + #'<) + (1 3 5 6 8 10 74 101 1391 17831)) + +(deftest nset-exclusive-or-5 + (check-set-exclusive-or + nil + '(a b c d e f g h) + (nset-exclusive-or-with-check nil '(a b c d e f g h))) + t) + +(deftest nset-exclusive-or-6 + (handler-case + (nset-exclusive-or-with-check '(a b c d e) '(d a b e) + :key nil) + (error (c) c)) + (c)) + +(deftest nset-exclusive-or-7 + (nset-exclusive-or-with-check '(a b c d e) '(d a b e) :test #'eq) + (c)) + +(deftest nset-exclusive-or-7-a + (nset-exclusive-or-with-check '(d a b e) '(a b c d e) :test #'eq) + (c)) + +(deftest nset-exclusive-or-8 + (nset-exclusive-or-with-check '(a b c d e) '(d a b e) :test #'eql) + (c)) + +(deftest nset-exclusive-or-8-a + (nset-exclusive-or-with-check '(e d b a) '(a b c d e) :test #'eql) + (c)) + +(deftest nset-exclusive-or-8-b + (nset-exclusive-or-with-check '(a b c d e) '(d a b e) + :test-not (complement #'eql)) + (c)) + +(deftest nset-exclusive-or-9 + (nset-exclusive-or-with-check '(a b c d e) '(d a b e) :test #'equal) + (c)) + +(deftest nset-exclusive-or-10 + (nset-exclusive-or-with-check '(a b c d e) '(d a b e) + :test 'eq) + (c)) + +(deftest nset-exclusive-or-11 + (nset-exclusive-or-with-check '(a b c d e) '(d a b e) + :test 'eql) + (c)) + +(deftest nset-exclusive-or-12 + (nset-exclusive-or-with-check '(a b c d e) '(d a b e) + :test 'equal) + (c)) + +(defun do-random-nset-exclusive-ors (size niters &optional (maxelem (* 2 size))) + (let ((state (make-random-state))) + (loop + for i from 1 to niters do + (let ((x (shuffle (loop for j from 1 to size collect + (random maxelem state)))) + (y (shuffle (loop for j from 1 to size collect + (random maxelem state))))) + (let ((z (nset-exclusive-or-with-check x y))) + (let ((is-good (check-set-exclusive-or x y z))) + (unless is-good (return (values x y z))))))) + nil)) + +(deftest nset-exclusive-or-13 + (do-random-nset-exclusive-ors 100 100) + nil) + +(deftest nset-exclusive-or-14 + (nset-exclusive-or-with-check '((a . 1) (b . 2) (c . 3012)) + '((a . 10) (c . 3)) + :key 'car) + ((b . 2))) + +(deftest nset-exclusive-or-15 + (nset-exclusive-or-with-check '((a . xx) (b . 2) (c . 3)) + '((a . 1) (c . 3313)) + :key #'car) + ((b . 2))) + +(deftest nset-exclusive-or-16 + (nset-exclusive-or-with-check '((a . xx) (b . 2) (c . 3)) + '((a . 1) (c . 3313)) + :key #'car + :test-not (complement #'eql)) + ((b . 2))) + +;; +;; Check that nset-exclusive-or does not invert +;; the order of the arguments to the test function +;; +(deftest nset-exclusive-or-17 + (let ((list1 '(a b c d)) + (list2 '(e f g h))) + (block fail + (not (not + (nset-exclusive-or-with-check + list1 list2 + :test #'(lambda (s1 s2) + (when (or (member s1 list2) + (member s2 list1)) + (return-from fail 'failed)))))))) + t) + +(deftest nset-exclusive-or-17-a + (let ((list1 '(a b c d)) + (list2 '(e f g h))) + (block fail + (not (not + (nset-exclusive-or-with-check + list1 list2 + :key #'identity + :test #'(lambda (s1 s2) + (when (or (member s1 list2) + (member s2 list1)) + (return-from fail 'failed)))))))) + t) + +(deftest nset-exclusive-or-18 + (let ((list1 '(a b c d)) + (list2 '(e f g h))) + (block fail + (not (not + (nset-exclusive-or-with-check + list1 list2 + :test-not + #'(lambda (s1 s2) + (when (or (member s1 list2) + (member s2 list1)) + (return-from fail 'failed)) + t)))))) + t) + +(deftest nset-exclusive-or-18-a + (let ((list1 '(a b c d)) + (list2 '(e f g h))) + (block fail + (not (not + (nset-exclusive-or-with-check + list1 list2 + :key #'identity + :test-not + #'(lambda (s1 s2) + (when (or (member s1 list2) + (member s2 list1)) + (return-from fail 'failed)) + t)))))) + t) diff --git a/ansi-tests/cons-test-24.lsp b/ansi-tests/cons-test-24.lsp new file mode 100644 index 0000000000000000000000000000000000000000..31dbf09c989f94347d15c05047aadc5a30582faa --- /dev/null +++ b/ansi-tests/cons-test-24.lsp @@ -0,0 +1,144 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Wed Apr 1 22:10:54 1998 +;;;; Contains: Testing of CL Features related to "CONS", part 24 + +(in-package :cl-test) +(use-package :rt) +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; subsetp + +(defvar cons-test-24-var '(78 "z" (8 9))) + +(defun subsetp-with-check (x y &key (key 'no-key) test test-not) + (let ((xcopy (make-scaffold-copy x)) + (ycopy (make-scaffold-copy y))) + (let ((result + (apply #'subsetp x y + `(,@(unless (eq key 'no-key) + `(:key ,key)) + ,@(when test `(:test ,test)) + ,@(when test-not `(:test-not ,test-not)))))) + (cond + ((and (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy)) + (not (not result))) + (t 'failed))))) + +(deftest subsetp-1 + (subsetp-with-check (copy-tree '(78)) cons-test-24-var) + t) + +(deftest subsetp-2 + (subsetp-with-check (copy-tree '((8 9))) cons-test-24-var) + nil) + +(deftest subsetp-3 + (subsetp-with-check (copy-tree '((8 9))) + cons-test-24-var :test 'equal) + t) + +(deftest subsetp-4 + (subsetp-with-check (list 78 (copy-seq "Z")) cons-test-24-var + :test #'equalp) + t) + +(deftest subsetp-5 + (subsetp-with-check (list 1) (list 0 2 3 4) + :key #'(lambda (i) (floor (/ i 2)))) + t) + +(deftest subsetp-6 + (subsetp-with-check (list 1 6) (list 0 2 3 4) + :key #'(lambda (i) (floor (/ i 2)))) + nil) + +(deftest subsetp-7 + (subsetp-with-check (list '(a . 10) '(b . 20) '(c . 30)) + (list '(z . c) '(a . y) '(b . 100) '(e . f) + '(c . foo)) + :key #'car) + t) + +(deftest subsetp-8 + (subsetp-with-check (copy-tree '((a . 10) (b . 20) (c . 30))) + (copy-tree '((z . c) (a . y) (b . 100) (e . f) + (c . foo))) + :key 'car) + t) + +(deftest subsetp-9 + (subsetp-with-check (list 'a 'b 'c) + (copy-tree + (list '(z . c) '(a . y) '(b . 100) '(e . f) + '(c . foo))) + :test #'(lambda (e1 e2) + (eq e1 (car e2)))) + t) + +(deftest subsetp-10 + (handler-case + (subsetp-with-check (list 'a 'b 'c) + (copy-tree + (list '(z . c) '(a . y) '(b . 100) '(e . f) + '(c . foo))) + :test #'(lambda (e1 e2) + (eq e1 (car e2))) + :key nil) + (error (c) c)) + t) + +(deftest subsetp-11 + (subsetp-with-check (list 'a 'b 'c) + (copy-tree + (list '(z . c) '(a . y) '(b . 100) '(e . f) + '(c . foo))) + :test-not #'(lambda (e1 e2) + (not (eq e1 (car e2))))) + t) + +;; Check that it maintains order of arguments + +(deftest subsetp-12 + (block fail + (subsetp-with-check + (list 1 2 3) + (list 4 5 6) + :test #'(lambda (x y) + (when (< y x) (return-from fail 'fail)) + t))) + t) + +(deftest subsetp-13 + (block fail + (subsetp-with-check + (list 1 2 3) + (list 4 5 6) + :key #'identity + :test #'(lambda (x y) + (when (< y x) (return-from fail 'fail)) + t))) + t) + +(deftest subsetp-14 + (block fail + (subsetp-with-check + (list 1 2 3) + (list 4 5 6) + :test-not #'(lambda (x y) + (when (< y x) (return-from fail 'fail)) + nil))) + t) + +(deftest subsetp-15 + (block fail + (subsetp-with-check + (list 1 2 3) + (list 4 5 6) + :key #'identity + :test-not #'(lambda (x y) + (when (< y x) (return-from fail 'fail)) + nil))) + t) diff --git a/ansi-tests/cons-test-25.lsp b/ansi-tests/cons-test-25.lsp new file mode 100644 index 0000000000000000000000000000000000000000..07c5c11cd6640f16febc5d4f05149a2bbc8415fe --- /dev/null +++ b/ansi-tests/cons-test-25.lsp @@ -0,0 +1,66 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Apr 5 22:26:59 1998 +;;;; Contains: Testing of CL Features related to "CONS", part 25 + +(in-package :cl-test) +(use-package :rt) +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; setting of C*R accessors + +(defun create-c*r-test (n) + (cond + ((<= n 0) 'none) + (t + (cons (create-c*r-test (1- n)) + (create-c*r-test (1- n)))))) + +(loop + for fn in '(car cdr caar cadr cdar cddr + caaar caadr cadar caddr cdaar cdadr cddar cdddr + caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr + cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr) + do + (let ((level (- (length (symbol-name fn)) 2))) + (eval `(deftest ,(intern + (concatenate 'string + (symbol-name fn) + "-SET") + :cl-test) + (let ((x (create-c*r-test ,level))) + (and + (setf (,fn x) 'a) + (eql (,fn x) 'a) + (setf (,fn x) 'none) + (equal x (create-c*r-test ,level)) + )) + t)))) + +(loop + for (fn len) in '((first 1) (second 2) (third 3) (fourth 4) + (fifth 5) (sixth 6) (seventh 7) (eighth 8) + (ninth 9) (tenth 10)) + do + (eval + `(deftest ,(intern + (concatenate 'string + (symbol-name fn) + "-SET") + :cl-test) + (let ((x (make-list 20 :initial-element nil))) + (and + (setf (,fn x) 'a) + (loop + for i from 1 to 20 + do (when (and (not (eql i ,len)) + (nth (1- i) x)) + (return nil)) + finally (return t)) + (eql (,fn x) 'a) + (nth ,(1- len) x))) + a))) + + + diff --git a/ansi-tests/count-if-not.lsp b/ansi-tests/count-if-not.lsp new file mode 100644 index 0000000000000000000000000000000000000000..c6b1025aa08414c5437f0d87c512fada49eddc4c --- /dev/null +++ b/ansi-tests/count-if-not.lsp @@ -0,0 +1,397 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Tue Aug 20 22:42:35 2002 +;;;; Contains: Tests for COUNT-IF-NOT + +(in-package :cl-test) + +(deftest count-if-not-list.1 + (count-if-not #'identity '(a b nil c d nil e)) + 2) + +(deftest count-if-not-list.2 + (count-if-not #'not '(a b nil c d nil e)) + 5) + +(deftest count-if-not-list.3 + (count-if-not #'(lambda (x) (break)) nil) + 0) + +(deftest count-if-not-list.4 + (count-if-not #'identity '(a b nil c d nil e) :key #'identity) + 2) + +(deftest count-if-not-list.5 + (count-if-not 'identity '(a b nil c d nil e) :key #'identity) + 2) + +(deftest count-if-not-list.6 + (count-if-not #'identity '(a b nil c d nil e) :key 'identity) + 2) + +(deftest count-if-not-list.8 + (count-if-not #'identity '(a b nil c d nil e) :key 'not) + 5) + +(deftest count-if-not-list.9 + (count-if-not #'oddp '(1 2 3 4 4 1 8 10 1)) + 5) + +(deftest count-if-not-list.10 + (count-if-not #'oddp '(1 2 3 4 4 1 8 10 1) :key #'1+) + 4) + +(deftest count-if-not-list.11 + (let ((c 0)) + (count-if-not #'oddp '(1 2 3 4 4 1 8 10 1) + :key #'(lambda (x) (+ x (incf c))))) + 6) + +(deftest count-if-not-list.12 + (let ((c 0)) + (count-if-not #'oddp '(0 1 2 3 4 4 1 7 10 1) + :from-end t + :key #'(lambda (x) (+ x (incf c))))) + 8) + +(deftest count-if-not-list.13 + (count-if-not #'(lambda (x) (not (eq x 'a))) + '(a b c d a e f a e f f a a) :start 2) + 4) + +(deftest count-if-not-list.14 + (count-if-not #'(lambda (x) (not (eq x 'a))) + '(a b c d a e f a e f f a a) :end 7) + 2) + +(deftest count-if-not-list.15 + (count-if-not #'(lambda (x) (not (eq x 'a))) + '(a b c d a e f a e f f a a) :end 7 + :start 2) + 1) + +(deftest count-if-not-list.16 + (count-if-not #'(lambda (x) (not (eq x 'a))) + '(a b c d a e f a e f f a a) :end 7 + :start 2 :from-end t) + 1) + + +;;; tests on vectors + +(deftest count-if-not-vector.1 + (count-if-not #'identity #(a b nil c d nil e)) + 2) + +(deftest count-if-not-vector.2 + (count-if-not #'not #(a b nil c d nil e)) + 5) + +(deftest count-if-not-vector.3 + (count-if-not #'(lambda (x) (break)) #()) + 0) + +(deftest count-if-not-vector.4 + (count-if-not #'not #(a b nil c d nil e) :key #'identity) + 5) + +(deftest count-if-not-vector.5 + (count-if-not 'not #(a b nil c d nil e) :key #'identity) + 5) + +(deftest count-if-not-vector.6 + (count-if-not #'not #(a b nil c d nil e) :key 'identity) + 5) + +(deftest count-if-not-vector.8 + (count-if-not #'not #(a b nil c d nil e) :key 'not) + 2) + +(deftest count-if-not-vector.9 + (count-if-not #'oddp #(1 2 3 4 4 1 8 10 1)) + 5) + +(deftest count-if-not-vector.10 + (count-if-not #'oddp #(1 2 3 4 4 1 8 10 1) :key #'1+) + 4) + +(deftest count-if-not-vector.11 + (let ((c 0)) + (count-if-not #'oddp #(1 2 3 4 4 1 8 10 1) + :key #'(lambda (x) (+ x (incf c))))) + 6) + +(deftest count-if-not-vector.12 + (let ((c 0)) + (count-if-not #'oddp #(0 1 2 3 4 4 1 7 10 1) + :from-end t + :key #'(lambda (x) (+ x (incf c))))) + 8) + +(deftest count-if-not-vector.13 + (count-if-not #'(lambda (x) (not (eq x 'a))) + #(a b c d a e f a e f f a a) :start 2) + 4) + +(deftest count-if-not-vector.14 + (count-if-not #'(lambda (x) (not (eq x 'a))) + #(a b c d a e f a e f f a a) :end 7) + 2) + +(deftest count-if-not-vector.15 + (count-if-not #'(lambda (x) (not (eq x 'a))) + #(a b c d a e f a e f f a a) :end 7 + :start 2) + 1) + +(deftest count-if-not-vector.16 + (count-if-not #'(lambda (x) (not (eq x 'a))) + #(a b c d a e f a e f f a a) :end 7 + :start 2 :from-end t) + 1) + +;;; Non-simple vectors + +(deftest count-if-not-nonsimple-vector.1 + (count-if-not #'identity (make-array 7 :initial-contents '(a b nil c d nil e) + :fill-pointer t + :adjustable t)) + 2) + +(deftest count-if-not-nonsimple-vector.2 + (count-if-not #'not (make-array 7 :initial-contents '(a b nil c d nil e) + :fill-pointer t + :adjustable t)) + 5) + +(deftest count-if-not-nonsimple-vector.3 + (count-if-not #'(lambda (x) (break)) (make-array 0 + :fill-pointer t + :adjustable t)) + 0) + +(deftest count-if-not-nonsimple-vector.4 + (count-if-not #'not + (make-array 7 :initial-contents '(a b nil c d nil e) + :fill-pointer t + :adjustable t) + :key #'identity) + 5) + +(deftest count-if-not-nonsimple-vector.5 + (count-if-not 'not + (make-array 7 :initial-contents '(a b nil c d nil e) + :fill-pointer t + :adjustable t) + :key #'identity) + 5) + +(deftest count-if-not-nonsimple-vector.6 + (count-if-not #'not + (make-array 7 :initial-contents '(a b nil c d nil e) + :fill-pointer t + :adjustable t) + :key 'identity) + 5) + +(deftest count-if-not-nonsimple-vector.8 + (count-if-not #'not + (make-array 7 :initial-contents '(a b nil c d nil e) + :fill-pointer t + :adjustable t) + :key 'not) + 2) + +(deftest count-if-not-nonsimple-vector.9 + (count-if-not #'oddp (make-array 9 :initial-contents '(1 2 3 4 4 1 8 10 1) + :fill-pointer t :adjustable t)) + 5) + +(deftest count-if-not-nonsimple-vector.10 + (count-if-not #'oddp + (make-array 9 :initial-contents '(1 2 3 4 4 1 8 10 1) + :fill-pointer t :adjustable t) + :key #'1+) + 4) + +(deftest count-if-not-nonsimple-vector.11 + (let ((c 0)) + (count-if-not #'oddp + (make-array 9 :initial-contents '(1 2 3 4 4 1 8 10 1) + :fill-pointer t :adjustable t) + :key #'(lambda (x) (+ x (incf c))))) + 6) + +(deftest count-if-not-nonsimple-vector.12 + (let ((c 0)) + (count-if-not #'oddp + (make-array 10 :initial-contents '(0 1 2 3 4 4 1 7 10 1) + :fill-pointer t :adjustable t) + :from-end t + :key #'(lambda (x) (+ x (incf c))))) + 8) + +(deftest count-if-not-nonsimple-vector.13 + (count-if-not #'(lambda (x) (not (eq x 'a))) + (make-array 13 :initial-contents '(a b c d a e f a e f f a a) + :fill-pointer t :adjustable t) + :start 2) + 4) + +(deftest count-if-not-nonsimple-vector.14 + (count-if-not #'(lambda (x) (not (eq x 'a))) + (make-array 13 :initial-contents '(a b c d a e f a e f f a a) + :fill-pointer t :adjustable t) + :end 7) + 2) + +(deftest count-if-not-nonsimple-vector.15 + (count-if-not #'(lambda (x) (not (eq x 'a))) + (make-array 13 :initial-contents '(a b c d a e f a e f f a a) + :fill-pointer t :adjustable t) + :end 7 :start 2) + 1) + +(deftest count-if-not-nonsimple-vector.16 + (count-if-not #'(lambda (x) (not (eq x 'a))) + (make-array 13 :initial-contents '(a b c d a e f a e f f a a) + :fill-pointer t :adjustable t) + :end 7 :start 2 :from-end t) + 1) + +;;; tests on bitstrings + +(deftest count-if-not-bitstring.1 + (count-if-not #'oddp #*001011101101) + 5) + +(deftest count-if-not-bitstring.2 + (count-if-not #'identity #*001011101101) + 0) + +(deftest count-if-not-bitstring.3 + (count-if-not #'(lambda (x) (break)) #*) + 0) + +(deftest count-if-not-bitstring.4 + (count-if-not #'identity #*001011101101 :key #'zerop) + 7) + +(deftest count-if-not-bitstring.5 + (count-if-not 'not #*001011101101 :key #'zerop) + 5) + +(deftest count-if-not-bitstring.6 + (count-if-not #'not #*001011101101 :key 'zerop) + 5) + +(deftest count-if-not-bitstring.8 + (count-if-not #'identity #*001011101101 :key 'oddp) + 5) + +(deftest count-if-not-bitstring.10 + (count-if-not #'oddp #*001011101101 :key #'1+) + 7) + +(deftest count-if-not-bitstring.11 + (let ((c 0)) + (count-if-not #'oddp #*001011101101 + :key #'(lambda (x) (+ x (incf c))))) + 7) + +(deftest count-if-not-bitstring.12 + (let ((c 0)) + (count-if-not #'oddp #*001011101101 + :from-end t + :key #'(lambda (x) (+ x (incf c))))) + 5) + +(deftest count-if-not-bitstring.13 + (count-if-not #'zerop #*0111011011100 :start 2) + 7) + +(deftest count-if-not-bitstring.14 + (count-if-not #'zerop #*0111011011100 :end 7) + 5) + +(deftest count-if-not-bitstring.15 + (count-if-not #'zerop #*0111011011100 :end 7 :start 2) + 4) + +(deftest count-if-not-bitstring.16 + (count-if-not #'zerop #*0111011011100 :end 7 :start 2 :from-end t) + 4) + +;;; tests on strings + +(deftest count-if-not-string.1 + (count-if-not #'(lambda (x) (eql x #\0)) "001011101101") + 7) + +(deftest count-if-not-string.2 + (count-if-not #'identity "001011101101") + 0) + +(deftest count-if-not-string.3 + (count-if-not #'(lambda (x) (break)) "") + 0) + +(deftest count-if-not-string.4 + (count-if-not #'identity "001011101101" :key #'(lambda (x) (eql x #\0))) + 7) + +(deftest count-if-not-string.5 + (count-if-not 'identity "001011101101" :key #'(lambda (x) (eql x #\0))) + 7) + +(deftest count-if-not-string.6 + (count-if-not #'(lambda (x) (eql x #\0)) "001011101101" :key 'identity) + 7) + +(deftest count-if-not-string.8 + (count-if-not #'identity "001011101101" :key #'(lambda (x) (eql x #\1))) + 5) + +(deftest count-if-not-string.11 + (let ((c 0)) + (count-if-not #'oddp "001011101101" + :key #'(lambda (x) (+ (if (eql x #\0) 0 1) (incf c))))) + 7) + +(deftest count-if-not-string.12 + (let ((c 0)) + (count-if-not #'oddp "001011101101" + :from-end t + :key #'(lambda (x) (+ (if (eql x #\0) 0 1) (incf c))))) + 5) + +(deftest count-if-not-string.13 + (count-if-not #'(lambda (x) (eql x #\0)) "0111011011100" :start 2) + 7) + +(deftest count-if-not-string.14 + (count-if-not #'(lambda (x) (eql x #\0)) "0111011011100" :end 7) + 5) + +(deftest count-if-not-string.15 + (count-if-not #'(lambda (x) (eql x #\0)) "0111011011100" :end 7 :start 2) + 4) + +(deftest count-if-not-string.16 + (count-if-not #'(lambda (x) (eql x #\0)) + "0111011011100" :end 7 :start 2 :from-end t) + 4) + +;;; Error tests + +(deftest count-if-not-error.1 + (catch-type-error (count-if-not #'identity 1)) + type-error) + +(deftest count-if-not-error.2 + (catch-type-error (count-if-not #'identity 'a)) + type-error) + +(deftest count-if-not-error.3 + (catch-type-error (count-if-not #'identity #\a)) + type-error) diff --git a/ansi-tests/count-if.lsp b/ansi-tests/count-if.lsp new file mode 100644 index 0000000000000000000000000000000000000000..357cf80920cc537bfffcac37b3db983bcf7949e3 --- /dev/null +++ b/ansi-tests/count-if.lsp @@ -0,0 +1,397 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Tue Aug 20 08:01:30 2002 +;;;; Contains: Tests for COUNT-IF + +(in-package :cl-test) + +(deftest count-if-list.1 + (count-if #'identity '(a b nil c d nil e)) + 5) + +(deftest count-if-list.2 + (count-if #'not '(a b nil c d nil e)) + 2) + +(deftest count-if-list.3 + (count-if #'(lambda (x) (break)) nil) + 0) + +(deftest count-if-list.4 + (count-if #'identity '(a b nil c d nil e) :key #'identity) + 5) + +(deftest count-if-list.5 + (count-if 'identity '(a b nil c d nil e) :key #'identity) + 5) + +(deftest count-if-list.6 + (count-if #'identity '(a b nil c d nil e) :key 'identity) + 5) + +(deftest count-if-list.8 + (count-if #'identity '(a b nil c d nil e) :key 'not) + 2) + +(deftest count-if-list.9 + (count-if #'evenp '(1 2 3 4 4 1 8 10 1)) + 5) + +(deftest count-if-list.10 + (count-if #'evenp '(1 2 3 4 4 1 8 10 1) :key #'1+) + 4) + +(deftest count-if-list.11 + (let ((c 0)) + (count-if #'evenp '(1 2 3 4 4 1 8 10 1) + :key #'(lambda (x) (+ x (incf c))))) + 6) + +(deftest count-if-list.12 + (let ((c 0)) + (count-if #'evenp '(0 1 2 3 4 4 1 7 10 1) + :from-end t + :key #'(lambda (x) (+ x (incf c))))) + 8) + +(deftest count-if-list.13 + (count-if #'(lambda (x) (eq x 'a)) + '(a b c d a e f a e f f a a) :start 2) + 4) + +(deftest count-if-list.14 + (count-if #'(lambda (x) (eq x 'a)) + '(a b c d a e f a e f f a a) :end 7) + 2) + +(deftest count-if-list.15 + (count-if #'(lambda (x) (eq x 'a)) + '(a b c d a e f a e f f a a) :end 7 + :start 2) + 1) + +(deftest count-if-list.16 + (count-if #'(lambda (x) (eq x 'a)) + '(a b c d a e f a e f f a a) :end 7 + :start 2 :from-end t) + 1) + + +;;; tests on vectors + +(deftest count-if-vector.1 + (count-if #'identity #(a b nil c d nil e)) + 5) + +(deftest count-if-vector.2 + (count-if #'not #(a b nil c d nil e)) + 2) + +(deftest count-if-vector.3 + (count-if #'(lambda (x) (break)) #()) + 0) + +(deftest count-if-vector.4 + (count-if #'identity #(a b nil c d nil e) :key #'identity) + 5) + +(deftest count-if-vector.5 + (count-if 'identity #(a b nil c d nil e) :key #'identity) + 5) + +(deftest count-if-vector.6 + (count-if #'identity #(a b nil c d nil e) :key 'identity) + 5) + +(deftest count-if-vector.8 + (count-if #'identity #(a b nil c d nil e) :key 'not) + 2) + +(deftest count-if-vector.9 + (count-if #'evenp #(1 2 3 4 4 1 8 10 1)) + 5) + +(deftest count-if-vector.10 + (count-if #'evenp #(1 2 3 4 4 1 8 10 1) :key #'1+) + 4) + +(deftest count-if-vector.11 + (let ((c 0)) + (count-if #'evenp #(1 2 3 4 4 1 8 10 1) + :key #'(lambda (x) (+ x (incf c))))) + 6) + +(deftest count-if-vector.12 + (let ((c 0)) + (count-if #'evenp #(0 1 2 3 4 4 1 7 10 1) + :from-end t + :key #'(lambda (x) (+ x (incf c))))) + 8) + +(deftest count-if-vector.13 + (count-if #'(lambda (x) (eq x 'a)) + #(a b c d a e f a e f f a a) :start 2) + 4) + +(deftest count-if-vector.14 + (count-if #'(lambda (x) (eq x 'a)) + #(a b c d a e f a e f f a a) :end 7) + 2) + +(deftest count-if-vector.15 + (count-if #'(lambda (x) (eq x 'a)) + #(a b c d a e f a e f f a a) :end 7 + :start 2) + 1) + +(deftest count-if-vector.16 + (count-if #'(lambda (x) (eq x 'a)) + #(a b c d a e f a e f f a a) :end 7 + :start 2 :from-end t) + 1) + +;;; Non-simple vectors + +(deftest count-if-nonsimple-vector.1 + (count-if #'identity (make-array 7 :initial-contents '(a b nil c d nil e) + :fill-pointer t + :adjustable t)) + 5) + +(deftest count-if-nonsimple-vector.2 + (count-if #'not (make-array 7 :initial-contents '(a b nil c d nil e) + :fill-pointer t + :adjustable t)) + 2) + +(deftest count-if-nonsimple-vector.3 + (count-if #'(lambda (x) (break)) (make-array 0 + :fill-pointer t + :adjustable t)) + 0) + +(deftest count-if-nonsimple-vector.4 + (count-if #'identity + (make-array 7 :initial-contents '(a b nil c d nil e) + :fill-pointer t + :adjustable t) + :key #'identity) + 5) + +(deftest count-if-nonsimple-vector.5 + (count-if 'identity + (make-array 7 :initial-contents '(a b nil c d nil e) + :fill-pointer t + :adjustable t) + :key #'identity) + 5) + +(deftest count-if-nonsimple-vector.6 + (count-if #'identity + (make-array 7 :initial-contents '(a b nil c d nil e) + :fill-pointer t + :adjustable t) + :key 'identity) + 5) + +(deftest count-if-nonsimple-vector.8 + (count-if #'identity + (make-array 7 :initial-contents '(a b nil c d nil e) + :fill-pointer t + :adjustable t) + :key 'not) + 2) + +(deftest count-if-nonsimple-vector.9 + (count-if #'evenp (make-array 9 :initial-contents '(1 2 3 4 4 1 8 10 1) + :fill-pointer t :adjustable t)) + 5) + +(deftest count-if-nonsimple-vector.10 + (count-if #'evenp + (make-array 9 :initial-contents '(1 2 3 4 4 1 8 10 1) + :fill-pointer t :adjustable t) + :key #'1+) + 4) + +(deftest count-if-nonsimple-vector.11 + (let ((c 0)) + (count-if #'evenp + (make-array 9 :initial-contents '(1 2 3 4 4 1 8 10 1) + :fill-pointer t :adjustable t) + :key #'(lambda (x) (+ x (incf c))))) + 6) + +(deftest count-if-nonsimple-vector.12 + (let ((c 0)) + (count-if #'evenp + (make-array 10 :initial-contents '(0 1 2 3 4 4 1 7 10 1) + :fill-pointer t :adjustable t) + :from-end t + :key #'(lambda (x) (+ x (incf c))))) + 8) + +(deftest count-if-nonsimple-vector.13 + (count-if #'(lambda (x) (eq x 'a)) + (make-array 13 :initial-contents '(a b c d a e f a e f f a a) + :fill-pointer t :adjustable t) + :start 2) + 4) + +(deftest count-if-nonsimple-vector.14 + (count-if #'(lambda (x) (eq x 'a)) + (make-array 13 :initial-contents '(a b c d a e f a e f f a a) + :fill-pointer t :adjustable t) + :end 7) + 2) + +(deftest count-if-nonsimple-vector.15 + (count-if #'(lambda (x) (eq x 'a)) + (make-array 13 :initial-contents '(a b c d a e f a e f f a a) + :fill-pointer t :adjustable t) + :end 7 :start 2) + 1) + +(deftest count-if-nonsimple-vector.16 + (count-if #'(lambda (x) (eq x 'a)) + (make-array 13 :initial-contents '(a b c d a e f a e f f a a) + :fill-pointer t :adjustable t) + :end 7 :start 2 :from-end t) + 1) + +;;; tests on bitstrings + +(deftest count-if-bitstring.1 + (count-if #'evenp #*001011101101) + 5) + +(deftest count-if-bitstring.2 + (count-if #'identity #*001011101101) + 12) + +(deftest count-if-bitstring.3 + (count-if #'(lambda (x) (break)) #*) + 0) + +(deftest count-if-bitstring.4 + (count-if #'identity #*001011101101 :key #'zerop) + 5) + +(deftest count-if-bitstring.5 + (count-if 'identity #*001011101101 :key #'zerop) + 5) + +(deftest count-if-bitstring.6 + (count-if #'identity #*001011101101 :key 'zerop) + 5) + +(deftest count-if-bitstring.8 + (count-if #'identity #*001011101101 :key 'oddp) + 7) + +(deftest count-if-bitstring.10 + (count-if #'evenp #*001011101101 :key #'1+) + 7) + +(deftest count-if-bitstring.11 + (let ((c 0)) + (count-if #'evenp #*001011101101 + :key #'(lambda (x) (+ x (incf c))))) + 7) + +(deftest count-if-bitstring.12 + (let ((c 0)) + (count-if #'evenp #*001011101101 + :from-end t + :key #'(lambda (x) (+ x (incf c))))) + 5) + +(deftest count-if-bitstring.13 + (count-if #'zerop #*0111011011100 :start 2) + 4) + +(deftest count-if-bitstring.14 + (count-if #'zerop #*0111011011100 :end 7) + 2) + +(deftest count-if-bitstring.15 + (count-if #'zerop #*0111011011100 :end 7 :start 2) + 1) + +(deftest count-if-bitstring.16 + (count-if #'zerop #*0111011011100 :end 7 :start 2 :from-end t) + 1) + +;;; tests on strings + +(deftest count-if-string.1 + (count-if #'(lambda (x) (eql x #\0)) "001011101101") + 5) + +(deftest count-if-string.2 + (count-if #'identity "001011101101") + 12) + +(deftest count-if-string.3 + (count-if #'(lambda (x) (break)) "") + 0) + +(deftest count-if-string.4 + (count-if #'identity "001011101101" :key #'(lambda (x) (eql x #\0))) + 5) + +(deftest count-if-string.5 + (count-if 'identity "001011101101" :key #'(lambda (x) (eql x #\0))) + 5) + +(deftest count-if-string.6 + (count-if #'(lambda (x) (eql x #\0)) "001011101101" :key 'identity) + 5) + +(deftest count-if-string.8 + (count-if #'identity "001011101101" :key #'(lambda (x) (eql x #\1))) + 7) + +(deftest count-if-string.11 + (let ((c 0)) + (count-if #'evenp "001011101101" + :key #'(lambda (x) (+ (if (eql x #\0) 0 1) (incf c))))) + 7) + +(deftest count-if-string.12 + (let ((c 0)) + (count-if #'evenp "001011101101" + :from-end t + :key #'(lambda (x) (+ (if (eql x #\0) 0 1) (incf c))))) + 5) + +(deftest count-if-string.13 + (count-if #'(lambda (x) (eql x #\0)) "0111011011100" :start 2) + 4) + +(deftest count-if-string.14 + (count-if #'(lambda (x) (eql x #\0)) "0111011011100" :end 7) + 2) + +(deftest count-if-string.15 + (count-if #'(lambda (x) (eql x #\0)) "0111011011100" :end 7 :start 2) + 1) + +(deftest count-if-string.16 + (count-if #'(lambda (x) (eql x #\0)) + "0111011011100" :end 7 :start 2 :from-end t) + 1) + +;;; Error tests + +(deftest count-if-error.1 + (catch-type-error (count-if #'identity 1)) + type-error) + +(deftest count-if-error.2 + (catch-type-error (count-if #'identity 'a)) + type-error) + +(deftest count-if-error.3 + (catch-type-error (count-if #'identity #\a)) + type-error) diff --git a/ansi-tests/count.lsp b/ansi-tests/count.lsp new file mode 100644 index 0000000000000000000000000000000000000000..73e0054f14eb664589b02859f450bd9dbc61fd0a --- /dev/null +++ b/ansi-tests/count.lsp @@ -0,0 +1,422 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Mon Aug 19 07:31:55 2002 +;;;; Contains: Tests for COUNT + +(in-package :cl-test) + +(deftest count-list.1 + (count 'a '(a b c d e a e f)) + 2) + +(deftest count-list.2 + (count 'a '(a b c d e a e f) :test #'eq) + 2) + +(deftest count-list.3 + (count 'a '(a b c d e a e f) :test 'eq) + 2) + +(deftest count-list.4 + (count 1 '(1 2 2 3 2 1 2 2 5 4) :key #'1-) + 5) + +(deftest count-list.5 + (count 1 '(1 2 2 3 2 1 2 2 5 4) :key '1-) + 5) + +(deftest count-list.6 + (count 1 '(1 2 2 3 2 1 2 2 5 4) :key #'1- :test #'equal) + 5) + +(deftest count-list.7 + (count 1 '(2 1 1 2 3 1 4 1 7 6 1 8) :from-end t) + 5) + +(deftest count-list.8 + (let ((c 0)) + (count 1 '(1 2 3 1 4 1 7 6 1 8) + :key #'(lambda (x) + ;; (format t "~%~A ~A" x c) + (prog1 (- x c) (incf c))))) + 4) + +(deftest count-list.9 + (let ((c 0)) + (count 1 '(1 2 3 7 4 5 7 6 2 8) + :from-end t + :key #'(lambda (x) + ;; (format t "~%~A ~A" x c) + (prog1 (- x c) (incf c))))) + 3) + +(deftest count-list.10 + (count 1 '(1 1 1 1 1 2 1 1) :start 3) + 4) + +(deftest count-list.11 + (count 1 '(1 1 1 1 1 2 1 1) :end 6) + 5) + +(deftest count-list.12 + (count 1 '(1 1 1 1 1 2 1 1) :start 2 :end 7) + 4) + +(deftest count-list.13 + (count 1 '(1 1 1 1 1 2 1 1) :start 3 :end nil) + 4) + +(deftest count-list.14 + (count 1 '(1 1 1 1 1 2 1 1) :end nil) + 7) + +(deftest count-list.15 + (count 1 '(1 1 1 1 1 2 1 1) :test-not #'eq) + 1) + +(deftest count-list.16 + (count 1 '(1 1 1 3 1 2 1 1) :start 2 :end 7 + :test #'(lambda (x y) t)) + 5) + +;;; On vectors + +(deftest count-vector.1 + (count 'a #(a b c d e a e f)) + 2) + +(deftest count-vector.2 + (count 'a #(a b c d e a e f) :test #'eq) + 2) + +(deftest count-vector.3 + (count 'a #(a b c d e a e f) :test 'eq) + 2) + +(deftest count-vector.4 + (count 1 #(1 2 2 3 2 1 2 2 5 4) :key #'1-) + 5) + +(deftest count-vector.5 + (count 1 #(1 2 2 3 2 1 2 2 5 4) :key '1-) + 5) + +(deftest count-vector.6 + (count 1 #(1 2 2 3 2 1 2 2 5 4) :key #'1- :test #'equal) + 5) + +(deftest count-vector.7 + (count 1 #(2 1 1 2 3 1 4 1 7 6 1 8) :from-end t) + 5) + +(deftest count-vector.8 + (let ((c 0)) + (count 1 #(1 2 3 1 4 1 7 6 1 8) + :key #'(lambda (x) + ;; (format t "~%~A ~A" x c) + (prog1 (- x c) (incf c))))) + 4) + +(deftest count-vector.9 + (let ((c 0)) + (count 1 #(1 2 3 7 4 5 7 6 2 8) + :from-end t + :key #'(lambda (x) + ;; (format t "~%~A ~A" x c) + (prog1 (- x c) (incf c))))) + 3) + +(deftest count-vector.10 + (count 1 #(1 1 1 1 1 2 1 1) :start 3) + 4) + +(deftest count-vector.11 + (count 1 #(1 1 1 1 1 2 1 1) :end 6) + 5) + +(deftest count-vector.12 + (count 1 #(1 1 1 1 1 2 1 1) :start 2 :end 7) + 4) + +(deftest count-vector.13 + (count 1 #(1 1 1 1 1 2 1 1) :start 3 :end nil) + 4) + +(deftest count-vector.14 + (count 1 #(1 1 1 1 1 2 1 1) :end nil) + 7) + +(deftest count-vector.15 + (count 1 #(1 1 1 1 1 2 1 1) :test-not #'eq) + 1) + +(deftest count-vector16 + (count 1 #(1 1 1 3 1 2 1 1) :start 2 :end 7 + :test #'(lambda (x y) t)) + 5) + +;;; Non-simple vectors + +(deftest count-filled-vector.1 + (count 'a (make-array 8 :initial-contents '(a b c d e a e f) + :fill-pointer t)) + 2) + +(deftest count-filled-vector.2 + (count 'a (make-array 8 :initial-contents '(a b c d e a e f) + :fill-pointer t) + :test #'eq) + 2) + +(deftest count-filled-vector.3 + (count 'a (make-array 8 :initial-contents '(a b c d e a e f) + :fill-pointer t) + :test 'eq) + 2) + +(deftest count-filled-vector.4 + (count 1 (make-array 10 :initial-contents '(1 2 2 3 2 1 2 2 5 4) + :fill-pointer t) + :key #'1-) + 5) + +(deftest count-filled-vector.5 + (count 1 (make-array 10 :initial-contents '(1 2 2 3 2 1 2 2 5 4) + :fill-pointer t) + :key '1-) + 5) + +(deftest count-filled-vector.6 + (count 1 (make-array 10 :initial-contents '(1 2 2 3 2 1 2 2 5 4) + :fill-pointer t) + :key #'1- :test #'equal) + 5) + +(deftest count-filled-vector.7 + (count 1 (make-array 12 :initial-contents '(2 1 1 2 3 1 4 1 7 6 1 8) + :fill-pointer t) + :from-end t) + 5) + +(deftest count-filled-vector.8 + (let ((c 0)) + (count 1 (make-array 10 :initial-contents '(1 2 3 1 4 1 7 6 1 8) + :fill-pointer t) + :key #'(lambda (x) + ;; (format t "~%~A ~A" x c) + (prog1 (- x c) (incf c))))) + 4) + +(deftest count-filled-vector.9 + (let ((c 0)) + (count 1 (make-array 10 :initial-contents '(1 2 3 7 4 5 7 6 2 8) + :fill-pointer t) + :from-end t + :key #'(lambda (x) + ;; (format t "~%~A ~A" x c) + (prog1 (- x c) (incf c))))) + 3) + +(deftest count-filled-vector.10 + (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 2 1 1) + :fill-pointer t) + :start 3) + 4) + +(deftest count-filled-vector.11 + (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 2 1 1) + :fill-pointer t) + :end 6) + 5) + +(deftest count-filled-vector.12 + (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 2 1 1) + :fill-pointer t) + :start 2 :end 7) + 4) + +(deftest count-filled-vector.13 + (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 2 1 1) + :fill-pointer t) + :start 3 :end nil) + 4) + +(deftest count-filled-vector.14 + (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 2 1 1) + :fill-pointer t) + :end nil) + 7) + +(deftest count-filled-vector.15 + (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 2 1 1) + :fill-pointer t) + :test-not #'eq) + 1) + +(deftest count-filled-vector.16 + (count 1 (make-array 8 :initial-contents '(1 1 1 3 1 2 1 1) + :fill-pointer t) + :start 2 :end 7 + :test #'(lambda (x y) t)) + 5) + +;;; Tests on bit vectors + +(deftest count-bit-vector.1 + (count 1 #*00101100011011000) + 7) + +(deftest count-bit-vector.2 + (count 1 #*00101100011011000 :test #'eq) + 7) + +(deftest count-bit-vector.3 + (count 1 #*00101100011011000 :test 'eq) + 7) + +(deftest count-bit-vector.4 + (count 1 #*00101100011011000 :key #'1+) + 10) + +(deftest count-bit-vector.5 + (count 0 #*00101100011011000 :key '1-) + 7) + +(deftest count-bit-vector.6 + (count 0 #*00101100011011000 :key #'1- :test #'equal) + 7) + +(deftest count-bit-vector.7 + (count 1 #*00101100011011000 :from-end t) + 7) + +(deftest count-bit-vector.8 + (let ((c 1)) + (count 0 #*0000110101001 + :key #'(lambda (x) (setf c (- c)) (+ c x)))) + 2) + +(deftest count-bit-vector.9 + (let ((c 1)) + (count 0 #*0000011010101 + :from-end t + :key #'(lambda (x) (setf c (- c)) (+ c x)))) + 4) + +(deftest count-bit-vector.10 + (count 1 #*11000110110 :start 3) + 4) + +(deftest count-bit-vector.11 + (count 1 '#*110111110111 :end 6) + 5) + +(deftest count-bit-vector.12 + (count 1 #*11111011 :start 2 :end 7) + 4) + +(deftest count-bit-vector.13 + (count 1 #*11111011 :start 3 :end nil) + 4) + +(deftest count-bit-vector.14 + (count 1 #*11111011 :end nil) + 7) + +(deftest count-bit-vector.15 + (count 1 #*11111011 :test-not #'eq) + 1) + +(deftest count-bit-vector.16 + (count 1 #*11101101 :start 2 :end 7 + :test #'(lambda (x y) t)) + 5) + +;;; Tests on strings + +(deftest count-string.1 + (count #\1 "00101100011011000") + 7) + +(deftest count-string.2 + (count #\1 "00101100011011000" :test #'eq) + 7) + +(deftest count-string.3 + (count #\1 "00101100011011000" :test 'eq) + 7) + +(deftest count-string.4 + (count #\1 "00101100011011000" :key #'(lambda (x) (if (eq x #\0) #\1 #\2))) + 10) + +(deftest count-string.5 + (count #\1 "00101100011011000" :key 'identity) + 7) + +(deftest count-string.6 + (count #\1 "00101100011011000" :key #'identity :test #'equal) + 7) + +(deftest count-string.7 + (count #\1 "00101100011011000" :from-end t) + 7) + +(deftest count-string.8 + (let ((c nil)) + (count #\0 "0000110101001" + :key #'(lambda (x) (setf c (not c)) + (and c x)))) + 5) + +(deftest count-string.9 + (let ((c nil)) + (count #\0 "0000011010101" + :from-end t + :key #'(lambda (x) (setf c (not c)) + (and c x)))) + 3) + +(deftest count-string.10 + (count #\1 "11000110110" :start 3) + 4) + +(deftest count-string.11 + (count #\1 '"110111110111" :end 6) + 5) + +(deftest count-string.12 + (count #\1 "11111011" :start 2 :end 7) + 4) + +(deftest count-string.13 + (count #\1 "11111011" :start 3 :end nil) + 4) + +(deftest count-string.14 + (count #\1 "11111011" :end nil) + 7) + +(deftest count-string.15 + (count #\1 "11111011" :test-not #'eq) + 1) + +(deftest count-string.16 + (count #\1 "11101101" :start 2 :end 7 + :test #'(lambda (x y) t)) + 5) + +;;; Error tests + +(deftest count-error.1 + (catch-type-error (count 'a 1)) + type-error) + +(deftest count-error.2 + (catch-type-error (count 'a 'a)) + type-error) + +(deftest count-error.3 + (catch-type-error (count 'a #\a)) + type-error) + diff --git a/ansi-tests/fill-strings.lsp b/ansi-tests/fill-strings.lsp new file mode 100644 index 0000000000000000000000000000000000000000..cb64cbe2b3caecd5370cd9c5ae2c4262d556aed5 --- /dev/null +++ b/ansi-tests/fill-strings.lsp @@ -0,0 +1,31 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Aug 17 08:04:27 2002 +;;;; Contains: Test cases for FILL on strings + +(in-package :cl-test) + +(defun array-string-fill-test-fn (a &rest fill-args) + (setq a (copy-seq a)) + (let ((b (apply #'fill a fill-args))) + (values (eq a b) b))) + +(deftest array-string-fill-1 + (array-string-fill-test-fn "abcde" #\Z) + t "ZZZZZ") + +(deftest array-string-fill-2 + (array-string-fill-test-fn "abcde" #\Z :start 2) + t "abZZZ") + +(deftest array-string-fill-3 + (array-string-fill-test-fn "abcde" #\Z :end 3) + t "ZZZde") + +(deftest array-string-fill-4 + (array-string-fill-test-fn "abcde" #\Z :start 1 :end 4) + t "aZZZe") + +(deftest array-string-fill-5 + (array-string-fill-test-fn "abcde" #\Z :start 2 :end 3) + t "abZde") diff --git a/ansi-tests/find-if-not.lsp b/ansi-tests/find-if-not.lsp new file mode 100644 index 0000000000000000000000000000000000000000..eba61ed666939703644c4a4bfbc031f1f668534d --- /dev/null +++ b/ansi-tests/find-if-not.lsp @@ -0,0 +1,515 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Wed Aug 28 20:53:24 2002 +;;;; Contains: Tests for FIND-IF-NOT + +(in-package :cl-test) + +(deftest find-if-not-list.1 + (find-if-not #'identity ()) + nil) + +(deftest find-if-not-list.2 + (find-if-not #'null '(a)) + a) + +(deftest find-if-not-list.2a + (find-if-not 'null '(a)) + a) + +(deftest find-if-not-list.3 + (find-if-not #'oddp '(1 2 4 8 3 1 6 7)) + 2) + +(deftest find-if-not-list.4 + (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :from-end t) + 6) + +(deftest find-if-not-list.5 + (loop for i from 0 to 7 collect + (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :start i)) + (2 2 4 8 6 6 6 nil)) + +(deftest find-if-not-list.6 + (loop for i from 0 to 7 collect + (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :start i :end nil)) + (2 2 4 8 6 6 6 nil)) + +(deftest find-if-not-list.7 + (loop for i from 0 to 7 collect + (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :start i :from-end t)) + (6 6 6 6 6 6 6 nil)) + +(deftest find-if-not-list.8 + (loop for i from 0 to 7 collect + (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :start i :end nil :from-end t)) + (6 6 6 6 6 6 6 nil)) + +(deftest find-if-not-list.9 + (loop for i from 0 to 8 collect + (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :end i)) + (nil nil 2 2 2 2 2 2 2)) + +(deftest find-if-not-list.10 + (loop for i from 0 to 8 collect + (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :end i :from-end t)) + (nil nil 2 4 8 8 8 6 6)) + +(deftest find-if-not-list.11 + (loop for j from 0 to 7 + collect + (loop for i from (1+ j) to 8 collect + (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :start j :end i))) + ((nil 2 2 2 2 2 2 2) + (2 2 2 2 2 2 2) + (4 4 4 4 4 4) + (8 8 8 8 8) + (nil nil 6 6) + (nil 6 6) + (6 6) + (nil))) + +(deftest find-if-not-list.12 + (loop for j from 0 to 7 + collect + (loop for i from (1+ j) to 8 collect + (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :start j :end i + :from-end t))) + ((nil 2 4 8 8 8 6 6) + (2 4 8 8 8 6 6) + (4 8 8 8 6 6) + (8 8 8 6 6) + (nil nil 6 6) + (nil 6 6) + (6 6) + (nil))) + +(deftest find-if-not-list.13 + (loop for i from 0 to 6 + collect + (find-if-not #'oddp '(1 6 11 32 45 71 100) :key #'1+ :start i)) + (1 11 11 45 45 71 nil)) + +(deftest find-if-not-list.14 + (loop for i from 0 to 6 + collect + (find-if-not #'oddp '(1 6 11 32 45 71 100) :key '1+ :start i :from-end t)) + (71 71 71 71 71 71 nil)) + +(deftest find-if-not-list.15 + (loop for i from 0 to 7 + collect + (find-if-not #'oddp '(1 6 11 32 45 71 100) :key #'1+ :end i)) + (nil 1 1 1 1 1 1 1)) + +(deftest find-if-not-list.16 + (loop for i from 0 to 7 + collect + (find-if-not #'oddp '(1 6 11 32 45 71 100) :key '1+ :end i :from-end t)) + (nil 1 1 11 11 45 71 71)) + +(deftest find-if-not-list.17 + (loop for j from 0 to 7 + collect + (loop for i from (1+ j) to 8 collect + (find-if-not #'evenp '(1 2 4 8 3 1 6 7) :start j :end i :key #'1-))) + ((nil 2 2 2 2 2 2 2) + (2 2 2 2 2 2 2) + (4 4 4 4 4 4) + (8 8 8 8 8) + (nil nil 6 6) + (nil 6 6) + (6 6) + (nil))) + +(deftest find-if-not-list.18 + (loop for j from 0 to 7 + collect + (loop for i from (1+ j) to 8 collect + (find-if-not #'evenp '(1 2 4 8 3 1 6 7) :start j :end i + :from-end t :key #'1+))) + ((nil 2 4 8 8 8 6 6) + (2 4 8 8 8 6 6) + (4 8 8 8 6 6) + (8 8 8 6 6) + (nil nil 6 6) + (nil 6 6) + (6 6) + (nil))) + +;;; tests for vectors + +(deftest find-if-not-vector.1 + (find-if-not #'identity #()) + nil) + +(deftest find-if-not-vector.2 + (find-if-not #'not #(a)) + a) + +(deftest find-if-not-vector.2a + (find-if-not 'null #(a)) + a) + +(deftest find-if-not-vector.3 + (find-if-not #'oddp #(1 2 4 8 3 1 6 7)) + 2) + +(deftest find-if-not-vector.4 + (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :from-end t) + 6) + +(deftest find-if-not-vector.5 + (loop for i from 0 to 7 collect + (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :start i)) + (2 2 4 8 6 6 6 nil)) + +(deftest find-if-not-vector.6 + (loop for i from 0 to 7 collect + (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :start i :end nil)) + (2 2 4 8 6 6 6 nil)) + +(deftest find-if-not-vector.7 + (loop for i from 0 to 7 collect + (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :start i :from-end t)) + (6 6 6 6 6 6 6 nil)) + +(deftest find-if-not-vector.8 + (loop for i from 0 to 7 collect + (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :start i :end nil :from-end t)) + (6 6 6 6 6 6 6 nil)) + +(deftest find-if-not-vector.9 + (loop for i from 0 to 8 collect + (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :end i)) + (nil nil 2 2 2 2 2 2 2)) + +(deftest find-if-not-vector.10 + (loop for i from 0 to 8 collect + (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :end i :from-end t)) + (nil nil 2 4 8 8 8 6 6)) + +(deftest find-if-not-vector.11 + (loop for j from 0 to 7 + collect + (loop for i from (1+ j) to 8 collect + (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :start j :end i))) + ((nil 2 2 2 2 2 2 2) + (2 2 2 2 2 2 2) + (4 4 4 4 4 4) + (8 8 8 8 8) + (nil nil 6 6) + (nil 6 6) + (6 6) + (nil))) + +(deftest find-if-not-vector.12 + (loop for j from 0 to 7 + collect + (loop for i from (1+ j) to 8 collect + (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :start j :end i + :from-end t))) + ((nil 2 4 8 8 8 6 6) + (2 4 8 8 8 6 6) + (4 8 8 8 6 6) + (8 8 8 6 6) + (nil nil 6 6) + (nil 6 6) + (6 6) + (nil))) + +(deftest find-if-not-vector.13 + (loop for i from 0 to 6 + collect + (find-if-not #'oddp #(1 6 11 32 45 71 100) :key #'1+ :start i)) + (1 11 11 45 45 71 nil)) + +(deftest find-if-not-vector.14 + (loop for i from 0 to 6 + collect + (find-if-not #'oddp #(1 6 11 32 45 71 100) :key '1+ :start i :from-end t)) + (71 71 71 71 71 71 nil)) + +(deftest find-if-not-vector.15 + (loop for i from 0 to 7 + collect + (find-if-not #'oddp #(1 6 11 32 45 71 100) :key #'1+ :end i)) + (nil 1 1 1 1 1 1 1)) + +(deftest find-if-not-vector.16 + (loop for i from 0 to 7 + collect + (find-if-not #'oddp #(1 6 11 32 45 71 100) :key '1+ :end i :from-end t)) + (nil 1 1 11 11 45 71 71)) + +(deftest find-if-not-vector.17 + (loop for j from 0 to 7 + collect + (loop for i from (1+ j) to 8 collect + (find-if-not #'evenp #(1 2 4 8 3 1 6 7) :start j :end i :key #'1-))) + ((nil 2 2 2 2 2 2 2) + (2 2 2 2 2 2 2) + (4 4 4 4 4 4) + (8 8 8 8 8) + (nil nil 6 6) + (nil 6 6) + (6 6) + (nil))) + +(deftest find-if-not-vector.18 + (loop for j from 0 to 7 + collect + (loop for i from (1+ j) to 8 collect + (find-if-not #'evenp #(1 2 4 8 3 1 6 7) :start j :end i + :from-end t :key #'1+))) + ((nil 2 4 8 8 8 6 6) + (2 4 8 8 8 6 6) + (4 8 8 8 6 6) + (8 8 8 6 6) + (nil nil 6 6) + (nil 6 6) + (6 6) + (nil))) + +;;; Tests for bit vectors + +(deftest find-if-not-bit-vector.1 + (find-if-not #'identity #*) + nil) + +(deftest find-if-not-bit-vector.2 + (find-if-not #'null #*1) + 1) + +(deftest find-if-not-bit-vector.3 + (find-if-not #'not #*0) + 0) + +(deftest find-if-not-bit-vector.4 + (loop for i from 0 to 6 + collect (loop for j from i to 7 + collect (find-if-not #'oddp #*0110110 :start i :end j))) + ((nil 0 0 0 0 0 0 0) + (nil nil nil 0 0 0 0) + (nil nil 0 0 0 0) + (nil 0 0 0 0) + (nil nil nil 0) + (nil nil 0) + (nil 0))) + +(deftest find-if-not-bit-vector.5 + (loop for i from 0 to 6 + collect (loop for j from i to 7 + collect (find-if-not #'oddp #*0110110 :start i :end j + :from-end t))) + ((nil 0 0 0 0 0 0 0) + (nil nil nil 0 0 0 0) + (nil nil 0 0 0 0) + (nil 0 0 0 0) + (nil nil nil 0) + (nil nil 0) + (nil 0))) + +(deftest find-if-not-bit-vector.6 + (loop for i from 0 to 6 + collect (loop for j from i to 7 + collect (find-if-not #'evenp #*0110110 :start i :end j + :from-end t :key #'1+))) + ((nil 0 0 0 0 0 0 0) + (nil nil nil 0 0 0 0) + (nil nil 0 0 0 0) + (nil 0 0 0 0) + (nil nil nil 0) + (nil nil 0) + (nil 0))) + +(deftest find-if-not-bit-vector.7 + (loop for i from 0 to 6 + collect (loop for j from i to 7 + collect (find-if-not #'evenp #*0110110 :start i :end j + :key '1-))) + ((nil 0 0 0 0 0 0 0) + (nil nil nil 0 0 0 0) + (nil nil 0 0 0 0) + (nil 0 0 0 0) + (nil nil nil 0) + (nil nil 0) + (nil 0))) + +;;; Tests for strings + +(deftest find-if-not-string.1 + (find-if-not #'identity "") + nil) + +(deftest find-if-not-string.2 + (find-if-not #'null "a") + #\a) + +(deftest find-if-not-string.2a + (find-if-not 'null "a") + #\a) + +(deftest find-if-not-string.3 + (find-if-not #'odddigitp "12483167") + #\2) + +(deftest find-if-not-string.3a + (find-if-not #'oddp "12483167" :key #'(lambda (c) (read-from-string (string c)))) + #\2) + +(deftest find-if-not-string.4 + (find-if-not #'odddigitp "12483167" :from-end t) + #\6) + +(deftest find-if-not-string.5 + (loop for i from 0 to 7 collect + (find-if-not #'odddigitp "12483167" :start i)) + (#\2 #\2 #\4 #\8 #\6 #\6 #\6 nil)) + +(deftest find-if-not-string.6 + (loop for i from 0 to 7 collect + (find-if-not #'odddigitp "12483167" :start i :end nil)) + (#\2 #\2 #\4 #\8 #\6 #\6 #\6 nil)) + +(deftest find-if-not-string.7 + (loop for i from 0 to 7 collect + (find-if-not #'odddigitp "12483167" :start i :from-end t)) + (#\6 #\6 #\6 #\6 #\6 #\6 #\6 nil)) + +(deftest find-if-not-string.8 + (loop for i from 0 to 7 collect + (find-if-not #'odddigitp "12483167" :start i :end nil :from-end t)) + (#\6 #\6 #\6 #\6 #\6 #\6 #\6 nil)) + +(deftest find-if-not-string.9 + (loop for i from 0 to 8 collect + (find-if-not #'odddigitp "12483167" :end i)) + (nil nil #\2 #\2 #\2 #\2 #\2 #\2 #\2)) + +(deftest find-if-not-string.10 + (loop for i from 0 to 8 collect + (find-if-not #'odddigitp "12483167" :end i :from-end t)) + (nil nil #\2 #\4 #\8 #\8 #\8 #\6 #\6)) + +(deftest find-if-not-string.11 + (loop for j from 0 to 7 + collect + (loop for i from (1+ j) to 8 collect + (find-if-not #'odddigitp "12483167" :start j :end i))) + ((nil #\2 #\2 #\2 #\2 #\2 #\2 #\2) + (#\2 #\2 #\2 #\2 #\2 #\2 #\2) + (#\4 #\4 #\4 #\4 #\4 #\4) + (#\8 #\8 #\8 #\8 #\8) + (nil nil #\6 #\6) + (nil #\6 #\6) + (#\6 #\6) + (nil))) + +(deftest find-if-not-string.12 + (loop for j from 0 to 7 + collect + (loop for i from (1+ j) to 8 collect + (find-if-not #'odddigitp "12483167" :start j :end i + :from-end t))) + ((nil #\2 #\4 #\8 #\8 #\8 #\6 #\6) + (#\2 #\4 #\8 #\8 #\8 #\6 #\6) + (#\4 #\8 #\8 #\8 #\6 #\6) + (#\8 #\8 #\8 #\6 #\6) + (nil nil #\6 #\6) + (nil #\6 #\6) + (#\6 #\6) + (nil))) + +(deftest find-if-not-string.13 + (loop for i from 0 to 6 + collect + (find-if-not #'oddp "1473816" + :key (compose #'read-from-string #'string) + :start i)) + (#\4 #\4 #\8 #\8 #\8 #\6 #\6)) + +(deftest find-if-not-string.14 + (loop for i from 0 to 6 + collect + (find-if-not #'oddp "1473816" + :key (compose #'read-from-string #'string) + :start i :from-end t)) + (#\6 #\6 #\6 #\6 #\6 #\6 #\6)) + +(deftest find-if-not-string.15 + (loop for i from 0 to 7 + collect + (find-if-not #'oddp "1473816" + :key (compose #'read-from-string #'string) + :end i)) + (nil nil #\4 #\4 #\4 #\4 #\4 #\4)) + +(deftest find-if-not-string.16 + (loop for i from 0 to 7 + collect + (find-if-not #'oddp "1473816" + :key (compose #'read-from-string #'string) + :end i :from-end t)) + (nil nil #\4 #\4 #\4 #\8 #\8 #\6)) + +(deftest find-if-not-string.17 + (loop for j from 0 to 6 + collect + (loop for i from (1+ j) to 7 collect + (find-if-not #'oddp "1473816" + :key (compose #'read-from-string #'string) + :start j :end i))) + ((nil #\4 #\4 #\4 #\4 #\4 #\4) + (#\4 #\4 #\4 #\4 #\4 #\4) + (nil nil #\8 #\8 #\8) + (nil #\8 #\8 #\8) + (#\8 #\8 #\8) + (nil #\6) + (#\6))) + +(deftest find-if-not-string.18 + (loop for j from 0 to 6 + collect + (loop for i from (1+ j) to 7 collect + (find-if-not #'oddp "1473816" + :key (compose #'read-from-string #'string) + :start j :end i + :from-end t))) + ((nil #\4 #\4 #\4 #\8 #\8 #\6) + (#\4 #\4 #\4 #\8 #\8 #\6) + (nil nil #\8 #\8 #\6) + (nil #\8 #\8 #\6) + (#\8 #\8 #\6) + (nil #\6) + (#\6))) + +;;; Error tests + +(deftest find-if-not-error.1 + (handler-case (find-if-not #'null 'b) + (type-error () :type-error) + (error (c) c)) + :type-error) + +(deftest find-if-not-error.2 + (handler-case (find-if-not #'identity 10) + (type-error () :type-error) + (error (c) c)) + :type-error) + +(deftest find-if-not-error.3 + (handler-case (find-if-not '1+ 1.4) + (type-error () :type-error) + (error (c) c)) + :type-error) + +(deftest find-if-not-error.4 + (locally (declare (optimize (safety 3))) + (handler-case (find-if-not 'identity '(a b c . d)) + (type-error () :type-error))) + :type-error) + + + + diff --git a/ansi-tests/find-if.lsp b/ansi-tests/find-if.lsp new file mode 100644 index 0000000000000000000000000000000000000000..1fd54a17caeaabe9d1e8aac93970bec85bb1041d --- /dev/null +++ b/ansi-tests/find-if.lsp @@ -0,0 +1,513 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Wed Aug 28 18:37:52 2002 +;;;; Contains: Tests for FIND-IF + +(in-package :cl-test) + +(deftest find-if-list.1 + (find-if #'identity ()) + nil) + +(deftest find-if-list.2 + (find-if #'identity '(a)) + a) + +(deftest find-if-list.2a + (find-if 'identity '(a)) + a) + +(deftest find-if-list.3 + (find-if #'evenp '(1 2 4 8 3 1 6 7)) + 2) + +(deftest find-if-list.4 + (find-if #'evenp '(1 2 4 8 3 1 6 7) :from-end t) + 6) + +(deftest find-if-list.5 + (loop for i from 0 to 7 collect + (find-if #'evenp '(1 2 4 8 3 1 6 7) :start i)) + (2 2 4 8 6 6 6 nil)) + +(deftest find-if-list.6 + (loop for i from 0 to 7 collect + (find-if #'evenp '(1 2 4 8 3 1 6 7) :start i :end nil)) + (2 2 4 8 6 6 6 nil)) + +(deftest find-if-list.7 + (loop for i from 0 to 7 collect + (find-if #'evenp '(1 2 4 8 3 1 6 7) :start i :from-end t)) + (6 6 6 6 6 6 6 nil)) + +(deftest find-if-list.8 + (loop for i from 0 to 7 collect + (find-if #'evenp '(1 2 4 8 3 1 6 7) :start i :end nil :from-end t)) + (6 6 6 6 6 6 6 nil)) + +(deftest find-if-list.9 + (loop for i from 0 to 8 collect + (find-if #'evenp '(1 2 4 8 3 1 6 7) :end i)) + (nil nil 2 2 2 2 2 2 2)) + +(deftest find-if-list.10 + (loop for i from 0 to 8 collect + (find-if #'evenp '(1 2 4 8 3 1 6 7) :end i :from-end t)) + (nil nil 2 4 8 8 8 6 6)) + +(deftest find-if-list.11 + (loop for j from 0 to 7 + collect + (loop for i from (1+ j) to 8 collect + (find-if #'evenp '(1 2 4 8 3 1 6 7) :start j :end i))) + ((nil 2 2 2 2 2 2 2) + (2 2 2 2 2 2 2) + (4 4 4 4 4 4) + (8 8 8 8 8) + (nil nil 6 6) + (nil 6 6) + (6 6) + (nil))) + +(deftest find-if-list.12 + (loop for j from 0 to 7 + collect + (loop for i from (1+ j) to 8 collect + (find-if #'evenp '(1 2 4 8 3 1 6 7) :start j :end i + :from-end t))) + ((nil 2 4 8 8 8 6 6) + (2 4 8 8 8 6 6) + (4 8 8 8 6 6) + (8 8 8 6 6) + (nil nil 6 6) + (nil 6 6) + (6 6) + (nil))) + +(deftest find-if-list.13 + (loop for i from 0 to 6 + collect + (find-if #'evenp '(1 6 11 32 45 71 100) :key #'1+ :start i)) + (1 11 11 45 45 71 nil)) + +(deftest find-if-list.14 + (loop for i from 0 to 6 + collect + (find-if #'evenp '(1 6 11 32 45 71 100) :key '1+ :start i :from-end t)) + (71 71 71 71 71 71 nil)) + +(deftest find-if-list.15 + (loop for i from 0 to 7 + collect + (find-if #'evenp '(1 6 11 32 45 71 100) :key #'1+ :end i)) + (nil 1 1 1 1 1 1 1)) + +(deftest find-if-list.16 + (loop for i from 0 to 7 + collect + (find-if #'evenp '(1 6 11 32 45 71 100) :key '1+ :end i :from-end t)) + (nil 1 1 11 11 45 71 71)) + +(deftest find-if-list.17 + (loop for j from 0 to 7 + collect + (loop for i from (1+ j) to 8 collect + (find-if #'oddp '(1 2 4 8 3 1 6 7) :start j :end i :key #'1-))) + ((nil 2 2 2 2 2 2 2) + (2 2 2 2 2 2 2) + (4 4 4 4 4 4) + (8 8 8 8 8) + (nil nil 6 6) + (nil 6 6) + (6 6) + (nil))) + +(deftest find-if-list.18 + (loop for j from 0 to 7 + collect + (loop for i from (1+ j) to 8 collect + (find-if #'oddp '(1 2 4 8 3 1 6 7) :start j :end i + :from-end t :key #'1+))) + ((nil 2 4 8 8 8 6 6) + (2 4 8 8 8 6 6) + (4 8 8 8 6 6) + (8 8 8 6 6) + (nil nil 6 6) + (nil 6 6) + (6 6) + (nil))) + +;;; tests for vectors + +(deftest find-if-vector.1 + (find-if #'identity #()) + nil) + +(deftest find-if-vector.2 + (find-if #'identity #(a)) + a) + +(deftest find-if-vector.2a + (find-if 'identity #(a)) + a) + +(deftest find-if-vector.3 + (find-if #'evenp #(1 2 4 8 3 1 6 7)) + 2) + +(deftest find-if-vector.4 + (find-if #'evenp #(1 2 4 8 3 1 6 7) :from-end t) + 6) + +(deftest find-if-vector.5 + (loop for i from 0 to 7 collect + (find-if #'evenp #(1 2 4 8 3 1 6 7) :start i)) + (2 2 4 8 6 6 6 nil)) + +(deftest find-if-vector.6 + (loop for i from 0 to 7 collect + (find-if #'evenp #(1 2 4 8 3 1 6 7) :start i :end nil)) + (2 2 4 8 6 6 6 nil)) + +(deftest find-if-vector.7 + (loop for i from 0 to 7 collect + (find-if #'evenp #(1 2 4 8 3 1 6 7) :start i :from-end t)) + (6 6 6 6 6 6 6 nil)) + +(deftest find-if-vector.8 + (loop for i from 0 to 7 collect + (find-if #'evenp #(1 2 4 8 3 1 6 7) :start i :end nil :from-end t)) + (6 6 6 6 6 6 6 nil)) + +(deftest find-if-vector.9 + (loop for i from 0 to 8 collect + (find-if #'evenp #(1 2 4 8 3 1 6 7) :end i)) + (nil nil 2 2 2 2 2 2 2)) + +(deftest find-if-vector.10 + (loop for i from 0 to 8 collect + (find-if #'evenp #(1 2 4 8 3 1 6 7) :end i :from-end t)) + (nil nil 2 4 8 8 8 6 6)) + +(deftest find-if-vector.11 + (loop for j from 0 to 7 + collect + (loop for i from (1+ j) to 8 collect + (find-if #'evenp #(1 2 4 8 3 1 6 7) :start j :end i))) + ((nil 2 2 2 2 2 2 2) + (2 2 2 2 2 2 2) + (4 4 4 4 4 4) + (8 8 8 8 8) + (nil nil 6 6) + (nil 6 6) + (6 6) + (nil))) + +(deftest find-if-vector.12 + (loop for j from 0 to 7 + collect + (loop for i from (1+ j) to 8 collect + (find-if #'evenp #(1 2 4 8 3 1 6 7) :start j :end i + :from-end t))) + ((nil 2 4 8 8 8 6 6) + (2 4 8 8 8 6 6) + (4 8 8 8 6 6) + (8 8 8 6 6) + (nil nil 6 6) + (nil 6 6) + (6 6) + (nil))) + +(deftest find-if-vector.13 + (loop for i from 0 to 6 + collect + (find-if #'evenp #(1 6 11 32 45 71 100) :key #'1+ :start i)) + (1 11 11 45 45 71 nil)) + +(deftest find-if-vector.14 + (loop for i from 0 to 6 + collect + (find-if #'evenp #(1 6 11 32 45 71 100) :key '1+ :start i :from-end t)) + (71 71 71 71 71 71 nil)) + +(deftest find-if-vector.15 + (loop for i from 0 to 7 + collect + (find-if #'evenp #(1 6 11 32 45 71 100) :key #'1+ :end i)) + (nil 1 1 1 1 1 1 1)) + +(deftest find-if-vector.16 + (loop for i from 0 to 7 + collect + (find-if #'evenp #(1 6 11 32 45 71 100) :key '1+ :end i :from-end t)) + (nil 1 1 11 11 45 71 71)) + +(deftest find-if-vector.17 + (loop for j from 0 to 7 + collect + (loop for i from (1+ j) to 8 collect + (find-if #'oddp #(1 2 4 8 3 1 6 7) :start j :end i :key #'1-))) + ((nil 2 2 2 2 2 2 2) + (2 2 2 2 2 2 2) + (4 4 4 4 4 4) + (8 8 8 8 8) + (nil nil 6 6) + (nil 6 6) + (6 6) + (nil))) + +(deftest find-if-vector.18 + (loop for j from 0 to 7 + collect + (loop for i from (1+ j) to 8 collect + (find-if #'oddp #(1 2 4 8 3 1 6 7) :start j :end i + :from-end t :key #'1+))) + ((nil 2 4 8 8 8 6 6) + (2 4 8 8 8 6 6) + (4 8 8 8 6 6) + (8 8 8 6 6) + (nil nil 6 6) + (nil 6 6) + (6 6) + (nil))) + +;;; Tests for bit vectors + +(deftest find-if-bit-vector.1 + (find-if #'identity #*) + nil) + +(deftest find-if-bit-vector.2 + (find-if #'identity #*1) + 1) + +(deftest find-if-bit-vector.3 + (find-if #'identity #*0) + 0) + +(deftest find-if-bit-vector.4 + (loop for i from 0 to 6 + collect (loop for j from i to 7 + collect (find-if #'evenp #*0110110 :start i :end j))) + ((nil 0 0 0 0 0 0 0) + (nil nil nil 0 0 0 0) + (nil nil 0 0 0 0) + (nil 0 0 0 0) + (nil nil nil 0) + (nil nil 0) + (nil 0))) + +(deftest find-if-bit-vector.5 + (loop for i from 0 to 6 + collect (loop for j from i to 7 + collect (find-if #'evenp #*0110110 :start i :end j + :from-end t))) + ((nil 0 0 0 0 0 0 0) + (nil nil nil 0 0 0 0) + (nil nil 0 0 0 0) + (nil 0 0 0 0) + (nil nil nil 0) + (nil nil 0) + (nil 0))) + +(deftest find-if-bit-vector.6 + (loop for i from 0 to 6 + collect (loop for j from i to 7 + collect (find-if #'oddp #*0110110 :start i :end j + :from-end t :key #'1+))) + ((nil 0 0 0 0 0 0 0) + (nil nil nil 0 0 0 0) + (nil nil 0 0 0 0) + (nil 0 0 0 0) + (nil nil nil 0) + (nil nil 0) + (nil 0))) + +(deftest find-if-bit-vector.7 + (loop for i from 0 to 6 + collect (loop for j from i to 7 + collect (find-if #'oddp #*0110110 :start i :end j + :key '1-))) + ((nil 0 0 0 0 0 0 0) + (nil nil nil 0 0 0 0) + (nil nil 0 0 0 0) + (nil 0 0 0 0) + (nil nil nil 0) + (nil nil 0) + (nil 0))) + +;;; Tests for strings + +(deftest find-if-string.1 + (find-if #'identity "") + nil) + +(deftest find-if-string.2 + (find-if #'identity "a") + #\a) + +(deftest find-if-string.2a + (find-if 'identity "a") + #\a) + +(deftest find-if-string.3 + (find-if #'evendigitp "12483167") + #\2) + +(deftest find-if-string.3a + (find-if #'evenp "12483167" :key #'(lambda (c) (read-from-string (string c)))) + #\2) + +(deftest find-if-string.4 + (find-if #'evendigitp "12483167" :from-end t) + #\6) + +(deftest find-if-string.5 + (loop for i from 0 to 7 collect + (find-if #'evendigitp "12483167" :start i)) + (#\2 #\2 #\4 #\8 #\6 #\6 #\6 nil)) + +(deftest find-if-string.6 + (loop for i from 0 to 7 collect + (find-if #'evendigitp "12483167" :start i :end nil)) + (#\2 #\2 #\4 #\8 #\6 #\6 #\6 nil)) + +(deftest find-if-string.7 + (loop for i from 0 to 7 collect + (find-if #'evendigitp "12483167" :start i :from-end t)) + (#\6 #\6 #\6 #\6 #\6 #\6 #\6 nil)) + +(deftest find-if-string.8 + (loop for i from 0 to 7 collect + (find-if #'evendigitp "12483167" :start i :end nil :from-end t)) + (#\6 #\6 #\6 #\6 #\6 #\6 #\6 nil)) + +(deftest find-if-string.9 + (loop for i from 0 to 8 collect + (find-if #'evendigitp "12483167" :end i)) + (nil nil #\2 #\2 #\2 #\2 #\2 #\2 #\2)) + +(deftest find-if-string.10 + (loop for i from 0 to 8 collect + (find-if #'evendigitp "12483167" :end i :from-end t)) + (nil nil #\2 #\4 #\8 #\8 #\8 #\6 #\6)) + +(deftest find-if-string.11 + (loop for j from 0 to 7 + collect + (loop for i from (1+ j) to 8 collect + (find-if #'evendigitp "12483167" :start j :end i))) + ((nil #\2 #\2 #\2 #\2 #\2 #\2 #\2) + (#\2 #\2 #\2 #\2 #\2 #\2 #\2) + (#\4 #\4 #\4 #\4 #\4 #\4) + (#\8 #\8 #\8 #\8 #\8) + (nil nil #\6 #\6) + (nil #\6 #\6) + (#\6 #\6) + (nil))) + +(deftest find-if-string.12 + (loop for j from 0 to 7 + collect + (loop for i from (1+ j) to 8 collect + (find-if #'evendigitp "12483167" :start j :end i + :from-end t))) + ((nil #\2 #\4 #\8 #\8 #\8 #\6 #\6) + (#\2 #\4 #\8 #\8 #\8 #\6 #\6) + (#\4 #\8 #\8 #\8 #\6 #\6) + (#\8 #\8 #\8 #\6 #\6) + (nil nil #\6 #\6) + (nil #\6 #\6) + (#\6 #\6) + (nil))) + +(deftest find-if-string.13 + (loop for i from 0 to 6 + collect + (find-if #'evenp "1473816" + :key (compose #'read-from-string #'string) + :start i)) + (#\4 #\4 #\8 #\8 #\8 #\6 #\6)) + +(deftest find-if-string.14 + (loop for i from 0 to 6 + collect + (find-if #'evenp "1473816" + :key (compose #'read-from-string #'string) + :start i :from-end t)) + (#\6 #\6 #\6 #\6 #\6 #\6 #\6)) + +(deftest find-if-string.15 + (loop for i from 0 to 7 + collect + (find-if #'evenp "1473816" + :key (compose #'read-from-string #'string) + :end i)) + (nil nil #\4 #\4 #\4 #\4 #\4 #\4)) + +(deftest find-if-string.16 + (loop for i from 0 to 7 + collect + (find-if #'evenp "1473816" + :key (compose #'read-from-string #'string) + :end i :from-end t)) + (nil nil #\4 #\4 #\4 #\8 #\8 #\6)) + +(deftest find-if-string.17 + (loop for j from 0 to 6 + collect + (loop for i from (1+ j) to 7 collect + (find-if #'evenp "1473816" + :key (compose #'read-from-string #'string) + :start j :end i))) + ((nil #\4 #\4 #\4 #\4 #\4 #\4) + (#\4 #\4 #\4 #\4 #\4 #\4) + (nil nil #\8 #\8 #\8) + (nil #\8 #\8 #\8) + (#\8 #\8 #\8) + (nil #\6) + (#\6))) + +(deftest find-if-string.18 + (loop for j from 0 to 6 + collect + (loop for i from (1+ j) to 7 collect + (find-if #'evenp "1473816" + :key (compose #'read-from-string #'string) + :start j :end i + :from-end t))) + ((nil #\4 #\4 #\4 #\8 #\8 #\6) + (#\4 #\4 #\4 #\8 #\8 #\6) + (nil nil #\8 #\8 #\6) + (nil #\8 #\8 #\6) + (#\8 #\8 #\6) + (nil #\6) + (#\6))) + +;;; Error tests + +(deftest find-if-error.1 + (handler-case (find-if #'null 'b) + (type-error () :type-error) + (error (c) c)) + :type-error) + +(deftest find-if-error.2 + (handler-case (find-if #'identity 10) + (type-error () :type-error) + (error (c) c)) + :type-error) + +(deftest find-if-error.3 + (handler-case (find-if '1+ 1.4) + (type-error () :type-error) + (error (c) c)) + :type-error) + +(deftest find-if-error.4 + (locally (declare (optimize (safety 3))) + (handler-case (find-if 'null '(a b c . d)) + (type-error () :type-error))) + :type-error) + + diff --git a/ansi-tests/find.lsp b/ansi-tests/find.lsp new file mode 100644 index 0000000000000000000000000000000000000000..7903e9f905439882fb54f83380049726151ef437 --- /dev/null +++ b/ansi-tests/find.lsp @@ -0,0 +1,726 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Fri Aug 23 07:49:49 2002 +;;;; Contains: Tests for FIND + +(in-package :cl-test) + +(deftest find-list.1 + (find 'c '(a b c d e c a)) + c) + +(deftest find-list.2 + (find 'c '(a b c d e c a) :from-end t) + c) + +(deftest find-list.3 + (loop for i from 0 to 7 collect + (find 'c '(a b c d e c a) :start i)) + (c c c c c c nil nil)) + +(deftest find-list.4 + (loop for i from 0 to 7 collect + (find 'c '(a b c d e c a) :start i :end nil)) + (c c c c c c nil nil)) + +(deftest find-list.5 + (loop for i from 7 downto 0 collect + (find 'c '(a b c d e c a) :end i)) + (c c c c c nil nil nil)) + +(deftest find-list.6 + (loop for i from 0 to 7 collect + (find 'c '(a b c d e c a) :start i :from-end t)) + (c c c c c c nil nil)) + +(deftest find-list.7 + (loop for i from 0 to 7 collect + (find 'c '(a b c d e c a) :start i :end nil :from-end t)) + (c c c c c c nil nil)) + +(deftest find-list.8 + (loop for i from 7 downto 0 collect + (find 'c '(a b c d e c a) :end i :from-end t)) + (c c c c c nil nil nil)) + +(deftest find-list.9 + (loop for i from 0 to 6 collect + (loop for j from (1+ i) to 7 + collect + (find 'c '(a b c d e c a) :start i :end j))) + ((nil nil c c c c c) + (nil c c c c c) + (c c c c c) + (nil nil c c) + (nil c c) + (c c) + (nil))) + +(deftest find-list.10 + (loop for i from 0 to 6 collect + (loop for j from (1+ i) to 7 + collect + (find 'c '(a b c d e c a) :start i :end j :from-end t))) + ((nil nil c c c c c) + (nil c c c c c) + (c c c c c) + (nil nil c c) + (nil c c) + (c c) + (nil))) + +(deftest find-list.11 + (find 5 '(1 2 3 4 5 6 4 8) :key #'1+) + 4) + +(deftest find-list.12 + (find 5 '(1 2 3 4 5 6 4 8) :key '1+) + 4) + +(deftest find-list.13 + (find 5 '(1 2 3 4 5 6 4 8) :key #'1+ :from-end t) + 4) + +(deftest find-list.14 + (find 'a '(a a b a c e d a f a) :test (complement #'eq)) + b) + +(deftest find-list.15 + (find 'a '(a a b a c e d a f a) :test (complement #'eq) + :from-end t) + f) + +(deftest find-list.16 + (find 'a '(a a b a c e d a f a) :test-not #'eq) + b) + +(deftest find-list.17 + (find 'a '(a a b a c e d a f a) :test-not 'eq + :from-end t) + f) + +(deftest find-list.18 + (find 'a '(a a b a c e d a f a) :test-not 'eq) + b) + +(deftest find-list.19 + (find 'a '(a a b a c e d a f a) :test-not #'eq + :from-end t) + f) + +(deftest find-list.20 + (find 'a '(a a b a c e d a f a) :test-not #'eq) + b) + +(deftest find-list.21 + (find 'a '(a a b a c e d a f a) :test #'eq + :start 2) + a) + +(deftest find-list.22 + (find 'a '(a a b a c e d a f a) :test #'eq + :start 2 :end nil) + a) + +(deftest find-list.23 + (find 'a '(a a b a c e d a f a) :test-not #'eq + :start 0 :end 5) + b) + +(deftest find-list.24 + (find 'a '(a a b a c e d a f a) :test-not #'eq + :start 0 :end 5 :from-end t) + c) + +(deftest find-list.25 + (find "ab" '("a" #(#\b #\a) #(#\a #\b #\c) #(#\a #\b) #(#\d #\e) f) :test #'equalp) + #(#\a #\b)) + +(deftest find-list.26 + (find 'a '((c) (b a) (a b c) (a b) (d e) f) :key #'car) + (a b c)) + +(deftest find-list.27 + (find 'a '((c) (b a) (a b c) (z) (a b) (d e) f) :key #'car + :start 3) + (a b)) + +(deftest find-list.28 + (find 'a '((c) (b a) (a b c) (z) (a b) (d e) (f)) :key #'car + :start 2 :from-end t) + (a b)) + +;;; Tests on vectors + +(deftest find-vector.1 + (find 'c #(a b c d e c a)) + c) + +(deftest find-vector.1a + (find 'z #(a b c d e c a)) + nil) + +(deftest find-vector.2 + (find 'c #(a b c d e c a) :from-end t) + c) + +(deftest find-vector.2a + (find 'z #(a b c d e c a) :from-end t) + nil) + +(deftest find-vector.3 + (loop for i from 0 to 7 collect + (find 'c #(a b c d e c a) :start i)) + (c c c c c c nil nil)) + +(deftest find-vector.4 + (loop for i from 0 to 7 collect + (find 'c #(a b c d e c a) :start i :end nil)) + (c c c c c c nil nil)) + +(deftest find-vector.5 + (loop for i from 7 downto 0 collect + (find 'c #(a b c d e c a) :end i)) + (c c c c c nil nil nil)) + +(deftest find-vector.6 + (loop for i from 0 to 7 collect + (find 'c #(a b c d e c a) :start i :from-end t)) + (c c c c c c nil nil)) + +(deftest find-vector.7 + (loop for i from 0 to 7 collect + (find 'c #(a b c d e c a) :start i :end nil :from-end t)) + (c c c c c c nil nil)) + +(deftest find-vector.8 + (loop for i from 7 downto 0 collect + (find 'c #(a b c d e c a) :end i :from-end t)) + (c c c c c nil nil nil)) + +(deftest find-vector.9 + (loop for i from 0 to 6 collect + (loop for j from (1+ i) to 7 + collect + (find 'c #(a b c d e c a) :start i :end j))) + ((nil nil c c c c c) + (nil c c c c c) + (c c c c c) + (nil nil c c) + (nil c c) + (c c) + (nil))) + +(deftest find-vector.10 + (loop for i from 0 to 6 collect + (loop for j from (1+ i) to 7 + collect + (find 'c #(a b c d e c a) :start i :end j :from-end t))) + ((nil nil c c c c c) + (nil c c c c c) + (c c c c c) + (nil nil c c) + (nil c c) + (c c) + (nil))) + +(deftest find-vector.11 + (find 5 #(1 2 3 4 5 6 4 8) :key #'1+) + 4) + +(deftest find-vector.12 + (find 5 #(1 2 3 4 5 6 4 8) :key '1+) + 4) + +(deftest find-vector.13 + (find 5 #(1 2 3 4 5 6 4 8) :key #'1+ :from-end t) + 4) + +(deftest find-vector.14 + (find 'a #(a a b a c e d a f a) :test (complement #'eq)) + b) + +(deftest find-vector.15 + (find 'a #(a a b a c e d a f a) :test (complement #'eq) + :from-end t) + f) + +(deftest find-vector.16 + (find 'a #(a a b a c e d a f a) :test-not #'eq) + b) + +(deftest find-vector.17 + (find 'a #(a a b a c e d a f a) :test-not 'eq + :from-end t) + f) + +(deftest find-vector.18 + (find 'a #(a a b a c e d a f a) :test-not 'eq) + b) + +(deftest find-vector.19 + (find 'a #(a a b a c e d a f a) :test-not #'eq + :from-end t) + f) + +(deftest find-vector.20 + (find 'a #(a a b a c e d a f a) :test-not #'eq) + b) + +(deftest find-vector.21 + (find 'a #(a a b a c e d a f a) :test #'eq + :start 2) + a) + +(deftest find-vector.22 + (find 'a #(a a b a c e d a f a) :test #'eq + :start 2 :end nil) + a) + +(deftest find-vector.23 + (find 'a #(a a b a c e d a f a) :test-not #'eq + :start 0 :end 5) + b) + +(deftest find-vector.24 + (find 'a #(a a b a c e d a f a) :test-not #'eq + :start 0 :end 5 :from-end t) + c) + +(deftest find-vector.25 + (find "ab" #("a" #(#\b #\a) #(#\a #\b #\c) #(#\a #\b) #(#\d #\e) f) :test #'equalp) + #(#\a #\b)) + +(deftest find-vector.26 + (find 'a #((c) (b a) (a b c) (a b) (d e) f) :key #'car) + (a b c)) + +(deftest find-vector.27 + (find 'a #((c) (b a) (a b c) (z) (a b) (d e) f) :key #'car + :start 3) + (a b)) + +(deftest find-vector.28 + (find 'a #((c) (b a) (a b c) (z) (a b) (d e) (f)) :key #'car + :start 2 :from-end t) + (a b)) + +;;; tests on bit vectors + +(deftest find-bit-vector.1 + (find 1 #*001001010100) + 1) + +(deftest find-bit-vector.1a + (find 0 #*001001010100) + 0) + +(deftest find-bit-vector.1b + (find 2 #*001001010100) + nil) + +(deftest find-bit-vector.1c + (find 'a #*001001010100) + nil) + +(deftest find-bit-vector.1d + (find 1 #*000000) + nil) + +(deftest find-bit-vector.2 + (find 1 #*001001010100 :from-end t) + 1) + +(deftest find-bit-vector.2a + (find 1 #*00000 :from-end t) + nil) + +(deftest find-bit-vector.2b + (find 0 #*00000 :from-end t) + 0) + +(deftest find-bit-vector.2c + (find 0 #*11111 :from-end t) + nil) + +(deftest find-bit-vector.2d + (find 2 #*11111 :from-end t) + nil) + +(deftest find-bit-vector.2e + (find 'a #*11111 :from-end t) + nil) + +(deftest find-bit-vector.3 + (loop for i from 0 to 7 collect + (find 1 #*0010010 :start i)) + (1 1 1 1 1 1 nil nil)) + +(deftest find-bit-vector.4 + (loop for i from 0 to 7 collect + (find 1 #*0010010 :start i :end nil)) + (1 1 1 1 1 1 nil nil)) + +(deftest find-bit-vector.5 + (loop for i from 7 downto 0 collect + (find 1 #*0010010 :end i)) + (1 1 1 1 1 nil nil nil)) + +(deftest find-bit-vector.6 + (loop for i from 0 to 7 collect + (find 1 #*0010010 :start i :from-end t)) + (1 1 1 1 1 1 nil nil)) + +(deftest find-bit-vector.7 + (loop for i from 0 to 7 collect + (find 0 #*1101101 :start i :end nil :from-end t)) + (0 0 0 0 0 0 nil nil)) + +(deftest find-bit-vector.8 + (loop for i from 7 downto 0 collect + (find 0 #*1101101 :end i :from-end t)) + (0 0 0 0 0 nil nil nil)) + +(deftest find-bit-vector.9 + (loop for i from 0 to 6 collect + (loop for j from (1+ i) to 7 + collect + (find 1 #*0010010 :start i :end j))) + ((nil nil 1 1 1 1 1) + (nil 1 1 1 1 1) + (1 1 1 1 1) + (nil nil 1 1) + (nil 1 1) + (1 1) + (nil))) + +(deftest find-bit-vector.10 + (loop for i from 0 to 6 collect + (loop for j from (1+ i) to 7 + collect + (find 1 #*0010010 :start i :end j :from-end t))) + ((nil nil 1 1 1 1 1) + (nil 1 1 1 1 1) + (1 1 1 1 1) + (nil nil 1 1) + (nil 1 1) + (1 1) + (nil))) + +(deftest find-bit-vector.11 + (find 2 #*00010001010 :key #'1+) + 1) + +(deftest find-bit-vector.12 + (find 2 #*00010001010 :key '1+) + 1) + +(deftest find-bit-vector.13 + (find 2 #*0010001000 :key #'1+ :from-end t) + 1) + +(deftest find-bit-vector.14 + (find 0 #*0010111010 :test (complement #'eq)) + 1) + +(deftest find-bit-vector.15 + (find 0 #*0010111010 :test (complement #'eq) + :from-end t) + 1) + +(deftest find-bit-vector.16 + (find 0 #*0010111010 :test-not #'eq) + 1) + +(deftest find-bit-vector.16a + (find 1 #*111111111111 :test-not #'eq) + nil) + +(deftest find-bit-vector.16b + (find 0 #*0000000 :test-not #'eq) + nil) + +(deftest find-bit-vector.17 + (find 0 #*001011101 :test-not 'eq + :from-end t) + 1) + +(deftest find-bit-vector.17a + (find 0 #*0000000 :test-not 'eq + :from-end t) + nil) + +(deftest find-bit-vector.17b + (find 1 #*111111111111 :test-not 'eq + :from-end t) + nil) + +(deftest find-bit-vector.18 + (find 0 #*00101110 :test-not 'eq) + 1) + +(deftest find-bit-vector.18a + (find 0 #*00000000 :test-not 'eq) + nil) + +(deftest find-bit-vector.19 + (find 0 #*00101110 :test-not #'eq + :from-end t) + 1) + +(deftest find-bit-vector.19a + (find 0 #*00000000 :test-not #'eq + :from-end t) + nil) + +(deftest find-bit-vector.20 + (find 0 #*00101110 :test-not #'eq) + 1) + +(deftest find-bit-vector.21 + (find 0 #*00101110 :test #'eq + :start 2) + 0) + +(deftest find-bit-vector.21a + (find 0 #*00111111 :test #'eq + :start 2) + nil) + +(deftest find-bit-vector.21b + (find 1 #*00111111 :test #'eq + :start 2) + 1) + +(deftest find-bit-vector.22 + (find 0 #*00101110 :test #'eq + :start 2 :end nil) + 0) + +(deftest find-bit-vector.22a + (find 0 #*001111111 :test #'eq + :start 2 :end nil) + nil) + +(deftest find-bit-vector.22b + (find 1 #*001111111 :test #'eq + :start 2 :end nil) + 1) + +(deftest find-bit-vector.23 + (find 0 #*00101110 :test-not #'eq + :start 0 :end 5) + 1) + +(deftest find-bit-vector.23a + (find 0 #*00000111 :test-not #'eq + :start 0 :end 5) + nil) + +(deftest find-bit-vector.23b + (find 0 #*00001000 :test-not #'eq + :start 0 :end 5) + 1) + +(deftest find-bit-vector.24 + (find 0 #*00101110 :test-not #'eq + :start 0 :end 5 :from-end t) + 1) + +(deftest find-bit-vector.24a + (find 0 #*0000001111 :test-not #'eq + :start 0 :end 5 :from-end t) + nil) + +(deftest find-bit-vector.24b + (find 0 #*0000100 :test-not #'eq + :start 0 :end 5 :from-end t) + 1) + +(deftest find-bit-vector.25 + (find 2 #*1100001010 :key #'1+ + :start 3) + 1) + +(deftest find-bit-vector.26 + (find 2 #*11100000 :key #'1+ + :start 3) + nil) + +(deftest find-bit-vector.26a + (find 2 #*11110000 :key #'1+ + :start 3) + 1) + +(deftest find-bit-vector.27 + (find 2 #*1100001010 :key #'1+ + :start 2 :from-end t) + 1) + +(deftest find-bit-vector.28 + (find 2 #*1100000000 :key #'1+ + :start 2 :from-end t) + nil) + +;;; strings + +(deftest find-string.1 + (find #\c "abcdeca") + #\c) + +(deftest find-string.1a + (find #\c "abCa") + nil) + +(deftest find-string.2 + (find #\c "abcdeca" :from-end t) + #\c) + +(deftest find-string.2a + (find #\c "abCCCa" :from-end t) + nil) + +(deftest find-string.3 + (loop for i from 0 to 7 collect + (find #\c "abcdeca" :start i)) + (#\c #\c #\c #\c #\c #\c nil nil)) + +(deftest find-string.4 + (loop for i from 0 to 7 collect + (find #\c "abcdeca" :start i :end nil)) + (#\c #\c #\c #\c #\c #\c nil nil)) + +(deftest find-string.5 + (loop for i from 7 downto 0 collect + (find #\c "abcdeca" :end i)) + (#\c #\c #\c #\c #\c nil nil nil)) + +(deftest find-string.6 + (loop for i from 0 to 7 collect + (find #\c "abcdeca" :start i :from-end t)) + (#\c #\c #\c #\c #\c #\c nil nil)) + +(deftest find-string.7 + (loop for i from 0 to 7 collect + (find #\c "abcdeca" :start i :end nil :from-end t)) + (#\c #\c #\c #\c #\c #\c nil nil)) + +(deftest find-string.8 + (loop for i from 7 downto 0 collect + (find #\c "abcdeca" :end i :from-end t)) + (#\c #\c #\c #\c #\c nil nil nil)) + +(deftest find-string.9 + (loop for i from 0 to 6 collect + (loop for j from (1+ i) to 7 + collect + (find #\c "abcdeca" :start i :end j))) + ((nil nil #\c #\c #\c #\c #\c) + (nil #\c #\c #\c #\c #\c) + (#\c #\c #\c #\c #\c) + (nil nil #\c #\c) + (nil #\c #\c) + (#\c #\c) + (nil))) + +(deftest find-string.10 + (loop for i from 0 to 6 collect + (loop for j from (1+ i) to 7 + collect + (find #\c "abcdeca" :start i :end j :from-end t))) + ((nil nil #\c #\c #\c #\c #\c) + (nil #\c #\c #\c #\c #\c) + (#\c #\c #\c #\c #\c) + (nil nil #\c #\c) + (nil #\c #\c) + (#\c #\c) + (nil))) + +(deftest find-string.11 + (find 5 "12345648" :key #'(lambda (c) + (1+ (read-from-string (string c))))) + #\4) + +(deftest find-string.13 + (find 5 "12345648" :key #'(lambda (c) + (1+ (read-from-string (string c)))) + :from-end t) + #\4) + +(deftest find-string.14 + (find #\a "aabacedafa" :test (complement #'eq)) + #\b) + +(deftest find-string.15 + (find #\a "aabacedafa" :test (complement #'eq) + :from-end t) + #\f) + +(deftest find-string.16 + (find #\a "aabacedafa" :test-not #'eq) + #\b) + +(deftest find-string.17 + (find #\a "aabacedafa" :test-not 'eq + :from-end t) + #\f) + +(deftest find-string.18 + (find #\a "aabacedafa" :test-not 'eq) + #\b) + +(deftest find-string.19 + (find #\a "aabacedafa" :test-not #'eq + :from-end t) + #\f) + +(deftest find-string.20 + (find #\a "aabacedafa" :test-not #'eq) + #\b) + +(deftest find-string.21 + (find #\a "aabAcedafa" :test #'char-equal + :start 2) + #\A) + +(deftest find-string.22 + (find #\a "aabAcedafa" :test #'char-equal + :start 2 :end nil) + #\A) + +(deftest find-string.23 + (find #\a "aAbAcedafa" :test-not #'char-equal + :start 0 :end 5) + #\b) + +(deftest find-string.24 + (find #\a "aabacedafa" :test-not #'char-equal + :start 0 :end 5 :from-end t) + #\c) + +;;; Error tests + +(deftest find-error.1 + (handler-case (find 'a 'b) + (type-error () :type-error) + (error (c) c)) + :type-error) + +(deftest find-error.2 + (handler-case (find 'a 10) + (type-error () :type-error) + (error (c) c)) + :type-error) + +(deftest find-error.3 + (handler-case (find 'a 1.4) + (type-error () :type-error) + (error (c) c)) + :type-error) + +(deftest find-error.4 + (locally (declare (optimize (safety 3))) + (handler-case (find 'a '(a b c . d)) + (type-error () :type-error) + (error (c) c))) + :type-error) diff --git a/ansi-tests/gclload.lsp b/ansi-tests/gclload.lsp new file mode 100644 index 0000000000000000000000000000000000000000..678b61de86c388585332acc31f2cc2c3d244324e --- /dev/null +++ b/ansi-tests/gclload.lsp @@ -0,0 +1,4 @@ +(load "gclload1.lsp") +(load "gclload2.lsp") + +(rt:do-tests) diff --git a/ansi-tests/gclload1.lsp b/ansi-tests/gclload1.lsp new file mode 100644 index 0000000000000000000000000000000000000000..b421a2ae02b74131bb26dc6938a051325d4d5c71 --- /dev/null +++ b/ansi-tests/gclload1.lsp @@ -0,0 +1,11 @@ +(load "compile-and-load.lsp") +(load "rt/rt-package.lsp") +(compile-and-load "rt/rt.lsp") +;;; (unless (probe-file "rt/rt.o") (compile-file "rt/rt.lsp")) +;;; (load "rt/rt.o") +(load "cl-test-package.lsp") +(in-package :cl-test) +(compile-and-load "aux.lsp") +;;; (unless (probe-file "aux.o") (compile-file "aux.lsp")) +;;; (load "aux.o") +(load "universe.lsp") diff --git a/ansi-tests/gclload2.lsp b/ansi-tests/gclload2.lsp new file mode 100644 index 0000000000000000000000000000000000000000..34a7538492e9afef49889fe44f0772a63a5c0de8 --- /dev/null +++ b/ansi-tests/gclload2.lsp @@ -0,0 +1,114 @@ + +;;; Load individual test files + +;;; Tests of conses + +(load "cons-test-01.lsp") +(load "cons-test-02.lsp") +(load "cons-test-03.lsp") +(load "cons-test-04.lsp") +(load "cons-test-05.lsp") +(load "cons-test-06.lsp") +(load "cons-test-07.lsp") +(load "cons-test-08.lsp") +(load "cons-test-09.lsp") +(load "cons-test-10.lsp") +(load "cons-test-11.lsp") +(load "cons-test-12.lsp") +(load "cons-test-13.lsp") +(load "cons-test-14.lsp") +(load "cons-test-15.lsp") +(load "cons-test-16.lsp") +(load "cons-test-17.lsp") +(load "cons-test-18.lsp") +(load "cons-test-19.lsp") +(load "cons-test-20.lsp") +(load "cons-test-21.lsp") +(load "cons-test-22.lsp") +(load "cons-test-23.lsp") +(load "cons-test-24.lsp") +(load "cons-test-25.lsp") + +;;; Tests of packages + +#| +(compile-file "packages-00.lsp") +(load "packages-00.o") +(load "packages-01.lsp") +(load "packages-02.lsp") +(load "packages-03.lsp") +(load "packages-04.lsp") +(load "packages-05.lsp") +(load "packages-06.lsp") +(load "packages-07.lsp") +(load "packages-08.lsp") +(load "packages-09.lsp") +(load "packages-10.lsp") +(load "packages-11.lsp") +(load "packages-12.lsp") +(load "packages-13.lsp") +(load "packages-14.lsp") +(load "packages-15.lsp") +(load "packages-16.lsp") +(load "packages-17.lsp") +(load "packages-18.lsp") +(load "packages-19.lsp") +|# + +;;; Tests of sequences + +;;; (load "copy-seq.lsp") +;;; (load "elt.lsp") +;;; (load "fill.lsp") +(load "fill-strings.lsp") +(load "make-sequence.lsp") +;;; (load "subseq.lsp") +(load "map.lsp") +(load "map-into.lsp") +(load "reduce.lsp") +(load "count.lsp") +(load "count-if.lsp") +(load "count-if-not.lsp") +(load "reverse.lsp") +(load "nreverse.lsp") +(load "sort.lsp") +(load "find.lsp") +(load "find-if.lsp") +(load "find-if-not.lsp") +(load "position.lsp") +(compile-file "search-aux.lsp") +(load "search-aux.o") +(load "search-list.lsp") +(load "search-vector.lsp") +(load "search-bitvector.lsp") +(load "search-string.lsp") +(load "mismatch.lsp") +(load "replace.lsp") +(load "substitute.lsp") +(load "substitute-if.lsp") +(load "substitute-if-not.lsp") +(load "nsubstitute.lsp") +(load "nsubstitute-if.lsp") +(load "nsubstitute-if-not.lsp") +(load "concatenate.lsp") +(load "merge.lsp") +(compile-and-load "remove-aux.lsp") +(load "remove.lsp") ;; need to extend these tests + +;;; Need to add tests for REMOVE-IF, REMOVE-IF-NOT, DELETE, +;;; DELETE-IF, DELETE-IF-NOT, REMOVE-DUPLICATES, DELETE-DUPLICATES + + +;;; Tests of structures + +(load "structure-00.lsp") +(load "structures-01.lsp") +(load "structures-02.lsp") + +;;; Tests of types and classes + +(load "types-and-class.lsp") + +;;; Tests of the reader + +(load "reader-test.lsp") diff --git a/ansi-tests/length.lsp b/ansi-tests/length.lsp new file mode 100644 index 0000000000000000000000000000000000000000..c1b20df86b8dc7e6bdaf38d47a0b5168515d30bc Binary files /dev/null and b/ansi-tests/length.lsp differ diff --git a/ansi-tests/load.lsp b/ansi-tests/load.lsp new file mode 100644 index 0000000000000000000000000000000000000000..af6f617782ff8fbbaacaded9b56c5ef1b023f5ad --- /dev/null +++ b/ansi-tests/load.lsp @@ -0,0 +1,15 @@ +;; Get the MK package +;; I've hardwired a path here; fix for your system +;; I assume the package is already compiled. +(unless (find-package "MK") + (load #.(concatenate 'string "../defsys30/defsystem." + #+cmu (C::BACKEND-FASL-FILE-TYPE C::*TARGET-BACKEND*) + #+allegro "fasl" + #+(or akcl gcl) "o"))) + +(load "rt/rt.system") +(mk::load-system "rt") +(mk::compile-system "cltest") +(in-package :cl-test) + + diff --git a/ansi-tests/make-array.lsp b/ansi-tests/make-array.lsp new file mode 100644 index 0000000000000000000000000000000000000000..8f71ff6f523799266a33157282bbc4c6afe18d47 --- /dev/null +++ b/ansi-tests/make-array.lsp @@ -0,0 +1,10 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Fri Sep 20 06:47:37 2002 +;;;; Contains: Tests for MAKE-ARRAY + +(in-package :cl-test) + +(defun make-array-check-upgrading (type) + (subtypep type (array-element-type (make-array 0 :element-type type)))) + diff --git a/ansi-tests/make-sequence.lsp b/ansi-tests/make-sequence.lsp new file mode 100644 index 0000000000000000000000000000000000000000..fff9751679ca91c9ad01a5006229c5da12c100ee --- /dev/null +++ b/ansi-tests/make-sequence.lsp @@ -0,0 +1,203 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Sep 14 09:58:47 2002 +;;;; Contains: Tests for MAKE-SEQUENCE + +(in-package :cl-test) + +(deftest make-sequence.1 + (let ((x (make-sequence 'list 4))) + (and (eql (length x) 4) + (listp x) + (loop for e in x always (eql (car x) e)) + t)) + t) + +(deftest make-sequence.2 + (make-sequence 'list 4 :initial-element 'a) + (a a a a)) + +(deftest make-sequence.3 + (let ((x (make-sequence 'cons 4))) + (and (eql (length x) 4) + (listp x) + (loop for e in x always (eql (car x) e)) + t)) + t) + +(deftest make-sequence.4 + (make-sequence 'cons 4 :initial-element 'a) + (a a a a)) + +(deftest make-sequence.5 + (make-sequence 'string 10 :initial-element #\a) + "aaaaaaaaaa") + +(deftest make-sequence.6 + (let ((s (make-sequence 'string 10))) + (and (eql (length s) 10) + (loop for e across s always (eql e (aref s 0))) + t)) + t) + +(deftest make-sequence.7 + (make-sequence 'simple-string 10 :initial-element #\a) + "aaaaaaaaaa") + +(deftest make-sequence.8 + (let ((s (make-sequence 'simple-string 10))) + (and (eql (length s) 10) + (loop for e across s always (eql e (aref s 0))) + t)) + t) + +(deftest make-sequence.9 + (make-sequence 'null 0) + nil) + +(deftest make-sequence.10 + (let ((x (make-sequence 'vector 10))) + (and (eql (length x) 10) + (loop for e across x always (eql e (aref x 0))) + t)) + t) + +(deftest make-sequence.11 + (let* ((u (list 'a)) + (x (make-sequence 'vector 10 :initial-element u))) + (and (eql (length x) 10) + (loop for e across x always (eql e u)) + t)) + t) + +(deftest make-sequence.12 + (let ((x (make-sequence 'simple-vector 10))) + (and (eql (length x) 10) + (loop for e across x always (eql e (aref x 0))) + t)) + t) + +(deftest make-sequence.13 + (let* ((u (list 'a)) + (x (make-sequence 'simple-vector 10 :initial-element u))) + (and (eql (length x) 10) + (loop for e across x always (eql e u)) + t)) + t) + +(deftest make-sequence.14 + (let ((x (make-sequence '(vector *) 10))) + (and (eql (length x) 10) + (loop for e across x always (eql e (aref x 0))) + t)) + t) + +(deftest make-sequence.15 + (let* ((u (list 'a)) + (x (make-sequence '(vector *) 10 :initial-element u))) + (and (eql (length x) 10) + (loop for e across x always (eql e u)) + t)) + t) + +(deftest make-sequence.16 + (let ((x (make-sequence '(simple-vector *) 10))) + (and (eql (length x) 10) + (loop for e across x always (eql e (aref x 0))) + t)) + t) + +(deftest make-sequence.17 + (let* ((u (list 'a)) + (x (make-sequence '(simple-vector *) 10 :initial-element u))) + (and (eql (length x) 10) + (loop for e across x always (eql e u)) + t)) + t) + +(deftest make-sequence.18 + (let ((x (make-sequence '(string *) 10))) + (and (eql (length x) 10) + (loop for e across x always (eql e (aref x 0))) + t)) + t) + +(deftest make-sequence.19 + (let* ((u #\a) + (x (make-sequence '(string *) 10 :initial-element u))) + (and (eql (length x) 10) + (loop for e across x always (eql e u)) + t)) + t) + +(deftest make-sequence.20 + (let ((x (make-sequence '(simple-string *) 10))) + (and (eql (length x) 10) + (loop for e across x always (eql e (aref x 0))) + t)) + t) + +(deftest make-sequence.21 + (let* ((u #\a) + (x (make-sequence '(simple-string *) 10 :initial-element u))) + (and (eql (length x) 10) + (loop for e across x always (eql e u)) + t)) + t) + +(deftest make-sequence.22 + (make-sequence '(vector * 5) 5 :initial-element 'a) + #(a a a a a)) + +(deftest make-sequence.23 + (make-sequence '(vector fixnum 5) 5 :initial-element 1) + #(1 1 1 1 1)) + +(deftest make-sequence.24 + (make-sequence '(vector (integer 0 255) 5) 5 :initial-element 17) + #(17 17 17 17 17)) + +(deftest make-sequence.25 + (make-sequence '(simple-vector 5) 5 :initial-element 'a) + #(a a a a a)) + +(deftest make-sequence.26 + (equalp (make-sequence 'string 5) (make-string 5)) + t) + +;;; Tests for errors + +(deftest make-sequence-error.1 + (handler-case (make-sequence 'symbol 10) + (type-error () :caught)) + :caught) + +(deftest make-sequence-error.2 + (handler-case (make-sequence 'null 1) + (type-error () :caught)) + :caught) + +(deftest make-sequence-error.3 + (handler-case (make-sequence '(vector * 4) 3) + (type-error () :caught)) + :caught) + +(deftest make-sequence-error.4 + (handler-case (make-sequence '(vector * 2) 3) + (type-error () :caught)) + :caught) + +(deftest make-sequence-error.5 + (handler-case (make-sequence '(string 4) 3) + (type-error () :caught)) + :caught) + +(deftest make-sequence-error.6 + (handler-case (make-sequence '(simple-string 2) 3) + (type-error () :caught)) + :caught) + +(deftest make-sequence-error.7 + (handler-case (make-sequence 'cons 0) + (type-error () :caught)) + :caught) diff --git a/ansi-tests/make-tar b/ansi-tests/make-tar new file mode 100755 index 0000000000000000000000000000000000000000..f1bf93a1ab1c91e9ba2b4bb992e16cfd188e79ae --- /dev/null +++ b/ansi-tests/make-tar @@ -0,0 +1,2 @@ +rm -f binary/* rt/binary/* +tar cvf cltest.tar README *.system *.lsp make-tar binary/ rt/*.system rt/*.lsp rt/*.txt rt/binary/ \ No newline at end of file diff --git a/ansi-tests/map-into.lsp b/ansi-tests/map-into.lsp new file mode 100644 index 0000000000000000000000000000000000000000..4a5a634f64d8dc845c6add7026147b69faa53f69 --- /dev/null +++ b/ansi-tests/map-into.lsp @@ -0,0 +1,180 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Aug 18 10:10:04 2002 +;;;; Contains: Tests for the MAP-INTO function + +(in-package :cl-test) + +(deftest map-into-list.1 + (let ((a (copy-seq '(a b c d e f))) + (b nil)) + (map-into a #'(lambda (x) (push x b) x) '(1 2 3 4 5 6)) + (values a b)) + (1 2 3 4 5 6) + (6 5 4 3 2 1)) + +(deftest map-into-list.2 + (let ((a (copy-seq '(a b c d e f g)))) + (map-into a #'identity '(1 2 3)) + a) + (1 2 3 d e f g)) + +(deftest map-into-list.3 + (let ((a (copy-seq '(a b c)))) + (map-into a #'identity '(1 2 3 4 5 6)) + a) + (1 2 3)) + +(deftest map-into-list.4 + (let ((a (copy-seq '(a b c d e f))) + (b nil)) + (map-into a #'(lambda (x y) (let ((z (+ x y))) (push z b) z)) + '(1 2 3 4 5 6) + '(10 11 12 13 14 15)) + (values a b)) + (11 13 15 17 19 21) + (21 19 17 15 13 11)) + +(deftest map-into-list.5 + (let ((a (copy-seq '(a b c d e f)))) + (map-into a 'identity '(1 2 3 4 5 6)) + a) + (1 2 3 4 5 6)) + +(deftest map-into-list.6 + (let ((b nil)) + (values + (map-into nil #'(lambda (x y) (let ((z (+ x y))) (push z b) z)) + '(1 2 3 4 5 6) + '(10 11 12 13 14 15)) + b)) + nil nil) + +(deftest map-into-list.7 + (let ((a (copy-seq '(a b c d e f)))) + (map-into a #'(lambda () 1)) + a) + (1 1 1 1 1 1)) + +(deftest map-into-array.1 + (let ((a (copy-seq #(a b c d e f))) + b) + (map-into a #'(lambda (x) (push x b) x) '(1 2 3 4 5 6)) + (values a b)) + #(1 2 3 4 5 6) + (6 5 4 3 2 1)) + +(deftest map-into-array.2 + (let ((a (copy-seq #(a b c d e f g h))) + b) + (map-into a #'(lambda (x) (push x b) x) '(1 2 3 4 5 6)) + (values a b)) + #(1 2 3 4 5 6 g h) + (6 5 4 3 2 1)) + +(deftest map-into-array.3 + (let ((a (copy-seq #(a b c d))) + b) + (map-into a #'(lambda (x) (push x b) x) '(1 2 3 4 5 6)) + (values a b)) + #(1 2 3 4) + (4 3 2 1)) + +(deftest map-into-array.4 + (let ((a (copy-seq #(a b c d e f))) + b) + (map-into a #'(lambda (x) (push x b) x) #(1 2 3 4 5 6)) + (values a b)) + #(1 2 3 4 5 6) + (6 5 4 3 2 1)) + +(deftest map-into-array.5 + (let ((a (copy-seq #(a b c d e f g h))) + b) + (map-into a #'(lambda (x) (push x b) x) #(1 2 3 4 5 6)) + (values a b)) + #(1 2 3 4 5 6 g h) + (6 5 4 3 2 1)) + +(deftest map-into-array.6 + (let ((a (copy-seq #(a b c d))) + b) + (map-into a #'(lambda (x) (push x b) x) #(1 2 3 4 5 6)) + (values a b)) + #(1 2 3 4) + (4 3 2 1)) + +;;; Tests of mapping into arrays with fill pointers +(deftest map-into-array.7 + (let ((a (make-array 6 :initial-element 'x + :fill-pointer 3))) + (map-into a #'identity '(1 2 3)) + a) + #(1 2 3)) + +(deftest map-into-array.8 + (let ((a (make-array 6 :initial-element 'x + :fill-pointer 3))) + (map-into a #'identity '(1 2)) + a) + #(1 2)) + +(deftest map-into-array.9 + (let ((a (make-array 6 :initial-element 'x + :fill-pointer 3))) + (map-into a #'identity '(1 2 3 4 5)) + a) + #(1 2 3 4 5)) + +(deftest map-into-array.10 + (let ((a (make-array 6 :initial-element 'x + :fill-pointer 3))) + (map-into a #'(lambda () 'y)) + a) + #(y y y y y y)) + +;;; mapping into strings + +(deftest map-into-string.1 + (let ((a (copy-seq "abcdef"))) + (map-into a #'identity "123456") + (values (not (not (stringp a))) a)) + t + "123456") + +(deftest map-into-string.2 + (let ((a (copy-seq "abcdef"))) + (map-into a #'identity "1234") + (values (not (not (stringp a))) a)) + t + "1234ef") + +(deftest map-into-string.3 + (let ((a (copy-seq "abcd"))) + (map-into a #'identity "123456") + (values (not (not (stringp a))) a)) + t + "1234") + +(deftest map-into-error.1 + (handler-case (map-into 'a #'(lambda () nil)) + (type-error (c) 'type-error) + (error (c) c)) + type-error) + +(deftest map-into-error.2 + (handler-case (map-into nil #'identity 'a) + (type-error (c) 'type-error) + (error (c) c)) + type-error) + +(deftest map-into-error.3 + (handler-case (map-into (copy-seq '(a b c)) #'cons '(d e f) 100) + (type-error (c) 'type-error) + (error (c) c)) + type-error) + + + + + diff --git a/ansi-tests/map.lsp b/ansi-tests/map.lsp new file mode 100644 index 0000000000000000000000000000000000000000..3b5be5470df2c3b0bafcc85f1b71b6675cad5c52 --- /dev/null +++ b/ansi-tests/map.lsp @@ -0,0 +1,183 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Aug 17 20:54:48 2002 +;;;; Contains: Tests for the MAP function + +(in-package :cl-test) + +(deftest map-array.1 + (map 'list #'1+ #(1 2 3 4)) + (2 3 4 5)) + +(deftest map-array.2 + (map 'vector #'+ #(1 2 3 4) #(6 6 6 6)) + #(7 8 9 10)) + +(deftest map-array.3 + (map 'vector #'+ #(1 2 3 4 5) #(6 6 6 6)) + #(7 8 9 10)) + +(deftest map-array.4 + (map 'vector #'+ #(1 2 3 4) #(6 6 6 6 6)) + #(7 8 9 10)) + +(deftest map-array.5 + (map '(vector *) #'+ #(1 2 3 4) #(6 6 6 6)) + #(7 8 9 10)) + +(deftest map-array.6 + (map '(vector * 4) #'+ #(1 2 3 4) #(6 6 6 6)) + #(7 8 9 10)) + +(deftest map-array.7 + (map 'array #'identity '(a b c d e f)) + #(a b c d e f)) + +(deftest map-array.8 + (map 'simple-array #'identity '(a b c d e f)) + #(a b c d e f)) + +(deftest map-array.9 + (map 'simple-vector #'identity '(a b c d e f)) + #(a b c d e f)) + +(deftest map-array.10 + (map 'simple-vector #'cons '(a b c d e f) #(1 2 3 4 5 6)) + #((a . 1) (b . 2) (c . 3) (d . 4) (e . 5) (f . 6))) + +(deftest map-array.11 + (map 'vector #'identity '(#\a #\b #\c #\d #\e)) + #(#\a #\b #\c #\d #\e)) + +(deftest map-array.12 + (map 'vector #'identity "abcde") + #(#\a #\b #\c #\d #\e)) + +(deftest map-array.13 + (map 'vector #'identity #*000001) + #(0 0 0 0 0 1)) + +(deftest map-array.14 + (map 'list #'identity #*000001) + (0 0 0 0 0 1)) + +(deftest map-bit-vector.15 + (map 'bit-vector #'identity '(0 0 0 0 0 1)) + #*000001) + +(deftest map-bit-vector.16 + (map 'simple-bit-vector #'identity '(0 0 0 0 0 1)) + #*000001) + +(deftest map-bit-vector.17 + (map '(vector bit) #'identity '(0 0 0 0 0 1)) + #*000001) + +(deftest map-bit-vector.18 + (map '(simple-vector *) #'identity '(0 0 0 0 0 1)) + #*000001) + +(deftest map-bit-vector.19 + (map '(bit-vector 6) #'identity '(0 0 0 0 0 1)) + #*000001) + +(deftest map-bit-vector.20 + (map '(bit-vector *) #'identity '(0 0 0 0 0 1)) + #*000001) + +(deftest map-bit-vector.21 + (map '(simple-bit-vector 6) #'identity '(0 0 0 0 0 1)) + #*000001) + +(deftest map-bit-vector.22 + (map '(simple-bit-vector *) #'identity '(0 0 0 0 0 1)) + #*000001) + +(deftest map-bit-vector.23 + (map '(vector bit 6) #'identity '(0 0 0 0 0 1)) + #*000001) + +(deftest map-bit-vector.24 + (map '(vector bit *) #'identity '(0 0 0 0 0 1)) + #*000001) + +(deftest map-bit-vector.25 + (map '(simple-vector 6) #'identity '(0 0 0 0 0 1)) + #*000001) + +(deftest map-string.26 + (map 'string #'identity '(#\a #\b #\c #\d #\e)) + "abcde") + +(deftest map-string.27 + (map 'string #'identity "abcde") + "abcde") + +(deftest map-string.28 + (map '(vector character) #'identity '(#\a #\b #\c #\d #\e)) + "abcde") + +(deftest map-string.29 + (map '(vector character 5) #'identity '(#\a #\b #\c #\d #\e)) + "abcde") + +(deftest map-string.30 + (map '(simple-vector character) #'identity '(#\a #\b #\c #\d #\e)) + "abcde") + +(deftest map-string.31 + (map '(simple-array character *) #'identity "abcde") + "abcde") + +(deftest map-string.32 + (map '(simple-array character * 5) #'identity "abcde") + "abcde") + +(deftest map-nil.33 + (let ((a nil)) + (values (map nil #'(lambda (x) (push x a)) "abcdef") a)) + nil (#\f #\e #\d #\c #\b #\a)) + +(deftest map-nil.34 + (let ((a nil)) + (values (map nil #'(lambda (x) (push x a)) '(a b c d e)) a)) + nil (e d c b a)) + +(deftest map-nil.35 + (let ((a nil)) + (values (map nil #'(lambda (x) (push x a)) #(a b c d e)) a)) + nil (e d c b a)) + +(deftest map-nil.36 + (let ((a nil)) + (values (map nil #'(lambda (x) (push x a)) #*001011110) a)) + nil (0 1 1 1 1 0 1 0 0)) + +(deftest map-null.1 + (map 'null #'identity nil) + nil) + +(deftest map-cons.1 + (map 'cons #'identity '(a b c)) + (a b c)) + +(deftest map-error.1 + (handler-case (map 'symbol #'identity '(a b c)) + (error () :caught)) + :caught) + +(deftest map-error.2 + (handler-case (map '(vector * 8) #'identity '(a b c)) + (type-error () :caught)) + :caught) + +(deftest map-error.3 + (handler-case (map 'list #'identity '(a b . c)) + (type-error () :caught)) + :caught) + + + + + + diff --git a/ansi-tests/merge.lsp b/ansi-tests/merge.lsp new file mode 100644 index 0000000000000000000000000000000000000000..dacd27035b2d6b4ace2cbf7e6d842259652084f6 --- /dev/null +++ b/ansi-tests/merge.lsp @@ -0,0 +1,443 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Fri Sep 6 07:24:17 2002 +;;;; Contains: Tests for MERGE + +(in-package :cl-test) + +(deftest merge-list.1 + (let ((x (list 1 3 7 8 10)) + (y (list 2 4 5 8 11))) + (merge 'list x y #'<)) + (1 2 3 4 5 7 8 8 10 11)) + +(deftest merge-list.2 + (let ((x nil) + (y (list 2 4 5 8 11))) + (merge 'list x y #'<)) + (2 4 5 8 11)) + +(deftest merge-list.3 + (let ((x nil) + (y (list 2 4 5 8 11))) + (merge 'list y x #'<)) + (2 4 5 8 11)) + +(deftest merge-list.4 + (merge 'list nil nil #'<) + nil) + +(deftest merge-list.5 + (let ((x (vector 1 3 7 8 10)) + (y (list 2 4 5 8 11))) + (merge 'list x y #'<)) + (1 2 3 4 5 7 8 8 10 11)) + +(deftest merge-list.6 + (let ((x (list 1 3 7 8 10)) + (y (vector 2 4 5 8 11))) + (merge 'list x y #'<)) + (1 2 3 4 5 7 8 8 10 11)) + +(deftest merge-list.7 + (let ((x (vector 1 3 7 8 10)) + (y (vector 2 4 5 8 11))) + (merge 'list x y #'<)) + (1 2 3 4 5 7 8 8 10 11)) + +(deftest merge-list.8 + (let ((x (sort (list 1 3 7 8 10) #'>)) + (y (sort (list 2 4 5 8 11) #'>))) + (merge 'list x y #'< :key #'-)) + (11 10 8 8 7 5 4 3 2 1)) + +(deftest merge-list.9 + (let ((x (list 1 3 7 8 10)) + (y (list 2 4 5 8 11))) + (merge 'list x y #'< :key nil)) + (1 2 3 4 5 7 8 8 10 11)) + +(deftest merge-list.10 + (let ((x (list 1 3 7 8 10)) + (y (list 2 4 5 8 11))) + (merge 'list x y '<)) + (1 2 3 4 5 7 8 8 10 11)) + +(deftest merge-list.11 + (let ((x (vector)) (y (vector))) + (merge 'list x y #'<)) + nil) + +(deftest merge-list.12 + (let ((x nil) (y (vector 1 2 3))) + (merge 'list x y #'<)) + (1 2 3)) + +(deftest merge-list.13 + (let ((x #()) (y (list 1 2 3))) + (merge 'list x y #'<)) + (1 2 3)) + +(deftest merge-list.14 + (let ((x nil) (y (vector 1 2 3))) + (merge 'list y x #'<)) + (1 2 3)) + +(deftest merge-list.15 + (let ((x #()) (y (list 1 2 3))) + (merge 'list y x #'<)) + (1 2 3)) + +;;; Tests yielding vectors + +(deftest merge-vector.1 + (let ((x (list 1 3 7 8 10)) + (y (list 2 4 5 8 11))) + (merge 'vector x y #'<)) + #(1 2 3 4 5 7 8 8 10 11)) + +(deftest merge-vector.2 + (let ((x nil) + (y (list 2 4 5 8 11))) + (merge 'vector x y #'<)) + #(2 4 5 8 11)) + +(deftest merge-vector.3 + (let ((x nil) + (y (list 2 4 5 8 11))) + (merge 'vector y x #'<)) + #(2 4 5 8 11)) + +(deftest merge-vector.4 + (merge 'vector nil nil #'<) + #()) + +(deftest merge-vector.5 + (let ((x (vector 1 3 7 8 10)) + (y (list 2 4 5 8 11))) + (merge 'vector x y #'<)) + #(1 2 3 4 5 7 8 8 10 11)) + +(deftest merge-vector.6 + (let ((x (list 1 3 7 8 10)) + (y (vector 2 4 5 8 11))) + (merge 'vector x y #'<)) + #(1 2 3 4 5 7 8 8 10 11)) + +(deftest merge-vector.7 + (let ((x (vector 1 3 7 8 10)) + (y (vector 2 4 5 8 11))) + (merge 'vector x y #'<)) + #(1 2 3 4 5 7 8 8 10 11)) + +(deftest merge-vector.8 + (let ((x (sort (list 1 3 7 8 10) #'>)) + (y (sort (list 2 4 5 8 11) #'>))) + (merge 'vector x y #'< :key #'-)) + #(11 10 8 8 7 5 4 3 2 1)) + +(deftest merge-vector.9 + (let ((x (list 1 3 7 8 10)) + (y (list 2 4 5 8 11))) + (merge 'vector x y #'< :key nil)) + #(1 2 3 4 5 7 8 8 10 11)) + +(deftest merge-vector.10 + (let ((x (list 1 3 7 8 10)) + (y (list 2 4 5 8 11))) + (merge 'vector x y '<)) + #(1 2 3 4 5 7 8 8 10 11)) + +(deftest merge-vector.11 + (let ((x (vector)) (y (vector))) + (merge 'vector x y #'<)) + #()) + +(deftest merge-vector.12 + (let ((x nil) (y (vector 1 2 3))) + (merge 'vector x y #'<)) + #(1 2 3)) + +(deftest merge-vector.13 + (let ((x #()) (y (list 1 2 3))) + (merge 'vector x y #'<)) + #(1 2 3)) + +(deftest merge-vector.14 + (let ((x nil) (y (vector 1 2 3))) + (merge 'vector y x #'<)) + #(1 2 3)) + +(deftest merge-vector.15 + (let ((x #()) (y (list 1 2 3))) + (merge 'vector y x #'<)) + #(1 2 3)) + +;;; Tests on strings + +(deftest merge-string.1 + (let ((x (list #\1 #\3 #\7 #\8)) + (y (list #\2 #\4 #\5 #\9))) + (merge 'string x y #'char<)) + "12345789") + +(deftest merge-string.1a + (let ((x "1378") + (y (list #\2 #\4 #\5 #\9))) + (merge 'string x y #'char<)) + "12345789") + +(deftest merge-string.1b + (let ((x (list #\1 #\3 #\7 #\8)) + (y "2459")) + (merge 'string x y #'char<)) + "12345789") + +(deftest merge-string.1c + (let ((x "1378") + (y "2459")) + (merge 'string x y #'char<)) + "12345789") + +(deftest merge-string.1d + (let ((x "1378") + (y "2459")) + (merge 'string y x #'char<)) + "12345789") + +(deftest merge-string.2 + (let ((x nil) + (y (list #\2 #\4 #\5 #\9))) + (merge 'string x y #'char<)) + "2459") + +(deftest merge-string.3 + (let ((x nil) + (y (list #\2 #\4 #\5 #\9))) + (merge 'string y x #'char<)) + "2459") + +(deftest merge-string.4 + (merge 'string nil nil #'char<) + "") + +(deftest merge-string.8 + (let ((x (list #\1 #\3 #\7 #\8)) + (y (list #\2 #\4 #\5))) + (merge 'string x y #'char< :key #'nextdigit)) + "1234578") + +(deftest merge-string.9 + (let ((x (list #\1 #\3 #\7 #\8)) + (y (list #\2 #\4 #\5 #\9))) + (merge 'string x y #'char< :key nil)) + "12345789") + +(deftest merge-string.10 + (let ((x (list #\1 #\3 #\7 #\8)) + (y (list #\2 #\4 #\5 #\9))) + (merge 'string x y 'char<)) + "12345789") + +(deftest merge-string.11 + (let ((x (vector)) (y (vector))) + (merge 'string x y #'char<)) + "") + +(deftest merge-string.12 + (let ((x nil) (y (vector #\1 #\2 #\3))) + (merge 'string x y #'char<)) + "123") + +(deftest merge-string.13 + (let ((x #()) (y (list #\1 #\2 #\3))) + (merge 'string x y #'char<)) + "123") + +(deftest merge-string.13a + (let ((x "") (y (list #\1 #\2 #\3))) + (merge 'string x y #'char<)) + "123") + +(deftest merge-string.14 + (let ((x nil) (y (vector #\1 #\2 #\3))) + (merge 'string y x #'char<)) + "123") + +(deftest merge-string.14a + (let ((x "") (y (vector #\1 #\2 #\3))) + (merge 'string y x #'char<)) + "123") + +;;; Tests for bit vectors + +(deftest merge-bitvector.1 + (let ((x (list 0 0 1 1 1)) + (y (list 0 0 0 1 1))) + (merge 'bit-vector x y #'<)) + #*0000011111) + +(deftest merge-bitvector.2 + (let ((x nil) + (y (list 0 0 0 1 1))) + (merge 'bit-vector x y #'<)) + #*00011) + +(deftest merge-bitvector.3 + (let ((x nil) + (y (list 0 0 0 1 1))) + (merge 'bit-vector y x #'<)) + #*00011) + +(deftest merge-bitvector.4 + (merge 'bit-vector nil nil #'<) + #*) + +(deftest merge-bitvector.5 + (let ((x (vector 0 0 1 1 1)) + (y (list 0 0 0 1 1))) + (merge 'bit-vector x y #'<)) + #*0000011111) + +(deftest merge-bitvector.5a + (let ((x (copy-seq #*00111)) + (y (list 0 0 0 1 1))) + (merge 'bit-vector x y #'<)) + #*0000011111) + +(deftest merge-bitvector.5b + (let ((x (list 0 0 1 1 1)) + (y (copy-seq #*00011))) + (merge 'bit-vector x y #'<)) + #*0000011111) + +(deftest merge-bitvector.5c + (let ((x (copy-seq #*00111)) + (y (copy-seq #*00011))) + (merge 'bit-vector x y #'<)) + #*0000011111) + +(deftest merge-bitvector.5d + (let ((x (copy-seq #*11111)) + (y (copy-seq #*00000))) + (merge 'bit-vector x y #'<)) + #*0000011111) + +(deftest merge-bitvector.5e + (let ((x (copy-seq #*11111)) + (y (copy-seq #*00000))) + (merge 'bit-vector y x #'<)) + #*0000011111) + +(deftest merge-bitvector.6 + (let ((x (list 0 0 1 1 1)) + (y (vector 0 0 0 1 1))) + (merge 'bit-vector x y #'<)) + #*0000011111) + +(deftest merge-bitvector.7 + (let ((x (vector 0 0 1 1 1)) + (y (vector 0 0 0 1 1))) + (merge 'bit-vector x y #'<)) + #*0000011111) + +(deftest merge-bitvector.8 + (let ((x (list 1 1 1 0 0)) + (y (list 1 1 0 0 0))) + (merge 'bit-vector x y #'< :key #'-)) + #*1111100000) + +(deftest merge-bitvector.9 + (let ((x (list 0 0 1 1 1)) + (y (list 0 0 0 1 1))) + (merge 'bit-vector x y #'< :key nil)) + #*0000011111) + +(deftest merge-bitvector.10 + (let ((x (list 0 0 1 1 1)) + (y (list 0 0 0 1 1))) + (merge 'bit-vector x y '<)) + #*0000011111) + +(deftest merge-bitvector.11 + (let ((x (copy-seq #*)) (y (copy-seq #*))) + (merge 'bit-vector x y #'<)) + #*) + +(deftest merge-bitvector.12 + (let ((x (copy-seq #*)) (y (copy-seq #*011))) + (merge 'bit-vector x y #'<)) + #*011) + +(deftest merge-bitvector.13 + (let ((x (copy-seq #*)) (y (list 0 1 1))) + (merge 'bit-vector x y #'<)) + #*011) + +(deftest merge-bitvector.14 + (let ((x nil) (y (vector 0 1 1))) + (merge 'bit-vector y x #'<)) + #*011) + +(deftest merge-bitvector.15 + (let ((x (copy-seq #*)) (y (list 0 1 1))) + (merge 'bit-vector y x #'<)) + #*011) + +;;; Cons (which is a recognizable subtype of list) + +(deftest merge-cons.1 + (merge 'cons (list 1 2 3) (list 4 5 6) #'<) + (1 2 3 4 5 6)) + +;;; Null, which is a recognizable subtype of list + +(deftest merge-null.1 + (merge 'null nil nil #'<) + nil) + +;;; Vectors with length + +(deftest merge-vector-length.1 + (merge '(vector * 6) (list 1 2 3) (list 4 5 6) #'<) + #(1 2 3 4 5 6)) + +(deftest merge-bit-vector-length.1 + (merge '(bit-vector 6) (list 0 1 1) (list 0 0 1) #'<) + #*000111) + +;;; Tests of error situations + +(deftest merge-error.1 + (handler-case (merge 'symbol (list 1 2 3) (list 4 5 6) #'<) + (error () :caught)) + :caught) + +(deftest merge-error.2 + (handler-case (merge '(vector * 3) (list 1 2 3) (list 4 5 6) #'<) + (type-error () :caught)) + :caught) + +(deftest merge-error.3 + (handler-case (merge '(bit-vector 3) (list 0 0 0) (list 1 1 1) #'<) + (type-error () :caught)) + :caught) + +(deftest merge-error.4 + (handler-case (merge '(vector * 7) (list 1 2 3) (list 4 5 6) #'<) + (type-error () :caught)) + :caught) + +(deftest merge-error.5 + (handler-case (merge '(bit-vector 7) (list 0 0 0) (list 1 1 1) #'<) + (type-error () :caught)) + :caught) + +(deftest merge-error.6 + (handler-case (merge 'null (list 1 2 3) (list 4 5 6) #'<) + (type-error () :caught)) + :caught) + + + + diff --git a/ansi-tests/mismatch.lsp b/ansi-tests/mismatch.lsp new file mode 100644 index 0000000000000000000000000000000000000000..54f221d3306fc67593bb51178c4a8117775fb0fb --- /dev/null +++ b/ansi-tests/mismatch.lsp @@ -0,0 +1,512 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Mon Aug 26 23:55:29 2002 +;;;; Contains: Tests for MISMATCH + +(in-package :cl-test) + +(deftest mismatch-list.1 + (mismatch '() '(a b c)) + 0) + +(deftest mismatch-list.2 + (mismatch '(a b c d) '()) + 0) + +(deftest mismatch-list.3 + (mismatch '(a b c) '(a b c)) + nil) + +(deftest mismatch-list.4 + (mismatch '(a b c) '(a b d)) + 2) + +(deftest mismatch-list.5 + (mismatch '(a b c) '(b c) :start1 1) + nil) + +(deftest mismatch-list.6 + (mismatch '(a b c d) '(z b c e) :start1 1 :start2 1) + 3) + +(deftest mismatch-list.7 + (mismatch '(a b c d) '(z b c e) :start1 1 :start2 1 :end1 3 :end2 3) + nil) + +(deftest mismatch-list.8 + (mismatch '(1 2 3 4) '(5 6 7 8) :test #'(lambda (x y) (= x (- y 4)))) + nil) + +(deftest mismatch-list.9 + (mismatch '(1 2 3 4) '(5 6 17 8) :test #'(lambda (x y) (= x (- y 4)))) + 2) + +(deftest mismatch-list.10 + (mismatch '(1 2 3 4) '(10 11 7 123) :test-not #'(lambda (x y) (= x (- y 4)))) + 2) + +(deftest mismatch-list.11 + (mismatch '(1 2 3 4) '(5 6 17 8) :key #'evenp) + nil) + +(deftest mismatch-list.12 + (mismatch '(1 2 3 4) '(5 6 12 8) :key 'oddp) + 2) + +(deftest mismatch-list.13 + (mismatch '(1 2 3 4) '(1 2 3 4) :test 'eq) + nil) + +(deftest mismatch-list.14 + (mismatch '(1 2 3 4) '(5 6 7 8) :test-not 'eq) + nil) + +(deftest mismatch-list.15 + (mismatch '(a b c d e f g h i j k) '(a b c c e f g h z j k)) + 3) + +(deftest mismatch-list.16 + (mismatch '(a b c d e f g h i j k) '(a b c c y f g h z j k) :from-end t) + 9) + +(deftest mismatch-list.17 + (mismatch '(a b c) '(a b c a b c d) :from-end t) + 3) + +(deftest mismatch-list.18 + (mismatch '(a b c a b c d) '(a b c) :from-end t) + 7) + +(deftest mismatch-list.19 + (mismatch '(1 1 1) '(2 2 2 2 2 1 2 2) :from-end t :test-not 'eq) + 1) + +(deftest mismatch-list.20 + (mismatch '(1 1 1 1 1 1 1) '(2 3 3) :from-end t :key #'evenp) + 5) + +(deftest mismatch-list.21 + (mismatch '(1 1 1) '(2 2 2 2 2 1 2 2) :from-end t :test-not #'equal) + 1) + +(deftest mismatch-list.22 + (mismatch '(1 1 1 1 1 1 1) '(2 3 3) :from-end t :key 'evenp) + 5) + +;;; tests on vectors + +(deftest mismatch-vector.1 + (mismatch #() #(a b c)) + 0) + +(deftest mismatch-vector.2 + (mismatch #(a b c d) #()) + 0) + +(deftest mismatch-vector.3 + (mismatch #(a b c) #(a b c)) + nil) + +(deftest mismatch-vector.4 + (mismatch #(a b c) #(a b d)) + 2) + +(deftest mismatch-vector.5 + (mismatch #(a b c) #(b c) :start1 1) + nil) + +(deftest mismatch-vector.6 + (mismatch #(a b c d) #(z b c e) :start1 1 :start2 1) + 3) + +(deftest mismatch-vector.7 + (mismatch #(a b c d) #(z b c e) :start1 1 :start2 1 :end1 3 :end2 3) + nil) + +(deftest mismatch-vector.8 + (mismatch #(1 2 3 4) #(5 6 7 8) :test #'(lambda (x y) (= x (- y 4)))) + nil) + +(deftest mismatch-vector.9 + (mismatch #(1 2 3 4) #(5 6 17 8) :test #'(lambda (x y) (= x (- y 4)))) + 2) + +(deftest mismatch-vector.10 + (mismatch #(1 2 3 4) #(10 11 7 123) :test-not #'(lambda (x y) (= x (- y 4)))) + 2) + +(deftest mismatch-vector.11 + (mismatch #(1 2 3 4) #(5 6 17 8) :key #'evenp) + nil) + +(deftest mismatch-vector.12 + (mismatch #(1 2 3 4) #(5 6 12 8) :key 'oddp) + 2) + +(deftest mismatch-vector.13 + (mismatch #(1 2 3 4) #(1 2 3 4) :test 'eq) + nil) + +(deftest mismatch-vector.14 + (mismatch #(1 2 3 4) #(5 6 7 8) :test-not 'eq) + nil) + +(deftest mismatch-vector.15 + (mismatch #(a b c d e f g h i j k) #(a b c c e f g h z j k)) + 3) + +(deftest mismatch-vector.16 + (mismatch #(a b c d e f g h i j k) #(a b c c y f g h z j k) :from-end t) + 9) + +(deftest mismatch-vector.17 + (mismatch #(a b c) #(a b c a b c d) :from-end t) + 3) + +(deftest mismatch-vector.18 + (mismatch #(a b c a b c d) #(a b c) :from-end t) + 7) + +(deftest mismatch-vector.19 + (mismatch #(1 1 1) #(2 2 2 2 2 1 2 2) :from-end t :test-not 'eq) + 1) + +(deftest mismatch-vector.20 + (mismatch #(1 1 1 1 1 1 1) #(2 3 3) :from-end t :key #'evenp) + 5) + +(deftest mismatch-vector.21 + (mismatch #(1 1 1) #(2 2 2 2 2 1 2 2) :from-end t :test-not #'equal) + 1) + +(deftest mismatch-vector.22 + (mismatch #(1 1 1 1 1 1 1) #(2 3 3) :from-end t :key 'evenp) + 5) + +;;; tests on bit vectors + +(deftest mismatch-bitvector.1 + (mismatch "" #*111) + 0) + +(deftest mismatch-bitvector.1a + (mismatch '() #*111) + 0) + +(deftest mismatch-bitvector.1b + (mismatch "" '(1 1 1)) + 0) + +(deftest mismatch-bitvector.2 + (mismatch #*1010 #*) + 0) + +(deftest mismatch-bitvector.2a + (mismatch #*1010 '()) + 0) + +(deftest mismatch-bitvector.2b + (mismatch '(1 0 1 0) #*) + 0) + +(deftest mismatch-bitvector.3 + (mismatch #*101 #*101) + nil) + +(deftest mismatch-bitvector.4 + (mismatch #*101 #*100) + 2) + +(deftest mismatch-bitvector.5 + (mismatch #*101 #*01 :start1 1) + nil) + +(deftest mismatch-bitvector.6 + (mismatch #*0110 #*0111 :start1 1 :start2 1) + 3) + +(deftest mismatch-bitvector.7 + (mismatch #*0110 #*0111 :start1 1 :start2 1 :end1 3 :end2 3) + nil) + +(deftest mismatch-bitvector.7a + (mismatch '(0 1 1 0) #*0111 :start1 1 :start2 1 :end1 3 :end2 3) + nil) + +(deftest mismatch-bitvector.7b + (mismatch #*0110 '(0 1 1 1) :start1 1 :start2 1 :end1 3 :end2 3) + nil) + +(deftest mismatch-bitvector.8 + (mismatch #*1001 #*0110 :test #'(lambda (x y) (= x (- 1 y)))) + nil) + +(deftest mismatch-bitvector.8a + (mismatch #*1001 '(5 4 4 5) :test #'(lambda (x y) (= x (- y 4)))) + nil) + +(deftest mismatch-bitvector.9 + (mismatch #*1001 '(5 4 17 5) :test #'(lambda (x y) (= x (- y 4)))) + 2) + +(deftest mismatch-bitvector.9a + (mismatch '(5 4 17 5) #*1001 :test #'(lambda (x y) (= y (- x 4)))) + 2) + +(deftest mismatch-bitvector.9b + (mismatch #*0100 #*1001 :test #'(lambda (x y) (= x (- 1 y)))) + 2) + +(deftest mismatch-bitvector.10 + (mismatch #*1001 '(10 11 4 123) :test-not #'(lambda (x y) (= x (- y 4)))) + 2) + +(deftest mismatch-bitvector.10a + (mismatch #*1001 '(10 11 100 123) :test-not #'(lambda (x y) (= x (- y 4)))) + nil) + +(deftest mismatch-bitvector.11 + (mismatch #*1010 '(5 6 17 8) :key #'evenp) + nil) + +(deftest mismatch-bitvector.11a + (mismatch '(5 6 17 8) #*1010 :key #'evenp) + nil) + +(deftest mismatch-bitvector.11b + (mismatch #*0101 #*1010 :key #'evenp :test-not 'eq) + nil) + +(deftest mismatch-bitvector.11c + (mismatch '(5 6 17 8) #*10101 :key #'evenp) + 4) + +(deftest mismatch-bitvector.11d + (mismatch '(5 6 17 8 100) #*1010 :key #'evenp) + 4) + +(deftest mismatch-bitvector.12 + (mismatch #*1010 #*1000 :key 'oddp) + 2) + +(deftest mismatch-bitvector.12a + (mismatch #*1010 '(5 6 8 8) :key 'oddp) + 2) + +(deftest mismatch-bitvector.12b + (mismatch '(5 6 8 8) #*1010 :key 'oddp) + 2) + +(deftest mismatch-bitvector.13 + (mismatch #*0001 #*0001 :test 'eq) + nil) + +(deftest mismatch-bitvector.14 + (mismatch '#*10001 #*01110 :test-not 'eq) + nil) + +(deftest mismatch-bitvector.15 + (mismatch #*00100010100 #*00110010000) + 3) + +(deftest mismatch-bitvector.16 + (mismatch #*00100010100 #*00110010000 :from-end t) + 9) + +(deftest mismatch-bitvector.17 + (mismatch #*001 #*0010010 :from-end t) + 3) + +(deftest mismatch-bitvector.18 + (mismatch #*0010010 #*001 :from-end t) + 7) + +(deftest mismatch-bitvector.19 + (mismatch #*000 #*11111011 :from-end t :test-not 'eq) + 1) + +(deftest mismatch-bitvector.20 + (mismatch #*1111111 '(2 3 3) :from-end t :key #'evenp) + 5) + +(deftest mismatch-bitvector.21 + (mismatch #*111 #*00000100 :from-end t :test-not #'equal) + 1) + +(deftest mismatch-bitvector.22 + (mismatch #*1111111 '(2 3 3) :from-end t :key 'evenp) + 5) + +;;; tests on strings + +(deftest mismatch-string.1 + (mismatch "" "111") + 0) + +(deftest mismatch-string.1a + (mismatch '() "111") + 0) + +(deftest mismatch-string.1b + (mismatch "" '(1 1 1)) + 0) + +(deftest mismatch-string.2 + (mismatch "1010" "") + 0) + +(deftest mismatch-string.2a + (mismatch "1010" '()) + 0) + +(deftest mismatch-string.2b + (mismatch '(1 0 1 0) "") + 0) + +(deftest mismatch-string.3 + (mismatch "101" "101") + nil) + +(deftest mismatch-string.4 + (mismatch "101" "100") + 2) + +(deftest mismatch-string.5 + (mismatch "101" "01" :start1 1) + nil) + +(deftest mismatch-string.6 + (mismatch "0110" "0111" :start1 1 :start2 1) + 3) + +(deftest mismatch-string.7 + (mismatch "0110" "0111" :start1 1 :start2 1 :end1 3 :end2 3) + nil) + +(deftest mismatch-string.7a + (mismatch '(#\0 #\1 #\1 #\0) "0111" :start1 1 :start2 1 :end1 3 :end2 3) + nil) + +(deftest mismatch-string.7b + (mismatch "0110" '(#\0 #\1 #\1 #\1) :start1 1 :start2 1 :end1 3 :end2 3) + nil) + +(deftest mismatch-string.8 + (mismatch "1001" "0110" :test #'(lambda (x y) (eql x (if (eq y #\0) #\1 #\0)))) + nil) + +(deftest mismatch-string.8a + (mismatch "1001" '(5 4 4 5) :test #'(lambda (x y) + (setq x (read-from-string (string x))) + (= x (- y 4)))) + nil) + +(deftest mismatch-string.9 + (mismatch "1001" '(5 4 17 5) :test #'(lambda (x y) + (setq x (read-from-string (string x))) + (= x (- y 4)))) + 2) + +(deftest mismatch-string.9a + (mismatch '(5 4 17 5) "1001" :test #'(lambda (x y) + (setq y (read-from-string (string y))) + (= y (- x 4)))) + 2) + +(deftest mismatch-string.9b + (mismatch "0100" "1001" :test #'(lambda (x y) (eql x (if (eql y #\0) #\1 #\0)))) + 2) + +(deftest mismatch-string.10 + (mismatch "1001" "0049" :test-not #'(lambda (x y) + (setq x (read-from-string (string x))) + (setq y (read-from-string (string y))) + (eql x (- y 4)))) + 2) + +(deftest mismatch-string.10a + (mismatch "1001" "3333" :test-not #'(lambda (x y) + (setq x (read-from-string (string x))) + (setq y (read-from-string (string y))) + (eql x (- y 4)))) + nil) + +(deftest mismatch-string.11 + (mismatch "1010" "5678" :key #'evendigitp) + nil) + +(deftest mismatch-string.11a + (mismatch "5678" "1010" :key #'odddigitp) + nil) + +(deftest mismatch-string.11b + (mismatch "0101" "1010" :key #'evendigitp :test-not 'eq) + nil) + +(deftest mismatch-string.11c + (mismatch "5678" "10101" :key #'evendigitp) + 4) + +(deftest mismatch-string.11d + (mismatch "56122" "1010" :key #'evendigitp) + 4) + +(deftest mismatch-string.11e + (mismatch "0101" '(#\1 #\0 #\1 #\0) :key #'evendigitp :test-not 'eq) + nil) + +(deftest mismatch-string.12 + (mismatch "1010" "1000" :key 'odddigitp) + 2) + +(deftest mismatch-string.12a + (mismatch "1010" "5688" :key 'odddigitp) + 2) + +(deftest mismatch-string.12b + (mismatch '(#\5 #\6 #\8 #\8) "1010" :key 'odddigitp) + 2) + +(deftest mismatch-string.13 + (mismatch "0001" "0001" :test 'eq) + nil) + +(deftest mismatch-string.14 + (mismatch "10001" "01110" :test-not 'eq) + nil) + +(deftest mismatch-string.15 + (mismatch "00100010100" "00110010000") + 3) + +(deftest mismatch-string.16 + (mismatch "00100010100" "00110010000" :from-end t) + 9) + +(deftest mismatch-string.17 + (mismatch "001" "0010010" :from-end t) + 3) + +(deftest mismatch-string.18 + (mismatch "0010010" "001" :from-end t) + 7) + +(deftest mismatch-string.19 + (mismatch "000" "11111011" :from-end t :test-not 'eq) + 1) + +(deftest mismatch-string.20 + (mismatch "1111111" "233" :from-end t :key #'evendigitp) + 5) + +(deftest mismatch-string.20a + (mismatch "1111111" '(#\2 #\3 #\3) :from-end t :key #'evendigitp) + 5) + +(deftest mismatch-string.21 + (mismatch "111" "00000100" :from-end t :test-not #'equal) + 1) + +(deftest mismatch-string.22 + (mismatch "1111111" "233" :from-end t :key 'evendigitp) + 5) diff --git a/ansi-tests/nreverse.lsp b/ansi-tests/nreverse.lsp new file mode 100644 index 0000000000000000000000000000000000000000..89ab94e46fdb5dc483b79c12288924903415ed00 --- /dev/null +++ b/ansi-tests/nreverse.lsp @@ -0,0 +1,82 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Wed Aug 21 00:04:57 2002 +;;;; Contains: Tests for NREVERSE + +(in-package :cl-test) + +(deftest nreverse-list.1 + (nreverse nil) + nil) + +(deftest nreverse-list.2 + (let ((x (copy-seq '(a b c)))) + (nreverse x)) + (c b a)) + +(deftest nreverse-vector.1 + (nreverse #()) + #()) + +(deftest nreverse-vector.2 + (let ((x (copy-seq #(a b c d e)))) + (nreverse x)) + #(e d c b a)) + +(deftest nreverse-nonsimple-vector.1 + (let ((x (make-array 0 :fill-pointer t :adjustable t))) + (nreverse x)) + #()) + +(deftest nreverse-nonsimple-vector.2 + (let* ((x (make-array 5 :initial-contents '(1 2 3 4 5) + :fill-pointer t :adjustable t)) + (y (nreverse x))) + (values y (equal (type-of x) (type-of y)))) + #(5 4 3 2 1) + t) + +(deftest nreverse-bitstring.1 + (nreverse #*) + #*) + +(deftest nreverse-bitstring.2 + (let ((x (copy-seq #*000110110110))) + (nreverse x)) + #*011011011000) + +(deftest nreverse-string.1 + (nreverse "") + "") + +(deftest nreverse-string.2 + (let ((x (copy-seq "000110110110"))) + (nreverse x)) + "011011011000") + +(deftest nreverse-error.1 + (catch-type-error (nreverse 'a)) + type-error) + +(deftest nreverse-error.2 + (catch-type-error (nreverse #\a)) + type-error) + +(deftest nreverse-error.3 + (catch-type-error (nreverse 10)) + type-error) + +(deftest nreverse-error.4 + (catch-type-error (nreverse 0.3)) + type-error) + +(deftest nreverse-error.5 + (catch-type-error (nreverse 10/3)) + type-error) + + + + + + + diff --git a/ansi-tests/nsubstitute-if-not.lsp b/ansi-tests/nsubstitute-if-not.lsp new file mode 100644 index 0000000000000000000000000000000000000000..728595da272dc1b481b2b346785f24989cf2c5fd --- /dev/null +++ b/ansi-tests/nsubstitute-if-not.lsp @@ -0,0 +1,547 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Aug 31 19:00:55 2002 +;;;; Contains: Tests for NSUBSTITUTE-IF-NOT + +(in-package :cl-test) + +(deftest nsubstitute-if-not-list.1 + (nsubstitute-if-not 'b 'identity nil) + nil) + +(deftest nsubstitute-if-not-list.2 + (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x) x) + (b b b c)) + +(deftest nsubstitute-if-not-list.3 + (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count nil)) + (b b b c)) + +(deftest nsubstitute-if-not-list.4 + (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count 2)) + (b b b c)) + +(deftest nsubstitute-if-not-list.5 + (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count 1)) + (b b a c)) + +(deftest nsubstitute-if-not-list.6 + (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count 0)) + (a b a c)) + +(deftest nsubstitute-if-not-list.7 + (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count -1)) + (a b a c)) + +(deftest nsubstitute-if-not-list.8 + (nsubstitute-if-not 'b (is-not-eq-p 'a) nil :from-end t) + nil) + +(deftest nsubstitute-if-not-list.9 + (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :from-end t)) + (b b b c)) + +(deftest nsubstitute-if-not-list.10 + (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :from-end t :count nil)) + (b b b c)) + +(deftest nsubstitute-if-not-list.11 + (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count 2 :from-end t)) + (b b b c)) + +(deftest nsubstitute-if-not-list.12 + (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count 1 :from-end t)) + (a b b c)) + +(deftest nsubstitute-if-not-list.13 + (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count 0 :from-end t)) + (a b a c)) + +(deftest nsubstitute-if-not-list.14 + (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count -1 :from-end t)) + (a b a c)) + +(deftest nsubstitute-if-not-list.15 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute-if-not 'x (is-not-eq-p 'a) x :start i :end j))) + (equal y (nconc (make-list i :initial-element 'a) + (make-list (- j i) :initial-element 'x) + (make-list (- 10 j) :initial-element 'a)))))) + t) + +(deftest nsubstitute-if-not-list.16 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute-if-not 'x (is-not-eq-p 'a) x :start i :end j :from-end t))) + (equal y (nconc (make-list i :initial-element 'a) + (make-list (- j i) :initial-element 'x) + (make-list (- 10 j) :initial-element 'a)))))) + t) + +(deftest nsubstitute-if-not-list.17 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute-if-not 'x (is-not-eq-p 'a) x :start i :end j :count c))) + (equal y (nconc (make-list i :initial-element 'a) + (make-list c :initial-element 'x) + (make-list (- 10 (+ i c)) :initial-element 'a))))))) + t) + +(deftest nsubstitute-if-not-list.18 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute-if-not 'x (is-not-eq-p 'a) x :start i :end j :count c :from-end t))) + (equal y (nconc (make-list (- j c) :initial-element 'a) + (make-list c :initial-element 'x) + (make-list (- 10 j) :initial-element 'a))))))) + t) + +;;; Tests on vectors + +(deftest nsubstitute-if-not-vector.1 + (let ((x #())) (nsubstitute-if-not 'b (is-not-eq-p 'a) x)) + #()) + +(deftest nsubstitute-if-not-vector.2 + (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x)) + #(b b b c)) + +(deftest nsubstitute-if-not-vector.3 + (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count nil) x) + #(b b b c)) + +(deftest nsubstitute-if-not-vector.4 + (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count 2)) + #(b b b c)) + +(deftest nsubstitute-if-not-vector.5 + (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count 1)) + #(b b a c)) + +(deftest nsubstitute-if-not-vector.6 + (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count 0)) + #(a b a c)) + +(deftest nsubstitute-if-not-vector.7 + (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count -1)) + #(a b a c)) + +(deftest nsubstitute-if-not-vector.8 + (let ((x #())) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :from-end t)) + #()) + +(deftest nsubstitute-if-not-vector.9 + (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :from-end t)) + #(b b b c)) + +(deftest nsubstitute-if-not-vector.10 + (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :from-end t :count nil)) + #(b b b c)) + +(deftest nsubstitute-if-not-vector.11 + (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count 2 :from-end t)) + #(b b b c)) + +(deftest nsubstitute-if-not-vector.12 + (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count 1 :from-end t)) + #(a b b c)) + +(deftest nsubstitute-if-not-vector.13 + (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count 0 :from-end t)) + #(a b a c)) + +(deftest nsubstitute-if-not-vector.14 + (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count -1 :from-end t)) + #(a b a c)) + +(deftest nsubstitute-if-not-vector.15 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute-if-not 'x (is-not-eq-p 'a) x :start i :end j))) + (equalp y (concatenate 'simple-vector + (make-array i :initial-element 'a) + (make-array (- j i) :initial-element 'x) + (make-array (- 10 j) :initial-element 'a)))))) + t) + +(deftest nsubstitute-if-not-vector.16 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute-if-not 'x (is-not-eq-p 'a) x :start i :end j :from-end t))) + (equalp y (concatenate 'simple-vector + (make-array i :initial-element 'a) + (make-array (- j i) :initial-element 'x) + (make-array (- 10 j) :initial-element 'a)))))) + t) + +(deftest nsubstitute-if-not-vector.17 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute-if-not 'x (is-not-eq-p 'a) x :start i :end j :count c))) + (equalp y (concatenate 'simple-vector + (make-array i :initial-element 'a) + (make-array c :initial-element 'x) + (make-array (- 10 (+ i c)) :initial-element 'a))))))) + t) + +(deftest nsubstitute-if-not-vector.18 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute-if-not 'x (is-not-eq-p 'a) x :start i :end j :count c :from-end t))) + (equalp y (concatenate 'simple-vector + (make-array (- j c) :initial-element 'a) + (make-array c :initial-element 'x) + (make-array (- 10 j) :initial-element 'a))))))) + t) + +;;; Tests on strings + +(deftest nsubstitute-if-not-string.1 + (let ((x "")) (nsubstitute-if-not #\b (is-not-eq-p #\a) x)) + "") + +(deftest nsubstitute-if-not-string.2 + (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eq-p #\a) x)) + "bbbc") + +(deftest nsubstitute-if-not-string.3 + (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eq-p #\a) x :count nil)) + "bbbc") + +(deftest nsubstitute-if-not-string.4 + (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eq-p #\a) x :count 2)) + "bbbc") + +(deftest nsubstitute-if-not-string.5 + (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eq-p #\a) x :count 1)) + "bbac") + +(deftest nsubstitute-if-not-string.6 + (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eq-p #\a) x :count 0)) + "abac") + +(deftest nsubstitute-if-not-string.7 + (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eq-p #\a) x :count -1)) + "abac") + +(deftest nsubstitute-if-not-string.8 + (let ((x "")) (nsubstitute-if-not #\b (is-not-eq-p #\a) x :from-end t)) + "") + +(deftest nsubstitute-if-not-string.9 + (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eq-p #\a) x :from-end t)) + "bbbc") + +(deftest nsubstitute-if-not-string.10 + (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eq-p #\a) x :from-end t :count nil)) + "bbbc") + +(deftest nsubstitute-if-not-string.11 + (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eq-p #\a) x :count 2 :from-end t)) + "bbbc") + +(deftest nsubstitute-if-not-string.12 + (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eq-p #\a) x :count 1 :from-end t)) + "abbc") + +(deftest nsubstitute-if-not-string.13 + (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eq-p #\a) x :count 0 :from-end t)) + "abac") + +(deftest nsubstitute-if-not-string.14 + (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eq-p #\a) x :count -1 :from-end t)) + "abac") + +(deftest nsubstitute-if-not-string.15 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (nsubstitute-if-not #\x (is-not-eq-p #\a) x :start i :end j))) + (equalp y (concatenate 'simple-string + (make-array i :initial-element #\a) + (make-array (- j i) :initial-element #\x) + (make-array (- 10 j) :initial-element #\a)))))) + t) + +(deftest nsubstitute-if-not-string.16 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (nsubstitute-if-not #\x (is-not-eq-p #\a) x :start i :end j :from-end t))) + (equalp y (concatenate 'simple-string + (make-array i :initial-element #\a) + (make-array (- j i) :initial-element #\x) + (make-array (- 10 j) :initial-element #\a)))))) + t) + +(deftest nsubstitute-if-not-string.17 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (nsubstitute-if-not #\x (is-not-eq-p #\a) x :start i :end j :count c))) + (equalp y (concatenate 'simple-string + (make-array i :initial-element #\a) + (make-array c :initial-element #\x) + (make-array (- 10 (+ i c)) :initial-element #\a))))))) + t) + +(deftest nsubstitute-if-not-string.18 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (nsubstitute-if-not #\x (is-not-eq-p #\a) x :start i :end j :count c :from-end t))) + (equalp y (concatenate 'simple-string + (make-array (- j c) :initial-element #\a) + (make-array c :initial-element #\x) + (make-array (- 10 j) :initial-element #\a))))))) + t) + +;;; Tests on bitstrings + +(deftest nsubstitute-if-not-bitstring.1 + (let* ((orig #*) + (x (copy-seq orig)) + (result (nsubstitute-if-not 0 (is-not-eq-p 1) x))) + result) + #*) + +(deftest nsubstitute-if-not-bitstring.2 + (let* ((orig #*) + (x (copy-seq orig)) + (result (nsubstitute-if-not 1 (is-not-eq-p 0) x))) + result) + #*) + +(deftest nsubstitute-if-not-bitstring.3 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if-not 0 (is-not-eq-p 1) x))) + result) + #*000000) + +(deftest nsubstitute-if-not-bitstring.4 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if-not 1 (is-not-eq-p 0) x))) + result) + #*111111) + +(deftest nsubstitute-if-not-bitstring.5 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if-not 1 (is-not-eq-p 0) x :start 1))) + result) + #*011111) + +(deftest nsubstitute-if-not-bitstring.6 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if-not 0 (is-not-eq-p 1) x :start 2 :end nil))) + result) + #*010000) + +(deftest nsubstitute-if-not-bitstring.7 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if-not 1 (is-not-eq-p 0) x :end 4))) + result) + #*111101) + +(deftest nsubstitute-if-not-bitstring.8 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if-not 0 (is-not-eq-p 1) x :end nil))) + result) + #*000000) + +(deftest nsubstitute-if-not-bitstring.9 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if-not 0 (is-not-eq-p 1) x :end 3))) + result) + #*000101) + +(deftest nsubstitute-if-not-bitstring.10 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if-not 0 (is-not-eq-p 1) x :start 2 :end 4))) + result) + #*010001) + +(deftest nsubstitute-if-not-bitstring.11 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if-not 1 (is-not-eq-p 0) x :start 2 :end 4))) + result) + #*011101) + +(deftest nsubstitute-if-not-bitstring.12 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if-not 1 (is-not-eq-p 0) x :count 1))) + result) + #*110101) + +(deftest nsubstitute-if-not-bitstring.13 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if-not 1 (is-not-eq-p 0) x :count 0))) + result) + #*010101) + +(deftest nsubstitute-if-not-bitstring.14 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if-not 1 (is-not-eq-p 0) x :count -1))) + result) + #*010101) + +(deftest nsubstitute-if-not-bitstring.15 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if-not 1 (is-not-eq-p 0) x :count 1 :from-end t))) + result) + #*010111) + +(deftest nsubstitute-if-not-bitstring.16 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if-not 1 (is-not-eq-p 0) x :count 0 :from-end t))) + result) + #*010101) + +(deftest nsubstitute-if-not-bitstring.17 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if-not 1 (is-not-eq-p 0) x :count -1 :from-end t))) + result) + #*010101) + +(deftest nsubstitute-if-not-bitstring.18 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if-not 1 (is-not-eq-p 0) x :count nil))) + result) + #*111111) + +(deftest nsubstitute-if-not-bitstring.19 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if-not 1 (is-not-eq-p 0) x :count nil :from-end t))) + result) + #*111111) + +(deftest nsubstitute-if-not-bitstring.20 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #*0000000000) + (x (copy-seq orig)) + (y (nsubstitute-if-not 1 (is-not-eq-p 0) x :start i :end j :count c))) + (equalp y (concatenate + 'simple-bit-vector + (make-list i :initial-element 0) + (make-list c :initial-element 1) + (make-list (- 10 (+ i c)) :initial-element 0))))))) + t) + +(deftest nsubstitute-if-not-bitstring.21 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #*1111111111) + (x (copy-seq orig)) + (y (nsubstitute-if-not 0 (is-not-eq-p 1) x :start i :end j :count c :from-end t))) + (equalp y (concatenate + 'simple-bit-vector + (make-list (- j c) :initial-element 1) + (make-list c :initial-element 0) + (make-list (- 10 j) :initial-element 1))))))) + t) + + +;;; More tests + +(deftest nsubstitute-if-not-list.24 + (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (nsubstitute-if-not '(a 10) (is-not-eq-p 'a) x :key #'car))) + result) + ((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) + +(deftest nsubstitute-if-not-list.25 + (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (nsubstitute-if-not '(a 10) (is-not-eq-p 'a) x + :key #'car :start 1 :end 5))) + result) + ((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) + +(deftest nsubstitute-if-not-vector.24 + (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (nsubstitute-if-not '(a 10) (is-not-eq-p 'a) x :key #'car))) + result) + #((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) + +(deftest nsubstitute-if-not-vector.25 + (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (nsubstitute-if-not '(a 10) (is-not-eq-p 'a) x :key #'car :start 1 :end 5))) + result) + #((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) + +(deftest nsubstitute-if-not-string.24 + (let* ((orig "0102342015") + (x (copy-seq orig)) + (result (nsubstitute-if-not #\a (is-not-eq-p #\1) x :key #'nextdigit))) + result) + "a1a2342a15") + +(deftest nsubstitute-if-not-string.25 + (let* ((orig "0102342015") + (x (copy-seq orig)) + (result (nsubstitute-if-not #\a (is-not-eq-p #\1) x :key #'nextdigit :start 1 :end 6))) + result) + "01a2342015") + +(deftest nsubstitute-if-not-bitstring.26 + (let* ((orig #*00111001011010110) + (x (copy-seq orig)) + (result (nsubstitute-if-not 1 (is-not-eq-p 1) x :key #'1+))) + result) + #*11111111111111111) + +(deftest nsubstitute-if-not-bitstring.27 + (let* ((orig #*00111001011010110) + (x (copy-seq orig)) + (result (nsubstitute-if-not 1 (is-not-eq-p 1) x :key #'1+ :start 1 :end 10))) + result) + #*01111111111010110) \ No newline at end of file diff --git a/ansi-tests/nsubstitute-if.lsp b/ansi-tests/nsubstitute-if.lsp new file mode 100644 index 0000000000000000000000000000000000000000..8f6debb68e369a872f5370378d1d02f3365112a2 --- /dev/null +++ b/ansi-tests/nsubstitute-if.lsp @@ -0,0 +1,546 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Aug 31 18:56:41 2002 +;;;; Contains: Tests for NSUBSTITUTE-IF + +(in-package :cl-test) + +(deftest nsubstitute-if-list.1 + (nsubstitute-if 'b 'identity nil) + nil) + +(deftest nsubstitute-if-list.2 + (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x) x) + (b b b c)) + +(deftest nsubstitute-if-list.3 + (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count nil)) + (b b b c)) + +(deftest nsubstitute-if-list.4 + (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count 2)) + (b b b c)) + +(deftest nsubstitute-if-list.5 + (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count 1)) + (b b a c)) + +(deftest nsubstitute-if-list.6 + (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count 0)) + (a b a c)) + +(deftest nsubstitute-if-list.7 + (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count -1)) + (a b a c)) + +(deftest nsubstitute-if-list.8 + (nsubstitute-if 'b (is-eq-p 'a) nil :from-end t) + nil) + +(deftest nsubstitute-if-list.9 + (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :from-end t)) + (b b b c)) + +(deftest nsubstitute-if-list.10 + (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :from-end t :count nil)) + (b b b c)) + +(deftest nsubstitute-if-list.11 + (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count 2 :from-end t)) + (b b b c)) + +(deftest nsubstitute-if-list.12 + (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count 1 :from-end t)) + (a b b c)) + +(deftest nsubstitute-if-list.13 + (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count 0 :from-end t)) + (a b a c)) + +(deftest nsubstitute-if-list.14 + (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count -1 :from-end t)) + (a b a c)) + +(deftest nsubstitute-if-list.15 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute-if 'x (is-eq-p 'a) x :start i :end j))) + (equal y (nconc (make-list i :initial-element 'a) + (make-list (- j i) :initial-element 'x) + (make-list (- 10 j) :initial-element 'a)))))) + t) + +(deftest nsubstitute-if-list.16 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute-if 'x (is-eq-p 'a) x :start i :end j :from-end t))) + (equal y (nconc (make-list i :initial-element 'a) + (make-list (- j i) :initial-element 'x) + (make-list (- 10 j) :initial-element 'a)))))) + t) + +(deftest nsubstitute-if-list.17 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute-if 'x (is-eq-p 'a) x :start i :end j :count c))) + (equal y (nconc (make-list i :initial-element 'a) + (make-list c :initial-element 'x) + (make-list (- 10 (+ i c)) :initial-element 'a))))))) + t) + +(deftest nsubstitute-if-list.18 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute-if 'x (is-eq-p 'a) x :start i :end j :count c :from-end t))) + (equal y (nconc (make-list (- j c) :initial-element 'a) + (make-list c :initial-element 'x) + (make-list (- 10 j) :initial-element 'a))))))) + t) + +;;; Tests on vectors + +(deftest nsubstitute-if-vector.1 + (let ((x #())) (nsubstitute-if 'b (is-eq-p 'a) x)) + #()) + +(deftest nsubstitute-if-vector.2 + (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x)) + #(b b b c)) + +(deftest nsubstitute-if-vector.3 + (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count nil) x) + #(b b b c)) + +(deftest nsubstitute-if-vector.4 + (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count 2)) + #(b b b c)) + +(deftest nsubstitute-if-vector.5 + (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count 1)) + #(b b a c)) + +(deftest nsubstitute-if-vector.6 + (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count 0)) + #(a b a c)) + +(deftest nsubstitute-if-vector.7 + (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count -1)) + #(a b a c)) + +(deftest nsubstitute-if-vector.8 + (let ((x #())) (nsubstitute-if 'b (is-eq-p 'a) x :from-end t)) + #()) + +(deftest nsubstitute-if-vector.9 + (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :from-end t)) + #(b b b c)) + +(deftest nsubstitute-if-vector.10 + (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :from-end t :count nil)) + #(b b b c)) + +(deftest nsubstitute-if-vector.11 + (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count 2 :from-end t)) + #(b b b c)) + +(deftest nsubstitute-if-vector.12 + (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count 1 :from-end t)) + #(a b b c)) + +(deftest nsubstitute-if-vector.13 + (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count 0 :from-end t)) + #(a b a c)) + +(deftest nsubstitute-if-vector.14 + (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count -1 :from-end t)) + #(a b a c)) + +(deftest nsubstitute-if-vector.15 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute-if 'x (is-eq-p 'a) x :start i :end j))) + (equalp y (concatenate 'simple-vector + (make-array i :initial-element 'a) + (make-array (- j i) :initial-element 'x) + (make-array (- 10 j) :initial-element 'a)))))) + t) + +(deftest nsubstitute-if-vector.16 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute-if 'x (is-eq-p 'a) x :start i :end j :from-end t))) + (equalp y (concatenate 'simple-vector + (make-array i :initial-element 'a) + (make-array (- j i) :initial-element 'x) + (make-array (- 10 j) :initial-element 'a)))))) + t) + +(deftest nsubstitute-if-vector.17 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute-if 'x (is-eq-p 'a) x :start i :end j :count c))) + (equalp y (concatenate 'simple-vector + (make-array i :initial-element 'a) + (make-array c :initial-element 'x) + (make-array (- 10 (+ i c)) :initial-element 'a))))))) + t) + +(deftest nsubstitute-if-vector.18 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute-if 'x (is-eq-p 'a) x :start i :end j :count c :from-end t))) + (equalp y (concatenate 'simple-vector + (make-array (- j c) :initial-element 'a) + (make-array c :initial-element 'x) + (make-array (- 10 j) :initial-element 'a))))))) + t) + +;;; Tests on strings + +(deftest nsubstitute-if-string.1 + (let ((x "")) (nsubstitute-if #\b (is-eq-p #\a) x)) + "") + +(deftest nsubstitute-if-string.2 + (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eq-p #\a) x)) + "bbbc") + +(deftest nsubstitute-if-string.3 + (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eq-p #\a) x :count nil)) + "bbbc") + +(deftest nsubstitute-if-string.4 + (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eq-p #\a) x :count 2)) + "bbbc") + +(deftest nsubstitute-if-string.5 + (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eq-p #\a) x :count 1)) + "bbac") + +(deftest nsubstitute-if-string.6 + (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eq-p #\a) x :count 0)) + "abac") + +(deftest nsubstitute-if-string.7 + (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eq-p #\a) x :count -1)) + "abac") + +(deftest nsubstitute-if-string.8 + (let ((x "")) (nsubstitute-if #\b (is-eq-p #\a) x :from-end t)) + "") + +(deftest nsubstitute-if-string.9 + (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eq-p #\a) x :from-end t)) + "bbbc") + +(deftest nsubstitute-if-string.10 + (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eq-p #\a) x :from-end t :count nil)) + "bbbc") + +(deftest nsubstitute-if-string.11 + (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eq-p #\a) x :count 2 :from-end t)) + "bbbc") + +(deftest nsubstitute-if-string.12 + (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eq-p #\a) x :count 1 :from-end t)) + "abbc") + +(deftest nsubstitute-if-string.13 + (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eq-p #\a) x :count 0 :from-end t)) + "abac") + +(deftest nsubstitute-if-string.14 + (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eq-p #\a) x :count -1 :from-end t)) + "abac") + +(deftest nsubstitute-if-string.15 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (nsubstitute-if #\x (is-eq-p #\a) x :start i :end j))) + (equalp y (concatenate 'simple-string + (make-array i :initial-element #\a) + (make-array (- j i) :initial-element #\x) + (make-array (- 10 j) :initial-element #\a)))))) + t) + +(deftest nsubstitute-if-string.16 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (nsubstitute-if #\x (is-eq-p #\a) x :start i :end j :from-end t))) + (equalp y (concatenate 'simple-string + (make-array i :initial-element #\a) + (make-array (- j i) :initial-element #\x) + (make-array (- 10 j) :initial-element #\a)))))) + t) + +(deftest nsubstitute-if-string.17 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (nsubstitute-if #\x (is-eq-p #\a) x :start i :end j :count c))) + (equalp y (concatenate 'simple-string + (make-array i :initial-element #\a) + (make-array c :initial-element #\x) + (make-array (- 10 (+ i c)) :initial-element #\a))))))) + t) + +(deftest nsubstitute-if-string.18 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (nsubstitute-if #\x (is-eq-p #\a) x :start i :end j :count c :from-end t))) + (equalp y (concatenate 'simple-string + (make-array (- j c) :initial-element #\a) + (make-array c :initial-element #\x) + (make-array (- 10 j) :initial-element #\a))))))) + t) + +;;; Tests on bitstrings + +(deftest nsubstitute-if-bitstring.1 + (let* ((orig #*) + (x (copy-seq orig)) + (result (nsubstitute-if 0 (is-eq-p 1) x))) + result) + #*) + +(deftest nsubstitute-if-bitstring.2 + (let* ((orig #*) + (x (copy-seq orig)) + (result (nsubstitute-if 1 (is-eq-p 0) x))) + result) + #*) + +(deftest nsubstitute-if-bitstring.3 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if 0 (is-eq-p 1) x))) + result) + #*000000) + +(deftest nsubstitute-if-bitstring.4 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if 1 (is-eq-p 0) x))) + result) + #*111111) + +(deftest nsubstitute-if-bitstring.5 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if 1 (is-eq-p 0) x :start 1))) + result) + #*011111) + +(deftest nsubstitute-if-bitstring.6 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if 0 (is-eq-p 1) x :start 2 :end nil))) + result) + #*010000) + +(deftest nsubstitute-if-bitstring.7 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if 1 (is-eq-p 0) x :end 4))) + result) + #*111101) + +(deftest nsubstitute-if-bitstring.8 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if 0 (is-eq-p 1) x :end nil))) + result) + #*000000) + +(deftest nsubstitute-if-bitstring.9 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if 0 (is-eq-p 1) x :end 3))) + result) + #*000101) + +(deftest nsubstitute-if-bitstring.10 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if 0 (is-eq-p 1) x :start 2 :end 4))) + result) + #*010001) + +(deftest nsubstitute-if-bitstring.11 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if 1 (is-eq-p 0) x :start 2 :end 4))) + result) + #*011101) + +(deftest nsubstitute-if-bitstring.12 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if 1 (is-eq-p 0) x :count 1))) + result) + #*110101) + +(deftest nsubstitute-if-bitstring.13 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if 1 (is-eq-p 0) x :count 0))) + result) + #*010101) + +(deftest nsubstitute-if-bitstring.14 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if 1 (is-eq-p 0) x :count -1))) + result) + #*010101) + +(deftest nsubstitute-if-bitstring.15 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if 1 (is-eq-p 0) x :count 1 :from-end t))) + result) + #*010111) + +(deftest nsubstitute-if-bitstring.16 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if 1 (is-eq-p 0) x :count 0 :from-end t))) + result) + #*010101) + +(deftest nsubstitute-if-bitstring.17 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if 1 (is-eq-p 0) x :count -1 :from-end t))) + result) + #*010101) + +(deftest nsubstitute-if-bitstring.18 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if 1 (is-eq-p 0) x :count nil))) + result) + #*111111) + +(deftest nsubstitute-if-bitstring.19 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if 1 (is-eq-p 0) x :count nil :from-end t))) + result) + #*111111) + +(deftest nsubstitute-if-bitstring.20 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #*0000000000) + (x (copy-seq orig)) + (y (nsubstitute-if 1 (is-eq-p 0) x :start i :end j :count c))) + (equalp y (concatenate + 'simple-bit-vector + (make-list i :initial-element 0) + (make-list c :initial-element 1) + (make-list (- 10 (+ i c)) :initial-element 0))))))) + t) + +(deftest nsubstitute-if-bitstring.21 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #*1111111111) + (x (copy-seq orig)) + (y (nsubstitute-if 0 (is-eq-p 1) x :start i :end j :count c :from-end t))) + (equalp y (concatenate + 'simple-bit-vector + (make-list (- j c) :initial-element 1) + (make-list c :initial-element 0) + (make-list (- 10 j) :initial-element 1))))))) + t) + +;;; More tests + +(deftest nsubstitute-if-list.24 + (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (nsubstitute-if '(a 10) (is-eq-p 'a) x :key #'car))) + result) + ((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) + +(deftest nsubstitute-if-list.25 + (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (nsubstitute-if '(a 10) (is-eq-p 'a) x + :key #'car :start 1 :end 5))) + result) + ((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) + +(deftest nsubstitute-if-vector.24 + (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (nsubstitute-if '(a 10) (is-eq-p 'a) x :key #'car))) + result) + #((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) + +(deftest nsubstitute-if-vector.25 + (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (nsubstitute-if '(a 10) (is-eq-p 'a) x :key #'car :start 1 :end 5))) + result) + #((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) + +(deftest nsubstitute-if-string.24 + (let* ((orig "0102342015") + (x (copy-seq orig)) + (result (nsubstitute-if #\a (is-eq-p #\1) x :key #'nextdigit))) + result) + "a1a2342a15") + +(deftest nsubstitute-if-string.25 + (let* ((orig "0102342015") + (x (copy-seq orig)) + (result (nsubstitute-if #\a (is-eq-p #\1) x :key #'nextdigit :start 1 :end 6))) + result) + "01a2342015") + +(deftest nsubstitute-if-bitstring.26 + (let* ((orig #*00111001011010110) + (x (copy-seq orig)) + (result (nsubstitute-if 1 (is-eq-p 1) x :key #'1+))) + result) + #*11111111111111111) + +(deftest nsubstitute-if-bitstring.27 + (let* ((orig #*00111001011010110) + (x (copy-seq orig)) + (result (nsubstitute-if 1 (is-eq-p 1) x :key #'1+ :start 1 :end 10))) + result) + #*01111111111010110) diff --git a/ansi-tests/nsubstitute.lsp b/ansi-tests/nsubstitute.lsp new file mode 100644 index 0000000000000000000000000000000000000000..28959c74e26072f6c07edc0b11aa6ea744dbed60 --- /dev/null +++ b/ansi-tests/nsubstitute.lsp @@ -0,0 +1,752 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Aug 31 16:56:48 2002 +;;;; Contains: Tests for NSUBSTITUTE + +(in-package :cl-test) + +(deftest nsubstitute-list.1 + (nsubstitute 'b 'a nil) + nil) + +(deftest nsubstitute-list.2 + (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x) x) + (b b b c)) + +(deftest nsubstitute-list.3 + (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x :count nil)) + (b b b c)) + +(deftest nsubstitute-list.4 + (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x :count 2)) + (b b b c)) + +(deftest nsubstitute-list.5 + (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x :count 1)) + (b b a c)) + +(deftest nsubstitute-list.6 + (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x :count 0)) + (a b a c)) + +(deftest nsubstitute-list.7 + (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x :count -1)) + (a b a c)) + +(deftest nsubstitute-list.8 + (nsubstitute 'b 'a nil :from-end t) + nil) + +(deftest nsubstitute-list.9 + (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x :from-end t)) + (b b b c)) + +(deftest nsubstitute-list.10 + (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x :from-end t :count nil)) + (b b b c)) + +(deftest nsubstitute-list.11 + (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x :count 2 :from-end t)) + (b b b c)) + +(deftest nsubstitute-list.12 + (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x :count 1 :from-end t)) + (a b b c)) + +(deftest nsubstitute-list.13 + (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x :count 0 :from-end t)) + (a b a c)) + +(deftest nsubstitute-list.14 + (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x :count -1 :from-end t)) + (a b a c)) + +(deftest nsubstitute-list.15 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute 'x 'a x :start i :end j))) + (equal y (nconc (make-list i :initial-element 'a) + (make-list (- j i) :initial-element 'x) + (make-list (- 10 j) :initial-element 'a)))))) + t) + +(deftest nsubstitute-list.16 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute 'x 'a x :start i :end j :from-end t))) + (equal y (nconc (make-list i :initial-element 'a) + (make-list (- j i) :initial-element 'x) + (make-list (- 10 j) :initial-element 'a)))))) + t) + +(deftest nsubstitute-list.17 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute 'x 'a x :start i :end j :count c))) + (equal y (nconc (make-list i :initial-element 'a) + (make-list c :initial-element 'x) + (make-list (- 10 (+ i c)) :initial-element 'a))))))) + t) + +(deftest nsubstitute-list.18 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute 'x 'a x :start i :end j :count c :from-end t))) + (equal y (nconc (make-list (- j c) :initial-element 'a) + (make-list c :initial-element 'x) + (make-list (- 10 j) :initial-element 'a))))))) + t) + +(deftest nsubstitute-list.19 + (let* ((orig '(1 2 3 4 5 6 7 8 9)) + (x (copy-seq orig)) + (result (nsubstitute 'x 5 x :test #'(lambda (a b) (<= (abs (- a b)) 2))))) + result) + (1 2 x x x x x 8 9)) + +(deftest nsubstitute-list.20 + (let* ((orig '(1 2 3 4 5 6 7 8 9)) + (x (copy-seq orig)) + (c -4) + (result (nsubstitute 'x 5 x :test #'(lambda (a b) (incf c 2) (= (+ b c) a))))) + result) + (1 2 x 4 5 6 7 8 9)) + + +(deftest nsubstitute-list.21 + (let* ((orig '(1 2 3 4 5 6 7 8 9)) + (x (copy-seq orig)) + (c 5) + (result (nsubstitute 'x 9 x :test #'(lambda (a b) (incf c -2) (= (+ b c) a)) + :from-end t))) + result) + (1 2 3 4 5 6 7 x 9)) + +(deftest nsubstitute-list.22 + (let* ((orig '(1 2 3 4 5 6 7 8 9)) + (x (copy-seq orig)) + (c -4) + (result (nsubstitute 'x 5 x :test-not #'(lambda (a b) (incf c 2) (/= (+ b c) a))))) + result) + (1 2 x 4 5 6 7 8 9)) + + +(deftest nsubstitute-list.23 + (let* ((orig '(1 2 3 4 5 6 7 8 9)) + (x (copy-seq orig)) + (c 5) + (result (nsubstitute 'x 9 x :test-not #'(lambda (a b) (incf c -2) (/= (+ b c) a)) + :from-end t))) + result) + (1 2 3 4 5 6 7 x 9)) + +;;; Tests on vectors + +(deftest nsubstitute-vector.1 + (let ((x #())) (values (nsubstitute 'b 'a x) x)) + #() #()) + +(deftest nsubstitute-vector.2 + (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x)) + #(b b b c)) + +(deftest nsubstitute-vector.3 + (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x :count nil) x) + #(b b b c)) + +(deftest nsubstitute-vector.4 + (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x :count 2)) + #(b b b c)) + +(deftest nsubstitute-vector.5 + (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x :count 1)) + #(b b a c)) + +(deftest nsubstitute-vector.6 + (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x :count 0)) + #(a b a c)) + +(deftest nsubstitute-vector.7 + (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x :count -1)) + #(a b a c)) + +(deftest nsubstitute-vector.8 + (let ((x #())) (nsubstitute 'b 'a x :from-end t)) + #()) + +(deftest nsubstitute-vector.9 + (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x :from-end t)) + #(b b b c)) + +(deftest nsubstitute-vector.10 + (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x :from-end t :count nil)) + #(b b b c)) + +(deftest nsubstitute-vector.11 + (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x :count 2 :from-end t)) + #(b b b c)) + +(deftest nsubstitute-vector.12 + (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x :count 1 :from-end t)) + #(a b b c)) + +(deftest nsubstitute-vector.13 + (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x :count 0 :from-end t)) + #(a b a c)) + +(deftest nsubstitute-vector.14 + (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x :count -1 :from-end t)) + #(a b a c)) + +(deftest nsubstitute-vector.15 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute 'x 'a x :start i :end j))) + (equalp y (concatenate 'simple-vector + (make-array i :initial-element 'a) + (make-array (- j i) :initial-element 'x) + (make-array (- 10 j) :initial-element 'a)))))) + t) + +(deftest nsubstitute-vector.16 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute 'x 'a x :start i :end j :from-end t))) + (equalp y (concatenate 'simple-vector + (make-array i :initial-element 'a) + (make-array (- j i) :initial-element 'x) + (make-array (- 10 j) :initial-element 'a)))))) + t) + +(deftest nsubstitute-vector.17 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute 'x 'a x :start i :end j :count c))) + (equalp y (concatenate 'simple-vector + (make-array i :initial-element 'a) + (make-array c :initial-element 'x) + (make-array (- 10 (+ i c)) :initial-element 'a))))))) + t) + +(deftest nsubstitute-vector.18 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute 'x 'a x :start i :end j :count c :from-end t))) + (equalp y (concatenate 'simple-vector + (make-array (- j c) :initial-element 'a) + (make-array c :initial-element 'x) + (make-array (- 10 j) :initial-element 'a))))))) + t) + +(deftest nsubstitute-vector.19 + (let* ((orig #(1 2 3 4 5 6 7 8 9)) + (x (copy-seq orig)) + (result (nsubstitute 'x 5 x :test #'(lambda (a b) (<= (abs (- a b)) 2))))) + result) + #(1 2 x x x x x 8 9)) + +(deftest nsubstitute-vector.20 + (let* ((orig #(1 2 3 4 5 6 7 8 9)) + (x (copy-seq orig)) + (c -4) + (result (nsubstitute 'x 5 x :test #'(lambda (a b) (incf c 2) (= (+ b c) a))))) + result) + #(1 2 x 4 5 6 7 8 9)) + + +(deftest nsubstitute-vector.21 + (let* ((orig #(1 2 3 4 5 6 7 8 9)) + (x (copy-seq orig)) + (c 5) + (result (nsubstitute 'x 9 x :test #'(lambda (a b) (incf c -2) (= (+ b c) a)) + :from-end t))) + result) + #(1 2 3 4 5 6 7 x 9)) + +(deftest nsubstitute-vector.22 + (let* ((orig #(1 2 3 4 5 6 7 8 9)) + (x (copy-seq orig)) + (c -4) + (result (nsubstitute 'x 5 x :test-not #'(lambda (a b) (incf c 2) (/= (+ b c) a))))) + result) + #(1 2 x 4 5 6 7 8 9)) + +(deftest nsubstitute-vector.23 + (let* ((orig #(1 2 3 4 5 6 7 8 9)) + (x (copy-seq orig)) + (c 5) + (result (nsubstitute 'x 9 x :test-not #'(lambda (a b) (incf c -2) (/= (+ b c) a)) + :from-end t))) + result) + #(1 2 3 4 5 6 7 x 9)) + +;;; Tests on strings + +(deftest nsubstitute-string.1 + (let ((x "")) (nsubstitute #\b #\a x)) + "") + +(deftest nsubstitute-string.2 + (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x)) + "bbbc") + +(deftest nsubstitute-string.3 + (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x :count nil)) + "bbbc") + +(deftest nsubstitute-string.4 + (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x :count 2)) + "bbbc") + +(deftest nsubstitute-string.5 + (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x :count 1)) + "bbac") + +(deftest nsubstitute-string.6 + (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x :count 0)) + "abac") + +(deftest nsubstitute-string.7 + (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x :count -1)) + "abac") + +(deftest nsubstitute-string.8 + (let ((x "")) (nsubstitute #\b #\a x :from-end t)) + "") + +(deftest nsubstitute-string.9 + (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x :from-end t)) + "bbbc") + +(deftest nsubstitute-string.10 + (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x :from-end t :count nil)) + "bbbc") + +(deftest nsubstitute-string.11 + (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x :count 2 :from-end t)) + "bbbc") + +(deftest nsubstitute-string.12 + (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x :count 1 :from-end t)) + "abbc") + +(deftest nsubstitute-string.13 + (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x :count 0 :from-end t)) + "abac") + +(deftest nsubstitute-string.14 + (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x :count -1 :from-end t)) + "abac") + +(deftest nsubstitute-string.15 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (nsubstitute #\x #\a x :start i :end j))) + (equalp y (concatenate 'simple-string + (make-array i :initial-element #\a) + (make-array (- j i) :initial-element #\x) + (make-array (- 10 j) :initial-element #\a)))))) + t) + +(deftest nsubstitute-string.16 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (nsubstitute #\x #\a x :start i :end j :from-end t))) + (equalp y (concatenate 'simple-string + (make-array i :initial-element #\a) + (make-array (- j i) :initial-element #\x) + (make-array (- 10 j) :initial-element #\a)))))) + t) + +(deftest nsubstitute-string.17 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (nsubstitute #\x #\a x :start i :end j :count c))) + (equalp y (concatenate 'simple-string + (make-array i :initial-element #\a) + (make-array c :initial-element #\x) + (make-array (- 10 (+ i c)) :initial-element #\a))))))) + t) + +(deftest nsubstitute-string.18 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (nsubstitute #\x #\a x :start i :end j :count c :from-end t))) + (equalp y (concatenate 'simple-string + (make-array (- j c) :initial-element #\a) + (make-array c :initial-element #\x) + (make-array (- 10 j) :initial-element #\a))))))) + t) + +(deftest nsubstitute-string.19 + (let* ((orig "123456789") + (x (copy-seq orig)) + (result (nsubstitute #\x #\5 x :test #'(lambda (a b) + (setq a (read-from-string (string a))) + (setq b (read-from-string (string b))) + (<= (abs (- a b)) 2))))) + result) + "12xxxxx89") + +(deftest nsubstitute-string.20 + (let* ((orig "123456789") + (x (copy-seq orig)) + (c -4) + (result (nsubstitute #\x #\5 x :test #'(lambda (a b) + (setq a (read-from-string (string a))) + (setq b (read-from-string (string b))) + (incf c 2) (= (+ b c) a))))) + result) + "12x456789") + + +(deftest nsubstitute-string.21 + (let* ((orig "123456789") + (x (copy-seq orig)) + (c 5) + (result (nsubstitute #\x #\9 x :test #'(lambda (a b) + (setq a (read-from-string (string a))) + (setq b (read-from-string (string b))) + (incf c -2) (= (+ b c) a)) + :from-end t))) + result) + "1234567x9") + +(deftest nsubstitute-string.22 + (let* ((orig "123456789") + (x (copy-seq orig)) + (c -4) + (result (nsubstitute #\x #\5 x :test-not #'(lambda (a b) + (setq a (read-from-string (string a))) + (setq b (read-from-string (string b))) + (incf c 2) (/= (+ b c) a))))) + result) + "12x456789") + + +(deftest nsubstitute-string.23 + (let* ((orig "123456789") + (x (copy-seq orig)) + (c 5) + (result (nsubstitute #\x #\9 x :test-not #'(lambda (a b) + (setq a (read-from-string (string a))) + (setq b (read-from-string (string b))) + (incf c -2) (/= (+ b c) a)) + :from-end t))) + result) + "1234567x9") + +;;; Tests on bitstrings + +(deftest nsubstitute-bitstring.1 + (let* ((orig #*) + (x (copy-seq orig)) + (result (nsubstitute 0 1 x))) + result) + #*) + +(deftest nsubstitute-bitstring.2 + (let* ((orig #*) + (x (copy-seq orig)) + (result (nsubstitute 1 0 x))) + result) + #*) + +(deftest nsubstitute-bitstring.3 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute 0 1 x))) + result) + #*000000) + +(deftest nsubstitute-bitstring.4 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute 1 0 x))) + result) + #*111111) + +(deftest nsubstitute-bitstring.5 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute 1 0 x :start 1))) + result) + #*011111) + +(deftest nsubstitute-bitstring.6 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute 0 1 x :start 2 :end nil))) + result) + #*010000) + +(deftest nsubstitute-bitstring.7 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute 1 0 x :end 4))) + result) + #*111101) + +(deftest nsubstitute-bitstring.8 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute 0 1 x :end nil))) + result) + #*000000) + +(deftest nsubstitute-bitstring.9 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute 0 1 x :end 3))) + result) + #*000101) + +(deftest nsubstitute-bitstring.10 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute 0 1 x :start 2 :end 4))) + result) + #*010001) + +(deftest nsubstitute-bitstring.11 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute 1 0 x :start 2 :end 4))) + result) + #*011101) + +(deftest nsubstitute-bitstring.12 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute 1 0 x :count 1))) + result) + #*110101) + +(deftest nsubstitute-bitstring.13 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute 1 0 x :count 0))) + result) + #*010101) + +(deftest nsubstitute-bitstring.14 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute 1 0 x :count -1))) + result) + #*010101) + +(deftest nsubstitute-bitstring.15 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute 1 0 x :count 1 :from-end t))) + result) + #*010111) + +(deftest nsubstitute-bitstring.16 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute 1 0 x :count 0 :from-end t))) + result) + #*010101) + +(deftest nsubstitute-bitstring.17 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute 1 0 x :count -1 :from-end t))) + result) + #*010101) + +(deftest nsubstitute-bitstring.18 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute 1 0 x :count nil))) + result) + #*111111) + +(deftest nsubstitute-bitstring.19 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute 1 0 x :count nil :from-end t))) + result) + #*111111) + +(deftest nsubstitute-bitstring.20 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #*0000000000) + (x (copy-seq orig)) + (y (nsubstitute 1 0 x :start i :end j :count c))) + (equalp y (concatenate + 'simple-bit-vector + (make-list i :initial-element 0) + (make-list c :initial-element 1) + (make-list (- 10 (+ i c)) :initial-element 0))))))) + t) + +(deftest nsubstitute-bitstring.21 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #*1111111111) + (x (copy-seq orig)) + (y (nsubstitute 0 1 x :start i :end j :count c :from-end t))) + (equalp y (concatenate + 'simple-bit-vector + (make-list (- j c) :initial-element 1) + (make-list c :initial-element 0) + (make-list (- 10 j) :initial-element 1))))))) + t) + +(deftest nsubstitute-bitstring.22 + (let* ((orig #*0101010101) + (x (copy-seq orig)) + (c 0) + (result (nsubstitute 1 0 x :test #'(lambda (a b) (incf c) (and (<= 2 c 5) (= a b)))))) + result) + #*0111110101) + +(deftest nsubstitute-bitstring.23 + (let* ((orig #*0101010101) + (x (copy-seq orig)) + (c 0) + (result (nsubstitute 1 0 x :test-not #'(lambda (a b) (incf c) + (not (and (<= 2 c 5) (= a b))))))) + result) + #*0111110101) + +(deftest nsubstitute-bitstring.24 + (let* ((orig #*0101010101) + (x (copy-seq orig)) + (c 0) + (result (nsubstitute 1 0 x :test #'(lambda (a b) (incf c) (and (<= 2 c 5) (= a b))) + :from-end t))) + result) + #*0101011111) + +(deftest nsubstitute-bitstring.25 + (let* ((orig #*0101010101) + (x (copy-seq orig)) + (c 0) + (result (nsubstitute 1 0 x :test-not #'(lambda (a b) (incf c) + (not (and (<= 2 c 5) (= a b)))) + :from-end t))) + result) + #*0101011111) + +;;;; additional tests + +(deftest nsubstitute-list.24 + (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (nsubstitute '(a 10) 'a x :key #'car))) + result) + ((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) + +(deftest nsubstitute-list.25 + (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (nsubstitute '(a 10) 'a x :key #'car :start 1 :end 5))) + result) + ((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) + +(deftest nsubstitute-list.26 + (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (nsubstitute '(a 10) 'a x :key #'car :test (complement #'eq)))) + result) + ((a 1) (a 10) (a 3) (a 10) (a 10) (a 6) (a 10))) + +(deftest nsubstitute-list.27 + (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (nsubstitute '(a 10) 'a x :key #'car :test-not #'eq))) + result) + ((a 1) (a 10) (a 3) (a 10) (a 10) (a 6) (a 10))) + +(deftest nsubstitute-vector.24 + (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (nsubstitute '(a 10) 'a x :key #'car))) + result) + #((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) + +(deftest nsubstitute-vector.25 + (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (nsubstitute '(a 10) 'a x :key #'car :start 1 :end 5))) + result) + #((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) + +(deftest nsubstitute-vector.26 + (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (nsubstitute '(a 10) 'a x :key #'car :test (complement #'eq)))) + result) + #((a 1) (a 10) (a 3) (a 10) (a 10) (a 6) (a 10))) + +(deftest nsubstitute-vector.27 + (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (nsubstitute '(a 10) 'a x :key #'car :test-not #'eq))) + result) + #((a 1) (a 10) (a 3) (a 10) (a 10) (a 6) (a 10))) + +(deftest nsubstitute-string.24 + (let* ((orig "0102342015") + (x (copy-seq orig)) + (result (nsubstitute #\a #\1 x :key #'nextdigit))) + result) + "a1a2342a15") + +(deftest nsubstitute-string.25 + (let* ((orig "0102342015") + (x (copy-seq orig)) + (result (nsubstitute #\a #\1 x :key #'nextdigit :start 1 :end 6))) + result) + "01a2342015") + +(deftest nsubstitute-string.26 + (let* ((orig "0102342015") + (x (copy-seq orig)) + (result (nsubstitute #\a #\1 x :key #'nextdigit :test (complement #'eq)))) + result) + "0a0aaaa0aa") + +(deftest nsubstitute-string.27 + (let* ((orig "0102342015") + (x (copy-seq orig)) + (result (nsubstitute #\a #\1 x :key #'nextdigit :test-not #'eq))) + result) + "0a0aaaa0aa") diff --git a/ansi-tests/packages-00.lsp b/ansi-tests/packages-00.lsp new file mode 100644 index 0000000000000000000000000000000000000000..2b18b164e79666782edfbaf69881c48000034084 --- /dev/null +++ b/ansi-tests/packages-00.lsp @@ -0,0 +1,69 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 25 08:07:31 1998 +;;;; Contains: Package test code (common code) + +(in-package :cl-test) +(declaim (optimize (safety 3))) + +(defpackage "A" + (:use) + (:nicknames "Q") + (:export "FOO")) + +(defpackage "B" + (:use "A") + (:export "BAR")) + +(defpackage "DS1" + (:use) + (:intern "C" "D") + (:export "A" "B")) + +(defpackage "DS2" + (:use) + (:intern "E" "F") + (:export "G" "H" "A")) + +(defpackage "DS3" + (:shadow "B") + (:shadowing-import-from "DS1" "A") + (:use "DS1" "DS2") + (:export "A" "B" "G" "I" "J" "K") + (:intern "L" "M")) + +(defpackage "DS4" + (:shadowing-import-from "DS1" "B") + (:use "DS1" "DS3") + (:intern "X" "Y" "Z") + (:import-from "DS2" "F"))9 + +(defun sort-package-list (x) + (sort (copy-list x) + #'string< + :key #'package-name)) + +(defun sort-symbols (sl) + (sort (copy-list sl) + #'(lambda (x y) + (or + (string< (symbol-name x) + (symbol-name y)) + (and (string= (symbol-name x) + (symbol-name y)) + (string< (package-name (symbol-package x)) + (package-name (symbol-package y)))))))) + +(defun num-symbols-in-package (p) + (let ((num 0)) + (declare (fixnum num)) + (do-symbols (s p num) + (declare (ignore s)) + (incf num)))) + +(defun num-external-symbols-in-package (p) + (let ((num 0)) + (declare (fixnum num)) + (do-external-symbols (s p num) + (declare (ignore s)) + (incf num)))) diff --git a/ansi-tests/packages-01.lsp b/ansi-tests/packages-01.lsp new file mode 100644 index 0000000000000000000000000000000000000000..6204560e22e9b43d5e482e184639280a628ef860 --- /dev/null +++ b/ansi-tests/packages-01.lsp @@ -0,0 +1,76 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 25 07:49:34 1998 +;;;; Contains: Package test code, part 01 + +(in-package :cl-test) +(declaim (optimize (safety 3))) + +;; Test find-symbol, with the various combinations of +;; package designators + +(deftest find-symbol-1 + (ignore-errors (find-symbol "aBmAchb1c")) + nil nil) + +(deftest find-symbol-2 + (ignore-errors (find-symbol "aBmAchb1c" "CL")) + nil nil) + +(deftest find-symbol-3 + (ignore-errors (find-symbol "aBmAchb1c" "COMMON-LISP")) + nil nil) + +(deftest find-symbol-4 + (ignore-errors (find-symbol "aBmAchb1c" "KEYWORD")) + nil nil) + +(deftest find-symbol-5 + (ignore-errors (find-symbol "aBmAchb1c" "COMMON-LISP-USER")) + nil nil) + +(deftest find-symbol-6 + (ignore-errors (find-symbol "CAR" "CL")) + car :external) + +(deftest find-symbol-7 + (ignore-errors (find-symbol "CAR" "COMMON-LISP")) + car :external) + +(deftest find-symbol-8 + (ignore-errors (find-symbol "CAR" "COMMON-LISP-USER")) + car :inherited) + +(deftest find-symbol-9 + (ignore-errors (find-symbol "CAR" "CL-TEST")) + car :inherited) + +(deftest find-symbol-10 + (ignore-errors (find-symbol "TEST" "KEYWORD")) + :test :external) + +(deftest find-symbol-11 + (ignore-errors (find-symbol "FIND-SYMBOL-11" "CL-TEST")) + find-symbol-11 :internal) + +(deftest find-symbol-12 + (ignore-errors (find-symbol "FOO" #\A)) + A::FOO :external) + +(deftest find-symbol-13 + (progn + (intern "X" (find-package "A")) + (ignore-errors (find-symbol "X" #\A))) + A::X :internal) + +(deftest find-symbol-14 + (ignore-errors (find-symbol "FOO" #\B)) + A::FOO :inherited) + +(deftest find-symbol-15 + (ignore-errors (find-symbol "FOO" "B")) + A::FOO :inherited) + +(deftest find-symbol-16 + (ignore-errors (find-symbol "FOO" (find-package "B"))) + A::FOO :inherited) diff --git a/ansi-tests/packages-02.lsp b/ansi-tests/packages-02.lsp new file mode 100644 index 0000000000000000000000000000000000000000..9b97aaa16f4c41c905c24fb610ba3d105e69174b --- /dev/null +++ b/ansi-tests/packages-02.lsp @@ -0,0 +1,87 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 25 07:50:39 1998 +;;;; Contains: Package test code, aprt 02 + +(in-package :cl-test) +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; find-package + +(deftest find-package-1 + (let ((p (find-package "CL")) + (p2 (find-package "COMMON-LISP"))) + (and p p2 (eq p p2))) + t) + +(deftest find-package-2 + (let ((p (find-package "CL-USER")) + (p2 (find-package "COMMON-LISP-USER"))) + (and p p2 (eq p p2))) + t) + +(deftest find-package-3 + (let ((p (find-package "KEYWORD"))) + (and p (eq p (symbol-package :test)))) + t) + +(deftest find-package-4 + (let ((p (ignore-errors (find-package "A")))) + (if (packagep p) + t + p)) + t) + +(deftest find-package-5 + (let ((p (ignore-errors (find-package #\A)))) + (if (packagep p) + t + p)) + t) + +(deftest find-package-6 + (let ((p (ignore-errors (find-package "B")))) + (if (packagep p) + t + p)) + t) + +(deftest find-package-7 + (let ((p (ignore-errors (find-package #\B)))) + (if (packagep p) + t + p)) + t) + +(deftest find-package-8 + (let ((p (ignore-errors (find-package "Q"))) + (p2 (ignore-errors (find-package "A")))) + (and (packagep p) + (packagep p2) + (eq p p2))) + t) + +(deftest find-package-9 + (let ((p (ignore-errors (find-package "A"))) + (p2 (ignore-errors (find-package "B")))) + (eq p p2)) + nil) + +(deftest find-package-10 + (let ((p (ignore-errors (find-package #\Q))) + (p2 (ignore-errors (find-package "Q")))) + (and (packagep p) + (eq p p2))) + t) + +(deftest find-package-11 + (handler-case + (let ((cl (find-package "CL"))) + (let ((cl2 (find-package cl))) + (and (packagep cl) + (eq cl cl2)))) + (error (c) c)) + t) + + diff --git a/ansi-tests/packages-03.lsp b/ansi-tests/packages-03.lsp new file mode 100644 index 0000000000000000000000000000000000000000..3ebbdfd7c4e7808b08bada38280b0b9a4570d502 --- /dev/null +++ b/ansi-tests/packages-03.lsp @@ -0,0 +1,187 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 25 07:51:26 1998 +;;;; Contains: Package test code, part 03 + +(in-package :cl-test) +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; list-all-packages + +;; list-all-packages returns a list +(deftest list-all-packages-1 + (numberp (ignore-errors (list-length (list-all-packages)))) + t) + +;; The required packages are present +(deftest list-all-packages-2 + (subsetp + (list (find-package "CL") + (find-package "CL-USER") + (find-package "KEYWORD") + (find-package "A") + (find-package "RT") + (find-package "CL-TEST") + (find-package "B")) + (list-all-packages)) + t) + +;; The list returned has only packages in it +(deftest list-all-packages-3 + (not (not (every #'packagep (list-all-packages)))) + t) + +;; It returns a list of the same packages each time it is called +(deftest list-all-packages-4 + (let ((p1 (list-all-packages)) + (p2 (list-all-packages))) + (and (subsetp p1 p2) + (subsetp p2 p1))) + t) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; package-name + +(deftest package-name-1 + (ignore-errors (package-name "A")) + "A") + +(deftest package-name-2 + (ignore-errors (package-name #\A)) + "A") + +(deftest package-name-3 + (ignore-errors (package-name "Q")) + "A") + +(deftest package-name-4 + (ignore-errors (package-name #\Q)) + "A") + +(deftest package-name-5 + (catch-type-error (package-name "NOT-THERE")) + type-error) + +(deftest package-name-6 + (catch-type-error (package-name #\*)) + type-error) + +(deftest package-name-7 + (package-name "CL") + "COMMON-LISP") + +(deftest package-name-8 + (package-name "COMMON-LISP") + "COMMON-LISP") + +(deftest package-name-9 + (package-name "COMMON-LISP-USER") + "COMMON-LISP-USER") + +(deftest package-name-10 + (package-name "CL-USER") + "COMMON-LISP-USER") + +(deftest package-name-11 + (package-name "KEYWORD") + "KEYWORD") + +(deftest package-name-12 + (package-name (find-package "CL")) + "COMMON-LISP") + +(deftest package-name-13 + (let* ((p (make-package "TEMP1")) + (pname1 (package-name p))) + (rename-package "TEMP1" "TEMP2") + (let ((pname2 (package-name p))) + (ignore-errors (delete-package p)) + (list pname1 pname2 (package-name p)))) + ("TEMP1" "TEMP2" nil)) + +;; (find-package (package-name p)) == p for any package p +(deftest package-name-14 + (loop + for p in (list-all-packages) count + (not + (let ((name (package-name p))) + (and (stringp name) + (eq (find-package name) p))))) + 0) + +;; package-name applied to a package's name +;; should return an equal string +(deftest package-name-15 + (loop + for p in (list-all-packages) count + (not (equal (package-name p) + (ignore-errors (package-name (package-name p)))))) + 0) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; package-nicknames + +(deftest package-nicknames-1 + (ignore-errors (package-nicknames "A")) + ("Q")) + +(deftest package-nicknames-2 + (ignore-errors (package-nicknames #\A)) + ("Q")) + +(deftest package-nicknames-3 + (ignore-errors (package-nicknames ':|A|)) + ("Q")) + +(deftest package-nicknames-4 + (ignore-errors (package-nicknames "B")) + nil) + +(deftest package-nicknames-5 + (ignore-errors (package-nicknames #\B)) + nil) + +(deftest package-nicknames-6 + (ignore-errors (package-nicknames '#:|B|)) + nil) + +(deftest package-nicknames-7 + (ignore-errors + (subsetp '("CL") + (package-nicknames "COMMON-LISP") + :test #'string=)) + t) + +(deftest package-nicknames-8 + (ignore-errors + (subsetp '("CL-USER") + (package-nicknames "COMMON-LISP-USER") + :test #'string=)) + t) + +(deftest package-nicknames-9 + (catch-type-error (package-nicknames 10)) + type-error) + +(deftest package-nicknames-10 + (ignore-errors (package-nicknames (find-package "A"))) + ("Q")) + +(deftest package-nicknames-11 + (catch-type-error (package-nicknames "NOT-A-PACKAGE-NAME")) + type-error) + + +;; (find-package n) == p for each n in (package-nicknames p), +;; for any package p +(deftest package-nicknames-12 + (loop + for p in (list-all-packages) sum + (loop + for nk in (package-nicknames p) count + (not + (and (stringp nk) + (eq p (find-package nk)))))) + 0) diff --git a/ansi-tests/packages-04.lsp b/ansi-tests/packages-04.lsp new file mode 100644 index 0000000000000000000000000000000000000000..5d427190c2359fe5d772e4d194d8e8fd00e03e3c --- /dev/null +++ b/ansi-tests/packages-04.lsp @@ -0,0 +1,40 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 25 07:59:10 1998 +;;;; Contains: Package test code, part 04 + +(in-package :cl-test) +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; intern + +(deftest intern-1 + (let ((p (make-package "TEMP1"))) + (multiple-value-bind (sym1 status1) + (find-symbol "FOO" p) + (intern "FOO" p) + (multiple-value-bind (sym2 status2) + (find-symbol "FOO" p) + (and (null sym1) + (null status1) + (string= (symbol-name sym2) "FOO") + (eq (symbol-package sym2) p) + (eq status2 :internal) + (progn (delete-package p) t))))) + t) + +(deftest intern-2 + (let ((p (make-package "TEMP1"))) + (multiple-value-bind (sym1 status1) + (find-symbol "FOO" "TEMP1") + (intern "FOO" "TEMP1") + (multiple-value-bind (sym2 status2) + (find-symbol "FOO" p) + (and (null sym1) + (null status1) + (string= (symbol-name sym2) "FOO") + (eq (symbol-package sym2) p) + (eq status2 :internal) + (progn (delete-package p) t))))) + t) diff --git a/ansi-tests/packages-05.lsp b/ansi-tests/packages-05.lsp new file mode 100644 index 0000000000000000000000000000000000000000..43d94f80fb07d3eeac01d54cc043aead4a79136d --- /dev/null +++ b/ansi-tests/packages-05.lsp @@ -0,0 +1,90 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 25 07:59:45 1998 +;;;; Contains: Package test code, part 05 + +(in-package :cl-test) +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; export + +(deftest export-1 + (let ((return-value nil)) + (ignore-errors (delete-package "TEST1")) + (let ((p (make-package "TEST1"))) + (let ((sym (intern "FOO" p))) + (setf return-value (export sym p)) + (multiple-value-bind (sym2 status) + (find-symbol "FOO" p) + (prog1 + (and sym2 + (eq (symbol-package sym2) p) + (string= (symbol-name sym2) "FOO") + (eq sym sym2) + (eq status :external)) + (delete-package p))))) + return-value) + t) + +(deftest export-2 + (progn (ignore-errors (delete-package "TEST1")) + (let ((p (make-package "TEST1"))) + (let ((sym (intern "FOO" p))) + (export (list sym) p) + (multiple-value-bind (sym2 status) + (find-symbol "FOO" p) + (prog1 + (and sym2 + (eq (symbol-package sym2) p) + (string= (symbol-name sym2) "FOO") + (eq sym sym2) + (eq status :external)) + (delete-package p)))))) + t) + +(deftest export-3 + (handler-case + (progn + (make-package "F") + (let ((sym (intern "FOO" "F"))) + (export sym #\F) + (delete-package "F") + t)) + (error (c) (delete-package "F") c)) + t) + +;; +;; When a symbol not in a package is exported, export +;; should signal a correctable package-error asking the +;; user whether the symbol should be imported. +;; +(deftest export-4 + (handler-case + (export 'b::bar "A") + (package-error () 'package-error) + (error (c) c)) + package-error) + +;; +;; Test that it catches an attempt to export a symbol +;; from a package that is used by another package that +;; is exporting a symbol with the same name. +;; +(deftest export-5 + (progn + (make-package "TEST1") + (make-package "TEST2" :use '("TEST1")) + (export (intern "X" "TEST2") "TEST2") + (prog1 + (handler-case + (let ((sym (intern "X" "TEST1"))) + (handler-case + (export sym "TEST1") + (error (c) + (format t "Caught error in EXPORT-5: ~A~%" c) + 'caught))) + (error (c) c)) + (delete-package "TEST2") + (delete-package "TEST1"))) + caught) diff --git a/ansi-tests/packages-06.lsp b/ansi-tests/packages-06.lsp new file mode 100644 index 0000000000000000000000000000000000000000..8798080fa398a36b775c2368aa4fd2dc4aad333a --- /dev/null +++ b/ansi-tests/packages-06.lsp @@ -0,0 +1,145 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 25 08:00:28 1998 +;;;; Contains: Package test code, part 06 + +(in-package :cl-test) +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; rename-package + +(deftest rename-package-1 + (block nil + (ignore-errors (delete-package "TEST1")) + (let ((p (make-package "TEST1"))) + (unless (packagep p) (return nil)) + (let ((p2 (rename-package "TEST1" "TEST2"))) + (unless (packagep p2) + (ignore-errors (delete-package p)) + (return p2)) + (unless (and (eq p p2) + (equal (package-name p2) "TEST2")) + (ignore-errors (delete-package p)) + (ignore-errors (delete-package p2)) + (return nil)) + (ignore-errors (delete-package p2)) + t))) + t) + +(deftest rename-package-2 + (block nil + (ignore-errors (delete-package "TEST1")) + (let ((p (make-package "TEST1")) + (nicknames (copy-list '("TEST3" "TEST4" "TEST5")))) + (unless (packagep p) (return nil)) + (let ((p2 (rename-package "TEST1" "TEST2" nicknames))) + (unless (packagep p2) + (ignore-errors (delete-package p)) + (return p2)) + (unless (and (eq p p2) + (equal (package-name p2) "TEST2") + (null (set-exclusive-or nicknames + (package-nicknames p2) + :test #'equal))) + (ignore-errors (delete-package p)) + (ignore-errors (delete-package p2)) + (return nil)) + (ignore-errors (delete-package p2)) + t))) + t) + +(deftest rename-package-3 + (block nil + (ignore-errors (delete-package "TEST1")) + (let ((p (make-package "TEST1")) + (nicknames (copy-list '(#\M #\N)))) + (unless (packagep p) (return nil)) + (let ((p2 (ignore-errors (rename-package "TEST1" "TEST2" nicknames)))) + (unless (packagep p2) + (ignore-errors (delete-package p)) + (return p2)) + (unless (and (eq p p2) + (equal (package-name p2) "TEST2") + (equal + (sort (copy-list (package-nicknames p2)) + #'string<) + (sort (mapcar #'(lambda (c) + (make-string 1 :initial-element c)) + nicknames) + #'string<))) + (ignore-errors (delete-package p)) + (ignore-errors (delete-package p2)) + (return nil)) + (ignore-errors (delete-package p2)) + t))) + t) + +(deftest rename-package-4 + (block nil + (ignore-errors (delete-package "G")) + (let ((p (make-package "G")) + (nicknames nil)) + (unless (packagep p) (return nil)) + (let ((p2 (ignore-errors (rename-package #\G "TEST2" nicknames)))) + (unless (packagep p2) + (ignore-errors (delete-package p)) + (return p2)) + (unless (and (eq p p2) + (equal (package-name p2) "TEST2") + (null (set-exclusive-or nicknames + (package-nicknames p2) + :test #'equal))) + (ignore-errors (delete-package p)) + (ignore-errors (delete-package p2)) + (return nil)) + (ignore-errors (delete-package p2)) + t))) + t) + +(deftest rename-package-5 + (block nil + (ignore-errors (delete-package "TEST1")) + (let ((p (make-package "TEST1")) + (nicknames nil)) + (unless (packagep p) (return nil)) + (let ((p2 (ignore-errors (rename-package "TEST1" #\G nicknames)))) + (unless (packagep p2) + (ignore-errors (delete-package p)) + (return p2)) + (unless (and (eq p p2) + (equal (package-name p2) "G") + (null (set-exclusive-or nicknames + (package-nicknames p2) + :test #'equal))) + (ignore-errors (delete-package p)) + (ignore-errors (delete-package p2)) + (return nil)) + (ignore-errors (delete-package p2)) + t))) + t) + +(deftest rename-package-6 + (block nil + (ignore-errors (delete-package '|TEST1|)) + (let ((p (make-package '|TEST1|)) + (nicknames (copy-list '(|M| |N|)))) + (unless (packagep p) (return nil)) + (let ((p2 (ignore-errors (rename-package + '|TEST1| '|TEST2| nicknames)))) + (unless (packagep p2) + (ignore-errors (delete-package p)) + (return p2)) + (unless (and (eq p p2) + (equal (package-name p2) "TEST2") + (equal + (sort (copy-list (package-nicknames p2)) + #'string<) + (sort (mapcar #'symbol-name nicknames) + #'string<))) + (ignore-errors (delete-package p)) + (ignore-errors (delete-package p2)) + (return nil)) + (ignore-errors (delete-package p2)) + t))) + t) diff --git a/ansi-tests/packages-07.lsp b/ansi-tests/packages-07.lsp new file mode 100644 index 0000000000000000000000000000000000000000..e6a611a4ecd890ec01d086a3c5be0202b08b9052 --- /dev/null +++ b/ansi-tests/packages-07.lsp @@ -0,0 +1,221 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 25 08:01:20 1998 +;;;; Contains: Package test code, part 07 + +(in-package :cl-test) +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; shadow + +(deftest shadow-1 + (prog1 + (progn + (ignore-errors (delete-package "TEST5")) + (ignore-errors (delete-package "TEST4")) + (handler-case + (let* ((p1 (prog1 + (make-package "TEST4") + (export (intern "A" "TEST4") "TEST4"))) + (p2 (make-package "TEST5" :use '("TEST4"))) + (r1 (package-shadowing-symbols "TEST4")) + (r2 (package-shadowing-symbols "TEST5"))) + (multiple-value-bind (s1 kind1) + (find-symbol "A" p1) + (multiple-value-bind (s2 kind2) + (find-symbol "A" p2) + (let ((r3 (shadow "A" p2))) + (multiple-value-bind (s3 kind3) + (find-symbol "A" p2) + (list + (package-name p1) + (package-name p2) + r1 r2 + (symbol-name s1) + (package-name (symbol-package s1)) + kind1 + (symbol-name s2) + (package-name (symbol-package s2)) + kind2 + r3 + (symbol-name s3) + (package-name (symbol-package s3)) + kind3)))))) + (error (c) c))) + (ignore-errors (delete-package "TEST5")) + (ignore-errors (delete-package "TEST4"))) + ("TEST4" "TEST5" nil nil "A" "TEST4" :external + "A" "TEST4" :inherited + t + "A" "TEST5" :internal)) + +(deftest shadow-2 + (progn + (ignore-errors (delete-package "H")) + (ignore-errors (delete-package "G")) + (handler-case + (let* ((p1 (prog1 + (make-package "G") + (export (intern "A" "G") "G"))) + (p2 (make-package "H" :use '("G"))) + (r1 (package-shadowing-symbols "G")) + (r2 (package-shadowing-symbols "H"))) + (multiple-value-bind (s1 kind1) + (find-symbol "A" p1) + (multiple-value-bind (s2 kind2) + (find-symbol "A" p2) + (let ((r3 (shadow "A" "H"))) + (multiple-value-bind (s3 kind3) + (find-symbol "A" p2) + (prog1 + (list (package-name p1) (package-name p2) + r1 r2 (symbol-name s1) (package-name (symbol-package s1)) + kind1 (symbol-name s2) (package-name (symbol-package s2)) + kind2 r3 (symbol-name s3) (package-name (symbol-package s3)) + kind3) + (ignore-errors (delete-package p2)) + (ignore-errors (delete-package p1)) + )))))) + (error (c) + (ignore-errors (delete-package "H")) + (ignore-errors (delete-package "G")) + c))) + ("G" "H" nil nil "A" "G" :external + "A" "G" :inherited + t + "A" "H" :internal)) + +;; shadow in which the package is given +;; by a character +(deftest shadow-3 + (progn + (ignore-errors (delete-package "H")) + (ignore-errors (delete-package "G")) + (handler-case + (let* ((p1 (prog1 + (make-package "G") + (export (intern "A" "G") "G"))) + (p2 (make-package "H" :use '("G"))) + (r1 (package-shadowing-symbols "G")) + (r2 (package-shadowing-symbols "H"))) + (multiple-value-bind (s1 kind1) + (find-symbol "A" p1) + (multiple-value-bind (s2 kind2) + (find-symbol "A" p2) + (let ((r3 (shadow "A" #\H))) + (multiple-value-bind (s3 kind3) + (find-symbol "A" p2) + (prog1 + (list (package-name p1) (package-name p2) + r1 r2 (symbol-name s1) (package-name (symbol-package s1)) + kind1 (symbol-name s2) (package-name (symbol-package s2)) + kind2 r3 (symbol-name s3) (package-name (symbol-package s3)) + kind3) + (ignore-errors (delete-package p2)) + (ignore-errors (delete-package p1)) + )))))) + (error (c) + (ignore-errors (delete-package "H")) + (ignore-errors (delete-package "G")) + c))) + ("G" "H" nil nil "A" "G" :external + "A" "G" :inherited + t + "A" "H" :internal)) + + +;; shadow on an existing internal symbol returns the existing symbol +(deftest shadow-4 + (prog1 + (handler-case + (progn + (ignore-errors (delete-package :G)) + (make-package :G) + (let ((s1 (intern "X" :G))) + (shadow "X" :G) + (multiple-value-bind (s2 kind) + (find-symbol "X" :G) + (list (eq s1 s2) + (symbol-name s2) + (package-name (symbol-package s2)) + kind)))) + (error (c) c)) + (ignore-errors (delete-package "G"))) + (t "X" "G" :internal)) + + +;; shadow of an existing shadowed symbol returns the symbol +(deftest shadow-5 + (prog1 + (handler-case + (progn + (ignore-errors (delete-package :H)) + (ignore-errors (delete-package :G)) + (make-package :G) + (export (intern "X" :G) :G) + (make-package :H :use '("G")) + (shadow "X" :H) + (multiple-value-bind (s1 kind1) + (find-symbol "X" :H) + (shadow "X" :H) + (multiple-value-bind (s2 kind2) + (find-symbol "X" :H) + (list (eq s1 s2) kind1 kind2)))) + (error (c) c)) + (ignore-errors (delete-package :H)) + (ignore-errors (delete-package :G))) + (t :internal :internal)) + +;; Shadow several names simultaneously + +(deftest shadow-6 + (prog1 + (handler-case + (progn + (ignore-errors (delete-package :G)) + (make-package :G) + (shadow '("X" "Y" |Z|) :G) + (let ((results + (append (multiple-value-list + (find-symbol "X" :G)) + (multiple-value-list + (find-symbol "Y" :G)) + (multiple-value-list + (find-symbol "Z" :G)) + nil))) + (list + (symbol-name (first results)) + (second results) + (symbol-name (third results)) + (fourth results) + (symbol-name (fifth results)) + (sixth results) + (length (package-shadowing-symbols :G))))) + (error (c) c)) + (ignore-errors (delete-package :G))) + ("X" :internal "Y" :internal "Z" :internal 3)) + +;; Same, but shadow character string designators +(deftest shadow-7 + (prog1 + (handler-case + (progn + (ignore-errors (delete-package :G)) + (make-package :G) + (shadow '(#\X #\Y) :G) + (let ((results + (append (multiple-value-list + (find-symbol "X" :G)) + (multiple-value-list + (find-symbol "Y" :G)) + nil))) + (list + (symbol-name (first results)) + (second results) + (symbol-name (third results)) + (fourth results) + (length (package-shadowing-symbols :G))))) + (error (c) c)) + (ignore-errors (delete-package :G))) + ("X" :internal "Y" :internal 2)) diff --git a/ansi-tests/packages-08.lsp b/ansi-tests/packages-08.lsp new file mode 100644 index 0000000000000000000000000000000000000000..eac8f27848ac1cd1bbd98c12ae2ac9540f6eb70f --- /dev/null +++ b/ansi-tests/packages-08.lsp @@ -0,0 +1,137 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 25 08:01:58 1998 +;;;; Contains: Package test code, part 08 + +(in-package :cl-test) +(declaim (optimize (safety 3))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; delete-package + +;; check return value of delete-package, and check +;; that package-name is nil on the deleted package object +(deftest delete-package-1 + (progn + (ignore-errors (delete-package :test1)) + (let ((p (make-package :test1 :use nil))) + (list + (not (not (delete-package :test1))) + (not (not (packagep p))) + (package-name p)))) + (t t nil)) + +(deftest delete-package-2 + (progn + (ignore-errors (delete-package :test1)) + (let ((p (make-package :test1 :use nil))) + (list + (not (not (delete-package :test1))) + (not (not (packagep p))) + (delete-package p)))) + (t t nil)) + +;; Check that deletion of different package designators works +(deftest delete-package-3 + (progn + (ignore-errors (delete-package "X")) + (make-package "X") + (handler-case + (not (not (delete-package "X"))) + (error (c) c))) + t) + +(deftest delete-package-4 + (progn + (ignore-errors (delete-package "X")) + (make-package "X") + (handler-case + (not (not (delete-package #\X))) + (error (c) c))) + t) + +;; Paul Werkowski pointed out a problem in a previous +;; version of the next test. The problem is to catch +;; an error, check that it is the appropriate type, +;; check that it is continuable, and continue it. +;; The scheme here uses *debugger-hook*, but this +;; apparently doesn't work if the code is inside +;; a handler-case or ignore-errors form. +;; +;; The next test had the same problem. + +(deftest delete-package-5 + (prog (P1 S1 P2 S2 P3) + (ignore-errors (delete-package "P3")) + (ignore-errors (delete-package "P2")) + (ignore-errors (delete-package "P1")) + + (setq P1 (make-package "P1" :use ())) + (setq S1 (intern "S1" P1)) + (export S1 "P1") + + (setq P2 (make-package "P2" :use '("P1"))) + (setq S2 (intern "S2" P2)) + (export S1 P2) + (export S2 "P2") + + (setf P3 (make-package "P3" :use '("P2"))) + + ;; Delete the P2 package, catching the continuable + ;; error and deleting the package + + (catch 'continue-failed + (let ((*debugger-hook* #'catch-continue-debugger-hook) + (*catch-error-type* 'package-error)) + (declare (special *debugger-hook* *catch-error-type*)) + (delete-package P2))) + + (unless (and (equal (package-name P1) "P1") + (null (package-name P2)) + (equal (package-name P3) "P3")) + (return 'fail1)) + + (unless (eq (symbol-package S1) P1) + (return 'fail2)) + (unless (equal (prin1-to-string S1) "P1:S1") + (return 'fail3)) + + (unless (equal (multiple-value-list (find-symbol "S1" P3)) + '(nil nil)) + (return 'fail4)) + + (unless (equal (multiple-value-list (find-symbol "S2" P3)) + '(nil nil)) + (return 'fail5)) + + (unless (and (null (package-used-by-list P1)) + (null (package-used-by-list P3))) + (return 'fail6)) + + (unless (and (packagep P1) + (packagep P2) + (packagep P3)) (return 'fail7)) + + (unless (and (null (package-use-list P1)) + (null (package-use-list P3))) + (return 'fail8)) + + (ignore-errors (delete-package P3)) + (ignore-errors (delete-package P1)) + (return t)) + t) + +;; deletion of a nonexistent package should cause a continuable +;; package-error (same comments for delete-package-5 apply +;; here as well) + +(deftest delete-package-6 + (progn + (when (find-package "TEST-20") (delete-package "TEST-20")) + (catch 'continue-failed + (let ((*debugger-hook* #'catch-continue-debugger-hook) + (*catch-error-type* 'package-error)) + (declare (special *debugger-hook* *catch-error-type*)) + (and (not (delete-package "TEST-20")) + t)))) + t) + diff --git a/ansi-tests/packages-09.lsp b/ansi-tests/packages-09.lsp new file mode 100644 index 0000000000000000000000000000000000000000..dfbfdf2efd409fa9fdb079d2eba4af26b955e249 --- /dev/null +++ b/ansi-tests/packages-09.lsp @@ -0,0 +1,306 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 25 08:02:43 1998 +;;;; Contains: Package test code, part 09 + +(in-package :cl-test) +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; make-package + +;; Test basic make-package, using string, symbol and character +;; package-designators + +(deftest make-package-1 + (progn + (ignore-errors (delete-package "TEST1")) + (let ((p (ignore-errors (make-package "TEST1")))) + (prog1 + (and (packagep p) + (equal (package-name p) "TEST1") + (equal (package-nicknames p) nil) + (equal (package-used-by-list p) nil)) + (ignore-errors (delete-package p))))) + t) + +(deftest make-package-2 + (progn + (ignore-errors (delete-package '#:|TEST1|)) + (let ((p (ignore-errors (make-package '#:|TEST1|)))) + (prog1 + (and (packagep p) + (equal (package-name p) "TEST1") + (equal (package-nicknames p) nil) + (equal (package-used-by-list p) nil)) + (ignore-errors (delete-package p))))) + t) + +(deftest make-package-3 + (progn + (ignore-errors (delete-package #\X)) + (let ((p (ignore-errors (make-package #\X)))) + (prog1 + (and (packagep p) + (equal (package-name p) "X") + (equal (package-nicknames p) nil) + (equal (package-used-by-list p) nil)) + (ignore-errors (delete-package p))))) + t) + +;; Same, but with a null :use list + +(deftest make-package-4 + (progn + (ignore-errors (delete-package "TEST1")) + (let ((p (ignore-errors (make-package "TEST1" :use nil)))) + (prog1 + (and (packagep p) + (equal (package-name p) "TEST1") + (equal (package-nicknames p) nil) + (equal (package-use-list p) nil) + (equal (package-used-by-list p) nil)) + (ignore-errors (delete-package p))))) + t) + +(deftest make-package-5 + (progn + (ignore-errors (delete-package '#:|TEST1|)) + (let ((p (ignore-errors (make-package '#:|TEST1| :use nil)))) + (prog1 + (and (packagep p) + (equal (package-name p) "TEST1") + (equal (package-nicknames p) nil) + (equal (package-use-list p) nil) + (equal (package-used-by-list p) nil)) + (ignore-errors (delete-package p))))) + t) + +(deftest make-package-6 + (progn + (ignore-errors (delete-package #\X)) + (let ((p (ignore-errors (make-package #\X)))) + (prog1 + (and (packagep p) + (equal (package-name p) "X") + (equal (package-nicknames p) nil) + (equal (package-use-list p) nil) + (equal (package-used-by-list p) nil)) + (ignore-errors (delete-package p))))) + t) + +;; Same, but use the A package + +(deftest make-package-7 + (progn + (ignore-errors (delete-package "TEST1")) + (let ((p (ignore-errors (make-package "TEST1" :use '("A"))))) + (prog1 + (and (packagep p) + (equal (package-name p) "TEST1") + (equal (package-nicknames p) nil) + (equal (package-use-list p) (list (find-package "A"))) + (equal (package-used-by-list p) nil)) + (ignore-errors (delete-package p))))) + t) + +(deftest make-package-7a + (progn + (ignore-errors (delete-package "TEST1")) + (let ((p (ignore-errors (make-package "TEST1" :use '(#:|A|))))) + (prog1 + (and (packagep p) + (equal (package-name p) "TEST1") + (equal (package-nicknames p) nil) + (equal (package-use-list p) (list (find-package "A"))) + (equal (package-used-by-list p) nil)) + (ignore-errors (delete-package p))))) + t) + +(deftest make-package-7b + (progn + (ignore-errors (delete-package "TEST1")) + (let ((p (ignore-errors (make-package "TEST1" :use '(#\A))))) + (prog1 + (and (packagep p) + (equal (package-name p) "TEST1") + (equal (package-nicknames p) nil) + (equal (package-use-list p) (list (find-package "A"))) + (equal (package-used-by-list p) nil)) + (ignore-errors (delete-package p))))) + t) + +(deftest make-package-8 + (progn + (ignore-errors (delete-package '#:|TEST1|)) + (let ((p (ignore-errors (make-package '#:|TEST1| :use '("A"))))) + (prog1 + (and (packagep p) + (equal (package-name p) "TEST1") + (equal (package-nicknames p) nil) + (equal (package-use-list p) (list (find-package "A"))) + (equal (package-used-by-list p) nil)) + (ignore-errors (delete-package p))))) + t) + +(deftest make-package-8a + (progn + (ignore-errors (delete-package '#:|TEST1|)) + (let ((p (ignore-errors (make-package '#:|TEST1| :use '(#:|A|))))) + (prog1 + (and (packagep p) + (equal (package-name p) "TEST1") + (equal (package-nicknames p) nil) + (equal (package-use-list p) (list (find-package "A"))) + (equal (package-used-by-list p) nil)) + (ignore-errors (delete-package p))))) + t) + +(deftest make-package-8b + (progn + (ignore-errors (delete-package '#:|TEST1|)) + (let ((p (ignore-errors (make-package '#:|TEST1| :use '(#\A))))) + (prog1 + (and (packagep p) + (equal (package-name p) "TEST1") + (equal (package-nicknames p) nil) + (equal (package-use-list p) (list (find-package "A"))) + (equal (package-used-by-list p) nil)) + (ignore-errors (delete-package p))))) + t) + +(deftest make-package-9 + (progn + (ignore-errors (delete-package #\X)) + (let ((p (ignore-errors (make-package #\X :use '("A"))))) + (prog1 + (and (packagep p) + (equal (package-name p) "X") + (equal (package-nicknames p) nil) + (equal (package-use-list p) (list (find-package "A"))) + (equal (package-used-by-list p) nil)) + (ignore-errors (delete-package p))))) + t) + +(deftest make-package-9a + (progn + (ignore-errors (delete-package #\X)) + (let ((p (ignore-errors (make-package #\X :use '(#:|A|))))) + (prog1 + (and (packagep p) + (equal (package-name p) "X") + (equal (package-nicknames p) nil) + (equal (package-use-list p) (list (find-package "A"))) + (equal (package-used-by-list p) nil)) + (ignore-errors (delete-package p))))) + t) + +(deftest make-package-9b + (progn + (ignore-errors (delete-package #\X)) + (let ((p (ignore-errors (make-package #\X :use '(#\A))))) + (prog1 + (and (packagep p) + (equal (package-name p) "X") + (equal (package-nicknames p) nil) + (equal (package-use-list p) (list (find-package "A"))) + (equal (package-used-by-list p) nil)) + (ignore-errors (delete-package p))))) + t) + +;; make-package with nicknames + +(deftest make-package-10 + (progn + (ignore-errors (delete-package "TEST1")) + (let ((p (ignore-errors (make-package "TEST1" :nicknames '("F"))))) + (prog1 + (and (packagep p) + (equal (package-name p) "TEST1") + (equal (package-nicknames p) '("F")) + (equal (package-used-by-list p) nil)) + (ignore-errors (delete-package p))))) + t) + +(deftest make-package-11 + (progn + (ignore-errors (delete-package '#:|TEST1|)) + (let ((p (ignore-errors (make-package '#:|TEST1| :nicknames '(#:|G|))))) + (prog1 + (and (packagep p) + (equal (package-name p) "TEST1") + (equal (package-nicknames p) '("G")) + (equal (package-used-by-list p) nil)) + (ignore-errors (delete-package p))))) + t) + +(deftest make-package-12 + (progn + (ignore-errors (delete-package '#:|TEST1|)) + (let ((p (ignore-errors (make-package '#:|TEST1| :nicknames '(#\G))))) + (prog1 + (and (packagep p) + (equal (package-name p) "TEST1") + (equal (package-nicknames p) '("G")) + (equal (package-used-by-list p) nil)) + (ignore-errors (delete-package p))))) + t) + +(deftest make-package-13 + (progn + (ignore-errors (delete-package #\X)) + (let ((p (ignore-errors (make-package #\X :nicknames '("F" #\G #:|H|))))) + (prog1 + (and (packagep p) + (equal (package-name p) "X") + (null (set-exclusive-or (package-nicknames p) + '("F" "G" "H") + :test #'equal)) + (equal (package-used-by-list p) nil)) + (ignore-errors (delete-package p))))) + t) + +;; Signal a continuable error if the package or any nicknames +;; exist as packages or nicknames of packages + +(deftest make-package-error-1 + (handler-case + (make-package "A") + (error (c) + (if (member 'abort (mapcar #'restart-name (compute-restarts c)) + :test (complement #'eq)) + 'success + 'failure))) + success) + +(deftest make-package-error-2 + (handler-case + (make-package "Q") + (error (c) + (if (member 'abort (mapcar #'restart-name (compute-restarts c)) + :test (complement #'eq)) + 'success + 'failure))) + success) + +(deftest make-package-error-3 + (handler-case + (progn (ignore-errors (delete-package "TEST1")) + (make-package "TEST1" :nicknames '("A"))) + (error (c) + (if (member 'abort (mapcar #'restart-name (compute-restarts c)) + :test (complement #'eq)) + 'success + 'failure))) + success) + +(deftest make-package-error-4 + (handler-case + (progn (ignore-errors (delete-package "TEST1")) + (make-package "TEST1" :nicknames '("Q"))) + (error (c) + (if (member 'abort (mapcar #'restart-name (compute-restarts c)) + :test (complement #'eq)) + 'success + 'failure))) + success) diff --git a/ansi-tests/packages-10.lsp b/ansi-tests/packages-10.lsp new file mode 100644 index 0000000000000000000000000000000000000000..a046aa2a1c049528d51ecb67d0d9dbee202db19e --- /dev/null +++ b/ansi-tests/packages-10.lsp @@ -0,0 +1,229 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 25 08:03:36 1998 +;;;; Contains: Package test code, part 10 + +(in-package :cl-test) +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; with-package-iterator + +(defconstant +fail-count-limit+ 20) + +(defmacro test-with-package-iterator (package-list-expr &rest symbol-types) + "Build an expression that tests the with-package-iterator form." + (let ((name (gensym)) + (cht-var (gensym)) + (pkg-list-var (gensym))) + `(let ((,cht-var (make-hash-table)) + (,pkg-list-var ,package-list-expr) + (fail-count 0)) + (with-package-iterator (,name ,pkg-list-var + ,@(copy-list symbol-types)) + ;; For each symbol, check that name is returning appropriate + ;; things + (loop + (block fail + (multiple-value-bind (more sym access pkg) + (,name) + (unless more (return nil)) + (setf (gethash sym ,cht-var) t) ;; note presence of symbol + ;; Check that its access status is in the list, + ;; that pkg is a package, + ;; that the symbol is in the package, + ;; and that (in the package) it has the correct access type + (unless (member access (quote ,(copy-list symbol-types))) + (unless (> fail-count +fail-count-limit+) + (format t "Bad access type: ~S ==> ~A~%" sym access)) + (when (= fail-count +fail-count-limit+) + (format t "Further messages suppressed~%")) + (incf fail-count) + (return-from fail nil)) + + (unless (packagep pkg) + (unless (> fail-count +fail-count-limit+) + (format t "Not a package: ~S ==> ~S~%" sym pkg)) + (when (= fail-count +fail-count-limit+) + (format t "Further messages suppressed~%")) + (incf fail-count) + (return-from fail nil)) + (multiple-value-bind (sym2 access2) + (find-symbol (symbol-name sym) pkg) + (unless (or (eq sym sym2) + (member sym2 (PACKAGE-SHADOWING-SYMBOLS pkg))) + (unless (> fail-count +fail-count-limit+) + (format t "Not same symbol: ~S ~S~%" sym sym2)) + (when (= fail-count +fail-count-limit+) + (format t "Further messages suppressed~%")) + (incf fail-count) + (return-from fail nil)) + (unless (eq access access2) + (unless (> fail-count +fail-count-limit+) + (format t "Not same access type: ~S ~S ~S~%" + sym access access2)) + (when (= fail-count +fail-count-limit+) + (format t "Further messages suppressed~%")) + (incf fail-count) + (return-from fail nil))))))) + ;; now, check that each symbol in each package has + ;; been properly found + (loop + for p in ,pkg-list-var do + (block fail + (do-symbols (sym p) + (multiple-value-bind (sym2 access) + (find-symbol (symbol-name sym) p) + (unless (eq sym sym2) + (unless (> fail-count +fail-count-limit+) + (format t "Not same symbol (2): ~S ~S~%" + sym sym2)) + (when (= fail-count +fail-count-limit+) + (format t "Further messages suppressed~%")) + (incf fail-count) + (return-from fail nil)) + (unless (or (not (member access + (quote ,(copy-list symbol-types)))) + (gethash sym ,cht-var)) + (format t "Symbol not found: ~S~%" sym) + (incf fail-count) + (return-from fail nil)))))) + (or (zerop fail-count) fail-count)))) + +(defun with-package-iterator-internal (packages) + (test-with-package-iterator packages :internal)) + +(defun with-package-iterator-external (packages) + (test-with-package-iterator packages :external)) + +(defun with-package-iterator-inherited (packages) + (test-with-package-iterator packages :inherited)) + +(defun with-package-iterator-all (packages) + (test-with-package-iterator packages :internal :external :inherited)) + +(deftest with-package-iterator-1 + (with-package-iterator-internal (list (find-package "COMMON-LISP-USER"))) + t) + +(deftest with-package-iterator-2 + (with-package-iterator-external (list (find-package "COMMON-LISP-USER"))) + t) + +(deftest with-package-iterator-3 + (with-package-iterator-inherited (list (find-package "COMMON-LISP-USER"))) + t) + +(deftest with-package-iterator-4 + (with-package-iterator-all (list (find-package "COMMON-LISP-USER"))) + t) + +;; Should test on some packages containing shadowed symbols, +;; multiple inheritance + +(deftest with-package-iterator-5 + (handler-case + (with-package-iterator-all '("A")) + (error (c) c)) + t) + +(deftest with-package-iterator-6 + (handler-case + (with-package-iterator-all '(#:|A|)) + (error (c) c)) + t) + +(deftest with-package-iterator-7 + (handler-case + (with-package-iterator-all '(#\A)) + (error (c) c)) + t) + +(deftest with-package-iterator-8 + (handler-case + (with-package-iterator-internal (list (find-package "A"))) + (error (c) c)) + t) + +(deftest with-package-iterator-9 + (handler-case + (with-package-iterator-external (list (find-package "A"))) + (error (c) c)) + t) + +(deftest with-package-iterator-10 + (handler-case + (with-package-iterator-inherited (list (find-package "A"))) + (error (c) c)) + t) + +;; Check that if no access symbols are provided, a program error is +;; raised +#| +(deftest with-package-iterator-11 + (handler-case + (progn + (test-with-package-iterator (list (find-package "COMMON-LISP-USER"))) + nil) + (program-error () t) + (error (c) c)) + t) +|# + +;; Paul Werkowski" <pw@snoopy.mv.com> pointed out that +;; test is broken. Here's a version of the replacement' +;; he suggested. +;; +;; I'm not sure if this is correct either; it depends on +;; whether with-package-iterator should signal the error +;; at macro expansion time or at run time. +;; +(deftest with-package-iterator-11 + (handler-case (macroexpand-1 + '(with-package-iterator (x "COMMON-LISP-USER"))) + (program-error () t) + (error (c) c)) + t) + +;; Apply to all packages +(deftest with-package-iterator-12 + (handler-case + (loop + for p in (list-all-packages) count + (handler-case + (progn + (format t "Package ~S~%" p) + (not (with-package-iterator-internal (list p)))) + (error (c) + (format "Error ~S on package ~A~%" c p) + t))) + (error (c) c)) + 0) + +(deftest with-package-iterator-13 + (handler-case + (loop + for p in (list-all-packages) count + (handler-case + (progn + (format t "Package ~S~%" p) + (not (with-package-iterator-external (list p)))) + (error (c) + (format "Error ~S on package ~A~%" c p) + t))) + (error (c) c)) + 0) + +(deftest with-package-iterator-14 + (handler-case + (loop + for p in (list-all-packages) count + (handler-case + (progn + (format t "Package ~S~%" p) + (not (with-package-iterator-inherited (list p)))) + (error (c) + (format t "Error ~S on package ~S~%" c p) + t))) + (condition (c) c)) + 0) diff --git a/ansi-tests/packages-11.lsp b/ansi-tests/packages-11.lsp new file mode 100644 index 0000000000000000000000000000000000000000..6a30101f04ca9df0cfa2a315c4ca16c3a77a0d4e --- /dev/null +++ b/ansi-tests/packages-11.lsp @@ -0,0 +1,127 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 25 08:04:19 1998 +;;;; Contains: Package test code, part 11 + +(in-package :cl-test) +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; unexport + +(deftest unexport-1 + (handler-case + (progn + (ignore-errors (delete-package "X")) + (let* ((p (make-package "X" :use nil)) + (r (export (intern "X" p) p))) + (multiple-value-bind (sym1 access1) + (find-symbol "X" p) + (unexport sym1 p) + (multiple-value-bind (sym2 access2) + (find-symbol "X" p) + (and (eq r t) + (eq sym1 sym2) + (eq access1 :external) + (eq access2 :internal) + (equal (symbol-name sym1) "X")))))) + (error (c) c)) + t) + +(deftest unexport-2 + (handler-case + (progn + (ignore-errors (delete-package "X")) + (let* ((p (make-package "X" :use nil)) + (r (export (intern "X" p) p))) + (multiple-value-bind (sym1 access1) + (find-symbol "X" p) + (unexport (list sym1) "X") + (multiple-value-bind (sym2 access2) + (find-symbol "X" p) + (and (eq sym1 sym2) + (eq r t) + (eq access1 :external) + (eq access2 :internal) + (equal (symbol-name sym1) "X")))))) + (error (c) c)) + t) + +(deftest unexport-3 + (handler-case + (progn + (ignore-errors (delete-package "X")) + (let* ((p (make-package "X" :use nil)) + (r1 (export (intern "X" p) p)) + (r2 (export (intern "Y" p) p))) + (multiple-value-bind (sym1 access1) + (find-symbol "X" p) + (multiple-value-bind (sym1a access1a) + (find-symbol "Y" p) + (unexport (list sym1 sym1a) '#:|X|) + (multiple-value-bind (sym2 access2) + (find-symbol "X" p) + (multiple-value-bind (sym2a access2a) + (find-symbol "Y" p) + (and (eq sym1 sym2) + (eq sym1a sym2a) + (eq r1 t) + (eq r2 t) + (eq access1 :external) + (eq access2 :internal) + (eq access1a :external) + (eq access2a :internal) + (equal (symbol-name sym1) "X") + (equal (symbol-name sym1a) "Y")))))))) + (error (c) c)) + t) + +(deftest unexport-4 + (handler-case + (progn + (ignore-errors (delete-package "X")) + (let* ((p (make-package "X" :use nil)) + (r (export (intern "X" p) p))) + (multiple-value-bind (sym1 access1) + (find-symbol "X" p) + (unexport (list sym1) #\X) + (multiple-value-bind (sym2 access2) + (find-symbol "X" p) + (and (eq sym1 sym2) + (eq r t) + (eq access1 :external) + (eq access2 :internal) + (equal (symbol-name sym1) "X")))))) + (error (c) c)) + t) + +;; Check that it signals a package error when unexporting +;; an inaccessible symbol + +(deftest unexport-5 + (handler-case + (progn + (when (find-package "X") (delete-package "X")) + (unexport 'a (make-package "X" :use nil)) + nil) + (package-error () t) + (error (c) c)) + t) + +;; Check that internal symbols are left alone + +(deftest unexport-6 + (handler-case + (progn + (when (find-package "X") (delete-package "X")) + (let ((p (make-package "X" :use nil))) + (let* ((sym (intern "FOO" p)) + (r (unexport sym p))) + (multiple-value-bind (sym2 access) + (find-symbol "FOO" p) + (and (eq r t) + (eq access :internal) + (eq sym sym2) + (equal (symbol-name sym) "FOO")))))) + (error (c) c)) + t) diff --git a/ansi-tests/packages-12.lsp b/ansi-tests/packages-12.lsp new file mode 100644 index 0000000000000000000000000000000000000000..9b8831b4904c0a077018e80c7bd75f59a63243ec --- /dev/null +++ b/ansi-tests/packages-12.lsp @@ -0,0 +1,240 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 25 08:04:56 1998 +;;;; Contains: Package test code, part 12 + +(in-package :cl-test) +(declaim (optimize (safety 3))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; unintern + +;; Simple unintern of an internal symbol, package explicitly +;; given as a package object +(deftest unintern-1 + (progn + (when (packagep (find-package "H")) + (delete-package "H")) + (prog1 + (let ((p (make-package "H"))) + (intern "FOO" p) + (multiple-value-bind (sym access) + (find-symbol "FOO" p) + (and + (eq access :internal) + (unintern sym p) + (null (symbol-package sym)) + (not (find-symbol "FOO" p))))) + (delete-package "H"))) + t) + +;; Simple unintern, package taken from the *PACKAGES* +;; special variable (should this have unwind protect?) +(deftest unintern-2 + (progn + (when (packagep (find-package "H")) + (delete-package "H")) + (prog1 + (let ((*PACKAGE* (make-package "H"))) + (declare (special *PACKAGE*)) + (intern "FOO") + (multiple-value-bind (sym access) + (find-symbol "FOO") + (and + (eq access :internal) + (unintern sym) + (null (symbol-package sym)) + (not (find-symbol "FOO"))))) + (delete-package "H"))) + t) + +;; Simple unintern, package given as string +(deftest unintern-3 + (progn + (when (packagep (find-package "H")) + (delete-package "H")) + (prog1 + (let ((p (make-package "H"))) + (intern "FOO" p) + (multiple-value-bind (sym access) + (find-symbol "FOO" p) + (and + (eq access :internal) + (unintern sym "H") + (null (symbol-package sym)) + (not (find-symbol "FOO" p))))) + (delete-package "H"))) + t) + +;; Simple unintern, package given as symbol +(deftest unintern-4 + (progn + (when (packagep (find-package "H")) + (delete-package "H")) + (prog1 + (let ((p (make-package "H"))) + (intern "FOO" p) + (multiple-value-bind (sym access) + (find-symbol "FOO" p) + (and + (eq access :internal) + (unintern sym '#:|H|) + (null (symbol-package sym)) + (not (find-symbol "FOO" p))))) + (delete-package "H"))) + t) + +;; Simple unintern, package given as character +(deftest unintern-5 + (handler-case + (progn + (when (packagep (find-package "H")) + (delete-package "H")) + (prog1 + (let ((p (make-package "H"))) + (intern "FOO" p) + (multiple-value-bind (sym access) + (find-symbol "FOO" p) + (and + (eq access :internal) + (unintern sym #\H) + (null (symbol-package sym)) + (not (find-symbol "FOO" p))))) + (delete-package "H"))) + (error (c) c)) + t) + + +;; Test more complex examples of unintern + +;; Unintern an external symbol that is also inherited + +(deftest unintern-6 + (handler-case + (progn + (ignore-errors (delete-package "H")) + (ignore-errors (delete-package "G")) + (make-package "G") + (export (intern "FOO" "G") "G") + (make-package "H" :use '("G")) + (export (intern "FOO" "H") "H") + ;; At this point, G:FOO is also an external + ;; symbol of H. + (multiple-value-bind (sym1 access1) + (find-symbol "FOO" "H") + (and sym1 + (eq access1 :external) + (equal "FOO" (symbol-name sym1)) + (eq (find-package "G") + (symbol-package sym1)) + (unintern sym1 "H") + (multiple-value-bind (sym2 access2) + (find-symbol "FOO" "H") + (and (eq sym1 sym2) + (eq (symbol-package sym1) + (find-package "G")) + (eq access2 :inherited)))))) + (error (c) c)) + t) + +;; unintern a symbol that is shadowing another symbol + +(deftest unintern-7 + (block failed + (ignore-errors (delete-package "H")) + (ignore-errors (delete-package "G")) + (let* ((pg (make-package "G")) + (ph (make-package "H" :use (list pg)))) + (handler-case + (shadow "FOO" ph) + (error (c) (return-from failed (list :shadow-error c)))) + (export (intern "FOO" pg) pg) + ;; At this point, H::FOO shadows G:FOO + (multiple-value-bind (sym1 access1) + (find-symbol "FOO" ph) + (and + sym1 + (eq (symbol-package sym1) ph) + (eq access1 :internal) + (equal (list sym1) (package-shadowing-symbols ph)) + (unintern sym1 ph) + (multiple-value-bind (sym2 access2) + (find-symbol "FOO" ph) + (and (not (eq sym1 sym2)) + (eq access2 :inherited) + (null (symbol-package sym1)) + (eq (symbol-package sym2) pg))))))) + t) + +;; Error situation: when the symbol is uninterned, creates +;; a name conflict from two used packages +(deftest unintern-8 + (block failed + (ignore-errors (delete-package "H")) + (ignore-errors (delete-package "G1")) + (ignore-errors (delete-package "G2")) + (let* ((pg1 (make-package "G1")) + (pg2 (make-package "G2")) + (ph (make-package "H" :use (list pg1 pg2)))) + (handler-case + (shadow "FOO" ph) + (error (c) (return-from failed (list :shadow-error c)))) + (let ((gsym1 (intern "FOO" pg1)) + (gsym2 (intern "FOO" pg2))) + (export gsym1 pg1) + (export gsym2 pg2) + (multiple-value-bind (sym1 access1) + (find-symbol "FOO" ph) + (and + (equal (list sym1) (package-shadowing-symbols ph)) + (not (eq sym1 gsym1)) + (not (eq sym1 gsym2)) + (eq (symbol-package sym1) ph) + (eq access1 :internal) + (equal (symbol-name sym1) "FOO") + (handler-case + (progn + (unintern sym1 ph) + nil) + (error (c) + (format t "Properly threw an error: ~S~%" c) + t))))))) + t) + +;; Now, inherit the same symbol through two intermediate +;; packages. No error should occur when the shadowing +;; is removed +(deftest unintern-9 + (block failed + (ignore-errors (delete-package "H")) + (ignore-errors (delete-package "G1")) + (ignore-errors (delete-package "G2")) + (ignore-errors (delete-package "G3")) + (let* ((pg3 (make-package "G3")) + (pg1 (make-package "G1" :use (list pg3))) + (pg2 (make-package "G2" :use (list pg3))) + (ph (make-package "H" :use (list pg1 pg2)))) + (handler-case + (shadow "FOO" ph) + (error (c) (return-from failed (list :shadow-error c)))) + (let ((gsym (intern "FOO" pg3))) + (export gsym pg3) + (export gsym pg1) + (export gsym pg2) + (multiple-value-bind (sym access) + (find-symbol "FOO" ph) + (and + (equal (list sym) (package-shadowing-symbols ph)) + (not (eq sym gsym)) + (equal (symbol-name sym) "FOO") + (equal (symbol-package sym) ph) + (eq access :internal) + (handler-case + (and (unintern sym ph) + (multiple-value-bind (sym2 access2) + (find-symbol "FOO" ph) + (and (eq gsym sym2) + (eq access2 :inherited)))) + (error (c) c))))))) + t) diff --git a/ansi-tests/packages-13.lsp b/ansi-tests/packages-13.lsp new file mode 100644 index 0000000000000000000000000000000000000000..ebe2c5bf0fd0a328a26ba30f381ebf986d20dcce --- /dev/null +++ b/ansi-tests/packages-13.lsp @@ -0,0 +1,54 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 25 08:06:03 1998 +;;;; Contains: Package test code, part 13 + +(in-package :cl-test) +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; in-package + +(deftest in-package-1 + (let ((*package* *package*)) + (declare (special *package*)) + (let ((p2 (in-package "A"))) + (and (eq p2 (find-package "A")) + (eq *package* p2)))) + t) + +(deftest in-package-2 + (let ((*package* *package*)) + (declare (special *package*)) + (let ((p2 (in-package |A|))) + (and (eq p2 (find-package "A")) + (eq *package* p2)))) + t) + +(deftest in-package-3 + (let ((*package* *package*)) + (declare (special *package*)) + (let ((p2 (in-package :|A|))) + (and (eq p2 (find-package "A")) + (eq *package* p2)))) + t) + +(deftest in-package-4 + (let ((*package* *package*)) + (declare (special *package*)) + (handler-case + (let ((p2 (in-package #\A))) + (and (eq p2 (find-package "A")) + (eq *package* p2))) + (error (c) c))) + t) + +(deftest in-package-5 + (let ((*package* *package*)) + (declare (special *package*)) + (ignore-errors (delete-package "H")) + (handler-case + (in-package "H") + (package-error () 'package-error) + (error (c) c))) + package-error) \ No newline at end of file diff --git a/ansi-tests/packages-14.lsp b/ansi-tests/packages-14.lsp new file mode 100644 index 0000000000000000000000000000000000000000..20304bbae620d2dba830d9276bf59f7592d7cb68 --- /dev/null +++ b/ansi-tests/packages-14.lsp @@ -0,0 +1,184 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 25 08:06:48 1998 +;;;; Contains: Package test code, part 14 + +(in-package :cl-test) +(declaim (optimize (safety 3))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; unuse-package + +(deftest unuse-package-1 + (progn + (ignore-errors (delete-package "H")) + (ignore-errors (delete-package "G")) + (let* ((pg (make-package "G" :use nil)) + (ph (make-package "H" :use '("G")))) + (prog1 + (and + (equal (package-use-list ph) (list pg)) + (equal (package-used-by-list pg) (list ph)) + (unuse-package pg ph) + (equal (package-use-list ph) nil) + (equal (package-used-by-list pg) nil)) + (delete-package "H") + (delete-package "G")))) + t) + +(deftest unuse-package-2 + (progn + (ignore-errors (delete-package "H")) + (ignore-errors (delete-package "G")) + (let* ((pg (make-package "G" :use nil)) + (ph (make-package "H" :use '("G")))) + (prog1 + (and + (equal (package-use-list ph) (list pg)) + (equal (package-used-by-list pg) (list ph)) + (unuse-package "G" ph) + (equal (package-use-list ph) nil) + (equal (package-used-by-list pg) nil)) + (delete-package "H") + (delete-package "G")))) + t) + +(deftest unuse-package-3 + (progn + (ignore-errors (delete-package "H")) + (ignore-errors (delete-package "G")) + (let* ((pg (make-package "G" :use nil)) + (ph (make-package "H" :use '("G")))) + (prog1 + (and + (equal (package-use-list ph) (list pg)) + (equal (package-used-by-list pg) (list ph)) + (unuse-package :|G| ph) + (equal (package-use-list ph) nil) + (equal (package-used-by-list pg) nil)) + (delete-package "H") + (delete-package "G")))) + t) + +(deftest unuse-package-4 + (progn + (ignore-errors (delete-package "H")) + (ignore-errors (delete-package "G")) + (let* ((pg (make-package "G" :use nil)) + (ph (make-package "H" :use '("G")))) + (prog1 + (and + (equal (package-use-list ph) (list pg)) + (equal (package-used-by-list pg) (list ph)) + (ignore-errors (unuse-package #\G ph)) + (equal (package-use-list ph) nil) + (equal (package-used-by-list pg) nil)) + (delete-package "H") + (delete-package "G")))) + t) + +(deftest unuse-package-5 + (progn + (ignore-errors (delete-package "H")) + (ignore-errors (delete-package "G")) + (let* ((pg (make-package "G" :use nil)) + (ph (make-package "H" :use '("G")))) + (prog1 + (and + (equal (package-use-list ph) (list pg)) + (equal (package-used-by-list pg) (list ph)) + (unuse-package (list pg) ph) + (equal (package-use-list ph) nil) + (equal (package-used-by-list pg) nil)) + (delete-package "H") + (delete-package "G")))) + t) + +(deftest unuse-package-6 + (progn + (ignore-errors (delete-package "H")) + (ignore-errors (delete-package "G")) + (let* ((pg (make-package "G" :use nil)) + (ph (make-package "H" :use '("G")))) + (prog1 + (and + (equal (package-use-list ph) (list pg)) + (equal (package-used-by-list pg) (list ph)) + (unuse-package (list "G") ph) + (equal (package-use-list ph) nil) + (equal (package-used-by-list pg) nil)) + (delete-package "H") + (delete-package "G")))) + t) + +(deftest unuse-package-7 + (progn + (ignore-errors (delete-package "H")) + (ignore-errors (delete-package "G")) + (let* ((pg (make-package "G" :use nil)) + (ph (make-package "H" :use '("G")))) + (prog1 + (and + (equal (package-use-list ph) (list pg)) + (equal (package-used-by-list pg) (list ph)) + (unuse-package (list :|G|) ph) + (equal (package-use-list ph) nil) + (equal (package-used-by-list pg) nil)) + (delete-package "H") + (delete-package "G")))) + t) + +(deftest unuse-package-8 + (progn + (ignore-errors (delete-package "H")) + (ignore-errors (delete-package "G")) + (let* ((pg (make-package "G" :use nil)) + (ph (make-package "H" :use '("G")))) + (prog1 + (and + (equal (package-use-list ph) (list pg)) + (equal (package-used-by-list pg) (list ph)) + (ignore-errors (unuse-package (list #\G) ph)) + (equal (package-use-list ph) nil) + (equal (package-used-by-list pg) nil)) + (delete-package "H") + (delete-package "G")))) + t) + +;; Now test with multiple packages + +(deftest unuse-package-9 + (progn + (dolist (p '("H1" "H2" "G1" "G2" "G3")) + (ignore-errors (delete-package p))) + (let* ((pg1 (make-package "G1" :use nil)) + (pg2 (make-package "G2" :use nil)) + (pg3 (make-package "G3" :use nil)) + (ph1 (make-package "H1" :use (list pg1 pg2 pg3))) + (ph2 (make-package "H2" :use (list pg1 pg2 pg3)))) + (let ((pubg1 (sort-package-list (package-used-by-list pg1))) + (pubg2 (sort-package-list (package-used-by-list pg2))) + (pubg3 (sort-package-list (package-used-by-list pg3))) + (puh1 (sort-package-list (package-use-list ph1))) + (puh2 (sort-package-list (package-use-list ph2)))) + (prog1 + (and + (= (length (remove-duplicates (list pg1 pg2 pg3 ph1 ph2))) + 5) + (equal (list ph1 ph2) pubg1) + (equal (list ph1 ph2) pubg2) + (equal (list ph1 ph2) pubg3) + (equal (list pg1 pg2 pg3) puh1) + (equal (list pg1 pg2 pg3) puh2) + (unuse-package (list pg1 pg3) ph1) + (equal (package-use-list ph1) (list pg2)) + (equal (package-used-by-list pg1) (list ph2)) + (equal (package-used-by-list pg3) (list ph2)) + (equal (sort-package-list (package-use-list ph2)) + (list pg1 pg2 pg3)) + (equal (sort-package-list (package-used-by-list pg2)) + (list ph1 ph2))) + (dolist (p '("H1" "H2" "G1" "G2" "G3")) + (ignore-errors (delete-package p))))))) + t) diff --git a/ansi-tests/packages-15.lsp b/ansi-tests/packages-15.lsp new file mode 100644 index 0000000000000000000000000000000000000000..5e7691e22823f5aa4b68d0ff11e2194f076a0997 --- /dev/null +++ b/ansi-tests/packages-15.lsp @@ -0,0 +1,193 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 25 08:08:41 1998 +;;;; Contains: Package test code, part 15 + +(in-package :cl-test) +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; use-package + +(deftest use-package-1 + (progn + (ignore-errors (delete-package "H")) + (ignore-errors (delete-package "G")) + (let* ((pg (make-package "G" :use nil)) + (ph (make-package "H" :use nil)) + (sym1 (intern "FOO" pg))) + (and + (eq (export sym1 pg) t) + (null (package-used-by-list pg)) + (null (package-used-by-list ph)) + (null (package-use-list pg)) + (null (package-use-list ph)) + (eq (use-package pg ph) t) ;; "H" will use "G" + (multiple-value-bind (sym2 access) + (find-symbol "FOO" ph) + (and + (eq access :inherited) + (eq sym1 sym2))) + (equal (package-use-list ph) (list pg)) + (equal (package-used-by-list pg) (list ph)) + (null (package-use-list pg)) + (null (package-used-by-list ph)) + (eq (unuse-package pg ph) t) + (null (find-symbol "FOO" ph))))) + t) + +(deftest use-package-2 + (progn + (ignore-errors (delete-package "H")) + (ignore-errors (delete-package "G")) + (let* ((pg (make-package "G" :use nil)) + (ph (make-package "H" :use nil)) + (sym1 (intern "FOO" pg))) + (and + (eq (export sym1 pg) t) + (null (package-used-by-list pg)) + (null (package-used-by-list ph)) + (null (package-use-list pg)) + (null (package-use-list ph)) + (eq (use-package "G" "H") t) ;; "H" will use "G" + (multiple-value-bind (sym2 access) + (find-symbol "FOO" ph) + (and + (eq access :inherited) + (eq sym1 sym2))) + (equal (package-use-list ph) (list pg)) + (equal (package-used-by-list pg) (list ph)) + (null (package-use-list pg)) + (null (package-used-by-list ph)) + (eq (unuse-package pg ph) t) + (null (find-symbol "FOO" ph))))) + t) + +(deftest use-package-3 + (progn + (ignore-errors (delete-package "H")) + (ignore-errors (delete-package "G")) + (let* ((pg (make-package "G" :use nil)) + (ph (make-package "H" :use nil)) + (sym1 (intern "FOO" pg))) + (and + (eq (export sym1 pg) t) + (null (package-used-by-list pg)) + (null (package-used-by-list ph)) + (null (package-use-list pg)) + (null (package-use-list ph)) + (eq (use-package '#:|G| '#:|H|) t) ;; "H" will use "G" + (multiple-value-bind (sym2 access) + (find-symbol "FOO" ph) + (and + (eq access :inherited) + (eq sym1 sym2))) + (equal (package-use-list ph) (list pg)) + (equal (package-used-by-list pg) (list ph)) + (null (package-use-list pg)) + (null (package-used-by-list ph)) + (eq (unuse-package pg ph) t) + (null (find-symbol "FOO" ph))))) + t) + +(deftest use-package-4 + (progn + (ignore-errors (delete-package "H")) + (ignore-errors (delete-package "G")) + (let* ((pg (make-package "G" :use nil)) + (ph (make-package "H" :use nil)) + (sym1 (intern "FOO" pg))) + (and + (eq (export sym1 pg) t) + (null (package-used-by-list pg)) + (null (package-used-by-list ph)) + (null (package-use-list pg)) + (null (package-use-list ph)) + (eq (ignore-errors (use-package #\G #\H)) + t) ;; "H" will use "G" + (multiple-value-bind (sym2 access) + (find-symbol "FOO" ph) + (and + (eq access :inherited) + (eq sym1 sym2))) + (equal (package-use-list ph) (list pg)) + (equal (package-used-by-list pg) (list ph)) + (null (package-use-list pg)) + (null (package-used-by-list ph)) + (eq (unuse-package pg ph) t) + (null (find-symbol "FOO" ph))))) + t) + +;; use lists of packages + +(deftest use-package-5 + (let ((pkgs '("H" "G1" "G2" "G3")) + (vars '("FOO1" "FOO2" "FOO3"))) + (dolist (p pkgs) + (ignore-errors (delete-package p)) + (make-package p :use nil)) + (and + (every (complement #'package-use-list) pkgs) + (every (complement #'package-used-by-list) pkgs) + (every #'(lambda (v p) + (export (intern v p) p)) + vars (cdr pkgs)) + (progn + (dolist (p (cdr pkgs)) (intern "MINE" p)) + (eq (use-package (cdr pkgs) (car pkgs)) t)) + (every #'(lambda (v p) + (eq (find-symbol v p) + (find-symbol v (car pkgs)))) + vars (cdr pkgs)) + (null (find-symbol "MINE" (car pkgs))) + (every #'(lambda (p) + (equal (package-used-by-list p) + (list (find-package (car pkgs))))) + (cdr pkgs)) + (equal (sort-package-list (package-use-list (car pkgs))) + (mapcar #'find-package (cdr pkgs))) + (every (complement #'package-use-list) (cdr pkgs)) + (null (package-used-by-list (car pkgs))))) + t) + +;; Circular package use + +(deftest use-package-6 + (progn + (ignore-errors (delete-package "H")) + (ignore-errors (delete-package "G")) + (let ((pg (make-package "G")) + (ph (make-package "H")) + sym1 sym2 sym3 sym4 + a1 a2 a3 a4) + (prog1 + (and + (export (intern "X" pg) pg) + (export (intern "Y" ph) ph) + (use-package pg ph) + (use-package ph pg) + (progn + (multiple-value-setq + (sym1 a1) (find-symbol "X" pg)) + (multiple-value-setq + (sym2 a2) (find-symbol "Y" ph)) + (multiple-value-setq + (sym3 a3) (find-symbol "Y" pg)) + (multiple-value-setq + (sym4 a4) (find-symbol "X" ph)) + (and + (eq a1 :external) + (eq a2 :external) + (eq a3 :inherited) + (eq a4 :inherited) + (eq sym1 sym4) + (eq sym2 sym3) + (eq (symbol-package sym1) pg) + (eq (symbol-package sym2) ph) + (unuse-package pg ph) + (unuse-package ph pg)))) + (ignore-errors (delete-package pg)) + (ignore-errors (delete-package ph))))) + t) + +;; Also: need to check that *PACKAGE* is used as a default diff --git a/ansi-tests/packages-16.lsp b/ansi-tests/packages-16.lsp new file mode 100644 index 0000000000000000000000000000000000000000..b3eee37d56cb70df2ee0dfad07a32b988a651c1c --- /dev/null +++ b/ansi-tests/packages-16.lsp @@ -0,0 +1,626 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 25 08:09:18 1998 +;;;; Contains: Package test code, part 16 + +(in-package :cl-test) +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; defpackage + +;; Test basic defpackage call, with no options +;; The use-list is implementation dependent, so +;; we don't examine it here. +;; Try several ways of specifying the package name. +(deftest defpackage-1 + (handler-case + (loop + for n in '("H" #:|H| #\H) count + (not + (progn + (ignore-errors (delete-package "H")) + (let ((p (ignore-errors (eval `(defpackage ,n))))) + (and + (packagep p) + (equal (package-name p) "H") + ;; (equal (package-use-list p) nil) + (equal (package-used-by-list p) nil) + (equal (package-nicknames p) nil) + (equal (package-shadowing-symbols p) nil) + (null (documentation p t)) + ))))) + (error (c) c)) + 0) + +;; Test :nicknames option +;; Do not check use-list, because it is implementation dependent +;; Try several ways of specifying a nickname. +(deftest defpackage-2 + (loop + for n in '("I" #:|I| #\I) count + (not + (ignore-errors + (progn + (ignore-errors (delete-package "H")) + (let ((p (ignore-errors + (eval `(defpackage "H" (:nicknames ,n "J")))))) + (and + (packagep p) + (equal (package-name p) "H") + ;; (equal (package-use-list p) nil) + (equal (package-used-by-list p) nil) + (equal (sort (copy-list (package-nicknames p)) + #'string<) + '("I" "J")) + (equal (package-shadowing-symbols p) nil) + (null (documentation p t)) + )))))) + 0) + +;; Test defpackage with documentation option +;; Do not check use-list, because it is implementation dependent +(deftest defpackage-3 + (progn + (ignore-errors (delete-package "H")) + (ignore-errors + (let ((p (eval '(defpackage "H" (:documentation "This is a doc string"))))) + (and + (packagep p) + (equal (package-name p) "H") + ;; (equal (package-use-list p) nil) + (equal (package-used-by-list p) nil) + (equal (package-nicknames p) nil) + (equal (package-shadowing-symbols p) nil) + (equal (documentation p t) + "This is a doc string") + )))) + t) + +;; Check use argument +;; Try several ways of specifying the package to be used +(deftest defpackage-4 + (loop + for n in '("A" :|A| #\A) count + (not + (ignore-errors + (progn + (ignore-errors (delete-package "H")) + (let ((p (ignore-errors (eval `(defpackage "H" (:use ,n)))))) + (and + (packagep p) + (equal (package-name p) "H") + (equal (package-use-list p) (list (find-package "A"))) + (equal (package-used-by-list p) nil) + (equal (package-nicknames p) nil) + (equal (package-shadowing-symbols p) nil) + (eql (num-symbols-in-package p) + (num-external-symbols-in-package "A")) + (equal (documentation p t) nil) + )))))) + 0) + +;; Test defpackage shadow option, and null use +(deftest defpackage-5 + (progn + (ignore-errors (delete-package "H")) + (ignore-errors + (let ((p (ignore-errors (eval `(defpackage "H" (:use) + (:shadow "foo")))))) + (and + (packagep p) + (equal (package-name p) "H") + (equal (package-use-list p) nil) + (equal (package-used-by-list p) nil) + (equal (package-nicknames p) nil) + (eql (num-symbols-in-package p) 1) + (multiple-value-bind (sym access) + (find-symbol "foo" p) + (and (eq access :internal) + (equal (symbol-name sym) "foo") + (equal (symbol-package sym) p) + (equal (package-shadowing-symbols p) + (list sym)))) + (equal (documentation p t) nil) + )))) + t) + +;; Test defpackage shadow and null use, with several ways +;; of specifying the name of the shadowed symbol +(deftest defpackage-6 + (loop + for s in '(:|f| #\f) count + (not + (ignore-errors + (ignore-errors (delete-package "H")) + (let ((p (ignore-errors (eval `(defpackage "H" + (:use) + (:shadow ,s)))))) + (and + (packagep p) + (equal (package-name p) "H") + (equal (package-use-list p) nil) + (equal (package-used-by-list p) nil) + (equal (package-nicknames p) nil) + (eql (num-symbols-in-package p) 1) + (multiple-value-bind (sym access) + (find-symbol "f" p) + (and (eq access :internal) + (equal (symbol-name sym) "f") + (equal (symbol-package sym) p) + (equal (package-shadowing-symbols p) + (list sym)))) + (equal (documentation p t) nil) + ))))) + 0) + + +;; Testing defpackage with shadowing-import-from. +;; Test several ways of specifying the symbol name +(deftest defpackage-7 + (progn + (ignore-errors (delete-package "H")) + (ignore-errors (delete-package "G")) + (let ((pg (make-package "G" :use nil))) + ;; Populate package G with several symbols + (export (intern "A" pg) pg) + (export (intern "foo" pg) pg) + (intern "bar" pg) + ;; Do test with several ways of specifying the + ;; shadowing-imported symbol + (loop + for n in '("A" :|A| #\A) count + (not + (ignore-errors + (ignore-errors (delete-package "H")) + (let ((p (ignore-errors + (eval + `(defpackage "H" + (:use) + (:shadowing-import-from "G" ,n)))))) + (and + (packagep p) + (equal (package-name p) "H") + (equal (package-use-list p) nil) + (equal (package-used-by-list p) nil) + (equal (package-nicknames p) nil) + (eql (num-symbols-in-package p) 1) + (multiple-value-bind (sym access) + (find-symbol "A" p) + (and (eq access :internal) + (equal (symbol-name sym) "A") + (equal (symbol-package sym) pg) + (equal (package-shadowing-symbols p) + (list sym)))) + (equal (documentation p t) nil) + ))))))) + 0) + +;; Test import-from option +;; Test for each way of specifying the imported symbol name, +;; and for each way of specifying the package name from which +;; the symbol is imported +(deftest defpackage-8 + (progn + (ignore-errors (delete-package "H")) + (ignore-errors (delete-package "G")) + (let ((pg (eval '(defpackage "G" (:use) (:intern "A" "B" "C"))))) + (loop + for pn in '("G" #:|G| #\G) sum + (loop + for n in '("B" #:|B| #\B) count + (not + (ignore-errors + (ignore-errors (delete-package "H")) + (let ((p (ignore-errors + (eval `(defpackage + "H" (:use) + (:import-from ,pn ,n "A")))))) + (and + (packagep p) + (equal (package-name p) "H") + (equal (package-use-list p) nil) + (equal (package-used-by-list p) nil) + (equal (package-nicknames p) nil) + (equal (package-shadowing-symbols p) nil) + (eql (num-symbols-in-package p) 2) + (multiple-value-bind (sym access) + (find-symbol "A" p) + (and (eq access :internal) + (equal (symbol-name sym) "A") + (equal (symbol-package sym) pg))) + (multiple-value-bind (sym access) + (find-symbol "B" p) + (and (eq access :internal) + (equal (symbol-name sym) "B") + (equal (symbol-package sym) pg))) + (equal (documentation p t) nil) + )))))))) + 0) + +;; Test defpackage with export option + +(deftest defpackage-9 + (progn + (loop + for n in '("Z" #:|Z| #\Z) count + (not + (ignore-errors + (ignore-errors (delete-package "H")) + (let ((p (ignore-errors + (eval `(defpackage + "H" + (:export "Q" ,n "R") (:use)))))) + (and + (packagep p) + (equal (package-name p) "H") + (equal (package-use-list p) nil) + (equal (package-used-by-list p) nil) + (equal (package-nicknames p) nil) + (equal (package-shadowing-symbols p) nil) + (eql (num-symbols-in-package p) 3) + (loop + for s in '("Q" "Z" "R") do + (unless + (multiple-value-bind (sym access) + (find-symbol s p) + (and (eq access :external) + (equal (symbol-name sym) s) + (equal (symbol-package sym) p))) + (return nil)) + finally (return t)) + )))))) + 0) + +;; Test defpackage with the intern option + +(deftest defpackage-10 + (progn + (loop + for n in '("Z" #:|Z| #\Z) count + (not + (ignore-errors + (ignore-errors (delete-package "H")) + (let ((p (ignore-errors + (eval `(defpackage + "H" + (:intern "Q" ,n "R") (:use)))))) + (and + (packagep p) + (equal (package-name p) "H") + (equal (package-use-list p) nil) + (equal (package-used-by-list p) nil) + (equal (package-nicknames p) nil) + (equal (package-shadowing-symbols p) nil) + (eql (num-symbols-in-package p) 3) + (loop + for s in '("Q" "Z" "R") do + (unless + (multiple-value-bind (sym access) + (find-symbol s p) + (and (eq access :internal) + (equal (symbol-name sym) s) + (equal (symbol-package sym) p))) + (return nil)) + finally (return t)) + )))))) + 0) + +;; Test defpackage with size + +(deftest defpackage-11 + (ignore-errors + (ignore-errors (delete-package "H")) + (let ((p (ignore-errors + (eval '(defpackage "H" (:use) (:size 0)))))) + (and + (packagep p) + (equal (package-name p) "H") + (equal (package-use-list p) nil) + (equal (package-used-by-list p) nil) + (equal (package-nicknames p) nil) + (equal (package-shadowing-symbols p) nil) + (zerop (num-symbols-in-package p))))) + t) + +(deftest defpackage-12 + (ignore-errors + (ignore-errors (delete-package "H")) + (let ((p (ignore-errors + (eval '(defpackage "H" (:use) (:size 10000)))))) + (and + (packagep p) + (equal (package-name p) "H") + (equal (package-use-list p) nil) + (equal (package-used-by-list p) nil) + (equal (package-nicknames p) nil) + (equal (package-shadowing-symbols p) nil) + (zerop (num-symbols-in-package p))))) + t) + +;; defpackage error handling + +;; Repeated size field should cause a program-error +(deftest defpackage-13 + (progn + (ignore-errors (delete-package "H")) + (handler-case + (eval '(defpackage "H" (:use) (:size 10) (:size 20))) + (program-error () 'program-error) + (error (c) c))) + program-error) + +;; Repeated documentation field should cause a program-error +(deftest defpackage-14 + (progn + (ignore-errors (delete-package "H")) + (handler-case + (eval '(defpackage "H" (:use) + (:documentation "foo") + (:documentation "bar"))) + (program-error () 'program-error) + (error (c) c))) + program-error) + +;; When a nickname refers to an existing package or nickname, +;; signal a program-error + +(deftest defpackage-15 + (progn + (ignore-errors (delete-package "H")) + (handler-case + (eval '(defpackage "H" (:use) + (:nicknames "A"))) + (program-error () 'program-error) + (error (c) c))) + program-error) + +(deftest defpackage-16 + (progn + (ignore-errors (delete-package "H")) + (handler-case + (eval '(defpackage "H" (:use) + (:nicknames "Q"))) + (program-error () 'program-error) + (error (c) c))) + program-error) + +;; Names in :shadow, :shadowing-import-from, :import-from, and :intern +;; must be disjoint, or a package-error is signalled. + +;; :shadow and :shadowing-import-from +(deftest defpackage-17 + (ignore-errors + (ignore-errors (delete-package "H")) + (ignore-errors (delete-package "G")) + (eval '(defpackage "G" (:use) (:export "A"))) + (handler-case + (eval '(defpackage "H" (:use) + (:shadow "A") + (:shadowing-import-from "G" "A"))) + (program-error () 'program-error) + (error (c) c))) + program-error) + +;; :shadow and :import-from +(deftest defpackage-18 + (ignore-errors + (ignore-errors (delete-package "H")) + (ignore-errors (delete-package "G")) + (eval '(defpackage "G" (:use) (:export "A"))) + (handler-case + (eval '(defpackage "H" (:use) + (:shadow "A") + (:import-from "G" "A"))) + (program-error () 'program-error) + (error (c) c))) + program-error) + +;; :shadow and :intern +(deftest defpackage-19 + (progn + (ignore-errors (delete-package "H")) + (handler-case + (eval '(defpackage "H" (:use) + (:shadow "A") + (:intern "A"))) + (program-error () 'program-error) + (error (c) c))) + program-error) + +;; :shadowing-import-from and :import-from +(deftest defpackage-20 + (ignore-errors + (ignore-errors (delete-package "H")) + (ignore-errors (delete-package "G")) + (eval '(defpackage "G" (:use) (:export "A"))) + (handler-case + (eval '(defpackage "H" (:use) + (:shadowing-import-from "G" "A") + (:import-from "G" "A"))) + (program-error () 'program-error) + (error (c) c))) + program-error) + +;; :shadowing-import-from and :intern +(deftest defpackage-21 + (ignore-errors + (ignore-errors (delete-package "H")) + (ignore-errors (delete-package "G")) + (eval '(defpackage "G" (:use) (:export "A"))) + (handler-case + (eval '(defpackage "H" (:use) + (:shadowing-import-from "G" "A") + (:intern "A"))) + (program-error () 'program-error) + (error (c) c))) + program-error) + +;; :import-from and :intern +(deftest defpackage-22 + (ignore-errors + (ignore-errors (delete-package "H")) + (ignore-errors (delete-package "G")) + (eval '(defpackage "G" (:use) (:export "A"))) + (handler-case + (eval '(defpackage "H" (:use) + (:import-from "G" "A") + (:intern "A"))) + (program-error () 'program-error) + (error (c) c))) + program-error) + +;; Names given to :export and :intern must be disjoint, +;; otherwise signal a package-error +(deftest defpackage-23 + (ignore-errors + (ignore-errors (delete-package "H")) + (handler-case + (eval '(defpackage "H" (:use) + (:export "A") + (:intern "A"))) + (program-error () 'program-error) + (error (c) c))) + program-error) + +;; :shadowing-import-from signals a correctable package-error +;; if the symbol is not accessible in the named package +(deftest defpackage-24 + (ignore-errors + (ignore-errors (delete-package "H")) + (ignore-errors (delete-package "G")) + (eval '(defpackage "G" (:use))) + (handler-case + (eval '(defpackage "H" (:shadowing-import-from "G" "NOT-THERE"))) + (package-error (c) + (if (member 'abort (mapcar #'restart-name + (compute-restarts c)) + :test (complement #'eq)) + 'success + 'fail)) + (error (c) c))) + success) + +;; :import-from signals a correctable package-error if a symbol with +;; the indicated name is not accessible in the package indicated + +(deftest defpackage-25 + (ignore-errors + (ignore-errors (delete-package "H")) + (ignore-errors (delete-package "G")) + (eval '(defpackage "G" (:use))) + (handler-case + (eval '(defpackage "H" (:import-from "G" "NOT-THERE"))) + (package-error (c) + (if (member 'abort (mapcar #'restart-name + (compute-restarts c)) + :test (complement #'eq)) + 'success + 'fail)) + (error (c) c))) + success) + +;; A big test that combines all the options to defpackage + +(deftest defpackage-26 + (ignore-errors + (flet + ((%do-it% (args) + (ignore-errors (delete-package "H")) + (ignore-errors (delete-package "G1")) + (ignore-errors (delete-package "G2")) + (ignore-errors (delete-package "G3")) + (let ((pg1 + (progn + (format t "Making G1...~%") + (eval '(defpackage "G1" + (:use) + (:export "A" "B" "C") + (:intern "D" "E" "F"))))) + (pg2 + (progn + (format t "Making G2...~%") + (eval '(defpackage "G2" + (:use) + (:export "A" "D" "G") + (:intern "E" "H" "I"))))) + (pg3 + (progn + (format t "Making G3...~%") + (eval '(defpackage "G3" + (:use) + (:export "J" "K" "L") + (:intern "M" "N" "O")))))) + (let ((p (eval (list* 'defpackage "H" (copy-tree args))))) + (prog () + (unless (packagep p) (return 1)) + (unless (equal (package-name p) "H") (return 2)) + (unless (equal (package-name pg1) "G1") (return 3)) + (unless (equal (package-name pg2) "G2") (return 4)) + (unless (equal (package-name pg3) "G3") (return 5)) + (unless + (equal (sort (copy-list (package-nicknames p)) #'string<) + '("H1" "H2")) + (return 6)) + (unless + (or + (equal (package-use-list p) (list pg1 pg2)) + (equal (package-use-list p) (list pg2 pg1))) + (return 7)) + (unless (equal (package-used-by-list pg1) (list p)) + (return 8)) + (unless (equal (package-used-by-list pg2) (list p)) + (return 9)) + (when (package-used-by-list pg3) (return 10)) + (unless (equal (sort (mapcar #'symbol-name + (package-shadowing-symbols p)) + #'string<) + '("A" "B")) + (return 10)) + (let ((num 11)) + (unless + (every + #'(lambda (str acc pkg) + (multiple-value-bind + (sym access) + (find-symbol str p) + (or + (and (or (not acc) (equal (symbol-name sym) str)) + (or (not acc) (equal (symbol-package sym) pkg)) + (equal access acc) + (incf num)) + (progn + (format t + "Failed on str = ~S, acc = ~S, pkg = ~S, sym = ~S, access = ~S~%" + str acc pkg sym access) + nil)))) + (list "A" "B" "C" "D" "E" "F" "G" + "H" "I" "J" "K" "L" "M" "N" "O") + (list :internal :internal + :external :inherited + nil nil + :inherited :internal + nil nil + nil :external + nil nil + :internal) + (list pg2 p pg1 pg2 nil nil + pg2 p nil nil nil pg3 + nil nil pg3)) + (return num))) + (return 'success)))))) + (let ((args '((:nicknames "H1" "H2") + (:use "G1" "G2") + (:shadow "B") + (:shadowing-import-from "G2" "A") + (:import-from "G3" "L" "O") + (:intern "D" "H") + (:export "L" "C") + (:size 20) + (:documentation "A test package")))) + (list (%do-it% args) + (%do-it% (reverse args)))))) + (success success)) + + + diff --git a/ansi-tests/packages-17.lsp b/ansi-tests/packages-17.lsp new file mode 100644 index 0000000000000000000000000000000000000000..c5174276601b02d85428e3769ad0e380881a0fba --- /dev/null +++ b/ansi-tests/packages-17.lsp @@ -0,0 +1,142 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 25 19:20:29 1998 +;;;; Contains: Package test code, part 17 + +(in-package :cl-test) +(declaim (optimize (safety 3))) + +(deftest do-symbols-1 + (equal + (sort-symbols (let ((all nil)) + (do-symbols (x "B" all) (push x all)))) + (list (find-symbol "BAR" "B") + (find-symbol "FOO" "A"))) + t) + +;; +;; Test up some test packages +;; + +(defun collect-symbols (pkg) + (sort-symbols + (let ((all nil)) + (do-symbols (x pkg all) (push x all))))) + +(defun collect-external-symbols (pkg) + (sort-symbols + (let ((all nil)) + (do-external-symbols (x pkg all) (push x all))))) + +(deftest do-symbols-2 + (collect-symbols "DS1") + (DS1:A DS1:B DS1::C DS1::D)) + +(deftest do-symbols-3 + (collect-symbols "DS2") + (DS2:A DS2::E DS2::F DS2:G DS2:H)) + +(deftest do-symbols-4 + (collect-symbols "DS3") + (DS1:A DS3:B DS2:G DS2:H DS3:I DS3:J DS3:K DS3::L DS3::M)) + +(deftest do-symbols-5 + (remove-duplicates + (collect-symbols "DS4") + :test #'(lambda (x y) + (and (eq x y) + (not (eq x 'DS4::B))))) + (DS1:A DS1:B DS2::F DS3:G DS3:I DS3:J DS3:K DS4::X DS4::Y DS4::Z)) + + +(deftest do-external-symbols-1 + (collect-external-symbols "DS1") + (DS1:A DS1:B)) + +(deftest do-external-symbols-2 + (collect-external-symbols "DS2") + (DS2:A DS2:G DS2:H)) + +(deftest do-external-symbols-3 + (collect-external-symbols "DS3") + (DS1:A DS3:B DS2:G DS3:I DS3:J DS3:K)) + +(deftest do-external-symbols-4 + (collect-external-symbols "DS4") + ()) + +(deftest do-external-symbols-5 + (equal (collect-external-symbols "KEYWORD") + (collect-symbols "KEYWORD")) + t) + +;; Test that do-symbols, do-external-symbols work without +;; a return value (and that the default return value is nil) + +(deftest do-symbols-6 + (do-symbols (s "DS1") (declare (ignore s)) t) + nil) + +(deftest do-external-symbols-6 + (do-external-symbols (s "DS1") (declare (ignore s)) t) + nil) + +;; Test that do-symbols, do-external-symbols work without +;; a package being specified + +(deftest do-symbols-7 + (let ((x nil) + (*package* (find-package "DS1"))) + (declare (special *package*)) + (list + (do-symbols (s) (push s x)) + (sort-symbols x))) + (nil (DS1:A DS1:B DS1::C DS1::D))) + +(deftest do-external-symbols-7 + (let ((x nil) + (*package* (find-package "DS1"))) + (declare (special *package*)) + (list + (do-external-symbols (s) (push s x)) + (sort-symbols x))) + (nil (DS1:A DS1:B))) + +;; Test that the tags work in the tagbody, +;; and that multiple statements work + +(deftest do-symbols-8 + (handler-case + (let ((x nil)) + (list + (do-symbols + (s "DS1") + (when (equal (symbol-name s) "C") (go bar)) + (push s x) + (go foo) + bar + (push T x) + foo) + (sort-symbols x))) + (error (c) c)) + (NIL (DS1:A DS1:B DS1::D T))) + +(deftest do-external-symbols-8 + (handler-case + (let ((x nil)) + (list + (do-external-symbols + (s "DS1") + (when (equal (symbol-name s) "A") (go bar)) + (push s x) + (go foo) + bar + (push T x) + foo) + (sort-symbols x))) + (error (c) c)) + (NIL (DS1:B T))) + + + + diff --git a/ansi-tests/packages-18.lsp b/ansi-tests/packages-18.lsp new file mode 100644 index 0000000000000000000000000000000000000000..662a232e9680148971546bff01988a69a77b92dd --- /dev/null +++ b/ansi-tests/packages-18.lsp @@ -0,0 +1,96 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 25 08:07:31 1998 +;;;; Contains: Package test code, part 18 + +(in-package :cl-test) +(declaim (optimize (safety 3))) + +(declaim (special *universe*)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; packagep, typep * 'package + +(deftest packagep-1 + (loop + for x in *universe* count + (unless (eq (not (not (packagep x))) + (not (not (typep x 'package)))) + (format t + "(packagep ~S) = ~S, (typep x 'package) = ~S~%" + x (packagep x) x (typep x 'package)) + t)) + 0) + +;; *package* is always a package + +(deftest packagep-2 + (not (not (packagep *package*))) + t) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; package-error + +(deftest package-error-1 + (not (not + (typep (make-condition 'package-error :package "CL") + 'package-error))) + t) + +(deftest package-error-2 + (not (not + (typep (make-condition 'package-error + :package (find-package "CL")) + 'package-error))) + t) + +(deftest package-error-3 + (subtypep 'package-error 'error) + t t) + +(deftest package-error-4 + (not (not + (typep (make-condition 'package-error + :package (find-package '#:|CL|)) + 'package-error))) + t) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; package-error-package + +(deftest package-error-package-1 + (handler-case + (eq (find-package (package-error-package + (make-condition 'package-error + :package "CL"))) + (find-package "CL")) + (error (c) c)) + t) + +(deftest package-error-package-2 + (handler-case + (eq (find-package (package-error-package + (make-condition 'package-error + :package (find-package "CL")))) + (find-package "CL")) + (error (c) c)) + t) + +(deftest package-error-package-3 + (handler-case + (eq (find-package (package-error-package + (make-condition 'package-error + :package '#:|CL|))) + (find-package "CL")) + (error (c) c)) + t) + +(deftest package-error-package-4 + (handler-case + (eq (find-package (package-error-package + (make-condition 'package-error + :package #\A))) + (find-package "A")) + (error (c) c)) + t) + diff --git a/ansi-tests/packages-19.lsp b/ansi-tests/packages-19.lsp new file mode 100644 index 0000000000000000000000000000000000000000..0d984c71f485636b0eeb3c1ba997a0d3b284d021 --- /dev/null +++ b/ansi-tests/packages-19.lsp @@ -0,0 +1,35 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Tue May 5 17:22:49 1998 +;;;; Contains: Packages test code, part 19. Tests of the keyword package. +;;;; See also cl-symbols.lsp (for keywordp test cases) + +(in-package :cl-test) +(declaim (optimize (safety 3))) + +;; Check that each keyword satisfies keywordp + +(deftest keyword-1 + (do-symbols (s "KEYWORD" t) + (unless (keywordp s) + (return (list s nil)))) + t) + +;; Every keyword is external +(deftest keyword-2 + (do-symbols (s "KEYWORD" t) + (multiple-value-bind (s2 access) + (find-symbol (symbol-name s) "KEYWORD") + (unless (and (eq s s2) + (eq access :external)) + (return (list s2 access))))) + t) + +;; Every keyword evaluates to itself +(deftest keyword-3 + (do-symbols (s "KEYWORD" t) + (unless (eq s (eval s)) + (return (list s (eval s))))) + t) + + diff --git a/ansi-tests/position-if-not.lsp b/ansi-tests/position-if-not.lsp new file mode 100644 index 0000000000000000000000000000000000000000..aaa2fa61277f09f41896ac88f7a61b308faf6fee --- /dev/null +++ b/ansi-tests/position-if-not.lsp @@ -0,0 +1,439 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Aug 24 07:10:05 2002 +;;;; Contains: Tests for POSITION-IF-NOT-NOT + +(in-package :cl-test) + +(deftest position-if-not-list.1 + (position-if-not #'oddp '(1 3 1 4 3 2 1 8 9)) + 3) + +(deftest position-if-not-list.2 + (position-if-not 'oddp '(1 3 1 4 3 2 1 8 9)) + 3) + +(deftest position-if-not-list.3 + (position-if-not #'oddp '(1 3 1 4 3 2 1 8 9) :start 4) + 5) + +(deftest position-if-not-list.4 + (position-if-not #'oddp '(1 3 1 4 3 2 1 8 9) :from-end t) + 7) + +(deftest position-if-not-list.5 + (position-if-not #'oddp '(1 3 1 4 3 2 1 8 9) :from-end nil) + 3) + +(deftest position-if-not-list.6 + (position-if-not #'oddp '(1 3 1 4 3 2 1 8 9) :start 4 + :from-end t) + 7) + +(deftest position-if-not-list.7 + (position-if-not #'oddp '(1 3 1 4 3 2 1 8 9) :end nil) + 3) + +(deftest position-if-not-list.8 + (position-if-not #'oddp '(1 3 1 4 3 2 1 8 9) :end 3) + nil) + +(deftest position-if-not-list.9 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if-not #'oddp '(1 3 1 4 3 2 1 8 9) :start i :end j))) + ((nil nil nil 3 3 3 3 3 3) + (nil nil 3 3 3 3 3 3) + (nil 3 3 3 3 3 3) + (3 3 3 3 3 3) + (nil 5 5 5 5) + (5 5 5 5) + (nil 7 7) + (7 7) + (nil))) + +(deftest position-if-not-list.10 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if-not #'oddp '(1 3 1 4 3 2 1 8 9) :start i :end j + :from-end t))) + ((nil nil nil 3 3 5 5 7 7) + (nil nil 3 3 5 5 7 7) + (nil 3 3 5 5 7 7) + (3 3 5 5 7 7) + (nil 5 5 7 7) + (5 5 7 7) + (nil 7 7) + (7 7) + (nil))) + +(deftest position-if-not-list.11 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if-not #'evenp '(1 3 1 4 3 2 1 8 9) :start i :end j + :key '1+))) + ((nil nil nil 3 3 3 3 3 3) + (nil nil 3 3 3 3 3 3) + (nil 3 3 3 3 3 3) + (3 3 3 3 3 3) + (nil 5 5 5 5) + (5 5 5 5) + (nil 7 7) + (7 7) + (nil))) + +(deftest position-if-not-list.12 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if-not #'evenp '(1 3 1 4 3 2 1 8 9) :start i :end j + :key #'1+ :from-end t))) + ((nil nil nil 3 3 5 5 7 7) + (nil nil 3 3 5 5 7 7) + (nil 3 3 5 5 7 7) + (3 3 5 5 7 7) + (nil 5 5 7 7) + (5 5 7 7) + (nil 7 7) + (7 7) + (nil))) + +;;; Vector tests + +(deftest position-if-not-vector.1 + (position-if-not #'oddp #(1 3 1 4 3 2 1 8 9)) + 3) + +(deftest position-if-not-vector.2 + (position-if-not 'oddp #(1 3 1 4 3 2 1 8 9)) + 3) + +(deftest position-if-not-vector.3 + (position-if-not #'oddp #(1 3 1 4 3 2 1 8 9) :start 4) + 5) + +(deftest position-if-not-vector.4 + (position-if-not #'oddp #(1 3 1 4 3 2 1 8 9) :from-end t) + 7) + +(deftest position-if-not-vector.5 + (position-if-not #'oddp #(1 3 1 4 3 2 1 8 9) :from-end nil) + 3) + +(deftest position-if-not-vector.6 + (position-if-not #'oddp #(1 3 1 4 3 2 1 8 9) :start 4 + :from-end t) + 7) + +(deftest position-if-not-vector.7 + (position-if-not #'oddp #(1 3 1 4 3 2 1 8 9) :end nil) + 3) + +(deftest position-if-not-vector.8 + (position-if-not #'oddp #(1 3 1 4 3 2 1 8 9) :end 3) + nil) + +(deftest position-if-not-vector.9 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if-not #'oddp #(1 3 1 4 3 2 1 8 9) :start i :end j))) + ((nil nil nil 3 3 3 3 3 3) + (nil nil 3 3 3 3 3 3) + (nil 3 3 3 3 3 3) + (3 3 3 3 3 3) + (nil 5 5 5 5) + (5 5 5 5) + (nil 7 7) + (7 7) + (nil))) + +(deftest position-if-not-vector.10 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if-not #'oddp #(1 3 1 4 3 2 1 8 9) :start i :end j + :from-end t))) + ((nil nil nil 3 3 5 5 7 7) + (nil nil 3 3 5 5 7 7) + (nil 3 3 5 5 7 7) + (3 3 5 5 7 7) + (nil 5 5 7 7) + (5 5 7 7) + (nil 7 7) + (7 7) + (nil))) + +(deftest position-if-not-vector.11 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if-not #'evenp #(1 3 1 4 3 2 1 8 9) :start i :end j + :key '1+))) + ((nil nil nil 3 3 3 3 3 3) + (nil nil 3 3 3 3 3 3) + (nil 3 3 3 3 3 3) + (3 3 3 3 3 3) + (nil 5 5 5 5) + (5 5 5 5) + (nil 7 7) + (7 7) + (nil))) + +(deftest position-if-not-vector.12 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if-not #'evenp #(1 3 1 4 3 2 1 8 9) :start i :end j + :key #'1+ :from-end t))) + ((nil nil nil 3 3 5 5 7 7) + (nil nil 3 3 5 5 7 7) + (nil 3 3 5 5 7 7) + (3 3 5 5 7 7) + (nil 5 5 7 7) + (5 5 7 7) + (nil 7 7) + (7 7) + (nil))) + +;;; Bit vector tests + +(deftest position-if-not-bit-vector.1 + (position-if-not #'oddp #*111010101) + 3) + +(deftest position-if-not-bit-vector.2 + (position-if-not 'oddp #*111010101) + 3) + +(deftest position-if-not-bit-vector.3 + (position-if-not #'oddp #*111010101 :start 4) + 5) + +(deftest position-if-not-bit-vector.4 + (position-if-not #'oddp #*111010101 :from-end t) + 7) + +(deftest position-if-not-bit-vector.5 + (position-if-not #'oddp #*111010101 :from-end nil) + 3) + +(deftest position-if-not-bit-vector.6 + (position-if-not #'oddp #*111010101 :start 4 + :from-end t) + 7) + +(deftest position-if-not-bit-vector.7 + (position-if-not #'oddp #*111010101 :end nil) + 3) + +(deftest position-if-not-bit-vector.8 + (position-if-not #'oddp #*111010101 :end 3) + nil) + +(deftest position-if-not-bit-vector.9 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if-not #'oddp #*111010101 :start i :end j))) + ((nil nil nil 3 3 3 3 3 3) + (nil nil 3 3 3 3 3 3) + (nil 3 3 3 3 3 3) + (3 3 3 3 3 3) + (nil 5 5 5 5) + (5 5 5 5) + (nil 7 7) + (7 7) + (nil))) + +(deftest position-if-not-bit-vector.10 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if-not #'oddp #*111010101 :start i :end j + :from-end t))) + ((nil nil nil 3 3 5 5 7 7) + (nil nil 3 3 5 5 7 7) + (nil 3 3 5 5 7 7) + (3 3 5 5 7 7) + (nil 5 5 7 7) + (5 5 7 7) + (nil 7 7) + (7 7) + (nil))) + +(deftest position-if-not-bit-vector.11 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if-not #'evenp #*111010101 :start i :end j + :key #'1+))) + ((nil nil nil 3 3 3 3 3 3) + (nil nil 3 3 3 3 3 3) + (nil 3 3 3 3 3 3) + (3 3 3 3 3 3) + (nil 5 5 5 5) + (5 5 5 5) + (nil 7 7) + (7 7) + (nil))) + +(deftest position-if-not-bit-vector.12 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if-not #'evenp #*111010101 :start i :end j + :key '1+ :from-end t))) + ((nil nil nil 3 3 5 5 7 7) + (nil nil 3 3 5 5 7 7) + (nil 3 3 5 5 7 7) + (3 3 5 5 7 7) + (nil 5 5 7 7) + (5 5 7 7) + (nil 7 7) + (7 7) + (nil))) + +;;; string tests + +(deftest position-if-not-string.1 + (position-if-not #'odddigitp "131432189") + 3) + +(deftest position-if-not-string.2 + (position-if-not 'odddigitp "131432189") + 3) + +(deftest position-if-not-string.3 + (position-if-not #'odddigitp "131432189" :start 4) + 5) + +(deftest position-if-not-string.4 + (position-if-not #'odddigitp "131432189" :from-end t) + 7) + +(deftest position-if-not-string.5 + (position-if-not #'odddigitp "131432189" :from-end nil) + 3) + +(deftest position-if-not-string.6 + (position-if-not #'odddigitp "131432189" :start 4 + :from-end t) + 7) + +(deftest position-if-not-string.7 + (position-if-not #'odddigitp "131432189" :end nil) + 3) + +(deftest position-if-not-string.8 + (position-if-not #'odddigitp "131432189" :end 3) + nil) + +(deftest position-if-not-string.9 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if-not #'odddigitp "131432189" :start i :end j))) + ((nil nil nil 3 3 3 3 3 3) + (nil nil 3 3 3 3 3 3) + (nil 3 3 3 3 3 3) + (3 3 3 3 3 3) + (nil 5 5 5 5) + (5 5 5 5) + (nil 7 7) + (7 7) + (nil))) + +(deftest position-if-not-string.10 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if-not #'odddigitp "131432189" :start i :end j + :from-end t))) + ((nil nil nil 3 3 5 5 7 7) + (nil nil 3 3 5 5 7 7) + (nil 3 3 5 5 7 7) + (3 3 5 5 7 7) + (nil 5 5 7 7) + (5 5 7 7) + (nil 7 7) + (7 7) + (nil))) + +(deftest position-if-not-string.11 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if-not #'evendigitp "131432183" :start i :end j + :key #'nextdigit))) + ((nil nil nil 3 3 3 3 3 3) + (nil nil 3 3 3 3 3 3) + (nil 3 3 3 3 3 3) + (3 3 3 3 3 3) + (nil 5 5 5 5) + (5 5 5 5) + (nil 7 7) + (7 7) + (nil))) + +(deftest position-if-not-string.12 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if-not #'evendigitp "131432183" :start i :end j + :key 'nextdigit :from-end t))) + ((nil nil nil 3 3 5 5 7 7) + (nil nil 3 3 5 5 7 7) + (nil 3 3 5 5 7 7) + (3 3 5 5 7 7) + (nil 5 5 7 7) + (5 5 7 7) + (nil 7 7) + (7 7) + (nil))) + +;;; Error tests + +(deftest position-if-not-error.1 + (handler-case (position-if-not #'identity 'b) + (type-error () :type-error) + (error (c) c)) + :type-error) + +(deftest position-if-not-error.2 + (handler-case (position-if-not #'identity 10) + (type-error () :type-error) + (error (c) c)) + :type-error) + +(deftest position-if-not-error.3 + (handler-case (position-if-not 'null 1.4) + (type-error () :type-error) + (error (c) c)) + :type-error) + +(deftest position-if-not-error.4 + (locally (declare (optimize (safety 3))) + (handler-case (position-if-not 'identity '(a b c . d)) + (type-error () :type-error) + (error (c) c))) + :type-error) \ No newline at end of file diff --git a/ansi-tests/position-if.lsp b/ansi-tests/position-if.lsp new file mode 100644 index 0000000000000000000000000000000000000000..f3eafbc3ab8e844b005de57e88693c9a4f6cd592 --- /dev/null +++ b/ansi-tests/position-if.lsp @@ -0,0 +1,439 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Fri Aug 23 22:08:57 2002 +;;;; Contains: Tests for POSITION-IF + +(in-package :cl-test) + +(deftest position-if-list.1 + (position-if #'evenp '(1 3 1 4 3 2 1 8 9)) + 3) + +(deftest position-if-list.2 + (position-if 'evenp '(1 3 1 4 3 2 1 8 9)) + 3) + +(deftest position-if-list.3 + (position-if #'evenp '(1 3 1 4 3 2 1 8 9) :start 4) + 5) + +(deftest position-if-list.4 + (position-if #'evenp '(1 3 1 4 3 2 1 8 9) :from-end t) + 7) + +(deftest position-if-list.5 + (position-if #'evenp '(1 3 1 4 3 2 1 8 9) :from-end nil) + 3) + +(deftest position-if-list.6 + (position-if #'evenp '(1 3 1 4 3 2 1 8 9) :start 4 + :from-end t) + 7) + +(deftest position-if-list.7 + (position-if #'evenp '(1 3 1 4 3 2 1 8 9) :end nil) + 3) + +(deftest position-if-list.8 + (position-if #'evenp '(1 3 1 4 3 2 1 8 9) :end 3) + nil) + +(deftest position-if-list.9 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if #'evenp '(1 3 1 4 3 2 1 8 9) :start i :end j))) + ((nil nil nil 3 3 3 3 3 3) + (nil nil 3 3 3 3 3 3) + (nil 3 3 3 3 3 3) + (3 3 3 3 3 3) + (nil 5 5 5 5) + (5 5 5 5) + (nil 7 7) + (7 7) + (nil))) + +(deftest position-if-list.10 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if #'evenp '(1 3 1 4 3 2 1 8 9) :start i :end j + :from-end t))) + ((nil nil nil 3 3 5 5 7 7) + (nil nil 3 3 5 5 7 7) + (nil 3 3 5 5 7 7) + (3 3 5 5 7 7) + (nil 5 5 7 7) + (5 5 7 7) + (nil 7 7) + (7 7) + (nil))) + +(deftest position-if-list.11 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if #'oddp '(1 3 1 4 3 2 1 8 9) :start i :end j + :key '1+))) + ((nil nil nil 3 3 3 3 3 3) + (nil nil 3 3 3 3 3 3) + (nil 3 3 3 3 3 3) + (3 3 3 3 3 3) + (nil 5 5 5 5) + (5 5 5 5) + (nil 7 7) + (7 7) + (nil))) + +(deftest position-if-list.12 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if #'oddp '(1 3 1 4 3 2 1 8 9) :start i :end j + :key #'1+ :from-end t))) + ((nil nil nil 3 3 5 5 7 7) + (nil nil 3 3 5 5 7 7) + (nil 3 3 5 5 7 7) + (3 3 5 5 7 7) + (nil 5 5 7 7) + (5 5 7 7) + (nil 7 7) + (7 7) + (nil))) + +;;; Vector tests + +(deftest position-if-vector.1 + (position-if #'evenp #(1 3 1 4 3 2 1 8 9)) + 3) + +(deftest position-if-vector.2 + (position-if 'evenp #(1 3 1 4 3 2 1 8 9)) + 3) + +(deftest position-if-vector.3 + (position-if #'evenp #(1 3 1 4 3 2 1 8 9) :start 4) + 5) + +(deftest position-if-vector.4 + (position-if #'evenp #(1 3 1 4 3 2 1 8 9) :from-end t) + 7) + +(deftest position-if-vector.5 + (position-if #'evenp #(1 3 1 4 3 2 1 8 9) :from-end nil) + 3) + +(deftest position-if-vector.6 + (position-if #'evenp #(1 3 1 4 3 2 1 8 9) :start 4 + :from-end t) + 7) + +(deftest position-if-vector.7 + (position-if #'evenp #(1 3 1 4 3 2 1 8 9) :end nil) + 3) + +(deftest position-if-vector.8 + (position-if #'evenp #(1 3 1 4 3 2 1 8 9) :end 3) + nil) + +(deftest position-if-vector.9 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if #'evenp #(1 3 1 4 3 2 1 8 9) :start i :end j))) + ((nil nil nil 3 3 3 3 3 3) + (nil nil 3 3 3 3 3 3) + (nil 3 3 3 3 3 3) + (3 3 3 3 3 3) + (nil 5 5 5 5) + (5 5 5 5) + (nil 7 7) + (7 7) + (nil))) + +(deftest position-if-vector.10 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if #'evenp #(1 3 1 4 3 2 1 8 9) :start i :end j + :from-end t))) + ((nil nil nil 3 3 5 5 7 7) + (nil nil 3 3 5 5 7 7) + (nil 3 3 5 5 7 7) + (3 3 5 5 7 7) + (nil 5 5 7 7) + (5 5 7 7) + (nil 7 7) + (7 7) + (nil))) + +(deftest position-if-vector.11 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if #'oddp #(1 3 1 4 3 2 1 8 9) :start i :end j + :key '1+))) + ((nil nil nil 3 3 3 3 3 3) + (nil nil 3 3 3 3 3 3) + (nil 3 3 3 3 3 3) + (3 3 3 3 3 3) + (nil 5 5 5 5) + (5 5 5 5) + (nil 7 7) + (7 7) + (nil))) + +(deftest position-if-vector.12 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if #'oddp #(1 3 1 4 3 2 1 8 9) :start i :end j + :key #'1+ :from-end t))) + ((nil nil nil 3 3 5 5 7 7) + (nil nil 3 3 5 5 7 7) + (nil 3 3 5 5 7 7) + (3 3 5 5 7 7) + (nil 5 5 7 7) + (5 5 7 7) + (nil 7 7) + (7 7) + (nil))) + +;;; Bit vector tests + +(deftest position-if-bit-vector.1 + (position-if #'evenp #*111010101) + 3) + +(deftest position-if-bit-vector.2 + (position-if 'evenp #*111010101) + 3) + +(deftest position-if-bit-vector.3 + (position-if #'evenp #*111010101 :start 4) + 5) + +(deftest position-if-bit-vector.4 + (position-if #'evenp #*111010101 :from-end t) + 7) + +(deftest position-if-bit-vector.5 + (position-if #'evenp #*111010101 :from-end nil) + 3) + +(deftest position-if-bit-vector.6 + (position-if #'evenp #*111010101 :start 4 + :from-end t) + 7) + +(deftest position-if-bit-vector.7 + (position-if #'evenp #*111010101 :end nil) + 3) + +(deftest position-if-bit-vector.8 + (position-if #'evenp #*111010101 :end 3) + nil) + +(deftest position-if-bit-vector.9 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if #'evenp #*111010101 :start i :end j))) + ((nil nil nil 3 3 3 3 3 3) + (nil nil 3 3 3 3 3 3) + (nil 3 3 3 3 3 3) + (3 3 3 3 3 3) + (nil 5 5 5 5) + (5 5 5 5) + (nil 7 7) + (7 7) + (nil))) + +(deftest position-if-bit-vector.10 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if #'evenp #*111010101 :start i :end j + :from-end t))) + ((nil nil nil 3 3 5 5 7 7) + (nil nil 3 3 5 5 7 7) + (nil 3 3 5 5 7 7) + (3 3 5 5 7 7) + (nil 5 5 7 7) + (5 5 7 7) + (nil 7 7) + (7 7) + (nil))) + +(deftest position-if-bit-vector.11 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if #'oddp #*111010101 :start i :end j + :key #'1+))) + ((nil nil nil 3 3 3 3 3 3) + (nil nil 3 3 3 3 3 3) + (nil 3 3 3 3 3 3) + (3 3 3 3 3 3) + (nil 5 5 5 5) + (5 5 5 5) + (nil 7 7) + (7 7) + (nil))) + +(deftest position-if-bit-vector.12 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if #'oddp #*111010101 :start i :end j + :key '1+ :from-end t))) + ((nil nil nil 3 3 5 5 7 7) + (nil nil 3 3 5 5 7 7) + (nil 3 3 5 5 7 7) + (3 3 5 5 7 7) + (nil 5 5 7 7) + (5 5 7 7) + (nil 7 7) + (7 7) + (nil))) + +;;; string tests + +(deftest position-if-string.1 + (position-if #'evendigitp "131432189") + 3) + +(deftest position-if-string.2 + (position-if 'evendigitp "131432189") + 3) + +(deftest position-if-string.3 + (position-if #'evendigitp "131432189" :start 4) + 5) + +(deftest position-if-string.4 + (position-if #'evendigitp "131432189" :from-end t) + 7) + +(deftest position-if-string.5 + (position-if #'evendigitp "131432189" :from-end nil) + 3) + +(deftest position-if-string.6 + (position-if #'evendigitp "131432189" :start 4 + :from-end t) + 7) + +(deftest position-if-string.7 + (position-if #'evendigitp "131432189" :end nil) + 3) + +(deftest position-if-string.8 + (position-if #'evendigitp "131432189" :end 3) + nil) + +(deftest position-if-string.9 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if #'evendigitp "131432189" :start i :end j))) + ((nil nil nil 3 3 3 3 3 3) + (nil nil 3 3 3 3 3 3) + (nil 3 3 3 3 3 3) + (3 3 3 3 3 3) + (nil 5 5 5 5) + (5 5 5 5) + (nil 7 7) + (7 7) + (nil))) + +(deftest position-if-string.10 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if #'evendigitp "131432189" :start i :end j + :from-end t))) + ((nil nil nil 3 3 5 5 7 7) + (nil nil 3 3 5 5 7 7) + (nil 3 3 5 5 7 7) + (3 3 5 5 7 7) + (nil 5 5 7 7) + (5 5 7 7) + (nil 7 7) + (7 7) + (nil))) + +(deftest position-if-string.11 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if #'odddigitp "131432189" :start i :end j + :key #'nextdigit))) + ((nil nil nil 3 3 3 3 3 3) + (nil nil 3 3 3 3 3 3) + (nil 3 3 3 3 3 3) + (3 3 3 3 3 3) + (nil 5 5 5 5) + (5 5 5 5) + (nil 7 7) + (7 7) + (nil))) + +(deftest position-if-string.12 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if #'odddigitp "131432189" :start i :end j + :key 'nextdigit :from-end t))) + ((nil nil nil 3 3 5 5 7 7) + (nil nil 3 3 5 5 7 7) + (nil 3 3 5 5 7 7) + (3 3 5 5 7 7) + (nil 5 5 7 7) + (5 5 7 7) + (nil 7 7) + (7 7) + (nil))) + +;;; Error tests + +(deftest position-if-error.1 + (handler-case (position-if #'identity 'b) + (type-error () :type-error) + (error (c) c)) + :type-error) + +(deftest position-if-error.2 + (handler-case (position-if #'identity 10) + (type-error () :type-error) + (error (c) c)) + :type-error) + +(deftest position-if-error.3 + (handler-case (position-if 'null 1.4) + (type-error () :type-error) + (error (c) c)) + :type-error) + +(deftest position-if-error.4 + (locally (declare (optimize (safety 3))) + (handler-case (position-if 'null '(a b c . d)) + (type-error () :type-error) + (error (c) c))) + :type-error) diff --git a/ansi-tests/position.lsp b/ansi-tests/position.lsp new file mode 100644 index 0000000000000000000000000000000000000000..a1542c6e14f7e82a5b00addd445804e50bf00d3c --- /dev/null +++ b/ansi-tests/position.lsp @@ -0,0 +1,598 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Fri Aug 23 07:49:49 2002 +;;;; Contains: Tests for POSITION + +(in-package :cl-test) + +(deftest position-list.1 + (position 'c '(a b c d e c a)) + 2) + +(deftest position-list.2 + (position 'c '(a b c d e c a) :from-end t) + 5) + +(deftest position-list.3 + (loop for i from 0 to 7 collect + (position 'c '(a b c d e c a) :start i)) + (2 2 2 5 5 5 nil nil)) + +(deftest position-list.4 + (loop for i from 0 to 7 collect + (position 'c '(a b c d e c a) :start i :end nil)) + (2 2 2 5 5 5 nil nil)) + +(deftest position-list.5 + (loop for i from 7 downto 0 collect + (position 'c '(a b c d e c a) :end i)) + (2 2 2 2 2 nil nil nil)) + +(deftest position-list.6 + (loop for i from 0 to 7 collect + (position 'c '(a b c d e c a) :start i :from-end t)) + (5 5 5 5 5 5 nil nil)) + +(deftest position-list.7 + (loop for i from 0 to 7 collect + (position 'c '(a b c d e c a) :start i :end nil :from-end t)) + (5 5 5 5 5 5 nil nil)) + +(deftest position-list.8 + (loop for i from 7 downto 0 collect + (position 'c '(a b c d e c a) :end i :from-end t)) + (5 5 2 2 2 nil nil nil)) + +(deftest position-list.9 + (loop for i from 0 to 6 collect + (loop for j from (1+ i) to 7 + collect + (position 'c '(a b c d e c a) :start i :end j))) + ((nil nil 2 2 2 2 2) + (nil 2 2 2 2 2) + (2 2 2 2 2) + (nil nil 5 5) + (nil 5 5) + (5 5) + (nil))) + +(deftest position-list.10 + (loop for i from 0 to 6 collect + (loop for j from (1+ i) to 7 + collect + (position 'c '(a b c d e c a) :start i :end j :from-end t))) + ((nil nil 2 2 2 5 5) + (nil 2 2 2 5 5) + (2 2 2 5 5) + (nil nil 5 5) + (nil 5 5) + (5 5) + (nil))) + +(deftest position-list.11 + (position 5 '(1 2 3 4 5 6 4 8) :key #'1+) + 3) + +(deftest position-list.12 + (position 5 '(1 2 3 4 5 6 4 8) :key '1+) + 3) + +(deftest position-list.13 + (position 5 '(1 2 3 4 5 6 4 8) :key #'1+ :from-end t) + 6) + +(deftest position-list.14 + (position 'a '(a a b a c e d a f a) :test (complement #'eq)) + 2) + +(deftest position-list.15 + (position 'a '(a a b a c e d a f a) :test (complement #'eq) + :from-end t) + 8) + +(deftest position-list.16 + (position 'a '(a a b a c e d a f a) :test-not #'eq) + 2) + +(deftest position-list.17 + (position 'a '(a a b a c e d a f a) :test-not 'eq + :from-end t) + 8) + +(deftest position-list.18 + (position 'a '(a a b a c e d a f a) :test-not 'eq) + 2) + +(deftest position-list.19 + (position 'a '(a a b a c e d a f a) :test-not #'eq + :from-end t) + 8) + +(deftest position-list.20 + (position 'a '(a a b a c e d a f a) :test-not #'eq) + 2) + +(deftest position-list.21 + (position 'a '(a a b a c e d a f a) :test #'eq + :start 2) + 3) + +(deftest position-list.22 + (position 'a '(a a b a c e d a f a) :test #'eq + :start 2 :end nil) + 3) + +(deftest position-list.23 + (position 'a '(a a b a c e d a f a) :test-not #'eq + :start 0 :end 5) + 2) + +(deftest position-list.24 + (position 'a '(a a b a c e d a f a) :test-not #'eq + :start 0 :end 5 :from-end t) + 4) + +(deftest position-list.25 + (position '(a b) '(a (b a) (a b c) (a b) (d e) f) :test #'equal) + 3) + +(deftest position-list.26 + (position 'a '((c) (b a) (a b c) (a b) (d e) f) :key #'car) + 2) + +(deftest position-list.27 + (position 'a '((c) (b a) (a b c) (z) (a b) (d e) f) :key #'car + :start 3) + 4) + +(deftest position-list.28 + (position 'a '((c) (b a) (a b c) (z) (a b) (d e) (f)) :key #'car + :start 2 :from-end t) + 4) + +;;; Tests on vectors + +(deftest position-vector.1 + (position 'c #(a b c d e c a)) + 2) + +(deftest position-vector.2 + (position 'c #(a b c d e c a) :from-end t) + 5) + +(deftest position-vector.3 + (loop for i from 0 to 7 collect + (position 'c #(a b c d e c a) :start i)) + (2 2 2 5 5 5 nil nil)) + +(deftest position-vector.4 + (loop for i from 0 to 7 collect + (position 'c #(a b c d e c a) :start i :end nil)) + (2 2 2 5 5 5 nil nil)) + +(deftest position-vector.5 + (loop for i from 7 downto 0 collect + (position 'c #(a b c d e c a) :end i)) + (2 2 2 2 2 nil nil nil)) + +(deftest position-vector.6 + (loop for i from 0 to 7 collect + (position 'c #(a b c d e c a) :start i :from-end t)) + (5 5 5 5 5 5 nil nil)) + +(deftest position-vector.7 + (loop for i from 0 to 7 collect + (position 'c #(a b c d e c a) :start i :end nil :from-end t)) + (5 5 5 5 5 5 nil nil)) + +(deftest position-vector.8 + (loop for i from 7 downto 0 collect + (position 'c #(a b c d e c a) :end i :from-end t)) + (5 5 2 2 2 nil nil nil)) + +(deftest position-vector.9 + (loop for i from 0 to 6 collect + (loop for j from (1+ i) to 7 + collect + (position 'c #(a b c d e c a) :start i :end j))) + ((nil nil 2 2 2 2 2) + (nil 2 2 2 2 2) + (2 2 2 2 2) + (nil nil 5 5) + (nil 5 5) + (5 5) + (nil))) + +(deftest position-vector.10 + (loop for i from 0 to 6 collect + (loop for j from (1+ i) to 7 + collect + (position 'c #(a b c d e c a) :start i :end j :from-end t))) + ((nil nil 2 2 2 5 5) + (nil 2 2 2 5 5) + (2 2 2 5 5) + (nil nil 5 5) + (nil 5 5) + (5 5) + (nil))) + +(deftest position-vector.11 + (position 5 #(1 2 3 4 5 6 4 8) :key #'1+) + 3) + +(deftest position-vector.12 + (position 5 #(1 2 3 4 5 6 4 8) :key '1+) + 3) + +(deftest position-vector.13 + (position 5 #(1 2 3 4 5 6 4 8) :key #'1+ :from-end t) + 6) + +(deftest position-vector.14 + (position 'a #(a a b a c e d a f a) :test (complement #'eq)) + 2) + +(deftest position-vector.15 + (position 'a #(a a b a c e d a f a) :test (complement #'eq) + :from-end t) + 8) + +(deftest position-vector.16 + (position 'a #(a a b a c e d a f a) :test-not #'eq) + 2) + +(deftest position-vector.17 + (position 'a #(a a b a c e d a f a) :test-not 'eq + :from-end t) + 8) + +(deftest position-vector.18 + (position 'a #(a a b a c e d a f a) :test-not 'eq) + 2) + +(deftest position-vector.19 + (position 'a #(a a b a c e d a f a) :test-not #'eq + :from-end t) + 8) + +(deftest position-vector.20 + (position 'a #(a a b a c e d a f a) :test-not #'eq) + 2) + +(deftest position-vector.21 + (position 'a #(a a b a c e d a f a) :test #'eq + :start 2) + 3) + +(deftest position-vector.22 + (position 'a #(a a b a c e d a f a) :test #'eq + :start 2 :end nil) + 3) + +(deftest position-vector.23 + (position 'a #(a a b a c e d a f a) :test-not #'eq + :start 0 :end 5) + 2) + +(deftest position-vector.24 + (position 'a #(a a b a c e d a f a) :test-not #'eq + :start 0 :end 5 :from-end t) + 4) + +(deftest position-vector.25 + (position '(a b) #(a (b a) (a b c) (a b) (d e) f) :test #'equal) + 3) + +(deftest position-vector.26 + (position 'a #((c) (b a) (a b c) (a b) (d e) f) :key #'car) + 2) + +(deftest position-vector.27 + (position 'a #((c) (b a) (a b c) (z) (a b) (d e) f) :key #'car + :start 3) + 4) + +(deftest position-vector.28 + (position 'a #((c) (b a) (a b c) (z) (a b) (d e) (f)) :key #'car + :start 2 :from-end t) + 4) + +;;; tests on bit vectors + +(deftest position-bit-vector.1 + (position 1 #*001001010100) + 2) + +(deftest position-bit-vector.2 + (position 1 #*001001010100 :from-end t) + 9) + +(deftest position-bit-vector.3 + (loop for i from 0 to 7 collect + (position 1 #*0010010 :start i)) + (2 2 2 5 5 5 nil nil)) + +(deftest position-bit-vector.4 + (loop for i from 0 to 7 collect + (position 1 #*0010010 :start i :end nil)) + (2 2 2 5 5 5 nil nil)) + +(deftest position-bit-vector.5 + (loop for i from 7 downto 0 collect + (position 1 #*0010010 :end i)) + (2 2 2 2 2 nil nil nil)) + +(deftest position-bit-vector.6 + (loop for i from 0 to 7 collect + (position 1 #*0010010 :start i :from-end t)) + (5 5 5 5 5 5 nil nil)) + +(deftest position-bit-vector.7 + (loop for i from 0 to 7 collect + (position 0 #*1101101 :start i :end nil :from-end t)) + (5 5 5 5 5 5 nil nil)) + +(deftest position-bit-vector.8 + (loop for i from 7 downto 0 collect + (position 0 #*1101101 :end i :from-end t)) + (5 5 2 2 2 nil nil nil)) + +(deftest position-bit-vector.9 + (loop for i from 0 to 6 collect + (loop for j from (1+ i) to 7 + collect + (position 1 #*0010010 :start i :end j))) + ((nil nil 2 2 2 2 2) + (nil 2 2 2 2 2) + (2 2 2 2 2) + (nil nil 5 5) + (nil 5 5) + (5 5) + (nil))) + +(deftest position-bit-vector.10 + (loop for i from 0 to 6 collect + (loop for j from (1+ i) to 7 + collect + (position 1 #*0010010 :start i :end j :from-end t))) + ((nil nil 2 2 2 5 5) + (nil 2 2 2 5 5) + (2 2 2 5 5) + (nil nil 5 5) + (nil 5 5) + (5 5) + (nil))) + +(deftest position-bit-vector.11 + (position 2 #*00010001010 :key #'1+) + 3) + +(deftest position-bit-vector.12 + (position 2 #*00010001010 :key '1+) + 3) + +(deftest position-bit-vector.13 + (position 2 #*0010001000 :key #'1+ :from-end t) + 6) + +(deftest position-bit-vector.14 + (position 0 #*0010111010 :test (complement #'eq)) + 2) + +(deftest position-bit-vector.15 + (position 0 #*0010111010 :test (complement #'eq) + :from-end t) + 8) + +(deftest position-bit-vector.16 + (position 0 #*0010111010 :test-not #'eq) + 2) + +(deftest position-bit-vector.17 + (position 0 #*001011101 :test-not 'eq + :from-end t) + 8) + +(deftest position-bit-vector.18 + (position 0 #*00101110 :test-not 'eq) + 2) + +(deftest position-bit-vector.19 + (position 0 #*00101110 :test-not #'eq + :from-end t) + 6) + +(deftest position-bit-vector.20 + (position 0 #*00101110 :test-not #'eq) + 2) + +(deftest position-bit-vector.21 + (position 0 #*00101110 :test #'eq + :start 2) + 3) + +(deftest position-bit-vector.22 + (position 0 #*00101110 :test #'eq + :start 2 :end nil) + 3) + +(deftest position-bit-vector.23 + (position 0 #*00101110 :test-not #'eq + :start 0 :end 5) + 2) + +(deftest position-bit-vector.24 + (position 0 #*00101110 :test-not #'eq + :start 0 :end 5 :from-end t) + 4) + +(deftest position-bit-vector.25 + (position 2 #*1100001010 :key #'1+ + :start 3) + 6) + +(deftest position-bit-vector.27 + (position 2 #*1100001010 :key #'1+ + :start 2 :from-end t) + 8) + +;;; strings + +(deftest position-string.1 + (position #\c "abcdeca") + 2) + +(deftest position-string.2 + (position #\c "abcdeca" :from-end t) + 5) + +(deftest position-string.3 + (loop for i from 0 to 7 collect + (position #\c "abcdeca" :start i)) + (2 2 2 5 5 5 nil nil)) + +(deftest position-string.4 + (loop for i from 0 to 7 collect + (position #\c "abcdeca" :start i :end nil)) + (2 2 2 5 5 5 nil nil)) + +(deftest position-string.5 + (loop for i from 7 downto 0 collect + (position #\c "abcdeca" :end i)) + (2 2 2 2 2 nil nil nil)) + +(deftest position-string.6 + (loop for i from 0 to 7 collect + (position #\c "abcdeca" :start i :from-end t)) + (5 5 5 5 5 5 nil nil)) + +(deftest position-string.7 + (loop for i from 0 to 7 collect + (position #\c "abcdeca" :start i :end nil :from-end t)) + (5 5 5 5 5 5 nil nil)) + +(deftest position-string.8 + (loop for i from 7 downto 0 collect + (position #\c "abcdeca" :end i :from-end t)) + (5 5 2 2 2 nil nil nil)) + +(deftest position-string.9 + (loop for i from 0 to 6 collect + (loop for j from (1+ i) to 7 + collect + (position #\c "abcdeca" :start i :end j))) + ((nil nil 2 2 2 2 2) + (nil 2 2 2 2 2) + (2 2 2 2 2) + (nil nil 5 5) + (nil 5 5) + (5 5) + (nil))) + +(deftest position-string.10 + (loop for i from 0 to 6 collect + (loop for j from (1+ i) to 7 + collect + (position #\c "abcdeca" :start i :end j :from-end t))) + ((nil nil 2 2 2 5 5) + (nil 2 2 2 5 5) + (2 2 2 5 5) + (nil nil 5 5) + (nil 5 5) + (5 5) + (nil))) + +(deftest position-string.11 + (position 5 "12345648" :key #'(lambda (c) + (1+ (read-from-string (string c))))) + 3) + +(deftest position-string.13 + (position 5 "12345648" :key #'(lambda (c) + (1+ (read-from-string (string c)))) + :from-end t) + 6) + +(deftest position-string.14 + (position #\a "aabacedafa" :test (complement #'eq)) + 2) + +(deftest position-string.15 + (position #\a "aabacedafa" :test (complement #'eq) + :from-end t) + 8) + +(deftest position-string.16 + (position #\a "aabacedafa" :test-not #'eq) + 2) + +(deftest position-string.17 + (position #\a "aabacedafa" :test-not 'eq + :from-end t) + 8) + +(deftest position-string.18 + (position #\a "aabacedafa" :test-not 'eq) + 2) + +(deftest position-string.19 + (position #\a "aabacedafa" :test-not #'eq + :from-end t) + 8) + +(deftest position-string.20 + (position #\a "aabacedafa" :test-not #'eq) + 2) + +(deftest position-string.21 + (position #\a "aabacedafa" :test #'eq + :start 2) + 3) + +(deftest position-string.22 + (position #\a "aabacedafa" :test #'eq + :start 2 :end nil) + 3) + +(deftest position-string.23 + (position #\a "aabacedafa" :test-not #'eq + :start 0 :end 5) + 2) + +(deftest position-string.24 + (position #\a "aabacedafa" :test-not #'eq + :start 0 :end 5 :from-end t) + 4) + +;;; Error tests + +(deftest position-error.1 + (handler-case (position 'a 'b) + (type-error () :type-error) + (error (c) c)) + :type-error) + +(deftest position-error.2 + (handler-case (position 'a 10) + (type-error () :type-error) + (error (c) c)) + :type-error) + +(deftest position-error.3 + (handler-case (position 'a 1.4) + (type-error () :type-error) + (error (c) c)) + :type-error) + +(deftest position-error.4 + (locally (declare (optimize (safety 3))) + (handler-case (position 'a '(a b c . d)) + (type-error () :type-error) + (error (c) c))) + :type-error) + + + + + + \ No newline at end of file diff --git a/ansi-tests/random-intern.lsp b/ansi-tests/random-intern.lsp new file mode 100644 index 0000000000000000000000000000000000000000..2688cad26f8c16d06dc2113ee86c60b2edf1b47d --- /dev/null +++ b/ansi-tests/random-intern.lsp @@ -0,0 +1,80 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Contains: Code to randomly intern and unintern random strings +;;;; in a package. Exercises package and hash table routines + +(in-package :cl-test) + +(defconstant + +base-chars+ #.(concatenate 'string + "abcdefghijklmnopqrstuvwxyz" + "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + "0123456789" + "<,>.?/\"':;[{]}~`!@#$%^&*()_-+= \\|")) +(defconstant +num-base-chars+ (length +base-chars+)) + +(defconstant +max-len-random-symbol+ 63) + +(defun make-random-symbol (package) + (declare (optimize (speed 3) (safety 3))) + (loop + (let* ((len (random (1+ +max-len-random-symbol+))) + (str (make-string len))) + (declare (type (integer 0 #.+max-len-random-symbol+) len)) + (loop + for i from 0 to (1- len) do + (setf (schar str i) + (schar +base-chars+ + (random +num-base-chars+)))) + (multiple-value-bind + (symbol status) + (intern (copy-seq str) package) + (unless (equal str (symbol-name symbol)) + (error "Intern gave bad symbol: ~A, ~A~%" str symbol)) + (unless status (return symbol)))))) + +(defun queue-insert (q x) + (declare (type cons q)) + (push x (cdr q))) + +(defun queue-remove (q) + (declare (type cons q)) + (when (null (car q)) + (when (null (cdr q)) + (error "Attempty to remove from empty queue.~%")) + (setf (car q) (nreverse (cdr q))) + (setf (cdr q) nil)) + (pop (car q))) + +(defun queue-empty (q) + (and (null (car q)) + (null (cdr q)))) + +(defun random-intern (n) + (declare (fixnum n)) + (let ((q (list nil)) + (xp (defpackage "X" (:use)))) + (declare (type cons q)) + (loop + for i from 1 to n do + (if (and + (= (random 2) 0) + (not (queue-empty q))) + (unintern (queue-remove q) xp) + (queue-insert q (make-random-symbol xp)))))) + +(defun fill-intern (n) + (declare (fixnum n)) + (let ((xp (defpackage "X" (:use)))) + (loop + for i from 1 to n do + (make-random-symbol xp)))) + + + + + + + + + diff --git a/ansi-tests/reader-test.lsp b/ansi-tests/reader-test.lsp new file mode 100644 index 0000000000000000000000000000000000000000..40120456330a1c2c506c7a5ce46cea717e27ef48 --- /dev/null +++ b/ansi-tests/reader-test.lsp @@ -0,0 +1,161 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Wed Apr 8 20:03:45 1998 +;;;; Contains: Tests on readtables (just started, very incomplete) + +(in-package :cl-test) +(use-package :rt) + +(declaim (optimize (safety 3))) + +(deftest readtable-valid (not (readtablep *readtable*)) nil) +(deftest readtablep-1 + (and (not (readtablep nil)) + (not (readtablep 'a)) + (not (readtablep 0)) + (not (readtablep 1/2)) + (not (readtablep 1.2)) + (not (readtablep 1.2s2)) + (not (readtablep 1.2f3)) + (not (readtablep 1.2e2)) + (not (readtablep 1.2d2)) + (not (readtablep (list 'a))) + (not (readtablep "abcde")) + (not (readtablep t)) + (not (readtablep '*readtable*)) + (not (readtablep (make-array '(10)))) + (not (readtablep (make-array '(10) :element-type 'fixnum))) + (not (readtablep (make-array '(10) :element-type 'float))) + (not (readtablep (make-array '(10) :element-type 'double-float))) + (not (readtablep (make-array '(10) :element-type 'string))) + (not (readtablep (make-array '(10) :element-type 'character))) + (not (readtablep (make-array '(10) :element-type 'bit))) + (not (readtablep (make-array '(10) :element-type 'boolean))) + (not (not (readtablep (copy-readtable)))) + (not (readtablep #'car)) + ) + t) + +(deftest read-symbol-1 + (let ((*package* (find-package "CL-TEST"))) + (ignore-errors (read-from-string "a"))) + a 1) + +(deftest read-symbol-2 + (let ((*package* (find-package "CL-TEST"))) + (ignore-errors (read-from-string "|a|"))) + |a| 3) + +(deftest read-symbol-3 + (multiple-value-bind (s n) + (ignore-errors (read-from-string "#:abc")) + (and (symbolp s) + (eql n 5) + (not (symbol-package s)) + (string-equal (symbol-name s) "abc"))) + t) + +(deftest read-symbol-4 + (multiple-value-bind (s n) + (ignore-errors (read-from-string "#:|abc|")) + (and (symbolp s) + (eql n 7) + (not (symbol-package s)) + (string= (symbol-name s) "abc"))) + t) + +(deftest read-symbol-5 + (multiple-value-bind (s n) + (ignore-errors (read-from-string "#:||")) + (if (not (symbolp s)) + s + (and (eql n 4) + (not (symbol-package s)) + (string= (symbol-name s) "")))) + t) + +(deftest read-symbol-6 + (let ((str "cl-test::abcd0123")) + (multiple-value-bind (s n) + (ignore-errors (read-from-string str)) + (if (not (symbolp s)) + s + (and (eql n (length str)) + (eq (symbol-package s) (find-package :cl-test)) + (string-equal (symbol-name s) + "abcd0123"))))) + t) + +(deftest read-symbol-7 + (multiple-value-bind (s n) + (ignore-errors (read-from-string ":ABCD")) + (if (not (symbolp s)) + s + (and (eql n 5) + (eq (symbol-package s) (find-package "KEYWORD")) + (string-equal (symbol-name s) + "ABCD")))) + t) + +(deftest read-symbol-8 + (multiple-value-bind (s n) + (ignore-errors (read-from-string "::ABCD")) + (if (not (symbolp s)) + s + (and (eql n 6) + (eq (symbol-package s) (find-package "KEYWORD")) + (string-equal (symbol-name s) + "ABCD")))) + t) + +(defun read-symbol-9-body (natoms maxlen) + (let* ((chars (concatenate 'string + "abcdefghijklmnopqrstuvwxyz" + "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + "0123456789" + "<,>.?/\"':;[{]}~`!@#$%^&*()_-+= \\|")) + (nchars (length chars))) + (loop + for i from 1 to natoms + count + (let* ((len (random (1+ maxlen))) + (actual-len 0) + (s (make-string (+ 2 (* 2 len)))) + (s2 (make-string len))) + (loop for j from 0 to (1- len) do + (let ((c (elt chars (random (max 1 (1- nchars)))))) + (when (member c '(#\| #\\)) + (setf (elt s actual-len) #\\) + (incf actual-len)) + (setf (elt s actual-len) c) + (setf (elt s2 j) c) + (incf actual-len))) + (let ((actual-string (subseq s 0 actual-len))) + (multiple-value-bind (sym nread) + (ignore-errors (read-from-string + (concatenate 'string + "#:|" actual-string "|"))) + (unless (and (symbolp sym) + (eql nread (+ 4 actual-len)) + (string-equal s2 (symbol-name sym))) + (format t "Symbol read failed: ~S (~S) read as ~S~%" + actual-string s2 sym :readably t) + t))))))) + +(deftest read-symbol-9 + (read-symbol-9-body 1000 100) + 0) + +(deftest read-symbol-10 + (handler-case + (equal (symbol-name + (read-from-string + (with-output-to-string (s) + (write (make-symbol ":") + :readably t + :stream s)))) + ":") + (error (c) c)) + t) + + diff --git a/ansi-tests/reduce.lsp b/ansi-tests/reduce.lsp new file mode 100644 index 0000000000000000000000000000000000000000..043b8a026c98d7da9d11514edad7c89c3c16af2d --- /dev/null +++ b/ansi-tests/reduce.lsp @@ -0,0 +1,248 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Aug 18 14:08:57 2002 +;;;; Contains: Tests for function REDUCE + +(in-package :cl-test) + +(deftest reduce-list.1 + (reduce #'cons '(a b c d e f)) + (((((a . b) . c) . d) . e) . f)) + +(deftest reduce-list.2 + (reduce #'cons '(a b c d e f) :from-end t) + (a b c d e . f)) + +(deftest reduce-list.3 + (reduce #'cons '(a b c d e f) :initial-value 'z) + ((((((z . a) . b) . c) . d) . e) . f)) + +(deftest reduce-list.4 + (reduce #'cons '(a b c d e f) :from-end t :initial-value 'g) + (a b c d e f . g)) + +(deftest reduce-list.5 + (reduce #'cons '(a b c d e f) :from-end nil) + (((((a . b) . c) . d) . e) . f)) + +(deftest reduce-list.6 + (reduce #'cons '(a b c d e f) :from-end 17) + (a b c d e . f)) + +(deftest reduce-list.7 + (reduce #'cons '(a b c d e f) :end nil) + (((((a . b) . c) . d) . e) . f)) + +(deftest reduce-list.8 + (reduce #'cons '(a b c d e f) :end 3) + ((a . b) . c)) + +(deftest reduce-list.9 + (reduce #'cons '(a b c d e f) :start 1 :end 4) + ((b . c) . d)) + +(deftest reduce-list.10 + (reduce #'cons '(a b c d e f) :start 1 :end 4 :from-end t) + (b c . d)) + +(deftest reduce-list.11 + (reduce #'cons '(a b c d e f) :start 1 :end 4 :from-end t + :initial-value nil) + (b c d)) + +(deftest reduce-list.12 + (reduce 'cons '(a b c d e f)) + (((((a . b) . c) . d) . e) . f)) + +(deftest reduce-list.13 + (reduce #'+ nil) + 0) + +(deftest reduce-list.14 + (reduce #'+ '(1 2 3) :start 0 :end 0) + 0) + +(deftest reduce-list.15 + (reduce #'+ '(1 2 3) :key '1+) + 9) + +(deftest reduce-list.16 + (reduce #'cons '(1 2 3) :key '1+ :from-end t :initial-value nil) + (2 3 4)) + +(deftest reduce-list.17 + (reduce #'+ '(1 2 3 4 5 6 7) :key '1+ :start 2 :end 6) + 22) + +;;;;;;; + +(deftest reduce-array.1 + (reduce #'cons #(a b c d e f)) + (((((a . b) . c) . d) . e) . f)) + +(deftest reduce-array.2 + (reduce #'cons #(a b c d e f) :from-end t) + (a b c d e . f)) + +(deftest reduce-array.3 + (reduce #'cons #(a b c d e f) :initial-value 'z) + ((((((z . a) . b) . c) . d) . e) . f)) + +(deftest reduce-array.4 + (reduce #'cons #(a b c d e f) :from-end t :initial-value 'g) + (a b c d e f . g)) + +(deftest reduce-array.5 + (reduce #'cons #(a b c d e f) :from-end nil) + (((((a . b) . c) . d) . e) . f)) + +(deftest reduce-array.6 + (reduce #'cons #(a b c d e f) :from-end 17) + (a b c d e . f)) + +(deftest reduce-array.7 + (reduce #'cons #(a b c d e f) :end nil) + (((((a . b) . c) . d) . e) . f)) + +(deftest reduce-array.8 + (reduce #'cons #(a b c d e f) :end 3) + ((a . b) . c)) + +(deftest reduce-array.9 + (reduce #'cons #(a b c d e f) :start 1 :end 4) + ((b . c) . d)) + +(deftest reduce-array.10 + (reduce #'cons #(a b c d e f) :start 1 :end 4 :from-end t) + (b c . d)) + +(deftest reduce-array.11 + (reduce #'cons #(a b c d e f) :start 1 :end 4 :from-end t + :initial-value nil) + (b c d)) + +(deftest reduce-array.12 + (reduce 'cons #(a b c d e f)) + (((((a . b) . c) . d) . e) . f)) + +(deftest reduce-array.13 + (reduce #'+ #(1 2 3) :start 0 :end 0) + 0) + +;;;;;;;; + +(deftest reduce-error.1 + (handler-case (reduce 'cons 'a) + (type-error (c) 'type-error) + (error (c) c)) + type-error) + +;;;;;;;; + +(deftest reduce-string.1 + (reduce #'cons "abcdef") + (((((#\a . #\b) . #\c) . #\d) . #\e) . #\f)) + +(deftest reduce-string.2 + (reduce #'cons "abcdef" :from-end t) + (#\a #\b #\c #\d #\e . #\f)) + +(deftest reduce-string.3 + (reduce #'cons "abcdef" :initial-value 'z) + ((((((z . #\a) . #\b) . #\c) . #\d) . #\e) . #\f)) + +(deftest reduce-string.4 + (reduce #'cons "abcdef" :from-end t :initial-value 'g) + (#\a #\b #\c #\d #\e #\f . g)) + +(deftest reduce-string.5 + (reduce #'cons "abcdef" :from-end nil) + (((((#\a . #\b) . #\c) . #\d) . #\e) . #\f)) + +(deftest reduce-string.6 + (reduce #'cons "abcdef" :from-end 17) + (#\a #\b #\c #\d #\e . #\f)) + +(deftest reduce-string.7 + (reduce #'cons "abcdef" :end nil) + (((((#\a . #\b) . #\c) . #\d) . #\e) . #\f)) + +(deftest reduce-string.8 + (reduce #'cons "abcdef" :end 3) + ((#\a . #\b) . #\c)) + +(deftest reduce-string.9 + (reduce #'cons "abcdef" :start 1 :end 4) + ((#\b . #\c) . #\d)) + +(deftest reduce-string.10 + (reduce #'cons "abcdef" :start 1 :end 4 :from-end t) + (#\b #\c . #\d)) + +(deftest reduce-string.11 + (reduce #'cons "abcdef" :start 1 :end 4 :from-end t + :initial-value nil) + (#\b #\c #\d)) + +(deftest reduce-string.12 + (reduce 'cons "abcdef") + (((((#\a . #\b) . #\c) . #\d) . #\e) . #\f)) + +(deftest reduce-string.13 + (reduce #'+ "abc" :start 0 :end 0) + 0) + +;;;;;;;; + +(deftest reduce-bitstring.1 + (reduce #'cons #*001101) + (((((0 . 0) . 1) . 1) . 0) . 1)) + +(deftest reduce-bitstring.2 + (reduce #'cons #*001101 :from-end t) + (0 0 1 1 0 . 1)) + +(deftest reduce-bitstring.3 + (reduce #'cons #*001101 :initial-value 'z) + ((((((z . 0) . 0) . 1) . 1) . 0) . 1)) + +(deftest reduce-bitstring.4 + (reduce #'cons #*001101 :from-end t :initial-value 'g) + (0 0 1 1 0 1 . g)) + +(deftest reduce-bitstring.5 + (reduce #'cons #*001101 :from-end nil) + (((((0 . 0) . 1) . 1) . 0) . 1)) + +(deftest reduce-bitstring.6 + (reduce #'cons #*001101 :from-end 17) + (0 0 1 1 0 . 1)) + +(deftest reduce-bitstring.7 + (reduce #'cons #*001101 :end nil) + (((((0 . 0) . 1) . 1) . 0) . 1)) + +(deftest reduce-bitstring.8 + (reduce #'cons #*001101 :end 3) + ((0 . 0) . 1)) + +(deftest reduce-bitstring.9 + (reduce #'cons #*001101 :start 1 :end 4) + ((0 . 1) . 1)) + +(deftest reduce-bitstring.10 + (reduce #'cons #*001101 :start 1 :end 4 :from-end t) + (0 1 . 1)) + +(deftest reduce-bitstring.11 + (reduce #'cons #*001101 :start 1 :end 4 :from-end t + :initial-value nil) + (0 1 1)) + +(deftest reduce-bitstring.12 + (reduce 'cons #*001101) + (((((0 . 0) . 1) . 1) . 0) . 1)) + +(deftest reduce-bitstring.13 + (reduce #'+ #(1 1 1) :start 0 :end 0) + 0) diff --git a/ansi-tests/remove-aux.lsp b/ansi-tests/remove-aux.lsp new file mode 100644 index 0000000000000000000000000000000000000000..054c521c24d92f640e17699b01a05ffee7ad08b2 --- /dev/null +++ b/ansi-tests/remove-aux.lsp @@ -0,0 +1,219 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Sep 15 07:42:36 2002 +;;;; Contains: Auxiliary functions for testing REMOVE and related functions + +(in-package :cl-test) + +(defun make-random-element (type) + (cond + ((subtypep 'fixnum type) + (random most-positive-fixnum)) + ((subtypep '(integer 0 255) type) + (random 255)) + ((subtypep '(integer 0 7) type) + (random 8)) + ((subtypep 'bit type) + (random 2)) + ((subtypep 'symbol type) + (elt '(a b c d e f g h) (random 8))) + ((subtypep '(member #\a #\b #\c #\d #\e #\f #\g #\h) type) + (elt "abcdefgh" (random 8))) + (t (error "Can't get random element of type ~A~%." type)))) + +(defun random-from-seq (seq) + "Generate a random member of a sequence." + (let ((len (length seq))) + (assert (> len 0)) + (elt seq (random len)))) + +(defmacro random-case (&body cases) + (let ((len (length cases))) + (assert (> len 0)) + `(case (random ,len) + ,@(loop for i from 0 for e in cases collect `(,i ,e)) + (t (error "Can't happen?! (in random-case~%"))))) + +(defun make-random-remove-input (len type element-type) + + "Randomly generate a test case for REMOVE. Given a length + a sequence type, and an element type, produce a random + sequence of length LEN of sequence type TYPE, and either + generate a random member of the sequence or a random + element of the element type to delete from the sequence." + + (let* ((seq (if (subtypep type 'list) + (loop for i from 1 to len collect + (make-random-element element-type)) + (let ((seq (make-sequence type len))) + (dotimes (i len) + (setf (elt seq i) (make-random-element element-type))) + seq))) + (e (if (and (> len 0) (eql (random 2) 0)) + (elt seq (random len)) + (make-random-element element-type))) + ) + (values len seq e))) + +(defun my-remove (element + sequence + &key + (start 0) + (end nil) + (test #'eql test-p) + (test-not nil test-not-p) + (key nil) + (from-end nil) + (count nil)) + (assert (not (and test-p test-not-p))) + (my-remove-if + (cond (test-p #'(lambda (x) (funcall test element x))) + (test-not-p #'(lambda (x) (not (funcall test-not element x)))) + (t #'(lambda (x) (eql element x)))) + sequence :start start :end end :key key :from-end from-end :count count)) + +(defun my-remove-if (predicate + original-sequence + &key (from-end nil) + (start 0) + (end nil) + (count nil) + (key #'identity)) + (let ((len (length original-sequence)) + (sequence (copy-seq original-sequence))) + (unless end (setq end len)) + (unless key (setq key #'identity)) + (unless count (setq count len)) + + ;; Check that everything's kosher + (assert (<= 0 start end len)) + (assert (typep sequence 'sequence)) + (assert (integerp count)) + (assert (or (symbolp predicate) (functionp predicate))) + (assert (or (symbolp key) (functionp key))) + + ;; If FROM-END, reverse the sequence and flip + ;; start, end + (when from-end + (psetq sequence (nreverse sequence) + start (- len end) + end (- len start))) + + ;; Accumulate a list of elements for the result + (let ((pos 0) + (result nil)) ;; accumulate in reverse order + (map nil + #'(lambda (e) + (if (and (> count 0) + (>= pos start) + (< pos end) + (funcall predicate (funcall key e))) + (decf count) + (push e result)) + (incf pos)) + sequence) + (unless from-end + (setq result (nreverse result))) + ;; Convert to the correct type + (if (listp sequence) + result + (let ((element-type (array-element-type original-sequence))) + (make-array (length result) :element-type element-type + :initial-contents result)))))) + +(defun my-remove-if-not (pred &rest args) + (apply #'my-remove-if (complement pred) args)) + +(defun coin (&optional (n 2)) (eql (random n) 0)) + +;; Randomly permute a sequence +(defun random-permute (seq) + (setq seq (copy-seq seq)) + (let ((len (length seq))) + (loop for i from len downto 2 + do (let ((r (random i))) + (rotatef (elt seq r) (elt seq (1- i)))))) + seq) + +(defun make-random-rd-params (maxlen) + "Generate random paramaters for remove/delete/etc. functions." + (let* ((element-type t) + (type-select (random 7)) + (type + (case type-select + (0 'list) + (1 'vector) + (2 (setq element-type 'character) 'string) + (3 (setq element-type 'bit) 'bit-vector) + (4 'simple-vector) + (5 (setq element-type '(integer 0 255)) + '(vector (integer 0 255))) + (6 (setq element-type 'fixnum) '(vector fixnum)) + (t (error "Can't happen?!~%")))) + (len (random maxlen)) + (start (and (coin) (> len 0) + (random len))) + (end (and (coin) + (if start (+ start (random (- len start))) + (random (1+ len))))) + (from-end (coin)) + (count (and (coin) + (random (1+ len)))) + (seq (multiple-value-bind (x y z) (make-random-remove-input len type element-type) + y)) + (key (and (coin) + (case type-select + (2 (random-case + #'char-upcase 'char-upcase + #'char-downcase 'char-downcase)) + (3 #'(lambda (x) (- 1 x))) + ((5 6) (random-case #'1+ '1+ #'1- '1-)) + (t (random-case 'identity #'identity))))) + (test (and (eql (random 3) 0) + (random-case 'eq 'eql 'equal + #'eq #'eql #'equal))) + (test-not (and (not test) + (coin) + (random-case 'eq 'eql 'equal + #'eq #'eql #'equal))) + ) + ;; Return parameters + (values + element-type type len start end from-end count seq key test test-not))) + +(defun random-test-remove-args (maxlen) + (multiple-value-bind (element-type type len start end from-end count seq key test test-not) + (make-random-rd-params maxlen) + (let ((element (if (and (coin) (> len 0)) + (random-from-seq seq) + (make-random-element element-type))) + (arg-list + (reduce #'nconc + (random-permute + (list + (when start (list :start start)) + (cond (end (list :end end)) + ((coin) (list :end nil))) + (cond (from-end (list :from-end from-end)) + ((coin) (list :from-end nil))) + (cond (count (list :count count)) + ((coin) (list :count nil))) + (cond (key (list :key key)) + ;; ((coin) (list :key nil)) + ) + (when test (list :test test)) + (when test-not (list :test test-not))))))) + (values element seq arg-list)))) + +(defun random-test-remove (maxlen) + (multiple-value-bind (element seq arg-list) + (random-test-remove-args maxlen) + (let* ((seq1 (copy-seq seq)) + (seq2 (copy-seq seq)) + (seq1r (apply #'remove element seq1 arg-list)) + (seq2r (apply #'my-remove element seq1 arg-list))) + (cond + ((not (equalp seq seq1)) :fail1) + ((not (equalp seq seq2)) :fail2) + ((not (equalp seq1r seq2r)) :fail3) + (t t))))) diff --git a/ansi-tests/remove-duplicates-aux.lsp b/ansi-tests/remove-duplicates-aux.lsp new file mode 100644 index 0000000000000000000000000000000000000000..77e540955343ab3ab8c0c40bdf80d61a84850f94 --- /dev/null +++ b/ansi-tests/remove-duplicates-aux.lsp @@ -0,0 +1,52 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Mon Sep 23 20:59:10 2002 +;;;; Contains: Aux. functions for testing REMOVE-DUPLICATES/DELETE-DUPLICATES + +(in-package :cl-test) + +(defun my-remove-duplicates (orig-sequence + &key from-end test test-not (start 0) end key) + (assert (typep orig-sequence 'sequence)) + (let* ((sequence orig-sequence) + (len (length sequence))) + (unless end (setq end len)) + (unless key (setq key #'identity)) + (cond + (test (assert (not test-not))) + (test-not (setq test #'(lambda (x y) (not (funcall test x y))))) + (t (setq test #'eql))) + (assert (integerp start)) + (assert (integerp end)) + (assert (<= 0 start end len)) + (format t "start = ~A, end = ~A, len = ~A~%" start end len) + (if from-end + (psetq start (- len end) + end (- len start) + sequence (reverse sequence)) + (setq sequence (copy-seq sequence))) + (format t "start = ~A, end = ~A, len = ~A~%" start end len) + (assert (<= 0 start end len) (start end len)) + (let ((result nil)) + (loop for i from 0 below start + do (push (elt sequence i) result)) + (loop for i from start below end + for x = (elt sequence i) + unless (position x + sequence + :start (1+ i) + :end end + :test test + :key key) + do (push x result)) + (loop for i from end below len + do (push (elt sequence i) result)) + (unless from-end (setq result (reverse result))) + (cond + ((listp orig-sequence) result) + ((arrayp orig-sequence) + (make-array (length result) :initial-contents result + :element-type (array-element-type orig-sequence))) + (t (assert nil)))))) + + diff --git a/ansi-tests/remove.lsp b/ansi-tests/remove.lsp new file mode 100644 index 0000000000000000000000000000000000000000..dfb3dddc00b8322a10e15f31f9cec9e59cfc66ce --- /dev/null +++ b/ansi-tests/remove.lsp @@ -0,0 +1,269 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Sep 14 11:46:05 2002 +;;;; Contains: Tests for REMOVE + +(in-package :cl-test) + +(deftest remove-list.1 + (let* ((orig '(a b c a b d a c b a e)) + (x (copy-seq orig)) + (y (remove 'a x))) + (and (equalp orig x) y)) + (b c b d c b e)) + +(deftest remove-list.2 + (let* ((orig '(a b c a b d a c b a e)) + (x (copy-seq orig)) + (y (remove 'a x :count nil))) + (and (equalp orig x) y)) + (b c b d c b e)) + +(deftest remove-list.3 + (let* ((orig '(a b c a b d a c b a e)) + (x (copy-seq orig)) + (y (remove 'a x :key nil))) + (and (equalp orig x) y)) + (b c b d c b e)) + +(deftest remove-list.4 + (let* ((orig '(a b c a b d a c b a e)) + (x (copy-seq orig)) + (y (remove 'a x :count 100))) + (and (equalp orig x) y)) + (b c b d c b e)) + +(deftest remove-list.5 + (let* ((orig '(a b c a b d a c b a e)) + (x (copy-seq orig)) + (y (remove 'a x :count 0))) + (and (equalp orig x) y)) + (a b c a b d a c b a e)) + +(deftest remove-list.6 + (let* ((orig '(a b c a b d a c b a e)) + (x (copy-seq orig)) + (y (remove 'a x :count 1))) + (and (equalp orig x) y)) + (b c a b d a c b a e)) + +(deftest remove-list.7 + (let* ((orig '(a b c a b d a c b a e)) + (x (copy-seq orig)) + (y (remove 'c x :count 1))) + (and (equalp orig x) y)) + (a b a b d a c b a e)) + +(deftest remove-list.8 + (let* ((orig '(a b c a b d a c b a e)) + (x (copy-seq orig)) + (y (remove 'a x :from-end t))) + (and (equalp orig x) y)) + (b c b d c b e)) + +(deftest remove-list.9 + (let* ((orig '(a b c a b d a c b a e)) + (x (copy-seq orig)) + (y (remove 'a x :from-end t :count 1))) + (and (equalp orig x) y)) + (a b c a b d a c b e)) + +(deftest remove-list.10 + (let* ((orig '(a b c a b d a c b a e)) + (x (copy-seq orig)) + (y (remove 'a x :from-end t :count 4))) + (and (equalp orig x) y)) + (b c b d c b e)) + +(deftest remove-list.11 + (let* ((orig '(a b c a b d a c b a e)) + (x (copy-seq orig))) + (values + (loop for i from 0 to 10 + collect (remove 'a x :start i)) + (equalp orig x))) + ((b c b d c b e) + (a b c b d c b e) + (a b c b d c b e) + (a b c b d c b e) + (a b c a b d c b e) + (a b c a b d c b e) + (a b c a b d c b e) + (a b c a b d a c b e) + (a b c a b d a c b e) + (a b c a b d a c b e) + (a b c a b d a c b a e)) + t) + +(deftest remove-list.12 + (let* ((orig '(a b c a b d a c b a e)) + (x (copy-seq orig))) + (values + (loop for i from 0 to 10 + collect (remove 'a x :start i :end nil)) + (equalp orig x))) + ((b c b d c b e) + (a b c b d c b e) + (a b c b d c b e) + (a b c b d c b e) + (a b c a b d c b e) + (a b c a b d c b e) + (a b c a b d c b e) + (a b c a b d a c b e) + (a b c a b d a c b e) + (a b c a b d a c b e) + (a b c a b d a c b a e)) + t) + +(deftest remove-list.13 + (let* ((orig '(a b c a b d a c b a e)) + (x (copy-seq orig))) + (values + (loop for i from 0 to 10 + collect (remove 'a x :start i :end 11)) + (equalp orig x))) + ((b c b d c b e) + (a b c b d c b e) + (a b c b d c b e) + (a b c b d c b e) + (a b c a b d c b e) + (a b c a b d c b e) + (a b c a b d c b e) + (a b c a b d a c b e) + (a b c a b d a c b e) + (a b c a b d a c b e) + (a b c a b d a c b a e)) + t) + +(deftest remove-list.14 + (let* ((orig '(a b c a b d a c b a e)) + (x (copy-seq orig)) + (y (remove 'a x :end nil))) + (and (equalp orig x) y)) + (b c b d c b e)) + +(deftest remove-list.15 + (let* ((orig '(a b c a b d a c b a e)) + (x (copy-seq orig))) + (values + (loop for i from 0 to 9 + collect (remove 'a x :start i :end 9)) + (equalp orig x))) + ((b c b d c b a e) + (a b c b d c b a e) + (a b c b d c b a e) + (a b c b d c b a e) + (a b c a b d c b a e) + (a b c a b d c b a e) + (a b c a b d c b a e) + (a b c a b d a c b a e) + (a b c a b d a c b a e) + (a b c a b d a c b a e)) + t) + +(deftest remove-list.16 + (let* ((orig '(a b c a b d a c b a e)) + (x (copy-seq orig))) + (values + (loop for i from 0 to 10 + collect (remove 'a x :start i :end 11 :count 1)) + (equalp orig x))) + ((b c a b d a c b a e) + (a b c b d a c b a e) + (a b c b d a c b a e) + (a b c b d a c b a e) + (a b c a b d c b a e) + (a b c a b d c b a e) + (a b c a b d c b a e) + (a b c a b d a c b e) + (a b c a b d a c b e) + (a b c a b d a c b e) + (a b c a b d a c b a e)) + t) + +(deftest remove-list.17 + (let* ((orig '(a b c a b d a c b a e)) + (x (copy-seq orig))) + (values + (loop for i from 0 to 10 + collect (remove 'a x :start i :end (1+ i))) + (equalp orig x))) + (( b c a b d a c b a e) + (a b c a b d a c b a e) + (a b c a b d a c b a e) + (a b c b d a c b a e) + (a b c a b d a c b a e) + (a b c a b d a c b a e) + (a b c a b d c b a e) + (a b c a b d a c b a e) + (a b c a b d a c b a e) + (a b c a b d a c b e) + (a b c a b d a c b a e)) + t) + +;;; Show that it tests using EQL, not EQ +(deftest remove-list.18 + (let* ((i (1+ most-positive-fixnum)) + (orig (list i 0 i 1 i 2 3)) + (x (copy-seq orig)) + (y (remove (1+ most-positive-fixnum) x))) + (and (equalp orig x) y)) + (0 1 2 3)) + +(deftest remove-list.19 + (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) + (x (copy-seq orig)) + (y (remove 1 x :key #'1-))) + (and (equalp orig x) y)) + (1 3 6 1 4 1 3 7)) + +(deftest remove-list.20 + (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) + (x (copy-seq orig)) + (y (remove 3 x :test #'>))) + (and (equalp orig x) y)) + (3 6 4 3 7)) + +(deftest remove-list.21 + (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) + (x (copy-seq orig)) + (y (remove 3 x :test '> :from-end t))) + (and (equalp orig x) y)) + (3 6 4 3 7)) + +(deftest remove-list.22 + (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) + (x (copy-seq orig)) + (y (remove 2 x :key nil))) + (and (equalp orig x) y)) + (1 3 6 1 4 1 3 7)) + +(deftest remove-list.23 + (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) + (x (copy-seq orig)) + (y (remove 1 x :key '1-))) + (and (equalp orig x) y)) + (1 3 6 1 4 1 3 7)) + +(deftest remove-list.24 + (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) + (x (copy-seq orig)) + (y (remove 3 x :test-not #'<=))) + (and (equalp orig x) y)) + (3 6 4 3 7)) + +(deftest remove-list.25 + (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) + (x (copy-seq orig)) + (y (remove 3 x :test-not '<= :from-end t))) + (and (equalp orig x) y)) + (3 6 4 3 7)) + +(deftest remove-list.26 + (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) + (x (copy-seq orig)) + (y (remove 3 x :from-end t :start 1 :end 5))) + (and (equalp orig x) y)) + (1 2 2 6 1 2 4 1 3 2 7)) + +;;; To do: add call to the randomized REMOVE tester diff --git a/ansi-tests/replace.lsp b/ansi-tests/replace.lsp new file mode 100644 index 0000000000000000000000000000000000000000..35bf6ad24a278a1b1fc26b94435c72539373bbbd --- /dev/null +++ b/ansi-tests/replace.lsp @@ -0,0 +1,425 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Tue Aug 27 16:11:38 2002 +;;;; Contains: Tests for REPLACE + +(in-package :cl-test) + +(deftest replace-list.1 + (let* ((x (copy-seq '(a b c d e f g))) + (result (replace x '(x y z)))) + (values (eq x result) result)) + t + (x y z d e f g)) + +(deftest replace-list.2 + (let* ((x (copy-seq '(a b c d e f g))) + (result (replace x '(x y z) :start1 1))) + (values (eq x result) result)) + t + (a x y z e f g)) + +(deftest replace-list.3 + (let* ((x (copy-seq '(a b c d e f g))) + (result (replace x '(x y z) :start1 4))) + (values (eq x result) result)) + t + (a b c d x y z)) + +(deftest replace-list.4 + (let* ((x (copy-seq '(a b c d e f g))) + (result (replace x '(x y z) :start1 5))) + (values (eq x result) result)) + t + (a b c d e x y)) + +(deftest replace-list.5 + (let* ((x (copy-seq '(a b c d e f g))) + (result (replace x '(x y z) :start1 6))) + (values (eq x result) result)) + t + (a b c d e f x)) + +(deftest replace-list.6 + (let* ((x (copy-seq '(a b c d e f g))) + (result (replace x #(x y z) :start1 2))) + (values (eq x result) result)) + t + (a b x y z f g)) + +(deftest replace-list.7 + (replace nil #(x y z)) + nil) + +(deftest replace-list.8 + (let* ((x (copy-seq '(a b c d e f g))) + (result (replace x '(x y z) :end1 1))) + (values (eq x result) result)) + t + (x b c d e f g)) + +(deftest replace-list.9 + (let* ((x (copy-seq '(a b c d e f g))) + (result (replace x '(x y z) :start1 3 :end1 4))) + (values (eq x result) result)) + t + (a b c x e f g)) + +(deftest replace-list.10 + (let* ((x (copy-seq '(a b c d e f g))) + (result (replace x '(x y z) :start1 0 :end1 5))) + (values (eq x result) result)) + t + (x y z d e f g)) + + +(deftest replace-list.11 + (let* ((x (copy-seq '(a b c d e f g))) + (result (replace x '(x y z) :start2 1))) + (values (eq x result) result)) + t + (y z c d e f g)) + +(deftest replace-list.12 + (let* ((x (copy-seq '(a b c d e f g))) + (result (replace x '(x y z) :start2 1 :end1 nil))) + (values (eq x result) result)) + t + (y z c d e f g)) + +(deftest replace-list.13 + (let* ((x (copy-seq '(a b c d e f g))) + (result (replace x '(x y z) :start2 1 :end2 nil))) + (values (eq x result) result)) + t + (y z c d e f g)) + +(deftest replace-list.14 + (let* ((x (copy-seq '(a b c d e f g))) + (result (replace x '(x y z) :start2 1 :end2 2))) + (values (eq x result) result)) + t + (y b c d e f g)) + +(deftest replace-list.15 + (let* ((x (copy-seq '(a b c d e f g))) + (result (replace x '(x y z) :start1 4 :end1 5 :start2 1 :end2 2))) + (values (eq x result) result)) + t + (a b c d y f g)) + + +;;; Tests of vectors + +(deftest replace-vector.1 + (let* ((x (copy-seq #(a b c d e f g))) + (result (replace x #(x y z)))) + (values (eq x result) result)) + t + #(x y z d e f g)) + +(deftest replace-vector.2 + (let* ((x (copy-seq #(a b c d e f g))) + (result (replace x #(x y z) :start1 1))) + (values (eq x result) result)) + t + #(a x y z e f g)) + +(deftest replace-vector.3 + (let* ((x (copy-seq #(a b c d e f g))) + (result (replace x #(x y z) :start1 4))) + (values (eq x result) result)) + t + #(a b c d x y z)) + +(deftest replace-vector.4 + (let* ((x (copy-seq #(a b c d e f g))) + (result (replace x #(x y z) :start1 5))) + (values (eq x result) result)) + t + #(a b c d e x y)) + +(deftest replace-vector.5 + (let* ((x (copy-seq #(a b c d e f g))) + (result (replace x #(x y z) :start1 6))) + (values (eq x result) result)) + t + #(a b c d e f x)) + +(deftest replace-vector.6 + (let* ((x (copy-seq #(a b c d e f g))) + (result (replace x '(x y z) :start1 2))) + (values (eq x result) result)) + t + #(a b x y z f g)) + +(deftest replace-vector.7 + (replace #() #(x y z)) + #()) + +(deftest replace-vector.8 + (let* ((x (copy-seq #(a b c d e f g))) + (result (replace x #(x y z) :end1 1))) + (values (eq x result) result)) + t + #(x b c d e f g)) + +(deftest replace-vector.9 + (let* ((x (copy-seq #(a b c d e f g))) + (result (replace x #(x y z) :start1 3 :end1 4))) + (values (eq x result) result)) + t + #(a b c x e f g)) + +(deftest replace-vector.10 + (let* ((x (copy-seq #(a b c d e f g))) + (result (replace x #(x y z) :start1 0 :end1 5))) + (values (eq x result) result)) + t + #(x y z d e f g)) + + +(deftest replace-vector.11 + (let* ((x (copy-seq #(a b c d e f g))) + (result (replace x #(x y z) :start2 1))) + (values (eq x result) result)) + t + #(y z c d e f g)) + +(deftest replace-vector.12 + (let* ((x (copy-seq #(a b c d e f g))) + (result (replace x #(x y z) :start2 1 :end1 nil))) + (values (eq x result) result)) + t + #(y z c d e f g)) + +(deftest replace-vector.13 + (let* ((x (copy-seq #(a b c d e f g))) + (result (replace x #(x y z) :start2 1 :end2 nil))) + (values (eq x result) result)) + t + #(y z c d e f g)) + +(deftest replace-vector.14 + (let* ((x (copy-seq #(a b c d e f g))) + (result (replace x #(x y z) :start2 1 :end2 2))) + (values (eq x result) result)) + t + #(y b c d e f g)) + +(deftest replace-vector.15 + (let* ((x (copy-seq #(a b c d e f g))) + (result (replace x #(x y z) :start1 4 :end1 5 :start2 1 :end2 2))) + (values (eq x result) result)) + t + #(a b c d y f g)) + +;;; tests on bit strings + +(deftest replace-bitstring.1 + (let* ((x (copy-seq #*1101001)) + (result (replace x #*011))) + (values (eq x result) result)) + t + #*0111001) + +(deftest replace-bitstring.2 + (let* ((x (copy-seq #*1101001)) + (result (replace x #*011 :start1 1))) + (values (eq x result) result)) + t + #*1011001) + +(deftest replace-bitstring.3 + (let* ((x (copy-seq #*1101001)) + (result (replace x #*011 :start1 4))) + (values (eq x result) result)) + t + #*1101011) + +(deftest replace-bitstring.4 + (let* ((x (copy-seq #*0000000)) + (result (replace x #*111 :start1 5))) + (values (eq x result) result)) + t + #*0000011) + +(deftest replace-bitstring.5 + (let* ((x (copy-seq #*0000000)) + (result (replace x #*100 :start1 6))) + (values (eq x result) result)) + t + #*0000001) + +(deftest replace-bitstring.6 + (let* ((x (copy-seq #*0000000)) + (result (replace x '(1 1 1) :start1 2))) + (values (eq x result) result)) + t + #*0011100) + +(deftest replace-bitstring.7 + (replace #* #*111) + #*) + +(deftest replace-bitstring.8 + (let* ((x (copy-seq #*0000000)) + (result (replace x #*111 :end1 1))) + (values (eq x result) result)) + t + #*1000000) + +(deftest replace-bitstring.9 + (let* ((x (copy-seq #*0000000)) + (result (replace x #*110 :start1 3 :end1 4))) + (values (eq x result) result)) + t + #*0001000) + +(deftest replace-bitstring.10 + (let* ((x (copy-seq #*0000000)) + (result (replace x #*111 :start1 0 :end1 5))) + (values (eq x result) result)) + t + #*1110000) + + +(deftest replace-bitstring.11 + (let* ((x (copy-seq #*0000000)) + (result (replace x #*011 :start2 1))) + (values (eq x result) result)) + t + #*1100000) + +(deftest replace-bitstring.12 + (let* ((x (copy-seq #*0000000)) + (result (replace x #*011 :start2 1 :end1 nil))) + (values (eq x result) result)) + t + #*1100000) + +(deftest replace-bitstring.13 + (let* ((x (copy-seq #*0000000)) + (result (replace x #*011 :start2 1 :end2 nil))) + (values (eq x result) result)) + t + #*1100000) + +(deftest replace-bitstring.14 + (let* ((x (copy-seq #*0000000)) + (result (replace x #*011 :start2 1 :end2 2))) + (values (eq x result) result)) + t + #*1000000) + +(deftest replace-bitstring.15 + (let* ((x (copy-seq #*0000000)) + (result (replace x #*011 :start1 4 :end1 5 :start2 1 :end2 2))) + (values (eq x result) result)) + t + #*0000100) + +;;; Tests on strings + +(deftest replace-string.1 + (let* ((x (copy-seq "abcdefg")) + (result (replace x "xyz"))) + (values (eq x result) result)) + t + "xyzdefg") + +(deftest replace-string.2 + (let* ((x (copy-seq "abcdefg")) + (result (replace x "xyz" :start1 1))) + (values (eq x result) result)) + t + "axyzefg") + +(deftest replace-string.3 + (let* ((x (copy-seq "abcdefg")) + (result (replace x "xyz" :start1 4))) + (values (eq x result) result)) + t + "abcdxyz") + +(deftest replace-string.4 + (let* ((x (copy-seq "abcdefg")) + (result (replace x "xyz" :start1 5))) + (values (eq x result) result)) + t + "abcdexy") + +(deftest replace-string.5 + (let* ((x (copy-seq "abcdefg")) + (result (replace x "xyz" :start1 6))) + (values (eq x result) result)) + t + "abcdefx") + +(deftest replace-string.6 + (let* ((x (copy-seq "abcdefg")) + (result (replace x '(#\x #\y #\z) :start1 2))) + (values (eq x result) result)) + t + "abxyzfg") + +(deftest replace-string.7 + (replace "" "xyz") + "") + +(deftest replace-string.8 + (let* ((x (copy-seq "abcdefg")) + (result (replace x "xyz" :end1 1))) + (values (eq x result) result)) + t + "xbcdefg") + +(deftest replace-string.9 + (let* ((x (copy-seq "abcdefg")) + (result (replace x "xyz" :start1 3 :end1 4))) + (values (eq x result) result)) + t + "abcxefg") + +(deftest replace-string.10 + (let* ((x (copy-seq "abcdefg")) + (result (replace x "xyz" :start1 0 :end1 5))) + (values (eq x result) result)) + t + "xyzdefg") + + +(deftest replace-string.11 + (let* ((x (copy-seq "abcdefg")) + (result (replace x "xyz" :start2 1))) + (values (eq x result) result)) + t + "yzcdefg") + +(deftest replace-string.12 + (let* ((x (copy-seq "abcdefg")) + (result (replace x "xyz" :start2 1 :end1 nil))) + (values (eq x result) result)) + t + "yzcdefg") + +(deftest replace-string.13 + (let* ((x (copy-seq "abcdefg")) + (result (replace x "xyz" :start2 1 :end2 nil))) + (values (eq x result) result)) + t + "yzcdefg") + +(deftest replace-string.14 + (let* ((x (copy-seq "abcdefg")) + (result (replace x "xyz" :start2 1 :end2 2))) + (values (eq x result) result)) + t + "ybcdefg") + +(deftest replace-string.15 + (let* ((x (copy-seq "abcdefg")) + (result (replace x "xyz" :start1 4 :end1 5 :start2 1 :end2 2))) + (values (eq x result) result)) + t + "abcdyfg") diff --git a/ansi-tests/reverse.lsp b/ansi-tests/reverse.lsp new file mode 100644 index 0000000000000000000000000000000000000000..69f09f213ca17265b724906dde499a279da4e135 --- /dev/null +++ b/ansi-tests/reverse.lsp @@ -0,0 +1,87 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Tue Aug 20 23:47:28 2002 +;;;; Contains: Tests for REVERSE + +(in-package :cl-test) + +(deftest reverse-list.1 + (reverse nil) + nil) + +(deftest reverse-list.2 + (let ((x '(a b c))) + (values (reverse x) x)) + (c b a) + (a b c)) + +(deftest reverse-vector.1 + (reverse #()) + #()) + +(deftest reverse-vector.2 + (let ((x #(a b c d e))) + (values (reverse x) x)) + #(e d c b a) + #(a b c d e)) + +(deftest reverse-nonsimple-vector.1 + (let ((x (make-array 0 :fill-pointer t :adjustable t))) + (reverse x)) + #()) + +(deftest reverse-nonsimple-vector.2 + (let* ((x (make-array 5 :initial-contents '(1 2 3 4 5) + :fill-pointer t :adjustable t)) + (y (reverse x))) + (values y x (equal (type-of x) (type-of y)))) + #(5 4 3 2 1) + #(1 2 3 4 5) + t) + +(deftest reverse-bitstring.1 + (reverse #*) + #*) + +(deftest reverse-bitstring.2 + (let ((x #*000110110110)) + (values (reverse x) x)) + #*011011011000 + #*000110110110) + +(deftest reverse-string.1 + (reverse "") + "") + +(deftest reverse-string.2 + (let ((x "000110110110")) + (values (reverse x) x)) + "011011011000" + "000110110110") + +(deftest reverse-error.1 + (catch-type-error (reverse 'a)) + type-error) + +(deftest reverse-error.2 + (catch-type-error (reverse #\a)) + type-error) + +(deftest reverse-error.3 + (catch-type-error (reverse 10)) + type-error) + +(deftest reverse-error.4 + (catch-type-error (reverse 0.3)) + type-error) + +(deftest reverse-error.5 + (catch-type-error (reverse 10/3)) + type-error) + + + + + + + diff --git a/ansi-tests/search-aux.lsp b/ansi-tests/search-aux.lsp new file mode 100644 index 0000000000000000000000000000000000000000..5e3ea06db21e03fea500f58092ca8a64d3578512 --- /dev/null +++ b/ansi-tests/search-aux.lsp @@ -0,0 +1,92 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Aug 24 07:22:10 2002 +;;;; Contains: Aux. functions for testing SEARCH + +(in-package :cl-test) + +(defparameter *searched-list* + '(B B A B B B B B B B A B A B B B A B A B B B A A A A B A A B A A A A A + A B A B B A B A A B A A A B B A A B A A A A B B A B A B A A A B A B + B A B A A B B B B B A A A A A B A B B B B B A B A B B A B A B)) + +(defparameter *pattern-sublists* + (remove-duplicates + (let* ((s *searched-list*) (len (length s))) + (loop for x from 0 to 8 nconc + (loop for y from 0 to (- len x) + collect (subseq s y (+ y x))))) + :test #'equal)) + +(defparameter *searched-vector* + (make-array (length *searched-list*) + :initial-contents *searched-list*)) + +(defparameter *pattern-subvectors* + (mapcar #'(lambda (x) (apply #'vector x)) *pattern-sublists*)) + +(defparameter *searched-bitvector* + #*1101111111010111010111000010010000001011010010001100100001101010001011010011111000001011111010110101) + +(defparameter *pattern-subbitvectors* + (remove-duplicates + (let* ((s *searched-bitvector*) (len (length s))) + (loop for x from 0 to 8 nconc + (loop for y from 0 to (- len x) + collect (subseq s y (+ y x))))) + :test #'equalp)) + +(defparameter *searched-string* + "1101111111010111010111000010010000001011010010001100100001101010001011010011111000001011111010110101") + +(defparameter *pattern-substrings* + (remove-duplicates + (let* ((s *searched-string*) (len (length s))) + (loop for x from 0 to 8 nconc + (loop for y from 0 to (- len x) + collect (subseq s y (+ y x))))) + :test #'equalp)) + +(defun subseq-equalp (seq1 seq2 start1 start2 len &key (test #'equalp)) + (assert + (and + (>= start1 0) + (>= start2 0) + (<= (+ start1 len) (length seq1)) + (<= (+ start2 len) (length seq2)))) + (if (and (listp seq1) (listp seq2)) + (loop for i from 0 to (1- len) + for e1 in (nthcdr start1 seq1) + for e2 in (nthcdr start2 seq2) + always (funcall test e1 e2)) + (loop for i from 0 to (1- len) + always + (funcall test + (elt seq1 (+ start1 i)) + (elt seq2 (+ start2 i)))))) + +(defun search-check (pattern searched pos + &key (start1 0) (end1 nil) (start2 0) (end2 nil) + key from-end (test #'equalp)) + (unless end1 (setq end1 (length pattern))) + (unless end2 (setq end2 (length searched))) + (assert (<= start1 end1)) + (assert (<= start2 end2)) + (let* ((plen (- end1 start1))) + (when key + (setq pattern (map 'list key pattern)) + (setq searched (map 'list key searched))) + (if pos + (and + (subseq-equalp searched pattern pos start1 plen :test test) + (if from-end + (loop for i from (1+ pos) to (- end2 plen) + never + (subseq-equalp searched pattern i start1 plen :test test)) + (loop for i from start2 to (1- pos) + never + (subseq-equalp searched pattern i start1 plen :test test)))) + (loop for i from start2 to (- end2 plen) + never (subseq-equalp searched pattern i start1 plen :test test))))) + + diff --git a/ansi-tests/search-bitvector.lsp b/ansi-tests/search-bitvector.lsp new file mode 100644 index 0000000000000000000000000000000000000000..1b8dc713fd6680fa17aec7b3e590fdf6fb6315b1 --- /dev/null +++ b/ansi-tests/search-bitvector.lsp @@ -0,0 +1,145 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Aug 25 13:06:54 2002 +;;;; Contains: Tests for SEARCH on vectors + +(in-package :cl-test) + +(deftest search-bitvector.1 + (let ((target *searched-bitvector*) + (pat #(a))) + (loop for i from 0 to (1- (length target)) + for tail on target + always + (let ((pos (search pat tail))) + (search-check pat tail pos)))) + t) + +(deftest search-bitvector.2 + (let ((target *searched-bitvector*) + (pat #(a))) + (loop for i from 1 to (length target) + always + (let ((pos (search pat target :end2 i :from-end t))) + (search-check pat target pos :end2 i :from-end t)))) + t) + +(deftest search-bitvector.3 + (let ((target *searched-bitvector*)) + (loop for pat in *pattern-subbitvectors* + for pos = (search pat target) + unless (search-check pat target pos) + collect pat)) + nil) + +(deftest search-bitvector.4 + (let ((target *searched-bitvector*)) + (loop for pat in *pattern-subbitvectors* + for pos = (search pat target :from-end t) + unless (search-check pat target pos :from-end t) + collect pat)) + nil) + +(deftest search-bitvector.5 + (let ((target *searched-bitvector*)) + (loop for pat in *pattern-subbitvectors* + for pos = (search pat target :start2 25 :end2 75) + unless (search-check pat target pos :start2 25 :end2 75) + collect pat)) + nil) + +(deftest search-bitvector.6 + (let ((target *searched-bitvector*)) + (loop for pat in *pattern-subbitvectors* + for pos = (search pat target :from-end t :start2 25 :end2 75) + unless (search-check pat target pos :from-end t + :start2 25 :end2 75) + collect pat)) + nil) + +(deftest search-bitvector.7 + (let ((target *searched-bitvector*)) + (loop for pat in *pattern-subbitvectors* + for pos = (search pat target :start2 20) + unless (search-check pat target pos :start2 20) + collect pat)) + nil) + +(deftest search-bitvector.8 + (let ((target *searched-bitvector*)) + (loop for pat in *pattern-subbitvectors* + for pos = (search pat target :from-end t :start2 20) + unless (search-check pat target pos :from-end t + :start2 20) + collect pat)) + nil) + +(deftest search-bitvector.9 + (let ((target *searched-bitvector*)) + (loop for pat in (mapcar #'(lambda (x) + (map 'vector + #'(lambda (y) + (sublis '((a . 2) (b . 3)) y)) + x)) + *pattern-sublists*) + for pos = (search pat target :start2 20 :key #'evenp) + unless (search-check pat target pos :start2 20 :key #'evenp) + collect pat)) + nil) + +(deftest search-bitvector.10 + (let ((target *searched-bitvector*)) + (loop for pat in (mapcar #'(lambda (x) + (map 'vector + #'(lambda (y) + (sublis '((a . 2) (b . 3)) y)) + x)) + *pattern-sublists*) + for pos = (search pat target :from-end t :start2 20 :key 'oddp) + unless (search-check pat target pos :from-end t + :start2 20 :key 'oddp) + collect pat)) + nil) + +(deftest search-bitvector.11 + (let ((target *searched-bitvector*)) + (loop for pat in *pattern-subbitvectors* + for pos = (search pat target :start2 20 :test (complement #'eq)) + unless (search-check pat target pos :start2 20 + :test (complement #'eq)) + collect pat)) + nil) + +(deftest search-bitvector.12 + (let ((target *searched-bitvector*)) + (loop for pat in *pattern-subbitvectors* + for pos = (search pat target :from-end t :start2 20 :test-not #'eq) + unless (search-check pat target pos :from-end t + :start2 20 :test (complement #'eq)) + collect pat)) + nil) + +(deftest search-bitvector.13 + (let ((target *searched-bitvector*)) + (loop for pat in *pattern-subbitvectors* + when (and (> (length pat) 0) + (let ((pos (search pat target :start1 1 + :test (complement #'eq)))) + (not (search-check pat target pos + :start1 1 + :test (complement #'eq))))) + collect pat)) + nil) + +(deftest search-bitvector.14 + (let ((target *searched-bitvector*)) + (loop for pat in *pattern-subbitvectors* + when (let ((len (length pat))) + (and (> len 0) + (let ((pos (search pat target :end1 (1- len) + :test (complement #'eq)))) + (not (search-check pat target pos + :end1 (1- len) + :test (complement #'eq)))))) + collect pat)) + nil) diff --git a/ansi-tests/search-list.lsp b/ansi-tests/search-list.lsp new file mode 100644 index 0000000000000000000000000000000000000000..420e97e291e7f9c4b4c1bc1f5cf918e33a5297f8 --- /dev/null +++ b/ansi-tests/search-list.lsp @@ -0,0 +1,136 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Aug 24 07:22:10 2002 +;;;; Contains: Tests for SEARCH on lists + +(in-package :cl-test) + +(deftest search-list.1 + (let ((target *searched-list*) + (pat '(a))) + (loop for i from 0 to (1- (length target)) + for tail on target + always + (let ((pos (search pat tail))) + (search-check pat tail pos)))) + t) + +(deftest search-list.2 + (let ((target *searched-list*) + (pat '(a))) + (loop for i from 1 to (length target) + always + (let ((pos (search pat target :end2 i :from-end t))) + (search-check pat target pos :end2 i :from-end t)))) + t) + +(deftest search-list.3 + (let ((target *searched-list*)) + (loop for pat in *pattern-sublists* + for pos = (search pat target) + unless (search-check pat target pos) + collect pat)) + nil) + +(deftest search-list.4 + (let ((target *searched-list*)) + (loop for pat in *pattern-sublists* + for pos = (search pat target :from-end t) + unless (search-check pat target pos :from-end t) + collect pat)) + nil) + +(deftest search-list.5 + (let ((target *searched-list*)) + (loop for pat in *pattern-sublists* + for pos = (search pat target :start2 25 :end2 75) + unless (search-check pat target pos :start2 25 :end2 75) + collect pat)) + nil) + +(deftest search-list.6 + (let ((target *searched-list*)) + (loop for pat in *pattern-sublists* + for pos = (search pat target :from-end t :start2 25 :end2 75) + unless (search-check pat target pos :from-end t + :start2 25 :end2 75) + collect pat)) + nil) + +(deftest search-list.7 + (let ((target *searched-list*)) + (loop for pat in *pattern-sublists* + for pos = (search pat target :start2 20) + unless (search-check pat target pos :start2 20) + collect pat)) + nil) + +(deftest search-list.8 + (let ((target *searched-list*)) + (loop for pat in *pattern-sublists* + for pos = (search pat target :from-end t :start2 20) + unless (search-check pat target pos :from-end t + :start2 20) + collect pat)) + nil) + +(deftest search-list.9 + (let ((target (sublis '((a . 1) (b . 2)) *searched-list*))) + (loop for pat in (sublis '((a . 3) (b . 4)) *pattern-sublists*) + for pos = (search pat target :start2 20 :key #'evenp) + unless (search-check pat target pos :start2 20 :key #'evenp) + collect pat)) + nil) + +(deftest search-list.10 + (let ((target (sublis '((a . 1) (b . 2)) *searched-list*))) + (loop for pat in (sublis '((a . 3) (b . 4)) *pattern-sublists*) + for pos = (search pat target :from-end t :start2 20 :key 'oddp) + unless (search-check pat target pos :from-end t + :start2 20 :key 'oddp) + collect pat)) + nil) + +(deftest search-list.11 + (let ((target *searched-list*)) + (loop for pat in *pattern-sublists* + for pos = (search pat target :start2 20 :test (complement #'eq)) + unless (search-check pat target pos :start2 20 + :test (complement #'eq)) + collect pat)) + nil) + +(deftest search-list.12 + (let ((target *searched-list*)) + (loop for pat in *pattern-sublists* + for pos = (search pat target :from-end t :start2 20 :test-not #'eq) + unless (search-check pat target pos :from-end t + :start2 20 :test (complement #'eq)) + collect pat)) + nil) + +(deftest search-list.13 + (let ((target *searched-list*)) + (loop for pat in *pattern-sublists* + when (and (> (length pat) 0) + (let ((pos (search pat target :start1 1 + :test (complement #'eq)))) + (not (search-check pat target pos + :start1 1 + :test (complement #'eq))))) + collect pat)) + nil) + +(deftest search-list.14 + (let ((target *searched-list*)) + (loop for pat in *pattern-sublists* + when (let ((len (length pat))) + (and (> len 0) + (let ((pos (search pat target :end1 (1- len) + :test (complement #'eq)))) + (not (search-check pat target pos + :end1 (1- len) + :test (complement #'eq)))))) + collect pat)) + nil) + diff --git a/ansi-tests/search-string.lsp b/ansi-tests/search-string.lsp new file mode 100644 index 0000000000000000000000000000000000000000..83af4bd486ebc07ddaf5b745dedaf4d517105d29 --- /dev/null +++ b/ansi-tests/search-string.lsp @@ -0,0 +1,127 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Aug 25 13:06:54 2002 +;;;; Contains: Tests for SEARCH on vectors + +(in-package :cl-test) + +(deftest search-string.1 + (let ((target *searched-string*) + (pat #(a))) + (loop for i from 0 to (1- (length target)) + for tail on target + always + (let ((pos (search pat tail))) + (search-check pat tail pos)))) + t) + +(deftest search-string.2 + (let ((target *searched-string*) + (pat #(a))) + (loop for i from 1 to (length target) + always + (let ((pos (search pat target :end2 i :from-end t))) + (search-check pat target pos :end2 i :from-end t)))) + t) + +(deftest search-string.3 + (let ((target *searched-string*)) + (loop for pat in *pattern-substrings* + for pos = (search pat target) + unless (search-check pat target pos) + collect pat)) + nil) + +(deftest search-string.4 + (let ((target *searched-string*)) + (loop for pat in *pattern-substrings* + for pos = (search pat target :from-end t) + unless (search-check pat target pos :from-end t) + collect pat)) + nil) + +(deftest search-string.5 + (let ((target *searched-string*)) + (loop for pat in *pattern-substrings* + for pos = (search pat target :start2 25 :end2 75) + unless (search-check pat target pos :start2 25 :end2 75) + collect pat)) + nil) + +(deftest search-string.6 + (let ((target *searched-string*)) + (loop for pat in *pattern-substrings* + for pos = (search pat target :from-end t :start2 25 :end2 75) + unless (search-check pat target pos :from-end t + :start2 25 :end2 75) + collect pat)) + nil) + +(deftest search-string.7 + (let ((target *searched-string*)) + (loop for pat in *pattern-substrings* + for pos = (search pat target :start2 20) + unless (search-check pat target pos :start2 20) + collect pat)) + nil) + +(deftest search-string.8 + (let ((target *searched-string*)) + (loop for pat in *pattern-substrings* + for pos = (search pat target :from-end t :start2 20) + unless (search-check pat target pos :from-end t + :start2 20) + collect pat)) + nil) + +(deftest search-string.9 + (flet ((%f (x) (case x ((#\0 a) 'c) ((#\1 b) 'd) (t nil)))) + (let ((target *searched-string*)) + (loop for pat in *pattern-sublists* + for pos = (search pat target :start2 20 :key #'%f) + unless (search-check pat target pos :start2 20 :key #'%f) + collect pat))) + nil) + +(deftest search-string.10 + (let ((target *searched-string*)) + (loop for pat in *pattern-substrings* + for pos = (search pat target :start2 20 :test (complement #'eq)) + unless (search-check pat target pos :start2 20 + :test (complement #'eq)) + collect pat)) + nil) + +(deftest search-string.11 + (let ((target *searched-string*)) + (loop for pat in *pattern-substrings* + for pos = (search pat target :from-end t :start2 20 :test-not #'eq) + unless (search-check pat target pos :from-end t + :start2 20 :test (complement #'eq)) + collect pat)) + nil) + +(deftest search-string.13 + (let ((target *searched-string*)) + (loop for pat in *pattern-substrings* + when (and (> (length pat) 0) + (let ((pos (search pat target :start1 1 + :test (complement #'eq)))) + (not (search-check pat target pos + :start1 1 + :test (complement #'eq))))) + collect pat)) + nil) + +(deftest search-string.14 + (let ((target *searched-string*)) + (loop for pat in *pattern-substrings* + when (let ((len (length pat))) + (and (> len 0) + (let ((pos (search pat target :end1 (1- len) + :test (complement #'eq)))) + (not (search-check pat target pos + :end1 (1- len) + :test (complement #'eq)))))) + collect pat)) + nil) diff --git a/ansi-tests/search-vector.lsp b/ansi-tests/search-vector.lsp new file mode 100644 index 0000000000000000000000000000000000000000..546444661bb4ec0f3907326ea82486a99aeefeca --- /dev/null +++ b/ansi-tests/search-vector.lsp @@ -0,0 +1,147 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Aug 25 13:06:54 2002 +;;;; Contains: Tests for SEARCH on vectors + +(in-package :cl-test) + +(deftest search-vector.1 + (let ((target *searched-vector*) + (pat #(a))) + (loop for i from 0 to (1- (length target)) + for tail on target + always + (let ((pos (search pat tail))) + (search-check pat tail pos)))) + t) + +(deftest search-vector.2 + (let ((target *searched-vector*) + (pat #(a))) + (loop for i from 1 to (length target) + always + (let ((pos (search pat target :end2 i :from-end t))) + (search-check pat target pos :end2 i :from-end t)))) + t) + +(deftest search-vector.3 + (let ((target *searched-vector*)) + (loop for pat in *pattern-subvectors* + for pos = (search pat target) + unless (search-check pat target pos) + collect pat)) + nil) + +(deftest search-vector.4 + (let ((target *searched-vector*)) + (loop for pat in *pattern-subvectors* + for pos = (search pat target :from-end t) + unless (search-check pat target pos :from-end t) + collect pat)) + nil) + +(deftest search-vector.5 + (let ((target *searched-vector*)) + (loop for pat in *pattern-subvectors* + for pos = (search pat target :start2 25 :end2 75) + unless (search-check pat target pos :start2 25 :end2 75) + collect pat)) + nil) + +(deftest search-vector.6 + (let ((target *searched-vector*)) + (loop for pat in *pattern-subvectors* + for pos = (search pat target :from-end t :start2 25 :end2 75) + unless (search-check pat target pos :from-end t + :start2 25 :end2 75) + collect pat)) + nil) + +(deftest search-vector.7 + (let ((target *searched-vector*)) + (loop for pat in *pattern-subvectors* + for pos = (search pat target :start2 20) + unless (search-check pat target pos :start2 20) + collect pat)) + nil) + +(deftest search-vector.8 + (let ((target *searched-vector*)) + (loop for pat in *pattern-subvectors* + for pos = (search pat target :from-end t :start2 20) + unless (search-check pat target pos :from-end t + :start2 20) + collect pat)) + nil) + +(deftest search-vector.9 + (let ((target (map 'vector #'(lambda (x) (sublis '((a . 1) (b . 2)) x)) + *searched-list*))) + (loop for pat in (mapcar #'(lambda (x) + (map 'vector + #'(lambda (y) + (sublis '((a . 3) (b . 4)) y)) + x)) + *pattern-sublists*) + for pos = (search pat target :start2 20 :key #'evenp) + unless (search-check pat target pos :start2 20 :key #'evenp) + collect pat)) + nil) + +(deftest search-vector.10 + (let ((target (map 'vector #'(lambda (x) (sublis '((a . 1) (b . 2)) x)) + *searched-list*))) + (loop for pat in (mapcar #'(lambda (x) + (map 'vector + #'(lambda (y) + (sublis '((a . 3) (b . 4)) y)) + x)) + *pattern-sublists*) + for pos = (search pat target :from-end t :start2 20 :key 'oddp) + unless (search-check pat target pos :from-end t + :start2 20 :key 'oddp) + collect pat)) + nil) + +(deftest search-vector.11 + (let ((target *searched-vector*)) + (loop for pat in *pattern-subvectors* + for pos = (search pat target :start2 20 :test (complement #'eq)) + unless (search-check pat target pos :start2 20 + :test (complement #'eq)) + collect pat)) + nil) + +(deftest search-vector.12 + (let ((target *searched-vector*)) + (loop for pat in *pattern-subvectors* + for pos = (search pat target :from-end t :start2 20 :test-not #'eq) + unless (search-check pat target pos :from-end t + :start2 20 :test (complement #'eq)) + collect pat)) + nil) + +(deftest search-vector.13 + (let ((target *searched-vector*)) + (loop for pat in *pattern-subvectors* + when (and (> (length pat) 0) + (let ((pos (search pat target :start1 1 + :test (complement #'eq)))) + (not (search-check pat target pos + :start1 1 + :test (complement #'eq))))) + collect pat)) + nil) + +(deftest search-vector.14 + (let ((target *searched-vector*)) + (loop for pat in *pattern-subvectors* + when (let ((len (length pat))) + (and (> len 0) + (let ((pos (search pat target :end1 (1- len) + :test (complement #'eq)))) + (not (search-check pat target pos + :end1 (1- len) + :test (complement #'eq)))))) + collect pat)) + nil) diff --git a/ansi-tests/sort.lsp b/ansi-tests/sort.lsp new file mode 100644 index 0000000000000000000000000000000000000000..18ac36af55623ce87c0e4c1a716c4132a76cbbc5 --- /dev/null +++ b/ansi-tests/sort.lsp @@ -0,0 +1,67 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Wed Aug 21 00:11:24 2002 +;;;; Contains: Tests for SORT + +(in-package :cl-test) + +(deftest sort-list.1 + (let ((a (list 1 4 2 5 3))) + (sort a #'<)) + (1 2 3 4 5)) + +(deftest sort-list.2 + (let ((a (list 1 4 2 5 3))) + (sort a #'< :key #'-)) + (5 4 3 2 1)) + +(deftest sort-list.3 + (let ((a (list 1 4 2 5 3))) + (sort a #'(lambda (x y) nil)) + (sort a #'<)) + (1 2 3 4 5)) + +(deftest sort-vector.1 + (let ((a (copy-seq #(1 4 2 5 3)))) + (sort a #'<)) + #(1 2 3 4 5)) + +(deftest sort-vector.2 + (let ((a (copy-seq #(1 4 2 5 3)))) + (sort a #'< :key #'-)) + #(5 4 3 2 1)) + +(deftest sort-vector.3 + (let ((a (copy-seq #(1 4 2 5 3)))) + (sort a #'(lambda (x y) nil)) + (sort a #'<)) + #(1 2 3 4 5)) + +(deftest sort-bit-vector.1 + (let ((a (copy-seq #*10011101))) + (sort a #'<)) + #*00011111) + +(deftest sort-bit-vector.2 + (let ((a (copy-seq #*10011101))) + (values (sort a #'< :key #'-) a)) + #*11111000 + #*11111000) + +(deftest sort-string.1 + (let ((a (copy-seq "10011101"))) + (values (sort a #'char<) a)) + "00011111" + "00011111") + +(deftest sort-string.2 + (let ((a (copy-seq "10011101"))) + (values (sort a #'char< :key #'(lambda (c) (if (eql c #\0) #\1 #\0))) a)) + "11111000" + "11111000") + + + + + + diff --git a/ansi-tests/stable-sort.lsp b/ansi-tests/stable-sort.lsp new file mode 100644 index 0000000000000000000000000000000000000000..f7ddc10b5254784a7d340b1000f2163c87ee2f87 --- /dev/null +++ b/ansi-tests/stable-sort.lsp @@ -0,0 +1,78 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Wed Aug 28 21:00:44 2002 +;;;; Contains: Tests for STABLE-SORT + +(in-package :cl-test) + +(deftest stable-sort-list.1 + (let ((a (list 1 4 2 5 3))) + (stable-sort a #'<)) + (1 2 3 4 5)) + +(deftest stable-sort-list.2 + (let ((a (list 1 4 2 5 3))) + (stable-sort a #'< :key #'-)) + (5 4 3 2 1)) + +(deftest stable-sort-list.3 + (let ((a (list 1 4 2 5 3))) + (stable-sort a #'(lambda (x y) nil)) + (stable-sort a #'<)) + (1 2 3 4 5)) + +(deftest stable-sort-list.4 + (let ((a (copy-seq '((1 a) (2 a) (1 b) (2 b) (1 c) (2 c))))) + (stable-sort a #'(lambda (x y) (< (car x) (car y))))) + ((1 a) (1 b) (1 c) (2 a) (2 b) (2 c))) + +(deftest stable-sort-list.5 + (let ((a (reverse (copy-seq '((1 a) (2 a) (1 b) (2 b) (1 c) (2 c)))))) + (stable-sort a #'(lambda (x y) (< (car x) (car y))))) + ((1 c) (1 b) (1 a) (2 c) (2 b) (2 a))) + +(deftest stable-sort-vector.1 + (let ((a (copy-seq #(1 4 2 5 3)))) + (stable-sort a #'<)) + #(1 2 3 4 5)) + +(deftest stable-sort-vector.2 + (let ((a (copy-seq #(1 4 2 5 3)))) + (stable-sort a #'< :key #'-)) + #(5 4 3 2 1)) + +(deftest stable-sort-vector.3 + (let ((a (copy-seq #(1 4 2 5 3)))) + (stable-sort a #'(lambda (x y) nil)) + (stable-sort a #'<)) + #(1 2 3 4 5)) + +(deftest stable-sort-bit-vector.1 + (let ((a (copy-seq #*10011101))) + (stable-sort a #'<)) + #*00011111) + +(deftest stable-sort-bit-vector.2 + (let ((a (copy-seq #*10011101))) + (values (stable-sort a #'< :key #'-) a)) + #*11111000 + #*11111000) + +(deftest stable-sort-string.1 + (let ((a (copy-seq "10011101"))) + (values (stable-sort a #'char<) a)) + "00011111" + "00011111") + +(deftest stable-sort-string.2 + (let ((a (copy-seq "10011101"))) + (values (stable-sort a #'char< :key #'(lambda (c) (if (eql c #\0) #\1 #\0))) a)) + "11111000" + "11111000") + + + + + + + diff --git a/ansi-tests/structure-00.lsp b/ansi-tests/structure-00.lsp new file mode 100644 index 0000000000000000000000000000000000000000..09b58dd3fd741f3da4e89d9132b3df020352f371 --- /dev/null +++ b/ansi-tests/structure-00.lsp @@ -0,0 +1,232 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat May 9 11:21:25 1998 +;;;; Contains: Common code for creating structure tests + +(in-package :cl-test) +(declaim (optimize (safety 3))) + +(defun make-struct-test-name (structure-name n) + (declare (type (or string symbol character) structure-name) + (type fixnum n)) + (setf structure-name (string structure-name)) + (intern (concatenate 'string + structure-name + "-STRUCT-TEST-" + (princ-to-string n)) + :cl-test)) + +(defun make-struct-p-fn (structure-name) + (setf structure-name (string structure-name)) + (intern (concatenate 'string + structure-name + "-P") + :cl-test)) + +(defun make-struct-copy-fn (structure-name) + (setf structure-name (string structure-name)) + (intern (concatenate 'string + "COPY-" + structure-name) + :cl-test)) + +(defun make-struct-field-fn (structure-name field-name) + "Make field accessor for a field in a structure" + (setf structure-name (string structure-name)) + (setf field-name (string field-name)) + (intern (concatenate 'string + structure-name "-" field-name) + :cl-test)) + +(defun make-struct-make-fn (structure-name) + "Make the make- function for a structure" + (setf structure-name (string structure-name)) + (intern (concatenate 'string + "MAKE-" structure-name) + :cl-test)) + +(defun create-instance-of-type (type) + "Return an instance of a type. Signal an error if + it can't figure out a value for the type." + (cond + ((eq type t) ;; anything + 'a) + ((eq type 'symbol) + 'b) + ((eq type 'null) nil) + ((eq type 'boolean) t) + ((eq type 'keyword) :foo) + ((eq type nil) (error "Cannot obtain element of type ~S~%" type)) + ((eq type 'cons) (cons 'a 'b)) + ((eq type 'list) (list 1 2 3)) + ((eq type 'fixnum) 17) + ((eq type 'bignum) + (let ((x 1)) + (loop until (typep x 'bignum) + do (setq x (* 2 x))) + x)) + ((and (symbolp type) + (typep type 'structure-class)) + (let ((make-fn + (intern (concatenate 'string "MAKE-" (symbol-name type)) + (symbol-package type)))) + (eval (list make-fn)))) + ((eq type 'character) #\w) + ((eq type 'base-char) #\z) + ((member type '(integer unsigned-byte signed-byte)) 35) + ((eq type 'bit) 1) + ((and (consp type) + (consp (cdr type)) + (consp (cddr type)) + (null (cdddr type)) + (eq (car type) 'integer) + (integerp (second type))) + (second type)) + ((member type '(float single-float long-float double-float short-float)) + 0.0) + ((and (consp type) + (eq (car type) 'member) + (consp (cdr type))) + (second type)) + ((and (consp type) + (eq (car type) 'or) + (consp (second type))) + (create-instance-of-type (second type))) + (t (error "Cannot generate element for type ~S~%" type)))) + +;; +;; There are a number of standardized tests for +;; structures. The following macro generates the +;; structure definition and the tests. +;; + +(defmacro defstruct-with-tests + (name-and-options &body slot-descriptions-and-documentation) +"Construct standardized tests for a defstruct, and also +do the defstruct." + (let* ((doc-string + (when (and (consp slot-descriptions-and-documentation) + (stringp (car slot-descriptions-and-documentation))) + (car slot-descriptions-and-documentation))) + (slot-descriptions + (if doc-string (cdr slot-descriptions-and-documentation) + slot-descriptions-and-documentation)) + (name (if (consp name-and-options) + (car name-and-options) + name-and-options)) + (options (if (consp name-and-options) + (cdr name-and-options) + nil)) + (slot-names + (loop + for x in slot-descriptions collect + (if (consp x) (car x) x))) + (make-fn (make-struct-make-fn name)) + (p-fn (make-struct-p-fn name)) + (copy-fn (make-struct-copy-fn name)) + ;; a list of initial values + (initial-value-alist + (loop + for slot-desc in slot-descriptions + collect + (let ((slot-name (if (consp slot-desc) + (car slot-desc) + slot-desc)) + (slot-attrs (if (consp slot-desc) + (cdr slot-desc) + nil))) + (when (and (consp slot-attrs) + (not (keywordp slot-attrs))) + (pop slot-attrs)) + (let ((type (getf slot-attrs :type))) + (if type + (cons slot-name (create-instance-of-type type)) + (cons slot-name (gensym))))))) + ) + `(eval-when (compile load eval) + (defstruct ,name-and-options + ,@slot-descriptions-and-documentation) + + ;; Test that structure is of the correct type + (deftest ,(make-struct-test-name name 1) + (not (not (typep (,make-fn) (quote ,name)))) + t) + + ;; Test that the -P predicate exists + (deftest ,(make-struct-test-name name 2) + (not (not (,p-fn (,make-fn)))) + t) + + ;; Test that the elements of *universe* are not + ;; of this type + (deftest ,(make-struct-test-name name 3) + (count-if (function ,p-fn) *universe*) + 0) + + (deftest ,(make-struct-test-name name 4) + (count-if (function (lambda (x) (typep x (quote ,name)))) + *universe*) + 0) + + ;; Check that the fields can be read after being initialized + (deftest ,(make-struct-test-name name 5) + ,(let ((inits nil) + (tests nil) + (var (gensym "X"))) + (loop + for (slot-name . initval) in initial-value-alist + do + (setf inits + (list* (intern (string slot-name) "KEYWORD") + (list 'quote initval) + inits)) + (push `(eql (quote ,initval) + (,(make-struct-field-fn name slot-name) + ,var)) + tests)) + `(let ((,var (,(make-struct-make-fn name) . ,inits))) + (and ,@tests t))) + t) + + ;; Check that two invocations return different structures + (deftest ,(make-struct-test-name name 6) + ,(let ((make-fn (make-struct-make-fn name))) + `(eq (,make-fn) (,make-fn))) + nil) + + ;; Check that we can setf the fields + (deftest ,(make-struct-test-name name 7) + ,(let* ((var (gensym "X")) + (var2 (gensym "T")) + (tests + (loop + for (slot-name . initval) in initial-value-alist + collect + (let ((field-fn (make-struct-field-fn name slot-name))) + `(let ((,var2 (quote ,initval))) + (setf (,field-fn ,var) ,var2) + (eql (,field-fn ,var) ,var2)))))) + `(let ((,var (,(make-struct-make-fn name)))) + (and ,@tests t))) + t) + + ;; Check that the copy function properly copies fields + (deftest ,(make-struct-test-name name 8) + ,(let* ((var (gensym "X")) + (var2 (gensym "Y"))) + `(let ((,var (,(make-struct-make-fn name) + ,@(loop + for (slot-name . initval) in initial-value-alist + nconc (list (intern (string slot-name) "KEYWORD") + `(quote ,initval)))))) + (let ((,var2 (,(make-struct-copy-fn name) ,var))) + (and + (not (eql ,var ,var2)) + ,@(loop + for (slot-name . initval) in initial-value-alist + collect + (let ((fn (make-struct-field-fn name slot-name))) + `(eql (,fn ,var) (,fn ,var2)))) + t)))) + t) + ))) diff --git a/ansi-tests/structures-01.lsp b/ansi-tests/structures-01.lsp new file mode 100644 index 0000000000000000000000000000000000000000..34429435b2c47b6750297d5963c0a6758ee94bac --- /dev/null +++ b/ansi-tests/structures-01.lsp @@ -0,0 +1,103 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat May 2 21:45:32 1998 +;;;; Contains: Test code for structures, part 01 + +(in-package :cl-test) +(declaim (optimize (safety 3))) + +;;; Tests for structures +;;; +;;; The CL Spec leaves undefined just what will happen when a structure is +;;; redefined. These tests don't redefine structures, but reloading a file +;;; with structure definition will do so. I assume that this leaves the +;;; structure type unchanged. + +;; Test simple defstruct (fields, no options) + +(defstruct s-1 + foo bar) + +;; Test that make-s-1 produces objects +;; of the correct type +(deftest structure-1-1 + (not (not (typep (make-s-1) 's-1))) + t) + +;; Test that the -p predicate exists +(deftest structure-1-2 + (not (not (s-1-p (make-s-1)))) + t) + +;; Test that all the objects in the universe are +;; not of this type +(deftest structure-1-3 + (count-if #'s-1-p *universe*) + 0) + +(deftest structure-1-4 + (count-if #'(lambda (x) (typep x 's-1)) *universe*) + 0) + +;; Check that the fields can be read after being initialized +(deftest structure-1-5 + (s-1-foo (make-s-1 :foo 'a)) + a) + +(deftest structure-1-6 + (s-1-bar (make-s-1 :bar 'b)) + b) + +(deftest structure-1-7 + (let ((s (make-s-1 :foo 'c :bar 'd))) + (list (s-1-foo s) (s-1-bar s))) + (c d)) + +;; Can setf the fields +(deftest structure-1-8 + (let ((s (make-s-1))) + (setf (s-1-foo s) 'e) + (setf (s-1-bar s) 'f) + (list (s-1-foo s) (s-1-bar s))) + (e f)) + +(deftest structure-1-9 + (let ((s (make-s-1 :foo 'a :bar 'b))) + (setf (s-1-foo s) 'e) + (setf (s-1-bar s) 'f) + (list (s-1-foo s) (s-1-bar s))) + (e f)) + +;; copier function defined +(deftest structure-1-10 + (let ((s (make-s-1 :foo 'a :bar 'b))) + (let ((s2 (copy-s-1 s))) + (setf (s-1-foo s) nil) + (setf (s-1-bar s) nil) + (list (s-1-foo s2) + (s-1-bar s2)))) + (a b)) + +;; Make produces unique items +(deftest structure-1-11 + (eq (make-s-1) (make-s-1)) + nil) + +(deftest structure-1-12 + (eq (make-s-1 :foo 'a :bar 'b) + (make-s-1 :foo 'a :bar 'b)) + nil) + +;; More type and class checks + +(deftest structure-1-13 + (not (not (typep (class-of (make-s-1)) 'structure-class))) + t) + +(deftest structure-1-14 + (not (not (typep (make-s-1) 'structure-object))) + t) + +(deftest structure-1-15 + (subtypep 's-1 'structure-object) + t t) diff --git a/ansi-tests/structures-02.lsp b/ansi-tests/structures-02.lsp new file mode 100644 index 0000000000000000000000000000000000000000..2d889a609736ea89391b57f2665107c43f67b060 --- /dev/null +++ b/ansi-tests/structures-02.lsp @@ -0,0 +1,46 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun May 3 22:46:54 1998 +;;;; Contains: Test code for structures, part 02 + +(in-package :cl-test) +(declaim (optimize (safety 3))) + +;; Test initializers for fields + +(defvar *s-2-f6-counter* 0) + +(defstruct s-2 + (f1 0) + (f2 'a) + (f3 1.21) + (f4 #\d) + (f5 (list 'a 'b)) + (f6 (incf *s-2-f6-counter*))) + +;; Standard structure tests + + +;; Fields have appropriate values +(deftest structure-2-1 + (let ((s (make-s-2))) + (and + (eql (s-2-f1 s) 0) + (eq (s-2-f2 s) 'a) + (eql (s-2-f3 s) 1.21) + (eql (s-2-f4 s) #\d) + (equal (s-2-f5 s) '(a b)) + (eql (s-2-f6 s) *s-2-f6-counter*))) + t) + +;; Two successive invocations of make-s-2 return different objects +(deftest structure-2-2 + (eq (s-2-f5 (make-s-2)) + (s-2-f5 (make-s-2))) + nil) + + + + + + diff --git a/ansi-tests/substitute-if-not.lsp b/ansi-tests/substitute-if-not.lsp new file mode 100644 index 0000000000000000000000000000000000000000..a2c9d2cc6a29a63a384b2e145f9e849f9119e174 --- /dev/null +++ b/ansi-tests/substitute-if-not.lsp @@ -0,0 +1,623 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Aug 31 18:17:09 2002 +;;;; Contains: Tests for SUBSTITUTE-IF-NOT + +(in-package :cl-test) + +(deftest substitute-if-not-list.1 + (let ((x '())) (values (substitute-if-not 'b #'null x) x)) + nil nil) + +(deftest substitute-if-not-list.2 + (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x) x)) + (b b b c) + (a b a c)) + +(deftest substitute-if-not-list.3 + (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count nil) x)) + (b b b c) + (a b a c)) + +(deftest substitute-if-not-list.4 + (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count 2) x)) + (b b b c) + (a b a c)) + +(deftest substitute-if-not-list.5 + (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count 1) x)) + (b b a c) + (a b a c)) + +(deftest substitute-if-not-list.6 + (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count 0) x)) + (a b a c) + (a b a c)) + +(deftest substitute-if-not-list.7 + (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count -1) x)) + (a b a c) + (a b a c)) + +(deftest substitute-if-not-list.8 + (let ((x '())) (values (substitute-if-not 'b (is-not-eq-p 'a) x :from-end t) x)) + nil nil) + +(deftest substitute-if-not-list.9 + (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :from-end t) x)) + (b b b c) + (a b a c)) + +(deftest substitute-if-not-list.10 + (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :from-end t :count nil) x)) + (b b b c) + (a b a c)) + +(deftest substitute-if-not-list.11 + (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count 2 :from-end t) x)) + (b b b c) + (a b a c)) + +(deftest substitute-if-not-list.12 + (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count 1 :from-end t) x)) + (a b b c) + (a b a c)) + +(deftest substitute-if-not-list.13 + (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count 0 :from-end t) x)) + (a b a c) + (a b a c)) + +(deftest substitute-if-not-list.14 + (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count -1 :from-end t) x)) + (a b a c) + (a b a c)) + +(deftest substitute-if-not-list.15 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute-if-not 'x (is-not-eq-p 'a) x :start i :end j))) + (and (equal orig x) + (equal y (nconc (make-list i :initial-element 'a) + (make-list (- j i) :initial-element 'x) + (make-list (- 10 j) :initial-element 'a))))))) + t) + +(deftest substitute-if-not-list.16 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute-if-not 'x (is-not-eq-p 'a) x :start i :end j :from-end t))) + (and (equal orig x) + (equal y (nconc (make-list i :initial-element 'a) + (make-list (- j i) :initial-element 'x) + (make-list (- 10 j) :initial-element 'a))))))) + t) + +(deftest substitute-if-not-list.17 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute-if-not 'x (is-not-eq-p 'a) x :start i :end j :count c))) + (and (equal orig x) + (equal y (nconc (make-list i :initial-element 'a) + (make-list c :initial-element 'x) + (make-list (- 10 (+ i c)) :initial-element 'a)))))))) + t) + +(deftest substitute-if-not-list.18 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute-if-not 'x (is-not-eq-p 'a) x :start i :end j :count c :from-end t))) + (and (equal orig x) + (equal y (nconc (make-list (- j c) :initial-element 'a) + (make-list c :initial-element 'x) + (make-list (- 10 j) :initial-element 'a)))))))) + t) + +;;; Tests on vectors + +(deftest substitute-if-not-vector.1 + (let ((x #())) (values (substitute-if-not 'b (is-not-eq-p 'a) x) x)) + #() #()) + +(deftest substitute-if-not-vector.2 + (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x) x)) + #(b b b c) + #(a b a c)) + +(deftest substitute-if-not-vector.3 + (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count nil) x)) + #(b b b c) + #(a b a c)) + +(deftest substitute-if-not-vector.4 + (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count 2) x)) + #(b b b c) + #(a b a c)) + +(deftest substitute-if-not-vector.5 + (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count 1) x)) + #(b b a c) + #(a b a c)) + +(deftest substitute-if-not-vector.6 + (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count 0) x)) + #(a b a c) + #(a b a c)) + +(deftest substitute-if-not-vector.7 + (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count -1) x)) + #(a b a c) + #(a b a c)) + +(deftest substitute-if-not-vector.8 + (let ((x #())) (values (substitute-if-not 'b (is-not-eq-p 'a) x :from-end t) x)) + #() #()) + +(deftest substitute-if-not-vector.9 + (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :from-end t) x)) + #(b b b c) + #(a b a c)) + +(deftest substitute-if-not-vector.10 + (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :from-end t :count nil) x)) + #(b b b c) + #(a b a c)) + +(deftest substitute-if-not-vector.11 + (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count 2 :from-end t) x)) + #(b b b c) + #(a b a c)) + +(deftest substitute-if-not-vector.12 + (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count 1 :from-end t) x)) + #(a b b c) + #(a b a c)) + +(deftest substitute-if-not-vector.13 + (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count 0 :from-end t) x)) + #(a b a c) + #(a b a c)) + +(deftest substitute-if-not-vector.14 + (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count -1 :from-end t) x)) + #(a b a c) + #(a b a c)) + +(deftest substitute-if-not-vector.15 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute-if-not 'x (is-not-eq-p 'a) x :start i :end j))) + (and (equalp orig x) + (equalp y (concatenate 'simple-vector + (make-array i :initial-element 'a) + (make-array (- j i) :initial-element 'x) + (make-array (- 10 j) :initial-element 'a))))))) + t) + +(deftest substitute-if-not-vector.16 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute-if-not 'x (is-not-eq-p 'a) x :start i :end j :from-end t))) + (and (equalp orig x) + (equalp y (concatenate 'simple-vector + (make-array i :initial-element 'a) + (make-array (- j i) :initial-element 'x) + (make-array (- 10 j) :initial-element 'a))))))) + t) + +(deftest substitute-if-not-vector.17 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute-if-not 'x (is-not-eq-p 'a) x :start i :end j :count c))) + (and (equalp orig x) + (equalp y (concatenate 'simple-vector + (make-array i :initial-element 'a) + (make-array c :initial-element 'x) + (make-array (- 10 (+ i c)) :initial-element 'a)))))))) + t) + +(deftest substitute-if-not-vector.18 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute-if-not 'x (is-not-eq-p 'a) x :start i :end j :count c :from-end t))) + (and (equalp orig x) + (equalp y (concatenate 'simple-vector + (make-array (- j c) :initial-element 'a) + (make-array c :initial-element 'x) + (make-array (- 10 j) :initial-element 'a)))))))) + t) + +;;; Tests on strings + +(deftest substitute-if-not-string.1 + (let ((x "")) (values (substitute-if-not #\b (is-not-eq-p #\a) x) x)) + "" "") + +(deftest substitute-if-not-string.2 + (let ((x "abac")) (values (substitute-if-not #\b (is-not-eq-p #\a) x) x)) + "bbbc" + "abac") + +(deftest substitute-if-not-string.3 + (let ((x "abac")) (values (substitute-if-not #\b (is-not-eq-p #\a) x :count nil) x)) + "bbbc" + "abac") + +(deftest substitute-if-not-string.4 + (let ((x "abac")) (values (substitute-if-not #\b (is-not-eq-p #\a) x :count 2) x)) + "bbbc" + "abac") + +(deftest substitute-if-not-string.5 + (let ((x "abac")) (values (substitute-if-not #\b (is-not-eq-p #\a) x :count 1) x)) + "bbac" + "abac") + +(deftest substitute-if-not-string.6 + (let ((x "abac")) (values (substitute-if-not #\b (is-not-eq-p #\a) x :count 0) x)) + "abac" + "abac") + +(deftest substitute-if-not-string.7 + (let ((x "abac")) (values (substitute-if-not #\b (is-not-eq-p #\a) x :count -1) x)) + "abac" + "abac") + +(deftest substitute-if-not-string.8 + (let ((x "")) (values (substitute-if-not #\b (is-not-eq-p #\a) x :from-end t) x)) + "" "") + +(deftest substitute-if-not-string.9 + (let ((x "abac")) (values (substitute-if-not #\b (is-not-eq-p #\a) x :from-end t) x)) + "bbbc" + "abac") + +(deftest substitute-if-not-string.10 + (let ((x "abac")) (values (substitute-if-not #\b (is-not-eq-p #\a) x :from-end t :count nil) x)) + "bbbc" + "abac") + +(deftest substitute-if-not-string.11 + (let ((x "abac")) (values (substitute-if-not #\b (is-not-eq-p #\a) x :count 2 :from-end t) x)) + "bbbc" + "abac") + +(deftest substitute-if-not-string.12 + (let ((x "abac")) (values (substitute-if-not #\b (is-not-eq-p #\a) x :count 1 :from-end t) x)) + "abbc" + "abac") + +(deftest substitute-if-not-string.13 + (let ((x "abac")) (values (substitute-if-not #\b (is-not-eq-p #\a) x :count 0 :from-end t) x)) + "abac" + "abac") + +(deftest substitute-if-not-string.14 + (let ((x "abac")) (values (substitute-if-not #\b (is-not-eq-p #\a) x :count -1 :from-end t) x)) + "abac" + "abac") + +(deftest substitute-if-not-string.15 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (substitute-if-not #\x (is-not-eq-p #\a) x :start i :end j))) + (and (equalp orig x) + (equalp y (concatenate 'simple-string + (make-array i :initial-element #\a) + (make-array (- j i) :initial-element #\x) + (make-array (- 10 j) :initial-element #\a))))))) + t) + +(deftest substitute-if-not-string.16 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (substitute-if-not #\x (is-not-eq-p #\a) x :start i :end j :from-end t))) + (and (equalp orig x) + (equalp y (concatenate 'simple-string + (make-array i :initial-element #\a) + (make-array (- j i) :initial-element #\x) + (make-array (- 10 j) :initial-element #\a))))))) + t) + +(deftest substitute-if-not-string.17 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (substitute-if-not #\x (is-not-eq-p #\a) x :start i :end j :count c))) + (and (equalp orig x) + (equalp y (concatenate 'simple-string + (make-array i :initial-element #\a) + (make-array c :initial-element #\x) + (make-array (- 10 (+ i c)) :initial-element #\a)))))))) + t) + +(deftest substitute-if-not-string.18 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (substitute-if-not #\x (is-not-eq-p #\a) x :start i :end j :count c :from-end t))) + (and (equalp orig x) + (equalp y (concatenate 'simple-string + (make-array (- j c) :initial-element #\a) + (make-array c :initial-element #\x) + (make-array (- 10 j) :initial-element #\a)))))))) + t) + +;;; Tests on bitstrings + +(deftest substitute-if-not-bitstring.1 + (let* ((orig #*) + (x (copy-seq orig)) + (result (substitute-if-not 0 (is-not-eq-p 1) x))) + (and (equalp orig x) + result)) + #*) + +(deftest substitute-if-not-bitstring.2 + (let* ((orig #*) + (x (copy-seq orig)) + (result (substitute-if-not 1 (complement #'zerop) x))) + (and (equalp orig x) + result)) + #*) + +(deftest substitute-if-not-bitstring.3 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if-not 0 (is-not-eq-p 1) x))) + (and (equalp orig x) + result)) + #*000000) + +(deftest substitute-if-not-bitstring.4 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if-not 1 (complement #'zerop) x))) + (and (equalp orig x) + result)) + #*111111) + +(deftest substitute-if-not-bitstring.5 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if-not 1 (complement #'zerop) x :start 1))) + (and (equalp orig x) + result)) + #*011111) + +(deftest substitute-if-not-bitstring.6 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if-not 0 (is-not-eq-p 1) x :start 2 :end nil))) + (and (equalp orig x) + result)) + #*010000) + +(deftest substitute-if-not-bitstring.7 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if-not 1 (complement #'zerop) x :end 4))) + (and (equalp orig x) + result)) + #*111101) + +(deftest substitute-if-not-bitstring.8 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if-not 0 (is-not-eq-p 1) x :end nil))) + (and (equalp orig x) + result)) + #*000000) + +(deftest substitute-if-not-bitstring.9 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if-not 0 (is-not-eq-p 1) x :end 3))) + (and (equalp orig x) + result)) + #*000101) + +(deftest substitute-if-not-bitstring.10 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if-not 0 (is-not-eq-p 1) x :start 2 :end 4))) + (and (equalp orig x) + result)) + #*010001) + +(deftest substitute-if-not-bitstring.11 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if-not 1 (complement #'zerop) x :start 2 :end 4))) + (and (equalp orig x) + result)) + #*011101) + +(deftest substitute-if-not-bitstring.12 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if-not 1 (complement #'zerop) x :count 1))) + (and (equalp orig x) + result)) + #*110101) + +(deftest substitute-if-not-bitstring.13 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if-not 1 (complement #'zerop) x :count 0))) + (and (equalp orig x) + result)) + #*010101) + +(deftest substitute-if-not-bitstring.14 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if-not 1 (complement #'zerop) x :count -1))) + (and (equalp orig x) + result)) + #*010101) + +(deftest substitute-if-not-bitstring.15 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if-not 1 (complement #'zerop) x :count 1 :from-end t))) + (and (equalp orig x) + result)) + #*010111) + +(deftest substitute-if-not-bitstring.16 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if-not 1 (complement #'zerop) x :count 0 :from-end t))) + (and (equalp orig x) + result)) + #*010101) + +(deftest substitute-if-not-bitstring.17 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if-not 1 (complement #'zerop) x :count -1 :from-end t))) + (and (equalp orig x) + result)) + #*010101) + +(deftest substitute-if-not-bitstring.18 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if-not 1 (complement #'zerop) x :count nil))) + (and (equalp orig x) + result)) + #*111111) + +(deftest substitute-if-not-bitstring.19 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if-not 1 (complement #'zerop) x :count nil :from-end t))) + (and (equalp orig x) + result)) + #*111111) + +(deftest substitute-if-not-bitstring.20 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #*0000000000) + (x (copy-seq orig)) + (y (substitute-if-not 1 (complement #'zerop) x :start i :end j :count c))) + (and (equalp orig x) + (equalp y (concatenate + 'simple-bit-vector + (make-list i :initial-element 0) + (make-list c :initial-element 1) + (make-list (- 10 (+ i c)) :initial-element 0)))))))) + t) + +(deftest substitute-if-not-bitstring.21 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #*1111111111) + (x (copy-seq orig)) + (y (substitute-if-not 0 (is-not-eq-p 1) x :start i :end j :count c :from-end t))) + (and (equalp orig x) + (equalp y (concatenate + 'simple-bit-vector + (make-list (- j c) :initial-element 1) + (make-list c :initial-element 0) + (make-list (- 10 j) :initial-element 1)))))))) + t) + +;;; More tests + +(deftest substitute-if-not-list.24 + (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (substitute-if-not '(a 10) (is-not-eq-p 'a) x :key #'car))) + (and (equal orig x) + result)) + ((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) + +(deftest substitute-if-not-list.25 + (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (substitute-if-not '(a 10) (is-not-eq-p 'a) x + :key #'car :start 1 :end 5))) + (and (equal orig x) + result)) + ((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) + +(deftest substitute-if-not-vector.24 + (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (substitute-if-not '(a 10) (is-not-eq-p 'a) x :key #'car))) + (and (equalp orig x) + result)) + #((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) + +(deftest substitute-if-not-vector.25 + (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (substitute-if-not '(a 10) (is-not-eq-p 'a) x :key #'car :start 1 :end 5))) + (and (equalp orig x) + result)) + #((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) + +(deftest substitute-if-not-string.24 + (let* ((orig "0102342015") + (x (copy-seq orig)) + (result (substitute-if-not #\a (is-not-eq-p #\1) x :key #'nextdigit))) + (and (equalp orig x) + result)) + "a1a2342a15") + +(deftest substitute-if-not-string.25 + (let* ((orig "0102342015") + (x (copy-seq orig)) + (result (substitute-if-not #\a (is-not-eq-p #\1) x :key #'nextdigit :start 1 :end 6))) + (and (equalp orig x) + result)) + "01a2342015") + +(deftest substitute-if-not-bitstring.26 + (let* ((orig #*00111001011010110) + (x (copy-seq orig)) + (result (substitute-if-not 1 (is-not-eq-p 1) x :key #'1+))) + (and (equalp orig x) + result)) + #*11111111111111111) + +(deftest substitute-if-not-bitstring.27 + (let* ((orig #*00111001011010110) + (x (copy-seq orig)) + (result (substitute-if-not 1 (is-not-eq-p 1) x :key #'1+ :start 1 :end 10))) + (and (equalp orig x) + result)) + #*01111111111010110) diff --git a/ansi-tests/substitute-if.lsp b/ansi-tests/substitute-if.lsp new file mode 100644 index 0000000000000000000000000000000000000000..3e0e807a21767377ac72b4b4afa9ec003dcb721d --- /dev/null +++ b/ansi-tests/substitute-if.lsp @@ -0,0 +1,623 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Aug 31 17:42:04 2002 +;;;; Contains: Tests for SUBSTITUTE-IF + +(in-package :cl-test) + +(deftest substitute-if-list.1 + (let ((x '())) (values (substitute-if 'b #'identity x) x)) + nil nil) + +(deftest substitute-if-list.2 + (let ((x '(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x) x)) + (b b b c) + (a b a c)) + +(deftest substitute-if-list.3 + (let ((x '(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count nil) x)) + (b b b c) + (a b a c)) + +(deftest substitute-if-list.4 + (let ((x '(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count 2) x)) + (b b b c) + (a b a c)) + +(deftest substitute-if-list.5 + (let ((x '(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count 1) x)) + (b b a c) + (a b a c)) + +(deftest substitute-if-list.6 + (let ((x '(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count 0) x)) + (a b a c) + (a b a c)) + +(deftest substitute-if-list.7 + (let ((x '(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count -1) x)) + (a b a c) + (a b a c)) + +(deftest substitute-if-list.8 + (let ((x '())) (values (substitute-if 'b (is-eq-p 'a) x :from-end t) x)) + nil nil) + +(deftest substitute-if-list.9 + (let ((x '(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :from-end t) x)) + (b b b c) + (a b a c)) + +(deftest substitute-if-list.10 + (let ((x '(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :from-end t :count nil) x)) + (b b b c) + (a b a c)) + +(deftest substitute-if-list.11 + (let ((x '(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count 2 :from-end t) x)) + (b b b c) + (a b a c)) + +(deftest substitute-if-list.12 + (let ((x '(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count 1 :from-end t) x)) + (a b b c) + (a b a c)) + +(deftest substitute-if-list.13 + (let ((x '(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count 0 :from-end t) x)) + (a b a c) + (a b a c)) + +(deftest substitute-if-list.14 + (let ((x '(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count -1 :from-end t) x)) + (a b a c) + (a b a c)) + +(deftest substitute-if-list.15 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute-if 'x (is-eq-p 'a) x :start i :end j))) + (and (equal orig x) + (equal y (nconc (make-list i :initial-element 'a) + (make-list (- j i) :initial-element 'x) + (make-list (- 10 j) :initial-element 'a))))))) + t) + +(deftest substitute-if-list.16 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute-if 'x (is-eq-p 'a) x :start i :end j :from-end t))) + (and (equal orig x) + (equal y (nconc (make-list i :initial-element 'a) + (make-list (- j i) :initial-element 'x) + (make-list (- 10 j) :initial-element 'a))))))) + t) + +(deftest substitute-if-list.17 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute-if 'x (is-eq-p 'a) x :start i :end j :count c))) + (and (equal orig x) + (equal y (nconc (make-list i :initial-element 'a) + (make-list c :initial-element 'x) + (make-list (- 10 (+ i c)) :initial-element 'a)))))))) + t) + +(deftest substitute-if-list.18 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute-if 'x (is-eq-p 'a) x :start i :end j :count c :from-end t))) + (and (equal orig x) + (equal y (nconc (make-list (- j c) :initial-element 'a) + (make-list c :initial-element 'x) + (make-list (- 10 j) :initial-element 'a)))))))) + t) + +;;; Tests on vectors + +(deftest substitute-if-vector.1 + (let ((x #())) (values (substitute-if 'b (is-eq-p 'a) x) x)) + #() #()) + +(deftest substitute-if-vector.2 + (let ((x #(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x) x)) + #(b b b c) + #(a b a c)) + +(deftest substitute-if-vector.3 + (let ((x #(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count nil) x)) + #(b b b c) + #(a b a c)) + +(deftest substitute-if-vector.4 + (let ((x #(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count 2) x)) + #(b b b c) + #(a b a c)) + +(deftest substitute-if-vector.5 + (let ((x #(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count 1) x)) + #(b b a c) + #(a b a c)) + +(deftest substitute-if-vector.6 + (let ((x #(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count 0) x)) + #(a b a c) + #(a b a c)) + +(deftest substitute-if-vector.7 + (let ((x #(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count -1) x)) + #(a b a c) + #(a b a c)) + +(deftest substitute-if-vector.8 + (let ((x #())) (values (substitute-if 'b (is-eq-p 'a) x :from-end t) x)) + #() #()) + +(deftest substitute-if-vector.9 + (let ((x #(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :from-end t) x)) + #(b b b c) + #(a b a c)) + +(deftest substitute-if-vector.10 + (let ((x #(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :from-end t :count nil) x)) + #(b b b c) + #(a b a c)) + +(deftest substitute-if-vector.11 + (let ((x #(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count 2 :from-end t) x)) + #(b b b c) + #(a b a c)) + +(deftest substitute-if-vector.12 + (let ((x #(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count 1 :from-end t) x)) + #(a b b c) + #(a b a c)) + +(deftest substitute-if-vector.13 + (let ((x #(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count 0 :from-end t) x)) + #(a b a c) + #(a b a c)) + +(deftest substitute-if-vector.14 + (let ((x #(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count -1 :from-end t) x)) + #(a b a c) + #(a b a c)) + +(deftest substitute-if-vector.15 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute-if 'x (is-eq-p 'a) x :start i :end j))) + (and (equalp orig x) + (equalp y (concatenate 'simple-vector + (make-array i :initial-element 'a) + (make-array (- j i) :initial-element 'x) + (make-array (- 10 j) :initial-element 'a))))))) + t) + +(deftest substitute-if-vector.16 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute-if 'x (is-eq-p 'a) x :start i :end j :from-end t))) + (and (equalp orig x) + (equalp y (concatenate 'simple-vector + (make-array i :initial-element 'a) + (make-array (- j i) :initial-element 'x) + (make-array (- 10 j) :initial-element 'a))))))) + t) + +(deftest substitute-if-vector.17 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute-if 'x (is-eq-p 'a) x :start i :end j :count c))) + (and (equalp orig x) + (equalp y (concatenate 'simple-vector + (make-array i :initial-element 'a) + (make-array c :initial-element 'x) + (make-array (- 10 (+ i c)) :initial-element 'a)))))))) + t) + +(deftest substitute-if-vector.18 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute-if 'x (is-eq-p 'a) x :start i :end j :count c :from-end t))) + (and (equalp orig x) + (equalp y (concatenate 'simple-vector + (make-array (- j c) :initial-element 'a) + (make-array c :initial-element 'x) + (make-array (- 10 j) :initial-element 'a)))))))) + t) + +;;; Tests on strings + +(deftest substitute-if-string.1 + (let ((x "")) (values (substitute-if #\b (is-eq-p #\a) x) x)) + "" "") + +(deftest substitute-if-string.2 + (let ((x "abac")) (values (substitute-if #\b (is-eq-p #\a) x) x)) + "bbbc" + "abac") + +(deftest substitute-if-string.3 + (let ((x "abac")) (values (substitute-if #\b (is-eq-p #\a) x :count nil) x)) + "bbbc" + "abac") + +(deftest substitute-if-string.4 + (let ((x "abac")) (values (substitute-if #\b (is-eq-p #\a) x :count 2) x)) + "bbbc" + "abac") + +(deftest substitute-if-string.5 + (let ((x "abac")) (values (substitute-if #\b (is-eq-p #\a) x :count 1) x)) + "bbac" + "abac") + +(deftest substitute-if-string.6 + (let ((x "abac")) (values (substitute-if #\b (is-eq-p #\a) x :count 0) x)) + "abac" + "abac") + +(deftest substitute-if-string.7 + (let ((x "abac")) (values (substitute-if #\b (is-eq-p #\a) x :count -1) x)) + "abac" + "abac") + +(deftest substitute-if-string.8 + (let ((x "")) (values (substitute-if #\b (is-eq-p #\a) x :from-end t) x)) + "" "") + +(deftest substitute-if-string.9 + (let ((x "abac")) (values (substitute-if #\b (is-eq-p #\a) x :from-end t) x)) + "bbbc" + "abac") + +(deftest substitute-if-string.10 + (let ((x "abac")) (values (substitute-if #\b (is-eq-p #\a) x :from-end t :count nil) x)) + "bbbc" + "abac") + +(deftest substitute-if-string.11 + (let ((x "abac")) (values (substitute-if #\b (is-eq-p #\a) x :count 2 :from-end t) x)) + "bbbc" + "abac") + +(deftest substitute-if-string.12 + (let ((x "abac")) (values (substitute-if #\b (is-eq-p #\a) x :count 1 :from-end t) x)) + "abbc" + "abac") + +(deftest substitute-if-string.13 + (let ((x "abac")) (values (substitute-if #\b (is-eq-p #\a) x :count 0 :from-end t) x)) + "abac" + "abac") + +(deftest substitute-if-string.14 + (let ((x "abac")) (values (substitute-if #\b (is-eq-p #\a) x :count -1 :from-end t) x)) + "abac" + "abac") + +(deftest substitute-if-string.15 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (substitute-if #\x (is-eq-p #\a) x :start i :end j))) + (and (equalp orig x) + (equalp y (concatenate 'simple-string + (make-array i :initial-element #\a) + (make-array (- j i) :initial-element #\x) + (make-array (- 10 j) :initial-element #\a))))))) + t) + +(deftest substitute-if-string.16 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (substitute-if #\x (is-eq-p #\a) x :start i :end j :from-end t))) + (and (equalp orig x) + (equalp y (concatenate 'simple-string + (make-array i :initial-element #\a) + (make-array (- j i) :initial-element #\x) + (make-array (- 10 j) :initial-element #\a))))))) + t) + +(deftest substitute-if-string.17 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (substitute-if #\x (is-eq-p #\a) x :start i :end j :count c))) + (and (equalp orig x) + (equalp y (concatenate 'simple-string + (make-array i :initial-element #\a) + (make-array c :initial-element #\x) + (make-array (- 10 (+ i c)) :initial-element #\a)))))))) + t) + +(deftest substitute-if-string.18 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (substitute-if #\x (is-eq-p #\a) x :start i :end j :count c :from-end t))) + (and (equalp orig x) + (equalp y (concatenate 'simple-string + (make-array (- j c) :initial-element #\a) + (make-array c :initial-element #\x) + (make-array (- 10 j) :initial-element #\a)))))))) + t) + +;;; Tests on bitstrings + +(deftest substitute-if-bitstring.1 + (let* ((orig #*) + (x (copy-seq orig)) + (result (substitute-if 0 (is-eq-p 1) x))) + (and (equalp orig x) + result)) + #*) + +(deftest substitute-if-bitstring.2 + (let* ((orig #*) + (x (copy-seq orig)) + (result (substitute-if 1 'zerop x))) + (and (equalp orig x) + result)) + #*) + +(deftest substitute-if-bitstring.3 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if 0 (is-eq-p 1) x))) + (and (equalp orig x) + result)) + #*000000) + +(deftest substitute-if-bitstring.4 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if 1 #'zerop x))) + (and (equalp orig x) + result)) + #*111111) + +(deftest substitute-if-bitstring.5 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if 1 #'zerop x :start 1))) + (and (equalp orig x) + result)) + #*011111) + +(deftest substitute-if-bitstring.6 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if 0 (is-eq-p 1) x :start 2 :end nil))) + (and (equalp orig x) + result)) + #*010000) + +(deftest substitute-if-bitstring.7 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if 1 #'zerop x :end 4))) + (and (equalp orig x) + result)) + #*111101) + +(deftest substitute-if-bitstring.8 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if 0 (is-eq-p 1) x :end nil))) + (and (equalp orig x) + result)) + #*000000) + +(deftest substitute-if-bitstring.9 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if 0 (is-eq-p 1) x :end 3))) + (and (equalp orig x) + result)) + #*000101) + +(deftest substitute-if-bitstring.10 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if 0 (is-eq-p 1) x :start 2 :end 4))) + (and (equalp orig x) + result)) + #*010001) + +(deftest substitute-if-bitstring.11 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if 1 #'zerop x :start 2 :end 4))) + (and (equalp orig x) + result)) + #*011101) + +(deftest substitute-if-bitstring.12 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if 1 #'zerop x :count 1))) + (and (equalp orig x) + result)) + #*110101) + +(deftest substitute-if-bitstring.13 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if 1 #'zerop x :count 0))) + (and (equalp orig x) + result)) + #*010101) + +(deftest substitute-if-bitstring.14 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if 1 #'zerop x :count -1))) + (and (equalp orig x) + result)) + #*010101) + +(deftest substitute-if-bitstring.15 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if 1 #'zerop x :count 1 :from-end t))) + (and (equalp orig x) + result)) + #*010111) + +(deftest substitute-if-bitstring.16 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if 1 #'zerop x :count 0 :from-end t))) + (and (equalp orig x) + result)) + #*010101) + +(deftest substitute-if-bitstring.17 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if 1 #'zerop x :count -1 :from-end t))) + (and (equalp orig x) + result)) + #*010101) + +(deftest substitute-if-bitstring.18 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if 1 #'zerop x :count nil))) + (and (equalp orig x) + result)) + #*111111) + +(deftest substitute-if-bitstring.19 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if 1 #'zerop x :count nil :from-end t))) + (and (equalp orig x) + result)) + #*111111) + +(deftest substitute-if-bitstring.20 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #*0000000000) + (x (copy-seq orig)) + (y (substitute-if 1 #'zerop x :start i :end j :count c))) + (and (equalp orig x) + (equalp y (concatenate + 'simple-bit-vector + (make-list i :initial-element 0) + (make-list c :initial-element 1) + (make-list (- 10 (+ i c)) :initial-element 0)))))))) + t) + +(deftest substitute-if-bitstring.21 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #*1111111111) + (x (copy-seq orig)) + (y (substitute-if 0 (is-eq-p 1) x :start i :end j :count c :from-end t))) + (and (equalp orig x) + (equalp y (concatenate + 'simple-bit-vector + (make-list (- j c) :initial-element 1) + (make-list c :initial-element 0) + (make-list (- 10 j) :initial-element 1)))))))) + t) + +;;; More tests + +(deftest substitute-if-list.24 + (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (substitute-if '(a 10) (is-eq-p 'a) x :key #'car))) + (and (equal orig x) + result)) + ((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) + +(deftest substitute-if-list.25 + (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (substitute-if '(a 10) (is-eq-p 'a) x + :key #'car :start 1 :end 5))) + (and (equal orig x) + result)) + ((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) + +(deftest substitute-if-vector.24 + (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (substitute-if '(a 10) (is-eq-p 'a) x :key #'car))) + (and (equalp orig x) + result)) + #((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) + +(deftest substitute-if-vector.25 + (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (substitute-if '(a 10) (is-eq-p 'a) x :key #'car :start 1 :end 5))) + (and (equalp orig x) + result)) + #((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) + +(deftest substitute-if-string.24 + (let* ((orig "0102342015") + (x (copy-seq orig)) + (result (substitute-if #\a (is-eq-p #\1) x :key #'nextdigit))) + (and (equalp orig x) + result)) + "a1a2342a15") + +(deftest substitute-if-string.25 + (let* ((orig "0102342015") + (x (copy-seq orig)) + (result (substitute-if #\a (is-eq-p #\1) x :key #'nextdigit :start 1 :end 6))) + (and (equalp orig x) + result)) + "01a2342015") + +(deftest substitute-if-bitstring.26 + (let* ((orig #*00111001011010110) + (x (copy-seq orig)) + (result (substitute-if 1 (is-eq-p 1) x :key #'1+))) + (and (equalp orig x) + result)) + #*11111111111111111) + +(deftest substitute-if-bitstring.27 + (let* ((orig #*00111001011010110) + (x (copy-seq orig)) + (result (substitute-if 1 (is-eq-p 1) x :key #'1+ :start 1 :end 10))) + (and (equalp orig x) + result)) + #*01111111111010110) diff --git a/ansi-tests/substitute.lsp b/ansi-tests/substitute.lsp new file mode 100644 index 0000000000000000000000000000000000000000..66654e68f59e8ffe08e85f0ed03bb01c9a35653c --- /dev/null +++ b/ansi-tests/substitute.lsp @@ -0,0 +1,883 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Wed Aug 28 21:15:33 2002 +;;;; Contains: Tests for SUBSTITUTE + +(in-package :cl-test) + +(deftest substitute-list.1 + (let ((x '())) (values (substitute 'b 'a x) x)) + nil nil) + +(deftest substitute-list.2 + (let ((x '(a b a c))) (values (substitute 'b 'a x) x)) + (b b b c) + (a b a c)) + +(deftest substitute-list.3 + (let ((x '(a b a c))) (values (substitute 'b 'a x :count nil) x)) + (b b b c) + (a b a c)) + +(deftest substitute-list.4 + (let ((x '(a b a c))) (values (substitute 'b 'a x :count 2) x)) + (b b b c) + (a b a c)) + +(deftest substitute-list.5 + (let ((x '(a b a c))) (values (substitute 'b 'a x :count 1) x)) + (b b a c) + (a b a c)) + +(deftest substitute-list.6 + (let ((x '(a b a c))) (values (substitute 'b 'a x :count 0) x)) + (a b a c) + (a b a c)) + +(deftest substitute-list.7 + (let ((x '(a b a c))) (values (substitute 'b 'a x :count -1) x)) + (a b a c) + (a b a c)) + +(deftest substitute-list.8 + (let ((x '())) (values (substitute 'b 'a x :from-end t) x)) + nil nil) + +(deftest substitute-list.9 + (let ((x '(a b a c))) (values (substitute 'b 'a x :from-end t) x)) + (b b b c) + (a b a c)) + +(deftest substitute-list.10 + (let ((x '(a b a c))) (values (substitute 'b 'a x :from-end t :count nil) x)) + (b b b c) + (a b a c)) + +(deftest substitute-list.11 + (let ((x '(a b a c))) (values (substitute 'b 'a x :count 2 :from-end t) x)) + (b b b c) + (a b a c)) + +(deftest substitute-list.12 + (let ((x '(a b a c))) (values (substitute 'b 'a x :count 1 :from-end t) x)) + (a b b c) + (a b a c)) + +(deftest substitute-list.13 + (let ((x '(a b a c))) (values (substitute 'b 'a x :count 0 :from-end t) x)) + (a b a c) + (a b a c)) + +(deftest substitute-list.14 + (let ((x '(a b a c))) (values (substitute 'b 'a x :count -1 :from-end t) x)) + (a b a c) + (a b a c)) + +(deftest substitute-list.15 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute 'x 'a x :start i :end j))) + (and (equal orig x) + (equal y (nconc (make-list i :initial-element 'a) + (make-list (- j i) :initial-element 'x) + (make-list (- 10 j) :initial-element 'a))))))) + t) + +(deftest substitute-list.16 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute 'x 'a x :start i :end j :from-end t))) + (and (equal orig x) + (equal y (nconc (make-list i :initial-element 'a) + (make-list (- j i) :initial-element 'x) + (make-list (- 10 j) :initial-element 'a))))))) + t) + +(deftest substitute-list.17 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute 'x 'a x :start i :end j :count c))) + (and (equal orig x) + (equal y (nconc (make-list i :initial-element 'a) + (make-list c :initial-element 'x) + (make-list (- 10 (+ i c)) :initial-element 'a)))))))) + t) + +(deftest substitute-list.18 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute 'x 'a x :start i :end j :count c :from-end t))) + (and (equal orig x) + (equal y (nconc (make-list (- j c) :initial-element 'a) + (make-list c :initial-element 'x) + (make-list (- 10 j) :initial-element 'a)))))))) + t) + +(deftest substitute-list.19 + (let* ((orig '(1 2 3 4 5 6 7 8 9)) + (x (copy-seq orig)) + (result (substitute 'x 5 x :test #'(lambda (a b) (<= (abs (- a b)) 2))))) + (and (equal orig x) + result)) + (1 2 x x x x x 8 9)) + +(deftest substitute-list.20 + (let* ((orig '(1 2 3 4 5 6 7 8 9)) + (x (copy-seq orig)) + (c -4) + (result (substitute 'x 5 x :test #'(lambda (a b) (incf c 2) (= (+ b c) a))))) + (and (equal orig x) + result)) + (1 2 x 4 5 6 7 8 9)) + + +(deftest substitute-list.21 + (let* ((orig '(1 2 3 4 5 6 7 8 9)) + (x (copy-seq orig)) + (c 5) + (result (substitute 'x 9 x :test #'(lambda (a b) (incf c -2) (= (+ b c) a)) + :from-end t))) + (and (equal orig x) + result)) + (1 2 3 4 5 6 7 x 9)) + +(deftest substitute-list.22 + (let* ((orig '(1 2 3 4 5 6 7 8 9)) + (x (copy-seq orig)) + (c -4) + (result (substitute 'x 5 x :test-not #'(lambda (a b) (incf c 2) (/= (+ b c) a))))) + (and (equal orig x) + result)) + (1 2 x 4 5 6 7 8 9)) + + +(deftest substitute-list.23 + (let* ((orig '(1 2 3 4 5 6 7 8 9)) + (x (copy-seq orig)) + (c 5) + (result (substitute 'x 9 x :test-not #'(lambda (a b) (incf c -2) (/= (+ b c) a)) + :from-end t))) + (and (equal orig x) + result)) + (1 2 3 4 5 6 7 x 9)) + +(deftest substitute-list.24 + (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (substitute '(a 10) 'a x :key #'car))) + (and (equal orig x) + result)) + ((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) + +(deftest substitute-list.25 + (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (substitute '(a 10) 'a x :key #'car :start 1 :end 5))) + (and (equal orig x) + result)) + ((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) + +(deftest substitute-list.26 + (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (substitute '(a 10) 'a x :key #'car :test (complement #'eq)))) + (and (equal orig x) + result)) + ((a 1) (a 10) (a 3) (a 10) (a 10) (a 6) (a 10))) + +(deftest substitute-list.27 + (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (substitute '(a 10) 'a x :key #'car :test-not #'eq))) + (and (equal orig x) + result)) + ((a 1) (a 10) (a 3) (a 10) (a 10) (a 6) (a 10))) + +;;; Tests on vectors + +(deftest substitute-vector.1 + (let ((x #())) (values (substitute 'b 'a x) x)) + #() #()) + +(deftest substitute-vector.2 + (let ((x #(a b a c))) (values (substitute 'b 'a x) x)) + #(b b b c) + #(a b a c)) + +(deftest substitute-vector.3 + (let ((x #(a b a c))) (values (substitute 'b 'a x :count nil) x)) + #(b b b c) + #(a b a c)) + +(deftest substitute-vector.4 + (let ((x #(a b a c))) (values (substitute 'b 'a x :count 2) x)) + #(b b b c) + #(a b a c)) + +(deftest substitute-vector.5 + (let ((x #(a b a c))) (values (substitute 'b 'a x :count 1) x)) + #(b b a c) + #(a b a c)) + +(deftest substitute-vector.6 + (let ((x #(a b a c))) (values (substitute 'b 'a x :count 0) x)) + #(a b a c) + #(a b a c)) + +(deftest substitute-vector.7 + (let ((x #(a b a c))) (values (substitute 'b 'a x :count -1) x)) + #(a b a c) + #(a b a c)) + +(deftest substitute-vector.8 + (let ((x #())) (values (substitute 'b 'a x :from-end t) x)) + #() #()) + +(deftest substitute-vector.9 + (let ((x #(a b a c))) (values (substitute 'b 'a x :from-end t) x)) + #(b b b c) + #(a b a c)) + +(deftest substitute-vector.10 + (let ((x #(a b a c))) (values (substitute 'b 'a x :from-end t :count nil) x)) + #(b b b c) + #(a b a c)) + +(deftest substitute-vector.11 + (let ((x #(a b a c))) (values (substitute 'b 'a x :count 2 :from-end t) x)) + #(b b b c) + #(a b a c)) + +(deftest substitute-vector.12 + (let ((x #(a b a c))) (values (substitute 'b 'a x :count 1 :from-end t) x)) + #(a b b c) + #(a b a c)) + +(deftest substitute-vector.13 + (let ((x #(a b a c))) (values (substitute 'b 'a x :count 0 :from-end t) x)) + #(a b a c) + #(a b a c)) + +(deftest substitute-vector.14 + (let ((x #(a b a c))) (values (substitute 'b 'a x :count -1 :from-end t) x)) + #(a b a c) + #(a b a c)) + +(deftest substitute-vector.15 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute 'x 'a x :start i :end j))) + (and (equalp orig x) + (equalp y (concatenate 'simple-vector + (make-array i :initial-element 'a) + (make-array (- j i) :initial-element 'x) + (make-array (- 10 j) :initial-element 'a))))))) + t) + +(deftest substitute-vector.16 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute 'x 'a x :start i :end j :from-end t))) + (and (equalp orig x) + (equalp y (concatenate 'simple-vector + (make-array i :initial-element 'a) + (make-array (- j i) :initial-element 'x) + (make-array (- 10 j) :initial-element 'a))))))) + t) + +(deftest substitute-vector.17 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute 'x 'a x :start i :end j :count c))) + (and (equalp orig x) + (equalp y (concatenate 'simple-vector + (make-array i :initial-element 'a) + (make-array c :initial-element 'x) + (make-array (- 10 (+ i c)) :initial-element 'a)))))))) + t) + +(deftest substitute-vector.18 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute 'x 'a x :start i :end j :count c :from-end t))) + (and (equalp orig x) + (equalp y (concatenate 'simple-vector + (make-array (- j c) :initial-element 'a) + (make-array c :initial-element 'x) + (make-array (- 10 j) :initial-element 'a)))))))) + t) + +(deftest substitute-vector.19 + (let* ((orig #(1 2 3 4 5 6 7 8 9)) + (x (copy-seq orig)) + (result (substitute 'x 5 x :test #'(lambda (a b) (<= (abs (- a b)) 2))))) + (and (equalp orig x) + result)) + #(1 2 x x x x x 8 9)) + +(deftest substitute-vector.20 + (let* ((orig #(1 2 3 4 5 6 7 8 9)) + (x (copy-seq orig)) + (c -4) + (result (substitute 'x 5 x :test #'(lambda (a b) (incf c 2) (= (+ b c) a))))) + (and (equalp orig x) + result)) + #(1 2 x 4 5 6 7 8 9)) + + +(deftest substitute-vector.21 + (let* ((orig #(1 2 3 4 5 6 7 8 9)) + (x (copy-seq orig)) + (c 5) + (result (substitute 'x 9 x :test #'(lambda (a b) (incf c -2) (= (+ b c) a)) + :from-end t))) + (and (equalp orig x) + result)) + #(1 2 3 4 5 6 7 x 9)) + +(deftest substitute-vector.22 + (let* ((orig #(1 2 3 4 5 6 7 8 9)) + (x (copy-seq orig)) + (c -4) + (result (substitute 'x 5 x :test-not #'(lambda (a b) (incf c 2) (/= (+ b c) a))))) + (and (equalp orig x) + result)) + #(1 2 x 4 5 6 7 8 9)) + + +(deftest substitute-vector.23 + (let* ((orig #(1 2 3 4 5 6 7 8 9)) + (x (copy-seq orig)) + (c 5) + (result (substitute 'x 9 x :test-not #'(lambda (a b) (incf c -2) (/= (+ b c) a)) + :from-end t))) + (and (equalp orig x) + result)) + #(1 2 3 4 5 6 7 x 9)) + +(deftest substitute-vector.24 + (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (substitute '(a 10) 'a x :key #'car))) + (and (equalp orig x) + result)) + #((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) + +(deftest substitute-vector.25 + (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (substitute '(a 10) 'a x :key #'car :start 1 :end 5))) + (and (equalp orig x) + result)) + #((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) + +(deftest substitute-vector.26 + (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (substitute '(a 10) 'a x :key #'car :test (complement #'eq)))) + (and (equalp orig x) + result)) + #((a 1) (a 10) (a 3) (a 10) (a 10) (a 6) (a 10))) + +(deftest substitute-vector.27 + (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (substitute '(a 10) 'a x :key #'car :test-not #'eq))) + (and (equalp orig x) + result)) + #((a 1) (a 10) (a 3) (a 10) (a 10) (a 6) (a 10))) + +;;; Tests on strings + +(deftest substitute-string.1 + (let ((x "")) (values (substitute #\b #\a x) x)) + "" "") + +(deftest substitute-string.2 + (let ((x "abac")) (values (substitute #\b #\a x) x)) + "bbbc" + "abac") + +(deftest substitute-string.3 + (let ((x "abac")) (values (substitute #\b #\a x :count nil) x)) + "bbbc" + "abac") + +(deftest substitute-string.4 + (let ((x "abac")) (values (substitute #\b #\a x :count 2) x)) + "bbbc" + "abac") + +(deftest substitute-string.5 + (let ((x "abac")) (values (substitute #\b #\a x :count 1) x)) + "bbac" + "abac") + +(deftest substitute-string.6 + (let ((x "abac")) (values (substitute #\b #\a x :count 0) x)) + "abac" + "abac") + +(deftest substitute-string.7 + (let ((x "abac")) (values (substitute #\b #\a x :count -1) x)) + "abac" + "abac") + +(deftest substitute-string.8 + (let ((x "")) (values (substitute #\b #\a x :from-end t) x)) + "" "") + +(deftest substitute-string.9 + (let ((x "abac")) (values (substitute #\b #\a x :from-end t) x)) + "bbbc" + "abac") + +(deftest substitute-string.10 + (let ((x "abac")) (values (substitute #\b #\a x :from-end t :count nil) x)) + "bbbc" + "abac") + +(deftest substitute-string.11 + (let ((x "abac")) (values (substitute #\b #\a x :count 2 :from-end t) x)) + "bbbc" + "abac") + +(deftest substitute-string.12 + (let ((x "abac")) (values (substitute #\b #\a x :count 1 :from-end t) x)) + "abbc" + "abac") + +(deftest substitute-string.13 + (let ((x "abac")) (values (substitute #\b #\a x :count 0 :from-end t) x)) + "abac" + "abac") + +(deftest substitute-string.14 + (let ((x "abac")) (values (substitute #\b #\a x :count -1 :from-end t) x)) + "abac" + "abac") + +(deftest substitute-string.15 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (substitute #\x #\a x :start i :end j))) + (and (equalp orig x) + (equalp y (concatenate 'simple-string + (make-array i :initial-element #\a) + (make-array (- j i) :initial-element #\x) + (make-array (- 10 j) :initial-element #\a))))))) + t) + +(deftest substitute-string.16 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (substitute #\x #\a x :start i :end j :from-end t))) + (and (equalp orig x) + (equalp y (concatenate 'simple-string + (make-array i :initial-element #\a) + (make-array (- j i) :initial-element #\x) + (make-array (- 10 j) :initial-element #\a))))))) + t) + +(deftest substitute-string.17 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (substitute #\x #\a x :start i :end j :count c))) + (and (equalp orig x) + (equalp y (concatenate 'simple-string + (make-array i :initial-element #\a) + (make-array c :initial-element #\x) + (make-array (- 10 (+ i c)) :initial-element #\a)))))))) + t) + +(deftest substitute-string.18 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (substitute #\x #\a x :start i :end j :count c :from-end t))) + (and (equalp orig x) + (equalp y (concatenate 'simple-string + (make-array (- j c) :initial-element #\a) + (make-array c :initial-element #\x) + (make-array (- 10 j) :initial-element #\a)))))))) + t) + +(deftest substitute-string.19 + (let* ((orig "123456789") + (x (copy-seq orig)) + (result (substitute #\x #\5 x :test #'(lambda (a b) + (setq a (read-from-string (string a))) + (setq b (read-from-string (string b))) + (<= (abs (- a b)) 2))))) + (and (equalp orig x) + result)) + "12xxxxx89") + +(deftest substitute-string.20 + (let* ((orig "123456789") + (x (copy-seq orig)) + (c -4) + (result (substitute #\x #\5 x :test #'(lambda (a b) + (setq a (read-from-string (string a))) + (setq b (read-from-string (string b))) + (incf c 2) (= (+ b c) a))))) + (and (equalp orig x) + result)) + "12x456789") + + +(deftest substitute-string.21 + (let* ((orig "123456789") + (x (copy-seq orig)) + (c 5) + (result (substitute #\x #\9 x :test #'(lambda (a b) + (setq a (read-from-string (string a))) + (setq b (read-from-string (string b))) + (incf c -2) (= (+ b c) a)) + :from-end t))) + (and (equalp orig x) + result)) + "1234567x9") + +(deftest substitute-string.22 + (let* ((orig "123456789") + (x (copy-seq orig)) + (c -4) + (result (substitute #\x #\5 x :test-not #'(lambda (a b) + (setq a (read-from-string (string a))) + (setq b (read-from-string (string b))) + (incf c 2) (/= (+ b c) a))))) + (and (equalp orig x) + result)) + "12x456789") + + +(deftest substitute-string.23 + (let* ((orig "123456789") + (x (copy-seq orig)) + (c 5) + (result (substitute #\x #\9 x :test-not #'(lambda (a b) + (setq a (read-from-string (string a))) + (setq b (read-from-string (string b))) + (incf c -2) (/= (+ b c) a)) + :from-end t))) + (and (equalp orig x) + result)) + "1234567x9") + +(deftest substitute-string.24 + (let* ((orig "0102342015") + (x (copy-seq orig)) + (result (substitute #\a #\1 x :key #'nextdigit))) + (and (equalp orig x) + result)) + "a1a2342a15") + +(deftest substitute-string.25 + (let* ((orig "0102342015") + (x (copy-seq orig)) + (result (substitute #\a #\1 x :key #'nextdigit :start 1 :end 6))) + (and (equalp orig x) + result)) + "01a2342015") + +(deftest substitute-string.26 + (let* ((orig "0102342015") + (x (copy-seq orig)) + (result (substitute #\a #\1 x :key #'nextdigit :test (complement #'eq)))) + (and (equalp orig x) + result)) + "0a0aaaa0aa") + +(deftest substitute-string.27 + (let* ((orig "0102342015") + (x (copy-seq orig)) + (result (substitute #\a #\1 x :key #'nextdigit :test-not #'eq))) + (and (equalp orig x) + result)) + "0a0aaaa0aa") + +;;; Tests on bitstrings + +(deftest substitute-bitstring.1 + (let* ((orig #*) + (x (copy-seq orig)) + (result (substitute 0 1 x))) + (and (equalp orig x) + result)) + #*) + +(deftest substitute-bitstring.2 + (let* ((orig #*) + (x (copy-seq orig)) + (result (substitute 1 0 x))) + (and (equalp orig x) + result)) + #*) + +(deftest substitute-bitstring.3 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute 0 1 x))) + (and (equalp orig x) + result)) + #*000000) + +(deftest substitute-bitstring.4 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute 1 0 x))) + (and (equalp orig x) + result)) + #*111111) + +(deftest substitute-bitstring.5 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute 1 0 x :start 1))) + (and (equalp orig x) + result)) + #*011111) + +(deftest substitute-bitstring.6 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute 0 1 x :start 2 :end nil))) + (and (equalp orig x) + result)) + #*010000) + +(deftest substitute-bitstring.7 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute 1 0 x :end 4))) + (and (equalp orig x) + result)) + #*111101) + +(deftest substitute-bitstring.8 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute 0 1 x :end nil))) + (and (equalp orig x) + result)) + #*000000) + +(deftest substitute-bitstring.9 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute 0 1 x :end 3))) + (and (equalp orig x) + result)) + #*000101) + +(deftest substitute-bitstring.10 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute 0 1 x :start 2 :end 4))) + (and (equalp orig x) + result)) + #*010001) + +(deftest substitute-bitstring.11 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute 1 0 x :start 2 :end 4))) + (and (equalp orig x) + result)) + #*011101) + +(deftest substitute-bitstring.12 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute 1 0 x :count 1))) + (and (equalp orig x) + result)) + #*110101) + +(deftest substitute-bitstring.13 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute 1 0 x :count 0))) + (and (equalp orig x) + result)) + #*010101) + +(deftest substitute-bitstring.14 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute 1 0 x :count -1))) + (and (equalp orig x) + result)) + #*010101) + +(deftest substitute-bitstring.15 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute 1 0 x :count 1 :from-end t))) + (and (equalp orig x) + result)) + #*010111) + +(deftest substitute-bitstring.16 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute 1 0 x :count 0 :from-end t))) + (and (equalp orig x) + result)) + #*010101) + +(deftest substitute-bitstring.17 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute 1 0 x :count -1 :from-end t))) + (and (equalp orig x) + result)) + #*010101) + +(deftest substitute-bitstring.18 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute 1 0 x :count nil))) + (and (equalp orig x) + result)) + #*111111) + +(deftest substitute-bitstring.19 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute 1 0 x :count nil :from-end t))) + (and (equalp orig x) + result)) + #*111111) + +(deftest substitute-bitstring.20 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #*0000000000) + (x (copy-seq orig)) + (y (substitute 1 0 x :start i :end j :count c))) + (and (equalp orig x) + (equalp y (concatenate + 'simple-bit-vector + (make-list i :initial-element 0) + (make-list c :initial-element 1) + (make-list (- 10 (+ i c)) :initial-element 0)))))))) + t) + +(deftest substitute-bitstring.21 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #*1111111111) + (x (copy-seq orig)) + (y (substitute 0 1 x :start i :end j :count c :from-end t))) + (and (equalp orig x) + (equalp y (concatenate + 'simple-bit-vector + (make-list (- j c) :initial-element 1) + (make-list c :initial-element 0) + (make-list (- 10 j) :initial-element 1)))))))) + t) + +(deftest substitute-bitstring.22 + (let* ((orig #*0101010101) + (x (copy-seq orig)) + (c 0) + (result (substitute 1 0 x :test #'(lambda (a b) (incf c) (and (<= 2 c 5) (= a b)))))) + (and (equalp orig x) + result)) + #*0111110101) + +(deftest substitute-bitstring.23 + (let* ((orig #*0101010101) + (x (copy-seq orig)) + (c 0) + (result (substitute 1 0 x :test-not #'(lambda (a b) (incf c) + (not (and (<= 2 c 5) (= a b))))))) + (and (equalp orig x) + result)) + #*0111110101) + +(deftest substitute-bitstring.24 + (let* ((orig #*0101010101) + (x (copy-seq orig)) + (c 0) + (result (substitute 1 0 x :test #'(lambda (a b) (incf c) (and (<= 2 c 5) (= a b))) + :from-end t))) + (and (equalp orig x) + result)) + #*0101011111) + +(deftest substitute-bitstring.25 + (let* ((orig #*0101010101) + (x (copy-seq orig)) + (c 0) + (result (substitute 1 0 x :test-not #'(lambda (a b) (incf c) + (not (and (<= 2 c 5) (= a b)))) + :from-end t))) + (and (equalp orig x) + result)) + #*0101011111) + +(deftest substitute-bitstring.26 + (let* ((orig #*00111001011010110) + (x (copy-seq orig)) + (result (substitute 1 1 x :key #'1+))) + (and (equalp orig x) + result)) + #*11111111111111111) + +(deftest substitute-bitstring.27 + (let* ((orig #*00111001011010110) + (x (copy-seq orig)) + (result (substitute 1 1 x :key #'1+ :start 1 :end 10))) + (and (equalp orig x) + result)) + #*01111111111010110) + +(deftest substitute-bitstring.28 + (let* ((orig #*00111001011010110) + (x (copy-seq orig)) + (result (substitute 0 1 x :key #'1+ :test (complement #'eq)))) + (and (equalp orig x) + result)) + #*00000000000000000) + +(deftest substitute-bitstring.29 + (let* ((orig #*00111001011010110) + (x (copy-seq orig)) + (result (substitute 0 1 x :key #'1+ :test-not #'eq))) + (and (equalp orig x) + result)) + #*00000000000000000) diff --git a/ansi-tests/types-and-class.lsp b/ansi-tests/types-and-class.lsp new file mode 100644 index 0000000000000000000000000000000000000000..0f248c179058c83d3a9e27794748a786b23f4f60 --- /dev/null +++ b/ansi-tests/types-and-class.lsp @@ -0,0 +1,361 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Thu Mar 19 21:48:39 1998 +;;;; Contains: Data for testing type and class inclusions + +;; We should check for every type that NIL is a subtype, and T a supertype + +(in-package :cl-test) +(use-package :rt) + +(declaim (optimize (safety 3))) + +(deftest boolean-type-1 + (handler-case + (not (not (typep nil 'boolean))) + (error (c) c)) + t) + +(deftest boolean-type-2 + (handler-case + (not (not (typep t 'boolean))) + (error (c) c)) + t) + +(defun is-t-or-nil (e) + (or (eq e t) (eq e nil))) + +(deftest boolean-type-3 + (check-type-predicate 'is-t-or-nil 'boolean) + 0) + +;; Two type inclusions on booleans +;; have been conditionalized to prevent +;; some tests from doing too badly on CMU CL on x86 +;; These should get removed when I get a more up to date +;; image for that platform -- pfd + +(defvar *subtype-table* +'( +(symbol t) +#-(and cmu (not sparc)) (boolean symbol) +(standard-object t) +(function t) +(compiled-function function) +(generic-function function) +(standard-generic-function generic-function) +(class standard-object) +(built-in-class class) +(structure-class class) +(standard-class class) +(method standard-object) +(standard-method method) +(structure-object t) +(method-combination t) +(condition t) +(serious-condition condition) +(error serious-condition) +(type-error error) +(simple-type-error type-error) +(simple-condition condition) +(simple-type-error simple-condition) +(parse-error error) +(hash-table t) +(cell-error error) +(unbound-slot cell-error) +(warning condition) +(style-warning warning) +(storage-condition serious-condition) +(simple-warning warning) +(simple-warning simple-condition) +(keyword symbol) +(unbound-variable cell-error) +(control-error error) +(program-error error) +(undefined-function cell-error) +(package t) +(package-error error) +(random-state t) +(number t) +(real number) +(complex number) +(float real) +(short-float float) +(single-float float) +(double-float float) +(long-float float) +(rational real) +(integer rational) +(ratio rational) +(signed-byte integer) +(integer signed-byte) +(unsigned-byte signed-byte) +(bit unsigned-byte) +(fixnum integer) +(bignum integer) +(bit fixnum) +(arithmetic-error error) +(division-by-zero arithmetic-error) +(floating-point-invalid-operation arithmetic-error) +(floating-point-inexact arithmetic-error) +(floating-point-overflow arithmetic-error) +(floating-point-underflow arithmetic-error) +(character t) +(base-char character) +(standard-char base-char) +(extended-char character) +(sequence t) +(list sequence) +(null list) +#-(and cmu (not sparc)) (null boolean) +(cons list) +(array t) +(simple-array array) +(vector sequence) +(vector array) +(string vector) +(bit-vector vector) +(simple-vector vector) +(simple-vector simple-array) +(simple-bit-vector bit-vector) +(simple-bit-vector simple-array) +(base-string string) +(simple-string string) +(simple-string simple-array) +(simple-base-string base-string) +(simple-base-string simple-string) +(pathname t) +(logical-pathname pathname) +(file-error error) +(stream t) +(broadcast-stream stream) +(concatenated-stream stream) +(echo-stream stream) +(file-stream stream) +(string-stream stream) +(synonym-stream stream) +(two-way-stream stream) +(stream-error error) +(end-of-file stream-error) +(print-not-readable error) +(readtable t) +(reader-error parse-error) +(reader-error stream-error) +)) + +(deftest types-3 + (count-if + #'(lambda (pair) + (let ((t1 (first pair)) + (t2 (second pair))) + (cond + ((not (subtypep t1 t2)) + (format t "~%~S not a subtype of ~S" t1 t2) + t) + (t nil)))) + *subtype-table*) + 0) + +(defconstant +float-types+ '(long-float double-float short-float single-float)) + +(defun types-4-body () + (let ((parent-table (make-hash-table :test #'equal)) + (types nil)) + (loop + for p in *subtype-table* do + (let ((tp (first p)) + (parent (second p))) + (pushnew tp types) + (pushnew parent types) + (let ((parents (gethash tp parent-table))) + (pushnew parent parents) + ;; (format t "~S ==> ~S~%" tp parent) + (loop + for pp in (gethash parent parent-table) do + ;; (format t "~S ==> ~S~%" tp pp) + (pushnew pp parents)) + (setf (gethash tp parent-table) parents)))) + ;; parent-table now contains lists of ancestors + (loop + for tp in types sum + (let ((parents (gethash tp parent-table))) + (loop + for tp2 in types sum + (cond + ((and (not (eq tp tp2)) + (not (eq tp2 'standard-object)) + (not (eq tp2 'structure-object)) + (not (member tp2 parents)) + (subtypep tp tp2) + (not (and (member tp +float-types+) + (member tp2 +float-types+))) + (not (and (eq tp2 'structure-object) + (member 'standard-object parents)))) + (format t "~%Improper subtype: ~S of ~S" + tp tp2) + 1) + (t 0))))) + )) + +(deftest types-4 + (types-4-body) + 0) + +(deftest types-5 + (subtypep* 'simple-base-string 'sequence) + t t) + +(defun types-6-body () + (loop + for p in *subtype-table* count + (let ((tp (car p))) + (cond + ((and (not (member tp '(sequence cons list t))) + (not (subtypep tp 'atom))) + (format t "~%Not an atomic type: ~S" tp) + t))))) + +(deftest types-6 + (types-6-body) + 0) + +(defvar *disjoint-types-list* + '(cons symbol array + number character hash-table function readtable package + pathname stream random-state condition restart)) + +(deftest types-7 + (loop + for tp in *disjoint-types-list* sum + (loop for tp2 in *disjoint-types-list* count + (and (not (eq tp tp2)) + (subtypep tp tp2)))) + 0) + +(deftest types-8 + (loop + for tp in *disjoint-types-list* count + (cond + ((and (not (eq tp 'cons)) + (not (subtypep tp 'atom))) + (format t "~%Should be atomic, but isn't: ~S" tp) + t))) + 0) + +(defvar *type-list* nil) +(defvar *supertype-table* nil) + +(defun types-9-body () + (let ((tp-list (append '(keyword atom list) + (loop for p in *subtype-table* collect (car p)))) + (result-list)) + (setf tp-list (remove-duplicates tp-list)) + (setf *type-list* tp-list) + (let ((subs (make-hash-table :test #'eq)) + (sups (make-hash-table :test #'eq))) + (loop + for x in tp-list do + (loop + for y in tp-list do + (multiple-value-bind (result good) + (subtypep x y) + (declare (ignore good)) + (when result + (pushnew x (gethash y subs)) + (pushnew y (gethash x sups)))))) + (setf *supertype-table* sups) + (loop + for x in tp-list do + (let ((sub-list (gethash x subs)) + (sup-list (gethash x sups))) + (loop + for t1 in sub-list do + (loop + for t2 in sup-list do + (multiple-value-bind (result good) + (subtypep t1 t2) + (when (and good (not result)) + (pushnew (list t1 x t2) result-list + :test #'equal))))))) + + result-list))) + +(deftest types-9 + (types-9-body) + nil) + +(defun types-9a-body () + (cond + ((not (and *type-list* *supertype-table*)) + (format nil "Run test type-9 first~%") + nil) + (t + (loop + for tp in *type-list* + sum + (let ((sups (gethash tp *supertype-table*))) + (loop + for x in *universe* + sum + (handler-case + (cond + ((not (typep x tp)) 0) + (t + (loop + for tp2 in sups + count + (handler-case + (and (not (typep x tp2)) + (progn + (format t "Found element of ~S not in ~S~%" + tp tp2) + t)) + (condition (c) (format t "Error ~S occured: ~S~%" + c tp2) + t))))) + (condition (c) (format t "Error ~S occured: ~S~%" c tp) + 1)))))))) + +(deftest types-9a + (types-9a-body) + 0) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; deftype + +(defun even-size-p (a) + (some #'evenp (array-dimensions a))) + +(deftype even-array (&optional type size) + `(and (array ,type ,size) + (satisfies even-size-p))) + +(deftest deftype-1 + (typep 1 '(even-array integer (10))) + nil) + +(deftest deftype-2 + (typep nil '(even-array t (*))) + nil) + +(deftest deftype-3 + (not (not (typep (make-array '(10)) '(even-array t (*))))) + t) + +(deftest deftype-4 + (typep (make-array '(5)) '(even-array t (*))) + nil) + +(deftest deftype-5 + (not (not (typep (make-string 10) '(even-array character (*))))) + t) + +(deftest deftype-6 + (not (not + (typep (make-array '(3 5 6) :element-type '(unsigned-byte 8)) + '(even-array (unsigned-byte 8))))) + t) + +;; This should be greatly expanded + diff --git a/ansi-tests/universe.lsp b/ansi-tests/universe.lsp new file mode 100644 index 0000000000000000000000000000000000000000..43df57e57871c6173a21f0a2d4c4a5e256bfd993 --- /dev/null +++ b/ansi-tests/universe.lsp @@ -0,0 +1,306 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Thu Apr 9 19:32:56 1998 +;;;; Contains: A global variable containing a list of +;;;; as many kinds of CL objects as we can think of +;;;; This list is used to test many other CL functions + +(in-package :cl-test) + +(defvar *condition-types* + '(arithmetic-error + cell-error + condition + control-error + division-by-zero + end-of-file + error + file-error + floating-point-inexact + floating-point-invalid-operation + floating-point-underflow + floating-point-overflow + package-error + parse-error + print-not-readable + program-error + reader-error + serious-condition + simple-condition + simple-error + simple-type-error + simple-warning + storage-condition + stream-error + style-warning + type-error + unbound-slot + unbound-variable + undefined-function + warning)) + +(defvar *condition-objects* + (loop + for tp in *condition-types* append + (handler-case + (list (make-condition tp)) + (error () nil)))) + +(defvar *standard-package-names* + '("COMMON-LISP" "COMMON-LISP-USER" "KEYWORD")) + +(defvar *package-objects* + (loop + for pname in *standard-package-names* append + (handler-case + (let ((pkg (find-package pname))) + (and pkg (list pkg))) + (error () nil)))) + +(defvar *integers* + (remove-duplicates + `( + 0 + ;; Integers near the fixnum/bignum boundaries + ,@(loop for i from -5 to 5 collect (+ i MOST-POSITIVE-FIXNUM)) + ,@(loop for i from -5 to 5 collect (+ i MOST-NEGATIVE-FIXNUM)) + ;; Powers of two, negatives, and off by one. + ,@(loop for i from 1 to 64 collect (ash 1 i)) + ,@(loop for i from 1 to 64 collect (1- (ash 1 i))) + ,@(loop for i from 1 to 64 collect (ash -1 i)) + ,@(loop for i from 1 to 64 collect (1+ (ash -1 i))) + ;; A big integer + ,(expt 17 50) + ;; Some arbitrarily chosen integers + 12387131 1272314 231 -131 -561823 23713 -1234611312123 444121 991))) + +(defvar *floats* + (list + MOST-POSITIVE-SHORT-FLOAT LEAST-POSITIVE-SHORT-FLOAT + LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT MOST-POSITIVE-DOUBLE-FLOAT + LEAST-POSITIVE-DOUBLE-FLOAT LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT + MOST-POSITIVE-LONG-FLOAT LEAST-POSITIVE-LONG-FLOAT LEAST-POSITIVE-NORMALIZED-LONG-FLOAT + MOST-POSITIVE-SINGLE-FLOAT LEAST-POSITIVE-SINGLE-FLOAT + LEAST-POSITIVE-NORMALIZED-SINGLE-FLOAT MOST-NEGATIVE-SHORT-FLOAT + LEAST-NEGATIVE-SHORT-FLOAT LEAST-NEGATIVE-NORMALIZED-SHORT-FLOAT + MOST-NEGATIVE-SINGLE-FLOAT LEAST-NEGATIVE-SINGLE-FLOAT + LEAST-NEGATIVE-NORMALIZED-SINGLE-FLOAT MOST-NEGATIVE-DOUBLE-FLOAT + LEAST-NEGATIVE-DOUBLE-FLOAT LEAST-NEGATIVE-NORMALIZED-DOUBLE-FLOAT + MOST-NEGATIVE-LONG-FLOAT LEAST-NEGATIVE-LONG-FLOAT LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT + SHORT-FLOAT-EPSILON SHORT-FLOAT-NEGATIVE-EPSILON SINGLE-FLOAT-EPSILON + SINGLE-FLOAT-NEGATIVE-EPSILON DOUBLE-FLOAT-EPSILON DOUBLE-FLOAT-NEGATIVE-EPSILON + LONG-FLOAT-EPSILON LONG-FLOAT-NEGATIVE-EPSILON + + 0.0 1.0 -1.0 313123.13 283143.231 -314781.9 + 1.31283d2 834.13812D-45 + 8131238.1E14 -4618926.231e-2 + -37818.131F3 81.318231f-19 + 1.31273s3 12361.12S-7 + 6124.124l0 13123.1L-23)) + +(defvar *ratios* + '(1/3 1/1000 1/1000000000000000 -10/3 -1000/7 -987129387912381/13612986912361 + 189729874978126783786123/1234678123487612347896123467851234671234)) + +(defvar *complexes* + '(#C(0.0 0.0) + #C(1.0 0.0) + #C(0.0 1.0) + #C(1.0 1.0) + #C(-1.0 -1.0) + #C(1289713.12312 -9.12681271) + #C(1.0D100 1.0D100) + #C(-1.0D-100 -1.0D-100))) + +(defvar *numbers* + (append *integers* + *floats* + *ratios* + *complexes*)) + +(defun try-to-read-chars (&rest namelist) + (loop + for name in namelist append + (handler-case + (list (read-from-string + (concatenate 'string "\#\\" name))) + (error () nil)))) + +(defvar *characters* + (remove-duplicates + `(#\Newline + #\Space + ,@(try-to-read-chars "Rubout" + "Page" + "Tab" + "Backspace" + "Return" + "Linefeed" + "Null") + #\a #\A #\0 #\9 #\. #\( #\) #\[ #\] + ))) + + +(defvar *strings* + (append + (and (code-char 0) + (list + (make-string 1 :initial-element (code-char 0)) + (make-string 10 :initial-element (code-char 0)))) + (list + "" "A" "a" "0" "abcdef" + "~!@#$%^&*()_+`1234567890-=<,>.?/:;\"'{[}]|\\ abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWYXZ" + (make-string 100000 :initial-element #\g) + (let ((s (make-string 256))) + (loop + for i from 0 to 255 + do (let ((c (code-char i))) + (when c + (setf (elt s i) c)))) + s)))) + +(defvar *conses* + (list + (list 'a 'b) + (list nil) + (list 1 2 3 4 5 6))) + +(defvar *circular-conses* + (list + (let ((s (copy-list '(a b c d)))) + (nconc s s) + s) + (let ((s (list nil))) + (setf (car s) s) + s) + (let ((s (list nil))) + (setf (car s) s) + (setf (cdr s) s)))) + +(defvar *booleans* '(nil t)) +(defvar *keywords* '(:a :b :|| :|a| :|1234|)) +(defvar *uninterned-symbols* + (list '#:nil '#:t '#:foo + #-CMU '#:|| + )) +(defvar *cl-test-symbols* + `(,(intern "a" :cl-test) + ,(intern "" :cl-test) + ,@(and (code-char 0) + (list (intern (make-string 1 :initial-element (code-char 0)) :cl-test))) + ,@(and (code-char 0) + (let* ((s (make-string 10 :initial-element (code-char 0))) + (s2 (copy-seq s)) + (s3 (copy-seq s))) + (setf (subseq s 3 4) "a") + (setf (subseq s2 4 5) "a") + (setf (subseq s3 4 5) "a") + (setf (subseq s3 7 8) "b") + (list (intern s :cl-test) + (intern s2 :cl-test) + (intern s3 :cl-test)))) + )) + +(defvar *cl-user-symbols* + '(cl-user::foo cl-user::x + cl-user::cons cl-user::lambda + cl-user::*print-readably* cl-user::push)) + +(defvar *symbols* + (append *booleans* *keywords* *uninterned-symbols* + *cl-test-symbols* + *cl-user-symbols*)) + +(defvar *array-dimensions* + (loop + for i from 1 to 8 collect + (loop for j from 1 to i collect 2))) + +(defvar *arrays* + (append + (list (make-array '10)) + (mapcar #'make-array *array-dimensions*) + + ;; typed arrays + (loop for tp in '(fixnum float bit character base-char + (signed-byte 8) (unsigned-byte 8)) + append + (loop + for d in *array-dimensions* + collect (make-array d :element-type tp))) + + ;; adjustable arrays + (loop + for d in *array-dimensions* + collect (make-array d :adjustable t)) + + ;; more kinds of arrays here later + )) + +(defvar *hash-tables* + (list + (make-hash-table) + (make-hash-table :test #'eq) + (make-hash-table :test #'eql) + (make-hash-table :test #'equal) + #-(or GCL CMU) (make-hash-table :test #'equalp) + )) + +(defvar *pathnames* + (list + (make-pathname :name "foo") + (make-pathname :name "bar") + (make-pathname :name "foo" :type "txt") + (make-pathname :name "bar" :type "txt") + (make-pathname :name :wild) + (make-pathname :name :wild :type "txt") + )) + +(defvar *streams* + (remove-duplicates + (remove-if + #'null + (list + *debug-io* + *error-output* + *query-io* + *standard-input* + *standard-output* + *terminal-io* + *trace-output*)))) + +(defvar *readtables* + (list *readtable* + (copy-readtable))) + +(defstruct foo-structure + x y z) + +(defstruct bar-structure + x y z) + +(defvar *structures* + (list + (make-foo-structure :x 1 :y 'a :z nil) + (make-foo-structure :x 1 :y 'a :z nil) + (make-bar-structure :x 1 :y 'a :z nil) + )) + +(defvar *universe* + (remove-duplicates + (append + *symbols* + *numbers* + *characters* + (mapcar #'copy-seq *strings*) + *conses* + *condition-objects* + *package-objects* + *arrays* + *hash-tables* + *pathnames* + *streams* + *readtables* + *structures* + nil))) +