Commit e81cdd30 authored by pfdietz's avatar pfdietz

Finished adding the argument evaluation order tests for the functions that...

Finished adding the argument evaluation order tests for the functions that have so far been covered in the tests.
parent bc1dd837
......@@ -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
......
......@@ -131,3 +131,6 @@
x y z w))
0 #*00010 3 1 2 3)
(deftest bit.error.1
(classify-error (bit))
program-error)
......@@ -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
......
......@@ -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
......
......@@ -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)
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -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")))
......
......@@ -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")
......
......@@ -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