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 (array-row a i)
  23   (make-shared-array a (lambda (j) (list i j))
  24                        (cadr (array-dimensions a))))
  25
  26 (define (array-col a j)
  27   (make-shared-array a (lambda (i) (list i j))
  28                        (car (array-dimensions a))))
  29
  30 ;;;
  31 ;;; array-index-map!
  32 ;;;
  33
  34 (with-test-prefix "array-index-map!"
  35
  36   (pass-if (let ((nlst '()))
  37              (array-index-map! (make-array #f '(1 1))
  38                                (lambda (n)
  39                                  (set! nlst (cons n nlst))))
  40              (equal? nlst '(1)))))
  41
  42 ;;;
  43 ;;; array-copy!
  44 ;;;
  45
  46 (with-test-prefix "array-copy!"
  47
  48   (pass-if "empty arrays"
  49     (let* ((b (make-array 0 2 2))
  50            (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
  51       (array-copy! #2:0:2() c)
  52       (array-equal? #2:0:2() c))))
  53
  54 ;;;
  55 ;;; array-map!
  56 ;;;
  57
  58 (with-test-prefix "array-map!"
  59
  60   (pass-if-exception "no args" exception:wrong-num-args
  61     (array-map!))
  62
  63   (pass-if-exception "one arg" exception:wrong-num-args
  64     (array-map! (make-array #f 5)))
  65
  66   (with-test-prefix "no sources"
  67
  68     (pass-if "closure 0"
  69       (array-map! (make-array #f 5) (lambda () #f))
  70       #t)
  71
  72     (pass-if-exception "closure 1" exception:wrong-num-args
  73       (array-map! (make-array #f 5) (lambda (x) #f)))
  74
  75     (pass-if-exception "closure 2" exception:wrong-num-args
  76       (array-map! (make-array #f 5) (lambda (x y) #f)))
  77
  78     (pass-if-exception "subr_1" exception:wrong-num-args
  79       (array-map! (make-array #f 5) length))
  80
  81     (pass-if-exception "subr_2" exception:wrong-num-args
  82       (array-map! (make-array #f 5) logtest))
  83
  84     (pass-if-exception "subr_2o" exception:wrong-num-args
  85       (array-map! (make-array #f 5) number->string))
  86
  87     (pass-if-exception "dsubr" exception:wrong-num-args
  88       (array-map! (make-array #f 5) sqrt))
  89
  90     (pass-if "rpsubr"
  91       (let ((a (make-array 'foo 5)))
  92         (array-map! a =)
  93         (equal? a (make-array #t 5))))
  94
  95     (pass-if "asubr"
  96       (let ((a (make-array 'foo 5)))
  97         (array-map! a +)
  98         (equal? a (make-array 0 5))))
  99
 100     ;; in Guile 1.6.4 and earlier this resulted in a segv
 101     (pass-if "noop"
 102       (array-map! (make-array #f 5) noop)
 103       #t))
 104
 105   (with-test-prefix "one source"
 106
 107     (pass-if-exception "closure 0" exception:wrong-num-args
 108       (array-map! (make-array #f 5) (lambda () #f)
 109                   (make-array #f 5)))
 110
 111     (pass-if "closure 1"
 112       (let ((a (make-array #f 5)))
 113         (array-map! a (lambda (x) 'foo) (make-array #f 5))
 114         (equal? a (make-array 'foo 5))))
 115
 116     (pass-if-exception "closure 2" exception:wrong-num-args
 117       (array-map! (make-array #f 5) (lambda (x y) #f)
 118             (make-array #f 5)))
 119
 120     (pass-if "subr_1"
 121       (let ((a (make-array #f 5)))
 122         (array-map! a length (make-array '(x y z) 5))
 123         (equal? a (make-array 3 5))))
 124
 125     (pass-if-exception "subr_2" exception:wrong-num-args
 126       (array-map! (make-array #f 5) logtest
 127                   (make-array 999 5)))
 128
 129     (pass-if "subr_2o"
 130       (let ((a (make-array #f 5)))
 131         (array-map! a number->string (make-array 99 5))
 132         (equal? a (make-array "99" 5))))
 133
 134     (pass-if "dsubr"
 135       (let ((a (make-array #f 5)))
 136         (array-map! a sqrt (make-array 16.0 5))
 137         (equal? a (make-array 4.0 5))))
 138
 139     (pass-if "rpsubr"
 140       (let ((a (make-array 'foo 5)))
 141         (array-map! a = (make-array 0 5))
 142         (equal? a (make-array #t 5))))
 143
 144     (pass-if "asubr"
 145       (let ((a (make-array 'foo 5)))
 146         (array-map! a - (make-array 99 5))
 147         (equal? a (make-array -99 5))))
 148
 149     ;; in Guile 1.6.5 and 1.6.6 this was an error
 150     (pass-if "1+"
 151       (let ((a (make-array #f 5)))
 152         (array-map! a 1+ (make-array 123 5))
 153         (equal? a (make-array 124 5)))))
 154
 155   (with-test-prefix "two sources"
 156
 157     (pass-if-exception "closure 0" exception:wrong-num-args
 158       (array-map! (make-array #f 5) (lambda () #f)
 159                   (make-array #f 5) (make-array #f 5)))
 160
 161     (pass-if-exception "closure 1" exception:wrong-num-args
 162       (array-map! (make-array #f 5) (lambda (x) #f)
 163                   (make-array #f 5) (make-array #f 5)))
 164
 165     (pass-if "closure 2"
 166       (let ((a (make-array #f 5)))
 167         (array-map! a (lambda (x y) 'foo)
 168                     (make-array #f 5) (make-array #f 5))
 169         (equal? a (make-array 'foo 5))))
 170
 171     (pass-if-exception "subr_1" exception:wrong-num-args
 172       (array-map! (make-array #f 5) length
 173                   (make-array #f 5) (make-array #f 5)))
 174
 175     (pass-if "subr_2"
 176       (let ((a (make-array 'foo 5)))
 177         (array-map! a logtest
 178                     (make-array 999 5) (make-array 999 5))
 179         (equal? a (make-array #t 5))))
 180
 181     (pass-if "subr_2o"
 182       (let ((a (make-array #f 5)))
 183         (array-map! a number->string
 184                     (make-array 32 5) (make-array 16 5))
 185         (equal? a (make-array "20" 5))))
 186
 187     (pass-if-exception "dsubr" exception:wrong-num-args
 188       (let ((a (make-array #f 5)))
 189         (array-map! a sqrt
 190                     (make-array 16.0 5) (make-array 16.0 5))
 191         (equal? a (make-array 4.0 5))))
 192
 193     (pass-if "rpsubr"
 194       (let ((a (make-array 'foo 5)))
 195         (array-map! a = (make-array 99 5) (make-array 77 5))
 196         (equal? a (make-array #f 5))))
 197
 198     (pass-if "asubr"
 199       (let ((a (make-array 'foo 5)))
 200         (array-map! a - (make-array 99 5) (make-array 11 5))
 201         (equal? a (make-array 88 5))))
 202
 203     (pass-if "+"
 204       (let ((a (make-array #f 4)))
 205         (array-map! a + #(1 2 3 4) #(5 6 7 8))
 206         (equal? a #(6 8 10 12))))
 207
 208     (pass-if "noncompact arrays 1"
 209       (let ((a #2((0 1) (2 3)))
 210             (c (make-array 0 2)))
 211         (begin
 212           (array-map! c + (array-row a 1) (array-row a 1))
 213           (array-equal? c #(4 6)))))
 214
 215     (pass-if "noncompact arrays 2"
 216       (let ((a #2((0 1) (2 3)))
 217             (c (make-array 0 2)))
 218         (begin
 219           (array-map! c + (array-col a 1) (array-col a 1))
 220           (array-equal? c #(2 6)))))
 221
 222     (pass-if "noncompact arrays 3"
 223       (let ((a #2((0 1) (2 3)))
 224             (c (make-array 0 2)))
 225         (begin
 226           (array-map! c + (array-col a 1) (array-row a 1))
 227           (array-equal? c #(3 6)))))
 228
 229     (pass-if "noncompact arrays 4"
 230       (let ((a #2((0 1) (2 3)))
 231             (c (make-array 0 2)))
 232         (begin
 233           (array-map! c + (array-col a 1) (array-row a 1))
 234           (array-equal? c #(3 6)))))))
 235
 236 ;;;
 237 ;;; array-for-each
 238 ;;;
 239
 240 (with-test-prefix "array-for-each"
 241
 242   (with-test-prefix "1 source"
 243     (pass-if-equal "noncompact array"
 244         '(3 2 1 0)
 245       (let* ((a #2((0 1) (2 3)))
 246              (l '())
 247              (p (lambda (x) (set! l (cons x l)))))
 248         (array-for-each p a)
 249         l))
 250
 251     (pass-if-equal "vector"
 252         '(3 2 1 0)
 253       (let* ((a #(0 1 2 3))
 254              (l '())
 255              (p (lambda (x) (set! l (cons x l)))))
 256         (array-for-each p a)
 257         l))
 258
 259     (pass-if-equal "shared array"
 260         '(3 2 1 0)
 261       (let* ((a  #2((0 1) (2 3)))
 262              (a' (make-shared-array a
 263                                     (lambda (x)
 264                                       (list (quotient x 4)
 265                                             (modulo x 4)))
 266                                     4))
 267              (l  '())
 268              (p  (lambda (x) (set! l (cons x l)))))
 269         (array-for-each p a')
 270         l)))
 271
 272   (with-test-prefix "3 sources"
 273     (pass-if-equal "noncompact arrays 1"
 274         '((3 3 3) (2 2 2))
 275       (let* ((a #2((0 1) (2 3)))
 276              (l '())
 277              (rec (lambda args (set! l (cons args l)))))
 278         (array-for-each rec (array-row a 1) (array-row a 1) (array-row a 1))
 279         l))
 280
 281     (pass-if-equal "noncompact arrays 2"
 282         '((3 3 3) (2 2 1))
 283       (let* ((a #2((0 1) (2 3)))
 284              (l '())
 285              (rec (lambda args (set! l (cons args l)))))
 286         (array-for-each rec (array-row a 1) (array-row a 1) (array-col a 1))
 287         l))
 288
 289     (pass-if-equal "noncompact arrays 3"
 290         '((3 3 3) (2 1 1))
 291       (let* ((a #2((0 1) (2 3)))
 292              (l '())
 293              (rec (lambda args (set! l (cons args l)))))
 294         (array-for-each rec (array-row a 1) (array-col a 1) (array-col a 1))
 295         l))
 296
 297     (pass-if-equal "noncompact arrays 4"
 298         '((3 2 3) (1 0 2))
 299       (let* ((a #2((0 1) (2 3)))
 300              (l '())
 301              (rec (lambda args (set! l (cons args l)))))
 302         (array-for-each rec (array-col a 1) (array-col a 0) (array-row a 1))
 303         l))))