Commit 30e82c01 authored by pfdietz's avatar pfdietz

Many cleanups. Replaced notnot, not with notnot-mv, not-mv in places where we...

Many cleanups.  Replaced notnot, not with notnot-mv, not-mv in places where we can inspect the results for the right number of multiple values.  Ditto for multiple-value-bind*, which is strict in checking for number of values.  Indentation changes.
parent 556f97c6
......@@ -13,13 +13,32 @@
(defun notnot (x) (not (not x)))
(defmacro notnot-mv (form)
`(apply #'values (mapcar #'notnot (multiple-value-list ,form))))
`(notnot-mv-fn (multiple-value-list ,form)))
;;; Macro to check that a function is returning a single value
(defmacro check-value (form &optional (num 1))
(defun notnot-mv-fn (results)
(if (null results)
(values)
(apply #'values
(not (not (first results)))
(rest results))))
(defmacro not-mv (form)
`(not-mv-fn (multiple-value-list ,form)))
(defun not-mv-fn (results)
(if (null results)
(values)
(apply #'values
(not (first results))
(rest results))))
;;; Macro to check that a function is returning a specified number of values
;;; (defaults to 1)
(defmacro check-values (form &optional (num 1))
(let ((v (gensym))
(n (gensym)))
`(let ((,v ,form)
`(let ((,v (multiple-value-list ,form))
(,n ,num))
(check-values-length ,v ,n ',form)
(car ,v))))
......
......@@ -9,7 +9,7 @@
(subtypep* type (array-element-type (make-array 0 :element-type type))))
(defun subtypep-or-unknown (subtype supertype)
(multiple-value-bind (is-subtype is-known)
(multiple-value-bind* (is-subtype is-known)
(subtypep subtype supertype)
(or (not is-known) (notnot is-subtype))))
......@@ -30,10 +30,10 @@
"Call MAKE-ARRAY and do sanity tests on the output."
(declare (ignore element-type-p initial-contents initial-contents-p
initial-element initial-element-p dio-p))
(let ((a (apply #'make-array dimensions options)))
(let ((a (check-values (apply #'make-array dimensions options))))
(cond
((not (typep a 'array)) :fail-not-array)
((not (arrayp a)) :fail-not-arrayp)
((not (check-values (arrayp a))) :fail-not-arrayp)
((and (eq t element-type)
(not adjustable)
......@@ -92,18 +92,18 @@
;; If :adjustable is given, the array must be adjustable.
((and adjustable
(not (adjustable-array-p a))
(not (check-values (adjustable-array-p a)))
:fail-adjustable))
;; If :fill-pointer is given, the array must have a fill pointer
((and fill-pointer
(not (array-has-fill-pointer-p a))
(not (check-values (array-has-fill-pointer-p a)))
:fail-has-fill-pointer))
;; If the fill pointer is given as an integer, it must be the value
;; of the fill pointer of the new array
((and (integerp fill-pointer)
(not (eql fill-pointer (fill-pointer a)))
((and (check-values (integerp fill-pointer))
(not (eql fill-pointer (check-values (fill-pointer a))))
:fail-fill-pointer-1))
;; If the fill-pointer argument is t, the fill pointer must be
......@@ -115,7 +115,7 @@
;; If displaced-to another array, check that this is proper
((and
displaced-to
(multiple-value-bind (actual-dt actual-dio)
(multiple-value-bind* (actual-dt actual-dio)
(array-displacement a)
(cond
((not (eq actual-dt displaced-to))
......@@ -124,14 +124,15 @@
:fail-displaced-index-offset)))))
;; Test of array-total-size
((not (eql (array-total-size a)
((not (eql (check-values (array-total-size a))
(reduce #'* dimensions-list :initial-value 1)))
:fail-array-total-size)
;; Test array-row-major-index on all zeros
((and (> (array-total-size a) 0)
(not (eql (apply #'array-row-major-index
a (make-list (array-rank a) :initial-element 0))
(not (eql (check-values
(apply #'array-row-major-index
a (make-list (array-rank a) :initial-element 0)))
0)))
:fail-array-row-major-index-0)
......
......@@ -7,7 +7,7 @@
(deftest compiled-function-p.1
(some #'(lambda (obj)
(if (compiled-function-p obj)
(if (check-values (compiled-function-p obj))
(not (typep obj 'compiled-function))
(typep obj 'compiled-function)))
*universe*)
......@@ -18,8 +18,8 @@
nil)
(deftest compiled-function-p.3
(not (compiled-function-p (compile nil '(lambda (y x) (cons x y)))))
nil)
(notnot-mv (compiled-function-p (compile nil '(lambda (y x) (cons x y)))))
t)
(deftest compiled-function-p.error.1
(classify-error (compiled-function-p))
......
......@@ -6,8 +6,8 @@
(in-package :cl-test)
(deftest complement.1
(not (funcall (complement #'identity) nil))
nil)
(notnot-mv (funcall (complement #'identity) nil))
t)
(deftest complement.2
(funcall (complement #'identity) t)
......@@ -28,11 +28,13 @@
t)
(deftest complement.5
(notnot-mv (complement #'identity))
t)
(deftest complement.error.1
(classify-error (complement))
program-error)
(deftest complement.6
(deftest complement.error.2
(classify-error (complement #'not t))
program-error)
......@@ -116,68 +116,67 @@
;; All the cons-related macros have a macro binding
(deftest macro-bound-cons-macros
(not (every #'macro-function
(list 'push 'pop 'pushnew 'remf)))
nil)
(notnot-mv (every #'macro-function
(list 'push 'pop 'pushnew 'remf)))
t)
;; None of the cons-related functions have macro bindings
(deftest no-cons-fns-are-macros
(some #'macro-function *cons-fns*)
(some #'macro-function *cons-fns*)
nil)
;; Various easy tests of cons
(deftest cons-of-symbols
(cons 'a 'b)
(cons 'a 'b)
(a . b))
(deftest cons-with-nil
(cons 'a nil)
(cons 'a nil)
(a))
;; successive calls to cons produces results that are equal, but not eq
(deftest cons-eq-equal
(let ((x (cons 'a 'b))
(y (cons 'a 'b)))
(and (not (eqt x y))
(equal x y)
t))
(let ((x (cons 'a 'b))
(y (cons 'a 'b)))
(and (not (eqt x y))
(equalt x y)))
t)
;; list can be expressed as a bunch of conses (with nil)
(deftest cons-equal-list
(equal (cons 'a (cons 'b (cons 'c nil)))
(list 'a 'b 'c))
(equalt (cons 'a (cons 'b (cons 'c nil)))
(list 'a 'b 'c))
t)
;; Lists satisfy consp
(deftest consp-list
(not (not (consp '(a))))
(notnot-mv (consp '(a)))
t)
;; cons satisfies consp
(deftest consp-cons
(not (not (consp (cons nil nil))))
(notnot-mv (consp (cons nil nil)))
t)
;; nil is not a consp
(deftest consp-nil
(consp nil)
(consp nil)
nil)
;; The empty list is not a cons
(deftest consp-empty-list
(consp (list))
(consp (list))
nil)
;; A single element list is a cons
(deftest consp-single-element-list
(not (not (consp (list 'a))))
(notnot-mv (consp (list 'a)))
t)
;; For everything in *universe*, it is either an atom, or satisfies
;; consp, but not both
(deftest consp-xor-atom-universe
(notnot
(notnot-mv
(every #'(lambda (x) (or (and (consp x) (not (atom x)))
(and (not (consp x)) (atom x))))
*universe*))
......@@ -185,7 +184,7 @@
;; Everything in type cons satisfies consp, and vice versa
(deftest consp-cons-universe
(check-type-predicate 'consp 'cons)
(check-type-predicate 'consp 'cons)
0)
(deftest consp.error.1
......
......@@ -107,31 +107,31 @@
;; Check listp against various simple cases
(deftest listp-nil
(not (not (listp nil)))
(notnot-mv (listp nil))
t)
(deftest listp-symbol
(listp 'a)
(listp 'a)
nil)
(deftest listp-singleton-list
(not (not (listp '(a))))
(notnot-mv (listp '(a)))
t)
(deftest listp-circular-list
(let ((x (cons nil nil)))
(setf (cdr x) x)
(not (not (listp x))))
(let ((x (cons nil nil)))
(setf (cdr x) x)
(notnot-mv (listp x)))
t)
(deftest listp-longer-list
(not (not (listp '(a b c d e f g h))))
(notnot-mv (listp '(a b c d e f g h)))
t)
;;; Check that (listp x) == (typep x 'list)
(deftest listp-universe
(check-type-predicate 'listp 'list)
(check-type-predicate 'listp 'list)
0)
(deftest listp.error.1
......@@ -148,25 +148,25 @@
;;; These tests are now somewhat redundant
(deftest typep-nil-list
(not (not (typep nil 'list)))
(notnot-mv (typep nil 'list))
t)
(deftest typep-symbol-list
(typep 'a 'list)
(typep 'a 'list)
nil)
(deftest typep-singleton-list-list
(not (not (typep '(a) 'list)))
(notnot-mv (typep '(a) 'list))
t)
(deftest typep-circular-list-list
(let ((x (cons nil nil)))
(setf (cdr x) x)
(not (not (typep x 'list))))
(let ((x (cons nil nil)))
(setf (cdr x) x)
(notnot-mv (typep x 'list)))
t)
(deftest typep-longer-list-list
(not (not (typep '(a b c d e f g h) 'list)))
(notnot-mv (typep '(a b c d e f g h) 'list))
t)
......@@ -174,19 +174,19 @@
;;; make-list
(deftest make-list-empty-1
(make-list 0)
(make-list 0)
nil)
(deftest make-list-empty-2
(make-list 0 :initial-element 'a)
(make-list 0 :initial-element 'a)
nil)
(deftest make-list-no-initial-element
(make-list 6)
(make-list 6)
(nil nil nil nil nil nil))
(deftest make-list-with-initial-element
(make-list 6 :initial-element 'a)
(make-list 6 :initial-element 'a)
(a a a a a a))
(deftest make-list.allow-other-keys.1
......@@ -220,7 +220,7 @@
;; This next test causes ACL 4.3 (Linux) to loop
#-allegro
(deftest make-list-type.error.2
(catch-type-error (make-list 'a))
(classify-error (make-list 'a))
type-error)
(deftest make-list.error.3
......
......@@ -12,15 +12,15 @@
;;; endp
(deftest endp-nil
(not (not (endp nil)))
(notnot-mv (endp nil))
t)
(deftest endp-cons
(endp (cons 'a 'a))
(endp (cons 'a 'a))
nil)
(deftest endp-singleton-list
(endp '(a))
(endp '(a))
nil)
(deftest endp-symbol-error
......
......@@ -178,7 +178,7 @@
;; TAILP-NIL:T in the X3J13 documentation.
(deftest tailp.error.1
(catch-type-error (not (not (tailp 'e (copy-tree '(a b c d . e))))))
(catch-type-error (notnot-mv (tailp 'e (copy-tree '(a b c d . e)))))
t)
(deftest tailp.error.2
......@@ -186,8 +186,8 @@
nil)
(deftest tailp.error.3
(catch-type-error (not (not (tailp 10203040506070
(list* 'a 'b (1- 10203040506071))))))
(catch-type-error (notnot-mv (tailp 10203040506070
(list* 'a 'b (1- 10203040506071)))))
t)
(deftest tailp.error.4
......
......@@ -29,15 +29,16 @@
(a b c . d)
,(make-array '(10))
"ancadas" #\w)))
(not (every
#'(lambda (x)
(let ((result (catch-type-error (member-if #'listp x))))
(or (eqt result 'type-error)
(progn
(format t "~%On ~S: returned ~%~S" x result)
nil))))
test-inputs)))
nil)
(notnot-mv
(every
#'(lambda (x)
(let ((result (catch-type-error (member-if #'listp x))))
(or (eqt result 'type-error)
(progn
(format t "~%On ~S: returned ~%~S" x result)
nil))))
test-inputs)))
t)
(deftest member-if-5
(member-if #'identity '(1 2 3 4 5) :key #'evenp)
......@@ -196,5 +197,3 @@
(deftest member-if-not.error.7
(classify-error (member-if-not #'null '(a b c) 1 2))
program-error)
......@@ -197,13 +197,13 @@
do (progn
(setf x (* x x))
(setf y (* y y))))
(not (not
(or
(eqt x y) ;; if bignums are eq, the test is worthless
(eql (length
(union-with-check
(list x) (list x)))
1)))))
(notnot-mv
(or
(eqt x y) ;; if bignums are eq, the test is worthless
(eql (length
(union-with-check
(list x) (list x)))
1))))
t)
(deftest union-27
......
......@@ -195,12 +195,12 @@
do (progn
(setf x (* x x))
(setf y (* y y))))
(not (not
(or
(eqt x y) ;; if bignums are eq, the test is worthless
(eql (length
(nunion-with-copy (list x) (list x)))
1)))))
(notnot-mv
(or
(eqt x y) ;; if bignums are eq, the test is worthless
(eql (length
(nunion-with-copy (list x) (list x)))
1))))
t)
(deftest nunion-27
......
......@@ -114,61 +114,61 @@
;; the order of the arguments to the test function
;;
(deftest set-exclusive-or-17
(let ((list1 '(a b c d))
(list2 '(e f g h)))
(block fail
(not (not
(set-exclusive-or-with-check
list1 list2
:test #'(lambda (s1 s2)
(when (or (member s1 list2)
(member s2 list1))
(return-from fail 'failed))))))))
(let ((list1 '(a b c d))
(list2 '(e f g h)))
(block fail
(notnot-mv
(set-exclusive-or-with-check
list1 list2
:test #'(lambda (s1 s2)
(when (or (member s1 list2)
(member s2 list1))
(return-from fail 'failed)))))))
t)
(deftest set-exclusive-or-17-a
(let ((list1 '(a b c d))
(list2 '(e f g h)))
(block fail
(not (not
(set-exclusive-or-with-check
list1 list2
:key #'identity
:test #'(lambda (s1 s2)
(when (or (member s1 list2)
(member s2 list1))
(return-from fail 'failed))))))))
(let ((list1 '(a b c d))
(list2 '(e f g h)))
(block fail
(notnot-mv
(set-exclusive-or-with-check
list1 list2
:key #'identity
:test #'(lambda (s1 s2)
(when (or (member s1 list2)
(member s2 list1))
(return-from fail 'failed)))))))
t)
(deftest set-exclusive-or-18
(let ((list1 '(a b c d))
(list2 '(e f g h)))
(block fail
(not (not
(set-exclusive-or-with-check
list1 list2
:test-not
#'(lambda (s1 s2)
(when (or (member s1 list2)
(member s2 list1))
(return-from fail 'failed))
t))))))
(let ((list1 '(a b c d))
(list2 '(e f g h)))
(block fail
(notnot-mv
(set-exclusive-or-with-check
list1 list2
:test-not
#'(lambda (s1 s2)
(when (or (member s1 list2)
(member s2 list1))
(return-from fail 'failed))
t)))))
t)
(deftest set-exclusive-or-18-a
(let ((list1 '(a b c d))
(list2 '(e f g h)))
(block fail
(not (not
(set-exclusive-or-with-check
list1 list2
:key #'identity
:test-not
#'(lambda (s1 s2)
(when (or (member s1 list2)
(member s2 list1))
(return-from fail 'failed))
t))))))
(let ((list1 '(a b c d))
(list2 '(e f g h)))
(block fail
(notnot-mv
(set-exclusive-or-with-check
list1 list2
:key #'identity
:test-not
#'(lambda (s1 s2)
(when (or (member s1 list2)
(member s2 list1))
(return-from fail 'failed))
t)))))
t)
;;; Keyword tests
......@@ -365,61 +365,61 @@
;; the order of the arguments to the test function
;;
(deftest nset-exclusive-or-17
(let ((list1 '(a b c d))
(list2 '(e f g h)))
(block fail
(not (not
(nset-exclusive-or-with-check
list1 list2
:test #'(lambda (s1 s2)
(when (or (member s1 list2)
(member s2 list1))
(return-from fail 'failed))))))))
(let ((list1 '(a b c d))
(list2 '(e f g h)))
(block fail
(notnot-mv
(nset-exclusive-or-with-check
list1 list2
:test #'(lambda (s1 s2)
(when (or (member s1 list2)
(member s2 list1))
(return-from fail 'failed)))))))
t)
(deftest nset-exclusive-or-17-a
(let ((list1 '(a b c d))
(list2 '(e f g h)))
(block fail
(not (not
(nset-exclusive-or-with-check
list1 list2
:key #'identity
:test #'(lambda (s1 s2)
(when (or (member s1 list2)
(member s2 list1))
(return-from fail 'failed))))))))
(let ((list1 '(a b c d))
(list2 '(e f g h)))
(block fail
(notnot-mv
(nset-exclusive-or-with-check
list1 list2
:key #'identity
:test #'(lambda (s1 s2)
(when (or (member s1 list2)
(member s2 list1))
(return-from fail 'failed)))))))
t)
(deftest nset-exclusive-or-18
(let ((list1 '(a b c d))
(list2 '(e f g h)))
(block fail
(not (not
(nset-exclusive-or-with-check
list1 list2
:test-not
#'(lambda (s1 s2)
(when (or (member s1 list2)
(member s2 list1))
(return-from fail 'failed))
t))))))
(let ((list1 '(a b c d))
(list2 '(e f g h)))
(block fail
(notnot-mv
(nset-exclusive-or-with-check
list1 list2
:test-not
#'(lambda (s1 s2)
(when (or (member s1 list2)
(member s2 list1))
(return-from fail 'failed))
t)))))
t)
(deftest nset-exclusive-or-18-a
(let ((list1 '(a b c d))
(list2 '(e f g h)))
(block fail
(not (not
(nset-exclusive-or-with-check
list1 list2
:key #'identity
:test-not
#'(lambda (s1 s2)
(when (or (member s1 list2)
(member s2 list1))
(return-from fail 'failed))
t))))))
(let ((list1 '(a b c d))
(list2 '(e f g h)))
(block fail
(notnot-mv
(nset-exclusive-or-with-check
list1 list2
:key #'identity
:test-not
#'(lambda (s1 s2)
(when (or (member s1 list2)
(member s2 list1))
(return-from fail 'failed))
t)))))
t)
;;; Keyword tests
......
......@@ -129,43 +129,43 @@
;;; Keyword tests
(deftest subsetp.allow-other-keys.1
(notnot (subsetp '(1 2 3 4) '(0 1 2 3 4 5) :bad t :allow-other-keys 67))
(notnot-mv (subsetp '(1 2 3 4) '(0 1 2 3 4 5) :bad t :allow-other-keys 67))
t)
(deftest subsetp.allow-other-keys.2
(notnot (subsetp '(1 2 3 4) '(0 1 2 3 4 5)
(notnot-mv (subsetp '(1 2 3 4) '(0 1 2 3 4 5)
:allow-other-keys #'cons :bad t))
t)
(deftest subsetp.allow-other-keys.3
(notnot (subsetp '(1 2 3 4) '(0 1 2 3 4)
(notnot-mv (subsetp '(1 2 3 4) '(0 1 2 3 4)
:allow-other-keys (make-hash-table)
:bad t
:test #'(lambda (x y) (= (1+ x) y))))
nil)
(deftest subsetp.allow-other-keys.4
(notnot (subsetp '(1 2 3 4) '(0 1 2 3 4 5) :allow-other-keys t))
(notnot-mv (subsetp '(1 2 3 4) '(0 1 2 3 4 5) :allow-other-keys t))
t)
(deftest subsetp.allow-other-keys.5
(notnot (subsetp '(1 2 3 4) '(0 1 2 3 4 5) :allow-other-keys nil))
(notnot-mv (subsetp '(1 2 3 4) '(0 1 2 3 4 5) :allow-other-keys nil))
t)
(deftest subsetp.allow-other-keys.6
(notnot (subsetp '(1 2 3 4) '(0 1 2 3 4 5)
(notnot-mv (subsetp '(1 2 3 4) '(0 1 2 3 4 5)
:allow-other-keys t :bad1 t
:allow-other-keys nil :bad2 t))
t)
(deftest subsetp.keywords.7
(notnot (subsetp '(1 2 3 4) '(0 1 2 3 4)
(notnot-mv (subsetp '(1 2 3 4) '(0 1 2 3 4)
:test #'(lambda (x y) (= (1+ x) y))
:test #'eql))
nil)
(deftest subsetp.keywords.8
(notnot (subsetp '(1 2 3 4 10) '(0 1 2 3 4)
(notnot-mv (subsetp '(1 2 3 4 10) '(0 1 2 3 4)
:key nil
:key #'(lambda (x) (mod x 2))))
nil)
......
......@@ -14,9 +14,13 @@
t)
(deftest constantly.2
(notnot-mv (cl:constantly 1))
t)
(deftest constantly.error.1
(classify-error (cl:constantly))
program-error)
(deftest constantly.3
(deftest constantly.error.2
(classify-error (cl:constantly 1 1))
program-error)
......@@ -25,15 +25,15 @@
nil)
(deftest constantp.2
(notnot (constantp t))
(notnot-mv (constantp t))
t)
(deftest constantp.3
(