Commit 8bedc5b0 authored by pfdietz's avatar pfdietz

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 @@
(deftest abs.21
(abs #c(-3.0l0 4.0l0))
5.0l0)
(deftest abs.22
(macrolet ((%m (z) z))
(abs (expand-in-current-env (%m -4))))
4)
......@@ -37,6 +37,18 @@
(acons #\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
(let ((i 0) x y z)
(values
......
......@@ -78,6 +78,10 @@
collect type)
nil)
(deftest acos.9
(macrolet ((%m (z) z)) (not (not (> (acos (expand-in-current-env (%m 0))) 0))))
t)
;;; FIXME
;;; Add accuracy tests
......
......@@ -68,6 +68,10 @@
collect (list x1 x2 rlist)))
nil)
(deftest acosh.7
(macrolet ((%m (z) z)) (not (not (complexp (acosh (expand-in-current-env (%m 0)))))))
t)
;;; FIXME
;;; Add accuracy tests here
......
......@@ -104,6 +104,32 @@
(adjoin 10 '(1 2 3) :test-not #'<)
(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
(adjoin 'a '(b c) :test #'eql :test-not #'eql))
......
......@@ -231,6 +231,116 @@
a2)
#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
(def-adjust-array-test adjust-array.adjustable.1
......
......@@ -25,6 +25,12 @@
(notnot (adjustable-array-p (make-array '(2 2 2 2) :adjustable 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
(let ((i 0) x)
(values
......
......@@ -47,6 +47,23 @@
(eq (append x nil) x))
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
(deftest append.order.1
......
......@@ -48,6 +48,21 @@
(apply 'cons '(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
(let ((i 0) x y z)
(values
......
......@@ -74,6 +74,22 @@
(notnot (member sym symbols)))
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
(deftest apropos-list.error.1
......
......@@ -69,6 +69,27 @@
(notnot (search "CAR" s :test #'string-equal)))
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
(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 @@
(array-dimension a 0))))
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
(let ((i 0) a b)
(values
......
......@@ -39,6 +39,11 @@
(array-dimension a 0))
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
(deftest array-dimensions.error.1
......
......@@ -94,6 +94,20 @@
(eqlt disp 0))))
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
(let* ((a (make-array '(10)))
(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 @@
(array-in-bounds-p #(a b c) -1000000000000000000)
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
(deftest array-in-bounds-p.order.1
......
......@@ -16,6 +16,10 @@
(eql (array-rank e) 1))))
nil)
(deftest array-rank.3
(macrolet ((%m (z) z)) (array-rank (expand-in-current-env (%m "abc"))))
1)
(deftest array-rank.order.1
(let ((i 0) a)
(values
......
......@@ -22,6 +22,18 @@
collect (array-row-major-index a i)))
(0 1 2 3 4))
(deftest array-row-major-index.4
(macrolet
((%m (z) z))
(array-row-major-index (expand-in-current-env (%m #(a b c))) 1))
1)
(deftest array-row-major-index.5
(macrolet
((%m (z) z))
(array-row-major-index #(a b c) (expand-in-current-env (%m 1))))
1)
(deftest array-row-major-index.order.1
(let ((x 0) y z
(a #(a b c d e f)))
......
......@@ -27,6 +27,11 @@
(array-total-size #2a((1 2 3)(4 5 6)(7 8 9)(a b c)))
12)
(deftest array-total-size.6
(macrolet ((%m (z) z))
(array-total-size (expand-in-current-env (%m #(a b c)))))
3)
(deftest array-total-size.order.1
(let ((i 0) a)
(values
......
......@@ -31,6 +31,10 @@
(check-type-predicate #'arrayp 'array)
nil)
(deftest arrayp.7
(macrolet ((%m (z) z)) (arrayp (expand-in-current-env (%m 0))))
nil)
(deftest arrayp.order.1
(let ((i 0) a)
(values
......
......@@ -63,6 +63,14 @@
always (eql (ash j j) -1))
t)
(deftest ash.6
(macrolet
((%m (z) z))
(values
(ash (expand-in-current-env (%m 3)) 1)
(ash 1 (expand-in-current-env (%m 3)))))
6 8)
(deftest ash.order.1
(let ((i 0) x y)
(values (ash (progn (setf x (incf i)) 1)
......
......@@ -78,6 +78,10 @@
collect type)
nil)
(deftest asin.9
(macrolet ((%m (z) z)) (asin (expand-in-current-env (%m 0.0))))
0.0)
;;; FIXME
;;; Add accuracy tests
......
......@@ -66,6 +66,10 @@
collect (list x1 x2 rlist)))
nil)
(deftest asinh.7
(macrolet ((%m (z) z)) (asinh (expand-in-current-env (%m 0.0))))
0.0)
;;; FIXME
;;; Add accuracy tests here
......
......@@ -28,17 +28,17 @@
(6 . c))
(deftest assoc-if-not.3
(let* ((x (copy-list '((1 . a) nil (3 . b) (6 . c) (7 . d))))
(xcopy (make-scaffold-copy x))
(result (assoc-if-not #'oddp x)))
(and
(check-scaffold-copy x xcopy)
(eqt result (fourth x))
result))
(let* ((x (copy-list '((1 . a) nil (3 . b) (6 . c) (7 . d))))
(xcopy (make-scaffold-copy x))
(result (assoc-if-not #'oddp x)))
(and
(check-scaffold-copy x xcopy)
(eqt result (fourth x))
result))
(6 . c))
(deftest assoc-if-not.4
(assoc-if-not #'identity '((a . b) nil (c . d) (nil . e) (f . g)))
(assoc-if-not #'identity '((a . b) nil (c . d) (nil . e) (f . g)))
(nil . e))
;;; Order of argument evaluation tests
......@@ -96,6 +96,29 @@
(assoc-if-not #'identity '((a . 1) (nil . 2) (c . 3)) :key nil :key #'null)
(nil . 2))
;;; Macro env tests
(deftest assoc-if-not.env.1
(macrolet
((%m (z) z))
(let ((alist '((1 . a) (3 . b) (4 . c) (6 . d))))
(values
(assoc-if-not (expand-in-current-env (%m 'oddp)) alist)
(assoc-if-not (expand-in-current-env (%m #'oddp)) alist)
(assoc-if-not 'oddp (expand-in-current-env (%m alist))))))
(4 . c)
(4 . c)
(4 . c))
(deftest assoc-if-not.env.2
(macrolet
((%m (z) z))
(let ((alist '((1 . a) (3 . b) (4 . c) (6 . d))))
(values
(assoc-if-not 'evenp alist (expand-in-current-env (%m :key)) #'1+)
(assoc-if-not #'evenp alist :key (expand-in-current-env (%m '1+)))
;;; Error tests
(deftest assoc-if-not.error.1
......
......@@ -125,6 +125,10 @@
(char-type-error-check #'alpha-char-p)
t)
(deftest alpha-char-p.4
(macrolet ((%m (z) z)) (alpha-char-p (expand-in-current-env (%m #\?))))
nil)
(deftest alpha-char-p.order.1
(let ((i 0))
(values
......@@ -165,6 +169,10 @@
(alphanumericp.5.body)
t)
(deftest alphanumbericp.6
(macrolet ((%m (z) z)) (alphanumericp (expand-in-current-env (%m #\=))))
nil)
(deftest alphanumericp.order.1
(let ((i 0))
(values
......
......@@ -204,3 +204,14 @@
(eql (/ frneg) frpos)))
collect (list i rpos rneg (float rpos one) (float rneg one))))
nil)
;;; Test that explicit calls to macroexpand in subforms
;;; are done in the correct environment
(deftest /.13
(macrolet ((%m (z) z))
(values
(/ (expand-in-current-env (%m 1/2)))
(/ (expand-in-current-env (%m 2)) 3)
(/ 5 (expand-in-current-env (%m 7)))))
2 2/3 5/7)
......@@ -14,6 +14,7 @@
(load "array-displacement.lsp")
(load "array-dimension.lsp")
(load "array-dimensions.lsp")
(load "array-element-type.lsp")
(load "array-in-bounds-p.lsp")
(load "array-misc.lsp")
(load "array-rank.lsp")
......
......@@ -111,3 +111,6 @@
(load "real.lsp")
(load "upgraded-complex-part-type.lsp")
(load "arithmetic-error.lsp")
......@@ -95,6 +95,13 @@
collect x))
nil)
;;; Test that explicit calls to macroexpand in subforms
;;; are done in the correct environment
(deftest minus.9
(macrolet ((%m (z) z)) (- (expand-in-current-env (%m 1))))
-1)