9 |
(subtypep* type (array-element-type (make-array 0 :element-type type)))) |
(subtypep* type (array-element-type (make-array 0 :element-type type)))) |
10 |
|
|
11 |
(defun subtypep-or-unknown (subtype supertype) |
(defun subtypep-or-unknown (subtype supertype) |
12 |
(multiple-value-bind (is-subtype is-known) |
(multiple-value-bind* (is-subtype is-known) |
13 |
(subtypep subtype supertype) |
(subtypep subtype supertype) |
14 |
(or (not is-known) (notnot is-subtype)))) |
(or (not is-known) (notnot is-subtype)))) |
15 |
|
|
30 |
"Call MAKE-ARRAY and do sanity tests on the output." |
"Call MAKE-ARRAY and do sanity tests on the output." |
31 |
(declare (ignore element-type-p initial-contents initial-contents-p |
(declare (ignore element-type-p initial-contents initial-contents-p |
32 |
initial-element initial-element-p dio-p)) |
initial-element initial-element-p dio-p)) |
33 |
(let ((a (apply #'make-array dimensions options))) |
(let ((a (check-values (apply #'make-array dimensions options)))) |
34 |
(cond |
(cond |
35 |
((not (typep a 'array)) :fail-not-array) |
((not (typep a 'array)) :fail-not-array) |
36 |
((not (arrayp a)) :fail-not-arrayp) |
((not (check-values (arrayp a))) :fail-not-arrayp) |
37 |
|
|
38 |
((and (eq t element-type) |
((and (eq t element-type) |
39 |
(not adjustable) |
(not adjustable) |
92 |
|
|
93 |
;; If :adjustable is given, the array must be adjustable. |
;; If :adjustable is given, the array must be adjustable. |
94 |
((and adjustable |
((and adjustable |
95 |
(not (adjustable-array-p a)) |
(not (check-values (adjustable-array-p a))) |
96 |
:fail-adjustable)) |
:fail-adjustable)) |
97 |
|
|
98 |
;; If :fill-pointer is given, the array must have a fill pointer |
;; If :fill-pointer is given, the array must have a fill pointer |
99 |
((and fill-pointer |
((and fill-pointer |
100 |
(not (array-has-fill-pointer-p a)) |
(not (check-values (array-has-fill-pointer-p a))) |
101 |
:fail-has-fill-pointer)) |
:fail-has-fill-pointer)) |
102 |
|
|
103 |
;; If the fill pointer is given as an integer, it must be the value |
;; If the fill pointer is given as an integer, it must be the value |
104 |
;; of the fill pointer of the new array |
;; of the fill pointer of the new array |
105 |
((and (integerp fill-pointer) |
((and (check-values (integerp fill-pointer)) |
106 |
(not (eql fill-pointer (fill-pointer a))) |
(not (eql fill-pointer (check-values (fill-pointer a)))) |
107 |
:fail-fill-pointer-1)) |
:fail-fill-pointer-1)) |
108 |
|
|
109 |
;; If the fill-pointer argument is t, the fill pointer must be |
;; If the fill-pointer argument is t, the fill pointer must be |
115 |
;; If displaced-to another array, check that this is proper |
;; If displaced-to another array, check that this is proper |
116 |
((and |
((and |
117 |
displaced-to |
displaced-to |
118 |
(multiple-value-bind (actual-dt actual-dio) |
(multiple-value-bind* (actual-dt actual-dio) |
119 |
(array-displacement a) |
(array-displacement a) |
120 |
(cond |
(cond |
121 |
((not (eq actual-dt displaced-to)) |
((not (eq actual-dt displaced-to)) |
124 |
:fail-displaced-index-offset))))) |
:fail-displaced-index-offset))))) |
125 |
|
|
126 |
;; Test of array-total-size |
;; Test of array-total-size |
127 |
((not (eql (array-total-size a) |
((not (eql (check-values (array-total-size a)) |
128 |
(reduce #'* dimensions-list :initial-value 1))) |
(reduce #'* dimensions-list :initial-value 1))) |
129 |
:fail-array-total-size) |
:fail-array-total-size) |
130 |
|
|
131 |
;; Test array-row-major-index on all zeros |
;; Test array-row-major-index on all zeros |
132 |
((and (> (array-total-size a) 0) |
((and (> (array-total-size a) 0) |
133 |
(not (eql (apply #'array-row-major-index |
(not (eql (check-values |
134 |
a (make-list (array-rank a) :initial-element 0)) |
(apply #'array-row-major-index |
135 |
|
a (make-list (array-rank a) :initial-element 0))) |
136 |
0))) |
0))) |
137 |
:fail-array-row-major-index-0) |
:fail-array-row-major-index-0) |
138 |
|
|