;;;; ramap.test --- test array mapping functions -*- scheme -*-
;;;;
-;;;; Copyright (C) 2004, 2005, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2004, 2005, 2006, 2009, 2013 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
(define-module (test-suite test-ramap)
#:use-module (test-suite lib))
+(define (array-row a i)
+ (make-shared-array a (lambda (j) (list i j))
+ (cadr (array-dimensions a))))
+
+(define (array-col a j)
+ (make-shared-array a (lambda (i) (list i j))
+ (car (array-dimensions a))))
+
;;;
;;; array-index-map!
;;;
(array-map! (make-array #f 5) number->string))
(pass-if-exception "dsubr" exception:wrong-num-args
- (array-map! (make-array #f 5) $sqrt))
+ (array-map! (make-array #f 5) sqrt))
(pass-if "rpsubr"
(let ((a (make-array 'foo 5)))
(pass-if "dsubr"
(let ((a (make-array #f 5)))
- (array-map! a $sqrt (make-array 16.0 5))
+ (array-map! a sqrt (make-array 16.0 5))
(equal? a (make-array 4.0 5))))
(pass-if "rpsubr"
(make-array #f 5) (make-array #f 5))
(equal? a (make-array 'foo 5))))
- (pass-if-exception "subr_1" exception:wrong-type-arg
+ (pass-if-exception "subr_1" exception:wrong-num-args
(array-map! (make-array #f 5) length
(make-array #f 5) (make-array #f 5)))
(make-array 32 5) (make-array 16 5))
(equal? a (make-array "20" 5))))
- (pass-if "dsubr"
+ (pass-if-exception "dsubr" exception:wrong-num-args
(let ((a (make-array #f 5)))
- (array-map! a $sqrt
+ (array-map! a sqrt
(make-array 16.0 5) (make-array 16.0 5))
(equal? a (make-array 4.0 5))))
(pass-if "+"
(let ((a (make-array #f 4)))
(array-map! a + #(1 2 3 4) #(5 6 7 8))
- (equal? a #(6 8 10 12))))))
+ (equal? a #(6 8 10 12))))
+
+ (pass-if "noncompact arrays 1"
+ (let ((a #2((0 1) (2 3)))
+ (c #(0 0)))
+ (begin
+ (array-map! c + (array-row a 1) (array-row a 1))
+ (array-equal? c #(4 6)))))
+
+ (pass-if "noncompact arrays 2"
+ (let ((a #2((0 1) (2 3)))
+ (c #(0 0)))
+ (begin
+ (array-map! c + (array-col a 1) (array-col a 1))
+ (array-equal? c #(2 6)))))
+
+ (pass-if "noncompact arrays 3"
+ (let ((a #2((0 1) (2 3)))
+ (c #(0 0)))
+ (begin
+ (array-map! c + (array-col a 1) (array-row a 1))
+ (array-equal? c #(3 6)))))
+
+ (pass-if "noncompact arrays 4"
+ (let ((a #2((0 1) (2 3)))
+ (c #(0 0)))
+ (begin
+ (array-map! c + (array-col a 1) (array-row a 1))
+ (array-equal? c #(3 6)))))))
+
+;;;
+;;; array-for-each
+;;;
+
+(with-test-prefix "array-for-each"
+
+ (with-test-prefix "1 source"
+ (pass-if-equal "noncompact array"
+ '(3 2 1 0)
+ (let* ((a #2((0 1) (2 3)))
+ (l '())
+ (p (lambda (x) (set! l (cons x l)))))
+ (array-for-each p a)
+ l))
+
+ (pass-if-equal "vector"
+ '(3 2 1 0)
+ (let* ((a #(0 1 2 3))
+ (l '())
+ (p (lambda (x) (set! l (cons x l)))))
+ (array-for-each p a)
+ l))
+
+ (pass-if-equal "shared array"
+ '(3 2 1 0)
+ (let* ((a #2((0 1) (2 3)))
+ (a' (make-shared-array a
+ (lambda (x)
+ (list (quotient x 4)
+ (modulo x 4)))
+ 4))
+ (l '())
+ (p (lambda (x) (set! l (cons x l)))))
+ (array-for-each p a')
+ l)))
+
+ (with-test-prefix "3 sources"
+ (pass-if-equal "noncompact arrays 1"
+ '((3 3 3) (2 2 2))
+ (let* ((a #2((0 1) (2 3)))
+ (l '())
+ (rec (lambda args (set! l (cons args l)))))
+ (array-for-each rec (array-row a 1) (array-row a 1) (array-row a 1))
+ l))
+
+ (pass-if-equal "noncompact arrays 2"
+ '((3 3 3) (2 2 1))
+ (let* ((a #2((0 1) (2 3)))
+ (l '())
+ (rec (lambda args (set! l (cons args l)))))
+ (array-for-each rec (array-row a 1) (array-row a 1) (array-col a 1))
+ l))
+
+ (pass-if-equal "noncompact arrays 3"
+ '((3 3 3) (2 1 1))
+ (let* ((a #2((0 1) (2 3)))
+ (l '())
+ (rec (lambda args (set! l (cons args l)))))
+ (array-for-each rec (array-row a 1) (array-col a 1) (array-col a 1))
+ l))
+
+ (pass-if-equal "noncompact arrays 4"
+ '((3 2 3) (1 0 2))
+ (let* ((a #2((0 1) (2 3)))
+ (l '())
+ (rec (lambda args (set! l (cons args l)))))
+ (array-for-each rec (array-col a 1) (array-col a 0) (array-row a 1))
+ l))))