diff options
Diffstat (limited to 'test-suite')
-rw-r--r-- | test-suite/lib.scm | 2 | ||||
-rw-r--r-- | test-suite/standalone/test-num2integral.c | 6 | ||||
-rw-r--r-- | test-suite/standalone/test-pthread-create-secondary.c | 2 | ||||
-rw-r--r-- | test-suite/standalone/test-scm-spawn-thread.c | 2 | ||||
-rw-r--r-- | test-suite/tests/ftw.test | 147 | ||||
-rw-r--r-- | test-suite/tests/i18n.test | 8 | ||||
-rw-r--r-- | test-suite/tests/load.test | 20 | ||||
-rw-r--r-- | test-suite/tests/procprop.test | 10 | ||||
-rw-r--r-- | test-suite/tests/r4rs.test | 2 | ||||
-rw-r--r-- | test-suite/tests/regexp.test | 15 | ||||
-rw-r--r-- | test-suite/tests/srfi-67.test | 2 | ||||
-rw-r--r-- | test-suite/tests/statprof.test | 2 | ||||
-rw-r--r-- | test-suite/tests/syntax.test | 8 |
13 files changed, 195 insertions, 31 deletions
diff --git a/test-suite/lib.scm b/test-suite/lib.scm index ecf39245a..9a03dc915 100644 --- a/test-suite/lib.scm +++ b/test-suite/lib.scm @@ -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 diff --git a/test-suite/standalone/test-num2integral.c b/test-suite/standalone/test-num2integral.c index d210a1982..c8dc3a7e4 100644 --- a/test-suite/standalone/test-num2integral.c +++ b/test-suite/standalone/test-num2integral.c @@ -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; } diff --git a/test-suite/standalone/test-pthread-create-secondary.c b/test-suite/standalone/test-pthread-create-secondary.c index fe39c2a26..e145fa5bc 100644 --- a/test-suite/standalone/test-pthread-create-secondary.c +++ b/test-suite/standalone/test-pthread-create-secondary.c @@ -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 diff --git a/test-suite/standalone/test-scm-spawn-thread.c b/test-suite/standalone/test-scm-spawn-thread.c index aa790cdbb..f6d561aa1 100644 --- a/test-suite/standalone/test-scm-spawn-thread.c +++ b/test-suite/standalone/test-scm-spawn-thread.c @@ -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 diff --git a/test-suite/tests/ftw.test b/test-suite/tests/ftw.test index fa179d400..be983a16a 100644 --- a/test-suite/tests/ftw.test +++ b/test-suite/tests/ftw.test @@ -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: diff --git a/test-suite/tests/i18n.test b/test-suite/tests/i18n.test index a5e418f67..05670516d 100644 --- a/test-suite/tests/i18n.test +++ b/test-suite/tests/i18n.test @@ -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)) diff --git a/test-suite/tests/load.test b/test-suite/tests/load.test index 50e5fa73f..1cf8d65e8 100644 --- a/test-suite/tests/load.test +++ b/test-suite/tests/load.test @@ -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) diff --git a/test-suite/tests/procprop.test b/test-suite/tests/procprop.test index 25dd4c293..ceb6e562b 100644 --- a/test-suite/tests/procprop.test +++ b/test-suite/tests/procprop.test @@ -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)) diff --git a/test-suite/tests/r4rs.test b/test-suite/tests/r4rs.test index e26fdada3..1e4243cae 100644 --- a/test-suite/tests/r4rs.test +++ b/test-suite/tests/r4rs.test @@ -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 diff --git a/test-suite/tests/regexp.test b/test-suite/tests/regexp.test index 832542edc..c2b65a64c 100644 --- a/test-suite/tests/regexp.test +++ b/test-suite/tests/regexp.test @@ -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))))))))) diff --git a/test-suite/tests/srfi-67.test b/test-suite/tests/srfi-67.test index e5a4471ee..312282e92 100644 --- a/test-suite/tests/srfi-67.test +++ b/test-suite/tests/srfi-67.test @@ -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. diff --git a/test-suite/tests/statprof.test b/test-suite/tests/statprof.test index 7ce39badb..b2ee41e1b 100644 --- a/test-suite/tests/statprof.test +++ b/test-suite/tests/statprof.test @@ -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)))))))) diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index ccc8d9804..5163bac00 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -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? |