mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 19:50:24 +02:00
Code Activity

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

Browse source
This commit is contained in:
Mark H Weaver 2012-11-03 03:35:14 -04:00
commit d628c078cc
7 changed files with 102 additions and 31 deletions
Download patch file Download diff file Expand all files Collapse all files

4
.dir-locals.el
View file

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

20
libguile/generalized-vectors.c
View file

@ -1,4 +1,5 @@
/* 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
@ -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;
}

2
module/ice-9/ftw.scm
View file

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

4
module/ice-9/futures.scm
View file

@ -93,8 +93,10 @@ touched."
;; Wait for futures to be available and process them.
(lock-mutex %futures-mutex)
(let loop ()
(when (q-empty? %futures)
(wait-condition-variable %futures-available
%futures-mutex)
%futures-mutex))
(or (q-empty? %futures)
(let ((future (deq! %futures)))
(lock-mutex (future-mutex future))

21
test-suite/test-suite/lib.scm
View file

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

40
test-suite/tests/arrays.test
View file

@ -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!

28
test-suite/tests/ftw.test
View file

@ -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 ((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)))
(name (string-append %test-suite-lib-dir "/lib.scm")))
(equal? (file-system-fold enter? leaf down up skip error '() name)
`((leaf ,name)))))
(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)