[Guile-commits] GNU Guile branch, master, updated. v2.1.0-645-g13af75b

[Andy Wingo]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=13af75bfe00ff66d18dff31fbf76fadbc3f8c4f4

The branch, master has been updated
       via  13af75bfe00ff66d18dff31fbf76fadbc3f8c4f4 (commit)
       via  69843ac1b9dcd2394452c71811438d3b28b5863f (commit)
      from  a6f8d3ddd833260bed88709f73ab9cb380f7afa0 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 13af75bfe00ff66d18dff31fbf76fadbc3f8c4f4
Author: Daniel Llorens <address@hidden>
Date:   Thu Apr 11 13:03:45 2013 +0200

    Fix bad uses of base and lbnd on rank 1 arrays
    
     * libguile/array-map.c
       - rafill, ramap, rafe, racp: object from SCM_I_ARRAY_V always
         has base 0, lbnd 0 and inc 1; make use of this.
     * libguile/arrays.c
       - array_handle_ref, array_handle_set: idem.
       - array_get_handle: sanity check.
     * libguile/generalized-vectors.c
       - scm_c_generalized_vector_ref, scm_c_generalized_vector_set_x:
         pos should be base when idx is lbnd. Furthermore, pos should be signed 
and
         have its overflow checked; do this by handling the job to
         scm_c_array_ref_1, scm_c_array_set_1_x.
     * libguile/generalized-vectors.h
       - fix prototypes.

-----------------------------------------------------------------------

Summary of changes:
 libguile/array-map.c           |   27 ++--
 libguile/arrays.c              |    2 +
 libguile/generalized-vectors.c |   29 +---
 libguile/generalized-vectors.h |    4 +-
 test-suite/tests/arrays.test   |  304 ++++++++++++++++++++--------------------
 5 files changed, 175 insertions(+), 191 deletions(-)

diff --git a/libguile/array-map.c b/libguile/array-map.c
index ad55656..245cc1f 100644
--- a/libguile/array-map.c
+++ b/libguile/array-map.c
@@ -183,9 +183,8 @@ scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, 
const char *what)
   SCM lvra, *plvra;
   long *vinds;
   int k, kmax;
-  int (*cproc) ();
+  int (*cproc) () = cproc_ptr;
 
-  cproc = cproc_ptr;
   switch (scm_ra_matchp (ra0, lra))
     {
     default:
@@ -333,8 +332,8 @@ rafill (SCM dst, SCM fill)
   size_t i;
   ssize_t inc;
   scm_array_get_handle (SCM_I_ARRAY_V (dst), &h);
-  i = h.base + h.dims[0].lbnd + SCM_I_ARRAY_BASE (dst)*h.dims[0].inc;
-  inc = SCM_I_ARRAY_DIMS (dst)->inc * h.dims[0].inc;
+  i = SCM_I_ARRAY_BASE (dst);
+  inc = SCM_I_ARRAY_DIMS (dst)->inc;
 
   for (; n-- > 0; i += inc)
     h.impl->vset (&h, i, fill);
@@ -367,10 +366,10 @@ racp (SCM src, SCM dst)
   scm_array_get_handle (SCM_I_ARRAY_V (src), &h_s);
   scm_array_get_handle (SCM_I_ARRAY_V (dst), &h_d);
 
-  i_s = h_s.base + h_s.dims[0].lbnd + SCM_I_ARRAY_BASE (src) * h_s.dims[0].inc;
-  i_d = h_d.base + h_d.dims[0].lbnd + SCM_I_ARRAY_BASE (dst) * h_d.dims[0].inc;
-  inc_s = SCM_I_ARRAY_DIMS (src)->inc * h_s.dims[0].inc;
-  inc_d = SCM_I_ARRAY_DIMS (dst)->inc * h_d.dims[0].inc;
+  i_s = SCM_I_ARRAY_BASE (src);
+  i_d = SCM_I_ARRAY_BASE (dst);
+  inc_s = SCM_I_ARRAY_DIMS (src)->inc;
+  inc_d = SCM_I_ARRAY_DIMS (dst)->inc;
 
   for (; n-- > 0; i_s += inc_s, i_d += inc_d)
     h_d.impl->vset (&h_d, i_d, h_s.impl->vref (&h_s, i_s));
@@ -670,8 +669,8 @@ ramap (SCM ra0, SCM proc, SCM ras)
   size_t i0, i0end;
   ssize_t inc0;
   scm_array_get_handle (SCM_I_ARRAY_V (ra0), &h0);
-  i0 = h0.base + h0.dims[0].lbnd + SCM_I_ARRAY_BASE (ra0)*h0.dims[0].inc;
-  inc0 = SCM_I_ARRAY_DIMS (ra0)->inc * h0.dims[0].inc;
+  i0 = SCM_I_ARRAY_BASE (ra0);
+  inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
   i0end = i0 + n*inc0;
   if (scm_is_null (ras))
     for (; i0 < i0end; i0 += inc0)
@@ -683,8 +682,8 @@ ramap (SCM ra0, SCM proc, SCM ras)
       size_t i1;
       ssize_t inc1;
       scm_array_get_handle (SCM_I_ARRAY_V (ra1), &h1);
-      i1 = h1.base + h1.dims[0].lbnd + SCM_I_ARRAY_BASE (ra1)*h1.dims[0].inc;
-      inc1 = SCM_I_ARRAY_DIMS (ra1)->inc * h1.dims[0].inc;
+      i1 = SCM_I_ARRAY_BASE (ra1);
+      inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
       ras = SCM_CDR (ras);
       if (scm_is_null (ras))
           for (; i0 < i0end; i0 += inc0, i1 += inc1)
@@ -743,8 +742,8 @@ rafe (SCM ra0, SCM proc, SCM ras)
   size_t i0, i0end;
   ssize_t inc0;
   scm_array_get_handle (SCM_I_ARRAY_V (ra0), &h0);
-  i0 = h0.base + h0.dims[0].lbnd + SCM_I_ARRAY_BASE (ra0)*h0.dims[0].inc;
-  inc0 = SCM_I_ARRAY_DIMS (ra0)->inc * h0.dims[0].inc;
+  i0 = SCM_I_ARRAY_BASE (ra0);
+  inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
   i0end = i0 + n*inc0;
   if (scm_is_null (ras))
     for (; i0 < i0end; i0 += inc0)
diff --git a/libguile/arrays.c b/libguile/arrays.c
index a8b62b2..a771739 100644
--- a/libguile/arrays.c
+++ b/libguile/arrays.c
@@ -27,6 +27,7 @@
 #include <stdio.h>
 #include <errno.h>
 #include <string.h>
+#include <assert.h>
 
 #include "libguile/_scm.h"
 #include "libguile/__scm.h"
@@ -836,6 +837,7 @@ array_get_handle (SCM array, scm_t_array_handle *h)
 {
   scm_t_array_handle vh;
   scm_array_get_handle (SCM_I_ARRAY_V (array), &vh);
+  assert (vh.dims[0].inc == 1 && vh.dims[0].lbnd == 0 && vh.base == 0);
   h->element_type = vh.element_type;
   h->elements = vh.elements;
   h->writable_elements = vh.writable_elements;
diff --git a/libguile/generalized-vectors.c b/libguile/generalized-vectors.c
index 5e3e552..fc493bc 100644
--- a/libguile/generalized-vectors.c
+++ b/libguile/generalized-vectors.c
@@ -1,5 +1,5 @@
 /* Copyright (C) 1995, 1996, 1997, 1998, 2000, 2001, 2002, 2003, 2004,
- *   2005, 2006, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+ *   2005, 2006, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, 
Inc.
  *
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -101,36 +101,19 @@ scm_generalized_vector_get_handle (SCM vec, 
scm_t_array_handle *h)
 size_t
 scm_c_generalized_vector_length (SCM v)
 {
-  scm_t_array_handle h;
-  size_t ret;
-  scm_generalized_vector_get_handle (v, &h);
-  ret = h.dims[0].ubnd - h.dims[0].lbnd + 1;
-  scm_array_handle_release (&h);
-  return ret;
+  return scm_c_array_length (v);
 }
 
 SCM
-scm_c_generalized_vector_ref (SCM v, size_t idx)
+scm_c_generalized_vector_ref (SCM v, ssize_t idx)
 {
-  scm_t_array_handle h;
-  size_t pos;
-  SCM ret;
-  scm_generalized_vector_get_handle (v, &h);
-  pos = h.base + h.dims[0].lbnd + idx * h.dims[0].inc;
-  ret = h.impl->vref (&h, pos);
-  scm_array_handle_release (&h);
-  return ret;
+  return scm_c_array_ref_1 (v, idx);
 }
 
 void
-scm_c_generalized_vector_set_x (SCM v, size_t idx, SCM val)
+scm_c_generalized_vector_set_x (SCM v, ssize_t idx, SCM val)
 {
-  scm_t_array_handle h;
-  size_t pos;
-  scm_generalized_vector_get_handle (v, &h);
-  pos = h.base + h.dims[0].lbnd + idx * h.dims[0].inc;
-  h.impl->vset (&h, pos, val);
-  scm_array_handle_release (&h);
+  scm_c_array_set_1_x (v, val, idx);
 }
 
 void
diff --git a/libguile/generalized-vectors.h b/libguile/generalized-vectors.h
index e2acb98..876537a 100644
--- a/libguile/generalized-vectors.h
+++ b/libguile/generalized-vectors.h
@@ -32,8 +32,8 @@
 
 SCM_API int scm_is_generalized_vector (SCM obj);
 SCM_API size_t scm_c_generalized_vector_length (SCM v);
-SCM_API SCM scm_c_generalized_vector_ref (SCM v, size_t idx);
-SCM_API void scm_c_generalized_vector_set_x (SCM v, size_t idx, SCM val);
+SCM_API SCM scm_c_generalized_vector_ref (SCM v, ssize_t idx);
+SCM_API void scm_c_generalized_vector_set_x (SCM v, ssize_t idx, SCM val);
 SCM_API void scm_generalized_vector_get_handle (SCM vec,
                                                scm_t_array_handle *h);
 
diff --git a/test-suite/tests/arrays.test b/test-suite/tests/arrays.test
index 600c295..0da1a19 100644
--- a/test-suite/tests/arrays.test
+++ b/test-suite/tests/arrays.test
@@ -6,12 +6,12 @@
 ;;;; modify it under the terms of the GNU Lesser General Public
 ;;;; License as published by the Free Software Foundation; either
 ;;;; version 3 of the License, or (at your option) any later version.
-;;;; 
+;;;;
 ;;;; This library is distributed in the hope that it will be useful,
 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 ;;;; Lesser General Public License for more details.
-;;;; 
+;;;;
 ;;;; You should have received a copy of the GNU Lesser General Public
 ;;;; License along with this library; if not, write to the Free Software
 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 
USA
@@ -207,6 +207,154 @@
     (array-equal? #s16(1 2 3) #s16(1 2 3))))
 
 ;;;
+;;; make-shared-array
+;;;
+
+(define exception:mapping-out-of-range
+  (cons 'misc-error "^mapping out of range"))  ;; per scm_make_shared_array
+
+(with-test-prefix "make-shared-array"
+
+  ;; this failed in guile 1.8.0
+  (pass-if "vector unchanged"
+    (let* ((a (make-array #f '(0 7)))
+          (s (make-shared-array a list '(0 7))))
+      (array-equal? a s)))
+
+  (pass-if-exception "vector, high too big" exception:mapping-out-of-range
+    (let* ((a (make-array #f '(0 7))))
+      (make-shared-array a list '(0 8))))
+
+  (pass-if-exception "vector, low too big" exception:out-of-range
+    (let* ((a (make-array #f '(0 7))))
+      (make-shared-array a list '(-1 7))))
+
+  (pass-if "truncate columns"
+    (array-equal? (make-shared-array #2((a b c) (d e f) (g h i)) list 3 2)
+                 #2((a b) (d e) (g h))))
+
+  (pass-if "pick one column"
+    (array-equal? (make-shared-array #2((a b c) (d e f) (g h i))
+                                    (lambda (i) (list i 2))
+                                    '(0 2))
+                 #(c f i)))
+
+  (pass-if "diagonal"
+    (array-equal? (make-shared-array #2((a b c) (d e f) (g h i))
+                                    (lambda (i) (list i i))
+                                    '(0 2))
+                 #(a e i)))
+
+  ;; this failed in guile 1.8.0
+  (pass-if "2 dims from 1 dim"
+    (array-equal? (make-shared-array #1(a b c d e f g h i j k l)
+                                    (lambda (i j) (list (+ (* i 3) j)))
+                                    4 3)
+                 #2((a b c) (d e f) (g h i) (j k l))))
+
+  (pass-if "reverse columns"
+    (array-equal? (make-shared-array #2((a b c) (d e f) (g h i))
+                                    (lambda (i j) (list i (- 2 j)))
+                                    3 3)
+                 #2((c b a) (f e d) (i h g))))
+
+  (pass-if "fixed offset, 0 based becomes 1 based"
+    (let* ((x #2((a b c) (d e f) (g h i)))
+          (y (make-shared-array x
+                                (lambda (i j) (list (1- i) (1- j)))
+                                '(1 3) '(1 3))))
+      (and (eq? (array-ref x 0 0) 'a)
+          (eq? (array-ref y 1 1) 'a))))
+
+  ;; this failed in guile 1.8.0
+  (pass-if "stride every third element"
+    (array-equal? (make-shared-array #1(a b c d e f g h i j k l)
+                                    (lambda (i) (list (* i 3)))
+                                    4)
+                 #1(a d g j)))
+
+  (pass-if "shared of shared"
+    (let* ((a  #2((1 2 3) (4 5 6) (7 8 9)))
+          (s1 (make-shared-array a (lambda (i) (list i 1)) 3))
+          (s2 (make-shared-array s1 list '(1 2))))
+      (and (eqv? 5 (array-ref s2 1))
+          (eqv? 8 (array-ref s2 2))))))
+
+;;;
+;;; shared-array-root
+;;;
+
+(with-test-prefix "shared-array-root"
+
+  (define amap1 (lambda (i) (list (* 2 i))))
+  (define amap2 (lambda (i j) (list (+ 1 (* 2 i)) (+ 1 (* 2 j)))))
+
+  (pass-if "plain vector"
+    (let* ((a (make-vector 4 0))
+           (b (make-shared-array a amap1 2)))
+      (eq? (shared-array-root a) (shared-array-root b) (array-contents a))))
+
+  (pass-if "plain array rank 2"
+    (let* ((a (make-array 0 4 4))
+           (b (make-shared-array a amap2 2 2)))
+      (eq? (shared-array-root a) (shared-array-root b) (array-contents a))))
+
+  (pass-if "uniform array rank 2"
+    (let* ((a (make-typed-array 'c64 0 4 4))
+           (b (make-shared-array a amap2 2 2)))
+      (eq? (shared-array-root a) (shared-array-root b) (array-contents a))))
+
+  (pass-if "bit array rank 2"
+    (let* ((a (make-typed-array 'b #f 4 4))
+           (b (make-shared-array a amap2 2 2)))
+      (eq? (shared-array-root a) (shared-array-root b) (array-contents a)))))
+
+;;;
+;;; transpose-array
+;;;
+
+; see strings.test.
+(define exception:wrong-type-arg
+  (cons #t "Wrong type"))
+
+(with-test-prefix "transpose-array"
+
+  (pass-if-exception "non array argument" exception:wrong-type-arg
+    (transpose-array 99))
+
+  (pass-if "rank 0"
+    (let* ((a #0(99))
+           (b (transpose-array a)))
+      (and (array-equal? a b)
+           (eq? (shared-array-root a) (shared-array-root b)))))
+
+  (pass-if "rank 1"
+    (let* ((a #(1 2 3))
+           (b (transpose-array a 0)))
+      (and (array-equal? a b)
+           (eq? (shared-array-root a) (shared-array-root b)))))
+
+  (pass-if "rank 2"
+    (let* ((a #2((1 2 3) (4 5 6)))
+           (b (transpose-array a 1 0))
+           (c (transpose-array a 0 1)))
+      (and (array-equal? b #2((1 4) (2 5) (3 6)))
+           (array-equal? c a)
+           (eq? (shared-array-root a)
+                (shared-array-root b)
+                (shared-array-root c)))))
+
+  ; rank > 2 is needed to check against the inverted axis index logic.
+  (pass-if "rank 3"
+    (let* ((a #3(((0 1 2 3) (4 5 6 7) (8 9 10 11))
+                 ((12 13 14 15) (16 17 18 19) (20 21 22 23))))
+           (b (transpose-array a 1 2 0)))
+      (and (array-equal? b #3(((0 4 8) (12 16 20)) ((1 5 9) (13 17 21))
+                              ((2 6 10) (14 18 22)) ((3 7 11) (15 19 23))))
+           (eq? (shared-array-root a)
+                (shared-array-root b))))))
+
+;;;
 ;;; array->list
 ;;;
 
@@ -397,8 +545,8 @@
       (for-each (lambda (type)
                  (pass-if (symbol->string type)
                     (eq? type
-                         (array-type (make-typed-array type 
-                                                       *unspecified* 
+                         (array-type (make-typed-array type
+                                                       *unspecified*
                                                        '(5 6))))))
                types))))
 
@@ -500,154 +648,6 @@
        (array-set! a 'y 4 8 0)))))
 
 ;;;
-;;; make-shared-array
-;;;
-
-(define exception:mapping-out-of-range
-  (cons 'misc-error "^mapping out of range"))  ;; per scm_make_shared_array
-
-(with-test-prefix "make-shared-array"
-
-  ;; this failed in guile 1.8.0
-  (pass-if "vector unchanged"
-    (let* ((a (make-array #f '(0 7)))
-          (s (make-shared-array a list '(0 7))))
-      (array-equal? a s)))
-
-  (pass-if-exception "vector, high too big" exception:mapping-out-of-range
-    (let* ((a (make-array #f '(0 7))))
-      (make-shared-array a list '(0 8))))
-
-  (pass-if-exception "vector, low too big" exception:out-of-range
-    (let* ((a (make-array #f '(0 7))))
-      (make-shared-array a list '(-1 7))))
-
-  (pass-if "truncate columns"
-    (array-equal? (make-shared-array #2((a b c) (d e f) (g h i)) list 3 2)
-                 #2((a b) (d e) (g h))))
-
-  (pass-if "pick one column"
-    (array-equal? (make-shared-array #2((a b c) (d e f) (g h i))
-                                    (lambda (i) (list i 2))
-                                    '(0 2))
-                 #(c f i)))
-
-  (pass-if "diagonal"
-    (array-equal? (make-shared-array #2((a b c) (d e f) (g h i))
-                                    (lambda (i) (list i i))
-                                    '(0 2))
-                 #(a e i)))
-
-  ;; this failed in guile 1.8.0
-  (pass-if "2 dims from 1 dim"
-    (array-equal? (make-shared-array #1(a b c d e f g h i j k l)
-                                    (lambda (i j) (list (+ (* i 3) j)))
-                                    4 3)
-                 #2((a b c) (d e f) (g h i) (j k l))))
-
-  (pass-if "reverse columns"
-    (array-equal? (make-shared-array #2((a b c) (d e f) (g h i))
-                                    (lambda (i j) (list i (- 2 j)))
-                                    3 3)
-                 #2((c b a) (f e d) (i h g))))
-
-  (pass-if "fixed offset, 0 based becomes 1 based"
-    (let* ((x #2((a b c) (d e f) (g h i)))
-          (y (make-shared-array x
-                                (lambda (i j) (list (1- i) (1- j)))
-                                '(1 3) '(1 3))))
-      (and (eq? (array-ref x 0 0) 'a)
-          (eq? (array-ref y 1 1) 'a))))
-
-  ;; this failed in guile 1.8.0
-  (pass-if "stride every third element"
-    (array-equal? (make-shared-array #1(a b c d e f g h i j k l)
-                                    (lambda (i) (list (* i 3)))
-                                    4)
-                 #1(a d g j)))
-
-  (pass-if "shared of shared"
-    (let* ((a  #2((1 2 3) (4 5 6) (7 8 9)))
-          (s1 (make-shared-array a (lambda (i) (list i 1)) 3))
-          (s2 (make-shared-array s1 list '(1 2))))
-      (and (eqv? 5 (array-ref s2 1))
-          (eqv? 8 (array-ref s2 2))))))
-
-;;;
-;;; shared-array-root
-;;;
-
-(with-test-prefix "shared-array-root"
-
-  (define amap1 (lambda (i) (list (* 2 i))))
-  (define amap2 (lambda (i j) (list (+ 1 (* 2 i)) (+ 1 (* 2 j)))))
-
-  (pass-if "plain vector"
-    (let* ((a (make-vector 4 0))
-           (b (make-shared-array a amap1 2)))
-      (eq? (shared-array-root a) (shared-array-root b) (array-contents a))))
-
-  (pass-if "plain array rank 2"
-    (let* ((a (make-array 0 4 4))
-           (b (make-shared-array a amap2 2 2)))
-      (eq? (shared-array-root a) (shared-array-root b) (array-contents a))))
-
-  (pass-if "uniform array rank 2"
-    (let* ((a (make-typed-array 'c64 0 4 4))
-           (b (make-shared-array a amap2 2 2)))
-      (eq? (shared-array-root a) (shared-array-root b) (array-contents a))))
-
-  (pass-if "bit array rank 2"
-    (let* ((a (make-typed-array 'b #f 4 4))
-           (b (make-shared-array a amap2 2 2)))
-      (eq? (shared-array-root a) (shared-array-root b) (array-contents a)))))
-
-;;;
-;;; transpose-array
-;;;
-
-; see strings.test.
-(define exception:wrong-type-arg
-  (cons #t "Wrong type"))
-
-(with-test-prefix "transpose-array"
-
-  (pass-if-exception "non array argument" exception:wrong-type-arg
-    (transpose-array 99))
-
-  (pass-if "rank 0"
-    (let* ((a #0(99))
-           (b (transpose-array a)))
-      (and (array-equal? a b)
-           (eq? (shared-array-root a) (shared-array-root b)))))
-
-  (pass-if "rank 1"
-    (let* ((a #(1 2 3))
-           (b (transpose-array a 0)))
-      (and (array-equal? a b)
-           (eq? (shared-array-root a) (shared-array-root b)))))
-
-  (pass-if "rank 2"
-    (let* ((a #2((1 2 3) (4 5 6)))
-           (b (transpose-array a 1 0))
-           (c (transpose-array a 0 1)))
-      (and (array-equal? b #2((1 4) (2 5) (3 6)))
-           (array-equal? c a)
-           (eq? (shared-array-root a)
-                (shared-array-root b)
-                (shared-array-root c)))))
-
-  ; rank > 2 is needed to check against the inverted axis index logic.
-  (pass-if "rank 3"
-    (let* ((a #3(((0 1 2 3) (4 5 6 7) (8 9 10 11))
-                 ((12 13 14 15) (16 17 18 19) (20 21 22 23))))
-           (b (transpose-array a 1 2 0)))
-      (and (array-equal? b #3(((0 4 8) (12 16 20)) ((1 5 9) (13 17 21))
-                              ((2 6 10) (14 18 22)) ((3 7 11) (15 19 23))))
-           (eq? (shared-array-root a)
-                (shared-array-root b))))))
-
-;;;
 ;;; uniform-vector
 ;;;
 


hooks/post-receive
-- 
GNU Guile