source: trunk/source/tests/ansi-tests/adjust-array.lsp @ 8991

Last change on this file since 8991 was 8991, checked in by gz, 12 years ago

Check in the gcl ansi test suite (original, in preparation for making local changes)

File size: 32.7 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Sun Feb 15 07:27:22 2004
4;;;; Contains: Tests of ADJUST-ARRAY
5
6(in-package :cl-test)
7
8(defun listify-form (form)
9  (cond
10   ((integerp form) `'(,form))
11   ((null form) nil)
12   ((and (consp form)
13         (eq (car form) 'quote)
14         (consp (cadr form)))
15    form)
16   (t `(let ((x ,form)) (if (listp x) x (list x))))))
17                     
18
19(defmacro def-adjust-array-test (name args1 args2 expected-result)
20  `(deftest ,name
21     (let* ((a1 (make-array ,@args1))
22            (a2 (adjust-array a1 ,@args2)))
23       (assert (or (not (adjustable-array-p a1)) (eq a1 a2)))
24       (assert (or (adjustable-array-p a1)
25                   (equal (array-dimensions a1) ,(listify-form (first args1)))))
26       (assert (equal (array-dimensions a2) ,(listify-form (first args2))))
27       ,@(unless (or (member :displaced-to args1)
28                     (member :displaced-to args2))
29           (list '(assert (not (array-displacement a2)))))
30       a2)
31     ,expected-result))
32
33(defmacro def-adjust-array-fp-test (name args1 args2 misc &rest expected-results)
34   `(deftest ,name
35     (let* ((a1 (make-array ,@args1))
36            (a2 (adjust-array a1 ,@args2)))
37       (assert (or (not (adjustable-array-p a1)) (eq a1 a2)))
38       (assert (or (adjustable-array-p a1)
39                   (equal (array-dimensions a1) ,(listify-form (first args1)))))
40       (assert (equal (array-dimensions a2) ,(listify-form (first args2))))
41       ,@(unless (or (member :displaced-to args1)
42                     (member :displaced-to args2))
43           (list '(assert (not (array-displacement a2)))))
44       ,@(when misc (list misc))
45       (values
46        (fill-pointer a2)
47        a2))
48     ,@expected-results))
49
50(def-adjust-array-test adjust-array.1
51  (5 :initial-contents '(a b c d e))
52  (4)
53  #(a b c d))
54
55(def-adjust-array-test adjust-array.2
56  (5 :initial-contents '(a b c d e))
57  (8 :initial-element 'x)
58  #(a b c d e x x x))
59
60
61(def-adjust-array-test adjust-array.3
62  (5 :initial-contents '(a b c d e))
63  (4 :initial-contents '(w x y z))
64  #(w x y z))
65
66(def-adjust-array-test adjust-array.4
67  (5 :initial-contents '(a b c d e))
68  (8 :initial-contents '(8 7 6 5 4 3 2 1))
69  #(8 7 6 5 4 3 2 1))
70
71(def-adjust-array-fp-test adjust-array.5
72  (5 :initial-contents '(a b c d e) :fill-pointer 3)
73  (4)
74  (assert (eq (aref a2 3) 'd))
75  3 #(a b c))
76
77(def-adjust-array-fp-test adjust-array.6
78  (5 :initial-contents '(a b c d e) :fill-pointer 3)
79  (4 :fill-pointer nil)
80  (assert (eq (aref a2 3) 'd))
81  3 #(a b c))
82
83(def-adjust-array-fp-test adjust-array.7
84  (5 :initial-contents '(a b c d e) :fill-pointer 3)
85  (4 :fill-pointer t)
86  nil
87  4 #(a b c d))
88
89(def-adjust-array-fp-test adjust-array.8
90  (5 :initial-contents '(a b c d e) :fill-pointer 3)
91  (4 :fill-pointer 2)
92  (progn (assert (eq (aref a2 2) 'c))
93         (assert (eq (aref a2 3) 'd)))
94  2 #(a b))
95
96(def-adjust-array-fp-test adjust-array.9
97  (5 :initial-contents '(a b c d e) :fill-pointer 3)
98  (8 :fill-pointer 5 :initial-element 'x)
99  (assert (equal (list (aref a2 5) (aref a2 6) (aref a2 7)) '(x x x)))
100  5 #(a b c d e))
101
102(deftest adjust-array.10
103  (let* ((a1 (make-array 5 :initial-contents '(a b c d e)))
104         (a2 (adjust-array a1 4 :displaced-to nil)))
105    (assert (if (adjustable-array-p a1)
106                (eq a1 a2)
107              (equal (array-dimensions a1) '(5))))
108    (assert (not (array-displacement a2)))
109    a2)
110  #(a b c d))
111
112(deftest adjust-array.11
113  (let* ((a0 (make-array 7 :initial-contents '(x a b c d e y)))
114         (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1))
115         (a2 (adjust-array a1 4)))
116    (assert (if (adjustable-array-p a1)
117                (eq a1 a2)
118              (equal (array-dimensions a1) '(5))))
119    (assert (not (array-displacement a2)))
120    a2)
121  #(a b c d))
122
123(deftest adjust-array.12
124  (let* ((a0 (make-array 7 :initial-contents '(1 2 3 4 5 6 7)))
125         (a1 (make-array 5 :initial-contents '(a b c d e)))
126         (a2 (adjust-array a1 4 :displaced-to a0)))
127    (assert (if (adjustable-array-p a1)
128                (eq a1 a2)
129              (equal (array-dimensions a1) '(5))))
130    (assert (equal (multiple-value-list (array-displacement a2))
131                   (list a0 0)))
132    a2)
133  #(1 2 3 4))
134
135(deftest adjust-array.13
136  (let* ((a0 (make-array 7 :initial-contents '(1 2 3 4 5 6 7)))
137         (a1 (make-array 5 :initial-contents '(a b c d e)))
138         (a2 (adjust-array a1 4 :displaced-to a0
139                           :displaced-index-offset 2)))
140    (assert (if (adjustable-array-p a1)
141                (eq a1 a2)
142              (equal (array-dimensions a1) '(5))))
143    (assert (equal (multiple-value-list (array-displacement a2))
144                   (list a0 2)))
145    a2)
146  #(3 4 5 6))
147
148(deftest adjust-array.14
149  (let* ((a0 (make-array 7 :initial-contents '(1 2 3 4 5 6 7)))
150         (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1))
151         (a2 (adjust-array a1 4 :displaced-to a0)))
152    (assert (if (adjustable-array-p a1)
153                (eq a1 a2)
154              (equal (array-dimensions a1) '(5))))
155    (assert (equal (multiple-value-list (array-displacement a2))
156                   (list a0 0)))
157    a2)
158  #(1 2 3 4))
159
160(deftest adjust-array.15
161  (let* ((a0 (make-array 7 :initial-contents '(1 2 3 4 5 6 7)))
162         (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1))
163         (a2 (make-array 4 :displaced-to a1 :displaced-index-offset 1))
164         (a3 (adjust-array a2 4 :displaced-to a1)))
165    a3)
166  #(2 3 4 5))
167
168(deftest adjust-array.16
169  (let* ((a0 (make-array 7 :initial-contents '(1 2 3 4 5 6 7)))
170         (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1))
171         (a2 (adjust-array a1 5 :displaced-to a0)))
172    a2)
173  #(1 2 3 4 5))
174
175(def-adjust-array-test adjust-array.17
176  (nil :initial-element 'x)
177  (nil)
178  #0ax)
179
180(def-adjust-array-test adjust-array.18
181  (nil :initial-element 'x)
182  (nil :initial-contents 'y)
183  #0ay)
184
185(def-adjust-array-test adjust-array.19
186  (nil :initial-element 'x)
187  (nil :initial-element 'y)
188  #0ax)
189
190(deftest adjust-array.20
191  (let* ((a0 (make-array nil :initial-element 'x))
192         (a1 (make-array nil :displaced-to a0))
193         (a2 (adjust-array a1 nil)))
194    a2)
195  #0ax)
196
197;; 2-d arrays
198
199(def-adjust-array-test adjust-array.21
200  ('(4 5) :initial-contents '((1 2 3 4 5)
201                              (3 4 5 6 7)
202                              (5 6 7 8 9)
203                              (7 8 9 1 2)))
204  ('(2 3))
205  #2a((1 2 3)(3 4 5)))
206
207(def-adjust-array-test adjust-array.22
208  ('(4 5) :initial-contents '((1 2 3 4 5)
209                              (3 4 5 6 7)
210                              (5 6 7 8 9)
211                              (7 8 9 1 2)))
212  ('(6 8) :initial-element 0)
213  #2a((1 2 3 4 5 0 0 0)
214      (3 4 5 6 7 0 0 0)
215      (5 6 7 8 9 0 0 0)
216      (7 8 9 1 2 0 0 0)
217      (0 0 0 0 0 0 0 0)
218      (0 0 0 0 0 0 0 0)))
219
220(deftest adjust-array.23
221  (let* ((a1 (make-array '(4 5) :initial-contents '((#\1 #\2 #\3 #\4 #\5)
222                                                    (#\3 #\4 #\5 #\6 #\7)
223                                                    (#\5 #\6 #\7 #\8 #\9)
224                                                    (#\7 #\8 #\9 #\1 #\2))
225                         :element-type 'character))
226         (a2 (adjust-array a1 '(2 3) :element-type 'character)))
227    (assert (if (adjustable-array-p a1)
228                (eq a1 a2)
229              (equal (array-dimensions a2) '(2 3))))
230    (assert (not (typep 0 (array-element-type a2))))
231    a2)
232  #2a((#\1 #\2 #\3)(#\3 #\4 #\5)))
233
234;;; Macro expansion tests
235
236(deftest adjust-array.24
237  (macrolet
238   ((%m (z) z))
239   (let ((a (make-array '(4) :initial-contents '(a b c d))))
240     (adjust-array (expand-in-current-env (%m a)) '(4))))
241  #(a b c d))
242
243(deftest adjust-array.25
244  (macrolet
245   ((%m (z) z))
246   (let ((a (make-array '(4) :initial-contents '(a b c d))))
247     (adjust-array a (expand-in-current-env (%m '(4))))))
248  #(a b c d))
249
250(deftest adjust-array.26
251  (macrolet
252   ((%m (z) z))
253   (let ((a (make-array '(4) :initial-contents '(a b c d))))
254     (adjust-array a '(4) (expand-in-current-env (%m :element-type)) t)))
255  #(a b c d))
256
257(deftest adjust-array.27
258  (macrolet
259   ((%m (z) z))
260   (let ((a (make-array '(4) :initial-contents '(a b c d))))
261     (adjust-array a '(4) :element-type
262                   (expand-in-current-env (%m t)))))
263  #(a b c d))
264
265(deftest adjust-array.28
266  (macrolet
267   ((%m (z) z))
268   (let ((a (make-array '(4) :initial-contents '(a b c d))))
269     (adjust-array a '(6) (expand-in-current-env (%m :initial-element)) 17)))
270  #(a b c d 17 17))
271
272(deftest adjust-array.29
273  (macrolet
274   ((%m (z) z))
275   (let ((a (make-array '(4) :initial-contents '(a b c d))))
276     (adjust-array a '(7) :initial-element (expand-in-current-env (%m 5)))))
277  #(a b c d 5 5 5))
278
279(deftest adjust-array.30
280  (macrolet
281   ((%m (z) z))
282   (let ((a (make-array '(4) :initial-contents '(a b c d))))
283     (adjust-array a '(6) (expand-in-current-env (%m :initial-contents))
284                   '(1 2 3 4 5 6))))
285  #(1 2 3 4 5 6))
286
287(deftest adjust-array.31
288  (macrolet
289   ((%m (z) z))
290   (let ((a (make-array '(4) :initial-contents '(a b c d))))
291     (adjust-array a '(3) :initial-contents
292                   (expand-in-current-env (%m "ABC")))))
293  #(#\A #\B #\C))
294
295(deftest adjust-array.32
296  (macrolet
297   ((%m (z) z))
298   (let ((a (make-array '(4) :initial-contents '(a b c d))))
299     (adjust-array a '(4) (expand-in-current-env (%m :fill-pointer)) nil)))
300  #(a b c d))
301
302(deftest adjust-array.33
303  (macrolet
304   ((%m (z) z))
305   (let ((a (make-array '(4) :initial-contents '(a b c d))))
306     (adjust-array a '(4) :fill-pointer (expand-in-current-env (%m nil)))))
307  #(a b c d))
308
309(deftest adjust-array.34
310  (macrolet
311   ((%m (z) z))
312   (let ((a (make-array '(4) :initial-contents '(a b c d))))
313     (adjust-array a '(4) (expand-in-current-env (%m :displaced-to)) nil)))
314  #(a b c d))
315
316(deftest adjust-array.35
317  (macrolet
318   ((%m (z) z))
319   (let ((a (make-array '(4) :initial-contents '(a b c d))))
320     (adjust-array a '(4) :displaced-to
321                   (expand-in-current-env (%m nil)))))
322  #(a b c d))
323
324(deftest adjust-array.36
325  (macrolet
326   ((%m (z) z))
327   (let ((a (make-array '(4) :initial-contents '(a b c d)))
328         (c (make-array '(8) :initial-contents '(1 2 3 4 5 6 7 8))))
329     (adjust-array a '(3) :displaced-to c
330                   (expand-in-current-env (%m :displaced-index-offset))
331                   2)))
332  #(3 4 5))
333
334(deftest adjust-array.37
335  (macrolet
336   ((%m (z) z))
337   (let ((a (make-array '(4) :initial-contents '(a b c d)))
338         (c (make-array '(8) :initial-contents '(1 2 3 4 5 6 7 8))))
339     (adjust-array a '(5) :displaced-to c
340                   :displaced-index-offset
341                   (expand-in-current-env (%m 1)))))
342  #(2 3 4 5 6))
343
344;;; Adjust an adjustable array
345
346(def-adjust-array-test adjust-array.adjustable.1
347  (5 :initial-contents '(a b c d e) :adjustable t)
348  (4)
349  #(a b c d))
350
351(def-adjust-array-test adjust-array.adjustable.2
352  (5 :initial-contents '(a b c d e) :adjustable t)
353  (8 :initial-element 'x)
354  #(a b c d e x x x))
355
356(def-adjust-array-test adjust-array.adjustable.3
357  (5 :initial-contents '(a b c d e) :adjustable t)
358  (4 :initial-contents '(w x y z))
359  #(w x y z))
360
361(def-adjust-array-test adjust-array.adjustable.4
362  (5 :initial-contents '(a b c d e) :adjustable t)
363  (8 :initial-contents '(8 7 6 5 4 3 2 1))
364  #(8 7 6 5 4 3 2 1))
365
366(def-adjust-array-fp-test adjust-array.adjustable.5
367  (5 :initial-contents '(a b c d e) :fill-pointer 3 :adjustable t)
368  (4)
369  (assert (eq (aref a2 3) 'd))
370  3 #(a b c))
371
372(def-adjust-array-fp-test adjust-array.adjustable.6
373  (5 :initial-contents '(a b c d e) :fill-pointer 3 :adjustable t)
374  (4 :fill-pointer nil)
375  (assert (eq (aref a2 3) 'd))
376  3 #(a b c))
377
378(def-adjust-array-fp-test adjust-array.adjustable.7
379  (5 :initial-contents '(a b c d e) :fill-pointer 3 :adjustable t)
380  (4 :fill-pointer t)
381  nil
382  4 #(a b c d))
383
384(def-adjust-array-fp-test adjust-array.adjustable.8
385  (5 :initial-contents '(a b c d e) :fill-pointer 3 :adjustable t)
386  (4 :fill-pointer 2)
387  (assert (equal (list (aref a2 2) (aref a2 3)) '(c d)))
388  2 #(a b))
389
390(def-adjust-array-fp-test adjust-array.adjustable.9
391  (5 :initial-contents '(a b c d e) :fill-pointer 3 :adjustable t)
392  (8 :fill-pointer 5 :initial-element 'x)
393  (assert (equal (list (aref a2 5) (aref a2 6) (aref a2 7)) '(x x x)))
394  5 #(a b c d e))
395
396(deftest adjust-array.adjustable.10
397  (let* ((a1 (make-array 5 :initial-contents '(a b c d e)
398                         :adjustable t))
399         (a2 (adjust-array a1 4 :displaced-to nil)))
400    (assert (eq a1 a2))
401    (assert (not (array-displacement a2)))
402    a2)
403  #(a b c d))
404
405(deftest adjust-array.adjustable.11
406  (let* ((a0 (make-array 7 :initial-contents '(x a b c d e y)))
407         (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1
408                         :adjustable t))
409         (a2 (adjust-array a1 4)))
410    (assert (eq a1 a2))
411    (assert (not (array-displacement a2)))
412    a2)
413  #(a b c d))
414
415(deftest adjust-array.adjustable.12
416  (let* ((a0 (make-array 7 :initial-contents '(x a b c d e y)))
417         (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1
418                         :adjustable t))
419         (a2 (adjust-array a1 4 :displaced-to a0)))
420    (assert (eq a1 a2))
421    a2)
422  #(x a b c))
423
424(deftest adjust-array.adjustable.13
425  (let* ((a0 (make-array 7 :initial-contents '(x a b c d e y)))
426         (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1
427                         :adjustable t))
428         (a2 (make-array 4 :displaced-to a1 :displaced-index-offset 1)))
429    (assert (eq a1 (adjust-array a1 5 :displaced-to a0
430                                 :displaced-index-offset 2)))
431    a2)
432  #(c d e y))
433
434
435;;;; Strings
436
437(loop for element-type in '(character base-char)
438      for forms = `(
439(def-adjust-array-test adjust-array.string.1
440  (5 :element-type 'character :initial-contents "abcde")
441  (4 :element-type 'character)
442  "abcd")
443
444(def-adjust-array-test adjust-array.string.2
445  (5 :element-type 'character :initial-contents "abcde")
446  (8 :element-type 'character :initial-element #\x)
447  "abcdexxx")
448
449(def-adjust-array-test adjust-array.string.3
450  (5 :element-type 'character :initial-contents "abcde")
451  (4 :element-type 'character :initial-contents "wxyz")
452  "wxyz")
453
454(def-adjust-array-test adjust-array.string.4
455  (5 :element-type 'character :initial-contents "abcde")
456  (8 :element-type 'character :initial-contents "87654321")
457  "87654321")
458
459(def-adjust-array-fp-test adjust-array.string.5
460  (5 :element-type 'character :initial-contents "abcde" :fill-pointer 3)
461  (4 :element-type 'character)
462  (assert (eql (aref a2 3) #\d))
463  3 "abc")
464
465(def-adjust-array-fp-test adjust-array.string.6
466  (5 :element-type 'character :initial-contents "abcde" :fill-pointer 3)
467  (4 :element-type 'character :fill-pointer nil)
468  (assert (eql (aref a2 3) #\d))
469  3 "abc")
470
471(def-adjust-array-fp-test adjust-array.string.7
472  (5 :element-type 'character :initial-contents "abcde" :fill-pointer 3)
473  (4 :element-type 'character :fill-pointer t)
474  nil
475  4 "abcd")
476
477(def-adjust-array-fp-test adjust-array.string.8
478  (5 :element-type 'character :initial-contents "abcde" :fill-pointer 3)
479  (4 :element-type 'character :fill-pointer 2)
480  (progn (assert (eql (aref a2 2) #\c))
481         (assert (eql (aref a2 3) #\d)))
482  2 "ab")
483
484(def-adjust-array-fp-test adjust-array.string.9
485  (5 :element-type 'character :initial-contents "abcde" :fill-pointer 3)
486  (8 :element-type 'character :fill-pointer 5 :initial-element #\x)
487  (assert (equal (list (aref a2 5) (aref a2 6) (aref a2 7))
488                 '(#\x #\x #\x)))
489  5 "abcde")
490
491(deftest adjust-array.string.10
492  (let* ((a1 (make-array 5 :element-type 'character :initial-contents "abcde"))
493         (a2 (adjust-array a1 4 :displaced-to nil :element-type 'character)))
494    (assert (if (adjustable-array-p a1)
495                (eq a1 a2)
496              (equal (array-dimensions a1) '(5))))
497    (assert (not (array-displacement a2)))
498    a2)
499  "abcd")
500
501(deftest adjust-array.string.11
502  (let* ((a0 (make-array 7 :initial-contents "xabcdey" :element-type 'character))
503         (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1
504                         :element-type 'character))
505         (a2 (adjust-array a1 4 :element-type 'character)))
506    (assert (if (adjustable-array-p a1)
507                (eq a1 a2)
508              (equal (array-dimensions a1) '(5))))
509    (assert (not (array-displacement a2)))
510    a2)
511  "abcd")
512
513(deftest adjust-array.string.12
514  (let* ((a0 (make-array 7 :initial-contents "1234567" :element-type 'character))
515         (a1 (make-array 5 :initial-contents "abcde" :element-type 'character))
516         (a2 (adjust-array a1 4 :displaced-to a0 :element-type 'character)))
517    (assert (if (adjustable-array-p a1)
518                (eq a1 a2)
519              (equal (array-dimensions a1) '(5))))
520    (assert (equal (multiple-value-list (array-displacement a2))
521                   (list a0 0)))
522    a2)
523  "1234")
524
525(deftest adjust-array.string.13
526  (let* ((a0 (make-array 7 :initial-contents "1234567" :element-type 'character))
527         (a1 (make-array 5 :initial-contents "abcde" :element-type 'character))
528         (a2 (adjust-array a1 4 :displaced-to a0
529                           :displaced-index-offset 2
530                           :element-type 'character)))
531    (assert (if (adjustable-array-p a1)
532                (eq a1 a2)
533              (equal (array-dimensions a1) '(5))))
534    (assert (equal (multiple-value-list (array-displacement a2))
535                   (list a0 2)))
536    a2)
537  "3456")
538
539(deftest adjust-array.string.14
540  (let* ((a0 (make-array 7 :initial-contents "1234567" :element-type 'character))
541         (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1
542                         :element-type 'character))
543         (a2 (adjust-array a1 4 :displaced-to a0 :element-type 'character)))
544    (assert (if (adjustable-array-p a1)
545                (eq a1 a2)
546              (equal (array-dimensions a1) '(5))))
547    (assert (equal (multiple-value-list (array-displacement a2))
548                   (list a0 0)))
549    a2)
550  "1234")
551
552(deftest adjust-array.string.15
553  (let* ((a0 (make-array 7 :initial-contents "1234567" :element-type 'character))
554         (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1
555                         :element-type 'character))
556         (a2 (make-array 4 :displaced-to a1 :displaced-index-offset 1
557                         :element-type 'character))
558         (a3 (adjust-array a2 4 :displaced-to a1 :element-type 'character)))
559    a3)
560  "2345")
561
562(deftest adjust-array.string.16
563  (let* ((a0 (make-array 7 :initial-contents "1234567" :element-type 'character))
564         (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1
565                         :element-type 'character))
566         (a2 (adjust-array a1 5 :displaced-to a0 :element-type 'character)))
567    a2)
568  "12345")
569
570(def-adjust-array-test adjust-array.string.17
571  (nil :initial-element #\x :element-type 'character)
572  (nil)
573  #.(make-array nil :initial-element #\x :element-type 'character))
574
575(def-adjust-array-test adjust-array.string.18
576  (nil :initial-element #\x :element-type 'character)
577  (nil :initial-contents #\y :element-type 'character)
578  #.(make-array nil :initial-element #\y :element-type 'character))
579
580(def-adjust-array-test adjust-array.string.19
581  (nil :initial-element #\x :element-type 'character)
582  (nil :initial-element #\y :element-type 'character)
583  #.(make-array nil :initial-element #\x :element-type 'character))
584
585
586(deftest adjust-array.string.20
587  (let* ((a0 (make-array nil :initial-element #\x :element-type 'character))
588         (a1 (make-array nil :displaced-to a0 :element-type 'character))
589         (a2 (adjust-array a1 nil :element-type 'character)))
590    a2)
591   #.(make-array nil :initial-element #\x :element-type 'character))
592
593(def-adjust-array-test adjust-array.string.adjustable.1
594  (5 :initial-contents "abcde" :adjustable t :element-type 'character)
595  (4 :element-type 'character)
596  "abcd")
597
598(def-adjust-array-test adjust-array.string.adjustable.2
599  (5 :initial-contents "abcde" :adjustable t :element-type 'character)
600  (8 :initial-element #\x :element-type 'character)
601  "abcdexxx")
602
603(def-adjust-array-test adjust-array.string.adjustable.3
604  (5 :initial-contents "abcde" :adjustable t :element-type 'character)
605  (4 :initial-contents "wxyz" :element-type 'character)
606  "wxyz")
607
608(def-adjust-array-test adjust-array.string.adjustable.4
609  (5 :initial-contents "abcde" :adjustable t :element-type 'character)
610  (8 :initial-contents "87654321" :element-type 'character)
611  "87654321")
612
613(def-adjust-array-fp-test adjust-array.string.adjustable.5
614  (5 :initial-contents "abcde" :fill-pointer 3 :adjustable t :element-type 'character)
615  (4 :element-type 'character :initial-element #\Space)
616  (assert (eql (aref a2 3) #\d))
617  3 "abc")
618
619(def-adjust-array-fp-test adjust-array.string.adjustable.6
620  (5 :initial-contents "abcde" :fill-pointer 3 :adjustable t :element-type 'character)
621  (4 :fill-pointer nil :element-type 'character :initial-element #\?)
622  (assert (eql (aref a2 3) #\d))
623  3 "abc")
624
625(def-adjust-array-fp-test adjust-array.string.adjustable.7
626  (5 :initial-contents "abcde" :fill-pointer 3 :adjustable t :element-type 'character)
627  (4 :fill-pointer t :element-type 'character :initial-element #\!)
628  nil
629  4 "abcd")
630
631(def-adjust-array-fp-test adjust-array.string.adjustable.8
632  (5 :initial-contents "abcde" :fill-pointer 3 :adjustable t :element-type 'character)
633  (4 :fill-pointer 2 :element-type 'character :initial-element #\X)
634  (assert (equal (list (aref a2 2) (aref a2 3)) '(#\c #\d)))
635  2 "ab")
636
637(def-adjust-array-fp-test adjust-array.string.adjustable.9
638  (5 :initial-contents "abcde" :fill-pointer 3 :adjustable t :element-type 'character)
639  (8 :fill-pointer 5 :initial-element #\x :element-type 'character)
640  (assert (equal (list (aref a2 5) (aref a2 6) (aref a2 7)) '(#\x #\x #\x)))
641  5 "abcde")
642
643(deftest adjust-array.string.adjustable.10
644  (let* ((a1 (make-array 5 :initial-contents "abcde"
645                         :adjustable t :element-type 'character))
646         (a2 (adjust-array a1 4 :displaced-to nil :element-type 'character)))
647    (assert (eq a1 a2))
648    (assert (not (array-displacement a2)))
649    a2)
650  "abcd")
651
652(deftest adjust-array.string.adjustable.11
653  (let* ((a0 (make-array 7 :initial-contents "xabcdey" :element-type 'character))
654         (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1
655                         :adjustable t :element-type 'character))
656         (a2 (adjust-array a1 4 :element-type 'character)))
657    (assert (eq a1 a2))
658    (assert (not (array-displacement a2)))
659    a2)
660  "abcd")
661
662(deftest adjust-array.string.adjustable.12
663  (let* ((a0 (make-array 7 :initial-contents "xabcdey" :element-type 'character))
664         (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1
665                         :adjustable t :element-type 'character))
666         (a2 (adjust-array a1 4 :displaced-to a0 :element-type 'character)))
667    (assert (eq a1 a2))
668    a2)
669  "xabc")
670
671(deftest adjust-array.string.adjustable.13
672  (let* ((a0 (make-array 7 :initial-contents "xabcdey" :element-type 'character))
673         (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1
674                         :adjustable t :element-type 'character))
675         (a2 (make-array 4 :displaced-to a1 :displaced-index-offset 1
676                         :element-type 'character)))
677    (assert (eq a1 (adjust-array a1 5 :displaced-to a0
678                                 :displaced-index-offset 2
679                                 :element-type 'character)))
680    a2)
681  "cdey")
682)
683  for forms2 = (subst element-type 'character forms)
684  for forms3 = (mapcar #'(lambda (form)
685                           (destructuring-bind (dt name . body) form
686                             `(,dt ,(if (eql element-type 'character) name
687                                      (intern (replace (copy-seq (symbol-name name))
688                                                       "BASEST"
689                                                       :start1 13 :end1 19)
690                                              (symbol-package name)))
691                                   ,@ body)))
692                       forms2)
693  do (eval `(progn ,@forms3)))
694
695;; 2-d arrays
696
697(def-adjust-array-test adjust-array.string.21
698  ('(4 5) :initial-contents '("12345" "34567" "56789" "78912")
699   :element-type 'character)
700  ('(2 3))
701  #.(make-array '(2 3) :initial-contents '("123" "345")
702                :element-type 'character))
703
704(def-adjust-array-test adjust-array.string.22
705  ('(4 5) :initial-contents  '("12345" "34567" "56789" "78912")
706   :element-type 'character)
707  ('(6 8) :initial-element #\0 :element-type 'character)
708  #.(make-array '(6 8)
709                :initial-contents '("12345000" "34567000" "56789000"
710                                    "78912000" "00000000" "00000000")
711                :element-type 'character))
712
713(def-adjust-array-test adjust-array.bit-vector.1
714  (5 :element-type 'bit :initial-contents #*01100)
715  (4 :element-type 'bit)
716  #*0110)
717
718(def-adjust-array-test adjust-array.bit-vector.2
719  (5 :element-type 'bit :initial-contents #*01100)
720  (8 :element-type 'bit :initial-element 1)
721  #*01100111)
722
723(def-adjust-array-test adjust-array.bit-vector.3
724  (5 :element-type 'bit :initial-contents #*01100)
725  (4 :element-type 'bit :initial-contents #*1011)
726  #*1011)
727
728(def-adjust-array-test adjust-array.bit-vector.4
729  (5 :element-type 'bit :initial-contents #*01100)
730  (8 :element-type 'bit :initial-contents #*11110000)
731  #*11110000)
732
733(def-adjust-array-fp-test adjust-array.bit-vector.5
734  (5 :element-type 'bit :initial-contents #*01100 :fill-pointer 3)
735  (4 :element-type 'bit)
736  (assert (eql (aref a2 3) 0))
737  3 #*011)
738
739(def-adjust-array-fp-test adjust-array.bit-vector.6
740  (5 :element-type 'bit :initial-contents #*01100 :fill-pointer 3)
741  (4 :element-type 'bit :fill-pointer nil)
742  (assert (eql (aref a2 3) 0))
743  3 #*011)
744
745(def-adjust-array-fp-test adjust-array.bit-vector.7
746  (5 :element-type 'bit :initial-contents #*01100 :fill-pointer 3)
747  (4 :element-type 'bit :fill-pointer t)
748  nil
749  4 #*0110)
750
751(def-adjust-array-fp-test adjust-array.bit-vector.8
752  (5 :element-type 'bit :initial-contents #*01100 :fill-pointer 3)
753  (4 :element-type 'bit :fill-pointer 2)
754  (progn (assert (eql (aref a2 2) 1))
755         (assert (eql (aref a2 3) 0)))
756  2 #*01)
757
758(def-adjust-array-fp-test adjust-array.bit-vector.9
759  (5 :element-type 'bit :initial-contents #*01100 :fill-pointer 3)
760  (8 :element-type 'bit :fill-pointer 5 :initial-element 1)
761  (assert (equal (list (aref a2 5) (aref a2 6) (aref a2 7))
762                 '(1 1 1)))
763  5 #*01100)
764
765(deftest adjust-array.bit-vector.10
766  (let* ((a1 (make-array 5 :element-type 'bit :initial-contents #*01100))
767         (a2 (adjust-array a1 4 :displaced-to nil :element-type 'bit)))
768    (assert (if (adjustable-array-p a1)
769                (eq a1 a2)
770              (equal (array-dimensions a1) '(5))))
771    (assert (not (array-displacement a2)))
772    a2)
773  #*0110)
774
775(deftest adjust-array.bit-vector.11
776  (let* ((a0 (make-array 7 :initial-contents #*0011001 :element-type 'bit))
777         (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1
778                         :element-type 'bit))
779         (a2 (adjust-array a1 4 :element-type 'bit)))
780    (assert (if (adjustable-array-p a1)
781                (eq a1 a2)
782              (equal (array-dimensions a1) '(5))))
783    (assert (not (array-displacement a2)))
784    a2)
785  #*0110)
786
787(deftest adjust-array.bit-vector.12
788  (let* ((a0 (make-array 7 :initial-contents #*1010101 :element-type 'bit))
789         (a1 (make-array 5 :initial-contents #*01100 :element-type 'bit))
790         (a2 (adjust-array a1 4 :displaced-to a0 :element-type 'bit)))
791    (assert (if (adjustable-array-p a1)
792                (eq a1 a2)
793              (equal (array-dimensions a1) '(5))))
794    (assert (equal (multiple-value-list (array-displacement a2))
795                   (list a0 0)))
796    a2)
797  #*1010)
798
799(deftest adjust-array.bit-vector.13
800  (let* ((a0 (make-array 7 :initial-contents #*1011101 :element-type 'bit))
801         (a1 (make-array 5 :initial-contents #*01100 :element-type 'bit))
802         (a2 (adjust-array a1 4 :displaced-to a0
803                           :displaced-index-offset 2
804                           :element-type 'bit)))
805    (assert (if (adjustable-array-p a1)
806                (eq a1 a2)
807              (equal (array-dimensions a1) '(5))))
808    (assert (equal (multiple-value-list (array-displacement a2))
809                   (list a0 2)))
810    a2)
811  #*1110)
812
813(deftest adjust-array.bit-vector.14
814  (let* ((a0 (make-array 7 :initial-contents #*1011001 :element-type 'bit))
815         (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1
816                         :element-type 'bit))
817         (a2 (adjust-array a1 4 :displaced-to a0 :element-type 'bit)))
818    (assert (if (adjustable-array-p a1)
819                (eq a1 a2)
820              (equal (array-dimensions a1) '(5))))
821    (assert (equal (multiple-value-list (array-displacement a2))
822                   (list a0 0)))
823    a2)
824  #*1011)
825
826(deftest adjust-array.bit-vector.15
827  (let* ((a0 (make-array 7 :initial-contents #*1100010 :element-type 'bit))
828         (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1
829                         :element-type 'bit))
830         (a2 (make-array 4 :displaced-to a1 :displaced-index-offset 1
831                         :element-type 'bit))
832         (a3 (adjust-array a2 4 :displaced-to a1 :element-type 'bit)))
833    a3)
834  #*1000)
835
836(deftest adjust-array.bit-vector.16
837  (let* ((a0 (make-array 7 :initial-contents #*1011011 :element-type 'bit))
838         (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1
839                         :element-type 'bit))
840         (a2 (adjust-array a1 5 :displaced-to a0 :element-type 'bit)))
841    a2)
842  #*10110)
843
844(def-adjust-array-test adjust-array.bit-vector.17
845  (nil :initial-element 0 :element-type 'bit)
846  (nil)
847  #.(make-array nil :initial-element 0 :element-type 'bit))
848
849(def-adjust-array-test adjust-array.bit-vector.18
850  (nil :initial-element 0 :element-type 'bit)
851  (nil :initial-contents 1 :element-type 'bit)
852  #.(make-array nil :initial-element 1 :element-type 'bit))
853
854(def-adjust-array-test adjust-array.bit-vector.19
855  (nil :initial-element 1 :element-type 'bit)
856  (nil :initial-element 0 :element-type 'bit)
857  #.(make-array nil :initial-element 1 :element-type 'bit))
858
859(deftest adjust-array.bit-vector.20
860  (let* ((a0 (make-array nil :initial-element 1 :element-type 'bit))
861         (a1 (make-array nil :displaced-to a0 :element-type 'bit))
862         (a2 (adjust-array a1 nil :element-type 'bit)))
863    a2)
864   #.(make-array nil :initial-element 1 :element-type 'bit))
865
866;; 2-d arrays
867
868(def-adjust-array-test adjust-array.bit-vector.21
869  ('(4 5) :initial-contents '(#*11100 #*00110 #*00001 #*11111)
870   :element-type 'bit)
871  ('(2 3))
872  #.(make-array '(2 3) :initial-contents '(#*111 #*001)
873                :element-type 'bit))
874
875(def-adjust-array-test adjust-array.bit-vector.22
876  ('(4 5) :initial-contents  '(#*11100 #*00110 #*00001 #*11111)
877   :element-type 'bit)
878  ('(6 8) :initial-element 0 :element-type 'bit)
879  #.(make-array '(6 8)
880                :initial-contents '(#*11100000 #*00110000 #*00001000
881                                    #*11111000 #*00000000 #*00000000)
882                :element-type 'bit))
883
884;;; Adjustable bit vector tests
885
886(def-adjust-array-test adjust-array.bit-vector.adjustable.1
887  (5 :initial-contents '(1 0 1 1 0) :adjustable t :element-type 'bit)
888  (4 :element-type 'bit)
889  #*1011)
890
891(def-adjust-array-test adjust-array.bit-vector.adjustable.2
892  (5 :initial-contents '(1 0 1 0 1) :adjustable t :element-type 'bit)
893  (8 :initial-element '1 :element-type 'bit)
894  #*10101111)
895
896(def-adjust-array-test adjust-array.bit-vector.adjustable.3
897  (5 :initial-contents '(0 1 0 1 0) :adjustable t :element-type 'bit)
898  (4 :initial-contents '(1 1 1 0) :element-type 'bit)
899  #*1110)
900
901(def-adjust-array-test adjust-array.bit-vector.adjustable.4
902  (5 :initial-contents '(1 0 0 1 0) :adjustable t :element-type 'bit)
903  (8 :initial-contents '(0 1 0 1 1 0 1 0) :element-type 'bit)
904  #*01011010)
905
906(def-adjust-array-fp-test adjust-array.bit-vector.adjustable.5
907  (5 :initial-contents '(1 1 1 0 0) :fill-pointer 3 :adjustable t :element-type 'bit)
908  (4 :element-type 'bit :initial-element 0)
909  (assert (eql (aref a2 3) 0))
910  3 #*111)
911
912(def-adjust-array-fp-test adjust-array.bit-vector.adjustable.6
913  (5 :initial-contents '(0 0 0 1 1) :fill-pointer 3 :adjustable t :element-type 'bit)
914  (4 :fill-pointer nil :element-type 'bit :initial-element 1)
915  (assert (eql (aref a2 3) 1))
916  3 #*000)
917
918(def-adjust-array-fp-test adjust-array.bit-vector.adjustable.7
919  (5 :initial-contents '(1 1 0 1 1) :fill-pointer 3 :adjustable t :element-type 'bit)
920  (4 :fill-pointer t :element-type 'bit :initial-element 1)
921  nil
922  4 #*1101)
923
924(def-adjust-array-fp-test adjust-array.bit-vector.adjustable.8
925  (5 :initial-contents '(0 1 1 1 0) :fill-pointer 3 :adjustable t :element-type 'bit)
926  (4 :fill-pointer 2 :element-type 'bit :initial-element 0)
927  (assert (equal (list (aref a2 2) (aref a2 3)) '(1 1)))
928  2 #*01)
929
930(def-adjust-array-fp-test adjust-array.bit-vector.adjustable.9
931  (5 :initial-contents '(1 0 0 0 1) :fill-pointer 3 :adjustable t :element-type 'bit)
932  (8 :fill-pointer 5 :initial-element 1 :element-type 'bit)
933  (assert (equal (list (aref a2 5) (aref a2 6) (aref a2 7)) '(1 1 1)))
934  5 #*10001)
935
936(deftest adjust-array.bit-vector.adjustable.10
937  (let* ((a1 (make-array 5 :initial-contents '(0 1 1 0 1)
938                         :adjustable t :element-type 'bit))
939         (a2 (adjust-array a1 4 :displaced-to nil :element-type 'bit)))
940    (assert (eq a1 a2))
941    (assert (not (array-displacement a2)))
942    a2)
943  #*0110)
944
945(deftest adjust-array.bit-vector.adjustable.11
946  (let* ((a0 (make-array 7 :initial-contents '(0 1 0 1 1 1 0)
947                         :element-type 'bit))
948         (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1
949                         :adjustable t :element-type 'bit))
950         (a2 (adjust-array a1 4 :element-type 'bit)))
951    (assert (eq a1 a2))
952    (assert (not (array-displacement a2)))
953    a2)
954  #*1011)
955
956(deftest adjust-array.bit-vector.adjustable.12
957  (let* ((a0 (make-array 7 :initial-contents '(0 0 1 1 1 1 1)
958                         :element-type 'bit))
959         (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1
960                         :adjustable t :element-type 'bit))
961         (a2 (adjust-array a1 4 :displaced-to a0 :element-type 'bit)))
962    (assert (eq a1 a2))
963    a2)
964  #*0011)
965
966(deftest adjust-array.bit-vector.adjustable.13
967  (let* ((a0 (make-array 7 :initial-contents '(1 0 0 0 0 0 1) :element-type 'bit))
968         (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1
969                         :adjustable t :element-type 'bit))
970         (a2 (make-array 4 :displaced-to a1 :displaced-index-offset 1
971                         :element-type 'bit)))
972    (assert (eq a1 (adjust-array a1 5 :displaced-to a0
973                                 :displaced-index-offset 2
974                                 :element-type 'bit)))
975    a2)
976  #*0001)
977
978;;; FIXME. specialized integer array tests
979
980;;; FIXNME float array tests
981
982;;; Error cases
983
984(deftest adjust-array.error.1
985  (signals-error (adjust-array) program-error)
986  t)
987
988(deftest adjust-array.error.2
989  (signals-error (adjust-array (make-array 10 :initial-element nil))
990                 program-error)
991  t)
992
993(deftest adjust-array.error.3
994  (signals-error (adjust-array (make-array 10 :initial-element nil)
995                               8 :bad t)
996                 program-error)
997  t)
998
999(deftest adjust-array.error.4
1000  (signals-error (adjust-array (make-array 10 :initial-element nil)
1001                               8 :initial-element)
1002                 program-error)
1003  t)
1004
1005(deftest adjust-array.error.5
1006  (signals-error (adjust-array (make-array 10 :initial-element nil)
1007                               8
1008                               :allow-other-keys nil
1009                               :allow-other-keys t
1010                               :bad t)
1011                 program-error)
1012  t)
1013
1014(deftest adjust-array.error.6
1015  (signals-error
1016   (let ((a (make-array 5 :initial-element 'x)))
1017     (adjust-array a :fill-pointer 4))
1018   error)
1019  t)
Note: See TracBrowser for help on using the repository browser.