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

.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))))

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;
+  i = h.dims[0].ubnd - h.dims[0].lbnd + 1;
-       pos -= h.dims[0].inc, i--)
+  inc = h.dims[0].inc;
-    ret = scm_cons (h.impl->vref (&h, pos), ret);
+  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;
 }

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<?))))
 

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
+    (when (q-empty? %futures)
-                             %futures-mutex)
+      (wait-condition-variable %futures-available
+                               %futures-mutex))
+
     (or (q-empty? %futures)
         (let ((future (deq! %futures)))
           (lock-mutex (future-mutex future))

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 ()

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 '(1 2 3) (array->list #s16(1 2 3)))
-  (pass-if (equal? (array->list #(1 2 3)) '(1 2 3)))
+  (pass-if-equal '(1 2 3) (array->list #(1 2 3)))
-  (pass-if (equal? (array->list #2((1 2) (3 4) (5 6))) '((1 2) (3 4) (5 6))))
+  (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 '()  (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!

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)
+      (file-system-fold enter? leaf down up skip error '() %test-dir)))
-              `((skip , %test-dir)))))
 
-  (pass-if "test-suite/lib.scm (flat file)"
+  (let ((name   (string-append %test-suite-lib-dir "/lib.scm")))
-    (let ((enter? (lambda (n s r) #t))
+    (pass-if-equal "test-suite/lib.scm (flat file)"
-          (leaf   (lambda (n s r) (cons `(leaf ,n) r)))
+        `((leaf ,name))
-          (down   (lambda (n s r) (cons `(down ,n) r)))
+      (let ((enter? (lambda (n s r) #t))
-          (up     (lambda (n s r) (cons `(up ,n) r)))
+            (leaf   (lambda (n s r) (cons `(leaf ,n) r)))
-          (skip   (lambda (n s r) (cons `(skip ,n) r)))
+            (down   (lambda (n s r) (cons `(down ,n) r)))
-          (error  (lambda (n s e r) (cons `(error ,n) r)))
+            (up     (lambda (n s r) (cons `(up ,n) r)))
-          (name   (string-append %test-suite-lib-dir "/lib.scm")))
+            (skip   (lambda (n s r) (cons `(skip ,n) r)))
-      (equal? (file-system-fold enter? leaf down up skip error '() name)
+            (error  (lambda (n s e r) (cons `(error ,n) r))))
-              `((leaf ,name)))))
+        (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)