Commit 8bedc5b0 authored by pfdietz's avatar pfdietz
Browse files

Begin adding (compiler) macro expansion tests for

builtin functions.  Add tests for arithmetic-error
and its accessors.  Add separate files for array-element-type,
array-has-fill-pointer-p.
parent 91fc7832
...@@ -172,3 +172,8 @@ ...@@ -172,3 +172,8 @@
(deftest abs.21 (deftest abs.21
(abs #c(-3.0l0 4.0l0)) (abs #c(-3.0l0 4.0l0))
5.0l0) 5.0l0)
(deftest abs.22
(macrolet ((%m (z) z))
(abs (expand-in-current-env (%m -4))))
4)
...@@ -37,6 +37,18 @@ ...@@ -37,6 +37,18 @@
(acons #\R :foo :bar) (acons #\R :foo :bar)
((#\R . :foo) . :bar)) ((#\R . :foo) . :bar))
(deftest acons.7
(macrolet ((%m (z) z)) (acons (expand-in-current-env (%m 'a)) 'b '(c)))
((a . b) c))
(deftest acons.8
(macrolet ((%m (z) z)) (acons 'a (expand-in-current-env (%m 'b)) '(c)))
((a . b) c))
(deftest acons.9
(macrolet ((%m (z) z)) (acons 'a 'b (expand-in-current-env (%m '(c)))))
((a . b) c))
(deftest acons.order.1 (deftest acons.order.1
(let ((i 0) x y z) (let ((i 0) x y z)
(values (values
......
...@@ -78,6 +78,10 @@ ...@@ -78,6 +78,10 @@
collect type) collect type)
nil) nil)
(deftest acos.9
(macrolet ((%m (z) z)) (not (not (> (acos (expand-in-current-env (%m 0))) 0))))
t)
;;; FIXME ;;; FIXME
;;; Add accuracy tests ;;; Add accuracy tests
......
...@@ -68,6 +68,10 @@ ...@@ -68,6 +68,10 @@
collect (list x1 x2 rlist))) collect (list x1 x2 rlist)))
nil) nil)
(deftest acosh.7
(macrolet ((%m (z) z)) (not (not (complexp (acosh (expand-in-current-env (%m 0)))))))
t)
;;; FIXME ;;; FIXME
;;; Add accuracy tests here ;;; Add accuracy tests here
......
...@@ -104,6 +104,32 @@ ...@@ -104,6 +104,32 @@
(adjoin 10 '(1 2 3) :test-not #'<) (adjoin 10 '(1 2 3) :test-not #'<)
(1 2 3)) (1 2 3))
;;; Test that :key satisfies the description in 17.2.1
;;; This contradicts other parts of the spec, particularly
;;; PUSHNEW, so the test is commented out.
;;; (deftest adjoin.23
;;; (adjoin 1 '(1 2 3) :key '1+)
;;; (1 1 2 3))
(deftest adjoin.24
(macrolet ((%m (z) z))
(values
(adjoin (expand-in-current-env (%m 'a)) '(b c))
(adjoin 'a (expand-in-current-env (%m '(b c))))
(adjoin 'a '(b c) (expand-in-current-env (%m :test)) 'eql)
(adjoin 'a '(a a) (expand-in-current-env (%m :test-not)) 'eql)
(adjoin 'a '(b c) :test (expand-in-current-env (%m 'eql)))
(adjoin 'a '(b c) :test (expand-in-current-env (%m #'eql)))
(adjoin 1 '(1 2 3) :key (expand-in-current-env (%m 'identity)))
))
(a b c)
(a b c)
(a b c)
(a a a)
(a b c)
(a b c)
(1 2 3))
(defharmless adjoin.test-and-test-not.1 (defharmless adjoin.test-and-test-not.1
(adjoin 'a '(b c) :test #'eql :test-not #'eql)) (adjoin 'a '(b c) :test #'eql :test-not #'eql))
......
...@@ -231,6 +231,116 @@ ...@@ -231,6 +231,116 @@
a2) a2)
#2a((#\1 #\2 #\3)(#\3 #\4 #\5))) #2a((#\1 #\2 #\3)(#\3 #\4 #\5)))
;;; Macro expansion tests
(deftest adjust-array.24
(macrolet
((%m (z) z))
(let ((a (make-array '(4) :initial-contents '(a b c d))))
(adjust-array (expand-in-current-env (%m a)) '(4))))
#(a b c d))
(deftest adjust-array.25
(macrolet
((%m (z) z))
(let ((a (make-array '(4) :initial-contents '(a b c d))))
(adjust-array a (expand-in-current-env (%m '(4))))))
#(a b c d))
(deftest adjust-array.26
(macrolet
((%m (z) z))
(let ((a (make-array '(4) :initial-contents '(a b c d))))
(adjust-array a '(4) (expand-in-current-env (%m :element-type)) t)))
#(a b c d))
(deftest adjust-array.27
(macrolet
((%m (z) z))
(let ((a (make-array '(4) :initial-contents '(a b c d))))
(adjust-array a '(4) :element-type
(expand-in-current-env (%m t)))))
#(a b c d))
(deftest adjust-array.28
(macrolet
((%m (z) z))
(let ((a (make-array '(4) :initial-contents '(a b c d))))
(adjust-array a '(6) (expand-in-current-env (%m :initial-element)) 17)))
#(a b c d 17 17))
(deftest adjust-array.29
(macrolet
((%m (z) z))
(let ((a (make-array '(4) :initial-contents '(a b c d))))
(adjust-array a '(7) :initial-element (expand-in-current-env (%m 5)))))
#(a b c d 5 5 5))
(deftest adjust-array.30
(macrolet
((%m (z) z))
(let ((a (make-array '(4) :initial-contents '(a b c d))))
(adjust-array a '(6) (expand-in-current-env (%m :initial-contents))
'(1 2 3 4 5 6))))
#(1 2 3 4 5 6))
(deftest adjust-array.31
(macrolet
((%m (z) z))
(let ((a (make-array '(4) :initial-contents '(a b c d))))
(adjust-array a '(3) :initial-contents
(expand-in-current-env (%m "ABC")))))
#(#\A #\B #\C))
(deftest adjust-array.32
(macrolet
((%m (z) z))
(let ((a (make-array '(4) :initial-contents '(a b c d))))
(adjust-array a '(4) (expand-in-current-env (%m :fill-pointer)) nil)))
#(a b c d))
(deftest adjust-array.33
(macrolet
((%m (z) z))
(let ((a (make-array '(4) :initial-contents '(a b c d))))
(adjust-array a '(4) :fill-pointer (expand-in-current-env (%m nil)))))
#(a b c d))
(deftest adjust-array.34
(macrolet
((%m (z) z))
(let ((a (make-array '(4) :initial-contents '(a b c d))))
(adjust-array a '(4) (expand-in-current-env (%m :displaced-to)) nil)))
#(a b c d))
(deftest adjust-array.35
(macrolet
((%m (z) z))
(let ((a (make-array '(4) :initial-contents '(a b c d))))
(adjust-array a '(4) :displaced-to
(expand-in-current-env (%m nil)))))
#(a b c d))
(deftest adjust-array.36
(macrolet
((%m (z) z))
(let ((a (make-array '(4) :initial-contents '(a b c d)))
(c (make-array '(8) :initial-contents '(1 2 3 4 5 6 7 8))))
(adjust-array a '(3) :displaced-to c
(expand-in-current-env (%m :displaced-index-offset))
2)))
#(3 4 5))
(deftest adjust-array.37
(macrolet
((%m (z) z))
(let ((a (make-array '(4) :initial-contents '(a b c d)))
(c (make-array '(8) :initial-contents '(1 2 3 4 5 6 7 8))))
(adjust-array a '(5) :displaced-to c
:displaced-index-offset
(expand-in-current-env (%m 1)))))
#(2 3 4 5 6))
;;; Adjust an adjustable array ;;; Adjust an adjustable array
(def-adjust-array-test adjust-array.adjustable.1 (def-adjust-array-test adjust-array.adjustable.1
......
...@@ -25,6 +25,12 @@ ...@@ -25,6 +25,12 @@
(notnot (adjustable-array-p (make-array '(2 2 2 2) :adjustable t))) (notnot (adjustable-array-p (make-array '(2 2 2 2) :adjustable t)))
t) t)
(deftest adjustable-array-p.6
(macrolet ((%m (z) z))
(let ((a (make-array '(5) :adjustable t)))
(notnot (adjustable-array-p (expand-in-current-env (%m a))))))
t)
(deftest adjustable-array-p.order.1 (deftest adjustable-array-p.order.1
(let ((i 0) x) (let ((i 0) x)
(values (values
......
...@@ -47,6 +47,23 @@ ...@@ -47,6 +47,23 @@
(eq (append x nil) x)) (eq (append x nil) x))
nil) nil)
;;; Compiler macro expansion in correct env
(deftest append.8
(macrolet ((%m (z) z))
(append (expand-in-current-env (%m '(a b c)))))
(a b c))
(deftest append.9
(macrolet ((%m (z) z))
(append (expand-in-current-env (%m (list 1 2 3))) (list 4 5 6)))
(1 2 3 4 5 6))
(deftest append.10
(macrolet ((%m (z) z))
(append (list 1 2 3) (expand-in-current-env (%m (list 4 5 6)))))
(1 2 3 4 5 6))
;;; Order of evaluation tests ;;; Order of evaluation tests
(deftest append.order.1 (deftest append.order.1
......
...@@ -48,6 +48,21 @@ ...@@ -48,6 +48,21 @@
(apply 'cons '(a b)) (apply 'cons '(a b))
(a . b)) (a . b))
(deftest apply.6
(macrolet ((%m (z) z))
(apply (expand-in-current-env (%m 'cons)) 1 2 nil))
(1 . 2))
(deftest apply.7
(macrolet ((%m (z) z))
(apply #'cons (expand-in-current-env (%m 1)) '(2)))
(1 . 2))
(deftest apply.8
(macrolet ((%m (z) z))
(apply #'cons (expand-in-current-env (%m '(1 2)))))
(1 . 2))
(deftest apply.order.1 (deftest apply.order.1
(let ((i 0) x y z) (let ((i 0) x y z)
(values (values
......
...@@ -74,6 +74,22 @@ ...@@ -74,6 +74,22 @@
(notnot (member sym symbols))) (notnot (member sym symbols)))
t) t)
(deftest apropos-list.8
(let ((*package* (find-package "COMMON-LISP")))
(macrolet
((%m (z) z))
(intersection '(car)
(apropos-list (expand-in-current-env (%m "CAR"))))))
(car))
(deftest apropos-list.9
(macrolet
((%m (z) z))
(intersection '(car)
(apropos-list "CAR" (expand-in-current-env
(%m (find-package "COMMON-LISP"))))))
(car))
;;; Error tests ;;; Error tests
(deftest apropos-list.error.1 (deftest apropos-list.error.1
......
...@@ -69,6 +69,27 @@ ...@@ -69,6 +69,27 @@
(notnot (search "CAR" s :test #'string-equal))) (notnot (search "CAR" s :test #'string-equal)))
t) t)
(deftest apropos.9
(macrolet
((%m (z) z))
(let ((s (with-output-to-string
(*standard-output*)
(assert (null (multiple-value-list
(apropos (expand-in-current-env (%m "CAR")))))))))
(notnot (search "CAR" s :test #'string-equal))))
t)
(deftest apropos.10
(macrolet
((%m (z) z))
(let ((s (with-output-to-string
(*standard-output*)
(assert (null (multiple-value-list
(apropos "CAR"
(expand-in-current-env (%m nil)))))))))
(notnot (search "CAR" s :test #'string-equal))))
t)
;;; Error tests ;;; Error tests
(deftest apropos.error.1 (deftest apropos.error.1
......
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Contains: Tests of ARITHMETIC-ERROR condition and associated accessors
(in-package :cl-test)
(deftest arithmethic-error.1
(let ((a (make-condition 'arithmetic-error
:operation '/
:operands '(0 0))))
(values
(notnot (typep a 'arithmetic-error))
(notnot (typep a (find-class 'arithmetic-error)))
(multiple-value-list (arithmetic-error-operation a))
(multiple-value-list (arithmetic-error-operands a))))
t t (/) ((0 0)))
(deftest arithmethic-error.2
(let ((a (make-condition 'arithmetic-error
:operation #'/
:operands '(0 0))))
(values
(notnot (typep a 'arithmetic-error))
(notnot (typep a 'error))
(notnot (typep a 'serious-condition))
(notnot (typep a 'condition))
(notnot (typep a (find-class 'arithmetic-error)))
(notnot (typep (arithmetic-error-operation a) 'function))
(funcall (arithmetic-error-operation a) 1 2)
(multiple-value-list (arithmetic-error-operands a))))
t t t t t t 1/2 ((0 0)))
(deftest arithmetic-error.3
(let ((a (make-condition 'arithmetic-error
:operation '/
:operands '(0 0))))
(macrolet
((%m (z) z))
(values
(arithmetic-error-operation (expand-in-current-env (%m a)))
(arithmetic-error-operands (expand-in-current-env (%m a))))))
/ (0 0))
;;; Error tests
(deftest arithmetic-error-operation.error.1
(signals-error (arithmetic-error-operation) program-error)
t)
(deftest arithmetic-error-operation.error.2
(signals-error (arithmetic-error-operation
(make-condition 'arithmetic-error :operation '/
:operands '(1 0))
nil)
program-error)
t)
(deftest arithmetic-error-operands.error.1
(signals-error (arithmetic-error-operands) program-error)
t)
(deftest arithmetic-error-operands.error.2
(signals-error (arithmetic-error-operands
(make-condition 'arithmetic-error :operation '/
:operands '(1 0))
nil)
program-error)
t)
...@@ -37,6 +37,17 @@ ...@@ -37,6 +37,17 @@
(array-dimension a 0)))) (array-dimension a 0))))
10 20) 10 20)
(deftest array-dimension.7
(macrolet ((%m (z) z))
(array-dimension (expand-in-current-env (%m "abc")) 0))
3)
(deftest array-dimension.8
(macrolet ((%m (z) z))
(array-dimension #2a((a b)(c d)(e f))
(expand-in-current-env (%m 0))))
3)
(deftest array-dimension.order.1 (deftest array-dimension.order.1
(let ((i 0) a b) (let ((i 0) a b)
(values (values
......
...@@ -39,6 +39,11 @@ ...@@ -39,6 +39,11 @@
(array-dimension a 0)) (array-dimension a 0))
10) 10)
(deftest array-dimensions.8
(macrolet ((%m (z) z)) (array-dimensions
(expand-in-current-env (%m #2a((a b)(c d)(e f))))))
(3 2))
;;; Error tests ;;; Error tests
(deftest array-dimensions.error.1 (deftest array-dimensions.error.1
......
...@@ -94,6 +94,20 @@ ...@@ -94,6 +94,20 @@
(eqlt disp 0)))) (eqlt disp 0))))
t) t)
(deftest array-displacement.15
(let* ((a (make-array '(10) :initial-contents '(a b c d e f g h i j)))
(b (make-array '(5) :displaced-to a :displaced-index-offset 2)))
(macrolet
((%m (z) z))
(multiple-value-bind
(x y)
(array-displacement (expand-in-current-env (%m b)))
(values (eqlt x a) y))))
t 2)
;;; FIXME: Add tests for other kinds of specialized arrays
;;; (character, other integer types, float types, complex types)
(deftest array-displacement.order.1 (deftest array-displacement.order.1
(let* ((a (make-array '(10))) (let* ((a (make-array '(10)))
(b (make-array '(10) :displaced-to a)) (b (make-array '(10) :displaced-to a))
......
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Contains: Tests of the function ARRAY-ELEMENT-TYPE
(in-package :cl-test)
;;; Mosts tests are in other files, incidental to testing of
;;; other things
(deftest array-element-type.1
(macrolet ((%m (z) z))
(notnot (array-element-type (expand-in-current-env (%m #(a b c))))))
t)
(deftest array-element-type.order.1
(let ((i 0))
(array-element-type (progn (incf i) #(a b c)))
i)
1)
;;; Error tests
(deftest array-element-type.error.1
(signals-error (array-element-type) program-error)
t)
(deftest array-element-type.error.2
(signals-error (array-element-type #(a b c) nil) program-error)
t)
(deftest array-element-type.error.3
(check-type-error #'array-element-type #'arrayp)
nil)
(deftest array-element-type.error.4
(signals-type-error x nil (array-element-type x))
t)
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Contains: Tests of the function ARRAY-HAS-FILL-POINTER-P
(in-package :cl-test)
;;; Many tests are in other files, incidental to testing of
;;; other things
(deftest array-has-fill-pointer-p.1
(array-has-fill-pointer-p #0a1)
nil)
(deftest array-has-fill-pointer-p.2
(array-has-fill-pointer-p #2a((a b)(c d)))
nil)
(deftest array-has-fill-pointer-p.3
(array-has-fill-pointer-p #3a(((a))))
nil)
(deftest array-has-fill-pointer-p.4
(array-has-fill-pointer-p #4a((((a)))))
nil)
(deftest array-has-fill-pointer-p.5
(macrolet
((%m (z) z))
(array-has-fill-pointer-p (expand-in-current-env (%m #2a((a b)(c d))))))
nil)
(deftest array-has-fill-pointer-p.order.1
(let ((i 0))
(array-has-fill-pointer-p (progn (incf i) #(a b c)))
i)
1)
;;; Error tests
(deftest array-has-fill-pointer-p.error.1
(signals-error (array-has-fill-pointer-p) program-error)
t)
(deftest array-has-fill-pointer-p.error.2
(signals-error (array-has-fill-pointer-p #(a b c) nil) program-error)
t)
(deftest array-has-fill-pointer-p.error.3
(check-type-error #'array-has-fill-pointer-p #'arrayp)
nil)
(deftest array-has-fill-pointer-p.error.4
(signals-type-error x nil (array-has-fill-pointer-p x))
t)
...@@ -132,6 +132,17 @@ ...@@ -132,6 +132,17 @@
(array-in-bounds-p #(a b c) -1000000000000000000) (array-in-bounds-p #(a b c) -1000000000000000000)
nil) nil)
;;; Macro expansion
(deftest array-in-bounds-p.24
(macrolet ((%m (z) z)) (array-in-bounds-p (expand-in-current-env (%m #(a b))) 3))
nil)
(deftest array-in-bounds-p.25
(macrolet ((%m (z) z))
(array-in-bounds-p #(a b) (expand-in-current-env (%m 2))))
nil)
;;; Order of evaluation tests ;;; Order of evaluation tests
(deftest array-in-bounds-p.order.1 (deftest array-in-bounds-p.order.1
......
...@@ -16,6 +16,10 @@ ...@@ -16,6 +16,10 @@
(eql (array-rank e) 1)))) (eql (array-rank e) 1))))
nil) nil)
(deftest array-rank.3
(macrolet ((%m (z) z)) (array-rank (expand-in-current-env (%m "abc"))))
1)
(deftest array-rank.order.1 (deftest array-rank.order.1
(let ((i 0) a) (let ((i 0) a)
(values (values
......
...@@ -22,6 +22,18 @@ ...@@ -22,6 +22,18 @@
collect (array-row-major-index a i))) collect (array-row-major-index a i)))
(0 1 2 3 4)) (0 1 2 3 4))
(deftest array-row-major-index.4
(macrolet