Commit b147b330 authored by pfdietz's avatar pfdietz

Added more array tests.

parent 687686fd
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Mon Jan 20 21:25:22 2003
;;;; Contains: Tests for ADJUSTABLE-ARRAY-P
(in-package :cl-test)
(deftest adjustable-array-p.1
(notnot (adjustable-array-p (make-array '(5) :adjustable t)))
t)
(deftest adjustable-array-p.2
(notnot (adjustable-array-p (make-array nil :adjustable t)))
t)
(deftest adjustable-array-p.3
(notnot (adjustable-array-p (make-array '(2 3) :adjustable t)))
t)
(deftest adjustable-array-p.4
(notnot (adjustable-array-p (make-array '(2 2 2) :adjustable t)))
t)
(deftest adjustable-array-p.5
(notnot (adjustable-array-p (make-array '(2 2 2 2) :adjustable t)))
t)
;;; Error tests
(deftest adjustable-array-p.error.1
(classify-error (adjustable-array-p))
program-error)
(deftest adjustable-array-p.error.2
(classify-error (adjustable-array-p "aaa" nil))
program-error)
(deftest adjustable-array-p.error.3
(classify-error (adjustable-array-p 10))
type-error)
(deftest adjustable-array-p.error.4
(loop for e in *mini-universe*
unless (or (typep e 'array)
(eq 'type-error (classify-error** `(adjustable-array-p ',e))))
collect e)
nil)
......@@ -144,6 +144,11 @@ the condition to go uncaught if it cannot be classified."
(package-error () 'package-error)
(type-error () 'type-error)
(control-error () 'control-error)
(stream-error () 'stream-error)
(reader-error () 'reader-error)
(file-error () 'file-error)
(control-error () 'control-error)
(cell-error () 'cell-error)
)))
(defun classify-error** (form)
......
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Tue Jan 21 05:11:31 2003
;;;; Contains: Auxiliary functions for array tests
(in-package :cl-test)
(defun make-array-check-upgrading (type)
(subtypep* type (array-element-type (make-array 0 :element-type type))))
(defun subtypep-or-unknown (subtype supertype)
(multiple-value-bind (is-subtype is-known)
(subtypep subtype supertype)
(or (not is-known) (notnot is-subtype))))
(defun make-array-with-checks (dimensions
&rest options
&key
(element-type t element-type-p)
(initial-contents nil initial-contents-p)
(initial-element nil initial-element-p)
(adjustable nil)
(fill-pointer nil)
(displaced-to nil)
(displaced-index-offset 0 dio-p)
&aux
(dimensions-list (if (listp dimensions)
dimensions
(list dimensions))))
"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))
(let ((a (apply #'make-array dimensions options)))
(cond
((not (typep a 'array)) :fail-not-array)
((and (eq t element-type)
(not adjustable)
(not fill-pointer)
(not displaced-to)
(not (typep a 'simple-array)))
:fail-not-simple-array)
;; If the array is a vector, check that...
((and (eq (length dimensions-list) 1)
(cond
;; It's in type vector
((not (typep a 'vector))
:fail-not-vector)
;; If the element type is a subtype of BIT, then it's a
;; bit vector...
((and (subtypep 'bit element-type)
(subtypep element-type 'bit)
(or (not (bit-vector-p a))
(not (typep a 'bit-vector))))
:fail-not-bit-vector)
;; If not adjustable, fill pointered, or displaced,
;; then it's a simple vector or simple bit vector
;; (if the element-type is appropriate)
((and (not adjustable)
(not fill-pointer)
(not displaced-to)
(cond
((and (eq t element-type)
(or (not (simple-vector-p a))
(not (typep a 'simple-vector))))
:fail-not-simple-vector)
((and (subtypep 'bit element-type)
(subtypep element-type 'bit)
(or (not (simple-bit-vector-p a))
(not (typep a 'simple-bit-vector))))
:fail-not-simple-bit-vector) ))) )))
;; The dimensions of the array must be initialized properly
((not (equal (array-dimensions a) dimensions-list))
:fail-array-dimensions)
;; The rank of the array must equal the number of dimensions
((not (equal (array-rank a) (length dimensions-list)))
:fail-array-rank)
;; Arrays other than vectors cannot have fill pointers
((and (not (equal (array-rank a) 1))
(array-has-fill-pointer-p a))
:fail-non-vector-fill-pointer)
;; The actual element type must be a supertype of the element-type
;; argument
((not (subtypep-or-unknown element-type (array-element-type a)))
:failed-array-element-type)
;; If :adjustable is given, the array must be adjustable.
((and adjustable
(not (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))
: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)))
:fail-fill-pointer-1))
;; If the fill-pointer argument is t, the fill pointer must be
;; set to the vector size.
((and (eq fill-pointer t)
(not (eql (first dimensions-list) (fill-pointer a)))
:fail-fill-pointer-2))
;; If displaced-to another array, check that this is proper
((and
displaced-to
(multiple-value-bind (actual-dt actual-dio)
(array-displacement a)
(cond
((not (eq actual-dt displaced-to))
:fail-displacement-1)
((not (eql actual-dio displaced-index-offset))
:fail-displaced-index-offset)))))
;; No problems -- return the array
(t a))))
\ No newline at end of file
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Tue Jan 21 06:55:14 2003
;;;; Contains: Tests of ARRAY-DIMENSION
(in-package :cl-test)
;;; array-dimension is also tested by the tests in make-array.lsp
(deftest array-dimension.1
(array-dimension #(0 1 2 3) 0)
4)
(deftest array-dimension.2
(array-dimension "abcdef" 0)
6)
(deftest array-dimension.3
(array-dimension #2a((1 2 3 4)(5 6 7 8)) 0)
2)
(deftest array-dimension.4
(array-dimension #2a((1 2 3 4)(5 6 7 8)) 1)
4)
(deftest array-dimension.5
(let ((a (make-array '(10) :fill-pointer 5)))
(array-dimension a 0))
10)
(deftest array-dimension.6
(let ((a (make-array '(10) :adjustable t)))
(values
(array-dimension a 0)
(progn
(adjust-array a '(20))
(array-dimension a 0))))
10 20)
;;; Error tests
(deftest array-dimension.error.1
(classify-error (array-dimension))
program-error)
(deftest array-dimension.error.2
(classify-error (array-dimension #(a b c)))
program-error)
(deftest array-dimension.error.3
(classify-error (array-dimension #(a b c) 0 nil))
program-error)
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Tue Jan 21 06:59:37 2003
;;;; Contains: Tests of ARRAY-DIMENSIONS
(in-package :cl-test)
;;; The tests in make-array.lsp also test this function
(deftest array-dimensions.1
(array-dimensions #0aX)
nil)
(deftest array-dimensions.2
(array-dimensions #(a b c d))
(4))
(deftest array-dimensions.3
(array-dimensions #*0011011011)
(10))
(deftest array-dimensions.4
(array-dimensions "abcdef")
(6))
(deftest array-dimensions.5
(array-dimensions #2a((1 2 3)(4 5 6)(7 8 9)(10 11 12)))
(4 3))
(deftest array-dimensions.6
(let ((a (make-array '(2 3 4) :adjustable t)))
(values (array-dimension a 0)
(array-dimension a 1)
(array-dimension a 2)))
2 3 4)
(deftest array-dimensions.7
(let ((a (make-array '(10) :fill-pointer 5)))
(array-dimension a 0))
10)
;;; Error tests
(deftest array-dimensions.error.1
(classify-error (array-dimensions))
program-error)
(deftest array-dimensions.error.2
(classify-error (array-dimensions #(a b c) nil))
program-error)
(deftest array-dimension.error.3
(loop for e in *mini-universe*
unless (or (typep e 'array)
(eq 'type-error
(classify-error** `(array-dimensions ',e))))
collect e)
nil)
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Tue Jan 21 06:20:51 2003
;;;; Contains: Tests for ARRAY-DISPLACEMENT
(in-package :cl-test)
;;; The tests in make-array.lsp also test array-displacement
;;; The standard is contradictory about whether arrays created with
;;; :displaced-to NIL should return NIL as their primary value or
;;; not. I will assume (as per Kent Pitman's comment on comp.lang.lisp)
;;; that an implementation is free to implement all arrays as actually
;;; displaced. Therefore, I've omitted all the tests of not-expressly
;;; displaced arrays.
;;; Behavior on expressly displaced arrays
(deftest array-displacement.7
(let* ((a (make-array '(10)))
(b (make-array '(10) :displaced-to a)))
(multiple-value-bind (dt disp)
(array-displacement b)
(and (eqt a dt)
(eqlt disp 0))))
t)
(deftest array-displacement.8
(let* ((a (make-array '(10)))
(b (make-array '(5) :displaced-to a :displaced-index-offset 2)))
(multiple-value-bind (dt disp)
(array-displacement b)
(and (eqt a dt)
(eqlt disp 2))))
t)
(deftest array-displacement.9
(let* ((a (make-array '(10) :element-type 'base-char))
(b (make-array '(5) :displaced-to a :displaced-index-offset 2
:element-type 'base-char)))
(multiple-value-bind (dt disp)
(array-displacement b)
(and (eqt a dt)
(eqlt disp 2))))
t)
(deftest array-displacement.10
(let* ((a (make-array '(10) :element-type 'base-char))
(b (make-array '(5) :displaced-to a
:element-type 'base-char)))
(multiple-value-bind (dt disp)
(array-displacement b)
(and (eqt a dt)
(eqlt disp 0))))
t)
(deftest array-displacement.11
(let* ((a (make-array '(10) :element-type 'bit))
(b (make-array '(5) :displaced-to a :displaced-index-offset 2
:element-type 'bit)))
(multiple-value-bind (dt disp)
(array-displacement b)
(and (eqt a dt)
(eqlt disp 2))))
t)
(deftest array-displacement.12
(let* ((a (make-array '(10) :element-type 'bit))
(b (make-array '(5) :displaced-to a
:element-type 'bit)))
(multiple-value-bind (dt disp)
(array-displacement b)
(and (eqt a dt)
(eqlt disp 0))))
t)
(deftest array-displacement.13
(let* ((a (make-array '(10) :element-type '(integer 0 255)))
(b (make-array '(5) :displaced-to a :displaced-index-offset 2
:element-type '(integer 0 255))))
(multiple-value-bind (dt disp)
(array-displacement b)
(and (eqt a dt)
(eqlt disp 2))))
t)
(deftest array-displacement.14
(let* ((a (make-array '(10) :element-type '(integer 0 255)))
(b (make-array '(5) :displaced-to a
:element-type '(integer 0 255))))
(multiple-value-bind (dt disp)
(array-displacement b)
(and (eqt a dt)
(eqlt disp 0))))
t)
;;; Error tests
(deftest array-displacement.error.1
(classify-error (array-displacement))
program-error)
(deftest array-displacement.error.2
(classify-error (array-displacement #(a b c) nil))
program-error)
(deftest array-displacement.error.3
(loop for e in *mini-universe*
unless (or (typep e 'array)
(eq 'type-error
(classify-error** `(array-displacement ',e))))
collect e)
nil)
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Tue Jan 21 19:57:29 2003
;;;; Contains: Tests for ARRAY-IN-BOUNDS-P
(in-package :cl-test)
(deftest array-in-bounds-p.1
(array-in-bounds-p #() 0)
nil)
(deftest array-in-bounds-p.2
(array-in-bounds-p #() -1)
nil)
(deftest array-in-bounds-p.3
(let ((a #(a b c d)))
(loop for i from 0 to 4 collect (notnot (array-in-bounds-p a i))))
(t t t t nil))
(deftest array-in-bounds-p.4
(notnot (array-in-bounds-p #0aNIL))
t)
(deftest array-in-bounds-p.5
(array-in-bounds-p "" 0)
nil)
(deftest array-in-bounds-p.6
(array-in-bounds-p "" -1)
nil)
(deftest array-in-bounds-p.7
(let ((a "abcd"))
(loop for i from 0 to 4 collect (notnot (array-in-bounds-p a i))))
(t t t t nil))
(deftest array-in-bounds-p.8
(array-in-bounds-p #* 0)
nil)
(deftest array-in-bounds-p.9
(array-in-bounds-p #* -1)
nil)
(deftest array-in-bounds-p.10
(let ((a #*0110))
(loop for i from 0 to 4 collect (notnot (array-in-bounds-p a i))))
(t t t t nil))
;; Fill pointer tests
(deftest array-in-bounds-p.11
(let ((a (make-array '(10) :fill-pointer 5)))
(loop for i from -1 to 10 collect (notnot (array-in-bounds-p a i))))
(nil t t t t t t t t t t nil))
(deftest array-in-bounds-p.12
(let ((a (make-array '(10) :fill-pointer 5 :element-type 'bit :initial-element 0)))
(loop for i from -1 to 10 collect (notnot (array-in-bounds-p a i))))
(nil t t t t t t t t t t nil))
(deftest array-in-bounds-p.13
(let ((a (make-array '(10) :fill-pointer 5 :element-type 'base-char :initial-element #\x)))
(loop for i from -1 to 10 collect (notnot (array-in-bounds-p a i))))
(nil t t t t t t t t t t nil))
(deftest array-in-bounds-p.14
(let ((a (make-array '(10) :fill-pointer 5 :element-type 'character :initial-element #\x)))
(loop for i from -1 to 10 collect (notnot (array-in-bounds-p a i))))
(nil t t t t t t t t t t nil))
;;; Displaced arrays
(deftest array-in-bounds-p.15
(let* ((a1 (make-array '(20)))
(a2 (make-array '(10) :displaced-to a1)))
(loop for i from -1 to 10 collect (notnot (array-in-bounds-p a2 i))))
(nil t t t t t t t t t t nil))
(deftest array-in-bounds-p.16
(let* ((a1 (make-array '(20) :element-type 'bit :initial-element 0))
(a2 (make-array '(10) :displaced-to a1 :element-type 'bit)))
(loop for i from -1 to 10 collect (notnot (array-in-bounds-p a2 i))))
(nil t t t t t t t t t t nil))
(deftest array-in-bounds-p.17
(let* ((a1 (make-array '(20) :element-type 'character :initial-element #\x))
(a2 (make-array '(10) :displaced-to a1 :element-type 'character)))
(loop for i from -1 to 10 collect (notnot (array-in-bounds-p a2 i))))
(nil t t t t t t t t t t nil))
;;; Multidimensional arrays
(deftest array-in-bounds-p.18
(let ((a (make-array '(3 4))))
(loop for i from -1 to 3 collect
(loop for j from -1 to 4 collect
(notnot (array-in-bounds-p a i j)))))
((nil nil nil nil nil nil)
(nil t t t t nil)
(nil t t t t nil)
(nil t t t t nil)
(nil nil nil nil nil nil)))
(deftest array-in-bounds-p.19
(let ((a (make-array '(1 3 4) :adjustable t)))
(loop for i from -1 to 3 collect
(loop for j from -1 to 4 collect
(notnot (array-in-bounds-p a 0 i j)))))
((nil nil nil nil nil nil)
(nil t t t t nil)
(nil t t t t nil)
(nil t t t t nil)
(nil nil nil nil nil nil)))
;;; Very large indices
(deftest array-in-bounds-p.20
(array-in-bounds-p #(a b c) (1+ most-positive-fixnum))
nil)
(deftest array-in-bounds-p.21
(array-in-bounds-p #(a b c) (1- most-negative-fixnum))
nil)
(deftest array-in-bounds-p.22
(array-in-bounds-p #(a b c) 1000000000000000000)
nil)
(deftest array-in-bounds-p.23
(array-in-bounds-p #(a b c) -1000000000000000000)
nil)
;;; Error tests
(deftest array-in-bounds-p.error.1
(classify-error (array-in-bounds-p))
program-error)
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Tue Jan 21 20:32:57 2003
;;;; Contains: Tests for ARRAY-RANK
(in-package :cl-test)
;;; Most tests for ARRAY-RANK are in make-array.lsp
(deftest array-rank.1
(array-rank #0aNIL)
0)
(deftest array-rank.2
(loop for e in *universe*
when (and (typep e 'vector)
(not (eql (array-rank e) 1)))
collect e)
nil)
;;; Error tests
(deftest array-rank.error.1
(classify-error (array-rank))
program-error)
(deftest array-rank.error.2
(classify-error (array-rank #(a b c) nil))
program-error)
(deftest array-rank.error.3
(loop for e in *mini-universe*
when (and (not (typep e 'array))
(not (eq (classify-error** `(array-rank ',e))
'type-error)))
collect e)
nil)
......@@ -133,7 +133,15 @@
(load "cons-test-25.lsp")
;;; Tests on arrays
(compile-and-load "array-aux.lsp")
(load "make-array.lsp")
(load "adjustable-array-p.lsp")
(load "array-displacement.lsp")
(load "adjustable-array-p.lsp")
(load "array-dimension.lsp")
(load "array-dimensions.lsp")
(load "array-in-bounds-p.lsp")
(load "array-rank.lsp")
;;; Tests of packages
......
......@@ -5,77 +5,7 @@
(in-package :cl-test)
(defun make-array-check-upgrading (type)
(subtypep* type (array-element-type (make-array 0 :element-type type))))
(defun make-array-with-checks (dimensions
&rest options
&key
(element-type t element-type-p)
(initial-contents nil intial-contents-p)
(initial-element nil initial-element-p)
(adjustable nil)
(fill-pointer nil)
(displaced-to nil)
(displaced-index-offset 0 dio-p)
&aux
(dimensions-list (if (listp dimensions)
dimensions
(list dimensions))))
"Call MAKE-ARRAY and do sanity tests on the output."
(let ((a (apply #'make-array dimensions options)))
(cond
((not (typep a 'array)) :fail-not-array)
((and (eq t element-type)
(not adjustable)
(not fill-pointer)
(not displaced-to)
(not (typep a 'simple-array)))
:fail-not-simple-array)
((and (eq (length dimensions-list) 1)
(cond
((not (typep a 'vector))
:fail-not-vector)
((and (subtypep 'bit element-type)
(subtypep element-type 'bit)
(or (not (bit-vector-p a))
(not (typep a 'bit-vector))))
:fail-not-bit-vector)
((and (not adjustable)
(not fill-pointer)
(not displaced-to)
(cond
((and (eq t element-type)
(or (not (simple-vector-p a))
(not (typep a 'simple-vector))))
:fail-not-simple-vector)
((and (subtypep 'bit element-type)
(subtypep element-type 'bit)
(or (not (simple-bit-vector-p a))
(not (typep a 'simple-bit-vector))))
:fail-not-simple-bit-vector) ))) )))
((not (equal (array-dimensions a) dimensions-list))
:fail-array-dimensions)
((not (equal (array-rank a) (length dimensions-list)))
:fail-array-rank)
((multiple-value-bind (sub good)
(subtypep element-type (array-element-type a))
(and good
(not sub)
:failed-array-element-type)))
((and adjustable
(not (adjustable-array-p a))
:fail-adjustable))
((and fill-pointer
(not (array-has-fill-pointer-p a))
:fail-has-fill-pointer))
((and (integerp fill-pointer)
(not (eql fill-pointer (fill-pointer a)))
:fail-fill-pointer-1))
((and (eq fill-pointer t)
(not (eql (first dimensions-list) (fill-pointer a)))
:fail-fill-pointer-2))
(t a))))
;;; See array-aux.lsp for auxiliary functions
(deftest make-array.1
(let ((a (make-array-with-checks 10)))
......@@ -283,6 +213,17 @@
:nonsense-argument t)
#(x x x x))
(deftest make-array.28
(let ((*package* (find-package :cl-test)))
(let ((len (1- (min 10000 array-rank-limit))))
(equalpt (make-array (make-list len :initial-element 1) :initial-element 'x)
(read-from-string (concatenate
'string
(format nil "#~dA" len)
(make-string len :initial-element #\()
"x"
(make-string len :initial-element #\)))))))
t)
;;; Adjustable arrays
......@@ -561,6 +502,44 @@
:adjustable t))
#(f g h i j k l m))
(deftest make-array.displaced.27
(let ((a (make-array '(10)
:initial-contents '(1 2 3 4 5 6 7 8 9 10)
:fill-pointer t)))
(make-array-with-checks '(2 4) :displaced-to a))
#2a((1 2 3 4) (5 6 7 8)))
(deftest make-array.displaced.28
(let ((a (make-array '(10)
:initial-contents '(1 2 3 4 5 6 7 8 9 10)
:fill-pointer 4)))
(make-array-with-checks '(2 4) :displaced-to a))
#2a((1 2 3 4) (5 6 7 8)))
(deftest make-array.displaced.29
(let ((a (make-array '(10) :initial-element 0)))
(prog1
(make-array-with-checks '(2 4) :displaced-to a)
(loop for i below 10 do (setf (aref a i) (1+ i)))))
#2a((1 2 3 4) (5 6 7 8)))
(deftest make-array.displaced.30
(let* ((a1 (make-array '(10) :initial-element 0))
(a2 (make-array '(10) :displaced-to a1)))
(prog1
(make-array-with-checks '(2 4) :displaced-to a2)
(loop for i below 10 do (setf (aref a2 i) (1+ i)))))
#2a((1 2 3 4) (5 6 7 8)))
(deftest make-array.displaced.31
(let* ((a1 (make-array '(10) :initial-element 0))
(a2 (make-array '(10) :displaced-to a1)))
(prog1
(make-array-with-checks '(2 4) :displaced-to a2)
(loop for i below 10 do (setf (aref a1 i) (1+ i)))))
#2a((1 2 3 4) (5 6 7 8)))
;;; Keywords tests
(deftest make-array.allow-other-keys.1
......
......@@ -314,3 +314,23 @@
*random-states*
nil)))
(defvar *mini-universe*
(remove-duplicates
(mapcar #'first
(list *symbols*
*numbers*
*characters*
(mapcar #'copy-seq *strings*)
*conses*
*condition-objects*
*package-objects*
*arrays*
*hash-tables*
*pathnames*
*streams*
*readtables*
*structures*
*functions*
*random-states*))))
Markdown is supported
0%