8 |
(defun make-array-check-upgrading (type) |
(defun make-array-check-upgrading (type) |
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 make-array-with-checks (dimensions |
12 |
|
&rest options |
13 |
|
&key |
14 |
|
(element-type t element-type-p) |
15 |
|
(initial-contents nil intial-contents-p) |
16 |
|
(initial-element nil initial-element-p) |
17 |
|
(adjustable nil) |
18 |
|
(fill-pointer nil) |
19 |
|
(displaced-to nil) |
20 |
|
(displaced-index-offset 0 dio-p) |
21 |
|
&aux |
22 |
|
(dimensions-list (if (listp dimensions) |
23 |
|
dimensions |
24 |
|
(list dimensions)))) |
25 |
|
"Call MAKE-ARRAY and do sanity tests on the output." |
26 |
|
(let ((a (apply #'make-array dimensions options))) |
27 |
|
(cond |
28 |
|
((not (typep a 'array)) :fail-not-array) |
29 |
|
((and (eq t element-type) |
30 |
|
(not adjustable) |
31 |
|
(not fill-pointer) |
32 |
|
(not displaced-to) |
33 |
|
(not (typep a 'simple-array))) |
34 |
|
:fail-not-simple-array) |
35 |
|
((and (eq (length dimensions-list) 1) |
36 |
|
(cond |
37 |
|
((not (typep a 'vector)) |
38 |
|
:fail-not-vector) |
39 |
|
((and (subtypep 'bit element-type) |
40 |
|
(subtypep element-type 'bit) |
41 |
|
(or (not (bit-vector-p a)) |
42 |
|
(not (typep a 'bit-vector)))) |
43 |
|
:fail-not-bit-vector) |
44 |
|
((and (not adjustable) |
45 |
|
(not fill-pointer) |
46 |
|
(not displaced-to) |
47 |
|
(cond |
48 |
|
((and (eq t element-type) |
49 |
|
(or (not (simple-vector-p a)) |
50 |
|
(not (typep a 'simple-vector)))) |
51 |
|
:fail-not-simple-vector) |
52 |
|
((and (subtypep 'bit element-type) |
53 |
|
(subtypep element-type 'bit) |
54 |
|
(or (not (simple-bit-vector-p a)) |
55 |
|
(not (typep a 'simple-bit-vector)))) |
56 |
|
:fail-not-simple-bit-vector) ))) ))) |
57 |
|
((not (equal (array-dimensions a) dimensions-list)) |
58 |
|
:fail-array-dimensions) |
59 |
|
((not (equal (array-rank a) (length dimensions-list))) |
60 |
|
:fail-array-rank) |
61 |
|
((multiple-value-bind (sub good) |
62 |
|
(subtypep element-type (array-element-type a)) |
63 |
|
(and good |
64 |
|
(not sub) |
65 |
|
:failed-array-element-type))) |
66 |
|
((and adjustable |
67 |
|
(not (adjustable-array-p a)) |
68 |
|
:fail-adjustable)) |
69 |
|
((and fill-pointer |
70 |
|
(not (array-has-fill-pointer-p a)) |
71 |
|
:fail-has-fill-pointer)) |
72 |
|
((and (integerp fill-pointer) |
73 |
|
(not (eql fill-pointer (fill-pointer a))) |
74 |
|
:fail-fill-pointer-1)) |
75 |
|
((and (eq fill-pointer t) |
76 |
|
(not (eql (first dimensions-list) (fill-pointer a))) |
77 |
|
:fail-fill-pointer-2)) |
78 |
|
(t a)))) |
79 |
|
|
80 |
|
(deftest make-array.1 |
81 |
|
(let ((a (make-array-with-checks 10))) |
82 |
|
(and (symbolp a) a)) |
83 |
|
nil) |
84 |
|
|
85 |
|
(deftest make-array.1a |
86 |
|
(let ((a (make-array-with-checks '(10)))) |
87 |
|
(and (symbolp a) a)) |
88 |
|
nil) |
89 |
|
|
90 |
|
(deftest make-array.2 |
91 |
|
(make-array-with-checks 3 :initial-element 'z) |
92 |
|
#(z z z)) |
93 |
|
|
94 |
|
(deftest make-array.2a |
95 |
|
(make-array-with-checks 3 :initial-contents '(a b c)) |
96 |
|
#(a b c)) |
97 |
|
|
98 |
|
(deftest make-array.2b |
99 |
|
(make-array-with-checks 3 :initial-contents #(a b c)) |
100 |
|
#(a b c)) |
101 |
|
|
102 |
|
(deftest make-array.2c |
103 |
|
(make-array-with-checks 3 :initial-contents "abc") |
104 |
|
#(#\a #\b #\c)) |
105 |
|
|
106 |
|
(deftest make-array.2d |
107 |
|
(make-array-with-checks 3 :initial-contents #*010) |
108 |
|
#(0 1 0)) |
109 |
|
|
110 |
|
(deftest make-array.3 |
111 |
|
(let ((a (make-array-with-checks 5 :element-type 'bit))) |
112 |
|
(and (symbolp a) a)) |
113 |
|
nil) |
114 |
|
|
115 |
|
(deftest make-array.4 |
116 |
|
(make-array-with-checks 5 :element-type 'bit :initial-element 1) |
117 |
|
#*11111) |
118 |
|
|
119 |
|
(deftest make-array.4a |
120 |
|
(make-array-with-checks 5 :element-type 'bit :initial-contents '(1 0 0 1 0)) |
121 |
|
#*10010) |
122 |
|
|
123 |
|
(deftest make-array.4b |
124 |
|
(make-array-with-checks 5 :element-type 'bit :initial-contents #(1 0 0 1 0)) |
125 |
|
#*10010) |
126 |
|
|
127 |
|
(deftest make-array.4c |
128 |
|
(make-array-with-checks 5 :element-type 'bit :initial-contents #*10010) |
129 |
|
#*10010) |
130 |
|
|
131 |
|
(deftest make-array.5 |
132 |
|
(let ((a (make-array-with-checks 4 :element-type 'character))) |
133 |
|
(and (symbolp a) a)) |
134 |
|
nil) |
135 |
|
|
136 |
|
(deftest make-array.5a |
137 |
|
(let ((a (make-array-with-checks '(4) :element-type 'character))) |
138 |
|
(and (symbolp a) a)) |
139 |
|
nil) |
140 |
|
|
141 |
|
(deftest make-array.6 |
142 |
|
(make-array-with-checks 4 :element-type 'character |
143 |
|
:initial-element #\x) |
144 |
|
"xxxx") |
145 |
|
|
146 |
|
(deftest make-array.6a |
147 |
|
(make-array-with-checks 4 :element-type 'character |
148 |
|
:initial-contents '(#\a #\b #\c #\d)) |
149 |
|
"abcd") |
150 |
|
|
151 |
|
(deftest make-array.6b |
152 |
|
(make-array-with-checks 4 :element-type 'character |
153 |
|
:initial-contents "abcd") |
154 |
|
"abcd") |
155 |
|
|
156 |
|
(deftest make-array.7 |
157 |
|
(make-array-with-checks 5 :element-type 'symbol |
158 |
|
:initial-element 'a) |
159 |
|
#(a a a a a)) |
160 |
|
|
161 |
|
(deftest make-array.7a |
162 |
|
(make-array-with-checks 5 :element-type 'symbol |
163 |
|
:initial-contents '(a b c d e)) |
164 |
|
#(a b c d e)) |
165 |
|
|
166 |
|
(deftest make-array.7b |
167 |
|
(make-array-with-checks '(5) :element-type 'symbol |
168 |
|
:initial-contents '(a b c d e)) |
169 |
|
#(a b c d e)) |
170 |
|
|
171 |
|
(deftest make-array.8 |
172 |
|
(let ((a (make-array-with-checks 8 :element-type '(integer 0 (256))))) |
173 |
|
(and (symbolp a) a)) |
174 |
|
nil) |
175 |
|
|
176 |
|
(deftest make-array.8a |
177 |
|
(make-array-with-checks 8 :element-type '(integer 0 (256)) |
178 |
|
:initial-element 9) |
179 |
|
#(9 9 9 9 9 9 9 9)) |
180 |
|
|
181 |
|
(deftest make-array.8b |
182 |
|
(make-array-with-checks '(8) :element-type '(integer 0 (256)) |
183 |
|
:initial-contents '(4 3 2 1 9 8 7 6)) |
184 |
|
#(4 3 2 1 9 8 7 6)) |
185 |
|
|
186 |
|
;;; Zero dimensional arrays |
187 |
|
|
188 |
|
(deftest make-array.9 |
189 |
|
(let ((a (make-array-with-checks nil))) |
190 |
|
(and (symbolp a) a)) |
191 |
|
nil) |
192 |
|
|
193 |
|
(deftest make-array.10 |
194 |
|
(make-array-with-checks nil :initial-element 1) |
195 |
|
#0A1) |
196 |
|
|
197 |
|
(deftest make-array.11 |
198 |
|
(make-array-with-checks nil :initial-contents 2) |
199 |
|
#0A2) |
200 |
|
|
201 |
|
(deftest make-array.12 |
202 |
|
(make-array-with-checks nil :element-type 'bit :initial-contents 1) |
203 |
|
#0A1) |
204 |
|
|
205 |
|
(deftest make-array.13 |
206 |
|
(make-array-with-checks nil :element-type t :initial-contents 'a) |
207 |
|
#0Aa) |
208 |
|
|
209 |
|
|
210 |
|
|
211 |
|
|
212 |
|
|
213 |
|
|
214 |
|
|
215 |
|
|