1;;;; srfi-43.test --- test suite for SRFI-43 Vector library -*- scheme -*-
2;;;;
3;;;; Copyright (C) 2014 Free Software Foundation, Inc.
4;;;;
5;;;; This library is free software; you can redistribute it and/or
6;;;; modify it under the terms of the GNU Lesser General Public
7;;;; License as published by the Free Software Foundation; either
8;;;; version 3 of the License, or (at your option) any later version.
9;;;;
10;;;; This library is distributed in the hope that it will be useful,
11;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
13;;;; Lesser General Public License for more details.
14;;;;
15;;;; You should have received a copy of the GNU Lesser General Public
16;;;; License along with this library; if not, write to the Free Software
17;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
18
19;;;
20;;; Originally written by Shiro Kawai and placed in the public domain
21;;; 10/5/2005.
22;;;
23;;; Many tests added, and adapted for Guile's (test-suite lib)
24;;; by Mark H Weaver <mhw@netris.org>, Jan 2014.
25;;;
26
27(define-module (test-suite test-srfi-43)
28  #:use-module (srfi srfi-43)
29  #:use-module (test-suite lib))
30
31(define-syntax-rule (pass-if-error name body0 body ...)
32  (pass-if name
33    (catch #t
34      (lambda () body0 body ... #f)
35      (lambda (key . args) #t))))
36
37;;;
38;;; Constructors
39;;;
40
41;;
42;; make-vector
43;;
44
45(with-test-prefix "make-vector"
46
47  (pass-if-equal "simple, no init"
48      5
49    (vector-length (make-vector 5)))
50
51  (pass-if-equal "empty"
52      '#()
53    (make-vector 0))
54
55  (pass-if-error "negative length"
56    (make-vector -4))
57
58  (pass-if-equal "simple with init"
59      '#(3 3 3 3 3)
60    (make-vector 5 3))
61
62  (pass-if-equal "empty with init"
63      '#()
64    (make-vector 0 3))
65
66  (pass-if-error "negative length"
67    (make-vector -1 3)))
68
69;;
70;; vector
71;;
72
73(with-test-prefix "vector"
74
75  (pass-if-equal "no args"
76      '#()
77    (vector))
78
79  (pass-if-equal "simple"
80      '#(1 2 3 4 5)
81    (vector 1 2 3 4 5)))
82
83;;
84;; vector-unfold
85;;
86
87(with-test-prefix "vector-unfold"
88
89  (pass-if-equal "no seeds"
90      '#(0 1 2 3 4 5 6 7 8 9)
91    (vector-unfold values 10))
92
93  (pass-if-equal "no seeds, zero len"
94      '#()
95    (vector-unfold values 0))
96
97  (pass-if-error "no seeds, negative len"
98    (vector-unfold values -1))
99
100  (pass-if-equal "1 seed"
101      '#(0 -1 -2 -3 -4 -5 -6 -7 -8 -9)
102    (vector-unfold (lambda (i x) (values x (- x 1)))
103                   10 0))
104
105  (pass-if-equal "1 seed, zero len"
106      '#()
107    (vector-unfold values 0 1))
108
109  (pass-if-error "1 seed, negative len"
110    (vector-unfold values -2 1))
111
112  (pass-if-equal "2 seeds"
113      '#((0 20) (-1 21) (-2 22) (-3 23) (-4 24)
114         (-5 25) (-6 26) (-7 27) (-8 28) (-9 29))
115    (vector-unfold (lambda (i x y) (values (list x y) (- x 1) (+ y 1)))
116                   10 0 20))
117
118  (pass-if-equal "2 seeds, zero len"
119      '#()
120    (vector-unfold values 0 1 2))
121
122  (pass-if-error "2 seeds, negative len"
123    (vector-unfold values -2 1 2))
124
125  (pass-if-equal "3 seeds"
126      '#((0 20 30) (-1 21 32) (-2 22 34) (-3 23 36) (-4 24 38)
127         (-5 25 40) (-6 26 42) (-7 27 44) (-8 28 46) (-9 29 48))
128    (vector-unfold (lambda (i x y z)
129                     (values (list x y z) (- x 1) (+ y 1) (+ z 2)))
130                   10 0 20 30))
131
132  (pass-if-equal "3 seeds, zero len"
133      '#()
134    (vector-unfold values 0 1 2 3))
135
136  (pass-if-error "3 seeds, negative len"
137    (vector-unfold values -2 1 2 3)))
138
139;;
140;; vector-unfold-right
141;;
142
143(with-test-prefix "vector-unfold-right"
144
145  (pass-if-equal "no seeds, zero len"
146      '#()
147    (vector-unfold-right values 0))
148
149  (pass-if-error "no seeds, negative len"
150    (vector-unfold-right values -1))
151
152  (pass-if-equal "1 seed"
153      '#(9 8 7 6 5 4 3 2 1 0)
154    (vector-unfold-right (lambda (i x) (values x (+ x 1))) 10 0))
155
156  (pass-if-equal "1 seed, zero len"
157      '#()
158    (vector-unfold-right values 0 1))
159
160  (pass-if-error "1 seed, negative len"
161    (vector-unfold-right values -1 1))
162
163  (pass-if-equal "1 seed, reverse vector"
164      '#(e d c b a)
165    (let ((vector '#(a b c d e)))
166      (vector-unfold-right
167       (lambda (i x) (values (vector-ref vector x) (+ x 1)))
168       (vector-length vector)
169       0)))
170
171  (pass-if-equal "2 seeds"
172      '#((0 20) (-1 21) (-2 22) (-3 23) (-4 24)
173         (-5 25) (-6 26) (-7 27) (-8 28) (-9 29))
174    (vector-unfold-right (lambda (i x y) (values (list x y) (+ x 1) (- y 1)))
175                         10 -9 29))
176
177  (pass-if-equal "2 seeds, zero len"
178      '#()
179    (vector-unfold-right values 0 1 2))
180
181  (pass-if-error "2 seeds, negative len"
182    (vector-unfold-right values -1 1 2))
183
184  (pass-if-equal "3 seeds"
185      '#((0 20 30) (-1 21 32) (-2 22 34) (-3 23 36) (-4 24 38)
186         (-5 25 40) (-6 26 42) (-7 27 44) (-8 28 46) (-9 29 48))
187    (vector-unfold-right (lambda (i x y z)
188                           (values (list x y z) (+ x 1) (- y 1) (- z 2)))
189                         10 -9 29 48))
190
191  (pass-if-equal "3 seeds, zero len"
192      '#()
193    (vector-unfold-right values 0 1 2 3))
194
195  (pass-if-error "3 seeds, negative len"
196    (vector-unfold-right values -1 1 2 3)))
197
198;;
199;; vector-copy
200;;
201
202(with-test-prefix "vector-copy"
203
204  (pass-if-equal "1 arg"
205      '#(a b c d e f g h i)
206    (vector-copy '#(a b c d e f g h i)))
207
208  (pass-if-equal "2 args"
209      '#(g h i)
210    (vector-copy '#(a b c d e f g h i) 6))
211
212  (pass-if-equal "3 args"
213      '#(d e f)
214    (vector-copy '#(a b c d e f g h i) 3 6))
215
216  (pass-if-equal "4 args"
217      '#(g h i x x x)
218    (vector-copy '#(a b c d e f g h i) 6 12 'x))
219
220  (pass-if-equal "3 args, empty range"
221      '#()
222    (vector-copy '#(a b c d e f g h i) 6 6))
223
224  (pass-if-error "3 args, invalid range"
225    (vector-copy '#(a b c d e f g h i) 4 2)))
226
227;;
228;; vector-reverse-copy
229;;
230
231(with-test-prefix "vector-reverse-copy"
232
233  (pass-if-equal "1 arg"
234      '#(e d c b a)
235    (vector-reverse-copy '#(a b c d e)))
236
237  (pass-if-equal "2 args"
238      '#(e d c)
239    (vector-reverse-copy '#(a b c d e) 2))
240
241  (pass-if-equal "3 args"
242      '#(d c b)
243    (vector-reverse-copy '#(a b c d e) 1 4))
244
245  (pass-if-equal "3 args, empty result"
246      '#()
247    (vector-reverse-copy '#(a b c d e) 1 1))
248
249  (pass-if-error "2 args, invalid range"
250    (vector-reverse-copy '#(a b c d e) 2 1)))
251
252;;
253;; vector-append
254;;
255
256(with-test-prefix "vector-append"
257
258  (pass-if-equal "no args"
259      '#()
260    (vector-append))
261
262  (pass-if-equal "1 arg"
263      '(#(1 2) #f)
264    (let* ((v (vector 1 2))
265           (v-copy (vector-append v)))
266      (list v-copy (eq? v v-copy))))
267
268  (pass-if-equal "2 args"
269      '#(x y)
270    (vector-append '#(x) '#(y)))
271
272  (pass-if-equal "3 args"
273      '#(x y x y x y)
274    (let ((v '#(x y)))
275      (vector-append v v v)))
276
277  (pass-if-equal "3 args with empty vector"
278      '#(x y)
279    (vector-append '#(x) '#() '#(y)))
280
281  (pass-if-error "3 args with non-vectors"
282    (vector-append '#() 'b 'c)))
283
284;;
285;; vector-concatenate
286;;
287
288(with-test-prefix "vector-concatenate"
289
290  (pass-if-equal "2 vectors"
291      '#(a b c d)
292    (vector-concatenate '(#(a b) #(c d))))
293
294  (pass-if-equal "no vectors"
295      '#()
296    (vector-concatenate '()))
297
298  (pass-if-error "non-vector in list"
299    (vector-concatenate '(#(a b) c))))
300
301;;;
302;;; Predicates
303;;;
304
305;;
306;; vector?
307;;
308
309(with-test-prefix "vector?"
310  (pass-if "empty vector" (vector? '#()))
311  (pass-if "simple" (vector? '#(a b)))
312  (pass-if "list" (not (vector? '(a b))))
313  (pass-if "symbol" (not (vector? 'a))))
314
315;;
316;; vector-empty?
317;;
318
319(with-test-prefix "vector-empty?"
320  (pass-if "empty vector" (vector-empty? '#()))
321  (pass-if "singleton vector" (not (vector-empty? '#(a))))
322  (pass-if-error "non-vector" (vector-empty 'a)))
323
324;;
325;; vector=
326;;
327
328(with-test-prefix "vector="
329
330  (pass-if "2 equal vectors"
331    (vector= eq? '#(a b c d) '#(a b c d)))
332
333  (pass-if "3 equal vectors"
334    (vector= eq? '#(a b c d) '#(a b c d) '#(a b c d)))
335
336  (pass-if "2 empty vectors"
337    (vector= eq? '#() '#()))
338
339  (pass-if "no vectors"
340    (vector= eq?))
341
342  (pass-if "1 vector"
343    (vector= eq? '#(a)))
344
345  (pass-if "2 unequal vectors of equal length"
346    (not (vector= eq? '#(a b c d) '#(a b d c))))
347
348  (pass-if "3 unequal vectors of equal length"
349    (not (vector= eq? '#(a b c d) '#(a b c d) '#(a b d c))))
350
351  (pass-if "2 vectors of unequal length"
352    (not (vector= eq? '#(a b c) '#(a b c d))))
353
354  (pass-if "3 vectors of unequal length"
355    (not (vector= eq? '#(a b c d) '#(a b c d) '#(a b c))))
356
357  (pass-if "2 vectors: empty, non-empty"
358    (not (vector= eq? '#() '#(a b d c))))
359
360  (pass-if "2 vectors: non-empty, empty"
361    (not (vector= eq? '#(a b d c) '#())))
362
363  (pass-if "2 equal vectors, elt= is equal?"
364    (vector= equal? '#("a" "b" "c") '#("a" "b" "c")))
365
366  (pass-if "2 equal vectors, elt= is ="
367    (vector= = '#(1/2 1/3 1/4 1/5) '#(1/2 1/3 1/4 1/5)))
368
369  (pass-if-error "vector and list"
370    (vector= equal? '#("a" "b" "c") '("a" "b" "c")))
371
372  (pass-if-error "non-procedure"
373    (vector= 1 '#("a" "b" "c") '("a" "b" "c"))))
374
375;;;
376;;; Selectors
377;;;
378
379;;
380;; vector-ref
381;;
382
383(with-test-prefix "vector-ref"
384  (pass-if-equal "simple 0" 'a (vector-ref '#(a b c) 0))
385  (pass-if-equal "simple 1" 'b (vector-ref '#(a b c) 1))
386  (pass-if-equal "simple 2" 'c (vector-ref '#(a b c) 2))
387  (pass-if-error "negative index" (vector-ref '#(a b c) -1))
388  (pass-if-error "index beyond end" (vector-ref '#(a b c) 3))
389  (pass-if-error "empty vector" (vector-ref '#() 0))
390  (pass-if-error "non-vector" (vector-ref '(a b c) 0))
391  (pass-if-error "inexact index" (vector-ref '#(a b c) 1.0)))
392
393;;
394;; vector-length
395;;
396
397(with-test-prefix "vector-length"
398  (pass-if-equal "empty vector" 0 (vector-length '#()))
399  (pass-if-equal "simple" 3 (vector-length '#(a b c)))
400  (pass-if-error "non-vector" (vector-length '(a b c))))
401
402;;;
403;;; Iteration
404;;;
405
406;;
407;; vector-fold
408;;
409
410(with-test-prefix "vector-fold"
411
412  (pass-if-equal "1 vector"
413      10
414    (vector-fold (lambda (i seed val) (+ seed val))
415                 0
416                 '#(0 1 2 3 4)))
417
418  (pass-if-equal "1 empty vector"
419      'a
420    (vector-fold (lambda (i seed val) (+ seed val))
421                 'a
422                 '#()))
423
424  (pass-if-equal "1 vector, use index"
425      30
426    (vector-fold (lambda (i seed val) (+ seed (* i val)))
427                 0
428                 '#(0 1 2 3 4)))
429
430  (pass-if-equal "2 vectors, unequal lengths"
431      '(1 -7 1 -1)
432    (vector-fold (lambda (i seed x y) (cons (- x y) seed))
433                 '()
434                 '#(6 1 2 3 4) '#(7 0 9 2)))
435
436  (pass-if-equal "3 vectors, unequal lengths"
437      '(51 33 31 19)
438    (vector-fold (lambda (i seed x y z) (cons (- x y z) seed))
439                 '()
440                 '#(6 1 2 3 4) '#(7 0 9 2) '#(-20 -30 -40 -50 -60 -70)))
441
442  (pass-if-error "5 args, non-vector"
443    (vector-fold (lambda (i seed x y z) (cons (- x y z) seed))
444                 '()
445                 '#(6 1 2 3 4) '#(7 0 9 2) '(-20 -30 -40 -50 -60 -70)))
446
447  (pass-if-error "non-procedure"
448    (vector-fold 1 '() '#(6 1 2 3 4) '#(7 0 9 2))))
449
450;;
451;; vector-fold-right
452;;
453
454(with-test-prefix "vector-fold-right"
455
456  (pass-if-equal "1 vector"
457      '((0 . a) (1 . b) (2 . c) (3 . d) (4 . e))
458    (vector-fold-right (lambda (i seed val) (cons (cons i val) seed))
459                       '()
460                       '#(a b c d e)))
461
462  (pass-if-equal "2 vectors, unequal lengths"
463      '(-1 1 -7 1)
464    (vector-fold-right (lambda (i seed x y) (cons (- x y) seed))
465                       '()
466                       '#(6 1 2 3 7) '#(7 0 9 2)))
467
468  (pass-if-equal "3 vectors, unequal lengths"
469      '(19 31 33 51)
470    (vector-fold-right (lambda (i seed x y z) (cons (- x y z) seed))
471                       '()
472                       '#(6 1 2 3 4) '#(7 0 9 2) '#(-20 -30 -40 -50 -60 -70)))
473
474  (pass-if-error "5 args, non-vector"
475    (vector-fold-right (lambda (i seed x y z) (cons (- x y z) seed))
476                       '()
477                       '#(6 1 2 3 4) '#(7 0 9 2) '(-20 -30 -40 -50 -60 -70)))
478
479  (pass-if-error "non-procedure"
480    (vector-fold-right 1 '() '#(6 1 2 3 4) '#(7 0 9 2))))
481
482;;
483;; vector-map
484;;
485
486(with-test-prefix "vector-map"
487
488  (pass-if-equal "1 vector"
489      '#((0 . a) (1 . b) (2 . c) (3 . d) (4 . e))
490    (vector-map cons '#(a b c d e)))
491
492  (pass-if-equal "1 empty vector"
493      '#()
494    (vector-map cons '#()))
495
496  (pass-if-equal "2 vectors, unequal lengths"
497      '#(5 8 11 14)
498    (vector-map + '#(0 1 2 3 4) '#(5 6 7 8)))
499
500  (pass-if-equal "3 vectors, unequal lengths"
501      '#(15 28 41 54)
502    (vector-map + '#(0 1 2 3 4) '#(5 6 7 8) '#(10 20 30 40 50 60)))
503
504  (pass-if-error "4 args, non-vector"
505    (vector-map + '#(0 1 2 3 4) '(5 6 7 8) '#(10 20 30 40 50 60)))
506
507  (pass-if-error "3 args, non-vector"
508    (vector-map + '#(0 1 2 3 4) '(5 6 7 8)))
509
510  (pass-if-error "non-procedure"
511    (vector-map #f '#(0 1 2 3 4) '#(5 6 7 8) '#(10 20 30 40 50 60))))
512
513;;
514;; vector-map!
515;;
516
517(with-test-prefix "vector-map!"
518
519  (pass-if-equal "1 vector"
520      '#(0 1 4 9 16)
521    (let ((v (vector 0 1 2 3 4)))
522      (vector-map! * v)
523      v))
524
525  (pass-if-equal "1 empty vector"
526      '#()
527    (let ((v (vector)))
528      (vector-map! * v)
529      v))
530
531  (pass-if-equal "2 vectors, unequal lengths"
532      '#(5 8 11 14 4)
533    (let ((v (vector 0 1 2 3 4)))
534      (vector-map! + v '#(5 6 7 8))
535      v))
536
537  (pass-if-equal "3 vectors, unequal lengths"
538      '#(15 28 41 54 4)
539    (let ((v (vector 0 1 2 3 4)))
540      (vector-map! + v '#(5 6 7 8) '#(10 20 30 40 50 60))
541      v))
542
543  (pass-if-error "non-vector"
544    (let ((v (vector 0 1 2 3 4)))
545      (vector-map! + v '#(5 6 7 8) '(10 20 30 40 50 60))
546      v))
547
548  (pass-if-error "non-procedure"
549    (let ((v (vector 0 1 2 3 4)))
550      (vector-map! '(1 . 2) v '#(5 6 7 8) '#(10 20 30 40 50 60))
551      v)))
552
553;;
554;; vector-for-each
555;;
556
557(with-test-prefix "vector-for-each"
558
559  (pass-if-equal "1 vector"
560      '(4 6 6 4 0)
561    (let ((lst '()))
562      (vector-for-each (lambda (i x)
563                         (set! lst (cons (* i x) lst)))
564                       '#(5 4 3 2 1))
565      lst))
566
567  (pass-if-equal "1 empty vector"
568      '()
569    (let ((lst '()))
570      (vector-for-each (lambda (i x)
571                         (set! lst (cons (* i x) lst)))
572                       '#())
573      lst))
574
575  (pass-if-equal "2 vectors, unequal lengths"
576      '(13 11 7 2)
577    (let ((lst '()))
578      (vector-for-each (lambda (i x y)
579                         (set! lst (cons (+ (* i x) y) lst)))
580                       '#(5 4 3 2 1)
581                       '#(2 3 5 7))
582      lst))
583
584  (pass-if-equal "3 vectors, unequal lengths"
585      '(-6 -6 -6 -9)
586    (let ((lst '()))
587      (vector-for-each (lambda (i x y z)
588                         (set! lst (cons (+ (* i x) (- y z)) lst)))
589                       '#(5 4 3 2 1)
590                       '#(2 3 5 7)
591                       '#(11 13 17 19 23 29))
592      lst))
593
594  (pass-if-error "non-vector"
595    (let ((lst '()))
596      (vector-for-each (lambda (i x y z)
597                         (set! lst (cons (+ (* i x) (- y z)) lst)))
598                       '#(5 4 3 2 1)
599                       '(2 3 5 7)
600                       '#(11 13 17 19 23 29))
601      lst))
602
603  (pass-if-error "non-procedure"
604    (let ((lst '()))
605      (vector-for-each '#(not a procedure)
606                       '#(5 4 3 2 1)
607                       '#(2 3 5 7)
608                       '#(11 13 17 19 23 29))
609      lst)))
610
611;;
612;; vector-count
613;;
614
615(with-test-prefix "vector-count"
616
617  (pass-if-equal "1 vector"
618      3
619    (vector-count (lambda (i x) (even? (+ i x))) '#(2 3 5 7 11)))
620
621  (pass-if-equal "1 empty vector"
622      0
623    (vector-count values '#()))
624
625  (pass-if-equal "2 vectors, unequal lengths"
626      3
627    (vector-count (lambda (i x y) (< x (* i y)))
628                  '#(8 2 7 8 9 1 0)
629                  '#(7 6 4 3 1)))
630
631  (pass-if-equal "3 vectors, unequal lengths"
632      2
633    (vector-count (lambda (i x y z) (<= x (- y i) z))
634                  '#(3 6 3 0 2 4 1)
635                  '#(8 7 4 4 9)
636                  '#(7 6 8 3 1 7 9)))
637
638  (pass-if-error "non-vector"
639    (vector-count (lambda (i x y z) (<= x (- y i) z))
640                  '#(3 6 3 0 2 4 1)
641                  '#(8 7 4 4 9)
642                  '(7 6 8 3 1 7 9)))
643
644  (pass-if-error "non-procedure"
645    (vector-count '(1 2)
646                  '#(3 6 3 0 2 4 1)
647                  '#(8 7 4 4 9)
648                  '#(7 6 8 3 1 7 9))))
649
650;;;
651;;; Searching
652;;;
653
654;;
655;; vector-index
656;;
657
658(with-test-prefix "vector-index"
659
660  (pass-if-equal "1 vector"
661      2
662    (vector-index even? '#(3 1 4 1 6 9)))
663
664  (pass-if-equal "2 vectors, unequal lengths, success"
665      1
666    (vector-index < '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2)))
667
668  (pass-if-equal "2 vectors, unequal lengths, failure"
669      #f
670    (vector-index = '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2)))
671
672  (pass-if-error "non-procedure"
673    (vector-index 1 '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2)))
674
675  (pass-if-error "3 args, non-vector"
676    (vector-index = '#(3 1 4 1 5 9 2 5 6) '(2 7 1 8 2)))
677
678  (pass-if-error "4 args, non-vector"
679    (vector-index = '#(3 1 4 1 5 9 2 5 6) '(2 7 1 8 2) '#(1 2 3)))
680
681  (pass-if-equal "3 vectors, unequal lengths, success"
682      1
683    (vector-index <
684                  '#(3 1 4 1 5 9 2 5 6)
685                  '#(2 6 1 7 2)
686                  '#(2 7 1 8)))
687
688  (pass-if-equal "3 vectors, unequal lengths, failure"
689      #f
690    (vector-index <
691                  '#(3 1 4 1 5 9 2 5 6)
692                  '#(2 7 1 7 2)
693                  '#(2 7 1 7)))
694
695  (pass-if-equal "empty vector"
696      #f
697    (vector-index < '#() '#(2 7 1 8 2))))
698
699;;
700;; vector-index-right
701;;
702
703(with-test-prefix "vector-index-right"
704
705  (pass-if-equal "1 vector"
706      4
707    (vector-index-right even? '#(3 1 4 1 6 9)))
708
709  (pass-if-equal "2 vectors, unequal lengths, success"
710      3
711    (vector-index-right < '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2)))
712
713  (pass-if-equal "2 vectors, unequal lengths, failure"
714      #f
715    (vector-index-right = '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2)))
716
717  (pass-if-error "non-procedure"
718    (vector-index-right 1 '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2)))
719
720  (pass-if-error "3 args, non-vector"
721    (vector-index-right = '#(3 1 4 1 5 9 2 5 6) '(2 7 1 8 2)))
722
723  (pass-if-error "4 args, non-vector"
724    (vector-index-right = '#(3 1 4 1 5 9 2 5 6) '(2 7 1 8 2) '#(1 2 3)))
725
726  (pass-if-equal "3 vectors, unequal lengths, success"
727      3
728    (vector-index-right <
729                        '#(3 1 4 1 5 9 2 5 6)
730                        '#(2 6 1 7 2)
731                        '#(2 7 1 8)))
732
733  (pass-if-equal "3 vectors, unequal lengths, failure"
734      #f
735    (vector-index-right <
736                        '#(3 1 4 1 5 9 2 5 6)
737                        '#(2 7 1 7 2)
738                        '#(2 7 1 7)))
739
740  (pass-if-equal "empty vector"
741      #f
742    (vector-index-right < '#() '#(2 7 1 8 2))))
743
744;;
745;; vector-skip
746;;
747
748(with-test-prefix "vector-skip"
749
750  (pass-if-equal "1 vector"
751      2
752    (vector-skip odd? '#(3 1 4 1 6 9)))
753
754  (pass-if-equal "2 vectors, unequal lengths, success"
755      1
756    (vector-skip >= '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2)))
757
758  (pass-if-equal "2 vectors, unequal lengths, failure"
759      #f
760    (vector-skip (negate =) '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2)))
761
762  (pass-if-error "non-procedure"
763    (vector-skip 1 '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2)))
764
765  (pass-if-error "3 args, non-vector"
766    (vector-skip = '#(3 1 4 1 5 9 2 5 6) '(2 7 1 8 2)))
767
768  (pass-if-error "4 args, non-vector"
769    (vector-skip = '#(3 1 4 1 5 9 2 5 6) '(2 7 1 8 2) '#(1 2 3)))
770
771  (pass-if-equal "3 vectors, unequal lengths, success"
772      1
773    (vector-skip (negate <)
774                 '#(3 1 4 1 5 9 2 5 6)
775                 '#(2 6 1 7 2)
776                 '#(2 7 1 8)))
777
778  (pass-if-equal "3 vectors, unequal lengths, failure"
779      #f
780    (vector-skip (negate <)
781                 '#(3 1 4 1 5 9 2 5 6)
782                 '#(2 7 1 7 2)
783                 '#(2 7 1 7)))
784
785  (pass-if-equal "empty vector"
786      #f
787    (vector-skip (negate <) '#() '#(2 7 1 8 2))))
788
789;;
790;; vector-skip-right
791;;
792
793(with-test-prefix "vector-skip-right"
794
795  (pass-if-equal "1 vector"
796      4
797    (vector-skip-right odd? '#(3 1 4 1 6 9)))
798
799  (pass-if-equal "2 vectors, unequal lengths, success"
800      3
801    (vector-skip-right >= '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2)))
802
803  (pass-if-equal "2 vectors, unequal lengths, failure"
804      #f
805    (vector-skip-right (negate =) '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2)))
806
807  (pass-if-error "non-procedure"
808    (vector-skip-right 1 '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2)))
809
810  (pass-if-error "3 args, non-vector"
811    (vector-skip-right = '#(3 1 4 1 5 9 2 5 6) '(2 7 1 8 2)))
812
813  (pass-if-error "4 args, non-vector"
814    (vector-skip-right = '#(3 1 4 1 5 9 2 5 6) '(2 7 1 8 2) '#(1 2 3)))
815
816  (pass-if-equal "3 vectors, unequal lengths, success"
817      3
818    (vector-skip-right (negate <)
819                       '#(3 1 4 1 5 9 2 5 6)
820                       '#(2 6 1 7 2)
821                       '#(2 7 1 8)))
822
823  (pass-if-equal "3 vectors, unequal lengths, failure"
824      #f
825    (vector-skip-right (negate <)
826                       '#(3 1 4 1 5 9 2 5 6)
827                       '#(2 7 1 7 2)
828                       '#(2 7 1 7)))
829
830  (pass-if-equal "empty vector"
831      #f
832    (vector-skip-right (negate <) '#() '#(2 7 1 8 2))))
833
834;;
835;; vector-binary-search
836;;
837
838(with-test-prefix "vector-binary-search"
839
840  (define (char-cmp c1 c2)
841    (cond ((char<? c1 c2) -1)
842          ((char=? c1 c2) 0)
843          (else 1)))
844
845  (pass-if-equal "success"
846      6
847    (vector-binary-search '#(#\a #\b #\c #\d #\e #\f #\g #\h)
848                          #\g
849                          char-cmp))
850
851  (pass-if-equal "failure"
852      #f
853    (vector-binary-search '#(#\a #\b #\c #\d #\e #\f #\g)
854                          #\q
855                          char-cmp))
856
857  (pass-if-equal "singleton vector, success"
858      0
859    (vector-binary-search '#(#\a)
860                          #\a
861                          char-cmp))
862
863  (pass-if-equal "empty vector"
864      #f
865    (vector-binary-search '#()
866                          #\a
867                          char-cmp))
868
869  (pass-if-error "first element"
870    (vector-binary-search '(#\a #\b #\c)
871                          #\a
872                          char-cmp))
873
874  (pass-if-equal "specify range, success"
875      3
876    (vector-binary-search '#(#\a #\b #\c #\d #\e #\f #\g #\h)
877                          #\d
878                          char-cmp
879                          2 6))
880
881  (pass-if-equal "specify range, failure"
882      #f
883    (vector-binary-search '#(#\a #\b #\c #\d #\e #\f #\g #\h)
884                          #\g
885                          char-cmp
886                          2 6)))
887
888;;
889;; vector-any
890;;
891
892(with-test-prefix "vector-any"
893
894  (pass-if-equal "1 vector, success"
895      #t
896    (vector-any even? '#(3 1 4 1 5 9 2)))
897
898  (pass-if-equal "1 vector, failure"
899      #f
900    (vector-any even? '#(3 1 5 1 5 9 1)))
901
902  (pass-if-equal "1 vector, left-to-right"
903      #t
904    (vector-any even? '#(3 1 4 1 5 #f 2)))
905
906  (pass-if-equal "1 vector, left-to-right"
907      4
908    (vector-any (lambda (x) (and (even? x) x))
909                '#(3 1 4 1 5 #f 2)))
910
911  (pass-if-equal "1 empty vector"
912      #f
913    (vector-any even? '#()))
914
915  (pass-if-equal "2 vectors, unequal lengths, success"
916      '(1 2)
917    (vector-any (lambda (x y) (and (< x y) (list x y)))
918                '#(3 1 4 1 5 #f)
919                '#(1 0 1 2 3)))
920
921  (pass-if-equal "2 vectors, unequal lengths, failure"
922      #f
923    (vector-any < '#(3 1 4 1 5 #f) '#(1 0 1 0 3)))
924
925  (pass-if-equal "3 vectors, unequal lengths, success"
926      '(1 2 3)
927    (vector-any (lambda (x y z) (and (< x y z) (list x y z)))
928                '#(3 1 4 1 3 #f)
929                '#(1 0 1 2 4)
930                '#(2 1 6 3 5)))
931
932  (pass-if-equal "3 vectors, unequal lengths, failure"
933      #f
934    (vector-any <
935                '#(3 1 4 1 5 #f)
936                '#(1 0 3 2)
937                '#(2 1 6 2 3))))
938
939;;
940;; vector-every
941;;
942
943(with-test-prefix "vector-every"
944
945  (pass-if-equal "1 vector, failure"
946      #f
947    (vector-every odd? '#(3 1 4 1 5 9 2)))
948
949  (pass-if-equal "1 vector, success"
950      11
951    (vector-every (lambda (x) (and (odd? x) x))
952                  '#(3 5 7 1 5 9 11)))
953
954  (pass-if-equal "1 vector, left-to-right, failure"
955      #f
956    (vector-every odd? '#(3 1 4 1 5 #f 2)))
957
958  (pass-if-equal "1 empty vector"
959      #t
960    (vector-every even? '#()))
961
962  (pass-if-equal "2 vectors, unequal lengths, left-to-right, failure"
963      #f
964    (vector-every >= '#(3 1 4 1 5) '#(1 0 1 2 3 #f)))
965
966  (pass-if-equal "2 vectors, unequal lengths, left-to-right, success"
967      '(5 3)
968    (vector-every (lambda (x y) (and (>= x y) (list x y)))
969                  '#(3 1 4 1 5)
970                  '#(1 0 1 0 3 #f)))
971
972  (pass-if-equal "3 vectors, unequal lengths, left-to-right, failure"
973      #f
974    (vector-every >=
975                  '#(3 1 4 1 5)
976                  '#(1 0 1 2 3 #f)
977                  '#(0 0 1 2)))
978
979  (pass-if-equal "3 vectors, unequal lengths, left-to-right, success"
980      '(8 5 4)
981    (vector-every (lambda (x y z) (and (>= x y z) (list x y z)))
982                  '#(3 5 4 8 5)
983                  '#(2 3 4 5 3 #f)
984                  '#(1 2 3 4))))
985
986;;;
987;;; Mutators
988;;;
989
990;;
991;; vector-set!
992;;
993
994(with-test-prefix "vector-set!"
995
996  (pass-if-equal "simple"
997      '#(0 a 2)
998    (let ((v (vector 0 1 2)))
999      (vector-set! v 1 'a)
1000      v))
1001
1002  (pass-if-error "index beyond end" (vector-set! (vector 0 1 2) 3 'a))
1003  (pass-if-error "negative index" (vector-set! (vector 0 1 2) -1 'a))
1004  (pass-if-error "empty vector" (vector-set! (vector) 0 'a)))
1005
1006;;
1007;; vector-swap!
1008;;
1009
1010(with-test-prefix "vector-swap!"
1011
1012  (pass-if-equal "simple"
1013      '#(b a c)
1014    (let ((v (vector 'a 'b 'c)))
1015      (vector-swap! v 0 1)
1016      v))
1017
1018  (pass-if-equal "same index"
1019      '#(a b c)
1020    (let ((v (vector 'a 'b 'c)))
1021      (vector-swap! v 1 1)
1022      v))
1023
1024  (pass-if-error "index beyond end" (vector-swap! (vector 'a 'b 'c) 0 3))
1025  (pass-if-error "negative index" (vector-swap! (vector 'a 'b 'c) -1 1))
1026  (pass-if-error "empty vector" (vector-swap! (vector) 0 0)))
1027
1028;;
1029;; vector-fill!
1030;;
1031
1032(with-test-prefix "vector-fill!"
1033
1034  (pass-if-equal "2 args"
1035      '#(z z z z z)
1036    (let ((v (vector 'a 'b 'c 'd 'e)))
1037      (vector-fill! v 'z)
1038      v))
1039
1040  (pass-if-equal "3 args"
1041      '#(a b z z z)
1042    (let ((v (vector 'a 'b 'c 'd 'e)))
1043      (vector-fill! v 'z 2)
1044      v))
1045
1046  (pass-if-equal "4 args"
1047      '#(a z z d e)
1048    (let ((v (vector 'a 'b 'c 'd 'e)))
1049      (vector-fill! v 'z 1 3)
1050      v))
1051
1052  (pass-if-equal "4 args, entire vector"
1053      '#(z z z z z)
1054    (let ((v (vector 'a 'b 'c 'd 'e)))
1055      (vector-fill! v 'z 0 5)
1056      v))
1057
1058  (pass-if-equal "4 args, empty range"
1059      '#(a b c d e)
1060    (let ((v (vector 'a 'b 'c 'd 'e)))
1061      (vector-fill! v 'z 2 2)
1062      v))
1063
1064  (pass-if-error "index beyond end" (vector-fill! (vector 'a 'b 'c) 'z 0 4))
1065  (pass-if-error "invalid range" (vector-fill! (vector 'a 'b 'c) 'z 2 1))
1066  (pass-if-error "negative index" (vector-fill! (vector 'a 'b 'c) 'z -1 1))
1067
1068  ;; This is intentionally allowed in Guile, as an extension:
1069  ;;(pass-if-error "vector-fill! e3" (vector-fill! (vector) 'z 0 0))
1070  )
1071
1072;;
1073;; vector-reverse!
1074;;
1075
1076(with-test-prefix "vector-reverse!"
1077
1078  (pass-if-equal "1 arg"
1079      '#(e d c b a)
1080    (let ((v (vector 'a 'b 'c 'd 'e)))
1081      (vector-reverse! v)
1082      v))
1083
1084  (pass-if-equal "2 args"
1085      '#(a b f e d c)
1086    (let ((v (vector 'a 'b 'c 'd 'e 'f)))
1087      (vector-reverse! v 2)
1088      v))
1089
1090  (pass-if-equal "3 args"
1091      '#(a d c b e f)
1092    (let ((v (vector 'a 'b 'c 'd 'e 'f)))
1093      (vector-reverse! v 1 4)
1094      v))
1095
1096  (pass-if-equal "3 args, empty range"
1097      '#(a b c d e f)
1098    (let ((v (vector 'a 'b 'c 'd 'e 'f)))
1099      (vector-reverse! v 3 3)
1100      v))
1101
1102  (pass-if-equal "3 args, singleton range"
1103      '#(a b c d e f)
1104    (let ((v (vector 'a 'b 'c 'd 'e 'f)))
1105      (vector-reverse! v 3 4)
1106      v))
1107
1108  (pass-if-equal "empty vector"
1109      '#()
1110    (let ((v (vector)))
1111      (vector-reverse! v)
1112      v))
1113
1114  (pass-if-error "index beyond end" (vector-reverse! (vector 'a 'b) 0 3))
1115  (pass-if-error "invalid range" (vector-reverse! (vector 'a 'b) 2 1))
1116  (pass-if-error "negative index" (vector-reverse! (vector 'a 'b) -1 1))
1117
1118  ;; This is intentionally allowed in Guile, as an extension:
1119  ;;(pass-if-error "vector-reverse! e3" (vector-reverse! (vector) 0 0))
1120  )
1121
1122;;
1123;; vector-copy!
1124;;
1125
1126(with-test-prefix "vector-copy!"
1127
1128  (pass-if-equal "3 args, 0 tstart"
1129      '#(1 2 3 d e)
1130    (let ((v (vector 'a 'b 'c 'd 'e)))
1131      (vector-copy! v 0 '#(1 2 3))
1132      v))
1133
1134  (pass-if-equal "3 args, 2 tstart"
1135      '#(a b 1 2 3)
1136    (let ((v (vector 'a 'b 'c 'd 'e)))
1137      (vector-copy! v 2 '#(1 2 3))
1138      v))
1139
1140  (pass-if-equal "4 args"
1141      '#(a b 2 3 e)
1142    (let ((v (vector 'a 'b 'c 'd 'e)))
1143      (vector-copy! v 2 '#(1 2 3) 1)
1144      v))
1145
1146  (pass-if-equal "5 args"
1147      '#(a b 3 4 5)
1148    (let ((v (vector 'a 'b 'c 'd 'e)))
1149      (vector-copy! v 2 '#(1 2 3 4 5) 2 5)
1150      v))
1151
1152  (pass-if-equal "5 args, empty range"
1153      '#(a b c d e)
1154    (let ((v (vector 'a 'b 'c 'd 'e)))
1155      (vector-copy! v 2 '#(1 2 3) 1 1)
1156      v))
1157
1158  (pass-if-equal "overlapping source/target, moving right"
1159      '#(b c c d e)
1160    (let ((v (vector 'a 'b 'c 'd 'e)))
1161      (vector-copy! v 0 v 1 3)
1162      v))
1163
1164  (pass-if-equal "overlapping source/target, moving left"
1165      '#(a b b c d)
1166    (let ((v (vector 'a 'b 'c 'd 'e)))
1167      (vector-copy! v 2 v 1 4)
1168      v))
1169
1170  (pass-if-equal "overlapping source/target, not moving"
1171      '#(a b c d e)
1172    (let ((v (vector 'a 'b 'c 'd 'e)))
1173      (vector-copy! v 0 v 0)
1174      v))
1175
1176  (pass-if-error "tstart beyond end"
1177    (vector-copy! (vector 1 2) 3 '#(1 2 3)))
1178  (pass-if-error "would overwrite target end"
1179    (vector-copy! (vector 1 2) 0 '#(1 2 3)))
1180  (pass-if-error "would overwrite target end"
1181    (vector-copy! (vector 1 2) 1 '#(1 2 3) 1)))
1182
1183;;
1184;; vector-reverse-copy!
1185;;
1186
1187(with-test-prefix "vector-reverse-copy!"
1188
1189  (pass-if-equal "3 args, 0 tstart"
1190      '#(3 2 1 d e)
1191    (let ((v (vector 'a 'b 'c 'd 'e)))
1192      (vector-reverse-copy! v 0 '#(1 2 3))
1193      v))
1194
1195  (pass-if-equal "3 args, 2 tstart"
1196      '#(a b 3 2 1)
1197    (let ((v (vector 'a 'b 'c 'd 'e)))
1198      (vector-reverse-copy! v 2 '#(1 2 3))
1199      v))
1200
1201  (pass-if-equal "4 args"
1202      '#(a b 3 2 e)
1203    (let ((v (vector 'a 'b 'c 'd 'e)))
1204      (vector-reverse-copy! v 2 '#(1 2 3) 1)
1205      v))
1206
1207  (pass-if-equal "5 args"
1208      '#(a b 4 3 2)
1209    (let ((v (vector 'a 'b 'c 'd 'e)))
1210      (vector-reverse-copy! v 2 '#(1 2 3 4 5) 1 4)
1211      v))
1212
1213  (pass-if-equal "5 args, empty range"
1214      '#(a b c d e)
1215    (let ((v (vector 'a 'b 'c 'd 'e)))
1216      (vector-reverse-copy! v 2 '#(1 2 3 4 5) 2 2)
1217      v))
1218
1219  (pass-if-equal "3 args, overlapping source/target"
1220      '#(e d c b a)
1221    (let ((v (vector 'a 'b 'c 'd 'e)))
1222      (vector-reverse-copy! v 0 v)
1223      v))
1224
1225  (pass-if-equal "5 args, overlapping source/target"
1226      '#(b a c d e)
1227    (let ((v (vector 'a 'b 'c 'd 'e)))
1228      (vector-reverse-copy! v 0 v 0 2)
1229      v))
1230
1231  (pass-if-error "3 args, would overwrite target end"
1232    (vector-reverse-copy! (vector 'a 'b) 2 '#(a b)))
1233  (pass-if-error "3 args, negative tstart"
1234    (vector-reverse-copy! (vector 'a 'b) -1 '#(a b)))
1235  (pass-if-error "3 args, would overwrite target end"
1236    (vector-reverse-copy! (vector 'a 'b) 0 '#(a b c)))
1237  (pass-if-error "5 args, send beyond end"
1238    (vector-reverse-copy! (vector 'a 'b) 0 '#(a b c) 1 4))
1239  (pass-if-error "5 args, negative sstart"
1240    (vector-reverse-copy! (vector 'a 'b) 0 '#(a b c) -1 2))
1241  (pass-if-error "5 args, invalid source range"
1242    (vector-reverse-copy! (vector 'a 'b) 0 '#(a b c) 2 1)))
1243
1244;;;
1245;;; Conversion
1246;;;
1247
1248;;
1249;; vector->list
1250;;
1251
1252(with-test-prefix "vector->list"
1253
1254  (pass-if-equal "1 arg"
1255      '(a b c)
1256    (vector->list '#(a b c)))
1257
1258  (pass-if-equal "2 args"
1259      '(b c)
1260    (vector->list '#(a b c) 1))
1261
1262  (pass-if-equal "3 args"
1263      '(b c d)
1264    (vector->list '#(a b c d e) 1 4))
1265
1266  (pass-if-equal "3 args, empty range"
1267      '()
1268    (vector->list '#(a b c d e) 1 1))
1269
1270  (pass-if-equal "1 arg, empty vector"
1271      '()
1272    (vector->list '#()))
1273
1274  (pass-if-error "index beyond end" (vector->list '#(a b c) 1 6))
1275  (pass-if-error "negative index" (vector->list '#(a b c) -1 1))
1276  (pass-if-error "invalid range" (vector->list '#(a b c) 2 1)))
1277
1278;;
1279;; reverse-vector->list
1280;;
1281
1282(with-test-prefix "reverse-vector->list"
1283
1284  (pass-if-equal "1 arg"
1285      '(c b a)
1286    (reverse-vector->list '#(a b c)))
1287
1288  (pass-if-equal "2 args"
1289      '(c b)
1290    (reverse-vector->list '#(a b c) 1))
1291
1292  (pass-if-equal "3 args"
1293      '(d c b)
1294    (reverse-vector->list '#(a b c d e) 1 4))
1295
1296  (pass-if-equal "3 args, empty range"
1297      '()
1298    (reverse-vector->list '#(a b c d e) 1 1))
1299
1300  (pass-if-equal "1 arg, empty vector"
1301      '()
1302    (reverse-vector->list '#()))
1303
1304  (pass-if-error "index beyond end" (reverse-vector->list '#(a b c) 1 6))
1305  (pass-if-error "negative index" (reverse-vector->list '#(a b c) -1 1))
1306  (pass-if-error "invalid range" (reverse-vector->list '#(a b c) 2 1)))
1307
1308;;
1309;; list->vector
1310;;
1311
1312(with-test-prefix "list->vector"
1313
1314  (pass-if-equal "1 arg"
1315      '#(a b c)
1316    (list->vector '(a b c)))
1317
1318  (pass-if-equal "1 empty list"
1319      '#()
1320    (list->vector '()))
1321
1322  (pass-if-equal "2 args"
1323      '#(2 3)
1324    (list->vector '(0 1 2 3) 2))
1325
1326  (pass-if-equal "3 args"
1327      '#(0 1)
1328    (list->vector '(0 1 2 3) 0 2))
1329
1330  (pass-if-equal "3 args, empty range"
1331      '#()
1332    (list->vector '(0 1 2 3) 2 2))
1333
1334  (pass-if-error "index beyond end" (list->vector '(0 1 2 3) 0 5))
1335  (pass-if-error "negative index" (list->vector '(0 1 2 3) -1 1))
1336  (pass-if-error "invalid range" (list->vector '(0 1 2 3) 2 1)))
1337
1338;;
1339;; reverse-list->vector
1340;;
1341
1342(with-test-prefix "reverse-list->vector"
1343
1344  (pass-if-equal "1 arg"
1345      '#(c b a)
1346    (reverse-list->vector '(a b c)))
1347
1348  (pass-if-equal "1 empty list"
1349      '#()
1350    (reverse-list->vector '()))
1351
1352  (pass-if-equal "2 args"
1353      '#(3 2)
1354    (reverse-list->vector '(0 1 2 3) 2))
1355
1356  (pass-if-equal "3 args"
1357      '#(1 0)
1358    (reverse-list->vector '(0 1 2 3) 0 2))
1359
1360  (pass-if-equal "3 args, empty range"
1361      '#()
1362    (reverse-list->vector '(0 1 2 3) 2 2))
1363
1364  (pass-if-error "index beyond end"
1365    (reverse-list->vector '(0 1 2 3) 0 5))
1366
1367  (pass-if-error "negative index"
1368    (reverse-list->vector '(0 1 2 3) -1 1))
1369
1370  (pass-if-error "invalid range"
1371    (reverse-list->vector '(0 1 2 3) 2 1)))
1372
1373;;; Local Variables:
1374;;; eval: (put 'pass-if-error 'scheme-indent-function 1)
1375;;; End:
1376