diff options
author | Andy Wingo <wingo@pobox.com> | 2012-01-10 00:41:42 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2012-01-10 00:41:42 +0100 |
commit | 91ee7515da0bad91330ce5c87b250d6cf12a2789 (patch) | |
tree | ce023c92c0d9bf895c1265b107b270c35ba59b94 /test-suite/tests | |
parent | 0bdd43515eb3c62839512181cf33e5aea383e661 (diff) | |
parent | 0e947e1d14597651c5762a4209225c472bdaef45 (diff) | |
download | guile-91ee7515da0bad91330ce5c87b250d6cf12a2789.tar.gz |
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
Diffstat (limited to 'test-suite/tests')
-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 |
9 files changed, 189 insertions, 25 deletions
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? |