test-suite/tests/arrays.test

   1 ;;;; arrays.test --- tests guile's uniform arrays     -*- scheme -*-
   2 ;;;;
   3 ;;;; Copyright 2004, 2006, 2009, 2010, 2011, 2012, 2013, 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 (define-module (test-suite test-arrays)
  20   #:use-module ((system base compile) #:select (compile))
  21   #:use-module (test-suite lib)
  22   #:use-module (srfi srfi-4)
  23   #:use-module (srfi srfi-4 gnu))
  24
  25 ;;;
  26 ;;; array?
  27 ;;;
  28
  29 (define exception:wrong-num-indices
  30   (cons 'misc-error "^wrong number of indices.*"))
  31
  32 (define exception:length-non-negative
  33   (cons 'read-error ".*array length must be non-negative.*"))
  34
  35
  36 (with-test-prefix "array?"
  37
  38   (let ((bool     (make-typed-array 'b    #t  '(5 6)))
  39         (char     (make-typed-array 'a    #\a '(5 6)))
  40         (byte     (make-typed-array 'u8   0   '(5 6)))
  41         (short    (make-typed-array 's16  0   '(5 6)))
  42         (ulong    (make-typed-array 'u32  0   '(5 6)))
  43         (long     (make-typed-array 's32  0   '(5 6)))
  44         (longlong (make-typed-array 's64  0   '(5 6)))
  45         (float    (make-typed-array 'f32  0   '(5 6)))
  46         (double   (make-typed-array 'f64  0   '(5 6)))
  47         (complex  (make-typed-array 'c64  0   '(5 6)))
  48         (scm      (make-typed-array #t    0   '(5 6))))
  49
  50     (with-test-prefix "is bool"
  51       (pass-if (eq? #t (typed-array? bool     'b)))
  52       (pass-if (eq? #f (typed-array? char     'b)))
  53       (pass-if (eq? #f (typed-array? byte     'b)))
  54       (pass-if (eq? #f (typed-array? short    'b)))
  55       (pass-if (eq? #f (typed-array? ulong    'b)))
  56       (pass-if (eq? #f (typed-array? long     'b)))
  57       (pass-if (eq? #f (typed-array? longlong 'b)))
  58       (pass-if (eq? #f (typed-array? float    'b)))
  59       (pass-if (eq? #f (typed-array? double   'b)))
  60       (pass-if (eq? #f (typed-array? complex  'b)))
  61       (pass-if (eq? #f (typed-array? scm      'b))))
  62
  63     (with-test-prefix "is char"
  64       (pass-if (eq? #f (typed-array? bool     'a)))
  65       (pass-if (eq? #t (typed-array? char     'a)))
  66       (pass-if (eq? #f (typed-array? byte     'a)))
  67       (pass-if (eq? #f (typed-array? short    'a)))
  68       (pass-if (eq? #f (typed-array? ulong    'a)))
  69       (pass-if (eq? #f (typed-array? long     'a)))
  70       (pass-if (eq? #f (typed-array? longlong 'a)))
  71       (pass-if (eq? #f (typed-array? float    'a)))
  72       (pass-if (eq? #f (typed-array? double   'a)))
  73       (pass-if (eq? #f (typed-array? complex  'a)))
  74       (pass-if (eq? #f (typed-array? scm      'a))))
  75
  76     (with-test-prefix "is byte"
  77       (pass-if (eq? #f (typed-array? bool     'u8)))
  78       (pass-if (eq? #f (typed-array? char     'u8)))
  79       (pass-if (eq? #t (typed-array? byte     'u8)))
  80       (pass-if (eq? #f (typed-array? short    'u8)))
  81       (pass-if (eq? #f (typed-array? ulong    'u8)))
  82       (pass-if (eq? #f (typed-array? long     'u8)))
  83       (pass-if (eq? #f (typed-array? longlong 'u8)))
  84       (pass-if (eq? #f (typed-array? float    'u8)))
  85       (pass-if (eq? #f (typed-array? double   'u8)))
  86       (pass-if (eq? #f (typed-array? complex  'u8)))
  87       (pass-if (eq? #f (typed-array? scm      'u8))))
  88
  89     (with-test-prefix "is short"
  90       (pass-if (eq? #f (typed-array? bool     's16)))
  91       (pass-if (eq? #f (typed-array? char     's16)))
  92       (pass-if (eq? #f (typed-array? byte     's16)))
  93       (pass-if (eq? #t (typed-array? short    's16)))
  94       (pass-if (eq? #f (typed-array? ulong    's16)))
  95       (pass-if (eq? #f (typed-array? long     's16)))
  96       (pass-if (eq? #f (typed-array? longlong 's16)))
  97       (pass-if (eq? #f (typed-array? float    's16)))
  98       (pass-if (eq? #f (typed-array? double   's16)))
  99       (pass-if (eq? #f (typed-array? complex  's16)))
 100       (pass-if (eq? #f (typed-array? scm      's16))))
 101
 102     (with-test-prefix "is ulong"
 103       (pass-if (eq? #f (typed-array? bool     'u32)))
 104       (pass-if (eq? #f (typed-array? char     'u32)))
 105       (pass-if (eq? #f (typed-array? byte     'u32)))
 106       (pass-if (eq? #f (typed-array? short    'u32)))
 107       (pass-if (eq? #t (typed-array? ulong    'u32)))
 108       (pass-if (eq? #f (typed-array? long     'u32)))
 109       (pass-if (eq? #f (typed-array? longlong 'u32)))
 110       (pass-if (eq? #f (typed-array? float    'u32)))
 111       (pass-if (eq? #f (typed-array? double   'u32)))
 112       (pass-if (eq? #f (typed-array? complex  'u32)))
 113       (pass-if (eq? #f (typed-array? scm      'u32))))
 114
 115     (with-test-prefix "is long"
 116       (pass-if (eq? #f (typed-array? bool     's32)))
 117       (pass-if (eq? #f (typed-array? char     's32)))
 118       (pass-if (eq? #f (typed-array? byte     's32)))
 119       (pass-if (eq? #f (typed-array? short    's32)))
 120       (pass-if (eq? #f (typed-array? ulong    's32)))
 121       (pass-if (eq? #t (typed-array? long     's32)))
 122       (pass-if (eq? #f (typed-array? longlong 's32)))
 123       (pass-if (eq? #f (typed-array? float    's32)))
 124       (pass-if (eq? #f (typed-array? double   's32)))
 125       (pass-if (eq? #f (typed-array? complex  's32)))
 126       (pass-if (eq? #f (typed-array? scm      's32))))
 127
 128     (with-test-prefix "is long long"
 129       (pass-if (eq? #f (typed-array? bool     's64)))
 130       (pass-if (eq? #f (typed-array? char     's64)))
 131       (pass-if (eq? #f (typed-array? byte     's64)))
 132       (pass-if (eq? #f (typed-array? short    's64)))
 133       (pass-if (eq? #f (typed-array? ulong    's64)))
 134       (pass-if (eq? #f (typed-array? long     's64)))
 135       (pass-if (eq? #t (typed-array? longlong 's64)))
 136       (pass-if (eq? #f (typed-array? float    's64)))
 137       (pass-if (eq? #f (typed-array? double   's64)))
 138       (pass-if (eq? #f (typed-array? complex  's64)))
 139       (pass-if (eq? #f (typed-array? scm      's64))))
 140
 141     (with-test-prefix "is float"
 142       (pass-if (eq? #f (typed-array? bool     'f32)))
 143       (pass-if (eq? #f (typed-array? char     'f32)))
 144       (pass-if (eq? #f (typed-array? byte     'f32)))
 145       (pass-if (eq? #f (typed-array? short    'f32)))
 146       (pass-if (eq? #f (typed-array? ulong    'f32)))
 147       (pass-if (eq? #f (typed-array? long     'f32)))
 148       (pass-if (eq? #f (typed-array? longlong 'f32)))
 149       (pass-if (eq? #t (typed-array? float    'f32)))
 150       (pass-if (eq? #f (typed-array? double   'f32)))
 151       (pass-if (eq? #f (typed-array? complex  'f32)))
 152       (pass-if (eq? #f (typed-array? scm      'f32))))
 153
 154     (with-test-prefix "is double"
 155       (pass-if (eq? #f (typed-array? bool     'f64)))
 156       (pass-if (eq? #f (typed-array? char     'f64)))
 157       (pass-if (eq? #f (typed-array? byte     'f64)))
 158       (pass-if (eq? #f (typed-array? short    'f64)))
 159       (pass-if (eq? #f (typed-array? ulong    'f64)))
 160       (pass-if (eq? #f (typed-array? long     'f64)))
 161       (pass-if (eq? #f (typed-array? longlong 'f64)))
 162       (pass-if (eq? #f (typed-array? float    'f64)))
 163       (pass-if (eq? #t (typed-array? double   'f64)))
 164       (pass-if (eq? #f (typed-array? complex  'f64)))
 165       (pass-if (eq? #f (typed-array? scm      'f64))))
 166
 167     (with-test-prefix "is complex"
 168       (pass-if (eq? #f (typed-array? bool     'c64)))
 169       (pass-if (eq? #f (typed-array? char     'c64)))
 170       (pass-if (eq? #f (typed-array? byte     'c64)))
 171       (pass-if (eq? #f (typed-array? short    'c64)))
 172       (pass-if (eq? #f (typed-array? ulong    'c64)))
 173       (pass-if (eq? #f (typed-array? long     'c64)))
 174       (pass-if (eq? #f (typed-array? longlong 'c64)))
 175       (pass-if (eq? #f (typed-array? float    'c64)))
 176       (pass-if (eq? #f (typed-array? double   'c64)))
 177       (pass-if (eq? #t (typed-array? complex  'c64)))
 178       (pass-if (eq? #f (typed-array? scm      'c64))))
 179
 180     (with-test-prefix "is scm"
 181       (pass-if (eq? #f (typed-array? bool     #t)))
 182       (pass-if (eq? #f (typed-array? char     #t)))
 183       (pass-if (eq? #f (typed-array? byte     #t)))
 184       (pass-if (eq? #f (typed-array? short    #t)))
 185       (pass-if (eq? #f (typed-array? ulong    #t)))
 186       (pass-if (eq? #f (typed-array? long     #t)))
 187       (pass-if (eq? #f (typed-array? longlong #t)))
 188       (pass-if (eq? #f (typed-array? float    #t)))
 189       (pass-if (eq? #f (typed-array? double   #t)))
 190       (pass-if (eq? #f (typed-array? complex  #t)))
 191       (pass-if (eq? #t (typed-array? scm      #t))))
 192
 193     (with-test-prefix "typed-array? returns #f"
 194       (pass-if (eq? #f (typed-array? '(1 2 3) 'c64)))
 195       (pass-if (eq? #f (typed-array? '(1 2 3) #t)))
 196       (pass-if (eq? #f (typed-array? 99 'c64)))
 197       (pass-if (eq? #f (typed-array? 99 #t))))))
 198
 199 ;;;
 200 ;;; array-equal?
 201 ;;;
 202
 203 (with-test-prefix "array-equal?"
 204
 205   (pass-if "#s16(...)"
 206     (array-equal? #s16(1 2 3) #s16(1 2 3))))
 207
 208 ;;;
 209 ;;; make-shared-array
 210 ;;;
 211
 212 (define exception:mapping-out-of-range
 213   (cons 'misc-error "^mapping out of range"))  ;; per scm_make_shared_array
 214
 215 (with-test-prefix "make-shared-array"
 216
 217   ;; this failed in guile 1.8.0
 218   (pass-if "vector unchanged"
 219     (let* ((a (make-array #f '(0 7)))
 220            (s (make-shared-array a list '(0 7))))
 221       (array-equal? a s)))
 222
 223   (pass-if-exception "vector, high too big" exception:mapping-out-of-range
 224     (let* ((a (make-array #f '(0 7))))
 225       (make-shared-array a list '(0 8))))
 226
 227   (pass-if-exception "vector, low too big" exception:out-of-range
 228     (let* ((a (make-array #f '(0 7))))
 229       (make-shared-array a list '(-1 7))))
 230
 231   (pass-if "truncate columns"
 232     (array-equal? (make-shared-array #2((a b c) (d e f) (g h i)) list 3 2)
 233                   #2((a b) (d e) (g h))))
 234
 235   (pass-if "pick one column"
 236     (array-equal? (make-shared-array #2((a b c) (d e f) (g h i))
 237                                      (lambda (i) (list i 2))
 238                                      '(0 2))
 239                   #(c f i)))
 240
 241   (pass-if "diagonal"
 242     (array-equal? (make-shared-array #2((a b c) (d e f) (g h i))
 243                                      (lambda (i) (list i i))
 244                                      '(0 2))
 245                   #(a e i)))
 246
 247   ;; this failed in guile 1.8.0
 248   (pass-if "2 dims from 1 dim"
 249     (array-equal? (make-shared-array #1(a b c d e f g h i j k l)
 250                                      (lambda (i j) (list (+ (* i 3) j)))
 251                                      4 3)
 252                   #2((a b c) (d e f) (g h i) (j k l))))
 253
 254   (pass-if "reverse columns"
 255     (array-equal? (make-shared-array #2((a b c) (d e f) (g h i))
 256                                      (lambda (i j) (list i (- 2 j)))
 257                                      3 3)
 258                   #2((c b a) (f e d) (i h g))))
 259
 260   (pass-if "fixed offset, 0 based becomes 1 based"
 261     (let* ((x #2((a b c) (d e f) (g h i)))
 262            (y (make-shared-array x
 263                                  (lambda (i j) (list (1- i) (1- j)))
 264                                  '(1 3) '(1 3))))
 265       (and (eq? (array-ref x 0 0) 'a)
 266            (eq? (array-ref y 1 1) 'a))))
 267
 268   ;; this failed in guile 1.8.0
 269   (pass-if "stride every third element"
 270     (array-equal? (make-shared-array #1(a b c d e f g h i j k l)
 271                                      (lambda (i) (list (* i 3)))
 272                                      4)
 273                   #1(a d g j)))
 274
 275   (pass-if "shared of shared"
 276     (let* ((a  #2((1 2 3) (4 5 6) (7 8 9)))
 277            (s1 (make-shared-array a (lambda (i) (list i 1)) 3))
 278            (s2 (make-shared-array s1 list '(1 2))))
 279       (and (eqv? 5 (array-ref s2 1))
 280            (eqv? 8 (array-ref s2 2))))))
 281
 282 ;;;
 283 ;;; array-contents
 284 ;;;
 285
 286 (with-test-prefix "array-contents"
 287
 288   (define (every-two x) (make-shared-array x (lambda (i) (list (* i 2))) 2))
 289
 290   (pass-if "simple vector"
 291     (let* ((a (make-array 0 4)))
 292       (eq? a (array-contents a))))
 293
 294   (pass-if "offset vector"
 295     (let* ((a (make-array 0 '(1 4))))
 296       (array-copy! #(1 2 3 4) (array-contents a))
 297       (array-equal? #1@1(1 2 3 4) a)))
 298
 299   (pass-if "offset vector, strict"
 300     (let* ((a (make-array 0 '(1 4))))
 301       (array-copy! #(1 2 3 4) (array-contents a #t))
 302       (array-equal? #1@1(1 2 3 4) a)))
 303
 304   (pass-if "stepped vector"
 305     (let* ((a (make-array 0 4)))
 306       (array-copy! #(99 66) (array-contents (every-two a)))
 307       (array-equal? #(99 0 66 0) a)))
 308
 309   ;; this failed in 2.0.9.
 310   (pass-if "stepped vector, strict"
 311     (let* ((a (make-array 0 4)))
 312       (not (array-contents (every-two a) #t))))
 313
 314   (pass-if "plain rank 2 array"
 315     (let* ((a (make-array 0 2 2)))
 316       (array-copy! #(1 2 3 4) (array-contents a #t))
 317       (array-equal? #2((1 2) (3 4)) a)))
 318
 319   (pass-if "offset rank 2 array"
 320     (let* ((a (make-array 0 '(1 2) '(1 2))))
 321       (array-copy! #(1 2 3 4) (array-contents a #t))
 322       (array-equal? #2@1@1((1 2) (3 4)) a)))
 323
 324   (pass-if "transposed rank 2 array"
 325     (let* ((a (make-array 0 4 4)))
 326       (not (array-contents (transpose-array a 1 0) #t))))
 327
 328   ;; This is a consequence of (array-contents? a #t) => #t.
 329   (pass-if "empty array"
 330     (let ((a (make-typed-array 'f64 2 0 0)))
 331       (f64vector? (array-contents a))))
 332
 333   (pass-if "broadcast vector I"
 334     (let* ((a (make-array 0 4))
 335            (b (make-shared-array a (lambda (i j k) (list k)) 1 1 4)))
 336       (array-copy! #(1 2 3 4) (array-contents b #t))
 337       (array-equal? #(1 2 3 4) a)))
 338
 339   (pass-if "broadcast vector II"
 340     (let* ((a (make-array 0 4))
 341            (b (make-shared-array a (lambda (i j k) (list k)) 2 1 4)))
 342       (not (array-contents b))))
 343
 344   ;; FIXME maybe this should be allowed.
 345   #;
 346   (pass-if "broadcast vector -> empty"
 347     (let* ((a (make-array 0 4))
 348            (b (make-shared-array a (lambda (i j k) (list k)) 0 1 4)))
 349       (if #f #f)))
 350
 351   (pass-if "broadcast 2-rank I"
 352     (let* ((a #2((1 2 3) (4 5 6)))
 353            (b (make-shared-array a (lambda (i j) (list 0 j)) 2 3)))
 354       (not (array-contents b))))
 355
 356   (pass-if "broadcast 2-rank I"
 357     (let* ((a #2((1 2 3) (4 5 6)))
 358            (b (make-shared-array a (lambda (i j) (list i 0)) 2 3)))
 359       (not (array-contents b)))))
 360
 361 ;;;
 362 ;;; shared-array-root
 363 ;;;
 364
 365 (with-test-prefix "shared-array-root"
 366
 367   (define amap1 (lambda (i) (list (* 2 i))))
 368   (define amap2 (lambda (i j) (list (+ 1 (* 2 i)) (+ 1 (* 2 j)))))
 369
 370   (pass-if "plain vector"
 371     (let* ((a (make-vector 4 0))
 372            (b (make-shared-array a amap1 2)))
 373       (eq? (shared-array-root a) (shared-array-root b) (array-contents a))))
 374
 375   (pass-if "plain array rank 2"
 376     (let* ((a (make-array 0 4 4))
 377            (b (make-shared-array a amap2 2 2)))
 378       (eq? (shared-array-root a) (shared-array-root b) (array-contents a))))
 379
 380   (pass-if "uniform array rank 2"
 381     (let* ((a (make-typed-array 'c64 0 4 4))
 382            (b (make-shared-array a amap2 2 2)))
 383       (eq? (shared-array-root a) (shared-array-root b) (array-contents a))))
 384
 385   (pass-if "bit array rank 2"
 386     (let* ((a (make-typed-array 'b #f 4 4))
 387            (b (make-shared-array a amap2 2 2)))
 388       (eq? (shared-array-root a) (shared-array-root b) (array-contents a)))))
 389
 390 ;;;
 391 ;;; transpose-array
 392 ;;;
 393
 394 ; see strings.test.
 395 (define exception:wrong-type-arg
 396   (cons #t "Wrong type"))
 397
 398 (with-test-prefix "transpose-array"
 399
 400   (pass-if-exception "non array argument" exception:wrong-type-arg
 401     (transpose-array 99))
 402
 403   (pass-if "rank 0"
 404     (let* ((a #0(99))
 405            (b (transpose-array a)))
 406       (and (array-equal? a b)
 407            (eq? (shared-array-root a) (shared-array-root b)))))
 408
 409   (pass-if "rank 1"
 410     (let* ((a #(1 2 3))
 411            (b (transpose-array a 0)))
 412       (and (array-equal? a b)
 413            (eq? (shared-array-root a) (shared-array-root b)))))
 414
 415   (pass-if "rank 2"
 416     (let* ((a #2((1 2 3) (4 5 6)))
 417            (b (transpose-array a 1 0))
 418            (c (transpose-array a 0 1)))
 419       (and (array-equal? b #2((1 4) (2 5) (3 6)))
 420            (array-equal? c a)
 421            (eq? (shared-array-root a)
 422                 (shared-array-root b)
 423                 (shared-array-root c)))))
 424
 425   ; rank > 2 is needed to check against the inverted axis index logic.
 426   (pass-if "rank 3"
 427     (let* ((a #3(((0 1 2 3) (4 5 6 7) (8 9 10 11))
 428                  ((12 13 14 15) (16 17 18 19) (20 21 22 23))))
 429            (b (transpose-array a 1 2 0)))
 430       (and (array-equal? b #3(((0 4 8) (12 16 20)) ((1 5 9) (13 17 21))
 431                               ((2 6 10) (14 18 22)) ((3 7 11) (15 19 23))))
 432            (eq? (shared-array-root a)
 433                 (shared-array-root b))))))
 434
 435 ;;;
 436 ;;; array->list
 437 ;;;
 438
 439 (with-test-prefix "array->list"
 440   (pass-if-equal '(1 2 3) (array->list #s16(1 2 3)))
 441   (pass-if-equal '(1 2 3) (array->list #(1 2 3)))
 442   (pass-if-equal '((1 2) (3 4) (5 6)) (array->list #2((1 2) (3 4) (5 6))))
 443   (pass-if-equal '()  (array->list #()))
 444
 445   (pass-if-equal "http://bugs.gnu.org/12465 - ok"
 446       '(3 4)
 447     (let* ((a #2((1 2) (3 4)))
 448            (b (make-shared-array a (lambda (j) (list 1 j)) 2)))
 449       (array->list b)))
 450   (pass-if-equal "http://bugs.gnu.org/12465 - bad"
 451       '(2 4)
 452     (let* ((a #2((1 2) (3 4)))
 453            (b (make-shared-array a (lambda (i) (list i 1)) 2)))
 454       (array->list b))))
 455
 456 ;;;
 457 ;;; array-fill!
 458 ;;;
 459
 460 (with-test-prefix "array-fill!"
 461
 462   (with-test-prefix "bool"
 463     (let ((a (make-bitvector 1 #t)))
 464       (pass-if "#f" (array-fill! a #f) #t)
 465       (pass-if "#t" (array-fill! a #t) #t)))
 466
 467   (with-test-prefix "char"
 468     (let ((a (make-string 1 #\a)))
 469       (pass-if "x" (array-fill! a #\x) #t)))
 470
 471   (with-test-prefix "byte"
 472     (let ((a (make-s8vector 1 0)))
 473       (pass-if "0"    (array-fill! a 0)    #t)
 474       (pass-if "127" (array-fill! a 127)   #t)
 475       (pass-if "-128" (array-fill! a -128) #t)
 476       (pass-if-exception "128" exception:out-of-range
 477         (array-fill! a 128))
 478       (pass-if-exception "-129" exception:out-of-range
 479         (array-fill! a -129))
 480       (pass-if-exception "symbol" exception:wrong-type-arg
 481         (array-fill! a 'symbol))))
 482
 483   (with-test-prefix "short"
 484     (let ((a (make-s16vector 1 0)))
 485       (pass-if "0"    (array-fill! a 0)    #t)
 486       (pass-if "123"  (array-fill! a 123)  #t)
 487       (pass-if "-123" (array-fill! a -123) #t)))
 488
 489   (with-test-prefix "ulong"
 490     (let ((a (make-u32vector 1 1)))
 491       (pass-if "0"    (array-fill! a 0)   #t)
 492       (pass-if "123"  (array-fill! a 123) #t)
 493       (pass-if-exception "-123" exception:out-of-range
 494         (array-fill! a -123) #t)))
 495
 496   (with-test-prefix "long"
 497     (let ((a (make-s32vector 1 -1)))
 498       (pass-if "0"    (array-fill! a 0)    #t)
 499       (pass-if "123"  (array-fill! a 123)  #t)
 500       (pass-if "-123" (array-fill! a -123) #t)))
 501
 502   (with-test-prefix "float"
 503     (let ((a (make-f32vector 1 1.0)))
 504       (pass-if "0.0"    (array-fill! a 0)      #t)
 505       (pass-if "123.0"  (array-fill! a 123.0)  #t)
 506       (pass-if "-123.0" (array-fill! a -123.0) #t)
 507       (pass-if "0"      (array-fill! a 0)      #t)
 508       (pass-if "123"    (array-fill! a 123)    #t)
 509       (pass-if "-123"   (array-fill! a -123)   #t)
 510       (pass-if "5/8"    (array-fill! a 5/8)    #t)))
 511
 512   (with-test-prefix "double"
 513     (let ((a (make-f64vector 1 1/3)))
 514       (pass-if "0.0"    (array-fill! a 0)      #t)
 515       (pass-if "123.0"  (array-fill! a 123.0)  #t)
 516       (pass-if "-123.0" (array-fill! a -123.0) #t)
 517       (pass-if "0"      (array-fill! a 0)      #t)
 518       (pass-if "123"    (array-fill! a 123)    #t)
 519       (pass-if "-123"   (array-fill! a -123)   #t)
 520       (pass-if "5/8"    (array-fill! a 5/8)    #t)))
 521
 522   (with-test-prefix "noncompact"
 523     (let* ((a (make-array 0 3 3))
 524            (b (make-shared-array a (lambda (i) (list i i)) 3)))
 525       (array-fill! b 9)
 526       (pass-if
 527         (and (equal? b #(9 9 9))
 528              (equal? a #2((9 0 0) (0 9 0) (0 0 9))))))))
 529
 530 ;;;
 531 ;;; array-in-bounds?
 532 ;;;
 533
 534 (with-test-prefix "array-in-bounds?"
 535
 536   (pass-if (let ((a (make-array #f '(425 425))))
 537              (eq? #f (array-in-bounds? a 0)))))
 538
 539 ;;;
 540 ;;; array-prototype
 541 ;;;
 542
 543 (with-test-prefix "array-type"
 544
 545   (with-test-prefix "on make-foo-vector"
 546
 547     (pass-if "bool"
 548       (eq? 'b (array-type (make-bitvector 1))))
 549
 550     (pass-if "char"
 551       (eq? 'a (array-type (make-string 1))))
 552
 553     (pass-if "byte"
 554       (eq? 'u8 (array-type (make-u8vector 1))))
 555
 556     (pass-if "short"
 557       (eq? 's16 (array-type (make-s16vector 1))))
 558
 559     (pass-if "ulong"
 560       (eq? 'u32 (array-type (make-u32vector 1))))
 561
 562     (pass-if "long"
 563       (eq? 's32 (array-type (make-s32vector 1))))
 564
 565     (pass-if "long long"
 566       (eq? 's64 (array-type (make-s64vector 1))))
 567
 568     (pass-if "float"
 569       (eq? 'f32 (array-type (make-f32vector 1))))
 570
 571     (pass-if "double"
 572       (eq? 'f64 (array-type (make-f64vector 1))))
 573
 574     (pass-if "complex"
 575       (eq? 'c64 (array-type (make-c64vector 1))))
 576
 577     (pass-if "scm"
 578       (eq? #t (array-type (make-vector 1)))))
 579
 580   (with-test-prefix "on make-typed-array"
 581
 582     (let ((types '(b a u8 s8 u16 s16 u32 s32 u64 u64 f32 f64 c32 c64)))
 583       (for-each (lambda (type)
 584                   (pass-if (symbol->string type)
 585                      (eq? type
 586                           (array-type (make-typed-array type
 587                                                         *unspecified*
 588                                                         '(5 6))))))
 589                 types))))
 590
 591 ;;;
 592 ;;; array-set!
 593 ;;;
 594
 595 (with-test-prefix "array-set!"
 596
 597   (with-test-prefix "bitvector"
 598
 599     ;; in Guile 1.8.0 a bug in bitvector_set() caused a segv in array-set!
 600     ;; on a bitvector like the following
 601     (let ((a (make-bitvector 1)))
 602       (pass-if "one elem set #t"
 603         (begin
 604           (array-set! a #t 0)
 605           (eq? #t (array-ref a 0))))
 606       (pass-if "one elem set #f"
 607         (begin
 608           (array-set! a #f 0)
 609           (eq? #f (array-ref a 0))))))
 610
 611   (with-test-prefix "byte"
 612
 613     (let ((a (make-s8vector 1)))
 614
 615       (pass-if "-128"
 616         (begin (array-set! a -128 0) #t))
 617       (pass-if "0"
 618         (begin (array-set! a 0 0) #t))
 619       (pass-if "127"
 620         (begin (array-set! a 127 0) #t))
 621       (pass-if-exception "-129" exception:out-of-range
 622         (begin (array-set! a -129 0) #t))
 623       (pass-if-exception "128" exception:out-of-range
 624         (begin (array-set! a 128 0) #t))))
 625
 626   (with-test-prefix "short"
 627
 628     (let ((a (make-s16vector 1)))
 629       ;; true if n can be array-set! into a
 630       (define (fits? n)
 631         (false-if-exception (begin (array-set! a n 0) #t)))
 632
 633       (with-test-prefix "store/fetch"
 634         ;; Check array-ref gives back what was put with array-set!.
 635         ;; In Guile 1.6.4 and earlier, array-set! only demanded an inum and
 636         ;; would silently truncate to a short.
 637
 638         (do ((n 1 (1+ (* 2 n))))  ;; n=2^k-1
 639             ((not (fits? n)))
 640           (array-set! a n 0)
 641           (pass-if n
 642             (= n (array-ref a 0))))
 643
 644         (do ((n -1 (* 2 n)))      ;; -n=2^k
 645             ((not (fits? n)))
 646           (array-set! a n 0)
 647           (pass-if n
 648             (= n (array-ref a 0))))))))
 649
 650 ;;;
 651 ;;; array-set!
 652 ;;;
 653
 654 (with-test-prefix "array-set!"
 655
 656   (with-test-prefix "one dim"
 657     (let ((a (make-array #f '(3 5))))
 658       (pass-if "start"
 659         (array-set! a 'y 3)
 660         #t)
 661       (pass-if "end"
 662         (array-set! a 'y 5)
 663         #t)
 664       (pass-if-exception "start-1" exception:out-of-range
 665         (array-set! a 'y 2))
 666       (pass-if-exception "end+1" exception:out-of-range
 667         (array-set! a 'y 6))
 668       (pass-if-exception "two indexes" exception:wrong-num-indices
 669         (array-set! a 'y 6 7))))
 670
 671   (with-test-prefix "two dim"
 672     (let ((a (make-array #f '(3 5) '(7 9))))
 673       (pass-if "start"
 674         (array-set! a 'y 3 7)
 675         #t)
 676       (pass-if "end"
 677         (array-set! a 'y 5 9)
 678         #t)
 679       (pass-if-exception "start i-1" exception:out-of-range
 680         (array-set! a 'y 2 7))
 681       (pass-if-exception "end i+1" exception:out-of-range
 682         (array-set! a 'y 6 9))
 683       (pass-if-exception "one index" exception:wrong-num-indices
 684         (array-set! a 'y 4))
 685       (pass-if-exception "three indexes" exception:wrong-num-indices
 686         (array-set! a 'y 4 8 0)))))
 687
 688 ;;;
 689 ;;; uniform-vector
 690 ;;;
 691
 692 (with-test-prefix "typed arrays"
 693
 694   (with-test-prefix "array-ref byte"
 695
 696     (let ((a (make-s8vector 1)))
 697
 698       (pass-if "0"
 699         (begin
 700           (array-set! a 0 0)
 701           (= 0 (array-ref a 0))))
 702       (pass-if "127"
 703         (begin
 704           (array-set! a 127 0)
 705           (= 127 (array-ref a 0))))
 706       (pass-if "-128"
 707         (begin
 708           (array-set! a -128 0)
 709           (= -128 (array-ref a 0))))))
 710
 711   (with-test-prefix "shared with rank 1 equality"
 712
 713     (let ((a #f64(1 2 3 4)))
 714
 715       (pass-if "change offset"
 716         (let ((b (make-shared-array a (lambda (i) (list (+ i 1))) 3)))
 717           (and (eq? (array-type b) (array-type a))
 718                (= 3 (array-length b))
 719                (array-equal? b #f64(2 3 4)))))
 720
 721       (pass-if "change stride"
 722         (let ((c (make-shared-array a (lambda (i) (list (* i 2))) 2)))
 723           (and (eq? (array-type c) (array-type a))
 724                (= 2 (array-length c))
 725                (array-equal? c #f64(1 3))))))))
 726
 727 ;;;
 728 ;;; syntax
 729 ;;;
 730
 731 (with-test-prefix "syntax"
 732
 733   (pass-if "rank and lower bounds"
 734     ;; uniform u32 array of rank 2 with index ranges 2..3 and 7..8.
 735     (let ((a '#2u32@2@7((1 2) (3 4))))
 736       (and (array? a)
 737            (typed-array? a 'u32)
 738            (= (array-rank a) 2)
 739            (let loop ((bounds '((2 7) (2 8) (3 7) (3 8)))
 740                       (result #t))
 741              (if (null? bounds)
 742                  result
 743                  (and result
 744                       (loop (cdr bounds)
 745                             (apply array-in-bounds? a (car bounds)))))))))
 746
 747   (pass-if "negative lower bound"
 748      (let ((a '#1@-3(a b)))
 749        (and (array? a)
 750             (= (array-rank a) 1)
 751             (array-in-bounds? a -3) (array-in-bounds? a -2)
 752             (eq? 'a (array-ref a -3))
 753             (eq? 'b (array-ref a -2)))))
 754
 755   (pass-if-exception "negative length" exception:length-non-negative
 756      (with-input-from-string "'#1:-3(#t #t)" read))
 757
 758   (pass-if "bitvector is self-evaluating"
 759      (equal? (compile (bitvector)) (bitvector)))
 760
 761   ; this failed in 2.0.9.
 762   (pass-if "typed arrays that are not uniform arrays"
 763     (let ((a #2b((#t #f) (#f #t)))
 764           (b (make-typed-array 'b #f 2 2)))
 765       (array-set! b #t 0 0)
 766       (array-set! b #t 1 1)
 767       (array-equal? a b))))
 768
 769 ;;;
 770 ;;; equal? with vector and one-dimensional array
 771 ;;;
 772
 773 (with-test-prefix "equal?"
 774   (pass-if "array and non-array"
 775     (not (equal? #2f64((0 1) (2 3)) 100)))
 776
 777   (pass-if "empty vectors of different types"
 778     (not (equal? #s32() #f64())))
 779
 780   (pass-if "empty arrays of different types"
 781     (not (equal? #2s32() #2f64())))
 782
 783   (pass-if "empty arrays of the same type"
 784     (equal? #s32() #s32()))
 785
 786   (pass-if "identical uniform vectors of the same type"
 787     (equal? #s32(1) #s32(1)))
 788
 789   (pass-if "nonidentical uniform vectors of the same type"
 790     (not (equal? #s32(1) #s32(-1))))
 791
 792   (pass-if "identical uniform vectors of different types"
 793     (not (equal? #s32(1) #s64(1))))
 794
 795   (pass-if "nonidentical uniform vectors of different types"
 796     (not (equal? #s32(1) #s64(-1))))
 797
 798   (pass-if "vector and one-dimensional array"
 799     (equal? (make-shared-array #2((a b c) (d e f) (g h i))
 800                                (lambda (i) (list i i))
 801                                '(0 2))
 802             #(a e i))))
 803
 804 ;;;
 805 ;;; slices as generalized vectors
 806 ;;;
 807
 808 (let ((array #2u32((0 1) (2 3))))
 809   (define (array-row a i)
 810     (make-shared-array a (lambda (j) (list i j))
 811                        (cadr (array-dimensions a))))
 812   (with-test-prefix "generalized vector slices"
 813     (pass-if (equal? (array-row array 1)
 814                      #u32(2 3)))
 815     (pass-if (equal? (array-ref (array-row array 1) 0)
 816                      2))))