Fix array map functions with empty arguments

* libguile/array-map.c
  - scm_ra_matchp: look for empty axes and return new case 5 if so. Use
    array handles to remove the SCM_I_ARRAYP / not branch.
  - scm_ramapc: Heed case 5.
* test-suite/tests/ramap.test
  - test empty arguments for array-copy! and array-for-each. Note those
    that failed in 2.0.9.

libguile/array-map.c

@@ -74,7 +74,9 @@ cind (SCM ra, long *ve)
 
 
 /* Checker for scm_array mapping functions:
-   return values: 4 --> shapes, increments, and bases are the same;
+   return values:
+   5 --> empty axes;
+   4 --> shapes, increments, and bases are the same;
    3 --> shapes and increments are the same;
    2 --> shapes are the same;
    1 --> ras are at least as big as ra0;
@@ -84,87 +86,57 @@ cind (SCM ra, long *ve)
 int
 scm_ra_matchp (SCM ra0, SCM ras)
 {
-  SCM ra1;
+  int i, exact = 4, empty = 0;
-  scm_t_array_dim dims;
+  scm_t_array_handle h0;
-  scm_t_array_dim *s0 = &dims;
-  scm_t_array_dim *s1;
-  unsigned long bas0 = 0;
-  int i, ndim = 1;
-  int exact = 2	  /* 4 */ ;  /* Don't care about values >2 (yet?) */
 
-  if (SCM_I_ARRAYP (ra0))
+  scm_array_get_handle (ra0, &h0);
+  for (i = 0; i < h0.ndims; ++i)
     {
-      ndim = SCM_I_ARRAY_NDIM (ra0);
+      empty = empty || (h0.dims[i].lbnd > h0.dims[i].ubnd);
-      s0 = SCM_I_ARRAY_DIMS (ra0);
-      bas0 = SCM_I_ARRAY_BASE (ra0);
     }
-  else if (scm_is_array (ra0))
-    {
-      s0->lbnd = 0;
-      s0->inc = 1;
-      s0->ubnd = scm_c_array_length (ra0) - 1;
-    }
-  else
-    return 0;
 
   while (scm_is_pair (ras))
     {
-      ra1 = SCM_CAR (ras);
+      scm_t_array_handle h1;
 
-      if (!SCM_I_ARRAYP (ra1))
+      scm_array_get_handle (SCM_CAR (ras), &h1);
+
+      if (h0.ndims != h1.ndims)
         {
-	  size_t length;
+          scm_array_handle_release (&h0);
-
+          scm_array_handle_release (&h1);
-	  if (1 != ndim)
-	    return 0;
-
-	  length = scm_c_array_length (ra1);
-
-	  switch (exact)
-	    {
-	    case 4:
-	      if (0 != bas0)
-		exact = 3;
-	    case 3:
-	      if (1 != s0->inc)
-		exact = 2;
-	    case 2:
-	      if ((0 == s0->lbnd) && (s0->ubnd == length - 1))
-		break;
-	      exact = 1;
-	    case 1:
-	      if (s0->lbnd < 0 || s0->ubnd >= length)
           return 0;
         }
-	}
+      if (h0.base != h1.base)
-      else if (ndim == SCM_I_ARRAY_NDIM (ra1))
+        exact = min(3, exact);
+
+      for (i = 0; i < h0.ndims; ++i)
         {
-	  s1 = SCM_I_ARRAY_DIMS (ra1);
+          empty = empty || (h1.dims[i].lbnd > h1.dims[i].ubnd);
-	  if (bas0 != SCM_I_ARRAY_BASE (ra1))
-	    exact = 3;
-	  for (i = 0; i < ndim; i++)
           switch (exact)
             {
             case 4:
             case 3:
-		if (s0[i].inc != s1[i].inc)
+              if (h0.dims[i].inc != h1.dims[i].inc)
                 exact = 2;
             case 2:
-		if (s0[i].lbnd == s1[i].lbnd && s0[i].ubnd == s1[i].ubnd)
+              if (h0.dims[i].lbnd == h1.dims[i].lbnd && h0.dims[i].ubnd == h1.dims[i].ubnd)
                 break;
               exact = 1;
             default:
-		if (s0[i].lbnd < s1[i].lbnd || s0[i].ubnd > s1[i].ubnd)
+              if (h0.dims[i].lbnd < h1.dims[i].lbnd || h0.dims[i].ubnd > h1.dims[i].ubnd)
-		  return (s0[i].lbnd <= s0[i].ubnd ? 0 : 1);
+                {
-	      }
+                  scm_array_handle_release (&h0);
-	}
+                  scm_array_handle_release (&h1);
-      else
                   return 0;
-
+                }
+            }
+        }
+      scm_array_handle_release (&h1);
       ras = SCM_CDR (ras);
     }
-
+  scm_array_handle_release (&h0);
-  return exact;
+  return empty ? 5 : exact;
 }
 
 /* array mapper: apply cproc to each dimension of the given arrays?.
@@ -320,6 +292,7 @@ scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what)
       }
     while (k >= 0);
 
+    case 5:
     return 1;
     }
 }

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))))
@@ -45,17 +48,21 @@
     (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)))
+      (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)))
+      (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)))))
+      (array-index-map! (make-typed-array #t 0 0 2) (const 0))
+      #t)))
 
 ;;;
 ;;; array-copy!
@@ -63,11 +70,23 @@
 
 (with-test-prefix "array-copy!"
 
-  (pass-if "empty arrays"
+  (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))))
+        (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 type 'b cases.
+
+    ))
 
 ;;;
 ;;; array-map!
@@ -318,4 +337,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)))))