diff --git a/ansi-tests/ansi-aux.lsp b/ansi-tests/ansi-aux.lsp index 1e0eec7e7b1732c64967362d87e37fdbaa9eac4b..6026857d77082cf117fad06e23f88494edb8776a 100644 --- a/ansi-tests/ansi-aux.lsp +++ b/ansi-tests/ansi-aux.lsp @@ -677,7 +677,7 @@ the condition to go uncaught if it cannot be classified." (declaim (special *subtype-table*)) -(defun types-6-body () +(defun types.6-body () (loop for p in *subtype-table* for tp = (car p) @@ -690,14 +690,14 @@ the condition to go uncaught if it cannot be classified." (defparameter *supertype-table* nil) (declaim (special *subtype-table*)) -(defun types-9-body () +(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)) ;; TP-LIST is now a list of unique CL type names ;; Store it in *TYPE-LIST* so we can inspect it later if this test - ;; fails. The variable is also used in test TYPES-9A + ;; fails. The variable is also used in test TYPES.9A (setf *type-list* tp-list) ;; Compute all pairwise SUBTYPEP relationships among ;; the elements of *TYPE-LIST*. @@ -714,7 +714,7 @@ the condition to go uncaught if it cannot be classified." (pushnew x (gethash y subs)) (pushnew y (gethash x sups)))))) ;; Store the supertype relations for later inspection - ;; and use in test TYPES-9A + ;; and use in test TYPES.9A (setf *supertype-table* sups) ;; Check that the relation we just computed is transitive. ;; Return a list of triples on which transitivity fails. @@ -734,15 +734,15 @@ the condition to go uncaught if it cannot be classified." result-list))) -;;; TYPES-9-BODY returns a list of triples (T1 T2 T3) +;;; TYPES.9-BODY returns a list of triples (T1 T2 T3) ;;; where (AND (SUBTYPEP T1 T2) (SUBTYPEP T2 T3) (NOT (SUBTYPEP T1 T3))) ;;; (and where SUBTYPEP succeeds in each case, returning true as its ;;; second return value.) -(defun types-9a-body () +(defun types.9a-body () (cond ((not (and *type-list* *supertype-table*)) - (format nil "Run test type-9 first~%") + (format nil "Run test type.9 first~%") nil) (t (loop diff --git a/ansi-tests/bit.lsp b/ansi-tests/bit.lsp index 9acfff7dd6184dd38d78f0056068ce2d6461d463..5a88fd35b75516828e45a45a53c1d10d25511fd8 100644 --- a/ansi-tests/bit.lsp +++ b/ansi-tests/bit.lsp @@ -131,3 +131,6 @@ x y z w)) 0 #*00010 3 1 2 3) +(deftest bit.error.1 + (classify-error (bit)) + program-error) diff --git a/ansi-tests/nsubstitute-if-not.lsp b/ansi-tests/nsubstitute-if-not.lsp index 55953c7d4d783737cd227864895f7ba8e7328c80..59ae27a73372214ebda3758f690e114bf34d69a0 100644 --- a/ansi-tests/nsubstitute-if-not.lsp +++ b/ansi-tests/nsubstitute-if-not.lsp @@ -633,6 +633,41 @@ result) #*01111) +(deftest nsubstitute-if-not.order.1 + (let ((i 0) a b c d e f g h) + (values + (nsubstitute-if-not + (progn (setf a (incf i)) 'a) + (progn (setf b (incf i)) #'identity) + (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) + :count (progn (setf d (incf i)) 2) + :start (progn (setf e (incf i)) 0) + :end (progn (setf f (incf i)) 7) + :key (progn (setf g (incf i)) #'identity) + :from-end (setf h (incf i)) + ) + i a b c d e f g h)) + (nil 1 2 a 3 4 a 5) + 8 1 2 3 4 5 6 7 8) + +(deftest nsubstitute-if-not.order.2 + (let ((i 0) a b c d e f g h) + (values + (nsubstitute-if-not + (progn (setf a (incf i)) 'a) + (progn (setf b (incf i)) #'identity) + (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) + :from-end (setf h (incf i)) + :key (progn (setf g (incf i)) #'identity) + :end (progn (setf f (incf i)) 7) + :start (progn (setf e (incf i)) 0) + :count (progn (setf d (incf i)) 2) + ) + i a b c d e f g h)) + (nil 1 2 a 3 4 a 5) + 8 1 2 3 8 7 6 5 4) + + ;;; Keyword tests (deftest nsubstitute-if-not.allow-other-keys.1 diff --git a/ansi-tests/nsubstitute.lsp b/ansi-tests/nsubstitute.lsp index 27beb4b49a2ef366665e060dac51e6e9f5b7af39..c751568edb1d0eac5c44d7360423ad9b26895309 100644 --- a/ansi-tests/nsubstitute.lsp +++ b/ansi-tests/nsubstitute.lsp @@ -836,6 +836,40 @@ result) #*01111) +(deftest nsubstitute.order.1 + (let ((i 0) a b c d e f g h) + (values + (nsubstitute + (progn (setf a (incf i)) 'a) + (progn (setf b (incf i)) nil) + (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) + :count (progn (setf d (incf i)) 2) + :start (progn (setf e (incf i)) 0) + :end (progn (setf f (incf i)) 7) + :key (progn (setf g (incf i)) #'identity) + :from-end (setf h (incf i)) + ) + i a b c d e f g h)) + (nil 1 2 a 3 4 a 5) + 8 1 2 3 4 5 6 7 8) + +(deftest nsubstitute.order.2 + (let ((i 0) a b c d e f g h) + (values + (nsubstitute + (progn (setf a (incf i)) 'a) + (progn (setf b (incf i)) nil) + (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) + :from-end (setf h (incf i)) + :key (progn (setf g (incf i)) #'identity) + :end (progn (setf f (incf i)) 7) + :start (progn (setf e (incf i)) 0) + :count (progn (setf d (incf i)) 2) + ) + i a b c d e f g h)) + (nil 1 2 a 3 4 a 5) + 8 1 2 3 8 7 6 5 4) + ;;; Keyword tests (deftest nsubstitute.allow-other-keys.1 diff --git a/ansi-tests/nth-value.lsp b/ansi-tests/nth-value.lsp index 56394ddfc39ec47740202aa25ff7946efa1f4ebd..1d825ad7a330a032ed24e4aa932acef3bcbe66a7 100644 --- a/ansi-tests/nth-value.lsp +++ b/ansi-tests/nth-value.lsp @@ -27,8 +27,10 @@ (nth-value 100 'a) nil) - - - - - +(deftest nth-value.order.1 + (let ((i 0) x y) + (values + (nth-value (progn (setf x (incf i)) 3) + (progn (setf y (incf i)) (values 'a 'b 'c 'd 'e 'f 'g))) + i x y)) + d 2 1 2) diff --git a/ansi-tests/packages-01.lsp b/ansi-tests/packages-01.lsp index 1b8f1ee5ea65290df821f964769d9383d600e883..5883d7295ba7c402b2eaec6df66a34d3a9b636bc 100644 --- a/ansi-tests/packages-01.lsp +++ b/ansi-tests/packages-01.lsp @@ -9,72 +9,80 @@ ;; Test find-symbol, with the various combinations of ;; package designators -(deftest find-symbol-1 +(deftest find-symbol.1 (find-symbol "aBmAchb1c") nil nil) -(deftest find-symbol-2 +(deftest find-symbol.2 (find-symbol "aBmAchb1c" "CL") nil nil) -(deftest find-symbol-3 +(deftest find-symbol.3 (find-symbol "aBmAchb1c" "COMMON-LISP") nil nil) -(deftest find-symbol-4 +(deftest find-symbol.4 (find-symbol "aBmAchb1c" "KEYWORD") nil nil) -(deftest find-symbol-5 +(deftest find-symbol.5 (find-symbol "aBmAchb1c" "COMMON-LISP-USER") nil nil) -(deftest find-symbol-6 +(deftest find-symbol.6 (find-symbol "CAR" "CL") car :external) -(deftest find-symbol-7 +(deftest find-symbol.7 (find-symbol "CAR" "COMMON-LISP") car :external) -(deftest find-symbol-8 +(deftest find-symbol.8 (values (find-symbol "CAR" "COMMON-LISP-USER")) car #| :inherited |# ) -(deftest find-symbol-9 +(deftest find-symbol.9 (find-symbol "CAR" "CL-TEST") car :inherited) -(deftest find-symbol-10 +(deftest find-symbol.10 (find-symbol "TEST" "KEYWORD") :test :external) -(deftest find-symbol-11 - (find-symbol "FIND-SYMBOL-11" "CL-TEST") - find-symbol-11 :internal) +(deftest find-symbol.11 + (find-symbol "FIND-SYMBOL.11" "CL-TEST") + find-symbol.11 :internal) -(deftest find-symbol-12 +(deftest find-symbol.12 (find-symbol "FOO" #\A) A::FOO :external) -(deftest find-symbol-13 +(deftest find-symbol.13 (progn (intern "X" (find-package "A")) (find-symbol "X" #\A)) A::X :internal) -(deftest find-symbol-14 +(deftest find-symbol.14 (find-symbol "FOO" #\B) A::FOO :inherited) -(deftest find-symbol-15 +(deftest find-symbol.15 (find-symbol "FOO" "B") A::FOO :inherited) -(deftest find-symbol-16 +(deftest find-symbol.16 (find-symbol "FOO" (find-package "B")) A::FOO :inherited) +(deftest find-symbol.order.1 + (let ((i 0) x y) + (values + (find-symbol (progn (setf x (incf i)) "CAR") + (progn (setf y (incf i)) "COMMON-LISP")) + i x y)) + car 2 1 2) + (deftest find-symbol.error.1 (classify-error (find-symbol)) program-error) diff --git a/ansi-tests/packages-02.lsp b/ansi-tests/packages-02.lsp index 96d89c7293c7890cb2f55bc2f354624c62143d85..3139da7ca8b00bc94d161b875aa88bd23dddc41a 100644 --- a/ansi-tests/packages-02.lsp +++ b/ansi-tests/packages-02.lsp @@ -9,79 +9,77 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; find-package -(deftest find-package-1 - (let ((p (find-package "CL")) - (p2 (find-package "COMMON-LISP"))) - (and p p2 (eqt p p2))) +(deftest find-package.1 + (let ((p (find-package "CL")) + (p2 (find-package "COMMON-LISP"))) + (and p p2 (eqt p p2))) t) -(deftest find-package-2 - (let ((p (find-package "CL-USER")) - (p2 (find-package "COMMON-LISP-USER"))) - (and p p2 (eqt p p2))) +(deftest find-package.2 + (let ((p (find-package "CL-USER")) + (p2 (find-package "COMMON-LISP-USER"))) + (and p p2 (eqt p p2))) t) -(deftest find-package-3 - (let ((p (find-package "KEYWORD"))) - (and p (eqt p (symbol-package :test)))) +(deftest find-package.3 + (let ((p (find-package "KEYWORD"))) + (and p (eqt p (symbol-package :test)))) t) -(deftest find-package-4 - (let ((p (ignore-errors (find-package "A")))) - (if (packagep p) - t - p)) +(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)) +(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)) +(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)) +(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) - (eqt p p2))) +(deftest find-package.8 + (let ((p (ignore-errors (find-package "Q"))) + (p2 (ignore-errors (find-package "A")))) + (and (packagep p) + (packagep p2) + (eqt p p2))) t) -(deftest find-package-9 - (let ((p (ignore-errors (find-package "A"))) - (p2 (ignore-errors (find-package "B")))) - (eqt p p2)) +(deftest find-package.9 + (let ((p (ignore-errors (find-package "A"))) + (p2 (ignore-errors (find-package "B")))) + (eqt p p2)) nil) -(deftest find-package-10 - (let ((p (ignore-errors (find-package #\Q))) - (p2 (ignore-errors (find-package "Q")))) - (and (packagep p) - (eqt p p2))) +(deftest find-package.10 + (let ((p (ignore-errors (find-package #\Q))) + (p2 (ignore-errors (find-package "Q")))) + (and (packagep p) + (eqt p p2))) t) -(deftest find-package-11 - (handler-case - (let ((cl (find-package "CL"))) - (let ((cl2 (find-package cl))) - (and (packagep cl) - (eqt cl cl2)))) - (error (c) c)) +(deftest find-package.11 + (let* ((cl (find-package "CL")) + (cl2 (find-package cl))) + (and (packagep cl) + (eqt cl cl2))) t) (deftest find-package.error.1 diff --git a/ansi-tests/packages-03.lsp b/ansi-tests/packages-03.lsp index 71216ac94451f941d609169d74441e54ebe95c4b..153f16ca0f965bdc4734a4b8a6e2130ade044757 100644 --- a/ansi-tests/packages-03.lsp +++ b/ansi-tests/packages-03.lsp @@ -10,34 +10,34 @@ ;;; list-all-packages ;; list-all-packages returns a list -(deftest list-all-packages-1 - (numberp (ignore-errors (list-length (list-all-packages)))) +(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)) +(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 - (notnot-mv (every #'packagep (list-all-packages))) +(deftest list-all-packages.3 + (notnot-mv (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))) +(deftest list-all-packages.4 + (let ((p1 (list-all-packages)) + (p2 (list-all-packages))) + (and (subsetp p1 p2) + (subsetp p2 p1))) t) (deftest list-all-packages.error.1 @@ -48,62 +48,62 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; package-name -(deftest package-name-1 - (ignore-errors (package-name "A")) +(deftest package-name.1 + (ignore-errors (package-name "A")) "A") -(deftest package-name-2 - (ignore-errors (package-name #\A)) +(deftest package-name.2 + (ignore-errors (package-name #\A)) "A") -(deftest package-name-3 - (ignore-errors (package-name "Q")) +(deftest package-name.3 + (ignore-errors (package-name "Q")) "A") -(deftest package-name-4 - (ignore-errors (package-name #\Q)) +(deftest package-name.4 + (ignore-errors (package-name #\Q)) "A") -(deftest package-name-5 +(deftest package-name.5 (notnot-mv (member (classify-error (package-name "NOT-THERE")) '(type-error package-error))) t) -(deftest package-name-6 +(deftest package-name.6 (notnot-mv (member (classify-error (package-name #\*)) '(type-error package-error))) t) -(deftest package-name-6a +(deftest package-name.6a (notnot-mv (member (classify-error (locally (package-name #\*) t)) '(type-error package-error))) t) -(deftest package-name-7 +(deftest package-name.7 (package-name "CL") "COMMON-LISP") -(deftest package-name-8 +(deftest package-name.8 (package-name "COMMON-LISP") "COMMON-LISP") -(deftest package-name-9 +(deftest package-name.9 (package-name "COMMON-LISP-USER") "COMMON-LISP-USER") -(deftest package-name-10 +(deftest package-name.10 (package-name "CL-USER") "COMMON-LISP-USER") -(deftest package-name-11 +(deftest package-name.11 (package-name "KEYWORD") "KEYWORD") -(deftest package-name-12 +(deftest package-name.12 (package-name (find-package "CL")) "COMMON-LISP") -(deftest package-name-13 +(deftest package-name.13 (let* ((p (make-package "TEMP1")) (pname1 (package-name p))) (rename-package "TEMP1" "TEMP2") @@ -113,7 +113,7 @@ ("TEMP1" "TEMP2" nil)) ;; (find-package (package-name p)) == p for any package p -(deftest package-name-14 +(deftest package-name.14 (loop for p in (list-all-packages) count (not @@ -124,7 +124,7 @@ ;; package-name applied to a package's name ;; should return an equal string -(deftest package-name-15 +(deftest package-name.15 (loop for p in (list-all-packages) count (not (equal (package-name p) @@ -142,38 +142,38 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; package-nicknames -(deftest package-nicknames-1 - (ignore-errors (package-nicknames "A")) +(deftest package-nicknames.1 + (ignore-errors (package-nicknames "A")) ("Q")) -(deftest package-nicknames-2 +(deftest package-nicknames.2 (ignore-errors (package-nicknames #\A)) ("Q")) -(deftest package-nicknames-3 +(deftest package-nicknames.3 (ignore-errors (package-nicknames ':|A|)) ("Q")) -(deftest package-nicknames-4 +(deftest package-nicknames.4 (ignore-errors (package-nicknames "B")) nil) -(deftest package-nicknames-5 +(deftest package-nicknames.5 (ignore-errors (package-nicknames #\B)) nil) -(deftest package-nicknames-6 +(deftest package-nicknames.6 (ignore-errors (package-nicknames '#:|B|)) nil) -(deftest package-nicknames-7 +(deftest package-nicknames.7 (ignore-errors (subsetp '("CL") (package-nicknames "COMMON-LISP") :test #'string=)) t) -(deftest package-nicknames-8 +(deftest package-nicknames.8 (ignore-errors (notnot (subsetp '("CL-USER") @@ -181,19 +181,19 @@ :test #'string=))) t) -(deftest package-nicknames-9 +(deftest package-nicknames.9 (classify-error (package-nicknames 10)) type-error) -(deftest package-nicknames-9a +(deftest package-nicknames.9a (classify-error (locally (package-nicknames 10) t)) type-error) -(deftest package-nicknames-10 +(deftest package-nicknames.10 (ignore-errors (package-nicknames (find-package "A"))) ("Q")) -(deftest package-nicknames-11 +(deftest package-nicknames.11 (notnot-mv (member (classify-error (package-nicknames "NOT-A-PACKAGE-NAME")) '(type-error package-error))) t) @@ -201,7 +201,7 @@ ;; (find-package n) == p for each n in (package-nicknames p), ;; for any package p -(deftest package-nicknames-12 +(deftest package-nicknames.12 (loop for p in (list-all-packages) sum (loop diff --git a/ansi-tests/packages-04.lsp b/ansi-tests/packages-04.lsp index 638fadabdc801b55fce62d70eb37ab007b9328c9..f9dabec14ebf471500b9eddb73252409a0c708d1 100644 --- a/ansi-tests/packages-04.lsp +++ b/ansi-tests/packages-04.lsp @@ -9,16 +9,21 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; intern -(deftest intern-1 +(deftest intern.1 (progn (safely-delete-package "TEMP1") - (let ((p (make-package "TEMP1"))) + (let ((p (make-package "TEMP1")) + (i 0) x y) (multiple-value-bind* (sym1 status1) (find-symbol "FOO" p) - (intern "FOO" p) + (intern (progn (setf x (incf i)) "FOO") + (progn (setf y (incf i)) p)) (multiple-value-bind* (sym2 status2) (find-symbol "FOO" p) - (and (null sym1) + (and (eql i 2) + (eql x 1) + (eql y 2) + (null sym1) (null status1) (string= (symbol-name sym2) "FOO") (eqt (symbol-package sym2) p) @@ -26,7 +31,7 @@ (progn (delete-package p) t)))))) t) -(deftest intern-2 +(deftest intern.2 (progn (safely-delete-package "TEMP1") (let ((p (make-package "TEMP1"))) diff --git a/ansi-tests/packages-05.lsp b/ansi-tests/packages-05.lsp index 79b27a4e068fdddc0f5afa1ed99e6de1447ba921..6085e34dd55fb5d828e3462353047f98bc74e089 100644 --- a/ansi-tests/packages-05.lsp +++ b/ansi-tests/packages-05.lsp @@ -9,16 +9,21 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; export -(deftest export-1 +(deftest export.1 (let ((return-value nil)) (safely-delete-package "TEST1") (let ((p (make-package "TEST1"))) - (let ((sym (intern "FOO" p))) - (setf return-value (export sym p)) + (let ((sym (intern "FOO" p)) + (i 0) x y) + (setf return-value (export (progn (setf x (incf i)) sym) + (progn (setf y (incf i)) p))) (multiple-value-bind* (sym2 status) (find-symbol "FOO" p) (prog1 (and sym2 + (eql i 2) + (eql x 1) + (eql y 2) (eqt (symbol-package sym2) p) (string= (symbol-name sym2) "FOO") (eqt sym sym2) @@ -27,7 +32,7 @@ return-value) t) -(deftest export-2 +(deftest export.2 (progn (safely-delete-package "TEST1") (let ((p (make-package "TEST1"))) @@ -44,7 +49,7 @@ (delete-package p)))))) t) -(deftest export-3 +(deftest export.3 (handler-case (progn (safely-delete-package "F") @@ -61,7 +66,7 @@ ;; should signal a correctable package-error asking the ;; user whether the symbol should be imported. ;; -(deftest export-4 +(deftest export.4 (handler-case (export 'b::bar "A") (package-error () 'package-error) @@ -73,7 +78,7 @@ ;; from a package that is used by another package that ;; is exporting a symbol with the same name. ;; -(deftest export-5 +(deftest export.5 (progn (safely-delete-package "TEST1") (safely-delete-package "TEST2") @@ -86,7 +91,7 @@ (handler-case (export sym "TEST1") (error (c) - (format t "Caught error in EXPORT-5: ~A~%" c) + (format t "Caught error in EXPORT.5: ~A~%" c) 'caught))) (error (c) c)) (delete-package "TEST2") diff --git a/ansi-tests/packages-06.lsp b/ansi-tests/packages-06.lsp index ad2162baa2591a326c789337fc82e28b40e05df5..a1580c6a50c550d0cbc58cf4e79ea37109ddb208 100644 --- a/ansi-tests/packages-06.lsp +++ b/ansi-tests/packages-06.lsp @@ -9,17 +9,22 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; rename-package -(deftest rename-package-1 +(deftest rename-package.1 (block nil (safely-delete-package "TEST1") (safely-delete-package "TEST2") - (let ((p (make-package "TEST1"))) + (let ((p (make-package "TEST1")) + (i 0) x y) (unless (packagep p) (return nil)) - (let ((p2 (rename-package "TEST1" "TEST2"))) + (let ((p2 (rename-package (progn (setf x (incf i)) "TEST1") + (progn (setf y (incf i)) "TEST2")))) (unless (packagep p2) (safely-delete-package p) (return p2)) (unless (and (eqt p p2) + (eql i 2) + (eql x 1) + (eql y 2) (equal (package-name p2) "TEST2")) (safely-delete-package p) (safely-delete-package p2) @@ -28,7 +33,7 @@ t))) t) -(deftest rename-package-2 +(deftest rename-package.2 (block nil (safely-delete-package "TEST1") (safely-delete-package "TEST2") @@ -54,7 +59,7 @@ t))) t) -(deftest rename-package-3 +(deftest rename-package.3 (block nil (safely-delete-package "TEST1") (safely-delete-package "TEST2") @@ -81,7 +86,7 @@ t))) t) -(deftest rename-package-4 +(deftest rename-package.4 (block nil (safely-delete-package "G") (safely-delete-package "TEST2") @@ -104,7 +109,7 @@ t))) t) -(deftest rename-package-5 +(deftest rename-package.5 (block nil (safely-delete-package "TEST1") (safely-delete-package "G") @@ -127,7 +132,7 @@ t))) t) -(deftest rename-package-6 +(deftest rename-package.6 (block nil (safely-delete-package '|TEST1|) (safely-delete-package '|TEST2|) diff --git a/ansi-tests/packages-07.lsp b/ansi-tests/packages-07.lsp index 499ba915a9d20af7f6924eee1ca3266a30639c9b..9d3c0cfaee2230dbe8dc0a90803931f7e48cea2e 100644 --- a/ansi-tests/packages-07.lsp +++ b/ansi-tests/packages-07.lsp @@ -9,7 +9,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; shadow -(deftest shadow-1 +(deftest shadow.1 (prog1 (progn (safely-delete-package "TEST5") @@ -50,7 +50,7 @@ t "A" "TEST5" :internal)) -(deftest shadow-2 +(deftest shadow.2 (progn (safely-delete-package "H") (safely-delete-package "G") @@ -88,7 +88,7 @@ ;; shadow in which the package is given ;; by a character -(deftest shadow-3 +(deftest shadow.3 (progn (safely-delete-package "H") (safely-delete-package "G") @@ -126,7 +126,7 @@ ;; shadow on an existing internal symbol returns the existing symbol -(deftest shadow-4 +(deftest shadow.4 (prog1 (handler-case (progn @@ -146,7 +146,7 @@ ;; shadow of an existing shadowed symbol returns the symbol -(deftest shadow-5 +(deftest shadow.5 (prog1 (handler-case (progn @@ -169,7 +169,7 @@ ;; Shadow several names simultaneously -(deftest shadow-6 +(deftest shadow.6 (prog1 (handler-case (progn @@ -197,13 +197,14 @@ ("X" :internal "Y" :internal "Z" :internal 3)) ;; Same, but shadow character string designators -(deftest shadow-7 +(deftest shadow.7 (prog1 (handler-case - (progn + (let ((i 0) x y) (safely-delete-package :G) (make-package :G) - (shadow '(#\X #\Y) :G) + (shadow (progn (setf x (incf i)) '(#\X #\Y)) + (progn (setf y (incf i)) :G)) (let ((results (append (multiple-value-list (find-symbol "X" :G)) @@ -211,6 +212,7 @@ (find-symbol "Y" :G)) nil))) (list + i x y (symbol-name (first results)) (second results) (symbol-name (third results)) @@ -218,7 +220,7 @@ (length (package-shadowing-symbols :G))))) (error (c) c)) (safely-delete-package :G)) - ("X" :internal "Y" :internal 2)) + (2 1 2 "X" :internal "Y" :internal 2)) (deftest shadow.error.1 (classify-error (shadow)) diff --git a/ansi-tests/packages-08.lsp b/ansi-tests/packages-08.lsp index a31b4a128ac726f4e50e16ee774b5bc8aa8d2c76..d35d09ba0c8694897bc9dcfe1a43362710286507 100644 --- a/ansi-tests/packages-08.lsp +++ b/ansi-tests/packages-08.lsp @@ -10,7 +10,7 @@ ;; check return value of delete-package, and check ;; that package-name is nil on the deleted package object -(deftest delete-package-1 +(deftest delete-package.1 (progn (safely-delete-package :test1) (let ((p (make-package :test1 :use nil))) @@ -20,7 +20,7 @@ (package-name p)))) (t t nil)) -(deftest delete-package-2 +(deftest delete-package.2 (progn (safely-delete-package :test1) (let ((p (make-package :test1 :use nil))) @@ -31,7 +31,7 @@ (t t nil)) ;; Check that deletion of different package designators works -(deftest delete-package-3 +(deftest delete-package.3 (progn (safely-delete-package "X") (make-package "X") @@ -40,7 +40,7 @@ (error (c) c))) t) -(deftest delete-package-4 +(deftest delete-package.4 (progn (safely-delete-package "X") (make-package "X") @@ -52,9 +52,9 @@ ;;; PFD 10/14/02 -- These tests are broken again. I suspect ;;; some sort of interaction with the test harness. -;;; PFD 01-18-03 This test is working, but suspicious. +;;; PFD 01.18.03 This test is working, but suspicious. -(deftest delete-package-5 +(deftest delete-package.5 (prog (P1 S1 P2 S2 P3) (safely-delete-package "P3") (safely-delete-package "P2") @@ -116,15 +116,15 @@ t) ;; deletion of a nonexistent package should cause a continuable -;; package-error (same comments for delete-package-5 apply +;; package-error (same comments for delete-package.5 apply ;; here as well) ;;; PFD 10/14/02 -- These tests are broken again. I suspect ;;; some sort of interaction with the test harness. -;;; PFD 01-18-03 This test is working, but suspicious. +;;; PFD 01.18.03 This test is working, but suspicious. -(deftest delete-package-6 +(deftest delete-package.6 (progn (safely-delete-package "TEST-20)") (handler-bind ((package-error diff --git a/ansi-tests/packages-09.lsp b/ansi-tests/packages-09.lsp index cead16bc8fb76dc44e0f59ab27174d363d92d07f..67a86ba157230bd1896eaa6f83245249571a6b98 100644 --- a/ansi-tests/packages-09.lsp +++ b/ansi-tests/packages-09.lsp @@ -12,7 +12,7 @@ ;; Test basic make-package, using string, symbol and character ;; package-designators -(deftest make-package-1 +(deftest make-package.1 (progn (safely-delete-package "TEST1") (let ((p (ignore-errors (make-package "TEST1")))) @@ -24,7 +24,7 @@ (safely-delete-package p)))) t) -(deftest make-package-2 +(deftest make-package.2 (progn (safely-delete-package '#:|TEST1|) (let ((p (ignore-errors (make-package '#:|TEST1|)))) @@ -36,7 +36,7 @@ (safely-delete-package p)))) t) -(deftest make-package-3 +(deftest make-package.3 (progn (safely-delete-package #\X) (let ((p (ignore-errors (make-package #\X)))) @@ -50,7 +50,7 @@ ;; Same, but with a null :use list -(deftest make-package-4 +(deftest make-package.4 (progn (safely-delete-package "TEST1") (let ((p (ignore-errors (make-package "TEST1" :use nil)))) @@ -63,7 +63,7 @@ (safely-delete-package p)))) t) -(deftest make-package-5 +(deftest make-package.5 (progn (safely-delete-package '#:|TEST1|) (let ((p (ignore-errors (make-package '#:|TEST1| :use nil)))) @@ -76,7 +76,7 @@ (safely-delete-package p)))) t) -(deftest make-package-6 +(deftest make-package.6 (progn (safely-delete-package #\X) (let ((p (make-package #\X))) @@ -91,7 +91,7 @@ ;; Same, but use the A package -(deftest make-package-7 +(deftest make-package.7 (progn (safely-delete-package "TEST1") (let ((p (ignore-errors (make-package "TEST1" :use '("A"))))) @@ -104,7 +104,7 @@ (safely-delete-package p)))) t) -(deftest make-package-7a +(deftest make-package.7a (progn (safely-delete-package "TEST1") (let ((p (ignore-errors (make-package "TEST1" :use '(#:|A|))))) @@ -117,7 +117,7 @@ (safely-delete-package p)))) t) -(deftest make-package-7b +(deftest make-package.7b (progn (safely-delete-package "TEST1") (let ((p (ignore-errors (make-package "TEST1" :use '(#\A))))) @@ -130,7 +130,7 @@ (safely-delete-package p)))) t) -(deftest make-package-8 +(deftest make-package.8 (progn (safely-delete-package '#:|TEST1|) (let ((p (ignore-errors (make-package '#:|TEST1| :use '("A"))))) @@ -143,7 +143,7 @@ (safely-delete-package p)))) t) -(deftest make-package-8a +(deftest make-package.8a (progn (safely-delete-package '#:|TEST1|) (let ((p (ignore-errors (make-package '#:|TEST1| :use '(#:|A|))))) @@ -156,7 +156,7 @@ (safely-delete-package p)))) t) -(deftest make-package-8b +(deftest make-package.8b (progn (safely-delete-package '#:|TEST1|) (let ((p (ignore-errors (make-package '#:|TEST1| :use '(#\A))))) @@ -169,7 +169,7 @@ (safely-delete-package p)))) t) -(deftest make-package-9 +(deftest make-package.9 (progn (safely-delete-package #\X) (let ((p (ignore-errors (make-package #\X :use '("A"))))) @@ -182,7 +182,7 @@ (safely-delete-package p)))) t) -(deftest make-package-9a +(deftest make-package.9a (progn (safely-delete-package #\X) (let ((p (ignore-errors (make-package #\X :use '(#:|A|))))) @@ -195,7 +195,7 @@ (safely-delete-package p)))) t) -(deftest make-package-9b +(deftest make-package.9b (progn (safely-delete-package #\X) (let ((p (ignore-errors (make-package #\X :use '(#\A))))) @@ -210,7 +210,7 @@ ;; make-package with nicknames -(deftest make-package-10 +(deftest make-package.10 (progn (safely-delete-package "TEST1") (let ((p (make-package "TEST1" :nicknames '("F")))) @@ -222,7 +222,7 @@ (safely-delete-package p)))) t) -(deftest make-package-11 +(deftest make-package.11 (progn (safely-delete-package '#:|TEST1|) (let ((p (make-package '#:|TEST1| :nicknames '(#:|G|)))) @@ -234,7 +234,7 @@ (safely-delete-package p)))) t) -(deftest make-package-12 +(deftest make-package.12 (progn (safely-delete-package '#:|TEST1|) (let ((p (make-package '#:|TEST1| :nicknames '(#\G)))) @@ -246,7 +246,7 @@ (safely-delete-package p)))) t) -(deftest make-package-13 +(deftest make-package.13 (progn (safely-delete-package #\X) (let ((p (make-package #\X :nicknames '("F" #\G #:|H|)))) diff --git a/ansi-tests/packages-10.lsp b/ansi-tests/packages-10.lsp index 648667933fdcae9d6d810b9da914a0022ea604e8..d8ff8979063353a90326b2b4cb9ae09630ff2e3a 100644 --- a/ansi-tests/packages-10.lsp +++ b/ansi-tests/packages-10.lsp @@ -9,65 +9,53 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; with-package-iterator -(deftest with-package-iterator-1 - (with-package-iterator-internal (list (find-package "COMMON-LISP-USER"))) +(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"))) +(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"))) +(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"))) +(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)) +(deftest with-package-iterator.5 + (with-package-iterator-all '("A")) t) -(deftest with-package-iterator-6 - (handler-case - (with-package-iterator-all '(#:|A|)) - (error (c) c)) +(deftest with-package-iterator.6 + (with-package-iterator-all '(#:|A|)) t) -(deftest with-package-iterator-7 - (handler-case - (with-package-iterator-all '(#\A)) - (error (c) c)) +(deftest with-package-iterator.7 + (with-package-iterator-all '(#\A)) t) -(deftest with-package-iterator-8 - (handler-case - (with-package-iterator-internal (list (find-package "A"))) - (error (c) c)) +(deftest with-package-iterator.8 + (with-package-iterator-internal (list (find-package "A"))) t) -(deftest with-package-iterator-9 - (handler-case - (with-package-iterator-external (list (find-package "A"))) - (error (c) c)) +(deftest with-package-iterator.9 + (with-package-iterator-external (list (find-package "A"))) t) -(deftest with-package-iterator-10 - (handler-case - (with-package-iterator-inherited (list (find-package "A"))) - (error (c) c)) +(deftest with-package-iterator.10 + (with-package-iterator-inherited (list (find-package "A"))) t) ;;; Check that if no access symbols are provided, a program error is ;;; raised #| -(deftest with-package-iterator-11 +(deftest with-package-iterator.11 (handler-case (progn (test-with-package-iterator (list (find-package "COMMON-LISP-USER"))) @@ -88,7 +76,7 @@ ;;; PFD 01-18-03: I should rewrite this to use CLASSIFY-ERROR, which ;;; uses EVAL to avoid that problem. -(deftest with-package-iterator-11 +(deftest with-package-iterator.11 (handler-case (macroexpand-1 '(with-package-iterator (x "COMMON-LISP-USER"))) (program-error () t) @@ -96,44 +84,38 @@ 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)) +(deftest with-package-iterator.12 + (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))) 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)) +(deftest with-package-iterator.13 + (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))) 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)) +(deftest with-package-iterator.14 + (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))) 0) diff --git a/ansi-tests/packages-11.lsp b/ansi-tests/packages-11.lsp index db1b88e13774c0ae9a35e03e13eec73e4456b47a..71e2cd3965a746e4092e686f4b1d005ed7dee096 100644 --- a/ansi-tests/packages-11.lsp +++ b/ansi-tests/packages-11.lsp @@ -9,126 +9,128 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; unexport -(deftest unexport-1 - (handler-case - (progn - (safely-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 (eqt r t) - (eqt sym1 sym2) - (eqt access1 :external) - (eqt access2 :internal) - (equal (symbol-name sym1) "X") - t))))) - (error (c) c)) +(deftest unexport.1 + (progn + (safely-delete-package "X") + (let* ((p (make-package "X" :use nil)) + (r (export (intern "X" p) p)) + (i 0) x y) + (multiple-value-bind* + (sym1 access1) + (find-symbol "X" p) + (unexport (progn (setf x (incf i)) sym1) + (progn (setf y (incf i)) p)) + (multiple-value-bind* + (sym2 access2) + (find-symbol "X" p) + (and (eqt r t) + (eql i 2) (eql x 1) (eql y 2) + (eqt sym1 sym2) + (eqt access1 :external) + (eqt access2 :internal) + (equal (symbol-name sym1) "X") + t))))) t) -(deftest unexport-2 - (handler-case - (progn - (safely-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 (eqt sym1 sym2) - (eqt r t) - (eqt access1 :external) - (eqt access2 :internal) - (equal (symbol-name sym1) "X") - t))))) - (error (c) c)) +(deftest unexport.2 + (progn + (safely-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 (eqt sym1 sym2) + (eqt r t) + (eqt access1 :external) + (eqt access2 :internal) + (equal (symbol-name sym1) "X") + t))))) t) -(deftest unexport-3 - (handler-case - (progn - (safely-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 (eqt sym1 sym2) - (eqt sym1a sym2a) - (eqt r1 t) - (eqt r2 t) - (eqt access1 :external) - (eqt access2 :internal) - (eqt access1a :external) - (eqt access2a :internal) - (equal (symbol-name sym1) "X") - (equal (symbol-name sym1a) "Y") - t))))))) - (error (c) c)) +(deftest unexport.3 + (progn + (safely-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 (eqt sym1 sym2) + (eqt sym1a sym2a) + (eqt r1 t) + (eqt r2 t) + (eqt access1 :external) + (eqt access2 :internal) + (eqt access1a :external) + (eqt access2a :internal) + (equal (symbol-name sym1) "X") + (equal (symbol-name sym1a) "Y") + t))))))) t) -(deftest unexport-4 - (handler-case - (progn - (safely-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 (eqt sym1 sym2) - (eqt r t) - (eqt access1 :external) - (eqt access2 :internal) - (equal (symbol-name sym1) "X") - t))))) - (error (c) c)) +(deftest unexport.4 + (progn + (safely-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 (eqt sym1 sym2) + (eqt r t) + (eqt access1 :external) + (eqt access2 :internal) + (equal (symbol-name sym1) "X") + t))))) t) ;; Check that it signals a package error when unexporting ;; an inaccessible symbol -(deftest unexport-5 - (handler-case +(deftest unexport.5 + (classify-error (progn (when (find-package "X") (delete-package "X")) (unexport 'a (make-package "X" :use nil)) - nil) - (package-error () t) - (error (c) c)) - t) + nil)) + package-error) ;; 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 (eqt r t) - (eqt access :internal) - (eqt sym sym2) - (equal (symbol-name sym) "FOO") - t))))) - (error (c) c)) +(deftest unexport.6 + (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 (eqt r t) + (eqt access :internal) + (eqt sym sym2) + (equal (symbol-name sym) "FOO") + t))))) t) (deftest unexport.error.1 diff --git a/ansi-tests/packages-12.lsp b/ansi-tests/packages-12.lsp index 85406d73312d4af17d0390b11e6a1136a71e4dca..b1614caefd747121ff0f3ab3a332cee5a42506a6 100644 --- a/ansi-tests/packages-12.lsp +++ b/ansi-tests/packages-12.lsp @@ -12,25 +12,29 @@ ;; Simple unintern of an internal symbol, package explicitly ;; given as a package object -(deftest unintern-1 +(deftest unintern.1 (progn (safely-delete-package "H") (prog1 - (let ((p (make-package "H"))) + (let ((p (make-package "H")) + (i 0) x y) (intern "FOO" p) - (multiple-value-bind* (sym access) - (find-symbol "FOO" p) - (and - (eqt access :internal) - (unintern sym p) - (null (symbol-package sym)) - (not (find-symbol "FOO" p))))) + (multiple-value-bind* + (sym access) + (find-symbol "FOO" p) + (and + (eqt access :internal) + (unintern (progn (setf x (incf i)) sym) + (progn (setf y (incf i)) p)) + (eql i 2) (eql x 1) (eql y 2) + (null (symbol-package sym)) + (not (find-symbol "FOO" p))))) (safely-delete-package "H"))) t) ;; Simple unintern, package taken from the *PACKAGES* ;; special variable (should this have unwind protect?) -(deftest unintern-2 +(deftest unintern.2 (progn (safely-delete-package "H") (prog1 @@ -48,7 +52,7 @@ t) ;; Simple unintern, package given as string -(deftest unintern-3 +(deftest unintern.3 (progn (safely-delete-package "H") (prog1 @@ -65,7 +69,7 @@ t) ;; Simple unintern, package given as symbol -(deftest unintern-4 +(deftest unintern.4 (progn (safely-delete-package "H") (prog1 @@ -82,7 +86,7 @@ t) ;; Simple unintern, package given as character -(deftest unintern-5 +(deftest unintern.5 (handler-case (progn (safely-delete-package "H") @@ -105,7 +109,7 @@ ;; Unintern an external symbol that is also inherited -(deftest unintern-6 +(deftest unintern.6 (handler-case (progn (safely-delete-package "H") @@ -135,7 +139,7 @@ ;; unintern a symbol that is shadowing another symbol -(deftest unintern-7 +(deftest unintern.7 (block failed (safely-delete-package "H") (safely-delete-package "G") @@ -164,7 +168,7 @@ ;; Error situation: when the symbol is uninterned, creates ;; a name conflict from two used packages -(deftest unintern-8 +(deftest unintern.8 (block failed (safely-delete-package "H") (safely-delete-package "G1") @@ -200,7 +204,7 @@ ;; Now, inherit the same symbol through two intermediate ;; packages. No error should occur when the shadowing ;; is removed -(deftest unintern-9 +(deftest unintern.9 (block failed (safely-delete-package "H") (safely-delete-package "G1") diff --git a/ansi-tests/packages-13.lsp b/ansi-tests/packages-13.lsp index 82b82c299c6d2ef9c3ac80e4160bacfccea4c11d..4add73c782ec5d64dea25145f659aa76d32f357f 100644 --- a/ansi-tests/packages-13.lsp +++ b/ansi-tests/packages-13.lsp @@ -9,7 +9,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; in-package -(deftest in-package-1 +(deftest in-package.1 (let ((*package* *package*)) (declare (special *package*)) (let ((p2 (in-package "A"))) @@ -17,7 +17,7 @@ (eqt *package* p2)))) t) -(deftest in-package-2 +(deftest in-package.2 (let ((*package* *package*)) (declare (special *package*)) (let ((p2 (in-package |A|))) @@ -25,7 +25,7 @@ (eqt *package* p2)))) t) -(deftest in-package-3 +(deftest in-package.3 (let ((*package* *package*)) (declare (special *package*)) (let ((p2 (in-package :|A|))) @@ -33,7 +33,7 @@ (eqt *package* p2)))) t) -(deftest in-package-4 +(deftest in-package.4 (let ((*package* *package*)) (declare (special *package*)) (let ((p2 (in-package #\A))) @@ -41,7 +41,7 @@ (eqt *package* p2)))) t) -(deftest in-package-5 +(deftest in-package.5 (let ((*package* *package*)) (declare (special *package*)) (safely-delete-package "H") diff --git a/ansi-tests/packages-14.lsp b/ansi-tests/packages-14.lsp index fc89bebb40226692a012a23021c5193212865023..fe3a9b2a199d589ce2b6c22b1a05217bbd5f7868 100644 --- a/ansi-tests/packages-14.lsp +++ b/ansi-tests/packages-14.lsp @@ -10,24 +10,27 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; unuse-package -(deftest unuse-package-1 +(deftest unuse-package.1 (progn (safely-delete-package "H") (safely-delete-package "G") (let* ((pg (make-package "G" :use nil)) - (ph (make-package "H" :use '("G")))) + (ph (make-package "H" :use '("G"))) + (i 0) x y) (prog1 (and (equal (package-use-list ph) (list pg)) (equal (package-used-by-list pg) (list ph)) - (unuse-package pg ph) + (unuse-package (progn (setf x (incf i)) pg) + (progn (setf y (incf i)) ph)) + (eql i 2) (eql x 1) (eql y 2) (equal (package-use-list ph) nil) (null (package-used-by-list pg))) (safely-delete-package "H") (safely-delete-package "G")))) t) -(deftest unuse-package-2 +(deftest unuse-package.2 (progn (safely-delete-package "H") (safely-delete-package "G") @@ -44,7 +47,7 @@ (safely-delete-package "G")))) t) -(deftest unuse-package-3 +(deftest unuse-package.3 (progn (safely-delete-package "H") (safely-delete-package "G") @@ -61,7 +64,7 @@ (safely-delete-package "G")))) t) -(deftest unuse-package-4 +(deftest unuse-package.4 (progn (safely-delete-package "H") (safely-delete-package "G") @@ -78,7 +81,7 @@ (safely-delete-package "G")))) t) -(deftest unuse-package-5 +(deftest unuse-package.5 (progn (safely-delete-package "H") (safely-delete-package "G") @@ -95,7 +98,7 @@ (safely-delete-package "G")))) t) -(deftest unuse-package-6 +(deftest unuse-package.6 (progn (safely-delete-package "H") (safely-delete-package "G") @@ -112,7 +115,7 @@ (safely-delete-package "G")))) t) -(deftest unuse-package-7 +(deftest unuse-package.7 (progn (safely-delete-package "H") (safely-delete-package "G") @@ -129,7 +132,7 @@ (safely-delete-package "G")))) t) -(deftest unuse-package-8 +(deftest unuse-package.8 (progn (safely-delete-package "H") (safely-delete-package "G") @@ -148,7 +151,7 @@ ;; Now test with multiple packages -(deftest unuse-package-9 +(deftest unuse-package.9 (progn (dolist (p '("H1" "H2" "G1" "G2" "G3")) (safely-delete-package p)) diff --git a/ansi-tests/packages-15.lsp b/ansi-tests/packages-15.lsp index a0302e23b9a66a10fe75333827e07ce29abff199..c4d24a7fddcb99748a06e3639d468a79426cd996 100644 --- a/ansi-tests/packages-15.lsp +++ b/ansi-tests/packages-15.lsp @@ -9,20 +9,24 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; use-package -(deftest use-package-1 +(deftest use-package.1 (progn (safely-delete-package "H") (safely-delete-package "G") (let* ((pg (make-package "G" :use nil)) (ph (make-package "H" :use nil)) - (sym1 (intern "FOO" pg))) + (sym1 (intern "FOO" pg)) + (i 0) x y) (and (eqt (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)) - (eqt (use-package pg ph) t) ;; "H" will use "G" + (eqt (use-package (progn (setf x (incf i)) pg) + (progn (setf y (incf i)) ph)) + t) ;; "H" will use "G" + (eql i 2) (eql x 1) (eql y 2) (multiple-value-bind (sym2 access) (find-symbol "FOO" ph) (and @@ -36,7 +40,7 @@ (null (find-symbol "FOO" ph))))) t) -(deftest use-package-2 +(deftest use-package.2 (progn (safely-delete-package "H") (safely-delete-package "G") @@ -63,7 +67,7 @@ (null (find-symbol "FOO" ph))))) t) -(deftest use-package-3 +(deftest use-package.3 (progn (safely-delete-package "H") (safely-delete-package "G") @@ -90,7 +94,7 @@ (null (find-symbol "FOO" ph))))) t) -(deftest use-package-4 +(deftest use-package.4 (progn (safely-delete-package "H") (safely-delete-package "G") @@ -120,7 +124,7 @@ ;; use lists of packages -(deftest use-package-5 +(deftest use-package.5 (let ((pkgs '("H" "G1" "G2" "G3")) (vars '("FOO1" "FOO2" "FOO3"))) (dolist (p pkgs) @@ -152,7 +156,7 @@ ;; Circular package use -(deftest use-package-6 +(deftest use-package.6 (progn (safely-delete-package "H") (safely-delete-package "G") diff --git a/ansi-tests/packages-16.lsp b/ansi-tests/packages-16.lsp index c893898f08947704c4a8ae2d07f47c72fcc4c142..44a052a6d5217ed3d90539528fca471eae83e000 100644 --- a/ansi-tests/packages-16.lsp +++ b/ansi-tests/packages-16.lsp @@ -13,7 +13,7 @@ ;; The use-list is implementation dependent, so ;; we don't examine it here. ;; Try several ways of specifying the package name. -(deftest defpackage-1 +(deftest defpackage.1 (loop for n in '("H" #:|H| #\H) count (not @@ -34,7 +34,7 @@ ;; Test :nicknames option ;; Do not check use-list, because it is implementation dependent ;; Try several ways of specifying a nickname. -(deftest defpackage-2 +(deftest defpackage.2 (loop for n in '("I" #:|I| #\I) count (not @@ -58,7 +58,7 @@ ;; Test defpackage with documentation option ;; Do not check use-list, because it is implementation dependent -(deftest defpackage-3 +(deftest defpackage.3 (progn (safely-delete-package "H") (ignore-errors @@ -81,7 +81,7 @@ ;; Check use argument ;; Try several ways of specifying the package to be used -(deftest defpackage-4 +(deftest defpackage.4 (loop for n in '("A" :|A| #\A) count (not @@ -103,7 +103,7 @@ 0) ;; Test defpackage shadow option, and null use -(deftest defpackage-5 +(deftest defpackage.5 (progn (safely-delete-package "H") (ignore-errors @@ -131,7 +131,7 @@ ;; Test defpackage shadow and null use, with several ways ;; of specifying the name of the shadowed symbol -(deftest defpackage-6 +(deftest defpackage.6 (loop for s in '(:|f| #\f) collect @@ -164,7 +164,7 @@ ;; Testing defpackage with shadowing-import-from. ;; Test several ways of specifying the symbol name -(deftest defpackage-7 +(deftest defpackage.7 (progn (safely-delete-package "H") (safely-delete-package "G") @@ -211,7 +211,7 @@ ;; 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 +(deftest defpackage.8 (progn (safely-delete-package "H") (safely-delete-package "G") @@ -256,7 +256,7 @@ ;; Test defpackage with export option -(deftest defpackage-9 +(deftest defpackage.9 (progn (loop for n in '("Z" #:|Z| #\Z) @@ -292,7 +292,7 @@ ;; Test defpackage with the intern option -(deftest defpackage-10 +(deftest defpackage.10 (progn (loop for n in '("Z" #:|Z| #\Z) @@ -328,7 +328,7 @@ ;; Test defpackage with size -(deftest defpackage-11 +(deftest defpackage.11 (ignore-errors (safely-delete-package "H") (let ((p (ignore-errors @@ -345,7 +345,7 @@ (zerop (num-symbols-in-package p)))))) (t t t t t t t)) -(deftest defpackage-12 +(deftest defpackage.12 (ignore-errors (safely-delete-package "H") (let ((p (ignore-errors @@ -365,7 +365,7 @@ ;; defpackage error handling ;; Repeated size field should cause a program-error -(deftest defpackage-13 +(deftest defpackage.13 (progn (safely-delete-package "H") (classify-error @@ -373,7 +373,7 @@ program-error) ;; Repeated documentation field should cause a program-error -(deftest defpackage-14 +(deftest defpackage.14 (progn (safely-delete-package "H") (classify-error @@ -385,7 +385,7 @@ ;; When a nickname refers to an existing package or nickname, ;; signal a package-error -(deftest defpackage-15 +(deftest defpackage.15 (progn (safely-delete-package "H") (classify-error @@ -393,7 +393,7 @@ (:nicknames "A"))))) package-error) -(deftest defpackage-16 +(deftest defpackage.16 (progn (safely-delete-package "H") (classify-error @@ -405,7 +405,7 @@ ;; must be disjoint, or a package-error is signalled. ;; :shadow and :shadowing-import-from -(deftest defpackage-17 +(deftest defpackage.17 (progn (safely-delete-package "H") (safely-delete-package "G") @@ -417,7 +417,7 @@ program-error) ;; :shadow and :import-from -(deftest defpackage-18 +(deftest defpackage.18 (progn (safely-delete-package "H") (safely-delete-package "G") @@ -429,7 +429,7 @@ program-error) ;; :shadow and :intern -(deftest defpackage-19 +(deftest defpackage.19 (progn (safely-delete-package "H") (classify-error @@ -439,7 +439,7 @@ program-error) ;; :shadowing-import-from and :import-from -(deftest defpackage-20 +(deftest defpackage.20 (progn (safely-delete-package "H") (safely-delete-package "G") @@ -451,7 +451,7 @@ program-error) ;; :shadowing-import-from and :intern -(deftest defpackage-21 +(deftest defpackage.21 (progn (safely-delete-package "H") (safely-delete-package "G") @@ -463,7 +463,7 @@ program-error) ;; :import-from and :intern -(deftest defpackage-22 +(deftest defpackage.22 (progn (safely-delete-package "H") (safely-delete-package "G") @@ -476,7 +476,7 @@ ;; Names given to :export and :intern must be disjoint, ;; otherwise signal a program-error -(deftest defpackage-23 +(deftest defpackage.23 (progn (safely-delete-package "H") (classify-error @@ -487,7 +487,7 @@ ;; :shadowing-import-from signals a correctable package-error ;; if the symbol is not accessible in the named package -(deftest defpackage-24 +(deftest defpackage.24 (progn (safely-delete-package "H") (safely-delete-package "G") @@ -500,7 +500,7 @@ ;; :import-from signals a correctable package-error if a symbol with ;; the indicated name is not accessible in the package indicated -(deftest defpackage-25 +(deftest defpackage.25 (progn (safely-delete-package "H") (safely-delete-package "G") @@ -511,7 +511,7 @@ ;; A big test that combines all the options to defpackage -(deftest defpackage-26 +(deftest defpackage.26 (ignore-errors (flet ((%do-it% diff --git a/ansi-tests/packages-17.lsp b/ansi-tests/packages-17.lsp index 677c7579f37746c5aec995134e6a41646d1fbc4e..d855017d241bff21c062971652dad50e674b7cd5 100644 --- a/ansi-tests/packages-17.lsp +++ b/ansi-tests/packages-17.lsp @@ -6,7 +6,7 @@ (in-package :cl-test) (declaim (optimize (safety 3))) -(deftest do-symbols-1 +(deftest do-symbols.1 (equalt (remove-duplicates (sort-symbols (let ((all nil)) @@ -31,19 +31,19 @@ (let ((all nil)) (do-external-symbols (x pkg all) (push x all)))))) -(deftest do-symbols-2 +(deftest do-symbols.2 (collect-symbols "DS1") (DS1:A DS1:B DS1::C DS1::D)) -(deftest do-symbols-3 +(deftest do-symbols.3 (collect-symbols "DS2") (DS2:A DS2::E DS2::F DS2:G DS2:H)) -(deftest do-symbols-4 +(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 +(deftest do-symbols.5 (remove-duplicates (collect-symbols "DS4") :test #'(lambda (x y) @@ -52,23 +52,23 @@ (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 +(deftest do-external-symbols.1 (collect-external-symbols "DS1") (DS1:A DS1:B)) -(deftest do-external-symbols-2 +(deftest do-external-symbols.2 (collect-external-symbols "DS2") (DS2:A DS2:G DS2:H)) -(deftest do-external-symbols-3 +(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 +(deftest do-external-symbols.4 (collect-external-symbols "DS4") ()) -(deftest do-external-symbols-5 +(deftest do-external-symbols.5 (equalt (collect-external-symbols "KEYWORD") (collect-symbols "KEYWORD")) t) @@ -76,18 +76,18 @@ ;; Test that do-symbols, do-external-symbols work without ;; a return value (and that the default return value is nil) -(deftest do-symbols-6 +(deftest do-symbols.6 (do-symbols (s "DS1") (declare (ignore s)) t) nil) -(deftest do-external-symbols-6 +(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 +(deftest do-symbols.7 (let ((x nil) (*package* (find-package "DS1"))) (declare (special *package*)) @@ -96,7 +96,7 @@ (sort-symbols x))) (nil (DS1:A DS1:B DS1::C DS1::D))) -(deftest do-external-symbols-7 +(deftest do-external-symbols.7 (let ((x nil) (*package* (find-package "DS1"))) (declare (special *package*)) @@ -108,7 +108,7 @@ ;; Test that the tags work in the tagbody, ;; and that multiple statements work -(deftest do-symbols-8 +(deftest do-symbols.8 (handler-case (let ((x nil)) (list @@ -124,7 +124,7 @@ (error (c) c)) (NIL (DS1:A DS1:B DS1::D T))) -(deftest do-external-symbols-8 +(deftest do-external-symbols.8 (handler-case (let ((x nil)) (list diff --git a/ansi-tests/packages-18.lsp b/ansi-tests/packages-18.lsp index 6afc6cdecdab4575aafdcb483931e896c34b5887..2fd03b2b4c78fa1177320c239cb148ad05a8ca08 100644 --- a/ansi-tests/packages-18.lsp +++ b/ansi-tests/packages-18.lsp @@ -11,7 +11,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; packagep, typep * 'package -(deftest packagep-1 +(deftest packagep.1 (loop for x in *universe* count (unless (eqt (not (packagep x)) @@ -22,9 +22,9 @@ t)) 0) -;; *package* is always a package +;;; *package* is always a package -(deftest packagep-2 +(deftest packagep.2 (not-mv (packagep *package*)) nil) @@ -39,24 +39,24 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; package-error -(deftest package-error-1 +(deftest package-error.1 (not (typep (make-condition 'package-error :package "CL") 'package-error)) nil) -(deftest package-error-2 +(deftest package-error.2 (not (typep (make-condition 'package-error :package (find-package "CL")) 'package-error)) nil) -(deftest package-error-3 +(deftest package-error.3 (subtypep* 'package-error 'error) t t) -(deftest package-error-4 +(deftest package-error.4 (not (typep (make-condition 'package-error :package (find-package '#:|CL|)) @@ -66,40 +66,32 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; package-error-package -(deftest package-error-package-1 - (handler-case - (eqt (find-package (package-error-package - (make-condition 'package-error - :package "CL"))) - (find-package "CL")) - (error (c) c)) +(deftest package-error-package.1 + (eqt (find-package (package-error-package + (make-condition 'package-error + :package "CL"))) + (find-package "CL")) t) -(deftest package-error-package-2 - (handler-case - (eqt (find-package (package-error-package - (make-condition 'package-error - :package (find-package "CL")))) - (find-package "CL")) - (error (c) c)) +(deftest package-error-package.2 + (eqt (find-package (package-error-package + (make-condition 'package-error + :package (find-package "CL")))) + (find-package "CL")) t) -(deftest package-error-package-3 - (handler-case - (eqt (find-package (package-error-package - (make-condition 'package-error - :package '#:|CL|))) - (find-package "CL")) - (error (c) c)) +(deftest package-error-package.3 + (eqt (find-package (package-error-package + (make-condition 'package-error + :package '#:|CL|))) + (find-package "CL")) t) -(deftest package-error-package-4 - (handler-case - (eqt (find-package (package-error-package - (make-condition 'package-error - :package #\A))) - (find-package "A")) - (error (c) c)) +(deftest package-error-package.4 + (eqt (find-package (package-error-package + (make-condition 'package-error + :package #\A))) + (find-package "A")) t) (deftest package-error-package.error.1 diff --git a/ansi-tests/packages-19.lsp b/ansi-tests/packages-19.lsp index 6001db4646c811a004e579eef46d122ab1bb05fa..be4b3b721a1197cfe4468d1430e6c92a061bdf0a 100644 --- a/ansi-tests/packages-19.lsp +++ b/ansi-tests/packages-19.lsp @@ -9,27 +9,27 @@ ;; Check that each keyword satisfies keywordp -(deftest keyword-1 - (do-symbols (s "KEYWORD" t) - (unless (keywordp s) - (return (list s nil)))) +(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 (eqt s s2) - (eqt access :external)) - (return (list s2 access))))) +(deftest keyword.2 + (do-symbols (s "KEYWORD" t) + (multiple-value-bind (s2 access) + (find-symbol (symbol-name s) "KEYWORD") + (unless (and (eqt s s2) + (eqt access :external)) + (return (list s2 access))))) t) ;; Every keyword evaluates to itself -(deftest keyword-3 - (do-symbols (s "KEYWORD" t) - (unless (eqt s (eval s)) - (return (list s (eval s))))) +(deftest keyword.3 + (do-symbols (s "KEYWORD" t) + (unless (eqt 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 index 53a8416d98dc63e7a7bc99ef5cd1b3303984a725..e44ab6a6f0dbe28aa16a59ba721ce0a71a759c80 100644 --- a/ansi-tests/position-if-not.lsp +++ b/ansi-tests/position-if-not.lsp @@ -444,6 +444,32 @@ (position-if-not (complement #'digit-char-p) a :from-end t)))) nil 0 nil 4) +(deftest position-if-not.order.1 + (let ((i 0) a b c d e f) + (values + (position-if-not + (progn (setf a (incf i)) (complement #'zerop)) + (progn (setf b (incf i)) '(3 1 8 2 1 2 3 4)) + :from-end (setf c (incf i)) + :start (progn (setf d (incf i)) 1) + :end (progn (setf e (incf i)) 6) + :key (progn (setf f (incf i)) #'1-)) + i a b c d e f)) + 4 6 1 2 3 4 5 6) + +(deftest position-if-not.order.2 + (let ((i 0) a b c d e f) + (values + (position-if-not + (progn (setf a (incf i)) (complement #'zerop)) + (progn (setf b (incf i)) '(3 1 8 2 1 2 3 4)) + :key (progn (setf c (incf i)) #'1-) + :end (progn (setf d (incf i)) 6) + :start (progn (setf e (incf i)) 1) + :from-end (setf f (incf i))) + i a b c d e f)) + 4 6 1 2 3 4 5 6) + ;;; Keyword tests (deftest position-if-not.allow-other-keys.1 diff --git a/ansi-tests/position-if.lsp b/ansi-tests/position-if.lsp index 35477db0cad9cf45e398929bf2126ccd43f21d05..4d590f616803050db543673b03dd25e33d49dc7f 100644 --- a/ansi-tests/position-if.lsp +++ b/ansi-tests/position-if.lsp @@ -441,6 +441,32 @@ (position-if #'%g a :from-end 'foo)))) nil nil 0 4) +(deftest position-if.order.1 + (let ((i 0) a b c d e f) + (values + (position-if + (progn (setf a (incf i)) #'zerop) + (progn (setf b (incf i)) '(3 1 8 2 1 2 3 4)) + :from-end (setf c (incf i)) + :start (progn (setf d (incf i)) 1) + :end (progn (setf e (incf i)) 6) + :key (progn (setf f (incf i)) #'1-)) + i a b c d e f)) + 4 6 1 2 3 4 5 6) + +(deftest position-if.order.2 + (let ((i 0) a b c d e f) + (values + (position-if + (progn (setf a (incf i)) #'zerop) + (progn (setf b (incf i)) '(3 1 8 2 1 2 3 4)) + :key (progn (setf c (incf i)) #'1-) + :end (progn (setf d (incf i)) 6) + :start (progn (setf e (incf i)) 1) + :from-end (setf f (incf i))) + i a b c d e f)) + 4 6 1 2 3 4 5 6) + ;;; Keyword tests (deftest position-if.allow-other-keys.1 diff --git a/ansi-tests/position.lsp b/ansi-tests/position.lsp index ec35078c6af536b7874b933de4cdee5a62d336ac..8e3b9a44090c96599f9d0f7f1ae000976e5ca514 100644 --- a/ansi-tests/position.lsp +++ b/ansi-tests/position.lsp @@ -638,6 +638,36 @@ :from-end t) 4) +(deftest position.order.1 + (let ((i 0) a b c d e f g) + (values + (position + (progn (setf a (incf i)) 0) + (progn (setf b (incf i)) '(3 1 8 2 1 2 3 4)) + :from-end (setf c (incf i)) + :start (progn (setf d (incf i)) 1) + :end (progn (setf e (incf i)) 6) + :key (progn (setf f (incf i)) #'1-) + :test (progn (setf g (incf i)) #'=) + ) + i a b c d e f g)) + 4 7 1 2 3 4 5 6 7) + +(deftest position.order.2 + (let ((i 0) a b c d e f g) + (values + (position + (progn (setf a (incf i)) 0) + (progn (setf b (incf i)) '(3 1 8 2 1 2 3 4)) + :test-not (progn (setf c (incf i)) #'/=) + :key (progn (setf d (incf i)) #'1-) + :end (progn (setf e (incf i)) 6) + :start (progn (setf f (incf i)) 1) + :from-end (setf g (incf i)) + ) + i a b c d e f g)) + 4 7 1 2 3 4 5 6 7) + ;;; Keyword tests (deftest position.allow-other-keys.1 diff --git a/ansi-tests/reduce.lsp b/ansi-tests/reduce.lsp index 556b6cb82798d00b7f16f655d73063e2ea75142d..d0a2a0b8e46fbff692b062be1f9d22122b5695a6 100644 --- a/ansi-tests/reduce.lsp +++ b/ansi-tests/reduce.lsp @@ -376,6 +376,45 @@ (reduce #'+ s :start 2 :end 4)) 2) +;;; Order of evaluation tests + +(deftest reduce.order.1 + (let ((i 0) x y) + (values + (reduce (progn (setf x (incf i)) #'cons) + (progn (setf y (incf i)) '(a b c))) + i x y)) + ((a . b) . c) 2 1 2) + +(deftest reduce.order.2 + (let ((i 0) a b c d e f g) + (values + (reduce (progn (setf a (incf i)) #'cons) + (progn (setf b (incf i)) '(a b c d e f)) + :from-end (progn (setf c (incf i)) t) + :initial-value (progn (setf d (incf i)) 'nil) + :start (progn (setf e (incf i)) 1) + :end (progn (setf f (incf i)) 4) + :key (progn (setf g (incf i)) #'identity) + ) + i a b c d e f g)) + (b c d) 7 1 2 3 4 5 6 7) + +(deftest reduce.order.3 + (let ((i 0) a b c d e f g) + (values + (reduce (progn (setf a (incf i)) #'cons) + (progn (setf b (incf i)) '(a b c d e f)) + :key (progn (setf c (incf i)) #'identity) + :end (progn (setf d (incf i)) 4) + :start (progn (setf e (incf i)) 1) + :initial-value (progn (setf f (incf i)) 'nil) + :from-end (progn (setf g (incf i)) t) + ) + i a b c d e f g)) + (b c d) 7 1 2 3 4 5 6 7) + + ;;; Keyword tests (deftest reduce.allow-other-keys.1 diff --git a/ansi-tests/remove-duplicates.lsp b/ansi-tests/remove-duplicates.lsp index 3937073fdda763c2bd9ef4f249435743cbcebeff..e75653e686077b28676389c7ec8c46f10ce15d1a 100644 --- a/ansi-tests/remove-duplicates.lsp +++ b/ansi-tests/remove-duplicates.lsp @@ -31,6 +31,38 @@ y) (3 4 1 5 6 2 7)) + +;;; Order of evaluation tests + +(deftest remove-duplicates.order.1 + (let ((i 0) a b c d e f) + (values + (remove-duplicates + (progn (setf a (incf i)) (list 1 2 3 1 3 1 2 4)) + :from-end (progn (setf b (incf i)) nil) + :start (progn (setf c (incf i)) 0) + :end (progn (setf d (incf i)) nil) + :key (progn (setf e (incf i)) #'identity) + :test (progn (setf f (incf i)) #'=) + ) + i a b c d e f)) + (3 1 2 4) 6 1 2 3 4 5 6) + +(deftest remove-duplicates.order.2 + (let ((i 0) a b c d e f) + (values + (remove-duplicates + (progn (setf a (incf i)) (list 1 2 3 1 3 1 2 4)) + :test-not (progn (setf b (incf i)) #'/=) + :key (progn (setf c (incf i)) #'identity) + :end (progn (setf d (incf i)) nil) + :start (progn (setf e (incf i)) 0) + :from-end (progn (setf f (incf i)) nil) + ) + i a b c d e f)) + (3 1 2 4) 6 1 2 3 4 5 6) + + ;;; Keyword tests (deftest remove-duplicates.allow-other-keys.1 @@ -114,6 +146,36 @@ (delete-duplicates (list 1 2 3 4 2 7 8 1 5) :from-end t :from-end nil) (1 2 3 4 7 8 5)) +;;; Order of evaluation tests + +(deftest delete-duplicates.order.1 + (let ((i 0) a b c d e f) + (values + (delete-duplicates + (progn (setf a (incf i)) (list 1 2 3 1 3 1 2 4)) + :from-end (progn (setf b (incf i)) nil) + :start (progn (setf c (incf i)) 0) + :end (progn (setf d (incf i)) nil) + :key (progn (setf e (incf i)) #'identity) + :test (progn (setf f (incf i)) #'=) + ) + i a b c d e f)) + (3 1 2 4) 6 1 2 3 4 5 6) + +(deftest delete-duplicates.order.2 + (let ((i 0) a b c d e f) + (values + (delete-duplicates + (progn (setf a (incf i)) (list 1 2 3 1 3 1 2 4)) + :test-not (progn (setf b (incf i)) #'/=) + :key (progn (setf c (incf i)) #'identity) + :end (progn (setf d (incf i)) nil) + :start (progn (setf e (incf i)) 0) + :from-end (progn (setf f (incf i)) nil) + ) + i a b c d e f)) + (3 1 2 4) 6 1 2 3 4 5 6) + ;;; Error cases (deftest remove-duplicates.error.1 diff --git a/ansi-tests/remove.lsp b/ansi-tests/remove.lsp index 04743db216210cbc2b63cd9d953205f2aa37dac8..38fbdd445caeb77d60911f118f20cb6fdce3df44 100644 --- a/ansi-tests/remove.lsp +++ b/ansi-tests/remove.lsp @@ -366,6 +366,185 @@ (delete 0 (copy-seq #*11111) :count -1) #*11111) +;;; Order of evaluation tests + +(deftest remove.order.1 + (let ((i 0) a b c d e f g h) + (values + (remove + (progn (setf a (incf i)) 'a) + (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) + :from-end (progn (setf c (incf i)) t) + :count (progn (setf d (incf i)) 1) + :key (progn (setf e (incf i)) #'identity) + :test (progn (setf f (incf i)) #'eq) + :start (progn (setf g (incf i)) 0) + :end (progn (setf h (incf i)) nil)) + i a b c d e f g h)) + (a b c d f) 8 1 2 3 4 5 6 7 8) + +(deftest remove.order.2 + (let ((i 0) a b c d e f g h) + (values + (remove + (progn (setf a (incf i)) 'a) + (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) + :end (progn (setf c (incf i)) nil) + :start (progn (setf d (incf i)) 0) + :test-not (progn (setf e (incf i)) (complement #'eq)) + :key (progn (setf f (incf i)) #'identity) + :count (progn (setf g (incf i)) 1) + :from-end (progn (setf h (incf i)) t) + ) + i a b c d e f g h)) + (a b c d f) 8 1 2 3 4 5 6 7 8) + +(deftest delete.order.1 + (let ((i 0) a b c d e f g h) + (values + (delete + (progn (setf a (incf i)) 'a) + (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) + :from-end (progn (setf c (incf i)) t) + :count (progn (setf d (incf i)) 1) + :key (progn (setf e (incf i)) #'identity) + :test (progn (setf f (incf i)) #'eq) + :start (progn (setf g (incf i)) 0) + :end (progn (setf h (incf i)) nil)) + i a b c d e f g h)) + (a b c d f) 8 1 2 3 4 5 6 7 8) + +(deftest delete.order.2 + (let ((i 0) a b c d e f g h) + (values + (delete + (progn (setf a (incf i)) 'a) + (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) + :end (progn (setf c (incf i)) nil) + :start (progn (setf d (incf i)) 0) + :test-not (progn (setf e (incf i)) (complement #'eq)) + :key (progn (setf f (incf i)) #'identity) + :count (progn (setf g (incf i)) 1) + :from-end (progn (setf h (incf i)) t) + ) + i a b c d e f g h)) + (a b c d f) 8 1 2 3 4 5 6 7 8) + +(deftest remove-if.order.1 + (let ((i 0) a b c d e f g) + (values + (remove-if + (progn (setf a (incf i)) #'(lambda (x) (eq x 'a))) + (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) + :from-end (progn (setf c (incf i)) t) + :count (progn (setf d (incf i)) 1) + :key (progn (setf e (incf i)) #'identity) + :start (progn (setf f (incf i)) 0) + :end (progn (setf g (incf i)) nil)) + i a b c d e f g)) + (a b c d f) 7 1 2 3 4 5 6 7) + +(deftest remove-if.order.2 + (let ((i 0) a b c d e f g) + (values + (remove-if + (progn (setf a (incf i)) #'(lambda (x) (eq x 'a))) + (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) + :end (progn (setf c (incf i)) nil) + :start (progn (setf d (incf i)) 0) + :key (progn (setf e (incf i)) #'identity) + :count (progn (setf f (incf i)) 1) + :from-end (progn (setf g (incf i)) t) + ) + i a b c d e f g)) + (a b c d f) 7 1 2 3 4 5 6 7) + +(deftest delete-if.order.1 + (let ((i 0) a b c d e f g) + (values + (delete-if + (progn (setf a (incf i)) #'(lambda (x) (eq x 'a))) + (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) + :from-end (progn (setf c (incf i)) t) + :count (progn (setf d (incf i)) 1) + :key (progn (setf e (incf i)) #'identity) + :start (progn (setf f (incf i)) 0) + :end (progn (setf g (incf i)) nil)) + i a b c d e f g)) + (a b c d f) 7 1 2 3 4 5 6 7) + +(deftest delete-if.order.2 + (let ((i 0) a b c d e f g) + (values + (delete-if + (progn (setf a (incf i)) #'(lambda (x) (eq x 'a))) + (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) + :end (progn (setf c (incf i)) nil) + :start (progn (setf d (incf i)) 0) + :key (progn (setf e (incf i)) #'identity) + :count (progn (setf f (incf i)) 1) + :from-end (progn (setf g (incf i)) t) + ) + i a b c d e f g)) + (a b c d f) 7 1 2 3 4 5 6 7) + +(deftest remove-if-not.order.1 + (let ((i 0) a b c d e f g) + (values + (remove-if-not + (progn (setf a (incf i)) #'(lambda (x) (not (eq x 'a)))) + (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) + :from-end (progn (setf c (incf i)) t) + :count (progn (setf d (incf i)) 1) + :key (progn (setf e (incf i)) #'identity) + :start (progn (setf f (incf i)) 0) + :end (progn (setf g (incf i)) nil)) + i a b c d e f g)) + (a b c d f) 7 1 2 3 4 5 6 7) + +(deftest remove-if-not.order.2 + (let ((i 0) a b c d e f g) + (values + (remove-if-not + (progn (setf a (incf i)) #'(lambda (x) (not (eq x 'a)))) + (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) + :end (progn (setf c (incf i)) nil) + :start (progn (setf d (incf i)) 0) + :key (progn (setf e (incf i)) #'identity) + :count (progn (setf f (incf i)) 1) + :from-end (progn (setf g (incf i)) t) + ) + i a b c d e f g)) + (a b c d f) 7 1 2 3 4 5 6 7) + +(deftest delete-if-not.order.1 + (let ((i 0) a b c d e f g) + (values + (delete-if-not + (progn (setf a (incf i)) #'(lambda (x) (not (eq x 'a)))) + (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) + :from-end (progn (setf c (incf i)) t) + :count (progn (setf d (incf i)) 1) + :key (progn (setf e (incf i)) #'identity) + :start (progn (setf f (incf i)) 0) + :end (progn (setf g (incf i)) nil)) + i a b c d e f g)) + (a b c d f) 7 1 2 3 4 5 6 7) + +(deftest delete-if-not.order.2 + (let ((i 0) a b c d e f g) + (values + (delete-if-not + (progn (setf a (incf i)) #'(lambda (x) (not (eq x 'a)))) + (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) + :end (progn (setf c (incf i)) nil) + :start (progn (setf d (incf i)) 0) + :key (progn (setf e (incf i)) #'identity) + :count (progn (setf f (incf i)) 1) + :from-end (progn (setf g (incf i)) t) + ) + i a b c d e f g)) + (a b c d f) 7 1 2 3 4 5 6 7) ;;; Randomized tests diff --git a/ansi-tests/replace.lsp b/ansi-tests/replace.lsp index 6f582419b656b0a391c4b9120c71e558ed22706c..310db8914eed4ffc5e6e4cf007e5a39956ac4905 100644 --- a/ansi-tests/replace.lsp +++ b/ansi-tests/replace.lsp @@ -586,6 +586,42 @@ t "aabcef") +;;; Order of evaluation tests + +(deftest replace.order.1 + (let ((i 0) a b) + (values + (replace (progn (setf a (incf i)) (list 'a 'b 'c)) + (progn (setf b (incf i)) (list 'e 'f))) + i a b)) + (e f c) 2 1 2) + +(deftest replace.order.2 + (let ((i 0) a b c d e f) + (values + (replace (progn (setf a (incf i)) (list 'a 'b 'c)) + (progn (setf b (incf i)) (list 'e 'f)) + :start1 (progn (setf c (incf i)) 1) + :end1 (progn (setf d (incf i)) 3) + :start2 (progn (setf e (incf i)) 0) + :end2 (progn (setf f (incf i)) 2) + ) + i a b c d e f)) + (a e f) 6 1 2 3 4 5 6) + +(deftest replace.order.3 + (let ((i 0) a b c d e f) + (values + (replace (progn (setf a (incf i)) (list 'a 'b 'c)) + (progn (setf b (incf i)) (list 'e 'f)) + :end2 (progn (setf c (incf i)) 2) + :start2 (progn (setf d (incf i)) 0) + :end1 (progn (setf e (incf i)) 3) + :start1 (progn (setf f (incf i)) 1) + ) + i a b c d e f)) + (a e f) 6 1 2 3 4 5 6) + ;;; Keyword tests (deftest replace.allow-other-keys.1 diff --git a/ansi-tests/row-major-aref.lsp b/ansi-tests/row-major-aref.lsp index fa685721c46eaa4833b533ef57015ab729745a53..48d4d3e4c0c9d4dadf89a37e0e02c725a218135c 100644 --- a/ansi-tests/row-major-aref.lsp +++ b/ansi-tests/row-major-aref.lsp @@ -84,6 +84,26 @@ (loop for i from 0 to 23 collect (row-major-aref a i))) (a b c d e f g h i j k l m n o p q r s t u v w x)) +(deftest row-major-aref.order.1 + (let ((i 0) x y) + (values + (row-major-aref + (progn (setf x (incf i)) #(a b c d e f)) + (progn (setf y (incf i)) 2)) + i x y)) + c 2 1 2) + +(deftest row-major-aref.order.2 + (let ((i 0) x y z + (a (copy-seq #(a b c d e f)))) + (values + (setf + (row-major-aref + (progn (setf x (incf i)) a) + (progn (setf y (incf i)) 2)) + (progn (setf z (incf i)) 'w)) + a i x y z)) + w #(a b w d e f) 3 1 2 3) ;;; Error tests diff --git a/ansi-tests/sbit.lsp b/ansi-tests/sbit.lsp index 27c4cfa6e1a44a6bb8d2e25cb8eed9e4ca3f5fd5..f657f59f0b3a586686e9363e0c7f4b575a433896 100644 --- a/ansi-tests/sbit.lsp +++ b/ansi-tests/sbit.lsp @@ -68,3 +68,28 @@ (aref a 5 5) (sbit a 5 5))) 0 0 1 1 1) + +(deftest sbit.order.1 + (let ((i 0) a b) + (values + (sbit (progn (setf a (incf i)) #*001001) + (progn (setf b (incf i)) 1)) + i a b)) + 0 2 1 2) + +(deftest sbit.order.2 + (let ((i 0) a b c + (v (copy-seq #*001001))) + (values + (setf (sbit (progn (setf a (incf i)) v) + (progn (setf b (incf i)) 1)) + (progn (setf c (incf i)) 1)) + v i a b c)) + 1 #*011001 3 1 2 3) + +(deftest sbit.error.1 + (classify-error (sbit)) + program-error) + + + \ No newline at end of file diff --git a/ansi-tests/search-list.lsp b/ansi-tests/search-list.lsp index 7cb5cc24627753cac3fb38dd5a93fc6b9f292d90..a0cd66e19d967ce8003e7073a8737d76d32f2f20 100644 --- a/ansi-tests/search-list.lsp +++ b/ansi-tests/search-list.lsp @@ -198,4 +198,38 @@ (classify-error (search "a" "a" 1 2)) program-error) - +;;; Order of evaluation + +(deftest search.order.1 + (let ((i 0) a b c d e f g h j) + (values + (search + (progn (setf a (incf i)) '(nil a b nil)) + (progn (setf b (incf i)) '(z z z a a b b z z z)) + :from-end (progn (setf c (incf i)) t) + :start1 (progn (setf d (incf i)) 1) + :end1 (progn (setf e (incf i)) 3) + :start2 (progn (setf f (incf i)) 1) + :end2 (progn (setf g (incf i)) 8) + :key (progn (setf h (incf i)) #'identity) + :test (progn (setf j (incf i)) #'eq) + ) + i a b c d e f g h j)) + 4 9 1 2 3 4 5 6 7 8 9) + +(deftest search.order.2 + (let ((i 0) a b c d e f g h j) + (values + (search + (progn (setf a (incf i)) '(nil a b nil)) + (progn (setf b (incf i)) '(z z z a a b b z z z)) + :test-not (progn (setf c (incf i)) (complement #'eq)) + :key (progn (setf d (incf i)) #'identity) + :end2 (progn (setf e (incf i)) 8) + :start2 (progn (setf f (incf i)) 1) + :end1 (progn (setf g (incf i)) 3) + :start1 (progn (setf h (incf i)) 1) + :from-end (progn (setf j (incf i)) t) + ) + i a b c d e f g h j)) + 4 9 1 2 3 4 5 6 7 8 9) \ No newline at end of file diff --git a/ansi-tests/some.lsp b/ansi-tests/some.lsp index 70119996206ea1ec43939b1ff19fdbdae503076a..d1a7517a9bca82b0ccb220171c6d77c35c4e4e8a 100644 --- a/ansi-tests/some.lsp +++ b/ansi-tests/some.lsp @@ -78,6 +78,23 @@ (not-mv (some 'null '(1 2 3 nil 5))) nil) +(deftest some.order.1 + (let ((i 0) x y) + (values + (some (progn (setf x (incf i)) #'null) + (progn (setf y (incf i)) '(a b c d))) + i x y)) + nil 2 1 2) + +(deftest some.order.2 + (let ((i 0) x y z) + (values + (some (progn (setf x (incf i)) #'eq) + (progn (setf y (incf i)) '(a b c d)) + (progn (setf z (incf i)) '(e f g h))) + i x y z)) + nil 3 1 2 3) + (deftest some.error.1 (classify-error (some 1 '(a b c))) diff --git a/ansi-tests/sort.lsp b/ansi-tests/sort.lsp index d96dd476f4d225f0d9220233d00424d8df93d761..f4d7fb109380dc0cea7d76280288a328cba9d349 100644 --- a/ansi-tests/sort.lsp +++ b/ansi-tests/sort.lsp @@ -80,6 +80,26 @@ (sort a #'char<)) "00111") +;;; Order of evaluation tests + +(deftest sort.order.1 + (let ((i 0) x y) + (values + (sort (progn (setf x (incf i)) (list 1 7 3 2)) + (progn (setf y (incf i)) #'<)) + i x y)) + (1 2 3 7) 2 1 2) + +(deftest sort.order.2 + (let ((i 0) x y z) + (values + (sort (progn (setf x (incf i)) (list 1 7 3 2)) + (progn (setf y (incf i)) #'<) + :key (progn (setf z (incf i)) #'-)) + i x y z)) + (7 3 2 1) 3 1 2 3) + + ;;; Error cases (deftest sort.error.1 diff --git a/ansi-tests/stable-sort.lsp b/ansi-tests/stable-sort.lsp index 81668bc61042691d885fa8e1a47e4c0524b10f01..cbf79d847a8a02b3a11e8a654218e4b2e0a7bf48 100644 --- a/ansi-tests/stable-sort.lsp +++ b/ansi-tests/stable-sort.lsp @@ -91,6 +91,26 @@ (stable-sort a #'char<)) "00111") +;;; Order of evaluation tests + +(deftest stable-sort.order.1 + (let ((i 0) x y) + (values + (stable-sort (progn (setf x (incf i)) (list 1 7 3 2)) + (progn (setf y (incf i)) #'<)) + i x y)) + (1 2 3 7) 2 1 2) + +(deftest stable-sort.order.2 + (let ((i 0) x y z) + (values + (stable-sort (progn (setf x (incf i)) (list 1 7 3 2)) + (progn (setf y (incf i)) #'<) + :key (progn (setf z (incf i)) #'-)) + i x y z)) + (7 3 2 1) 3 1 2 3) + + ;;; Error cases (deftest stable-sort.error.1 diff --git a/ansi-tests/string-capitalize.lsp b/ansi-tests/string-capitalize.lsp index e13ddaea5c024e0a0b28133b6207312d935e065f..82be8ce64e71effe9d3fdcafa48fd4c4e1a33bc9 100644 --- a/ansi-tests/string-capitalize.lsp +++ b/ansi-tests/string-capitalize.lsp @@ -84,6 +84,26 @@ ("ABCDEF" "ABCDEF")) "ABCDEF") +(deftest string-capitalize.order.1 + (let ((i 0) a b c (s (copy-seq "abcdef"))) + (values + (string-capitalize + (progn (setf a (incf i)) s) + :start (progn (setf b (incf i)) 1) + :end (progn (setf c (incf i)) 4)) + i a b c)) + "aBcdef" 3 1 2 3) + +(deftest string-capitalize.order.2 + (let ((i 0) a b c (s (copy-seq "abcdef"))) + (values + (string-capitalize + (progn (setf a (incf i)) s) + :end (progn (setf b (incf i)) 4) + :start (progn (setf c (incf i)) 1)) + i a b c)) + "aBcdef" 3 1 2 3) + ;;; Error cases (deftest string-capitalize.error.1 diff --git a/ansi-tests/string-comparisons.lsp b/ansi-tests/string-comparisons.lsp index 92db5fca7aff85112e842dd8f66310dae617c29d..617390eff50eb12178ffe01bfd3fe8fce08d3008 100644 --- a/ansi-tests/string-comparisons.lsp +++ b/ansi-tests/string-comparisons.lsp @@ -75,6 +75,420 @@ collect (not (string= "ab" "xyab" :start2 i :end2 nil))) (t t nil t)) +;;; Order of evaluation + +(deftest string=.order.1 + (let ((i 0) x y) + (values + (string= (progn (setf x (incf i)) "abc") + (progn (setf y (incf i)) "abd")) + i x y)) + nil 2 1 2) + +(deftest string=.order.2 + (let ((i 0) a b c d e f) + (values + (string= (progn (setf a (incf i)) "abc") + (progn (setf b (incf i)) "abd") + :start1 (progn (setf c (incf i)) 0) + :start2 (progn (setf d (incf i)) 0) + :end1 (progn (setf e (incf i)) nil) + :end2 (progn (setf f (incf i)) nil) + ) + i a b c d e f)) + nil 6 1 2 3 4 5 6) + +(deftest string=.order.3 + (let ((i 0) a b c d e f) + (values + (string= (progn (setf a (incf i)) "abc") + (progn (setf b (incf i)) "abd") + :end2 (progn (setf c (incf i)) nil) + :end1 (progn (setf d (incf i)) nil) + :start2 (progn (setf e (incf i)) 0) + :start1 (progn (setf f (incf i)) 0) + ) + i a b c d e f)) + nil 6 1 2 3 4 5 6) + +(deftest string<=.order.1 + (let ((i 0) x y) + (values + (string<= (progn (setf x (incf i)) "abf") + (progn (setf y (incf i)) "abd")) + i x y)) + nil 2 1 2) + +(deftest string<=.order.2 + (let ((i 0) a b c d e f) + (values + (string<= (progn (setf a (incf i)) "abf") + (progn (setf b (incf i)) "abd") + :start1 (progn (setf c (incf i)) 0) + :start2 (progn (setf d (incf i)) 0) + :end1 (progn (setf e (incf i)) nil) + :end2 (progn (setf f (incf i)) nil) + ) + i a b c d e f)) + nil 6 1 2 3 4 5 6) + +(deftest string<=.order.3 + (let ((i 0) a b c d e f) + (values + (string<= (progn (setf a (incf i)) "abf") + (progn (setf b (incf i)) "abd") + :end2 (progn (setf c (incf i)) nil) + :end1 (progn (setf d (incf i)) nil) + :start2 (progn (setf e (incf i)) 0) + :start1 (progn (setf f (incf i)) 0) + ) + i a b c d e f)) + nil 6 1 2 3 4 5 6) + +(deftest string<.order.1 + (let ((i 0) x y) + (values + (string< (progn (setf x (incf i)) "abf") + (progn (setf y (incf i)) "abd")) + i x y)) + nil 2 1 2) + +(deftest string<.order.2 + (let ((i 0) a b c d e f) + (values + (string< (progn (setf a (incf i)) "abf") + (progn (setf b (incf i)) "abd") + :start1 (progn (setf c (incf i)) 0) + :start2 (progn (setf d (incf i)) 0) + :end1 (progn (setf e (incf i)) nil) + :end2 (progn (setf f (incf i)) nil) + ) + i a b c d e f)) + nil 6 1 2 3 4 5 6) + +(deftest string<.order.3 + (let ((i 0) a b c d e f) + (values + (string< (progn (setf a (incf i)) "abf") + (progn (setf b (incf i)) "abd") + :end2 (progn (setf c (incf i)) nil) + :end1 (progn (setf d (incf i)) nil) + :start2 (progn (setf e (incf i)) 0) + :start1 (progn (setf f (incf i)) 0) + ) + i a b c d e f)) + nil 6 1 2 3 4 5 6) + + +(deftest string/=.order.1 + (let ((i 0) x y) + (values + (string/= (progn (setf x (incf i)) "abc") + (progn (setf y (incf i)) "abc")) + i x y)) + nil 2 1 2) + +(deftest string/=.order.2 + (let ((i 0) a b c d e f) + (values + (string/= (progn (setf a (incf i)) "abc") + (progn (setf b (incf i)) "abc") + :start1 (progn (setf c (incf i)) 0) + :start2 (progn (setf d (incf i)) 0) + :end1 (progn (setf e (incf i)) nil) + :end2 (progn (setf f (incf i)) nil) + ) + i a b c d e f)) + nil 6 1 2 3 4 5 6) + +(deftest string/=.order.3 + (let ((i 0) a b c d e f) + (values + (string/= (progn (setf a (incf i)) "abc") + (progn (setf b (incf i)) "abc") + :end2 (progn (setf c (incf i)) nil) + :end1 (progn (setf d (incf i)) nil) + :start2 (progn (setf e (incf i)) 0) + :start1 (progn (setf f (incf i)) 0) + ) + i a b c d e f)) + nil 6 1 2 3 4 5 6) + +(deftest string>=.order.1 + (let ((i 0) x y) + (values + (string<= (progn (setf x (incf i)) "abf") + (progn (setf y (incf i)) "abd")) + i x y)) + nil 2 1 2) + +(deftest string>=.order.2 + (let ((i 0) a b c d e f) + (values + (string>= (progn (setf a (incf i)) "abc") + (progn (setf b (incf i)) "abd") + :start1 (progn (setf c (incf i)) 0) + :start2 (progn (setf d (incf i)) 0) + :end1 (progn (setf e (incf i)) nil) + :end2 (progn (setf f (incf i)) nil) + ) + i a b c d e f)) + nil 6 1 2 3 4 5 6) + +(deftest string>=.order.3 + (let ((i 0) a b c d e f) + (values + (string>= (progn (setf a (incf i)) "abc") + (progn (setf b (incf i)) "abd") + :end2 (progn (setf c (incf i)) nil) + :end1 (progn (setf d (incf i)) nil) + :start2 (progn (setf e (incf i)) 0) + :start1 (progn (setf f (incf i)) 0) + ) + i a b c d e f)) + nil 6 1 2 3 4 5 6) + +(deftest string>.order.1 + (let ((i 0) x y) + (values + (string> (progn (setf x (incf i)) "abc") + (progn (setf y (incf i)) "abd")) + i x y)) + nil 2 1 2) + +(deftest string>.order.2 + (let ((i 0) a b c d e f) + (values + (string> (progn (setf a (incf i)) "abc") + (progn (setf b (incf i)) "abd") + :start1 (progn (setf c (incf i)) 0) + :start2 (progn (setf d (incf i)) 0) + :end1 (progn (setf e (incf i)) nil) + :end2 (progn (setf f (incf i)) nil) + ) + i a b c d e f)) + nil 6 1 2 3 4 5 6) + +(deftest string>.order.3 + (let ((i 0) a b c d e f) + (values + (string> (progn (setf a (incf i)) "abc") + (progn (setf b (incf i)) "abd") + :end2 (progn (setf c (incf i)) nil) + :end1 (progn (setf d (incf i)) nil) + :start2 (progn (setf e (incf i)) 0) + :start1 (progn (setf f (incf i)) 0) + ) + i a b c d e f)) + nil 6 1 2 3 4 5 6) + + +(deftest string-equal.order.1 + (let ((i 0) x y) + (values + (string-equal (progn (setf x (incf i)) "abc") + (progn (setf y (incf i)) "abd")) + i x y)) + nil 2 1 2) + +(deftest string-equal.order.2 + (let ((i 0) a b c d e f) + (values + (string-equal (progn (setf a (incf i)) "abc") + (progn (setf b (incf i)) "abd") + :start1 (progn (setf c (incf i)) 0) + :start2 (progn (setf d (incf i)) 0) + :end1 (progn (setf e (incf i)) nil) + :end2 (progn (setf f (incf i)) nil) + ) + i a b c d e f)) + nil 6 1 2 3 4 5 6) + +(deftest string-equal.order.3 + (let ((i 0) a b c d e f) + (values + (string-equal (progn (setf a (incf i)) "abc") + (progn (setf b (incf i)) "abd") + :end2 (progn (setf c (incf i)) nil) + :end1 (progn (setf d (incf i)) nil) + :start2 (progn (setf e (incf i)) 0) + :start1 (progn (setf f (incf i)) 0) + ) + i a b c d e f)) + nil 6 1 2 3 4 5 6) + +(deftest string-not-greaterp.order.1 + (let ((i 0) x y) + (values + (string-not-greaterp (progn (setf x (incf i)) "abf") + (progn (setf y (incf i)) "abd")) + i x y)) + nil 2 1 2) + +(deftest string-not-greaterp.order.2 + (let ((i 0) a b c d e f) + (values + (string-not-greaterp (progn (setf a (incf i)) "abf") + (progn (setf b (incf i)) "abd") + :start1 (progn (setf c (incf i)) 0) + :start2 (progn (setf d (incf i)) 0) + :end1 (progn (setf e (incf i)) nil) + :end2 (progn (setf f (incf i)) nil) + ) + i a b c d e f)) + nil 6 1 2 3 4 5 6) + +(deftest string-not-greaterp.order.3 + (let ((i 0) a b c d e f) + (values + (string-not-greaterp (progn (setf a (incf i)) "abf") + (progn (setf b (incf i)) "abd") + :end2 (progn (setf c (incf i)) nil) + :end1 (progn (setf d (incf i)) nil) + :start2 (progn (setf e (incf i)) 0) + :start1 (progn (setf f (incf i)) 0) + ) + i a b c d e f)) + nil 6 1 2 3 4 5 6) + +(deftest string-lessp.order.1 + (let ((i 0) x y) + (values + (string-lessp (progn (setf x (incf i)) "abf") + (progn (setf y (incf i)) "abd")) + i x y)) + nil 2 1 2) + +(deftest string-lessp.order.2 + (let ((i 0) a b c d e f) + (values + (string-lessp (progn (setf a (incf i)) "abf") + (progn (setf b (incf i)) "abd") + :start1 (progn (setf c (incf i)) 0) + :start2 (progn (setf d (incf i)) 0) + :end1 (progn (setf e (incf i)) nil) + :end2 (progn (setf f (incf i)) nil) + ) + i a b c d e f)) + nil 6 1 2 3 4 5 6) + +(deftest string-lessp.order.3 + (let ((i 0) a b c d e f) + (values + (string-lessp (progn (setf a (incf i)) "abf") + (progn (setf b (incf i)) "abd") + :end2 (progn (setf c (incf i)) nil) + :end1 (progn (setf d (incf i)) nil) + :start2 (progn (setf e (incf i)) 0) + :start1 (progn (setf f (incf i)) 0) + ) + i a b c d e f)) + nil 6 1 2 3 4 5 6) + + +(deftest string-not-equal.order.1 + (let ((i 0) x y) + (values + (string-not-equal (progn (setf x (incf i)) "abc") + (progn (setf y (incf i)) "abc")) + i x y)) + nil 2 1 2) + +(deftest string-not-equal.order.2 + (let ((i 0) a b c d e f) + (values + (string-not-equal (progn (setf a (incf i)) "abc") + (progn (setf b (incf i)) "abc") + :start1 (progn (setf c (incf i)) 0) + :start2 (progn (setf d (incf i)) 0) + :end1 (progn (setf e (incf i)) nil) + :end2 (progn (setf f (incf i)) nil) + ) + i a b c d e f)) + nil 6 1 2 3 4 5 6) + +(deftest string-not-equal.order.3 + (let ((i 0) a b c d e f) + (values + (string-not-equal (progn (setf a (incf i)) "abc") + (progn (setf b (incf i)) "abc") + :end2 (progn (setf c (incf i)) nil) + :end1 (progn (setf d (incf i)) nil) + :start2 (progn (setf e (incf i)) 0) + :start1 (progn (setf f (incf i)) 0) + ) + i a b c d e f)) + nil 6 1 2 3 4 5 6) + +(deftest string-not-lessp.order.1 + (let ((i 0) x y) + (values + (string-not-lessp (progn (setf x (incf i)) "abc") + (progn (setf y (incf i)) "abd")) + i x y)) + nil 2 1 2) + +(deftest string-not-lessp.order.2 + (let ((i 0) a b c d e f) + (values + (string-not-lessp (progn (setf a (incf i)) "abc") + (progn (setf b (incf i)) "abd") + :start1 (progn (setf c (incf i)) 0) + :start2 (progn (setf d (incf i)) 0) + :end1 (progn (setf e (incf i)) nil) + :end2 (progn (setf f (incf i)) nil) + ) + i a b c d e f)) + nil 6 1 2 3 4 5 6) + +(deftest string-not-lessp.order.3 + (let ((i 0) a b c d e f) + (values + (string-not-lessp (progn (setf a (incf i)) "abc") + (progn (setf b (incf i)) "abd") + :end2 (progn (setf c (incf i)) nil) + :end1 (progn (setf d (incf i)) nil) + :start2 (progn (setf e (incf i)) 0) + :start1 (progn (setf f (incf i)) 0) + ) + i a b c d e f)) + nil 6 1 2 3 4 5 6) + +(deftest string-greaterp.order.1 + (let ((i 0) x y) + (values + (string-greaterp (progn (setf x (incf i)) "abc") + (progn (setf y (incf i)) "abd")) + i x y)) + nil 2 1 2) + +(deftest string-greaterp.order.2 + (let ((i 0) a b c d e f) + (values + (string-greaterp (progn (setf a (incf i)) "abc") + (progn (setf b (incf i)) "abd") + :start1 (progn (setf c (incf i)) 0) + :start2 (progn (setf d (incf i)) 0) + :end1 (progn (setf e (incf i)) nil) + :end2 (progn (setf f (incf i)) nil) + ) + i a b c d e f)) + nil 6 1 2 3 4 5 6) + +(deftest string-greaterp.order.3 + (let ((i 0) a b c d e f) + (values + (string-greaterp (progn (setf a (incf i)) "abc") + (progn (setf b (incf i)) "abd") + :end2 (progn (setf c (incf i)) nil) + :end1 (progn (setf d (incf i)) nil) + :start2 (progn (setf e (incf i)) 0) + :start1 (progn (setf f (incf i)) 0) + ) + i a b c d e f)) + nil 6 1 2 3 4 5 6) + + ;;; Random tests (of all the string comparson functions) (deftest random-string-comparison-tests diff --git a/ansi-tests/string-downcase.lsp b/ansi-tests/string-downcase.lsp index d0824412f152a76312c80cbf6c3996bcf887eaff..a1c4dd294545c90215df51cc219444980f273ee0 100644 --- a/ansi-tests/string-downcase.lsp +++ b/ansi-tests/string-downcase.lsp @@ -80,6 +80,26 @@ ("abcde" "abcdE")) "ABCDE") +(deftest string-downcase.order.1 + (let ((i 0) a b c (s (copy-seq "ABCDEF"))) + (values + (string-downcase + (progn (setf a (incf i)) s) + :start (progn (setf b (incf i)) 1) + :end (progn (setf c (incf i)) 4)) + i a b c)) + "AbcdEF" 3 1 2 3) + +(deftest string-downcase.order.2 + (let ((i 0) a b c (s (copy-seq "ABCDEF"))) + (values + (string-downcase + (progn (setf a (incf i)) s) + :end (progn (setf b (incf i)) 4) + :start (progn (setf c (incf i)) 1)) + i a b c)) + "AbcdEF" 3 1 2 3) + ;;; Error cases (deftest string-downcase.error.1 diff --git a/ansi-tests/string-left-trim.lsp b/ansi-tests/string-left-trim.lsp index 7291f0446dd40575b0503f4f821e76ea6f29c567..c620670c852bb0d999483fd937e14c52ab116646 100644 --- a/ansi-tests/string-left-trim.lsp +++ b/ansi-tests/string-left-trim.lsp @@ -141,6 +141,15 @@ (string-left-trim "abc" (copy-seq "abcabcabc")) "") +(deftest string-left-trim.order.1 + (let ((i 0) x y) + (values + (string-left-trim (progn (setf x (incf i)) " ") + (progn (setf y (incf i)) + (copy-seq " abc d e f "))) + i x y)) + "abc d e f " 2 1 2) + ;;; Error cases (deftest string-left-trim.error.1 diff --git a/ansi-tests/string-right-trim.lsp b/ansi-tests/string-right-trim.lsp index a551c0e7f2783e62f9ce35c77886153e4c73253a..883348e5e209681b806c0cf1887684731481264c 100644 --- a/ansi-tests/string-right-trim.lsp +++ b/ansi-tests/string-right-trim.lsp @@ -141,6 +141,15 @@ (string-right-trim "abc" (copy-seq "abcabcabc")) "") +(deftest string-right-trim.order.1 + (let ((i 0) x y) + (values + (string-right-trim (progn (setf x (incf i)) " ") + (progn (setf y (incf i)) + (copy-seq " abc d e f "))) + i x y)) + " abc d e f" 2 1 2) + ;;; Error cases (deftest string-right-trim.error.1 diff --git a/ansi-tests/string-trim.lsp b/ansi-tests/string-trim.lsp index 66582456619ab336c8cd0ef684eea712dd411cf0..a722268d76f02bb0afcd2d5f1dd2197c97efed75 100644 --- a/ansi-tests/string-trim.lsp +++ b/ansi-tests/string-trim.lsp @@ -141,6 +141,15 @@ (string-trim "abc" (copy-seq "abcabcabc")) "") +(deftest string-trim.order.1 + (let ((i 0) x y) + (values + (string-trim (progn (setf x (incf i)) " ") + (progn (setf y (incf i)) + (copy-seq " abc d e f "))) + i x y)) + "abc d e f" 2 1 2) + ;;; Error cases (deftest string-trim.error.1 diff --git a/ansi-tests/string-upcase.lsp b/ansi-tests/string-upcase.lsp index f75caa020ac1cc7d4eedd3aa15a84ecc804e90b6..4999f5cd7e53386a5d19d83e47afb0813afd295e 100644 --- a/ansi-tests/string-upcase.lsp +++ b/ansi-tests/string-upcase.lsp @@ -80,6 +80,26 @@ ("abcde" "abcdE")) "abcde") +(deftest string-upcase.order.1 + (let ((i 0) a b c (s (copy-seq "abcdef"))) + (values + (string-upcase + (progn (setf a (incf i)) s) + :start (progn (setf b (incf i)) 1) + :end (progn (setf c (incf i)) 4)) + i a b c)) + "aBCDef" 3 1 2 3) + +(deftest string-upcase.order.2 + (let ((i 0) a b c (s (copy-seq "abcdef"))) + (values + (string-upcase + (progn (setf a (incf i)) s) + :end (progn (setf b (incf i)) 4) + :start (progn (setf c (incf i)) 1)) + i a b c)) + "aBCDef" 3 1 2 3) + ;;; Error cases diff --git a/ansi-tests/subseq-aux.lsp b/ansi-tests/subseq-aux.lsp index 55aa421cf95a8299647de62ea7c2066884a6819f..ef466de06e2024fc77126a077c7b7f83952c540f 100644 --- a/ansi-tests/subseq-aux.lsp +++ b/ansi-tests/subseq-aux.lsp @@ -5,7 +5,7 @@ (in-package :cl-test) -(defun subseq-list-4-body () +(defun subseq-list.4-body () (block done (let ((x (loop for i from 0 to 19 collect i))) (loop @@ -18,7 +18,7 @@ (unless (eqlt e k) (return-from done nil))))))) t)) -(defun subseq-list-5-body () +(defun subseq-list.5-body () (block done (let ((x (loop for i from 0 to 29 collect i))) (loop @@ -28,7 +28,7 @@ (return-from done nil)))) t)) -(defun subseq-list-6-body () +(defun subseq-list.6-body () (let* ((x (make-list 100)) (z (loop for e on x collect e)) (y (subseq x 0))) @@ -43,7 +43,7 @@ (return nil)) finally (return t)))) -(defun subseq-vector-1-body () +(defun subseq-vector.1-body () (block nil (let* ((x (make-sequence 'vector 10 :initial-element 'a)) (y (subseq x 4 8))) @@ -61,7 +61,7 @@ (not (not (every #'(lambda (e) (eqt e 'b)) x))) 6)))) -(defun subseq-vector-2-body () +(defun subseq-vector.2-body () (block nil (let* ((x (make-sequence '(vector fixnum) 10 :initial-element 1)) (y (subseq x 4 8))) @@ -79,7 +79,7 @@ (not (not (every #'(lambda (e) (eqlt e 2)) x))) 6)))) -(defun subseq-vector-3-body () +(defun subseq-vector.3-body () (block nil (let* ((x (make-sequence '(vector single-float) 10 :initial-element 1.0)) (y (subseq x 4 8))) @@ -97,7 +97,7 @@ (not (not (every #'(lambda (e) (= e 2.0)) x))) 6)))) -(defun subseq-vector-4-body () +(defun subseq-vector.4-body () (block nil (let* ((x (make-sequence '(vector double-float) 10 :initial-element 1.0d0)) (y (subseq x 4 8))) @@ -115,7 +115,7 @@ (not (not (every #'(lambda (e) (= e 2.0)) x))) 6)))) -(defun subseq-vector-5-body () +(defun subseq-vector.5-body () (block nil (let* ((x (make-sequence '(vector short-float) 10 :initial-element 1.0s0)) (y (subseq x 4 8))) @@ -133,7 +133,7 @@ (not (not (every #'(lambda (e) (= e 2.0)) x))) 6)))) -(defun subseq-vector-6-body () +(defun subseq-vector.6-body () (block nil (let* ((x (make-sequence '(vector long-float) 10 :initial-element 1.0l0)) (y (subseq x 4 8))) @@ -151,7 +151,7 @@ (not (not (every #'(lambda (e) (= e 2.0)) x))) 6)))) -(defun subseq-string-1-body () +(defun subseq-string.1-body () (let* ((s1 "abcdefgh") (len (length s1))) (loop for start from 0 below len @@ -161,7 +161,7 @@ collect (aref s1 i)) 'string))))) -(defun subseq-string-2-body () +(defun subseq-string.2-body () (let* ((s1 "abcdefgh") (len (length s1))) (loop for start from 0 below len @@ -173,7 +173,7 @@ collect (aref s1 i)) 'string)))))) -(defun subseq-string-3-body () +(defun subseq-string.3-body () (let* ((s1 (make-array '(10) :initial-contents "abcdefghij" :fill-pointer 8 :element-type 'character)) @@ -194,7 +194,7 @@ (coerce (loop for i from start below end collect (aref s1 i)) 'string))))))) -(defun subseq-bit-vector-1-body () +(defun subseq-bit-vector.1-body () (let* ((s1 #*11001000) (len (length s1))) (loop for start from 0 below len @@ -204,7 +204,7 @@ collect (aref s1 i)) 'bit-vector))))) -(defun subseq-bit-vector-2-body () +(defun subseq-bit-vector.2-body () (let* ((s1 #*01101011) (len (length s1))) (loop for start from 0 below len @@ -216,7 +216,7 @@ collect (aref s1 i)) 'bit-vector)))))) -(defun subseq-bit-vector-3-body () +(defun subseq-bit-vector.3-body () (let* ((s1 (make-array '(10) :initial-contents #*1101100110 :fill-pointer 8 :element-type 'bit)) diff --git a/ansi-tests/subseq.lsp b/ansi-tests/subseq.lsp index 87a40a9e90a9efb476bab19253dcad2e1217f672..80d3d123dc16ddef18d6a3744cbfa0dd9605083f 100644 --- a/ansi-tests/subseq.lsp +++ b/ansi-tests/subseq.lsp @@ -8,66 +8,66 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; subseq, on lists -(deftest subseq-list-1 +(deftest subseq-list.1 (subseq '(a b c d e) 0 0) nil) -(deftest subseq-list-2 +(deftest subseq-list.2 (subseq '(a b c) 0) (a b c)) -(deftest subseq-list-3 +(deftest subseq-list.3 (subseq '(a b c) 1) (b c)) -(deftest subseq-list-4 - (subseq-list-4-body) +(deftest subseq-list.4 + (subseq-list.4-body) t) -(deftest subseq-list-5 - (subseq-list-5-body) +(deftest subseq-list.5 + (subseq-list.5-body) t) -(deftest subseq-list-6 ;; check that no structure is shared - (subseq-list-6-body) +(deftest subseq-list.6 ;; check that no structure is shared + (subseq-list.6-body) t) -(deftest subseq-list-7 +(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 +(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 +(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 +(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 +(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 +(deftest subseq-list.12 (let* ((x '(a b c d e)) (y (copy-seq x))) (setf (subseq y 0 0) '(1 2)) @@ -77,39 +77,39 @@ ;; subseq on vectors -(deftest subseq-vector-1 - (subseq-vector-1-body) +(deftest subseq-vector.1 + (subseq-vector.1-body) t) -(deftest subseq-vector-2 - (subseq-vector-2-body) +(deftest subseq-vector.2 + (subseq-vector.2-body) t) -(deftest subseq-vector-3 - (subseq-vector-3-body) +(deftest subseq-vector.3 + (subseq-vector.3-body) t) -(deftest subseq-vector-4 - (subseq-vector-4-body) +(deftest subseq-vector.4 + (subseq-vector.4-body) t) -(deftest subseq-vector-5 - (subseq-vector-5-body) +(deftest subseq-vector.5 + (subseq-vector.5-body) t) -(deftest subseq-vector-6 - (subseq-vector-6-body) +(deftest subseq-vector.6 + (subseq-vector.6-body) t) -(deftest subseq-vector-7 +(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 +(deftest subseq-vector.8 (let* ((x (make-array '(200) :initial-element 107 :element-type 'fixnum)) (y (subseq x 17 95))) @@ -120,8 +120,8 @@ :element-type 'fixnum)))) t) -(deftest subseq-vector-9 - (let* ((x (make-array '(1000) :initial-element 17.6e-1 +(deftest subseq-vector.9 + (let* ((x (make-array '(1000) :initial-element 17.6e.1 :element-type 'single-float)) (lo 164) (hi 873) @@ -129,11 +129,11 @@ (and (eqlt (length y) (- hi lo)) (equal-array y (make-array (list (- hi lo)) - :initial-element 17.6e-1 + :initial-element 17.6e.1 :element-type 'single-float)))) t) -(deftest subseq-vector-10 +(deftest subseq-vector.10 (let* ((x (make-array '(2000) :initial-element 3.1415927d4 :element-type 'double-float)) (lo 731) @@ -148,32 +148,76 @@ ;;; subseq on strings -(deftest subseq-string-1 - (subseq-string-1-body) +(deftest subseq-string.1 + (subseq-string.1-body) t) -(deftest subseq-string-2 - (subseq-string-2-body) +(deftest subseq-string.2 + (subseq-string.2-body) t) -(deftest subseq-string-3 - (subseq-string-3-body) +(deftest subseq-string.3 + (subseq-string.3-body) t) ;;; Tests on bit vectors -(deftest subseq-bit-vector-1 - (subseq-bit-vector-1-body) +(deftest subseq-bit-vector.1 + (subseq-bit-vector.1-body) t) -(deftest subseq-bit-vector-2 - (subseq-bit-vector-2-body) +(deftest subseq-bit-vector.2 + (subseq-bit-vector.2-body) t) -(deftest subseq-bit-vector-3 - (subseq-bit-vector-3-body) +(deftest subseq-bit-vector.3 + (subseq-bit-vector.3-body) t) +;;; Order of evaluation + +(deftest subseq.order.1 + (let ((i 0) a b c) + (values + (subseq + (progn (setf a (incf i)) "abcdefgh") + (progn (setf b (incf i)) 1) + (progn (setf c (incf i)) 4)) + i a b c)) + "bcd" 3 1 2 3) + +(deftest subseq.order.2 + (let ((i 0) a b) + (values + (subseq + (progn (setf a (incf i)) "abcdefgh") + (progn (setf b (incf i)) 1)) + i a b)) + "bcdefgh" 2 1 2) + +(deftest subseq.order.3 + (let ((i 0) a b c d + (s (copy-seq "abcdefgh"))) + (values + (setf (subseq + (progn (setf a (incf i)) s) + (progn (setf b (incf i)) 1) + (progn (setf c (incf i)) 4)) + (progn (setf d (incf i)) "xyz")) + s i a b c d)) + "xyz" "axyzefgh" 4 1 2 3 4) + +(deftest subseq.order.4 + (let ((i 0) a b c + (s (copy-seq "abcd"))) + (values + (setf (subseq + (progn (setf a (incf i)) s) + (progn (setf b (incf i)) 1)) + (progn (setf c (incf i)) "xyz")) + s i a b c)) + "xyz" "axyz" 3 1 2 3) + ;;; Error cases (deftest subseq.error.1 diff --git a/ansi-tests/substitute-if-not.lsp b/ansi-tests/substitute-if-not.lsp index 603709c96088e644bd61433113eeb3f355cc19a4..26b5b5787ea66c7a5a9dea77b85f23ec0780f068 100644 --- a/ansi-tests/substitute-if-not.lsp +++ b/ansi-tests/substitute-if-not.lsp @@ -711,6 +711,40 @@ result) #*01111) +(deftest substitute-if-not.order.1 + (let ((i 0) a b c d e f g h) + (values + (substitute-if-not + (progn (setf a (incf i)) 'a) + (progn (setf b (incf i)) #'identity) + (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) + :count (progn (setf d (incf i)) 2) + :start (progn (setf e (incf i)) 0) + :end (progn (setf f (incf i)) 7) + :key (progn (setf g (incf i)) #'identity) + :from-end (setf h (incf i)) + ) + i a b c d e f g h)) + (nil 1 2 a 3 4 a 5) + 8 1 2 3 4 5 6 7 8) + +(deftest substitute-if-not.order.2 + (let ((i 0) a b c d e f g h) + (values + (substitute-if-not + (progn (setf a (incf i)) 'a) + (progn (setf b (incf i)) #'identity) + (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) + :from-end (setf h (incf i)) + :key (progn (setf g (incf i)) #'identity) + :end (progn (setf f (incf i)) 7) + :start (progn (setf e (incf i)) 0) + :count (progn (setf d (incf i)) 2) + ) + i a b c d e f g h)) + (nil 1 2 a 3 4 a 5) + 8 1 2 3 8 7 6 5 4) + ;;; Keyword tests (deftest substitute-if-not.allow-other-keys.1 diff --git a/ansi-tests/substitute-if.lsp b/ansi-tests/substitute-if.lsp index 186762c0da6c8d50b28f0c7ecc551cada1c98bae..7dfac780938c1ce9798f541b44b811b3d0cc632e 100644 --- a/ansi-tests/substitute-if.lsp +++ b/ansi-tests/substitute-if.lsp @@ -735,6 +735,40 @@ result) #*01111) +(deftest substitute-if.order.1 + (let ((i 0) a b c d e f g h) + (values + (substitute-if + (progn (setf a (incf i)) 'a) + (progn (setf b (incf i)) #'null) + (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) + :count (progn (setf d (incf i)) 2) + :start (progn (setf e (incf i)) 0) + :end (progn (setf f (incf i)) 7) + :key (progn (setf g (incf i)) #'identity) + :from-end (setf h (incf i)) + ) + i a b c d e f g h)) + (nil 1 2 a 3 4 a 5) + 8 1 2 3 4 5 6 7 8) + +(deftest substitute-if.order.2 + (let ((i 0) a b c d e f g h) + (values + (substitute-if + (progn (setf a (incf i)) 'a) + (progn (setf b (incf i)) #'null) + (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) + :from-end (setf h (incf i)) + :key (progn (setf g (incf i)) #'identity) + :end (progn (setf f (incf i)) 7) + :start (progn (setf e (incf i)) 0) + :count (progn (setf d (incf i)) 2) + ) + i a b c d e f g h)) + (nil 1 2 a 3 4 a 5) + 8 1 2 3 8 7 6 5 4) + ;;; Keyword tests (deftest substitute-if.allow-other-keys.1 diff --git a/ansi-tests/substitute.lsp b/ansi-tests/substitute.lsp index eaffad366c70581aa547cc1685c68c3dcf887092..149edb57001145de1999d3893b0d7c48bbb1632f 100644 --- a/ansi-tests/substitute.lsp +++ b/ansi-tests/substitute.lsp @@ -966,6 +966,40 @@ result) #*01111) +(deftest substitute.order.1 + (let ((i 0) a b c d e f g h) + (values + (substitute + (progn (setf a (incf i)) 'a) + (progn (setf b (incf i)) nil) + (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) + :count (progn (setf d (incf i)) 2) + :start (progn (setf e (incf i)) 0) + :end (progn (setf f (incf i)) 7) + :key (progn (setf g (incf i)) #'identity) + :from-end (setf h (incf i)) + ) + i a b c d e f g h)) + (nil 1 2 a 3 4 a 5) + 8 1 2 3 4 5 6 7 8) + +(deftest substitute.order.2 + (let ((i 0) a b c d e f g h) + (values + (substitute + (progn (setf a (incf i)) 'a) + (progn (setf b (incf i)) nil) + (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) + :from-end (setf h (incf i)) + :key (progn (setf g (incf i)) #'identity) + :end (progn (setf f (incf i)) 7) + :start (progn (setf e (incf i)) 0) + :count (progn (setf d (incf i)) 2) + ) + i a b c d e f g h)) + (nil 1 2 a 3 4 a 5) + 8 1 2 3 8 7 6 5 4) + ;;; Keyword tests (deftest substitute.allow-other-keys.1 diff --git a/ansi-tests/subtypep.lsp b/ansi-tests/subtypep.lsp index e38c145554e08bbb5650009dbbd01f6a04d01770..d35417fee1d9a8c67ca233a23dc89e17840f3a40 100644 --- a/ansi-tests/subtypep.lsp +++ b/ansi-tests/subtypep.lsp @@ -7,6 +7,14 @@ ;;; More subtypep tests are in types-and-class.lsp +(deftest subtypep.order.1 + (let ((i 0) x y) + (values + (notnot (subtypep (progn (setf x (incf i)) t) + (progn (setf y (incf i)) t))) + i x y)) + t 2 1 2) + (deftest simple-base-string-is-sequence (subtypep* 'simple-base-string 'sequence) t t) diff --git a/ansi-tests/svref.lsp b/ansi-tests/svref.lsp index 333dc4ede2036a014f5458b8c22399d83a5e569d..af0f7c4949ba5c7339c2ba14ac88e734b0a51bcf 100644 --- a/ansi-tests/svref.lsp +++ b/ansi-tests/svref.lsp @@ -19,6 +19,27 @@ (10 11 12 13) #(10 11 12 13)) +(deftest svref.order.1 + (let ((v (vector 'a 'b 'c 'd)) + (i 0) a b) + (values + (svref (progn (setf a (incf i)) v) + (progn (setf b (incf i)) 2)) + i a b)) + c 2 1 2) + +(deftest svref.order.2 + (let ((v (vector 'a 'b 'c 'd)) + (i 0) a b c) + (values + (setf + (svref (progn (setf a (incf i)) v) + (progn (setf b (incf i)) 2)) + (progn (setf c (incf i)) 'w)) + v i a b c)) + w #(a b w d) 3 1 2 3) + + ;;; Error tests (deftest svref.error.1 diff --git a/ansi-tests/types-and-class.lsp b/ansi-tests/types-and-class.lsp index 01ce8fe90ca949afdedf5303d8ef3997b5f3c264..4c1ddf4d90fbef36469d9064f71727afc1c4972c 100644 --- a/ansi-tests/types-and-class.lsp +++ b/ansi-tests/types-and-class.lsp @@ -10,15 +10,15 @@ (declaim (optimize (safety 3))) -(deftest boolean-type-1 +(deftest boolean-type.1 (notnot-mv (typep nil 'boolean)) t) -(deftest boolean-type-2 +(deftest boolean-type.2 (notnot-mv (typep t 'boolean)) t) -(deftest boolean-type-3 +(deftest boolean-type.3 (check-type-predicate 'is-t-or-nil 'boolean) 0) @@ -30,7 +30,7 @@ -(deftest types-3 +(deftest types.3 (loop for (t1 t2) in *subtype-table* for m1 = (check-subtypep t1 t2 t t) @@ -51,7 +51,7 @@ ;;; incorrectly that certain subtype relationships that are ;;; not specified in the spec cannot occur. #| -(defun types-4-body () +(defun types.4-body () (let ((parent-table (make-hash-table :test #'equal)) (types nil)) (loop @@ -90,20 +90,20 @@ (t 0))))) )) -(deftest types-4 - (types-4-body) +(deftest types.4 + (types.4-body) 0) |# -(deftest types-6 - (types-6-body) +(deftest types.6 + (types.6-body) nil) (declaim (special *disjoint-types-list*)) ;;; Check that the disjoint types really are disjoint -(deftest types-7b +(deftest types.7b (loop for e on *disjoint-types-list* for tp1 = (first e) append @@ -111,7 +111,7 @@ append (classes-are-disjoint tp1 tp2))) nil) -(deftest types-7c +(deftest types.7c (loop for e on *disjoint-types-list2* for list1 = (first e) append @@ -122,7 +122,7 @@ (classes-are-disjoint tp1 tp2))))) nil) -(deftest types-8 +(deftest types.8 (loop for tp in *disjoint-types-list* count (cond @@ -135,18 +135,18 @@ (declaim (special *type-list* *supertype-table*)) ;;; -;;; TYPES-9 checks the transitivity of SUBTYPEP on pairs of types +;;; TYPES.9 checks the transitivity of SUBTYPEP on pairs of types ;;; occuring in *SUBTYPE-TABLE*, as well as the types KEYWORD, ATOM, ;;; and LIST (the relationships given in *SUBTYPE-TABLE* are not used ;;; here.) ;;; -(deftest types-9 - (types-9-body) +(deftest types.9 + (types.9-body) nil) ;;; -;;; TYPES-9A takes the supertype relationship computed by test TYPE-9 +;;; TYPES.9A takes the supertype relationship computed by test TYPE.9 ;;; and checks that TYPEP respects it for all elements of *UNIVERSE*. ;;; That is, if T1 and T2 are two types, and X is an element of *UNIVERSE*, ;;; then if (SUBTYPEP T1) then (TYPEP X T1) implies (TYPEP X T2). @@ -154,11 +154,11 @@ ;;; The function prints error messages when this fails, and returns the ;;; number of occurences of failure. ;;; -;;; Test TYPES-9 must be run before this test. +;;; Test TYPES.9 must be run before this test. ;;; -(deftest types-9a - (types-9a-body) +(deftest types.9a + (types.9a-body) 0) @@ -227,27 +227,27 @@ `(and (array ,type ,size) (satisfies even-size-p))) -(deftest deftype-1 +(deftest deftype.1 (typep 1 '(even-array integer (10))) nil) -(deftest deftype-2 +(deftest deftype.2 (typep nil '(even-array t (*))) nil) -(deftest deftype-3 +(deftest deftype.3 (notnot-mv (typep (make-array '(10)) '(even-array t (*)))) t) -(deftest deftype-4 +(deftest deftype.4 (typep (make-array '(5)) '(even-array t (*))) nil) -(deftest deftype-5 +(deftest deftype.5 (notnot-mv (typep (make-string 10) '(even-array character (*)))) t) -(deftest deftype-6 +(deftest deftype.6 (notnot-mv (typep (make-array '(3 5 6) :element-type '(unsigned-byte 8)) '(even-array (unsigned-byte 8)))) diff --git a/ansi-tests/values.lsp b/ansi-tests/values.lsp index d381baec1cc309a02a69315daae5c88f990502c0..32e4d99f80360bd58795264df5c117ac03f23a30 100644 --- a/ansi-tests/values.lsp +++ b/ansi-tests/values.lsp @@ -53,4 +53,10 @@ (multiple-value-list (apply #'values x)))) t) +(deftest values.order.1 + (let ((i 0) a b c) + (values (multiple-value-list + (values (setf a (incf i)) (setf b (incf i)) (setf c (incf i)))) + i a b c)) + (1 2 3) 3 1 2 3) diff --git a/ansi-tests/vector-push-extend.lsp b/ansi-tests/vector-push-extend.lsp index 8bcce33c7f61a5042420b7a38960e0113b122e91..63903d67c3e115b385b5400dfa502530b4c709f0 100644 --- a/ansi-tests/vector-push-extend.lsp +++ b/ansi-tests/vector-push-extend.lsp @@ -7,14 +7,16 @@ (deftest vector-push-extend.1 (let ((a (make-array '(5) :fill-pointer 2 - :initial-contents '(a b c d e)))) + :initial-contents '(a b c d e))) + (i 0) x y) (values (fill-pointer a) - (vector-push-extend 'x a) + (vector-push-extend (progn (setf x (incf i)) 'x) + (progn (setf y (incf i)) a)) (fill-pointer a) - a)) - 2 2 3 #(a b x)) - + a + i x y)) + 2 2 3 #(a b x) 2 1 2) (deftest vector-push-extend.2 (let ((a (make-array '(5) :fill-pointer 5 @@ -43,14 +45,18 @@ (let ((a (make-array '(5) :fill-pointer 5 :adjustable t :initial-contents "abcde" - :element-type 'base-char))) + :element-type 'base-char)) + (i 0) x y z) (values (fill-pointer a) - (vector-push-extend #\x a 1) + (vector-push-extend (progn (setf x (incf i)) #\x) + (progn (setf y (incf i)) a) + (progn (setf z (incf i)) 1)) (fill-pointer a) (<= (array-total-size a) 5) - a)) - 5 5 6 nil "abcdex") + a + i x y z)) + 5 5 6 nil "abcdex" 3 1 2 3) (deftest vector-push-extend.5 (let ((a (make-array '(5) :fill-pointer 2 diff --git a/ansi-tests/vector-push.lsp b/ansi-tests/vector-push.lsp index 13278ebe1ced9bb7949e6bb8d9ae6860e4e1698d..6cb106b2ba188fb641865cffd40cafb32fdc5a0e 100644 --- a/ansi-tests/vector-push.lsp +++ b/ansi-tests/vector-push.lsp @@ -7,13 +7,15 @@ (deftest vector-push.1 (let ((a (make-array '(5) :fill-pointer 2 - :initial-contents '(a b c d e)))) + :initial-contents '(a b c d e))) + (i 0) x y) (values (fill-pointer a) - (vector-push 'x a) + (vector-push (progn (setf x (incf i)) 'x) + (progn (setf y (incf i)) a)) (fill-pointer a) - a)) - 2 2 3 #(a b x)) + a i x y)) + 2 2 3 #(a b x) 2 1 2) (deftest vector-push.2 diff --git a/ansi-tests/vector.lsp b/ansi-tests/vector.lsp index 0b9131f003d9fa7e070c31cb96e0a4e4bca46a90..2dc1bd49d192b2a025eee602bb6264b4752c8c5c 100644 --- a/ansi-tests/vector.lsp +++ b/ansi-tests/vector.lsp @@ -323,3 +323,9 @@ (notnot-mv (typep (vector 1 2 3) '(simple-vector *))) t) +(deftest vector.order.1 + (let ((i 0) a b c) + (values + (vector (setf a (incf i)) (setf b (incf i)) (setf c (incf i))) + i a b c)) + #(1 2 3) 3 1 2 3)