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 <daniel.llor...@bluewin.ch>
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
