[Guile-commits] 04/08: Support non-zero lower bounds in array-slice-for-each

[Daniel Llorens]

lloda pushed a commit to branch wip-exception-truncate
in repository guile.

commit b2604259519b664430b909eabb486adc74b1dcbb
Author: Daniel Llorens <address@hidden>
Date:   Mon Feb 13 13:49:35 2017 +0100

    Support non-zero lower bounds in array-slice-for-each
    
    * libguile/array-handle.c (scm_array_handle_writable_elements): Fix
      error message.
    * libguile/array-map.c (scm_array_slice_for_each): Support non-zero
      lower bounds. Fix error messages.
    * test-suite/tests/array-map.test: Test scm_array_slice_for_each with
      non-zero lower bound argument.
---
 libguile/array-map.c            | 22 +++++++++-------------
 test-suite/tests/array-map.test |  8 ++++++++
 2 files changed, 17 insertions(+), 13 deletions(-)

diff --git a/libguile/array-map.c b/libguile/array-map.c
index 7938396..d2cd651 100644
--- a/libguile/array-map.c
+++ b/libguile/array-map.c
@@ -679,6 +679,7 @@ SCM_DEFINE (scm_array_slice_for_each, 
"array-slice-for-each", 2, 0, 1,
             "@end lisp")
 #define FUNC_NAME s_scm_array_slice_for_each
 {
+  SCM xargs = args;
   int const N = scm_ilength (args);
   int const frank = scm_to_int (frame_rank);
   int ocd;
@@ -742,9 +743,9 @@ SCM_DEFINE (scm_array_slice_for_each, 
"array-slice-for-each", 2, 0, 1,
   assert((pool0+pool_size==pool) && "internal error");
 #undef AFIC_ALLOC_ADVANCE
 
-  for (n=0; scm_is_pair(args); args=scm_cdr(args), ++n)
+  for (n=0, xargs=args; scm_is_pair(xargs); xargs=scm_cdr(xargs), ++n)
     {
-      args_[n] = scm_car(args);
+      args_[n] = scm_car(xargs);
       scm_array_get_handle(args_[n], ah+n);
       as[n] = scm_array_handle_dims(ah+n);
       rank[n] = scm_array_handle_rank(ah+n);
@@ -752,29 +753,24 @@ SCM_DEFINE (scm_array_slice_for_each, 
"array-slice-for-each", 2, 0, 1,
   /* checks */
   msg = NULL;
   if (frank<0)
-    msg = "bad frame rank";
+    msg = "bad frame rank ~S, ~S";
   else
     {
       for (n=0; n!=N; ++n)
         {
           if (rank[n]<frank)
             {
-              msg = "frame too large for arguments";
+              msg = "frame too large for arguments: ~S, ~S";
               goto check_msg;
             }
           for (k=0; k!=frank; ++k)
             {
-              if (as[n][k].lbnd!=0)
+              if (as[0][k].lbnd!=as[n][k].lbnd || as[0][k].ubnd!=as[n][k].ubnd)
                 {
-                  msg = "non-zero base index is not supported";
+                  msg = "mismatched frames: ~S, ~S";
                   goto check_msg;
                 }
-              if (as[0][k].ubnd!=as[n][k].ubnd)
-                {
-                  msg = "mismatched frames";
-                  goto check_msg;
-                }
-              s[k] = as[n][k].ubnd + 1;
+              s[k] = as[n][k].ubnd - as[n][k].lbnd + 1;
 
               /* this check is needed if the array cannot be entirely */
               /* unrolled, because the unrolled subloop will be run before */
@@ -789,7 +785,7 @@ SCM_DEFINE (scm_array_slice_for_each, 
"array-slice-for-each", 2, 0, 1,
     {
       for (n=0; n!=N; ++n)
         scm_array_handle_release(ah+n);
-      scm_misc_error("array-slice-for-each", msg, scm_cons_star(frame_rank, 
args));
+      scm_misc_error("array-slice-for-each", msg, scm_cons(frame_rank, args));
     }
   /* prepare moving cells. */
   for (n=0; n!=N; ++n)
diff --git a/test-suite/tests/array-map.test b/test-suite/tests/array-map.test
index 3471841..8e0e769 100644
--- a/test-suite/tests/array-map.test
+++ b/test-suite/tests/array-map.test
@@ -520,6 +520,14 @@
         (array-slice-for-each 1 (lambda (a) (sort! a <)) a)
         a))
 
+  (pass-if-equal "1 argument frame rank 1, non-zero base indices"
+      address@hidden@1((1 3 9) (2 7 8))
+      (let* ((a (make-array *unspecified* '(1 2) '(1 3)))
+             (b address@hidden@1((9 1 3) (7 8 2))))
+        (array-copy! b a)
+        (array-slice-for-each 1 (lambda (a) (sort! a <)) a)
+        a))
+
   (pass-if-equal "2 arguments frame rank 1"
       #f64(8 -1)
       (let* ((x (list->typed-array 'f64 2 '((9 1) (7 8))))