test-suite/tests/ramap.test

   1 ;;;; ramap.test --- test array mapping functions -*- scheme -*-
   2 ;;;;
   3 ;;;; Copyright (C) 2004, 2005, 2006, 2009, 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-ramap)
  20   #:use-module (test-suite lib))
  21
  22 (define exception:shape-mismatch
  23   (cons 'misc-error ".*shape mismatch.*"))
  24
  25 (define (array-row a i)
  26   (make-shared-array a (lambda (j) (list i j))
  27                        (cadr (array-dimensions a))))
  28
  29 (define (array-col a j)
  30   (make-shared-array a (lambda (i) (list i j))
  31                        (car (array-dimensions a))))
  32
  33 ;;;
  34 ;;; array-index-map!
  35 ;;;
  36
  37 (with-test-prefix "array-index-map!"
  38
  39   (pass-if "basic test"
  40     (let ((nlst '()))
  41       (array-index-map! (make-array #f '(1 1))
  42                         (lambda (n)
  43                           (set! nlst (cons n nlst))))
  44       (equal? nlst '(1))))
  45
  46   (with-test-prefix "empty arrays"
  47
  48     (pass-if "all axes empty"
  49       (array-index-map! (make-typed-array 'f64 0 0 0) (const 0))
  50       (array-index-map! (make-typed-array 'b #t 0 0) (const #t))
  51       (array-index-map! (make-typed-array #t 0 0 0) (const 0))
  52       #t)
  53
  54     (pass-if "last axis empty"
  55       (array-index-map! (make-typed-array 'f64 0 2 0) (const 0))
  56       (array-index-map! (make-typed-array 'b #t 2 0) (const #t))
  57       (array-index-map! (make-typed-array #t 0 2 0) (const 0))
  58       #t)
  59
  60     ; the 'f64 cases fail in 2.0.9 with out-of-range.
  61     (pass-if "axis empty, other than last"
  62       (array-index-map! (make-typed-array 'f64 0 0 2) (const 0))
  63       (array-index-map! (make-typed-array 'b #t 0 2) (const #t))
  64       (array-index-map! (make-typed-array #t 0 0 2) (const 0))
  65       #t)))
  66
  67 ;;;
  68 ;;; array-copy!
  69 ;;;
  70
  71 (with-test-prefix "array-copy!"
  72
  73   (with-test-prefix "empty arrays"
  74
  75     (pass-if "empty other than last, #t"
  76       (let* ((b (make-array 0 2 2))
  77              (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
  78         (array-copy! #2:0:2() c)
  79         (array-equal? #2:0:2() c)))
  80
  81     (pass-if "empty other than last, 'f64"
  82       (let* ((b (make-typed-array 'f64 0 2 2))
  83              (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
  84         (array-copy! #2:0:2() c)
  85         (array-equal? #2f64:0:2() c)))
  86
  87   ;; FIXME add empty, type 'b cases.
  88
  89     )
  90
  91   ;; note that it is the opposite of array-map!. This is, unfortunately,
  92   ;; documented in the manual.
  93
  94   (pass-if "matching behavior I"
  95     (let ((a #(1 2))
  96           (b (make-array 0 3)))
  97       (array-copy! a b)
  98       (equal? b #(1 2 0))))
  99
 100   (pass-if-exception "matching behavior II" exception:shape-mismatch
 101     (let ((a #(1 2 3))
 102           (b (make-array 0 2)))
 103       (array-copy! a b)
 104       (equal? b #(1 2))))
 105
 106   (pass-if "rank 2"
 107     (let ((a #2((1 2) (3 4)))
 108           (b (make-array 0 2 2))
 109           (c (make-array 0 2 2))
 110           (d (make-array 0 2 2))
 111           (e (make-array 0 2 2)))
 112       (array-copy! a b)
 113       (array-copy! a (transpose-array c 1 0))
 114       (array-copy! (transpose-array a 1 0) d)
 115       (array-copy! (transpose-array a 1 0) (transpose-array e 1 0))
 116       (and (equal? a #2((1 2) (3 4)))
 117            (equal? b #2((1 2) (3 4)))
 118            (equal? c #2((1 3) (2 4)))
 119            (equal? d #2((1 3) (2 4)))
 120            (equal? e #2((1 2) (3 4))))))
 121
 122   (pass-if "rank 1"
 123     (let* ((a #2((1 2) (3 4)))
 124            (b (make-shared-array a (lambda (j) (list 1 j)) 2))
 125            (c (make-shared-array a (lambda (i) (list (- 1 i) 1)) 2))
 126            (d (make-array 0 2))
 127            (e (make-array 0 2)))
 128       (array-copy! b d)
 129       (array-copy! c e)
 130       (and (equal? d #(3 4))
 131            (equal? e #(4 2)))))
 132
 133   (pass-if "rank 0"
 134     (let ((a #0(99))
 135           (b (make-array 0)))
 136       (array-copy! a b)
 137       (equal? b #0(99)))))
 138
 139 ;;;
 140 ;;; array-map!
 141 ;;;
 142
 143 (with-test-prefix "array-map!"
 144
 145   (pass-if-exception "no args" exception:wrong-num-args
 146     (array-map!))
 147
 148   (pass-if-exception "one arg" exception:wrong-num-args
 149     (array-map! (make-array #f 5)))
 150
 151   (with-test-prefix "no sources"
 152
 153     (pass-if "closure 0"
 154       (array-map! (make-array #f 5) (lambda () #f))
 155       #t)
 156
 157     (pass-if-exception "closure 1" exception:wrong-num-args
 158       (array-map! (make-array #f 5) (lambda (x) #f)))
 159
 160     (pass-if-exception "closure 2" exception:wrong-num-args
 161       (array-map! (make-array #f 5) (lambda (x y) #f)))
 162
 163     (pass-if-exception "subr_1" exception:wrong-num-args
 164       (array-map! (make-array #f 5) length))
 165
 166     (pass-if-exception "subr_2" exception:wrong-num-args
 167       (array-map! (make-array #f 5) logtest))
 168
 169     (pass-if-exception "subr_2o" exception:wrong-num-args
 170       (array-map! (make-array #f 5) number->string))
 171
 172     (pass-if-exception "dsubr" exception:wrong-num-args
 173       (array-map! (make-array #f 5) sqrt))
 174
 175     (pass-if "rpsubr"
 176       (let ((a (make-array 'foo 5)))
 177         (array-map! a =)
 178         (equal? a (make-array #t 5))))
 179
 180     (pass-if "asubr"
 181       (let ((a (make-array 'foo 5)))
 182         (array-map! a +)
 183         (equal? a (make-array 0 5))))
 184
 185     ;; in Guile 1.6.4 and earlier this resulted in a segv
 186     (pass-if "noop"
 187       (array-map! (make-array #f 5) noop)
 188       #t))
 189
 190   (with-test-prefix "one source"
 191
 192     (pass-if-exception "closure 0" exception:wrong-num-args
 193       (array-map! (make-array #f 5) (lambda () #f)
 194                   (make-array #f 5)))
 195
 196     (pass-if "closure 1"
 197       (let ((a (make-array #f 5)))
 198         (array-map! a (lambda (x) 'foo) (make-array #f 5))
 199         (equal? a (make-array 'foo 5))))
 200
 201     (pass-if-exception "closure 2" exception:wrong-num-args
 202       (array-map! (make-array #f 5) (lambda (x y) #f)
 203                   (make-array #f 5)))
 204
 205     (pass-if "subr_1"
 206       (let ((a (make-array #f 5)))
 207         (array-map! a length (make-array '(x y z) 5))
 208         (equal? a (make-array 3 5))))
 209
 210     (pass-if-exception "subr_2" exception:wrong-num-args
 211       (array-map! (make-array #f 5) logtest
 212                   (make-array 999 5)))
 213
 214     (pass-if "subr_2o"
 215       (let ((a (make-array #f 5)))
 216         (array-map! a number->string (make-array 99 5))
 217         (equal? a (make-array "99" 5))))
 218
 219     (pass-if "dsubr"
 220       (let ((a (make-array #f 5)))
 221         (array-map! a sqrt (make-array 16.0 5))
 222         (equal? a (make-array 4.0 5))))
 223
 224     (pass-if "rpsubr"
 225       (let ((a (make-array 'foo 5)))
 226         (array-map! a = (make-array 0 5))
 227         (equal? a (make-array #t 5))))
 228
 229     (pass-if "asubr"
 230       (let ((a (make-array 'foo 5)))
 231         (array-map! a - (make-array 99 5))
 232         (equal? a (make-array -99 5))))
 233
 234     ;; in Guile 1.6.5 and 1.6.6 this was an error
 235     (pass-if "1+"
 236       (let ((a (make-array #f 5)))
 237         (array-map! a 1+ (make-array 123 5))
 238         (equal? a (make-array 124 5)))))
 239
 240   (with-test-prefix "two sources"
 241
 242     (pass-if-exception "closure 0" exception:wrong-num-args
 243       (array-map! (make-array #f 5) (lambda () #f)
 244                   (make-array #f 5) (make-array #f 5)))
 245
 246     (pass-if-exception "closure 1" exception:wrong-num-args
 247       (array-map! (make-array #f 5) (lambda (x) #f)
 248                   (make-array #f 5) (make-array #f 5)))
 249
 250     (pass-if "closure 2"
 251       (let ((a (make-array #f 5)))
 252         (array-map! a (lambda (x y) 'foo)
 253                     (make-array #f 5) (make-array #f 5))
 254         (equal? a (make-array 'foo 5))))
 255
 256     (pass-if-exception "subr_1" exception:wrong-num-args
 257       (array-map! (make-array #f 5) length
 258                   (make-array #f 5) (make-array #f 5)))
 259
 260     (pass-if "subr_2"
 261       (let ((a (make-array 'foo 5)))
 262         (array-map! a logtest
 263                     (make-array 999 5) (make-array 999 5))
 264         (equal? a (make-array #t 5))))
 265
 266     (pass-if "subr_2o"
 267       (let ((a (make-array #f 5)))
 268         (array-map! a number->string
 269                     (make-array 32 5) (make-array 16 5))
 270         (equal? a (make-array "20" 5))))
 271
 272     (pass-if-exception "dsubr" exception:wrong-num-args
 273       (let ((a (make-array #f 5)))
 274         (array-map! a sqrt
 275                     (make-array 16.0 5) (make-array 16.0 5))
 276         (equal? a (make-array 4.0 5))))
 277
 278     (pass-if "rpsubr"
 279       (let ((a (make-array 'foo 5)))
 280         (array-map! a = (make-array 99 5) (make-array 77 5))
 281         (equal? a (make-array #f 5))))
 282
 283     (pass-if "asubr"
 284       (let ((a (make-array 'foo 5)))
 285         (array-map! a - (make-array 99 5) (make-array 11 5))
 286         (equal? a (make-array 88 5))))
 287
 288     (pass-if "+"
 289       (let ((a (make-array #f 4)))
 290         (array-map! a + #(1 2 3 4) #(5 6 7 8))
 291         (equal? a #(6 8 10 12))))
 292
 293     (pass-if "noncompact arrays 1"
 294       (let ((a #2((0 1) (2 3)))
 295             (c (make-array 0 2)))
 296         (begin
 297           (array-map! c + (array-row a 1) (array-row a 1))
 298           (array-equal? c #(4 6)))))
 299
 300     (pass-if "noncompact arrays 2"
 301       (let ((a #2((0 1) (2 3)))
 302             (c (make-array 0 2)))
 303         (begin
 304           (array-map! c + (array-col a 1) (array-col a 1))
 305           (array-equal? c #(2 6)))))
 306
 307     (pass-if "noncompact arrays 3"
 308       (let ((a #2((0 1) (2 3)))
 309             (c (make-array 0 2)))
 310         (begin
 311           (array-map! c + (array-col a 1) (array-row a 1))
 312           (array-equal? c #(3 6)))))
 313
 314     (pass-if "noncompact arrays 4"
 315       (let ((a #2((0 1) (2 3)))
 316             (c (make-array 0 2)))
 317         (begin
 318           (array-map! c + (array-col a 1) (array-row a 1))
 319           (array-equal? c #(3 6))))))
 320
 321   ;; note that array-copy! has the opposite behavior.
 322
 323   (pass-if-exception "matching behavior I" exception:shape-mismatch
 324     (let ((a #(1 2))
 325           (b (make-array 0 3)))
 326       (array-map! b values a)
 327       (equal? b #(1 2 0))))
 328
 329   (pass-if "matching behavior II"
 330     (let ((a #(1 2 3))
 331           (b (make-array 0 2)))
 332       (array-map! b values a)
 333       (equal? b #(1 2)))))
 334
 335 ;;;
 336 ;;; array-for-each
 337 ;;;
 338
 339 (with-test-prefix "array-for-each"
 340
 341   (with-test-prefix "1 source"
 342     (pass-if-equal "noncompact array"
 343         '(3 2 1 0)
 344       (let* ((a #2((0 1) (2 3)))
 345              (l '())
 346              (p (lambda (x) (set! l (cons x l)))))
 347         (array-for-each p a)
 348         l))
 349
 350     (pass-if-equal "vector"
 351         '(3 2 1 0)
 352       (let* ((a #(0 1 2 3))
 353              (l '())
 354              (p (lambda (x) (set! l (cons x l)))))
 355         (array-for-each p a)
 356         l))
 357
 358     (pass-if-equal "shared array"
 359         '(3 2 1 0)
 360       (let* ((a  #2((0 1) (2 3)))
 361              (a' (make-shared-array a
 362                                     (lambda (x)
 363                                       (list (quotient x 4)
 364                                             (modulo x 4)))
 365                                     4))
 366              (l  '())
 367              (p  (lambda (x) (set! l (cons x l)))))
 368         (array-for-each p a')
 369         l)))
 370
 371   (with-test-prefix "3 sources"
 372     (pass-if-equal "noncompact arrays 1"
 373         '((3 3 3) (2 2 2))
 374       (let* ((a #2((0 1) (2 3)))
 375              (l '())
 376              (rec (lambda args (set! l (cons args l)))))
 377         (array-for-each rec (array-row a 1) (array-row a 1) (array-row a 1))
 378         l))
 379
 380     (pass-if-equal "noncompact arrays 2"
 381         '((3 3 3) (2 2 1))
 382       (let* ((a #2((0 1) (2 3)))
 383              (l '())
 384              (rec (lambda args (set! l (cons args l)))))
 385         (array-for-each rec (array-row a 1) (array-row a 1) (array-col a 1))
 386         l))
 387
 388     (pass-if-equal "noncompact arrays 3"
 389         '((3 3 3) (2 1 1))
 390       (let* ((a #2((0 1) (2 3)))
 391              (l '())
 392              (rec (lambda args (set! l (cons args l)))))
 393         (array-for-each rec (array-row a 1) (array-col a 1) (array-col a 1))
 394         l))
 395
 396     (pass-if-equal "noncompact arrays 4"
 397         '((3 2 3) (1 0 2))
 398       (let* ((a #2((0 1) (2 3)))
 399              (l '())
 400              (rec (lambda args (set! l (cons args l)))))
 401         (array-for-each rec (array-col a 1) (array-col a 0) (array-row a 1))
 402         l)))
 403
 404   (with-test-prefix "empty arrays"
 405
 406     (pass-if "empty other than last, #t" ; fails in 2.0.9 with bad a.
 407       (let* ((a (list))
 408              (b (make-array 0 2 2))
 409              (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
 410         (array-for-each (lambda (c) (set! a (cons c a))) c)
 411         (equal? a '())))
 412
 413     (pass-if "empty other than last, f64" ; fails in 2.0.9 with out of range.
 414       (let* ((a (list))
 415              (b (make-typed-array 'f64 0 2 2))
 416              (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
 417         (array-for-each (lambda (c) (set! a (cons c a))) c)
 418         (equal? a '())))
 419
 420     ;; FIXME add type 'b cases.
 421
 422     (pass-if-exception "empty arrays shape check" exception:shape-mismatch
 423       (let* ((a (list))
 424              (b (make-typed-array 'f64 0 0 2))
 425              (c (make-typed-array 'f64 0 2 0)))
 426         (array-for-each (lambda (b c) (set! a (cons* b c a))) b c)))))