[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-440-gd628c07
From: |
Mark H Weaver |
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-440-gd628c07 |
Date: |
Sat, 03 Nov 2012 07:41:08 +0000 |
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
[Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-440-gd628c07,
Mark H Weaver <=