array-aux.lsp 6.61 KB
Newer Older
pfdietz's avatar
pfdietz committed
1
2
3
4
5
6
7
8
9
10
11
;-*- 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)
12
  (multiple-value-bind* (is-subtype is-known)
pfdietz's avatar
pfdietz committed
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
      (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
pfdietz's avatar
pfdietz committed
32
		   initial-element initial-element-p dio-p))
33
34
  (let ((a (check-values (apply #'make-array dimensions options)))
	(rank (length dimensions-list)))
pfdietz's avatar
pfdietz committed
35
    (cond
36
37
38

     ((not (typep a 'array))
      :fail-not-array)
39
40
     ((not (typep a (find-class 'array)))
      :fail-not-array-class)
41
42
43
44
45
46
47
48
49
50
51
52
     ((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
53
     ((not (typep a `(array ,element-type ,rank)))
54
55
56
57
58
59
60
61
62
      :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)

63
64
65
66
67
68
69
70
71
     ((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)

72
     ((not (check-values (arrayp a))) :fail-not-arrayp)
pfdietz's avatar
pfdietz committed
73

74
     ((and ;; (eq t element-type)
pfdietz's avatar
pfdietz committed
75
76
77
	   (not adjustable)
	   (not fill-pointer)
	   (not displaced-to)
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
	   (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
93
					  ,rank)))
94
95
96
97
98
99
100
101
	     :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)
	    )))
pfdietz's avatar
pfdietz committed
102
103

     ;; If the array is a vector, check that...
104
     ((and (eql rank 1) 
pfdietz's avatar
pfdietz committed
105
	   (cond
106
	    ;; ...It's in type vector
pfdietz's avatar
pfdietz committed
107
108
	    ((not (typep a 'vector))
	     :fail-not-vector)
109
	    ;; ...If the element type is a subtype of BIT, then it's a
pfdietz's avatar
pfdietz committed
110
111
112
113
114
115
	    ;; 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)
116
	    ;; ...If not adjustable, fill pointered, or displaced,
pfdietz's avatar
pfdietz committed
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
	    ;; 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
138
     ((not (equal (array-rank a) rank))
pfdietz's avatar
pfdietz committed
139
140
141
142
143
144
145
146
147
148
149
150
151
152
      :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
153
	   (not (check-values (adjustable-array-p a)))
pfdietz's avatar
pfdietz committed
154
155
156
157
	   :fail-adjustable))

     ;; If :fill-pointer is given, the array must have a fill pointer
     ((and fill-pointer
158
	   (not (check-values (array-has-fill-pointer-p a)))
pfdietz's avatar
pfdietz committed
159
160
161
162
	   :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
163
164
     ((and (check-values (integerp fill-pointer))
	   (not (eql fill-pointer (check-values (fill-pointer a))))
pfdietz's avatar
pfdietz committed
165
166
167
168
169
170
171
172
173
174
175
	   :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
176
       (multiple-value-bind* (actual-dt actual-dio)
pfdietz's avatar
pfdietz committed
177
178
179
180
181
182
183
	   (array-displacement a)
	 (cond
	  ((not (eq actual-dt displaced-to))
	   :fail-displacement-1)
	  ((not (eql actual-dio displaced-index-offset))
	   :fail-displaced-index-offset)))))

pfdietz's avatar
pfdietz committed
184
     ;; Test of array-total-size
185
     ((not (eql (check-values (array-total-size a))
pfdietz's avatar
pfdietz committed
186
187
188
189
190
		(reduce #'* dimensions-list :initial-value 1)))
      :fail-array-total-size)

     ;; Test array-row-major-index on all zeros
     ((and (> (array-total-size a) 0)
191
192
193
	   (not (eql (check-values
		      (apply #'array-row-major-index
			     a (make-list (array-rank a) :initial-element 0)))
pfdietz's avatar
pfdietz committed
194
195
196
197
198
199
200
201
202
203
		     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)

pfdietz's avatar
pfdietz committed
204
     ;; No problems -- return the array
pfdietz's avatar
pfdietz committed
205
     (t a))))