source: trunk/source/tests/ansi-tests/vector-push-extend.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: 15.7 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Sat Jan 25 08:04:35 2003
4;;;; Contains: Tests for VECTOR-PUSH-EXTEND
5
6(in-package :cl-test)
7
8(deftest vector-push-extend.1
9  (let ((a (make-array '(5) :fill-pointer 2
10                       :initial-contents '(a b c d e)))
11        (i 0) x y)
12    (values
13     (fill-pointer a)
14     (vector-push-extend (progn (setf x (incf i)) 'x)
15                         (progn (setf y (incf i)) a))
16     (fill-pointer a)
17     a
18     i x y))
19  2 2 3 #(a b x) 2 1 2)
20
21(deftest vector-push-extend.2
22  (let ((a (make-array '(5) :fill-pointer 5
23                       :adjustable t
24                       :initial-contents '(a b c d e))))
25    (values
26     (fill-pointer a)
27     (vector-push-extend 'x a)
28     (fill-pointer a)
29     (<= (array-total-size a) 5)
30     a))
31  5 5 6 nil #(a b c d e x))
32
33(deftest vector-push-extend.3
34  (let ((a (make-array '(5) :fill-pointer 2
35                       :initial-contents "abcde"
36                       :element-type 'base-char)))
37    (values
38     (fill-pointer a)
39     (vector-push-extend #\x a)
40     (fill-pointer a)
41     a))
42  2 2 3 "abx")
43
44(deftest vector-push-extend.4
45  (let ((a (make-array '(5) :fill-pointer 5
46                       :adjustable t
47                       :initial-contents "abcde"
48                       :element-type 'base-char))
49        (i 0) x y z)
50    (values
51     (fill-pointer a)
52     (vector-push-extend (progn (setf x (incf i)) #\x)
53                         (progn (setf y (incf i)) a)
54                         (progn (setf z (incf i)) 1))
55     (fill-pointer a)
56     (<= (array-total-size a) 5)
57     a
58     i x y z))
59  5 5 6 nil "abcdex" 3 1 2 3)
60
61(deftest vector-push-extend.5
62  (let ((a (make-array '(5) :fill-pointer 2
63                       :initial-contents "abcde"
64                       :element-type 'character)))
65    (values
66     (fill-pointer a)
67     (vector-push-extend #\x a)
68     (fill-pointer a)
69     a))
70  2 2 3 "abx")
71
72(deftest vector-push-extend.6
73  (let ((a (make-array '(5) :fill-pointer 5
74                       :adjustable t
75                       :initial-contents "abcde"
76                       :element-type 'character)))
77    (values
78     (fill-pointer a)
79     (vector-push-extend #\x a 10)
80     (fill-pointer a)
81     (<= (array-total-size a) 5)
82     a))
83  5 5 6 nil "abcdex")
84
85(deftest vector-push-extend.7
86  (let ((a (make-array '(5) :fill-pointer 2
87                       :initial-contents '(0 1 1 0 0)
88                       :element-type 'bit)))
89    (values
90     (fill-pointer a)
91     (vector-push-extend 0 a)
92     (fill-pointer a)
93     a))
94  2 2 3 #*010)
95
96(deftest vector-push-extend.8
97  (let ((a (make-array '(5) :fill-pointer 5
98                       :adjustable t
99                       :initial-contents '(0 0 0 0 0)
100                       :element-type 'bit)))
101    (values
102     (fill-pointer a)
103     (vector-push-extend 1 a 100)
104     (fill-pointer a)
105     (<= (array-total-size a) 5)
106     a))
107  5 5 6 nil #*000001)
108
109(deftest vector-push-extend.9
110  (let ((a (make-array '(5) :fill-pointer 2
111                       :initial-contents '(1 2 3 4 5)
112                       :element-type 'fixnum)))
113    (values
114     (fill-pointer a)
115     (vector-push-extend 0 a)
116     (fill-pointer a)
117     a))
118  2 2 3 #(1 2 0))
119
120(deftest vector-push-extend.10
121  (let ((a (make-array '(5) :fill-pointer 5
122                       :adjustable t
123                       :initial-contents '(1 2 3 4 5)
124                       :element-type 'fixnum)))
125    (values
126     (fill-pointer a)
127     (vector-push-extend 0 a 1)
128     (fill-pointer a)
129     (<= (array-total-size a) 5)
130     a))
131  5 5 6 nil #(1 2 3 4 5 0))
132
133(deftest vector-push-extend.11
134  (let ((a (make-array '(5) :fill-pointer 2
135                       :initial-contents '(1 2 3 4 5)
136                       :element-type '(integer 0 (256)))))
137    (values
138     (fill-pointer a)
139     (vector-push-extend 0 a)
140     (fill-pointer a)
141     a))
142  2 2 3 #(1 2 0))
143
144(deftest vector-push-extend.12
145  (let ((a (make-array '(5) :fill-pointer 5
146                       :adjustable t
147                       :initial-contents '(1 2 3 4 5)
148                       :element-type '(integer 0 (256)))))
149    (values
150     (fill-pointer a)
151     (vector-push-extend 0 a 1)
152     (fill-pointer a)
153     (<= (array-total-size a) 5)
154     a))
155  5 5 6 nil #(1 2 3 4 5 0))
156
157(deftest vector-push-extend.13
158  (let ((a (make-array '(5) :fill-pointer 2
159                       :initial-contents '(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0)
160                       :element-type 'short-float)))
161    (values
162     (fill-pointer a)
163     (vector-push-extend 0.0s0 a)
164     (fill-pointer a)
165     a))
166  2 2 3 #(1.0s0 2.0s0 0.0s0))
167
168(deftest vector-push-extend.14
169  (let ((a (make-array '(5) :fill-pointer 5
170                       :adjustable t
171                       :initial-contents '(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0)
172                       :element-type 'short-float)))
173    (values
174     (fill-pointer a)
175     (vector-push-extend 0.0s0 a 1)
176     (fill-pointer a)
177     (<= (array-total-size a) 5)
178     a))
179  5 5 6 nil #(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0 0.0s0))
180
181(deftest vector-push-extend.15
182  (let ((a (make-array '(5) :fill-pointer 2
183                       :initial-contents '(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0)
184                       :element-type 'single-float)))
185    (values
186     (fill-pointer a)
187     (vector-push-extend 0.0f0 a)
188     (fill-pointer a)
189     a))
190  2 2 3 #(1.0f0 2.0f0 0.0f0))
191
192(deftest vector-push-extend.16
193  (let ((a (make-array '(5) :fill-pointer 5
194                       :adjustable t
195                       :initial-contents '(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0)
196                       :element-type 'single-float)))
197    (values
198     (fill-pointer a)
199     (vector-push-extend 0.0f0 a 1)
200     (fill-pointer a)
201     (<= (array-total-size a) 5)
202     a))
203  5 5 6 nil #(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0 0.0f0))
204
205
206(deftest vector-push-extend.17
207  (let ((a (make-array '(5) :fill-pointer 2
208                       :initial-contents '(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0)
209                       :element-type 'double-float)))
210    (values
211     (fill-pointer a)
212     (vector-push-extend 0.0d0 a)
213     (fill-pointer a)
214     a))
215  2 2 3 #(1.0d0 2.0d0 0.0d0))
216
217(deftest vector-push-extend.18
218  (let ((a (make-array '(5) :fill-pointer 5
219                       :adjustable t
220                       :initial-contents '(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0)
221                       :element-type 'double-float)))
222    (values
223     (fill-pointer a)
224     (vector-push-extend 0.0d0 a 1)
225     (fill-pointer a)
226     (<= (array-total-size a) 5)
227     a))
228  5 5 6 nil #(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0 0.0d0))
229
230(deftest vector-push-extend.19
231  (let ((a (make-array '(5) :fill-pointer 2
232                       :initial-contents '(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0)
233                       :element-type 'long-float)))
234    (values
235     (fill-pointer a)
236     (vector-push-extend 0.0l0 a)
237     (fill-pointer a)
238     a))
239  2 2 3 #(1.0l0 2.0l0 0.0l0))
240
241(deftest vector-push-extend.20
242  (let ((a (make-array '(5) :fill-pointer 5
243                       :adjustable t
244                       :initial-contents '(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0)
245                       :element-type 'long-float)))
246    (values
247     (fill-pointer a)
248     (vector-push-extend 0.0l0 a 1)
249     (fill-pointer a)
250     (<= (array-total-size a) 5)
251     a))
252  5 5 6 nil #(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0 0.0l0))
253
254
255;;; Tests on displaced arrays
256
257(deftest vector-push-extend.21
258  (let* ((a1 (make-array 10 :initial-element nil))
259         (a2 (make-array 6 :displaced-to a1
260                         :displaced-index-offset 2
261                         :fill-pointer 0)))
262    (values
263     (fill-pointer a2)
264     (map 'list #'identity a2)
265     (vector-push-extend 'foo a2)
266     (fill-pointer a2)
267     (map 'list #'identity a2)
268     (map 'list #'identity a1)))
269  0
270  ()
271  0
272  1
273  (foo)
274  (nil nil foo nil nil nil nil nil nil nil))
275
276(deftest vector-push-extend.22
277  (let* ((a1 (make-array 6 :initial-element nil))
278         (a2 (make-array 0 :displaced-to a1
279                         :displaced-index-offset 2
280                         :adjustable t
281                         :fill-pointer 0)))
282    (values
283     (fill-pointer a2)
284     (map 'list #'identity a2)
285     (vector-push-extend 'foo a2)
286     (fill-pointer a2)
287     (map 'list #'identity a2)
288     (map 'list #'identity a1)
289     (notnot (adjustable-array-p a2))
290     (multiple-value-list (array-displacement a2))
291     ))
292  0
293  ()
294  0
295  1
296  (foo)
297  (nil nil nil nil nil nil)
298  t
299  (nil 0))
300
301(deftest vector-push-extend.23
302  (let* ((a1 (make-array 10 :initial-element nil))
303         (a2 (make-array 6 :displaced-to a1
304                         :displaced-index-offset 2
305                         :adjustable t
306                         :fill-pointer 1)))
307    (values
308     (fill-pointer a2)
309     (map 'list #'identity a2)
310     (vector-push-extend 'foo a2)
311     (fill-pointer a2)
312     (map 'list #'identity a2)
313     (map 'list #'identity a1)
314     (notnot (adjustable-array-p a2))
315     (eqt (array-displacement a2) a1)
316     (nth-value 1 (array-displacement a2))
317     ))
318  1
319  (nil)
320  1
321  2
322  (nil foo)
323  (nil nil nil foo nil nil nil nil nil nil)
324  t
325  t
326  2)
327
328(deftest vector-push-extend.24
329  (let* ((a1 (make-array 4 :initial-element nil))
330         (a2 (make-array 2 :displaced-to a1
331                         :displaced-index-offset 2
332                         :adjustable t
333                         :fill-pointer 2)))
334    (values
335     (map 'list #'identity a1)
336     (map 'list #'identity a2)
337     (vector-push-extend 'foo a2 7)
338     (fill-pointer a2)
339     (map 'list #'identity a1)
340     (map 'list #'identity a2)
341     (array-dimension a2 0)
342     (notnot (adjustable-array-p a2))
343     (multiple-value-list (array-displacement a2))))
344  (nil nil nil nil)
345  (nil nil)
346  2
347  3
348  (nil nil nil nil)
349  (nil nil foo)
350  9
351  t
352  (nil 0))
353
354;;; Integer vectors
355
356(deftest vector-push-extend.25
357  (loop for adj in '(nil t)
358        nconc
359        (loop for bits from 1 to 64
360              for etype = `(unsigned-byte ,bits)
361              for a1 = (make-array 10 :initial-element 0
362                                   :element-type etype)
363              for a2 =(make-array 6
364                                  :element-type etype
365                                  :displaced-to a1
366                                  :displaced-index-offset 2
367                                  :adjustable adj
368                                  :fill-pointer 0)
369              for result = (list (fill-pointer a2)
370                                 (map 'list #'identity a2)
371                                 (vector-push-extend 1 a2)
372                                 (fill-pointer a2)
373                                 (map 'list #'identity a2)
374                                 (map 'list #'identity a1))
375              unless (equal result '(0 () 0 1 (1) (0 0 1 0 0 0 0 0 0 0)))
376              collect (list etype adj result)))
377  nil)
378
379(deftest vector-push-extend.26
380  (loop for bits from 1 to 64
381        for etype = `(unsigned-byte ,bits)
382        for a1 = (make-array 8 :initial-element 0
383                             :element-type etype)
384        for a2 = (make-array 6
385                             :element-type etype
386                             :displaced-to a1
387                             :displaced-index-offset 2
388                             :adjustable t
389                             :fill-pointer 6)
390        for result = (list (fill-pointer a2)
391                           (map 'list #'identity a2)
392                           (vector-push-extend 1 a2)
393                           (fill-pointer a2)
394                           (map 'list #'identity a2)
395                           (map 'list #'identity a1)
396                           (notnot (adjustable-array-p a2))
397                           (multiple-value-list (array-displacement a1)))
398        unless (equal result '(6 (0 0 0 0 0 0) 6 7 (0 0 0 0 0 0 1)
399                                 (0 0 0 0 0 0 0 0) t (nil 0)))
400        collect (list etype result))
401  nil)
402
403;;; strings
404
405(deftest vector-push-extend.27
406  (loop for adj in '(nil t)
407        nconc
408        (loop for etype in '(character base-char standard-char)
409              for a1 = (make-array 10 :initial-element #\a
410                                   :element-type etype)
411              for a2 =(make-array 6
412                                  :element-type etype
413                                  :displaced-to a1
414                                  :displaced-index-offset 2
415                                  :adjustable adj
416                                  :fill-pointer 0)
417              for result = (list (fill-pointer a2)
418                                 (map 'list #'identity a2)
419                                 (vector-push-extend #\b a2)
420                                 (fill-pointer a2)
421                                 (map 'list #'identity a2)
422                                 (map 'list #'identity a1))
423              unless (equal result '(0 () 0 1 (#\b) (#\a #\a #\b #\a #\a #\a #\a #\a #\a #\a)))
424              collect (list etype adj result)))
425  nil)
426
427(deftest vector-push-extend.28
428  (loop for etype in '(character base-char standard-char)
429        for a1 = (make-array 8 :initial-element #\a
430                             :element-type etype)
431        for a2 = (make-array 6
432                             :element-type etype
433                             :displaced-to a1
434                             :displaced-index-offset 2
435                             :adjustable t
436                             :fill-pointer 6)
437        for result = (list (fill-pointer a2)
438                           (map 'list #'identity a2)
439                           (vector-push-extend #\b a2)
440                           (fill-pointer a2)
441                           (map 'list #'identity a2)
442                           (map 'list #'identity a1)
443                           (notnot (adjustable-array-p a2))
444                           (multiple-value-list (array-displacement a1)))
445        unless (equal result '(6 #.(coerce "aaaaaa" 'list)
446                                 6 7
447                                 #.(coerce "aaaaaab" 'list)
448                                 #.(coerce "aaaaaaaa" 'list)
449                                 t (nil 0)))
450        collect (list etype result))
451  nil)
452
453;;; float tests
454
455(deftest vector-push-extend.29
456  (loop for adj in '(nil t)
457        nconc
458        (loop for etype in '(short-float single-float double-float long-float)
459              for zero in '(0.0s0 0.0f0 0.0d0 0.0l0)
460              for one in '(1.0s0 1.0f0 1.0d0 1.0l0)
461              for a1 = (make-array 10 :initial-element zero
462                                   :element-type etype)
463              for a2 =(make-array 6
464                                  :element-type etype
465                                  :displaced-to a1
466                                  :displaced-index-offset 2
467                                  :adjustable adj
468                                  :fill-pointer 0)
469              for result = (list (fill-pointer a2)
470                                 (map 'list #'identity a2)
471                                 (vector-push-extend one a2)
472                                 (fill-pointer a2)
473                                 (map 'list #'identity a2)
474                                 (map 'list #'identity a1))
475              unless (equal result `(0 () 0 1 (,one) (,zero ,zero ,one ,zero ,zero ,zero ,zero ,zero ,zero ,zero)))
476              collect (list etype adj result)))
477  nil)
478
479(deftest vector-push-extend.30
480  (loop for etype in '(short-float single-float double-float long-float)
481        for zero in '(0.0s0 0.0f0 0.0d0 0.0l0)
482        for one in '(1.0s0 1.0f0 1.0d0 1.0l0)
483        for a1 = (make-array 8 :initial-element zero
484                             :element-type etype)
485        for a2 = (make-array 6
486                             :element-type etype
487                             :displaced-to a1
488                             :displaced-index-offset 2
489                             :adjustable t
490                             :fill-pointer 6)
491        for result = (list (fill-pointer a2)
492                           (map 'list #'identity a2)
493                           (vector-push-extend one a2)
494                           (fill-pointer a2)
495                           (map 'list #'identity a2)
496                           (map 'list #'identity a1)
497                           (notnot (adjustable-array-p a2))
498                           (multiple-value-list (array-displacement a1)))
499        unless (equal result `(6 (,zero ,zero ,zero ,zero ,zero ,zero)
500                                 6 7
501                                 (,zero ,zero ,zero ,zero ,zero ,zero ,one)
502                                 (,zero ,zero ,zero ,zero ,zero ,zero ,zero ,zero)
503                                 t (nil 0)))
504        collect (list etype result))
505  nil)
506
507
508;;; Error tests
509
510(defun vector-push-extend-error-test (seq val)
511  (declare (optimize (safety 3)))
512  (handler-case
513   (eval `(let ((a (copy-seq ,seq)))
514            (declare (optimize (safety 3)))
515            (or (notnot (array-has-fill-pointer-p a))
516                (vector-push-extend ',val a 1))))
517   (error () t)))
518
519(deftest vector-push-extend.error.1
520  (vector-push-extend-error-test #(a b c d) 'x)
521  t)
522
523(deftest vector-push-extend.error.2
524  (vector-push-extend-error-test #*00000 1)
525  t)
526
527(deftest vector-push-extend.error.3
528  (vector-push-extend-error-test "abcde" #\x)
529  t)
530
531(deftest vector-push-extend.error.4
532  (vector-push-extend-error-test #() 'x)
533  t)
534
535(deftest vector-push-extend.error.5
536  (vector-push-extend-error-test #* 1)
537  t)
538
539(deftest vector-push-extend.error.6
540  (vector-push-extend-error-test "" #\x)
541  t)
542
543(deftest vector-push-extend.error.7
544  (vector-push-extend-error-test (make-array '5 :element-type 'base-char
545                                      :initial-element #\a)
546                          #\x)
547  t)
548
549(deftest vector-push-extend.error.8
550  (vector-push-extend-error-test (make-array '5 :element-type '(integer 0 (256))
551                                      :initial-element 0)
552                          17)
553  t)
554
555(deftest vector-push-extend.error.9
556  (vector-push-extend-error-test (make-array '5 :element-type 'float
557                                      :initial-element 1.0)
558                          2.0)
559  t)
560
561(deftest vector-push-extend.error.10
562  (vector-push-extend-error-test (make-array '5 :element-type 'short-float
563                                      :initial-element 1.0s0)
564                          2.0s0)
565  t)
566
567(deftest vector-push-extend.error.11
568  (vector-push-extend-error-test (make-array '5 :element-type 'long-float
569                                      :initial-element 1.0l0)
570                          2.0l0)
571  t)
572
573(deftest vector-push-extend.error.12
574  (vector-push-extend-error-test (make-array '5 :element-type 'single-float
575                                      :initial-element 1.0f0)
576                          2.0f0)
577  t)
578
579(deftest vector-push-extend.error.13
580  (vector-push-extend-error-test (make-array '5 :element-type 'double-float
581                                      :initial-element 1.0d0)
582                          2.0d0)
583  t)
584
585(deftest vector-push-extend.error.14
586  (signals-error (vector-push-extend) program-error)
587  t)
588
589(deftest vector-push-extend.error.15
590  (signals-error (vector-push-extend (vector 1 2 3)) program-error)
591  t)
592
593(deftest vector-push-extend.error.16
594  (signals-error (vector-push-extend (vector 1 2 3) 4 1 nil) program-error)
595  t)
596
597(deftest vector-push-extend.error.17
598  (handler-case
599   (eval
600    `(locally
601      (declare (optimize (safety 3)))
602      (let ((a (make-array '5 :fill-pointer t :adjustable nil
603                           :initial-element nil)))
604        (or (notnot (adjustable-array-p a))  ; It's actually adjustable, or...
605            (vector-push-extend a 'x)        ; ... this fails
606            ))))
607   (error () t))
608  t)
Note: See TracBrowser for help on using the repository browser.