test-suite/tests/arrays.test

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