[Guile-commits] GNU Guile branch, master, updated. v2.1.0-440-gd628c07

[Mark H Weaver]

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=d628c078cc8e2ccddbcab74346733486f7cf27e8

The branch, master has been updated
       via  d628c078cc8e2ccddbcab74346733486f7cf27e8 (commit)
       via  134c95f1e6a574d30881cf3ccaffba5e3c39cca4 (commit)
       via  1d4e6ee3013b2c0bebf7d715318e6c493f41ee19 (commit)
       via  80aeb9af0d593da8647162ed2416a22c83bd1e70 (commit)
       via  139ce194749391487d35fc2681d348a4d6976cef (commit)
       via  f3bb42fc9bc0bac1d8589a9788a93ad4ebbbda3d (commit)
       via  d4eee584e0976e38813d731bb6770f9146f1ef9c (commit)
      from  fa980bcc0f5b186b98d84fc5d165d35fcbb5d5ec (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 d628c078cc8e2ccddbcab74346733486f7cf27e8
Merge: fa980bc 134c95f
Author: Mark H Weaver <address@hidden>
Date:   Sat Nov 3 03:35:14 2012 -0400

    Merge remote-tracking branch 'origin/stable-2.0'

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

Summary of changes:
 .dir-locals.el                 |    4 +++-
 libguile/generalized-vectors.c |   22 +++++++++++++++-------
 module/ice-9/ftw.scm           |    2 +-
 module/ice-9/futures.scm       |    6 ++++--
 test-suite/test-suite/lib.scm  |   21 ++++++++++++++++++++-
 test-suite/tests/arrays.test   |   40 +++++++++++++++++++++++++++++++++++-----
 test-suite/tests/ftw.test      |   38 ++++++++++++++++++++++++--------------
 7 files changed, 102 insertions(+), 31 deletions(-)

diff --git a/.dir-locals.el b/.dir-locals.el
index e651538..3640530 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -3,7 +3,9 @@
 ((nil             . ((fill-column . 72)
                      (tab-width   .  8)))
  (c-mode          . ((c-file-style . "gnu")))
- (scheme-mode     . ((indent-tabs-mode . nil)))
+ (scheme-mode
+  . ((indent-tabs-mode . nil)
+     (eval . (put 'pass-if-equal 'scheme-indent-function 2))))
  (emacs-lisp-mode . ((indent-tabs-mode . nil)))
  (texinfo-mode    . ((indent-tabs-mode . nil)
                      (fill-column . 72))))
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/module/ice-9/ftw.scm b/module/ice-9/ftw.scm
index 6c9db27..9c9694f 100644
--- a/module/ice-9/ftw.scm
+++ b/module/ice-9/ftw.scm
@@ -562,7 +562,7 @@ of file names is sorted according to ENTRY<?, which 
defaults to
         result
         (visit (basename name*) result)))
 
-  (and=> (file-system-fold enter? leaf down up skip error #f name stat)
+  (and=> (file-system-fold enter? leaf down up skip error #f name lstat)
          (lambda (files)
            (sort files entry<?))))
 
diff --git a/module/ice-9/futures.scm b/module/ice-9/futures.scm
index 3c4cd7d..2ab3edd 100644
--- a/module/ice-9/futures.scm
+++ b/module/ice-9/futures.scm
@@ -93,8 +93,10 @@ touched."
   ;; Wait for futures to be available and process them.
   (lock-mutex %futures-mutex)
   (let loop ()
-    (wait-condition-variable %futures-available
-                             %futures-mutex)
+    (when (q-empty? %futures)
+      (wait-condition-variable %futures-available
+                               %futures-mutex))
+
     (or (q-empty? %futures)
         (let ((future (deq! %futures)))
           (lock-mutex (future-mutex future))
diff --git a/test-suite/test-suite/lib.scm b/test-suite/test-suite/lib.scm
index 385cdfa..7517b4e 100644
--- a/test-suite/test-suite/lib.scm
+++ b/test-suite/test-suite/lib.scm
@@ -44,6 +44,7 @@
  ;; Reporting passes and failures.
  run-test
  pass-if expect-fail
+ pass-if-equal
  pass-if-exception expect-fail-exception
 
  ;; Naming groups of tests in a regular fashion.
@@ -332,7 +333,11 @@
                   ((pass)
                    (report (if expect-pass 'pass 'upass) test-name))
                   ((fail)
-                   (report (if expect-pass 'fail 'xfail) test-name))
+                   ;; ARGS may contain extra info about the failure,
+                   ;; such as the expected and actual value.
+                   (apply report (if expect-pass 'fail 'xfail)
+                          test-name
+                          args))
                   ((unresolved untested unsupported)
                    (report key test-name))
                   ((quit)
@@ -352,6 +357,20 @@
     ((_ name rest ...)
      (run-test name #t (lambda () rest ...)))))
 
+(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
+               (lambda ()
+                 (let ((result (begin body ...)))
+                   (or (equal? expected result)
+                       (throw 'fail
+                              'expected-value expected
+                              'actual-value result))))))))
+
 ;;; A short form for tests that are expected to fail, taken from Greg.
 (define-syntax expect-fail
   (syntax-rules ()
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!
diff --git a/test-suite/tests/ftw.test b/test-suite/tests/ftw.test
index 33537d0..2a203de 100644
--- a/test-suite/tests/ftw.test
+++ b/test-suite/tests/ftw.test
@@ -182,26 +182,26 @@
               (any (match-lambda (('skip (= basename "vm")) #t) (_ #f))
                    between))))))
 
-  (pass-if "test-suite (never enter)"
+  (pass-if-equal "test-suite (never enter)"
+      `((skip ,%test-dir))
     (let ((enter? (lambda (n s r) #f))
           (leaf   (lambda (n s r) (cons `(leaf ,n) r)))
           (down   (lambda (n s r) (cons `(down ,n) r)))
           (up     (lambda (n s r) (cons `(up ,n) r)))
           (skip   (lambda (n s r) (cons `(skip ,n) r)))
           (error  (lambda (n s e r) (cons `(error ,n) r))))
-      (equal? (file-system-fold enter? leaf down up skip error '() %test-dir)
-              `((skip , %test-dir)))))
+      (file-system-fold enter? leaf down up skip error '() %test-dir)))
 
-  (pass-if "test-suite/lib.scm (flat file)"
-    (let ((enter? (lambda (n s r) #t))
-          (leaf   (lambda (n s r) (cons `(leaf ,n) r)))
-          (down   (lambda (n s r) (cons `(down ,n) r)))
-          (up     (lambda (n s r) (cons `(up ,n) r)))
-          (skip   (lambda (n s r) (cons `(skip ,n) r)))
-          (error  (lambda (n s e r) (cons `(error ,n) r)))
-          (name   (string-append %test-suite-lib-dir "/lib.scm")))
-      (equal? (file-system-fold enter? leaf down up skip error '() name)
-              `((leaf ,name)))))
+  (let ((name   (string-append %test-suite-lib-dir "/lib.scm")))
+    (pass-if-equal "test-suite/lib.scm (flat file)"
+        `((leaf ,name))
+      (let ((enter? (lambda (n s r) #t))
+            (leaf   (lambda (n s r) (cons `(leaf ,n) r)))
+            (down   (lambda (n s r) (cons `(down ,n) r)))
+            (up     (lambda (n s r) (cons `(up ,n) r)))
+            (skip   (lambda (n s r) (cons `(skip ,n) r)))
+            (error  (lambda (n s e r) (cons `(error ,n) r))))
+        (file-system-fold enter? leaf down up skip error '() name))))
 
   (pass-if "ENOENT"
     (let ((enter? (lambda (n s r) #t))
@@ -320,7 +320,17 @@
     (not (scandir "/.does-not-exist.")))
 
   (pass-if "no select"
-    (null? (scandir %test-dir (lambda (_) #f)))))
+    (null? (scandir %test-dir (lambda (_) #f))))
+
+  ;; In Guile up to 2.0.6, this would return ("." ".." "link-to-dir").
+  (pass-if-equal "symlink to directory"
+      '("." ".." "link-to-dir" "subdir")
+    (with-file-tree %top-builddir '(directory "test-scandir-symlink"
+                                              (("link-to-dir" -> "subdir")
+                                               (directory "subdir"
+                                                          (("a")))))
+      (let ((name (string-append %top-builddir "/test-scandir-symlink")))
+        (scandir name)))))
 
 ;;; Local Variables:
 ;;; eval: (put 'with-file-tree 'scheme-indent-function 2)


hooks/post-receive
-- 
GNU Guile