Commit e0725c20 authored by pfdietz's avatar pfdietz

Indentation/style changes. Tests for empty implicit PROGNs in case, ccase,...

Indentation/style changes.  Tests for empty implicit PROGNs in case, ccase, ecase.  Added some tests of argument evaluation order to many function calls.
parent 0f52a92a
......@@ -42,3 +42,13 @@
(deftest apply.5
(apply 'cons '(a b))
(a . b))
(deftest apply.6
(let ((x 0) y z)
(values
(apply (progn (setf y (incf x))
#'identity)
(progn (setf z (incf x))
(list 'a)))
x y z))
a 2 1 2)
......@@ -132,6 +132,18 @@
(array-in-bounds-p #(a b c) -1000000000000000000)
nil)
;;; Order of evaluation tests
(deftest array-in-bounds-p.24
(let ((x 0) y z)
(values
(array-in-bounds-p (progn (setf y (incf x))
#())
(progn (setf z (incf x))
10))
x y z))
nil 2 1 2)
;;; Error tests
(deftest array-in-bounds-p.error.1
......
......@@ -22,6 +22,16 @@
collect (array-row-major-index a i)))
(0 1 2 3 4))
(deftest array-row-major-index.4
(let ((x 0) y z
(a #(a b c d e f)))
(values
(array-row-major-index
(progn (setf y (incf x)) a)
(progn (setf z (incf x)) 0))
x y z))
0 2 1 2)
;;; Error tests
(deftest array-row-major-index.error.1
......
......@@ -24,7 +24,7 @@
(deftest bit-and.3
(let* ((s1 (make-array nil :initial-element 0 :element-type 'bit))
(s2 (make-array nil :initial-element 1 :element-type 'bit)))
(values(bit-and s1 s2) s1 s2))
(values (bit-and s1 s2) s1 s2))
#0a0
#0a0
#0a1)
......@@ -218,6 +218,16 @@
#2a((0 0)(1 1))
#2a((0 0)(0 1)))
(deftest bit-and.20
(let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit))
(s2 (make-array 1 :initial-element 0 :element-type 'bit))
(x 0) y z)
(values
(bit-and (progn (setf y (incf x)) s1)
(progn (setf z (incf x)) s2))
x y z))
#*0 2 1 2)
;;; Error tests
(deftest bit-and.error.1
......
......@@ -24,7 +24,7 @@
(deftest bit-andc1.3
(let* ((s1 (make-array nil :initial-element 0 :element-type 'bit))
(s2 (make-array nil :initial-element 1 :element-type 'bit)))
(values(bit-andc1 s1 s2) s1 s2))
(values (bit-andc1 s1 s2) s1 s2))
#0a1
#0a0
#0a1)
......@@ -218,6 +218,16 @@
#2a((0 0)(1 1))
#2a((0 0)(1 0)))
(deftest bit-andc1.20
(let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit))
(s2 (make-array 1 :initial-element 0 :element-type 'bit))
(x 0) y z)
(values
(bit-andc1 (progn (setf y (incf x)) s1)
(progn (setf z (incf x)) s2))
x y z))
#*0 2 1 2)
;;; Error tests
(deftest bit-andc1.error.1
......
......@@ -24,7 +24,7 @@
(deftest bit-andc2.3
(let* ((s1 (make-array nil :initial-element 0 :element-type 'bit))
(s2 (make-array nil :initial-element 1 :element-type 'bit)))
(values(bit-andc2 s1 s2) s1 s2))
(values (bit-andc2 s1 s2) s1 s2))
#0a0
#0a0
#0a1)
......@@ -218,6 +218,16 @@
#2a((0 0)(1 1))
#2a((0 1)(0 0)))
(deftest bit-andc2.20
(let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit))
(s2 (make-array 1 :initial-element 0 :element-type 'bit))
(x 0) y z)
(values
(bit-andc2 (progn (setf y (incf x)) s1)
(progn (setf z (incf x)) s2))
x y z))
#*0 2 1 2)
;;; Error tests
(deftest bit-andc2.error.1
......
......@@ -25,7 +25,7 @@
(deftest bit-eqv.3
(let* ((s1 (make-array nil :initial-element 0 :element-type 'bit))
(s2 (make-array nil :initial-element 1 :element-type 'bit)))
(values(bit-eqv s1 s2) s1 s2))
(values (bit-eqv s1 s2) s1 s2))
#0a0
#0a0
#0a1)
......@@ -219,6 +219,16 @@
#2a((0 0)(1 1))
#2a((1 0)(0 1)))
(deftest bit-eqv.20
(let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit))
(s2 (make-array 1 :initial-element 0 :element-type 'bit))
(x 0) y z)
(values
(bit-eqv (progn (setf y (incf x)) s1)
(progn (setf z (incf x)) s2))
x y z))
#*1 2 1 2)
;;; Error tests
(deftest bit-eqv.error.1
......
......@@ -24,7 +24,7 @@
(deftest bit-ior.3
(let* ((s1 (make-array nil :initial-element 0 :element-type 'bit))
(s2 (make-array nil :initial-element 1 :element-type 'bit)))
(values(bit-ior s1 s2) s1 s2))
(values (bit-ior s1 s2) s1 s2))
#0a1
#0a0
#0a1)
......@@ -218,6 +218,16 @@
#2a((0 0)(1 1))
#2a((0 1)(1 1)))
(deftest bit-ior.20
(let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit))
(s2 (make-array 1 :initial-element 0 :element-type 'bit))
(x 0) y z)
(values
(bit-ior (progn (setf y (incf x)) s1)
(progn (setf z (incf x)) s2))
x y z))
#*0 2 1 2)
;;; Error tests
(deftest bit-ior.error.1
......
......@@ -24,7 +24,7 @@
(deftest bit-nand.3
(let* ((s1 (make-array nil :initial-element 0 :element-type 'bit))
(s2 (make-array nil :initial-element 1 :element-type 'bit)))
(values(bit-nand s1 s2) s1 s2))
(values (bit-nand s1 s2) s1 s2))
#0a1
#0a0
#0a1)
......@@ -218,6 +218,16 @@
#2a((0 0)(1 1))
#2a((1 1)(1 0)))
(deftest bit-nand.20
(let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit))
(s2 (make-array 1 :initial-element 0 :element-type 'bit))
(x 0) y z)
(values
(bit-nand (progn (setf y (incf x)) s1)
(progn (setf z (incf x)) s2))
x y z))
#*1 2 1 2)
;;; Error tests
(deftest bit-nand.error.1
......
......@@ -24,7 +24,7 @@
(deftest bit-nor.3
(let* ((s1 (make-array nil :initial-element 0 :element-type 'bit))
(s2 (make-array nil :initial-element 1 :element-type 'bit)))
(values(bit-nor s1 s2) s1 s2))
(values (bit-nor s1 s2) s1 s2))
#0a0
#0a0
#0a1)
......@@ -218,6 +218,16 @@
#2a((0 0)(1 1))
#2a((1 0)(0 0)))
(deftest bit-nor.20
(let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit))
(s2 (make-array 1 :initial-element 0 :element-type 'bit))
(x 0) y z)
(values
(bit-nor (progn (setf y (incf x)) s1)
(progn (setf z (incf x)) s2))
x y z))
#*1 2 1 2)
;;; Error tests
(deftest bit-nor.error.1
......
......@@ -24,7 +24,7 @@
(deftest bit-orc1.3
(let* ((s1 (make-array nil :initial-element 0 :element-type 'bit))
(s2 (make-array nil :initial-element 1 :element-type 'bit)))
(values(bit-orc1 s1 s2) s1 s2))
(values (bit-orc1 s1 s2) s1 s2))
#0a1
#0a0
#0a1)
......@@ -218,6 +218,16 @@
#2a((0 0)(1 1))
#2a((1 0)(1 1)))
(deftest bit-orc1.20
(let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit))
(s2 (make-array 1 :initial-element 0 :element-type 'bit))
(x 0) y z)
(values
(bit-orc1 (progn (setf y (incf x)) s1)
(progn (setf z (incf x)) s2))
x y z))
#*1 2 1 2)
;;; Error tests
(deftest bit-orc1.error.1
......
......@@ -24,7 +24,7 @@
(deftest bit-orc2.3
(let* ((s1 (make-array nil :initial-element 0 :element-type 'bit))
(s2 (make-array nil :initial-element 1 :element-type 'bit)))
(values(bit-orc2 s1 s2) s1 s2))
(values (bit-orc2 s1 s2) s1 s2))
#0a0
#0a0
#0a1)
......@@ -218,6 +218,16 @@
#2a((0 0)(1 1))
#2a((1 1)(0 1)))
(deftest bit-orc2.20
(let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit))
(s2 (make-array 1 :initial-element 0 :element-type 'bit))
(x 0) y z)
(values
(bit-orc2 (progn (setf y (incf x)) s1)
(progn (setf z (incf x)) s2))
x y z))
#*1 2 1 2)
;;; Error tests
(deftest bit-orc2.error.1
......
......@@ -24,7 +24,7 @@
(deftest bit-xor.3
(let* ((s1 (make-array nil :initial-element 0 :element-type 'bit))
(s2 (make-array nil :initial-element 1 :element-type 'bit)))
(values(bit-xor s1 s2) s1 s2))
(values (bit-xor s1 s2) s1 s2))
#0a1
#0a0
#0a1)
......@@ -218,6 +218,16 @@
#2a((0 0)(1 1))
#2a((0 1)(1 0)))
(deftest bit-xor.20
(let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit))
(s2 (make-array 1 :initial-element 0 :element-type 'bit))
(x 0) y z)
(values
(bit-xor (progn (setf y (incf x)) s1)
(progn (setf z (incf x)) s2))
x y z))
#*0 2 1 2)
;;; Error tests
(deftest bit-xor.error.1
......
......@@ -108,3 +108,26 @@
(1 0 0 1 1 0 0 0 1 1)
(1 0 0 1 1 0 0 0 1 1)
(1 0 0 1 1 0 0 0 1 1))
;;; Order of evaluation tests
(deftest bit.9
(let ((x 0) y z
(b (copy-seq #*01010)))
(values
(bit (progn (setf y (incf x)) b)
(progn (setf z (incf x)) 1))
x y z))
1 2 1 2)
(deftest bit.10
(let ((x 0) y z w
(b (copy-seq #*01010)))
(values
(setf (bit (progn (setf y (incf x)) b)
(progn (setf z (incf x)) 1))
(progn (setf w (incf x)) 0))
b
x y z w))
0 #*00010 3 1 2 3)
......@@ -153,3 +153,16 @@
(deftest case.31
(case (values 'b 'c) (c 0) ((a b) 10) (t 20))
10)
(deftest case.32
(case 'a (a) (t 'b))
nil)
(deftest case.33
(case 'a (b 'b) (t))
nil)
(deftest case.34
(case 'a (b 'b) (otherwise))
nil)
......@@ -166,5 +166,9 @@
x))
y b)
(deftest ccase.30
(ccase 'a (a))
nil)
;;; Need to add tests for continuability of the error,
;;; and resetting of the place.
......@@ -35,6 +35,15 @@
#'(lambda (c1 c2) (not (char= c1 c2))))
t)
(deftest char=.5
(let ((i 0) a b c)
(values
(char= (progn (setq a (incf i)) #\a)
(progn (setq b (incf i)) #\a)
(progn (setq c (incf i)) #\b))
i a b c))
nil 3 1 2 3)
(deftest char/=.1
(is-ordered-by +code-chars+ #'char/=)
t)
......@@ -52,6 +61,15 @@
(is-ordered-by +rev-code-chars+ #'char/=)
t)
(deftest char/=.5
(let ((i 0) a b c)
(values
(char/= (progn (setq a (incf i)) #\a)
(progn (setq b (incf i)) #\b)
(progn (setq c (incf i)) #\b))
i a b c))
nil 3 1 2 3)
(deftest char<=.1
(loop for c across +code-chars+
always (char<= c c))
......@@ -85,6 +103,15 @@
(notnot-mv (or (char<= #\9 #\a) (char<= #\z #\0)))
t)
(deftest char<=.9
(let ((i 0) a b c)
(values
(char<= (progn (setq a (incf i)) #\a)
(progn (setq b (incf i)) #\b)
(progn (setq c (incf i)) #\a))
i a b c))
nil 3 1 2 3)
(deftest char<.1
(loop for c across +code-chars+
never (char< c c))
......@@ -118,6 +145,14 @@
(notnot-mv (or (char< #\9 #\a) (char< #\z #\0)))
t)
(deftest char<.9
(let ((i 0) a b c)
(values
(char< (progn (setq a (incf i)) #\a)
(progn (setq b (incf i)) #\b)
(progn (setq c (incf i)) #\a))
i a b c))
nil 3 1 2 3)
(deftest char>=.1
(loop for c across +code-chars+
......@@ -152,6 +187,15 @@
(notnot-mv (or (char>= #\a #\9) (char>= #\0 #\z)))
t)
(deftest char>=.9
(let ((i 0) a b c)
(values
(char>= (progn (setq a (incf i)) #\b)
(progn (setq b (incf i)) #\a)
(progn (setq c (incf i)) #\b))
i a b c))
nil 3 1 2 3)
(deftest char>.1
(loop for c across +code-chars+
never (char> c c))
......@@ -185,6 +229,15 @@
(notnot-mv (or (char> #\a #\9) (char> #\0 #\z)))
t)
(deftest char>.9
(let ((i 0) a b c)
(values
(char> (progn (setq a (incf i)) #\b)
(progn (setq b (incf i)) #\a)
(progn (setq c (incf i)) #\b))
i a b c))
nil 3 1 2 3)
;;; Case-insensitive comparisons
(deftest char-equal.1
......@@ -213,6 +266,15 @@
(not (char-equal c1 c2)))))
t)
(deftest char-equal.5
(let ((i 0) a b c)
(values
(char-equal (progn (setq a (incf i)) #\a)
(progn (setq b (incf i)) #\a)
(progn (setq c (incf i)) #\b))
i a b c))
nil 3 1 2 3)
(deftest char-not-equal.1
(is-ordered-by +code-chars+ #'(lambda (c1 c2)
(or (char= (char-downcase c1)
......@@ -236,6 +298,15 @@
(char-not-equal c1 c2))))
t)
(deftest char-not-equal.5
(let ((i 0) a b c)
(values
(char-not-equal (progn (setq a (incf i)) #\a)
(progn (setq b (incf i)) #\b)
(progn (setq c (incf i)) #\b))
i a b c))
nil 3 1 2 3)
(deftest char-not-greaterp.1
(loop for c across +code-chars+
always (char-not-greaterp c c))
......@@ -269,6 +340,15 @@
(notnot-mv (or (char-not-greaterp #\9 #\a) (char-not-greaterp #\z #\0)))
t)
(deftest char-not-greaterp.9
(let ((i 0) a b c)
(values
(char-not-greaterp (progn (setq a (incf i)) #\a)
(progn (setq b (incf i)) #\b)
(progn (setq c (incf i)) #\a))
i a b c))
nil 3 1 2 3)
(deftest char-lessp.1
(loop for c across +code-chars+
never (char-lessp c c))
......@@ -302,6 +382,15 @@
(notnot-mv (or (char-lessp #\9 #\a) (char-lessp #\z #\0)))
t)
(deftest char-lessp.9
(let ((i 0) a b c)
(values
(char-lessp (progn (setq a (incf i)) #\a)
(progn (setq b (incf i)) #\b)
(progn (setq c (incf i)) #\a))
i a b c))
nil 3 1 2 3)
(deftest char-not-lessp.1
(loop for c across +code-chars+
always (char-not-lessp c c))
......@@ -336,6 +425,15 @@
(notnot-mv (or (char-not-lessp #\a #\9) (char-not-lessp #\0 #\z)))
t)
(deftest char-not-lessp.9
(let ((i 0) a b c)
(values
(char-not-lessp (progn (setq a (incf i)) #\b)
(progn (setq b (incf i)) #\a)
(progn (setq c (incf i)) #\b))
i a b c))
nil 3 1 2 3)
(deftest char-greaterp.1
(loop for c across +code-chars+
never (char-greaterp c c))
......@@ -369,3 +467,12 @@
(deftest char-greaterp.8
(notnot-mv (or (char-greaterp #\a #\9) (char-greaterp #\0 #\z)))
t)
(deftest char-greaterp.9
(let ((i 0) a b c)
(values
(char-greaterp (progn (setq a (incf i)) #\b)
(progn (setq b (incf i)) #\a)
(progn (setq c (incf i)) #\b))
i a b c))
nil 3 1 2 3)
......@@ -78,6 +78,24 @@
s)
"aaaXa")
(deftest char.11
(let ((i 0) a b)
(values
(char (progn (setf a (incf i)) "abc")
(progn (setf b (incf i)) 1))
i a b))
#\b 2 1 2)
(deftest char.12
(let ((i 0) a b c (s (make-string 5 :initial-element #\z)))
(values
(setf
(char (progn (setf a (incf i)) s)
(progn (setf b (incf i)) 1))
(progn (setf c (incf i)) #\a))
s i a b c))
#\a "zazzz" 3 1 2 3)
;;; Tests of schar
(deftest schar.1
......@@ -126,3 +144,21 @@
(setf (schar s 2) #\X)
s)
"xxXxxx")
(deftest schar.11
(let ((i 0) a b)
(values
(schar (progn (setf a (incf i)) "abc")
(progn (setf b (incf i)) 1))
i a b))
#\b 2 1 2)
(deftest schar.12
(let ((i 0) a b c (s (copy-seq "zzzzz")))
(values
(setf
(schar (progn (setf a (incf i)) s)
(progn (setf b (incf i)) 1))
(progn (setf c (incf i)) #\a))
s i a b c))
#\a "zazzz" 3 1 2 3)
......@@ -1205,7 +1205,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; copy-symbol
(deftest copy-symbol-1
(deftest copy-symbol.1
(notnot-mv
(every
#'(lambda (x)
......@@ -1221,7 +1221,7 @@
'(nil t a b |a| |123|)))
t)
(deftest copy-symbol-2
(deftest copy-symbol.2
(progn
(setf (symbol-plist '|foo|) '(a b c d))
(makunbound '|foo|)
......@@ -1242,7 +1242,7 @@
'(nil t a b |foo| |a| |123|))))
t)
(deftest copy-symbol-3
(deftest copy-symbol.3
(progn
(setf (symbol-plist '|foo|) '(a b c d))
(setf (symbol-value '|a|) 12345)
......@@ -1269,15 +1269,26 @@
'(nil t a b |foo| |a| |123|))))
t)
(deftest copy-symbol-4
(deftest copy-symbol.4
(eqt (copy-symbol 'a) (copy-symbol 'a))
nil)
(deftest copy-symbol-5
(deftest copy-symbol.5
(let ((i 0) x y (s '#:|x|))
(let ((s2 (copy-symbol
(progn (setf x (incf i)) s)
(progn (setf y (incf i)) nil))))
(values
(symbol-name s2)
(eq s s2)
i x y)))
"x" nil 2 1 2)
(deftest copy-symbol.error.1
(classify-error (copy-symbol))
program-error)
(deftest copy-symbol-6
(deftest copy-symbol.error.2
(classify-error (copy-symbol 'a t 'foo))
program-error)
......
......@@ -130,6 +130,14 @@
(funcall (coerce '(lambda () 10) 'function))
10)
(deftest coerce.23
(let ((i 0) a b)
(values
(coerce (progn (setf a (incf i)) 10)
(progn (setf b (incf i)) 'single-float))
i a b))
10.0f0 2 1 2)
;;; Error tests
;;; (deftest coerce.error.1
......
......@@ -184,6 +184,26 @@
#*01100
nil)
(deftest concatenate.31
(let ((i 0) w x y z)
(values
(concatenate (progn (setf w (incf i)) 'string)
(progn (setf x (incf i)) "abc")
(progn (setf y (incf i)) "def")
(progn (setf z (incf i)) "ghi"))
i w x y z))
"abcdefghi" 4 1 2 3 4)
(deftest concatenate.32
(let ((i 0) x y z)
(values
(concatenate 'string
(progn (setf x (incf i)) "abc")
(progn (setf y (incf i)) "def")
(progn (setf z (incf i)) "ghi"))
i x y z))
"abcdefghi" 3 1 2 3)
;;; Error tests
(deftest concatenate-error.1
......
......@@ -12,39 +12,39 @@
;; Test the subtype relationships between null, list, cons and atom
;;
(deftest subtypep-null-list
(subtypep* 'null 'list)
(subtypep* 'null 'list)
t t)
(deftest subtypep-cons-list
(subtypep* 'cons 'list)
(subtypep* 'cons 'list)
t t)
(deftest subtypep-null-cons
(subtypep* 'null 'cons)
(subtypep* 'null 'cons)
nil t)
(deftest subtypep-cons-null
(subtypep* 'cons 'null)
(subtypep* 'cons 'null)
nil t)
(deftest subtypep-null-atom
(subtypep* 'null 'atom)
(subtypep* 'null 'atom)
t t)
(deftest subtypep-cons-atom
(subtypep* 'cons 'atom)
(subtypep* 'cons 'atom)
nil t)
(deftest subtypep-atom-cons
(subtypep* 'atom 'cons)
(subtypep* 'atom 'cons)
nil t)
(deftest subtypep-atom-list
(subtypep* 'atom 'list)
(subtypep* 'atom 'list)
nil t)
(deftest subtypep-list-atom
(subtypep* 'list 'atom)
(subtypep* 'list 'atom)
nil t)
;;
......@@ -52,56 +52,56 @@
;; are those for which the null predice is true.
;;
(deftest null-null-universe
(check-type-predicate 'null 'null)
(check-type-predicate 'null 'null)
0)
(defvar *cons-fns*
(list 'cons 'consp 'atom 'rplaca 'rplacd
'car 'cdr 'caar 'cadr 'cdar 'cddr
'caaar 'caadr 'cadar 'caddr
'cdaar 'cdadr 'cddar 'cdddr
'caaaar 'caaadr 'caadar 'caaddr
'cadaar 'cadadr 'caddar 'cadddr
'cdaaar 'cdaadr 'cdadar 'cdaddr
'cddaar 'cddadr 'cdddar 'cddddr
'copy-tree 'sublis 'nsublis
'subst 'subst-if 'subst-if-not
'nsubst 'nsubst-if 'nsubst-if-not
'tree-equal
'copy-list
'list
'list*
'list-length
'listp
'make-list
'first 'second 'third 'fourth
'fifth 'sixth 'seventh 'eighth 'ninth 'tenth
'nth
'endp
'null
'nconc
'append
'revappend 'nreconc
'butlast 'nbutlast