[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.6-64-g1d4e6ee

[Ludovic Courtès]

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=1d4e6ee3013b2c0bebf7d715318e6c493f41ee19

The branch, stable-2.0 has been updated
       via  1d4e6ee3013b2c0bebf7d715318e6c493f41ee19 (commit)
       via  80aeb9af0d593da8647162ed2416a22c83bd1e70 (commit)
      from  139ce194749391487d35fc2681d348a4d6976cef (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 1d4e6ee3013b2c0bebf7d715318e6c493f41ee19
Author: Ludovic Courtès <address@hidden>
Date:   Sat Nov 3 00:20:23 2012 +0100

    Fix `generalized-vector->list' indexing bug with shared arrays.
    
    Fixes <http://bugs.gnu.org/12465>.
    Reported by Daniel Llorens <address@hidden>.
    
    * libguile/generalized-vectors.c (scm_generalized_vector_to_list): Fix
      initial value of POS; pass the `h.base + pos', not just `pos' as the
      `vref' argument.
    
    * test-suite/tests/arrays.test ("array->list")["http://bugs.gnu.org/12465
      - ok", "http://bugs.gnu.org/12465 - bad]: New tests.
      ("generalized-vector->list"): New test prefix.

commit 80aeb9af0d593da8647162ed2416a22c83bd1e70
Author: Ludovic Courtès <address@hidden>
Date:   Fri Nov 2 23:29:43 2012 +0100

    test-suite: Add a nameless form of `pass-if-equal'.
    
    * test-suite/test-suite/lib.scm (pass-if-equal): Add a nameless pattern.
    * test-suite/tests/arrays.test ("array->list"): Use `pass-if-equal'.

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

Summary of changes:
 libguile/generalized-vectors.c |   22 +++++++++++++++-------
 test-suite/test-suite/lib.scm  |    4 +++-
 test-suite/tests/arrays.test   |   40 +++++++++++++++++++++++++++++++++++-----
 3 files changed, 53 insertions(+), 13 deletions(-)

diff --git a/libguile/generalized-vectors.c b/libguile/generalized-vectors.c
index d8a3bf8..4da0e88 100644
--- a/libguile/generalized-vectors.c
+++ b/libguile/generalized-vectors.c
@@ -1,5 +1,6 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 
2009, 2010, 2011 Free Software Foundation, Inc.
- * 
+/* Copyright (C) 1995, 1996, 1997, 1998, 2000, 2001, 2002, 2003, 2004,
+ *   2005, 2006, 2009, 2010, 2011, 2012 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
  * as published by the Free Software Foundation; either version 3 of
@@ -178,14 +179,21 @@ SCM_DEFINE (scm_generalized_vector_to_list, 
"generalized-vector->list", 1, 0, 0,
            "generalized vector @var{v}.")
 #define FUNC_NAME s_scm_generalized_vector_to_list
 {
+  /* FIXME: This duplicates `array_to_list'.  */
   SCM ret = SCM_EOL;
-  ssize_t pos, i = 0;
+  long inc;
+  ssize_t pos, i;
   scm_t_array_handle h;
+
   scm_generalized_vector_get_handle (v, &h);
-  for (pos = h.dims[0].ubnd, i = (h.dims[0].ubnd - h.dims[0].lbnd);
-       i >= 0;
-       pos -= h.dims[0].inc, i--)
-    ret = scm_cons (h.impl->vref (&h, pos), ret);
+
+  i = h.dims[0].ubnd - h.dims[0].lbnd + 1;
+  inc = h.dims[0].inc;
+  pos = (i - 1) * inc;
+
+  for (; i > 0; i--, pos -= inc)
+    ret = scm_cons (h.impl->vref (&h, h.base + pos), ret);
+
   scm_array_handle_release (&h);
   return ret;
 }
diff --git a/test-suite/test-suite/lib.scm b/test-suite/test-suite/lib.scm
index 756d97e..7517b4e 100644
--- a/test-suite/test-suite/lib.scm
+++ b/test-suite/test-suite/lib.scm
@@ -360,8 +360,10 @@
 (define-syntax pass-if-equal
   (syntax-rules ()
     "Succeed if and only if BODY's return value is equal? to EXPECTED."
+    ((_ expected body)
+     (pass-if-equal 'body expected body))
     ((_ name expected body ...)
-     (run-test 'name #t
+     (run-test name #t
                (lambda ()
                  (let ((result (begin body ...)))
                    (or (equal? expected result)
diff --git a/test-suite/tests/arrays.test b/test-suite/tests/arrays.test
index b6eee7c..f13b1a2 100644
--- a/test-suite/tests/arrays.test
+++ b/test-suite/tests/arrays.test
@@ -1,6 +1,6 @@
 ;;;; unif.test --- tests guile's uniform arrays     -*- scheme -*-
 ;;;;
-;;;; Copyright 2004, 2006, 2009, 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright 2004, 2006, 2009, 2010, 2011, 2012 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
@@ -211,11 +211,41 @@
 ;;;
 
 (with-test-prefix "array->list"
-  (pass-if (equal? (array->list #s16(1 2 3)) '(1 2 3)))
-  (pass-if (equal? (array->list #(1 2 3)) '(1 2 3)))
-  (pass-if (equal? (array->list #2((1 2) (3 4) (5 6))) '((1 2) (3 4) (5 6))))
-  (pass-if (equal? (array->list #()) '())))
+  (pass-if-equal '(1 2 3) (array->list #s16(1 2 3)))
+  (pass-if-equal '(1 2 3) (array->list #(1 2 3)))
+  (pass-if-equal '((1 2) (3 4) (5 6)) (array->list #2((1 2) (3 4) (5 6))))
+  (pass-if-equal '()  (array->list #()))
+
+  (pass-if-equal "http://bugs.gnu.org/12465 - ok"
+      '(3 4)
+    (let* ((a #2((1 2) (3 4)))
+           (b (make-shared-array a (lambda (j) (list 1 j)) 2)))
+      (array->list b)))
+  (pass-if-equal "http://bugs.gnu.org/12465 - bad"
+      '(2 4)
+    (let* ((a #2((1 2) (3 4)))
+           (b (make-shared-array a (lambda (i) (list i 1)) 2)))
+      (array->list b))))
 
+;;;
+;;; generalized-vector->list
+;;;
+
+(with-test-prefix "generalized-vector->list"
+  (pass-if-equal '(1 2 3) (generalized-vector->list #s16(1 2 3)))
+  (pass-if-equal '(1 2 3) (generalized-vector->list #(1 2 3)))
+  (pass-if-equal '()  (generalized-vector->list #()))
+
+  (pass-if-equal "http://bugs.gnu.org/12465 - ok"
+      '(3 4)
+    (let* ((a #2((1 2) (3 4)))
+           (b (make-shared-array a (lambda (j) (list 1 j)) 2)))
+      (generalized-vector->list b)))
+  (pass-if-equal "http://bugs.gnu.org/12465 - bad"
+      '(2 4)
+    (let* ((a #2((1 2) (3 4)))
+           (b (make-shared-array a (lambda (i) (list i 1)) 2)))
+      (generalized-vector->list b))))
 
 ;;;
 ;;; array-fill!


hooks/post-receive
-- 
GNU Guile