;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jan 21 05:11:31 2003 ;;;; Contains: Auxiliary functions for array tests (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 dio-p)) (let ((a (check-values (apply #'make-array dimensions options))) (rank (length dimensions-list))) (cond ((not (typep a 'array)) :fail-not-array) ((not (typep a (find-class 'array))) :fail-not-array-class) ((not (typep a '(array *))) :fail-not-array2) ((not (typep a `(array * ,dimensions-list))) :fail-not-array3) ((not (typep a `(array * *))) :fail-not-array4) ((not (typep a `(array ,element-type))) :fail-not-array5) ((not (typep a `(array ,element-type *))) :fail-not-array6) ; #-gcl ((not (typep a `(array ,element-type ,rank))) :fail-not-array7) ((not (typep a `(array ,element-type ,dimensions-list))) :fail-not-array8) ((not (typep a `(array ,element-type ,(mapcar (constantly '*) dimensions-list)))) :fail-not-array9) ((loop for i from 0 below (min 10 rank) thereis (let ((x (append (subseq dimensions-list 0 i) (list '*) (subseq dimensions-list (1+ i))))) (or (not (typep a `(array * ,x))) (not (typep a `(array ,element-type ,x)))))) :fail-not-array10) ((not (check-values (arrayp a))) :fail-not-arrayp) ((and ;; (eq t element-type) (not adjustable) (not fill-pointer) (not displaced-to) (cond ((not (typep a 'simple-array)) :fail-not-simple-array) ((not (typep a '(simple-array *))) :fail-not-simple-array2) ((not (typep a `(simple-array * ,dimensions-list))) :fail-not-simple-array3) ((not (typep a `(simple-array * *))) :fail-not-simple-array4) ((not (typep a `(simple-array ,element-type))) :fail-not-simple-array5) ((not (typep a `(simple-array ,element-type *))) :fail-not-simple-array6) #-gcl ((not (typep a `(simple-array ,element-type ,rank))) :fail-not-array7) ((not (typep a `(simple-array ,element-type ,dimensions-list))) :fail-not-simple-array8) ((not (typep a `(simple-array ,element-type ,(mapcar (constantly '*) dimensions-list)))) :fail-not-simple-array9) ))) ;; If the array is a vector, check that... ((and (eql rank 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) rank)) :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 (check-values (adjustable-array-p a))) :fail-adjustable)) ;; If :fill-pointer is given, the array must have a fill pointer ((and fill-pointer (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 (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 ;; 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))))) ;; Test of array-total-size ((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 (check-values (apply #'array-row-major-index a (make-list (array-rank a) :initial-element 0))) 0))) :fail-array-row-major-index-0) ;; For the last entry ((and (> (array-total-size a) 0) (not (eql (apply #'array-row-major-index a (mapcar #'1- dimensions-list)) (1- (reduce #'* dimensions-list :initial-value 1))))) :fail-array-row-major-index-last) ;; No problems -- return the array (t a))))