mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-24 20:30:28 +02:00
Merge remote-tracking branch 'origin/stable-2.0'
Conflicts: libguile/__scm.h libguile/array-map.c libguile/procprop.c libguile/tags.h module/ice-9/deprecated.scm module/ice-9/psyntax-pp.scm module/ice-9/psyntax.scm test-suite/standalone/test-num2integral.c test-suite/tests/regexp.test
This commit is contained in:
Andy Wingo
commit
91ee7515da
64 changed files with 1024 additions and 648 deletions
|
|
@ -119,7 +119,7 @@
|
|||
;;;;
|
||||
;;;; * (pass-if-exception name exception body) will pass if the execution of
|
||||
;;;; body causes the given exception to be thrown. If no exception is
|
||||
;;;; thrown, the test fails. If some other exception is thrown, is is an
|
||||
;;;; thrown, the test fails. If some other exception is thrown, it is an
|
||||
;;;; error.
|
||||
;;;; * (expect-fail-exception name exception body) will pass unexpectedly if
|
||||
;;;; the execution of body causes the given exception to be thrown. If no
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
/* Copyright (C) 1999,2000,2001,2003,2004, 2006, 2008, 2010, 2011 Free Software Foundation, Inc.
|
||||
/* Copyright (C) 1999, 2000, 2001, 2003, 2004, 2006, 2008, 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
|
||||
|
|
@ -34,8 +35,7 @@ SCM call_num2ulong_long_body (void *data);
|
|||
SCM
|
||||
out_of_range_handler (void *data, SCM key, SCM args)
|
||||
{
|
||||
assert (scm_is_true
|
||||
(scm_equal_p (key, scm_from_locale_symbol ("out-of-range"))));
|
||||
assert (scm_is_eq (key, scm_from_locale_symbol ("out-of-range")));
|
||||
return SCM_BOOL_T;
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -27,7 +27,7 @@
|
|||
#include <stdlib.h>
|
||||
#include <libguile.h>
|
||||
|
||||
#include <gc/gc_version.h>
|
||||
#include <gc/gc.h>
|
||||
|
||||
|
||||
/* Up to GC 7.2alpha5, calling `GC_INIT' from a secondary thread would
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
/* Copyright (C) 2011 Free Software Foundation, Inc.
|
||||
/* Copyright (C) 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
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;;; ftw.test --- exercise ice-9/ftw.scm -*- scheme -*-
|
||||
;;;;
|
||||
;;;; Copyright 2006, 2011 Free Software Foundation, Inc.
|
||||
;;;; Copyright 2006, 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
|
||||
|
|
@ -81,12 +81,71 @@
|
|||
;;; `file-system-fold' & co.
|
||||
;;;
|
||||
|
||||
(define %top-builddir
|
||||
(canonicalize-path (getcwd)))
|
||||
|
||||
(define %top-srcdir
|
||||
(assq-ref %guile-build-info 'top_srcdir))
|
||||
|
||||
(define %test-dir
|
||||
(string-append %top-srcdir "/test-suite"))
|
||||
|
||||
(define (make-file-tree dir tree)
|
||||
"Make file system TREE at DIR."
|
||||
(define (touch file)
|
||||
(call-with-output-file file
|
||||
(cut display "" <>)))
|
||||
|
||||
(let loop ((dir dir)
|
||||
(tree tree))
|
||||
(define (scope file)
|
||||
(string-append dir "/" file))
|
||||
|
||||
(match tree
|
||||
(('directory name (body ...))
|
||||
(mkdir (scope name))
|
||||
(for-each (cute loop (scope name) <>) body))
|
||||
(('directory name (? integer? mode) (body ...))
|
||||
(mkdir (scope name))
|
||||
(for-each (cute loop (scope name) <>) body)
|
||||
(chmod (scope name) mode))
|
||||
((file)
|
||||
(touch (scope file)))
|
||||
((file (? integer? mode))
|
||||
(touch (scope file))
|
||||
(chmod (scope file) mode))
|
||||
((from '-> to)
|
||||
(symlink to (scope from))))))
|
||||
|
||||
(define (delete-file-tree dir tree)
|
||||
"Delete file TREE from DIR."
|
||||
(let loop ((dir dir)
|
||||
(tree tree))
|
||||
(define (scope file)
|
||||
(string-append dir "/" file))
|
||||
|
||||
(match tree
|
||||
(('directory name (body ...))
|
||||
(for-each (cute loop (scope name) <>) body)
|
||||
(rmdir (scope name)))
|
||||
(('directory name (? integer? mode) (body ...))
|
||||
(chmod (scope name) #o755) ; make sure it can be entered
|
||||
(for-each (cute loop (scope name) <>) body)
|
||||
(rmdir (scope name)))
|
||||
((from '-> _)
|
||||
(delete-file (scope from)))
|
||||
((file _ ...)
|
||||
(delete-file (scope file))))))
|
||||
|
||||
(define-syntax-rule (with-file-tree dir tree body ...)
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
(make-file-tree dir tree))
|
||||
(lambda ()
|
||||
body ...)
|
||||
(lambda ()
|
||||
(delete-file-tree dir tree))))
|
||||
|
||||
(with-test-prefix "file-system-fold"
|
||||
|
||||
(pass-if "test-suite"
|
||||
|
|
@ -98,10 +157,11 @@
|
|||
(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))))
|
||||
(skip (lambda (n s r) (cons `(skip ,n) r)))
|
||||
(error (lambda (n s e r) (cons `(error ,n) r))))
|
||||
(define seq
|
||||
(reverse
|
||||
(file-system-fold enter? leaf down up skip '() %test-dir)))
|
||||
(file-system-fold enter? leaf down up skip error '() %test-dir)))
|
||||
|
||||
(match seq
|
||||
((('down (? (cut string=? <> %test-dir)))
|
||||
|
|
@ -123,8 +183,9 @@
|
|||
(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))))
|
||||
(equal? (file-system-fold enter? leaf down up skip '() %test-dir)
|
||||
(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)))))
|
||||
|
||||
(pass-if "test-suite/lib.scm (flat file)"
|
||||
|
|
@ -133,9 +194,67 @@
|
|||
(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-dir "/lib.scm")))
|
||||
(equal? (file-system-fold enter? leaf down up skip '() name)
|
||||
`((leaf ,name))))))
|
||||
(equal? (file-system-fold enter? leaf down up skip error '() name)
|
||||
`((leaf ,name)))))
|
||||
|
||||
(pass-if "ENOENT"
|
||||
(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 ,e) r)))
|
||||
(name "/.does-not-exist."))
|
||||
(equal? (file-system-fold enter? leaf down up skip error '() name)
|
||||
`((error ,name ,ENOENT)))))
|
||||
|
||||
(pass-if "EACCES"
|
||||
(with-file-tree %top-builddir '(directory "test-EACCES" #o000
|
||||
(("a") ("b")))
|
||||
(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 ,e) r)))
|
||||
(name (string-append %top-builddir "/test-EACCES")))
|
||||
(equal? (file-system-fold enter? leaf down up skip error '() name)
|
||||
`((error ,name ,EACCES))))))
|
||||
|
||||
(pass-if "dangling symlink and lstat"
|
||||
(with-file-tree %top-builddir '(directory "test-dangling"
|
||||
(("dangling" -> "xxx")))
|
||||
(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 ,e) r)))
|
||||
(name (string-append %top-builddir "/test-dangling")))
|
||||
(equal? (file-system-fold enter? leaf down up skip error '()
|
||||
name)
|
||||
`((up ,name)
|
||||
(leaf ,(string-append name "/dangling"))
|
||||
(down ,name))))))
|
||||
|
||||
(pass-if "dangling symlink and stat"
|
||||
;; Same as above, but using `stat' instead of `lstat'.
|
||||
(with-file-tree %top-builddir '(directory "test-dangling"
|
||||
(("dangling" -> "xxx")))
|
||||
(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 ,e) r)))
|
||||
(name (string-append %top-builddir "/test-dangling")))
|
||||
(equal? (file-system-fold enter? leaf down up skip error '()
|
||||
name stat)
|
||||
`((up ,name)
|
||||
(error ,(string-append name "/dangling") ,ENOENT)
|
||||
(down ,name)))))))
|
||||
|
||||
(with-test-prefix "file-system-tree"
|
||||
|
||||
|
|
@ -165,7 +284,10 @@
|
|||
(lset-intersection string=? files expected)
|
||||
expected)))
|
||||
(_ #f))
|
||||
children)))))
|
||||
children))))
|
||||
|
||||
(pass-if "ENOENT"
|
||||
(not (file-system-tree "/.does-not-exist."))))
|
||||
|
||||
(with-test-prefix "scandir"
|
||||
|
||||
|
|
@ -188,4 +310,11 @@
|
|||
#t))))
|
||||
|
||||
(pass-if "flat file"
|
||||
(not (scandir (string-append %test-dir "/Makefile.am")))))
|
||||
(not (scandir (string-append %test-dir "/Makefile.am"))))
|
||||
|
||||
(pass-if "EACCES"
|
||||
(not (scandir "/.does-not-exist."))))
|
||||
|
||||
;;; Local Variables:
|
||||
;;; eval: (put 'with-file-tree 'scheme-indent-function 2)
|
||||
;;; End:
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;;; i18n.test --- Exercise the i18n API. -*- coding: utf-8; mode: scheme; -*-
|
||||
;;;;
|
||||
;;;; Copyright (C) 2006, 2007, 2009, 2010, 2011 Free Software Foundation, Inc.
|
||||
;;;; Copyright (C) 2006, 2007, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
|
||||
;;;; Ludovic Courtès
|
||||
;;;;
|
||||
;;;; This library is free software; you can redistribute it and/or
|
||||
|
|
@ -138,7 +138,11 @@
|
|||
(under-locale-or-unresolved %french-utf8-locale thunk))
|
||||
|
||||
(define (under-turkish-utf8-locale-or-unresolved thunk)
|
||||
(under-locale-or-unresolved %turkish-utf8-locale thunk))
|
||||
;; FreeBSD 8.2 has a broken tr_TR locale where `i' is mapped to
|
||||
;; uppercase `I' instead of `İ', so disable tests on that platform.
|
||||
(if (string-contains %host-type "freebsd8")
|
||||
(throw 'unresolved)
|
||||
(under-locale-or-unresolved %turkish-utf8-locale thunk)))
|
||||
|
||||
(define (under-german-utf8-locale-or-unresolved thunk)
|
||||
(under-locale-or-unresolved %german-utf8-locale thunk))
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
;;;; load.test --- test LOAD and path searching functions -*- scheme -*-
|
||||
;;;; Jim Blandy <jimb@red-bean.com> --- September 1999
|
||||
;;;;
|
||||
;;;; Copyright (C) 1999, 2001, 2006, 2010 Free Software Foundation, Inc.
|
||||
;;;; Copyright (C) 1999, 2001, 2006, 2010, 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
|
||||
|
|
@ -18,8 +18,9 @@
|
|||
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
||||
|
||||
(define-module (test-suite test-load)
|
||||
:use-module (test-suite lib)
|
||||
:use-module (test-suite guile-test))
|
||||
#:use-module (test-suite lib)
|
||||
#:use-module (test-suite guile-test)
|
||||
#:use-module (system base compile))
|
||||
|
||||
(define temp-dir (data-file-name "load-test.dir"))
|
||||
|
||||
|
|
@ -124,4 +125,17 @@
|
|||
(try-search-with-extensions path "ugly.scm" extensions "dir3/ugly.scm")
|
||||
(try-search-with-extensions path "ugly.ss" extensions #f))
|
||||
|
||||
(with-test-prefix "return value of `load'"
|
||||
(let ((temp-file (in-vicinity temp-dir "foo.scm")))
|
||||
(call-with-output-file temp-file
|
||||
(lambda (port)
|
||||
(write '(+ 2 3) port)
|
||||
(newline port)))
|
||||
(pass-if "primitive-load"
|
||||
(equal? 5 (primitive-load temp-file)))
|
||||
(let ((temp-compiled-file (in-vicinity temp-dir "foo.go")))
|
||||
(compile-file temp-file #:output-file temp-compiled-file)
|
||||
(pass-if "load-compiled"
|
||||
(equal? 5 (load-compiled temp-compiled-file))))))
|
||||
|
||||
(delete-tree temp-dir)
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
;;;; procprop.test --- Procedure properties -*- mode: scheme; coding: utf-8; -*-
|
||||
;;;; Ludovic Courtès <ludo@gnu.org>
|
||||
;;;;
|
||||
;;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
|
||||
;;;; Copyright (C) 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
|
||||
|
|
@ -72,4 +72,10 @@
|
|||
(pass-if "opt, eval"
|
||||
(equal? (procedure-minimum-arity (eval '(lambda* (a b #:optional c) #t)
|
||||
(current-module)))
|
||||
'(2 1 #f))))
|
||||
'(2 1 #f)))
|
||||
|
||||
(if (include-deprecated-features)
|
||||
(pass-if-exception "set-procedure-properties! arity"
|
||||
'(misc-error . "arity is a read-only property")
|
||||
(set-procedure-properties! (lambda x x) '((arity . 3))))
|
||||
#t))
|
||||
|
|
|
|||
|
|
@ -35,7 +35,7 @@
|
|||
;;;; Author: Aubrey Jaffer
|
||||
;;;; Modified: Mikael Djurfeldt
|
||||
;;;; Removed tests which Guile deliberately
|
||||
;;;; won't pass. Made the the tests (test-cont), (test-sc4), and
|
||||
;;;; won't pass. Made the tests (test-cont), (test-sc4), and
|
||||
;;;; (test-delay) start to run automatically.
|
||||
;;;; Modified: Jim Blandy
|
||||
;;;; adapted to new Guile test suite framework
|
||||
|
|
|
|||
|
|
@ -147,6 +147,14 @@
|
|||
|
||||
(define char-code-limit 256)
|
||||
|
||||
;; Since `regexp-quote' uses string ports, and since it is used below
|
||||
;; with non-ASCII characters, these ports must be Unicode-capable.
|
||||
(define-syntax with-unicode
|
||||
(syntax-rules ()
|
||||
((_ exp)
|
||||
(with-fluids ((%default-port-encoding "UTF-8"))
|
||||
exp))))
|
||||
|
||||
(with-test-prefix "regexp-quote"
|
||||
|
||||
(pass-if-exception "no args" exception:wrong-num-args
|
||||
|
|
@ -175,7 +183,7 @@
|
|||
(s (string c)))
|
||||
(pass-if (list "char" i (format #f "~s ~s" c s))
|
||||
(with-ascii-or-latin1-locale i
|
||||
(let* ((q (regexp-quote s))
|
||||
(let* ((q (with-unicode (regexp-quote s)))
|
||||
(m (regexp-exec (make-regexp q flag) s)))
|
||||
(and (= 0 (match:start m))
|
||||
(= 1 (match:end m))))))))
|
||||
|
|
@ -187,7 +195,7 @@
|
|||
((>= i char-code-limit))
|
||||
(let* ((c (integer->char i))
|
||||
(s (string #\a c))
|
||||
(q (regexp-quote s)))
|
||||
(q (with-unicode (regexp-quote s))))
|
||||
(pass-if (list "string \"aX\"" i (format #f "~s ~s ~s" c s q))
|
||||
(with-ascii-or-latin1-locale i
|
||||
(let* ((m (regexp-exec (make-regexp q flag) s)))
|
||||
|
|
@ -196,7 +204,8 @@
|
|||
|
||||
(pass-if "string of all chars"
|
||||
(with-latin1-locale
|
||||
(let ((m (regexp-exec (make-regexp (regexp-quote allchars)
|
||||
(let ((m (regexp-exec (make-regexp (with-unicode
|
||||
(regexp-quote allchars))
|
||||
flag) allchars)))
|
||||
(and (= 0 (match:start m))
|
||||
(= (string-length allchars) (match:end m)))))))))
|
||||
|
|
|
|||
|
|
@ -36,7 +36,7 @@
|
|||
; Test engine
|
||||
; ===========
|
||||
;
|
||||
; We use an extended version of the the checker of SRFI-42 (with
|
||||
; We use an extended version of the checker of SRFI-42 (with
|
||||
; Felix' reduction on codesize) for running a batch of tests for
|
||||
; the various procedures of 'compare.scm'. Moreover, we use the
|
||||
; comprehensions of SRFI-42 to generate examples systematically.
|
||||
|
|
|
|||
|
|
@ -75,7 +75,7 @@
|
|||
|
||||
(let ((drift-fraction (/ max-diff average)))
|
||||
(or (< drift-fraction max-allowed-drift)
|
||||
;; don't stop the the test suite for what statistically is
|
||||
;; don't stop the test suite for what statistically is
|
||||
;; bound to happen.
|
||||
(throw 'unresolved (pk average drift-fraction))))))))
|
||||
|
||||
|
|
|
|||
|
|
@ -81,6 +81,8 @@
|
|||
|
||||
(define exception:too-many-args
|
||||
"too many arguments")
|
||||
(define exception:zero-expression-sequence
|
||||
"sequence of zero expressions")
|
||||
|
||||
|
||||
;; (put 'pass-if-syntax-error 'scheme-indent-function 1)
|
||||
|
|
@ -148,12 +150,12 @@
|
|||
|
||||
(with-test-prefix "begin"
|
||||
|
||||
(pass-if "legal (begin)"
|
||||
(pass-if "valid (begin)"
|
||||
(eval '(begin (begin) #t) (interaction-environment)))
|
||||
|
||||
(if (not (include-deprecated-features))
|
||||
(pass-if-syntax-error "illegal (begin)"
|
||||
exception:generic-syncase-error
|
||||
(pass-if-syntax-error "invalid (begin)"
|
||||
exception:zero-expression-sequence
|
||||
(eval '(begin (if #t (begin)) #t) (interaction-environment)))))
|
||||
|
||||
(define-syntax matches?
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue