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 type 'b cases.
  88
  89     ))
  90
  91 ;;;
  92 ;;; array-map!
  93 ;;;
  94
  95 (with-test-prefix "array-map!"
  96
  97   (pass-if-exception "no args" exception:wrong-num-args
  98     (array-map!))
  99
 100   (pass-if-exception "one arg" exception:wrong-num-args
 101     (array-map! (make-array #f 5)))
 102
 103   (with-test-prefix "no sources"
 104
 105     (pass-if "closure 0"
 106       (array-map! (make-array #f 5) (lambda () #f))
 107       #t)
 108
 109     (pass-if-exception "closure 1" exception:wrong-num-args
 110       (array-map! (make-array #f 5) (lambda (x) #f)))
 111
 112     (pass-if-exception "closure 2" exception:wrong-num-args
 113       (array-map! (make-array #f 5) (lambda (x y) #f)))
 114
 115     (pass-if-exception "subr_1" exception:wrong-num-args
 116       (array-map! (make-array #f 5) length))
 117
 118     (pass-if-exception "subr_2" exception:wrong-num-args
 119       (array-map! (make-array #f 5) logtest))
 120
 121     (pass-if-exception "subr_2o" exception:wrong-num-args
 122       (array-map! (make-array #f 5) number->string))
 123
 124     (pass-if-exception "dsubr" exception:wrong-num-args
 125       (array-map! (make-array #f 5) sqrt))
 126
 127     (pass-if "rpsubr"
 128       (let ((a (make-array 'foo 5)))
 129         (array-map! a =)
 130         (equal? a (make-array #t 5))))
 131
 132     (pass-if "asubr"
 133       (let ((a (make-array 'foo 5)))
 134         (array-map! a +)
 135         (equal? a (make-array 0 5))))
 136
 137     ;; in Guile 1.6.4 and earlier this resulted in a segv
 138     (pass-if "noop"
 139       (array-map! (make-array #f 5) noop)
 140       #t))
 141
 142   (with-test-prefix "one source"
 143
 144     (pass-if-exception "closure 0" exception:wrong-num-args
 145       (array-map! (make-array #f 5) (lambda () #f)
 146                   (make-array #f 5)))
 147
 148     (pass-if "closure 1"
 149       (let ((a (make-array #f 5)))
 150         (array-map! a (lambda (x) 'foo) (make-array #f 5))
 151         (equal? a (make-array 'foo 5))))
 152
 153     (pass-if-exception "closure 2" exception:wrong-num-args
 154       (array-map! (make-array #f 5) (lambda (x y) #f)
 155             (make-array #f 5)))
 156
 157     (pass-if "subr_1"
 158       (let ((a (make-array #f 5)))
 159         (array-map! a length (make-array '(x y z) 5))
 160         (equal? a (make-array 3 5))))
 161
 162     (pass-if-exception "subr_2" exception:wrong-num-args
 163       (array-map! (make-array #f 5) logtest
 164                   (make-array 999 5)))
 165
 166     (pass-if "subr_2o"
 167       (let ((a (make-array #f 5)))
 168         (array-map! a number->string (make-array 99 5))
 169         (equal? a (make-array "99" 5))))
 170
 171     (pass-if "dsubr"
 172       (let ((a (make-array #f 5)))
 173         (array-map! a sqrt (make-array 16.0 5))
 174         (equal? a (make-array 4.0 5))))
 175
 176     (pass-if "rpsubr"
 177       (let ((a (make-array 'foo 5)))
 178         (array-map! a = (make-array 0 5))
 179         (equal? a (make-array #t 5))))
 180
 181     (pass-if "asubr"
 182       (let ((a (make-array 'foo 5)))
 183         (array-map! a - (make-array 99 5))
 184         (equal? a (make-array -99 5))))
 185
 186     ;; in Guile 1.6.5 and 1.6.6 this was an error
 187     (pass-if "1+"
 188       (let ((a (make-array #f 5)))
 189         (array-map! a 1+ (make-array 123 5))
 190         (equal? a (make-array 124 5)))))
 191
 192   (with-test-prefix "two sources"
 193
 194     (pass-if-exception "closure 0" exception:wrong-num-args
 195       (array-map! (make-array #f 5) (lambda () #f)
 196                   (make-array #f 5) (make-array #f 5)))
 197
 198     (pass-if-exception "closure 1" exception:wrong-num-args
 199       (array-map! (make-array #f 5) (lambda (x) #f)
 200                   (make-array #f 5) (make-array #f 5)))
 201
 202     (pass-if "closure 2"
 203       (let ((a (make-array #f 5)))
 204         (array-map! a (lambda (x y) 'foo)
 205                     (make-array #f 5) (make-array #f 5))
 206         (equal? a (make-array 'foo 5))))
 207
 208     (pass-if-exception "subr_1" exception:wrong-num-args
 209       (array-map! (make-array #f 5) length
 210                   (make-array #f 5) (make-array #f 5)))
 211
 212     (pass-if "subr_2"
 213       (let ((a (make-array 'foo 5)))
 214         (array-map! a logtest
 215                     (make-array 999 5) (make-array 999 5))
 216         (equal? a (make-array #t 5))))
 217
 218     (pass-if "subr_2o"
 219       (let ((a (make-array #f 5)))
 220         (array-map! a number->string
 221                     (make-array 32 5) (make-array 16 5))
 222         (equal? a (make-array "20" 5))))
 223
 224     (pass-if-exception "dsubr" exception:wrong-num-args
 225       (let ((a (make-array #f 5)))
 226         (array-map! a sqrt
 227                     (make-array 16.0 5) (make-array 16.0 5))
 228         (equal? a (make-array 4.0 5))))
 229
 230     (pass-if "rpsubr"
 231       (let ((a (make-array 'foo 5)))
 232         (array-map! a = (make-array 99 5) (make-array 77 5))
 233         (equal? a (make-array #f 5))))
 234
 235     (pass-if "asubr"
 236       (let ((a (make-array 'foo 5)))
 237         (array-map! a - (make-array 99 5) (make-array 11 5))
 238         (equal? a (make-array 88 5))))
 239
 240     (pass-if "+"
 241       (let ((a (make-array #f 4)))
 242         (array-map! a + #(1 2 3 4) #(5 6 7 8))
 243         (equal? a #(6 8 10 12))))
 244
 245     (pass-if "noncompact arrays 1"
 246       (let ((a #2((0 1) (2 3)))
 247             (c (make-array 0 2)))
 248         (begin
 249           (array-map! c + (array-row a 1) (array-row a 1))
 250           (array-equal? c #(4 6)))))
 251
 252     (pass-if "noncompact arrays 2"
 253       (let ((a #2((0 1) (2 3)))
 254             (c (make-array 0 2)))
 255         (begin
 256           (array-map! c + (array-col a 1) (array-col a 1))
 257           (array-equal? c #(2 6)))))
 258
 259     (pass-if "noncompact arrays 3"
 260       (let ((a #2((0 1) (2 3)))
 261             (c (make-array 0 2)))
 262         (begin
 263           (array-map! c + (array-col a 1) (array-row a 1))
 264           (array-equal? c #(3 6)))))
 265
 266     (pass-if "noncompact arrays 4"
 267       (let ((a #2((0 1) (2 3)))
 268             (c (make-array 0 2)))
 269         (begin
 270           (array-map! c + (array-col a 1) (array-row a 1))
 271           (array-equal? c #(3 6)))))))
 272
 273 ;;;
 274 ;;; array-for-each
 275 ;;;
 276
 277 (with-test-prefix "array-for-each"
 278
 279   (with-test-prefix "1 source"
 280     (pass-if-equal "noncompact array"
 281         '(3 2 1 0)
 282       (let* ((a #2((0 1) (2 3)))
 283              (l '())
 284              (p (lambda (x) (set! l (cons x l)))))
 285         (array-for-each p a)
 286         l))
 287
 288     (pass-if-equal "vector"
 289         '(3 2 1 0)
 290       (let* ((a #(0 1 2 3))
 291              (l '())
 292              (p (lambda (x) (set! l (cons x l)))))
 293         (array-for-each p a)
 294         l))
 295
 296     (pass-if-equal "shared array"
 297         '(3 2 1 0)
 298       (let* ((a  #2((0 1) (2 3)))
 299              (a' (make-shared-array a
 300                                     (lambda (x)
 301                                       (list (quotient x 4)
 302                                             (modulo x 4)))
 303                                     4))
 304              (l  '())
 305              (p  (lambda (x) (set! l (cons x l)))))
 306         (array-for-each p a')
 307         l)))
 308
 309   (with-test-prefix "3 sources"
 310     (pass-if-equal "noncompact arrays 1"
 311         '((3 3 3) (2 2 2))
 312       (let* ((a #2((0 1) (2 3)))
 313              (l '())
 314              (rec (lambda args (set! l (cons args l)))))
 315         (array-for-each rec (array-row a 1) (array-row a 1) (array-row a 1))
 316         l))
 317
 318     (pass-if-equal "noncompact arrays 2"
 319         '((3 3 3) (2 2 1))
 320       (let* ((a #2((0 1) (2 3)))
 321              (l '())
 322              (rec (lambda args (set! l (cons args l)))))
 323         (array-for-each rec (array-row a 1) (array-row a 1) (array-col a 1))
 324         l))
 325
 326     (pass-if-equal "noncompact arrays 3"
 327         '((3 3 3) (2 1 1))
 328       (let* ((a #2((0 1) (2 3)))
 329              (l '())
 330              (rec (lambda args (set! l (cons args l)))))
 331         (array-for-each rec (array-row a 1) (array-col a 1) (array-col a 1))
 332         l))
 333
 334     (pass-if-equal "noncompact arrays 4"
 335         '((3 2 3) (1 0 2))
 336       (let* ((a #2((0 1) (2 3)))
 337              (l '())
 338              (rec (lambda args (set! l (cons args l)))))
 339         (array-for-each rec (array-col a 1) (array-col a 0) (array-row a 1))
 340         l)))
 341
 342   (with-test-prefix "empty arrays"
 343
 344     (pass-if "empty other than last, #t" ; fails in 2.0.9 with bad a.
 345       (let* ((a (list))
 346              (b (make-array 0 2 2))
 347              (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
 348         (array-for-each (lambda (c) (set! a (cons c a))) c)
 349         (equal? a '())))
 350
 351     (pass-if "empty other than last, f64" ; fails in 2.0.9 with out of range.
 352       (let* ((a (list))
 353              (b (make-typed-array 'f64 0 2 2))
 354              (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
 355         (array-for-each (lambda (c) (set! a (cons c a))) c)
 356         (equal? a '())))
 357
 358     ;; FIXME add type 'b cases.
 359
 360     (pass-if-exception "empty arrays shape check" exception:shape-mismatch
 361       (let* ((a (list))
 362              (b (make-typed-array 'f64 0 0 2))
 363              (c (make-typed-array 'f64 0 2 0)))
 364         (array-for-each (lambda (b c) (set! a (cons* b c a))) b c)))))