Subject: bug#10252: bugs in array-map!, array-for-each, others

From: Daniel Llorens <[email-masked]>
Date: Thu, 8 Dec 2011 19:20:21 +0100

Hello,

I've found some bugs in array-map! and array-for-each. Apparently the array parameters only get used for the required arguments. The rest get base=0 and inc=1, which causes errors when those don't apply. 1.8.8 works fine.

I have a patch and it solves my problem, but it needs a review. I'm not certain of understanding the functions generalized_vector_ref / set which are used everywhere on array-map.c. Also I needed to use array-equal? in the tests, but AFAICT equal? should work as well.

The patch also changes array-for-each to work with a zero-arity function, like for-each.

I have another bug of the same sort, which I haven't looked into. The last line gives 0 but it should give 2.

; generalized-vector-ref / set! is broken.

(define (array-row a i)
  (make-shared-array a (lambda (j) (list i j))
                       (cadr (array-dimensions a))))
(define nn #2u32((0 1) (2 3)))

(array-ref (array-row nn 1) 0)
(generalized-vector-ref (array-row nn 1) 0)

Regards,

	Daniel

%< -----

From 58e544c0034582de01f3b54f52228bfa2273578b Mon Sep 17 00:00:00 2001
From: Daniel Llorens <[email-masked]>
Date: Thu, 8 Dec 2011 18:49:00 +0100
Subject: [PATCH] Fix array-map! and array-for-each when rest arguments are not compact

* array-map.c (rafe, rafmap): Use array base and inc for all arguments.
* array-map.c, array-map.h (array-for-each): Allow empty argument list,
  after for-each.
* ramap.test: New tests.
  - array-map! with noncompact arrays and more than one argument.
  - array-for-each with noncompact arrays and more than two arguments.
  - array-for-each with zero arity function.
---
 libguile/array-map.c        |   86 ++++++++++++++++++++----------------------
 libguile/array-map.h        |    2 +-
 test-suite/tests/ramap.test |   79 +++++++++++++++++++++++++++++++++++++++-
 3 files changed, 120 insertions(+), 47 deletions(-)

diff --git a/libguile/array-map.c b/libguile/array-map.c
index d442bdf..449318b 100644
--- a/libguile/array-map.c
+++ b/libguile/array-map.c
@@ -621,7 +621,6 @@ scm_ra_divide (SCM ra0, SCM ras)
   return 1;
 }
 
-
 int
 scm_array_identity (SCM dst, SCM src)
 {
@@ -629,40 +628,36 @@ scm_array_identity (SCM dst, SCM src)
 }

-
 static int 
 ramap (SCM ra0, SCM proc, SCM ras)
 {
-  long i = SCM_I_ARRAY_DIMS (ra0)->lbnd;
-  long inc = SCM_I_ARRAY_DIMS (ra0)->inc;
-  long n = SCM_I_ARRAY_DIMS (ra0)->ubnd;
-  long base = SCM_I_ARRAY_BASE (ra0) - i * inc;
+  long i;
+  long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
+  long n = SCM_I_ARRAY_DIMS (ra0)->ubnd-SCM_I_ARRAY_DIMS (ra0)->lbnd;
+  long base0 = SCM_I_ARRAY_BASE (ra0);
   ra0 = SCM_I_ARRAY_V (ra0);
   if (scm_is_null (ras))
-    for (; i <= n; i++)
-      GVSET (ra0, i*inc+base, scm_call_0 (proc));
+    for (i = 0; i <= n; i++)
+      GVSET (ra0, i*inc0+base0, scm_call_0 (proc));
   else
     {
-      SCM ra1 = SCM_CAR (ras);
-      SCM args;
-      unsigned long k, i1 = SCM_I_ARRAY_BASE (ra1);
-      long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
-      ra1 = SCM_I_ARRAY_V (ra1);
-      ras = scm_vector (SCM_CDR (ras));
-      
-      for (; i <= n; i++, i1 += inc1)
+      ras = scm_vector (ras);
+      for (i = 0; i <= n; i++)
 	{
-	  args = SCM_EOL;
-	  for (k = scm_c_vector_length (ras); k--;)
-	    args = scm_cons (GVREF (scm_c_vector_ref (ras, k), i), args);
-	  args = scm_cons (GVREF (ra1, i1), args);
-	  GVSET (ra0, i*inc+base, scm_apply_0 (proc, args));
+	  SCM args = SCM_EOL;
+          unsigned long k;
+	  for (k = scm_c_vector_length (ras); k--;) {
+            SCM rak = scm_c_vector_ref (ras, k);
+            long inck = SCM_I_ARRAY_DIMS (rak)->inc;
+            long basek = SCM_I_ARRAY_BASE (rak);
+	    args = scm_cons (GVREF (rak, i*inck+basek), args);
+          }
+	  GVSET (ra0, i*inc0+base0, scm_apply_0 (proc, args));
 	}
     }
   return 1;
 }
 
-
 SCM_REGISTER_PROC(s_array_map_in_order_x, "array-map-in-order!", 2, 0, 1, scm_array_map_x);
 
 SCM_SYMBOL (sym_b, "b");
@@ -690,45 +685,46 @@ SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1,
 static int
 rafe (SCM ra0, SCM proc, SCM ras)
 {
-  long i = SCM_I_ARRAY_DIMS (ra0)->lbnd;
-  unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
+  long i;
   long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
-  long n = SCM_I_ARRAY_DIMS (ra0)->ubnd;
+  long n = SCM_I_ARRAY_DIMS (ra0)->ubnd-SCM_I_ARRAY_DIMS (ra0)->lbnd;
+  long base0 = SCM_I_ARRAY_BASE (ra0);
   ra0 = SCM_I_ARRAY_V (ra0);
   if (scm_is_null (ras))
-    for (; i <= n; i++, i0 += inc0)
-      scm_call_1 (proc, GVREF (ra0, i0));
+    for (i = 0; i <= n; i++)
+      scm_call_1 (proc, GVREF (ra0, i*inc0+base0));
   else
     {
-      SCM ra1 = SCM_CAR (ras);
-      SCM args;
-      unsigned long k, i1 = SCM_I_ARRAY_BASE (ra1);
-      long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
-      ra1 = SCM_I_ARRAY_V (ra1);
-      ras = scm_vector (SCM_CDR (ras));
-
-      for (; i <= n; i++, i0 += inc0, i1 += inc1)
+      ras = scm_vector (ras);
+      for (i = 0; i <= n; i++)
 	{
-	  args = SCM_EOL;
-	  for (k = scm_c_vector_length (ras); k--;)
-	    args = scm_cons (GVREF (scm_c_vector_ref (ras, k), i), args);
-	  args = scm_cons2 (GVREF (ra0, i0), GVREF (ra1, i1), args);
-	  scm_apply_0 (proc, args);
+	  SCM args = SCM_EOL;
+          unsigned long k;
+	  for (k = scm_c_vector_length (ras); k--;) {
+            SCM rak = scm_c_vector_ref (ras, k);
+            long inck = SCM_I_ARRAY_DIMS (rak)->inc;
+            long basek = SCM_I_ARRAY_BASE (rak);
+	    args = scm_cons (GVREF (rak, i*inck+basek), args);
+          }
+	  scm_apply_0 (proc, scm_cons (GVREF (ra0, i*inc0+base0), args));
 	}
     }
   return 1;
 }
 
-
-SCM_DEFINE (scm_array_for_each, "array-for-each", 2, 0, 1,
-	    (SCM proc, SCM ra0, SCM lra),
-	    "Apply @var{proc} to each tuple of elements of @var{array0} @dots{}\n"
+SCM_DEFINE (scm_array_for_each, "array-for-each", 1, 0, 1,
+	    (SCM proc, SCM lra),
+	    "Apply @var{proc} to each tuple of elements of @var{lra} @dots{}\n"
 	    "in row-major order.  The value returned is unspecified.")
 #define FUNC_NAME s_scm_array_for_each
 {
   SCM_VALIDATE_PROC (1, proc);
   SCM_VALIDATE_REST_ARGUMENT (lra);
-  scm_ramapc (rafe, proc, ra0, lra, FUNC_NAME);
+/* scm_ramapc() needs at least one argument to check shapes */
+  if (!scm_is_null(lra))
+    {
+      scm_ramapc (rafe, proc, scm_car (lra), scm_cdr (lra), FUNC_NAME);
+    }
   return SCM_UNSPECIFIED;
 }
 #undef FUNC_NAME
diff --git a/libguile/array-map.h b/libguile/array-map.h
index 43d2a92..dbb8365 100644
--- a/libguile/array-map.h
+++ b/libguile/array-map.h
@@ -45,7 +45,7 @@ SCM_API int scm_ra_product (SCM ra0, SCM ras);
 SCM_API int scm_ra_divide (SCM ra0, SCM ras);
 SCM_API int scm_array_identity (SCM src, SCM dst);
 SCM_API SCM scm_array_map_x (SCM ra0, SCM proc, SCM lra);
-SCM_API SCM scm_array_for_each (SCM proc, SCM ra0, SCM lra);
+SCM_API SCM scm_array_for_each (SCM proc, SCM lra);
 SCM_API SCM scm_array_index_map_x (SCM ra, SCM proc);
 SCM_API SCM scm_array_equal_p (SCM ra0, SCM ra1);
 SCM_INTERNAL void scm_init_array_map (void);
diff --git a/test-suite/tests/ramap.test b/test-suite/tests/ramap.test
index e3a65ae..bb604e2 100644
--- a/test-suite/tests/ramap.test
+++ b/test-suite/tests/ramap.test
@@ -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!
 ;;;
@@ -183,4 +191,73 @@
     (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 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)))))))
+
+;;;
+;;; array-for-each
+;;;
+
+(with-test-prefix "array-for-each"
+
+  (with-test-prefix "no sources"
+    (pass-if "noncompact arrays 1"
+      (let ((l 99))
+        (array-for-each (lambda x (set! l (length x))))
+        (= l 99))))
+
+  (with-test-prefix "3 sources"
+    (pass-if "noncompact arrays 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-row a 1))
+        (equal? l '((3 3 3) (2 2 2)))))
+          
+    (pass-if "noncompact arrays 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-col a 1))
+        (equal? l '((3 3 3) (2 2 1)))))
+          
+    (pass-if "noncompact arrays 3"
+      (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))
+        (equal? l '((3 3 3) (2 1 1)))))
+          
+    (pass-if "noncompact arrays 4"
+      (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))
+        (equal? l '((3 2 3) (1 0 2)))))))
-- 
1.7.1