summaryrefslogtreecommitdiff
path: root/test-suite/tests
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2012-01-10 00:41:42 +0100
committerAndy Wingo <wingo@pobox.com>2012-01-10 00:41:42 +0100
commit91ee7515da0bad91330ce5c87b250d6cf12a2789 (patch)
treece023c92c0d9bf895c1265b107b270c35ba59b94 /test-suite/tests
parent0bdd43515eb3c62839512181cf33e5aea383e661 (diff)
parent0e947e1d14597651c5762a4209225c472bdaef45 (diff)
downloadguile-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.test147
-rw-r--r--test-suite/tests/i18n.test8
-rw-r--r--test-suite/tests/load.test20
-rw-r--r--test-suite/tests/procprop.test10
-rw-r--r--test-suite/tests/r4rs.test2
-rw-r--r--test-suite/tests/regexp.test15
-rw-r--r--test-suite/tests/srfi-67.test2
-rw-r--r--test-suite/tests/statprof.test2
-rw-r--r--test-suite/tests/syntax.test8
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?