X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/7affd3141b4f821fba911caa7a94d9cc9c03fafe..3f4829e082c2fdd0553a6ce97fe173f8df327e7b:/test-suite/tests/ramap.test

diff --git a/test-suite/tests/ramap.test b/test-suite/tests/ramap.test
index 00de626a4..c8eaf96eb 100644
--- a/test-suite/tests/ramap.test
+++ b/test-suite/tests/ramap.test
@@ -19,6 +19,9 @@
 (define-module (test-suite test-ramap)
   #:use-module (test-suite lib))
 
+(define exception:shape-mismatch
+  (cons 'misc-error ".*shape mismatch.*"))
+
 (define (array-row a i)
   (make-shared-array a (lambda (j) (list i j))
                        (cadr (array-dimensions a))))
@@ -33,11 +36,41 @@
 
 (with-test-prefix "array-index-map!"
 
-  (pass-if (let ((nlst '()))
-             (array-index-map! (make-array #f '(1 1))
-                               (lambda (n)
-                                 (set! nlst (cons n nlst))))
-             (equal? nlst '(1)))))
+  (pass-if "basic test"
+    (let ((nlst '()))
+      (array-index-map! (make-array #f '(1 1))
+                        (lambda (n)
+                          (set! nlst (cons n nlst))))
+      (equal? nlst '(1))))
+
+  (with-test-prefix "empty arrays"
+
+    (pass-if "all axes empty"
+      (array-index-map! (make-typed-array 'f64 0 0 0) (const 0))
+      (array-index-map! (make-typed-array 'b #t 0 0) (const #t))
+      (array-index-map! (make-typed-array #t 0 0 0) (const 0))
+      #t)
+
+    (pass-if "last axis empty"
+      (array-index-map! (make-typed-array 'f64 0 2 0) (const 0))
+      (array-index-map! (make-typed-array 'b #t 2 0) (const #t))
+      (array-index-map! (make-typed-array #t 0 2 0) (const 0))
+      #t)
+
+    ; the 'f64 cases fail in 2.0.9 with out-of-range.
+    (pass-if "axis empty, other than last"
+      (array-index-map! (make-typed-array 'f64 0 0 2) (const 0))
+      (array-index-map! (make-typed-array 'b #t 0 2) (const #t))
+      (array-index-map! (make-typed-array #t 0 0 2) (const 0))
+      #t))
+
+  (pass-if "rank 2"
+    (let ((a (make-array 0 2 2))
+          (b (make-array 0 2 2)))
+      (array-index-map! a (lambda (i j) i))
+      (array-index-map! b (lambda (i j) j))
+      (and (array-equal? a #2((0 0) (1 1)))
+           (array-equal? b #2((0 1) (0 1)))))))
 
 ;;;
 ;;; array-copy!
@@ -45,11 +78,98 @@
 
 (with-test-prefix "array-copy!"
 
-  (pass-if "empty arrays"
-    (let* ((b (make-array 0 2 2))
-           (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
-      (array-copy! #2:0:2() c)
-      (array-equal? #2:0:2() c))))
+  (with-test-prefix "empty arrays"
+
+    (pass-if "empty other than last, #t"
+      (let* ((b (make-array 0 2 2))
+             (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
+        (array-copy! #2:0:2() c)
+        (array-equal? #2:0:2() c)))
+
+    (pass-if "empty other than last, 'f64"
+      (let* ((b (make-typed-array 'f64 0 2 2))
+             (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
+        (array-copy! #2:0:2() c)
+        (array-equal? #2f64:0:2() c)))
+
+  ;; FIXME add empty, type 'b cases.
+
+    )
+
+  ;; note that it is the opposite of array-map!. This is, unfortunately,
+  ;; documented in the manual.
+
+  (pass-if "matching behavior I"
+    (let ((a #(1 2))
+          (b (make-array 0 3)))
+      (array-copy! a b)
+      (equal? b #(1 2 0))))
+
+  (pass-if-exception "matching behavior II" exception:shape-mismatch
+    (let ((a #(1 2 3))
+          (b (make-array 0 2)))
+      (array-copy! a b)
+      (equal? b #(1 2))))
+
+  ;; here both a & b are are unrollable down to the first axis, but the
+  ;; size mismatch limits unrolling to the last axis only.
+
+  (pass-if "matching behavior III"
+    (let ((a #3(((1 2) (3 4)) ((5 6) (7 8))))
+          (b (make-array 0 2 3 2)))
+      (array-copy! a b)
+      (array-equal? b #3(((1 2) (3 4) (0 0)) ((5 6) (7 8) (0 0))))))
+
+  (pass-if "rank 0"
+    (let ((a #0(99))
+          (b (make-array 0)))
+      (array-copy! a b)
+      (equal? b #0(99))))
+
+  (pass-if "rank 1"
+    (let* ((a #2((1 2) (3 4)))
+           (b (make-shared-array a (lambda (j) (list 1 j)) 2))
+           (c (make-shared-array a (lambda (i) (list (- 1 i) 1)) 2))
+           (d (make-array 0 2))
+           (e (make-array 0 2)))
+      (array-copy! b d)
+      (array-copy! c e)
+      (and (equal? d #(3 4))
+           (equal? e #(4 2)))))
+
+  (pass-if "rank 2"
+    (let ((a #2((1 2) (3 4)))
+          (b (make-array 0 2 2))
+          (c (make-array 0 2 2))
+          (d (make-array 0 2 2))
+          (e (make-array 0 2 2)))
+      (array-copy! a b)
+      (array-copy! a (transpose-array c 1 0))
+      (array-copy! (transpose-array a 1 0) d)
+      (array-copy! (transpose-array a 1 0) (transpose-array e 1 0))
+      (and (equal? a #2((1 2) (3 4)))
+           (equal? b #2((1 2) (3 4)))
+           (equal? c #2((1 3) (2 4)))
+           (equal? d #2((1 3) (2 4)))
+           (equal? e #2((1 2) (3 4))))))
+
+  (pass-if "rank 2, discontinuous"
+    (let ((A #2((0 1) (2 3) (4 5)))
+          (B #2((10 11) (12 13) (14 15)))
+          (C #2((20) (21) (22)))
+          (X (make-array 0 3 5))
+          (piece (lambda (X w s)
+                   (make-shared-array
+                    X (lambda (i j) (list i (+ j s))) 3 w))))
+      (array-copy! A (piece X 2 0))
+      (array-copy! B (piece X 2 2))
+      (array-copy! C (piece X 1 4))
+      (and (array-equal? X #2((0 1 10 11 20) (2 3 12 13 21) (4 5 14 15 22))))))
+
+  (pass-if "null increments, not empty"
+    (let ((a (make-array 0 2 2)))
+      (array-copy! (make-shared-array #0(1) (lambda x '()) 2 2) a)
+      (array-equal? #2((1 1) (1 1))))))
 
 ;;;
 ;;; array-map!
@@ -115,7 +235,7 @@
 
     (pass-if-exception "closure 2" exception:wrong-num-args
       (array-map! (make-array #f 5) (lambda (x y) #f)
-            (make-array #f 5)))
+                  (make-array #f 5)))
 
     (pass-if "subr_1"
       (let ((a (make-array #f 5)))
@@ -150,7 +270,31 @@
     (pass-if "1+"
       (let ((a (make-array #f 5)))
 	(array-map! a 1+ (make-array 123 5))
-	(equal? a (make-array 124 5)))))
+	(equal? a (make-array 124 5))))
+
+    (pass-if "rank 0"
+      (let ((a #0(99))
+            (b (make-array 0)))
+        (array-map! b values a)
+        (equal? b #0(99))))
+
+    (pass-if "rank 2, discontinuous"
+      (let ((A #2((0 1) (2 3) (4 5)))
+            (B #2((10 11) (12 13) (14 15)))
+            (C #2((20) (21) (22)))
+            (X (make-array 0 3 5))
+            (piece (lambda (X w s)
+                     (make-shared-array
+                      X (lambda (i j) (list i (+ j s))) 3 w))))
+        (array-map! (piece X 2 0) values A)
+        (array-map! (piece X 2 2) values B)
+        (array-map! (piece X 1 4) values C)
+        (and (array-equal? X #2((0 1 10 11 20) (2 3 12 13 21) (4 5 14 15 22))))))
+
+    (pass-if "null increments, not empty"
+      (let ((a (make-array 0 2 2)))
+        (array-map! a values (make-shared-array #0(1) (lambda x '()) 2 2))
+        (array-equal? a #2((1 1) (1 1))))))
 
   (with-test-prefix "two sources"
 
@@ -231,7 +375,37 @@
             (c (make-array 0 2)))
         (begin
           (array-map! c + (array-col a 1) (array-row a 1))
-          (array-equal? c #(3 6)))))))
+          (array-equal? c #(3 6)))))
+
+    (pass-if "offset arrays 1"
+      (let ((a #2@1@-3((0 1) (2 3)))
+            (c (make-array 0 '(1 2) '(-3 -2))))
+        (begin
+          (array-map! c + a a)
+          (array-equal? c #2@1@-3((0 2) (4 6)))))))
+
+  ;; note that array-copy! has the opposite behavior.
+
+  (pass-if-exception "matching behavior I" exception:shape-mismatch
+    (let ((a #(1 2))
+          (b (make-array 0 3)))
+      (array-map! b values a)
+      (equal? b #(1 2 0))))
+
+  (pass-if "matching behavior II"
+    (let ((a #(1 2 3))
+          (b (make-array 0 2)))
+      (array-map! b values a)
+      (equal? b #(1 2))))
+
+  ;; here both a & b are are unrollable down to the first axis, but the
+  ;; size mismatch limits unrolling to the last axis only.
+
+  (pass-if "matching behavior III"
+    (let ((a #3(((1 2) (3 4) (5 6)) ((7 8) (9 10) (11 12))))
+          (b (make-array 0 2 2 2)))
+      (array-map! b values a)
+      (array-equal? b #3(((1 2) (3 4)) ((7 8) (9 10)))))))
 
 ;;;
 ;;; array-for-each
@@ -240,6 +414,14 @@
 (with-test-prefix "array-for-each"
 
   (with-test-prefix "1 source"
+    (pass-if-equal "rank 0"
+        '(99)
+      (let* ((a #0(99))
+             (l '())
+             (p (lambda (x) (set! l (cons x l)))))
+        (array-for-each p a)
+        l))
+
     (pass-if-equal "noncompact array"
         '(3 2 1 0)
       (let* ((a #2((0 1) (2 3)))
@@ -300,4 +482,28 @@
              (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))))
+        l)))
+
+  (with-test-prefix "empty arrays"
+
+    (pass-if "empty other than last, #t" ; fails in 2.0.9 with bad a.
+      (let* ((a (list))
+             (b (make-array 0 2 2))
+             (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
+        (array-for-each (lambda (c) (set! a (cons c a))) c)
+        (equal? a '())))
+
+    (pass-if "empty other than last, f64" ; fails in 2.0.9 with out of range.
+      (let* ((a (list))
+             (b (make-typed-array 'f64 0 2 2))
+             (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
+        (array-for-each (lambda (c) (set! a (cons c a))) c)
+        (equal? a '())))
+
+    ;; FIXME add type 'b cases.
+
+    (pass-if-exception "empty arrays shape check" exception:shape-mismatch
+      (let* ((a (list))
+             (b (make-typed-array 'f64 0 0 2))
+             (c (make-typed-array 'f64 0 2 0)))
+        (array-for-each (lambda (b c) (set! a (cons* b c a))) b c)))))