tests: Use NUL instead of /dev/null on MinGW.

[bpt/guile.git] / test-suite / tests / ramap.test

diff --git a/test-suite/tests/ramap.test b/test-suite/tests/ramap.test
index 948a778..7c3142d 100644 (file)
--- a/test-suite/tests/ramap.test
+++ b/test-suite/tests/ramap.test
@@ -1,6 +1,6 @@
 ;;;; 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
@@ -19,6 +19,14 @@
 (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!
 ;;;
@@ -65,7 +73,7 @@
       (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)))
@@ -113,7 +121,7 @@
 
     (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"
@@ -148,7 +156,7 @@
                    (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)))
 
@@ -164,9 +172,9 @@
                    (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))))
 
@@ -183,4 +191,101 @@
     (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))))