summaryrefslogtreecommitdiff
path: root/test-suite/tests
diff options
context:
space:
mode:
Diffstat (limited to 'test-suite/tests')
-rw-r--r--test-suite/tests/coding.test104
-rw-r--r--test-suite/tests/continuations.test13
-rw-r--r--test-suite/tests/control.test123
-rw-r--r--test-suite/tests/eval-string.test54
-rw-r--r--test-suite/tests/foreign.test54
-rw-r--r--test-suite/tests/goops.test11
-rw-r--r--test-suite/tests/i18n.test89
-rw-r--r--test-suite/tests/modules.test45
-rw-r--r--test-suite/tests/numbers.test53
-rw-r--r--test-suite/tests/r6rs-base.test24
-rw-r--r--test-suite/tests/r6rs-ports.test59
-rw-r--r--test-suite/tests/reader.test26
-rw-r--r--test-suite/tests/srfi-4.test83
-rw-r--r--test-suite/tests/srfi-9.test19
-rw-r--r--test-suite/tests/strings.test28
-rw-r--r--test-suite/tests/symbols.test7
-rw-r--r--test-suite/tests/syncase.test21
-rw-r--r--test-suite/tests/tree-il.test13
-rw-r--r--test-suite/tests/vlist.test14
19 files changed, 801 insertions, 39 deletions
diff --git a/test-suite/tests/coding.test b/test-suite/tests/coding.test
new file mode 100644
index 000000000..4152af86a
--- /dev/null
+++ b/test-suite/tests/coding.test
@@ -0,0 +1,104 @@
+;;;; coding.test --- test suite for coding declarations. -*- mode: scheme -*-
+;;;;
+;;;; Copyright (C) 2011 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 as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (test-coding)
+ #:use-module (test-suite lib))
+
+(define (with-temp-file proc)
+ (let* ((name (string-copy "/tmp/coding-test.XXXXXX"))
+ (port (mkstemp! name)))
+ (let ((res (with-throw-handler
+ #t
+ (lambda ()
+ (proc name port))
+ (lambda _
+ (delete-file name)))))
+ (delete-file name)
+ res)))
+
+(define (scan-coding str)
+ (with-temp-file
+ (lambda (name port)
+ (display str port)
+ (close port)
+ ;; We don't simply seek back and rescan, because the encoding scan
+ ;; relies on the opportunistic filling of the input buffer, which
+ ;; doesn't happen after a seek.
+ (let* ((port (open-input-file name))
+ (res (port-encoding port)))
+ (close-port port)
+ res))))
+
+(with-test-prefix "block comments"
+
+ (pass-if "first line"
+ (equal? (scan-coding "#! coding: iso-8859-1 !#")
+ "ISO-8859-1"))
+
+ (pass-if "first line no whitespace"
+ (equal? (scan-coding "#!coding:iso-8859-1!#")
+ "ISO-8859-1"))
+
+ (pass-if "second line"
+ (equal? (scan-coding "#! \n coding: iso-8859-1 !#")
+ "ISO-8859-1"))
+
+ (pass-if "second line no whitespace"
+ (equal? (scan-coding "#!\ncoding:iso-8859-1!#")
+ "ISO-8859-1"))
+
+ (pass-if "third line"
+ (equal? (scan-coding "#! \n coding: iso-8859-1 \n !#")
+ "ISO-8859-1"))
+
+ (pass-if "third line no whitespace"
+ (equal? (scan-coding "#!\ncoding:iso-8859-1\n!#")
+ "ISO-8859-1")))
+
+(with-test-prefix "line comments"
+ (pass-if "first line, no whitespace, no nl"
+ (equal? (scan-coding ";coding:iso-8859-1")
+ "ISO-8859-1"))
+
+ (pass-if "first line, whitespace, no nl"
+ (equal? (scan-coding "; coding: iso-8859-1 ")
+ "ISO-8859-1"))
+
+ (pass-if "first line, no whitespace, nl"
+ (equal? (scan-coding ";coding:iso-8859-1\n")
+ "ISO-8859-1"))
+
+ (pass-if "first line, whitespace, nl"
+ (equal? (scan-coding "; coding: iso-8859-1 \n")
+ "ISO-8859-1"))
+
+ (pass-if "second line, no whitespace, no nl"
+ (equal? (scan-coding "\n;coding:iso-8859-1")
+ "ISO-8859-1"))
+
+ (pass-if "second line, whitespace, no nl"
+ (equal? (scan-coding "\n; coding: iso-8859-1 ")
+ "ISO-8859-1"))
+
+ (pass-if "second line, no whitespace, nl"
+ (equal? (scan-coding "\n;coding:iso-8859-1\n")
+ "ISO-8859-1"))
+
+ (pass-if "second line, whitespace, nl"
+ (equal? (scan-coding "\n; coding: iso-8859-1 \n")
+ "ISO-8859-1")))
diff --git a/test-suite/tests/continuations.test b/test-suite/tests/continuations.test
index f6db40e58..a436b90d4 100644
--- a/test-suite/tests/continuations.test
+++ b/test-suite/tests/continuations.test
@@ -1,7 +1,7 @@
;;;; -*- scheme -*-
;;;; continuations.test --- test suite for continutations
;;;;
-;;;; Copyright (C) 2003, 2006, 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2003, 2006, 2009, 2011 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
@@ -80,6 +80,17 @@
(error "Catch me if you can!")))))))))
handled))
+ (pass-if "exit unwinds dynwinds inside a continuation barrier"
+ (let ((s (with-error-to-string
+ (lambda ()
+ (with-continuation-barrier
+ (lambda ()
+ (dynamic-wind
+ (lambda () #f)
+ (lambda () (exit 1))
+ (lambda () (throw 'abcde)))))))))
+ (and (string-contains s "abcde") #t)))
+
(with-debugging-evaluator
(pass-if "make a stack from a continuation"
diff --git a/test-suite/tests/control.test b/test-suite/tests/control.test
index 682c69f1e..6f1804a3f 100644
--- a/test-suite/tests/control.test
+++ b/test-suite/tests/control.test
@@ -1,7 +1,7 @@
;;;; -*- scheme -*-
;;;; control.test --- test suite for delimited continuations
;;;;
-;;;; Copyright (C) 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2011 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
@@ -27,7 +27,7 @@
;; For these, the compiler should be able to prove that "k" is not referenced,
;; so it avoids reifying the continuation. Since that's a slightly different
;; codepath, we test them both.
-(with-test-prefix "escape-only continuations"
+(with-test-prefix/c&e "escape-only continuations"
(pass-if "no values, normal exit"
(equal? '()
(call-with-values
@@ -80,7 +80,7 @@
args)))))
;;; And the case in which the compiler has to reify the continuation.
-(with-test-prefix "reified continuations"
+(with-test-prefix/c&e "reified continuations"
(pass-if "no values, normal exit"
(equal? '()
(call-with-values
@@ -133,10 +133,20 @@
(abort 'foo 'bar 'baz)
(error "unexpected exit"))
(lambda args
- args))))))
+ args)))))
+
+ (pass-if "reified pending call frames, instantiated elsewhere on the stack"
+ (equal? 'foo
+ ((call-with-prompt
+ 'p0
+ (lambda ()
+ (identity ((abort-to-prompt 'p0) 'foo)))
+ (lambda (c) c))
+ (lambda (x) x)))))
+
;; The variants check different cases in the compiler.
-(with-test-prefix "restarting partial continuations"
+(with-test-prefix/c&e "restarting partial continuations"
(pass-if "in side-effect position"
(let ((k (% (begin (abort) 'foo)
(lambda (k) k))))
@@ -168,9 +178,106 @@
(eq? (k 'xyzzy)
'xyzzy))))
+;; Here we test different cases for the `prompt'.
+(with-test-prefix/c&e "prompt in different contexts"
+ (pass-if "push, normal exit"
+ (car (call-with-prompt
+ 'foo
+ (lambda () '(#t))
+ (lambda (k) '(#f)))))
+
+ (pass-if "push, nonlocal exit"
+ (car (call-with-prompt
+ 'foo
+ (lambda () (abort-to-prompt 'foo) '(#f))
+ (lambda (k) '(#t)))))
+
+ (pass-if "push with RA, normal exit"
+ (car (letrec ((test (lambda ()
+ (call-with-prompt
+ 'foo
+ (lambda () '(#t))
+ (lambda (k) '(#f))))))
+ (test))))
+
+ (pass-if "push with RA, nonlocal exit"
+ (car (letrec ((test (lambda ()
+ (call-with-prompt
+ 'foo
+ (lambda () (abort-to-prompt 'foo) '(#f))
+ (lambda (k) '(#t))))))
+ (test))))
+
+ (pass-if "tail, normal exit"
+ (call-with-prompt
+ 'foo
+ (lambda () #t)
+ (lambda (k) #f)))
+
+ (pass-if "tail, nonlocal exit"
+ (call-with-prompt
+ 'foo
+ (lambda () (abort-to-prompt 'foo) #f)
+ (lambda (k) #t)))
+
+ (pass-if "tail with RA, normal exit"
+ (letrec ((test (lambda ()
+ (call-with-prompt
+ 'foo
+ (lambda () #t)
+ (lambda (k) #f)))))
+ (test)))
+
+ (pass-if "tail with RA, nonlocal exit"
+ (letrec ((test (lambda ()
+ (call-with-prompt
+ 'foo
+ (lambda () (abort-to-prompt 'foo) #f)
+ (lambda (k) #t)))))
+ (test)))
+
+ (pass-if "drop, normal exit"
+ (begin
+ (call-with-prompt
+ 'foo
+ (lambda () #f)
+ (lambda (k) #f))
+ #t))
+
+ (pass-if "drop, nonlocal exit"
+ (begin
+ (call-with-prompt
+ 'foo
+ (lambda () (abort-to-prompt 'foo))
+ (lambda (k) #f))
+ #t))
+
+ (pass-if "drop with RA, normal exit"
+ (begin
+ (letrec ((test (lambda ()
+ (call-with-prompt
+ 'foo
+ (lambda () #f)
+ (lambda (k) #f)))))
+ (test))
+ #t))
+
+ (pass-if "drop with RA, nonlocal exit"
+ (begin
+ (letrec ((test (lambda ()
+ (call-with-prompt
+ 'foo
+ (lambda () (abort-to-prompt 'foo) #f)
+ (lambda (k) #f)))))
+ (test))
+ #t)))
+
+
(define fl (make-fluid))
(fluid-set! fl 0)
+;; Not c&e as it assumes this block executes once.
+;;
(with-test-prefix "suspend/resume with fluids"
(pass-if "normal"
(zero? (% (fluid-ref fl)
@@ -212,7 +319,7 @@
(pass-if "post"
(equal? (fluid-ref fl) 0))))
-(with-test-prefix "rewinding prompts"
+(with-test-prefix/c&e "rewinding prompts"
(pass-if "nested prompts"
(let ((k (% 'a
(% 'b
@@ -223,11 +330,11 @@
(lambda (k) k))))
(k))))
-(with-test-prefix "abort to unknown prompt"
+(with-test-prefix/c&e "abort to unknown prompt"
(pass-if-exception "foo" '(misc-error . "^Abort to unknown prompt")
(abort-to-prompt 'does-not-exist)))
-(with-test-prefix "the-vm"
+(with-test-prefix/c&e "the-vm"
(pass-if "unwind changes VMs"
(let ((new-vm (make-vm))
diff --git a/test-suite/tests/eval-string.test b/test-suite/tests/eval-string.test
new file mode 100644
index 000000000..8cef244bf
--- /dev/null
+++ b/test-suite/tests/eval-string.test
@@ -0,0 +1,54 @@
+;;;; eval-string.test --- tests for (ice-9 eval-string) -*- scheme -*-
+;;;; Copyright (C) 2011 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 as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (test-suite test-eval-string)
+ #:use-module (test-suite lib)
+ #:use-module (ice-9 eval-string))
+
+
+(with-test-prefix "basic"
+ (pass-if "eval none"
+ (equal? (eval-string "") *unspecified*))
+
+ (pass-if "eval single"
+ (equal? (eval-string "'foo") 'foo))
+
+ (pass-if "eval multiple"
+ (equal? (eval-string "'foo 'bar") 'bar))
+
+ (pass-if "compile none"
+ (equal? (eval-string "" #:compile? #t) *unspecified*))
+
+ (pass-if "compile single"
+ (equal? (eval-string "'foo" #:compile? #t)
+ 'foo))
+
+ (pass-if "compile multiple"
+ (equal? (eval-string "'foo 'bar" #:compile? #t)
+ 'bar))
+
+ (pass-if "eval values"
+ (equal? (call-with-values (lambda ()
+ (eval-string "(values 1 2)"))
+ list)
+ '(1 2)))
+
+ (pass-if "compile values"
+ (equal? (call-with-values (lambda ()
+ (eval-string "(values 1 2)" #:compile? #t))
+ list)
+ '(1 2)))) \ No newline at end of file
diff --git a/test-suite/tests/foreign.test b/test-suite/tests/foreign.test
index 3569c8a52..60b466e1c 100644
--- a/test-suite/tests/foreign.test
+++ b/test-suite/tests/foreign.test
@@ -28,6 +28,14 @@
#:use-module (test-suite lib))
+(with-test-prefix "dynamic-pointer"
+
+ (pass-if-exception
+ "error message"
+ '(misc-error . "^Symbol not found")
+ (dynamic-func "does_not_exist___" (dynamic-link))))
+
+
(with-test-prefix "null pointer"
(pass-if "pointer?"
@@ -67,6 +75,17 @@
(not (equal? (make-pointer 123) (make-pointer 456)))))
+(with-test-prefix "pointer<->scm"
+
+ (pass-if "immediates"
+ (equal? (pointer->scm (scm->pointer #\newline))
+ #\newline))
+
+ (pass-if "non-immediates"
+ (equal? (pointer->scm (scm->pointer "Hello, world!"))
+ "Hello, world!")))
+
+
(define-wrapped-pointer-type foo
foo?
wrap-foo unwrap-foo
@@ -134,7 +153,18 @@
(pass-if "bijection [latin1]"
(with-latin1-locale
(let ((s "Szép jó napot!"))
- (string=? s (pointer->string (string->pointer s)))))))
+ (string=? s (pointer->string (string->pointer s))))))
+
+ (pass-if "bijection, utf-8"
+ (let ((s "hello, world"))
+ (string=? s (pointer->string (string->pointer s "utf-8")
+ -1 "utf-8"))))
+
+ (pass-if "bijection, utf-8 [latin1]"
+ (let ((s "Szép jó napot!"))
+ (string=? s (pointer->string (string->pointer s "utf-8")
+ -1 "utf-8")))))
+
(with-test-prefix "pointer->procedure"
@@ -214,6 +244,16 @@
(arg3 (map (cut / <> 4.0) (iota 123 100 4))))
(equal? (map proc arg1 arg2 arg3)
(map proc* arg1 arg2 arg3)))
+ (throw 'unresolved)))
+
+ (pass-if "procedures returning void"
+ (if (defined? 'procedure->pointer)
+ (let* ((called? #f)
+ (proc (lambda () (set! called? #t)))
+ (pointer (procedure->pointer void proc '()))
+ (proc* (pointer->procedure void pointer '())))
+ (proc*)
+ called?)
(throw 'unresolved))))
@@ -228,6 +268,11 @@
(>= (sizeof layout)
(reduce + 0.0 (map sizeof layout)))))
+ (pass-if "alignof { int8, double, int8 }"
+ ;; alignment of the most strictly aligned component
+ (let ((layout (list int8 double int8)))
+ (= (alignof layout) (alignof double))))
+
(pass-if "parse-c-struct"
(let ((layout (list int64 uint8))
(data (list -300 43)))
@@ -268,4 +313,11 @@
(data (list 77 %null-pointer -42 3.14)))
(equal? (parse-c-struct (make-c-struct layout data)
layout)
+ data)))
+
+ (pass-if "int8, { int8, double, int8 }, int16"
+ (let ((layout (list int8 (list int8 double int8) int16))
+ (data (list 77 (list 42 4.2 55) 88)))
+ (equal? (parse-c-struct (make-c-struct layout data)
+ layout)
data))))
diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test
index 908d1e7ae..2bf7d698b 100644
--- a/test-suite/tests/goops.test
+++ b/test-suite/tests/goops.test
@@ -1,6 +1,6 @@
;;;; goops.test --- test suite for GOOPS -*- scheme -*-
;;;;
-;;;; Copyright (C) 2001,2003,2004, 2006, 2008, 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001,2003,2004, 2006, 2008, 2009, 2011 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
@@ -234,7 +234,11 @@
(eval '(define-generic foo) (current-module))
(eval '(and (is-a? foo <generic>)
(null? (generic-function-methods foo)))
- (current-module)))))
+ (current-module)))
+
+ (pass-if-exception "getters do not have setters"
+ exception:wrong-type-arg
+ (eval '(setter foo) (current-module)))))
(with-test-prefix "defining methods"
@@ -294,6 +298,9 @@
(null? (generic-function-methods foo-1)))
(current-module)))
+ (pass-if "accessors have setters"
+ (procedure? (eval '(setter foo-1) (current-module))))
+
(pass-if "overwriting a top-level binding to a non-accessor"
(eval '(define (foo) #f) (current-module))
(eval '(define-accessor foo) (current-module))
diff --git a/test-suite/tests/i18n.test b/test-suite/tests/i18n.test
index 708075e15..a5e418f67 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 Free Software Foundation, Inc.
+;;;; Copyright (C) 2006, 2007, 2009, 2010, 2011 Free Software Foundation, Inc.
;;;; Ludovic Courtès
;;;;
;;;; This library is free software; you can redistribute it and/or
@@ -88,6 +88,12 @@
(define %turkish-utf8-locale-name
"tr_TR.UTF-8")
+(define %german-utf8-locale-name
+ "de_DE.UTF-8")
+
+(define %greek-utf8-locale-name
+ "el_GR.UTF-8")
+
(define %french-locale
(false-if-exception
(make-locale (list LC_CTYPE LC_COLLATE LC_NUMERIC LC_TIME)
@@ -98,6 +104,16 @@
(make-locale (list LC_CTYPE LC_COLLATE LC_NUMERIC LC_TIME)
%french-utf8-locale-name)))
+(define %german-utf8-locale
+ (false-if-exception
+ (make-locale LC_ALL
+ %german-utf8-locale-name)))
+
+(define %greek-utf8-locale
+ (false-if-exception
+ (make-locale LC_ALL
+ %greek-utf8-locale-name)))
+
(define %turkish-utf8-locale
(false-if-exception
(make-locale LC_ALL
@@ -124,6 +140,12 @@
(define (under-turkish-utf8-locale-or-unresolved thunk)
(under-locale-or-unresolved %turkish-utf8-locale thunk))
+(define (under-german-utf8-locale-or-unresolved thunk)
+ (under-locale-or-unresolved %german-utf8-locale thunk))
+
+(define (under-greek-utf8-locale-or-unresolved thunk)
+ (under-locale-or-unresolved %greek-utf8-locale thunk))
+
(with-test-prefix "text collation (French)"
(pass-if "string-locale<?"
@@ -192,6 +214,24 @@
(char-locale-ci>? #\Œ #\e %french-utf8-locale))))))
+(with-test-prefix "text collation (German)"
+
+ (pass-if "string-locale-ci=?"
+ (under-german-utf8-locale-or-unresolved
+ (lambda ()
+ (let ((de (make-locale LC_ALL %german-utf8-locale-name)))
+ (string-locale-ci=? "Straße" "STRASSE"))))))
+
+
+(with-test-prefix "text collation (Greek)"
+
+ (pass-if "string-locale-ci=?"
+ (under-greek-utf8-locale-or-unresolved
+ (lambda ()
+ (let ((gr (make-locale LC_ALL %greek-utf8-locale-name)))
+ (string-locale-ci=? "ΧΑΟΣ" "χαος" gr))))))
+
+
(with-test-prefix "character mapping"
(pass-if "char-locale-downcase"
@@ -213,17 +253,11 @@
(pass-if "char-locale-upcase Turkish"
(under-turkish-utf8-locale-or-unresolved
(lambda ()
- ;; This test is disabled for now, because char-locale-upcase is
- ;; incomplete.
- (throw 'untested)
(eq? #\İ (char-locale-upcase #\i %turkish-utf8-locale)))))
(pass-if "char-locale-downcase Turkish"
(under-turkish-utf8-locale-or-unresolved
(lambda ()
- ;; This test is disabled for now, because char-locale-downcase
- ;; is incomplete.
- (throw 'untested)
(eq? #\i (char-locale-downcase #\İ %turkish-utf8-locale))))))
@@ -242,20 +276,49 @@
(string=? "Hello, World" (string-locale-titlecase
"hello, world" (make-locale LC_ALL "C")))))
+ (pass-if "string-locale-upcase German"
+ (under-german-utf8-locale-or-unresolved
+ (lambda ()
+ (let ((de (make-locale LC_ALL %german-utf8-locale-name)))
+ (string=? "STRASSE"
+ (string-locale-upcase "Straße" de))))))
+
+ (pass-if "string-locale-upcase Greek"
+ (under-greek-utf8-locale-or-unresolved
+ (lambda ()
+ (let ((el (make-locale LC_ALL %greek-utf8-locale-name)))
+ (string=? "ΧΑΟΣ"
+ (string-locale-upcase "χαος" el))))))
+
+ (pass-if "string-locale-upcase Greek (two sigmas)"
+ (under-greek-utf8-locale-or-unresolved
+ (lambda ()
+ (let ((el (make-locale LC_ALL %greek-utf8-locale-name)))
+ (string=? "ΓΕΙΆ ΣΑΣ"
+ (string-locale-upcase "Γειά σας" el))))))
+
+ (pass-if "string-locale-downcase Greek"
+ (under-greek-utf8-locale-or-unresolved
+ (lambda ()
+ (let ((el (make-locale LC_ALL %greek-utf8-locale-name)))
+ (string=? "χαος"
+ (string-locale-downcase "ΧΑΟΣ" el))))))
+
+ (pass-if "string-locale-downcase Greek (two sigmas)"
+ (under-greek-utf8-locale-or-unresolved
+ (lambda ()
+ (let ((el (make-locale LC_ALL %greek-utf8-locale-name)))
+ (string=? "γειά σας"
+ (string-locale-downcase "ΓΕΙΆ ΣΑΣ" el))))))
+
(pass-if "string-locale-upcase Turkish"
(under-turkish-utf8-locale-or-unresolved
(lambda ()
- ;; This test is disabled for now, because string-locale-upcase
- ;; is incomplete.
- (throw 'untested)
(string=? "İI" (string-locale-upcase "iı" %turkish-utf8-locale)))))
(pass-if "string-locale-downcase Turkish"
(under-turkish-utf8-locale-or-unresolved
(lambda ()
- ;; This test is disabled for now, because
- ;; string-locale-downcase is incomplete.
- (throw 'untested)
(string=? "iı" (string-locale-downcase "İI" %turkish-utf8-locale))))))
diff --git a/test-suite/tests/modules.test b/test-suite/tests/modules.test
index 29abd093a..5f34d9e70 100644
--- a/test-suite/tests/modules.test
+++ b/test-suite/tests/modules.test
@@ -146,6 +146,51 @@
;;;
+;;; module-use! / module-use-interfaces!
+;;;
+(with-test-prefix "module-use"
+ (let ((m (make-module)))
+ (pass-if "no uses initially"
+ (null? (module-uses m)))
+
+ (pass-if "using ice-9 q"
+ (begin
+ (module-use! m (resolve-interface '(ice-9 q)))
+ (equal? (module-uses m)
+ (list (resolve-interface '(ice-9 q))))))
+
+ (pass-if "using ice-9 q again"
+ (begin
+ (module-use! m (resolve-interface '(ice-9 q)))
+ (equal? (module-uses m)
+ (list (resolve-interface '(ice-9 q))))))
+
+ (pass-if "using ice-9 ftw"
+ (begin
+ (module-use-interfaces! m (list (resolve-interface '(ice-9 ftw))))
+ (equal? (module-uses m)
+ (list (resolve-interface '(ice-9 q))
+ (resolve-interface '(ice-9 ftw))))))
+
+ (pass-if "using ice-9 ftw again"
+ (begin
+ (module-use-interfaces! m (list (resolve-interface '(ice-9 ftw))))
+ (equal? (module-uses m)
+ (list (resolve-interface '(ice-9 q))
+ (resolve-interface '(ice-9 ftw))))))
+
+ (pass-if "using ice-9 control twice"
+ (begin
+ (module-use-interfaces! m (list (resolve-interface '(ice-9 control))
+ (resolve-interface '(ice-9 control))))
+ (equal? (module-uses m)
+ (list (resolve-interface '(ice-9 q))
+ (resolve-interface '(ice-9 ftw))
+ (resolve-interface '(ice-9 control))))))))
+
+
+
+;;;
;;; Resolve-module.
;;;
diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test
index 95842941d..b1f3d8bc0 100644
--- a/test-suite/tests/numbers.test
+++ b/test-suite/tests/numbers.test
@@ -1456,6 +1456,11 @@
(pass-if (string=? (number->string 35 36) "z"))
(pass-if (= (num->str->num 35 36) 35))
+ ;; Before Guile 2.0.1, even in the presence of a #e forced exactness
+ ;; specifier, negative exponents were applied inexactly and then
+ ;; later coerced to exact, yielding an incorrect fraction.
+ (pass-if (eqv? (string->number "#e1e-10") 1/10000000000))
+
;; Numeric conversion from decimal is not precise, in its current
;; implementation, so 11.333... and 1.324... can't be expected to
;; reliably come out to precise values. These tests did actually work
@@ -4542,6 +4547,54 @@
(lognot #x-100000000000000000000000000000000))))
;;;
+;;; exact-integer-sqrt
+;;;
+
+(with-test-prefix "exact-integer-sqrt"
+ (define (non-negative-exact-integer? k)
+ (and (integer? k) (exact? k) (>= k 0)))
+
+ (define (test k)
+ (pass-if k (let-values (((s r) (exact-integer-sqrt k)))
+ (and (non-negative-exact-integer? s)
+ (non-negative-exact-integer? r)
+ (= k (+ r (* s s)))
+ (< k (* (1+ s) (1+ s)))))))
+
+ (define (test-wrong-type-arg k)
+ (pass-if-exception k exception:wrong-type-arg
+ (let-values (((s r) (exact-integer-sqrt k)))
+ #t)))
+
+ (pass-if (documented? exact-integer-sqrt))
+
+ (pass-if-exception "no args" exception:wrong-num-args
+ (exact-integer-sqrt))
+ (pass-if-exception "two args" exception:wrong-num-args
+ (exact-integer-sqrt 123 456))
+
+ (test 0)
+ (test 1)
+ (test 9)
+ (test 10)
+ (test fixnum-max)
+ (test (1+ fixnum-max))
+ (test (* fixnum-max fixnum-max))
+ (test (+ 1 (* fixnum-max fixnum-max)))
+ (test (expt 10 100))
+ (test (+ 3 (expt 10 100)))
+
+ (test-wrong-type-arg -1)
+ (test-wrong-type-arg 1/9)
+ (test-wrong-type-arg fixnum-min)
+ (test-wrong-type-arg (1- fixnum-min))
+ (test-wrong-type-arg 1.0)
+ (test-wrong-type-arg 1.5)
+ (test-wrong-type-arg "foo")
+ (test-wrong-type-arg 'foo))
+
+
+;;;
;;; sqrt
;;;
diff --git a/test-suite/tests/r6rs-base.test b/test-suite/tests/r6rs-base.test
index 1509b04ed..df11d67b3 100644
--- a/test-suite/tests/r6rs-base.test
+++ b/test-suite/tests/r6rs-base.test
@@ -19,8 +19,26 @@
(define-module (test-suite test-r6rs-base)
:use-module ((rnrs base) :version (6))
+ :use-module ((rnrs conditions) :version (6))
+ :use-module ((rnrs exceptions) :version (6))
:use-module (test-suite lib))
+
+;; numbers are considered =? if their difference is less than a set
+;; tolerance
+(define (=? alpha beta)
+ (< (abs (- alpha beta)) 1e-10))
+
+(with-test-prefix "log (2nd arg)"
+ (pass-if "log positive-base" (=? (log 8 2) 3))
+ (pass-if "log negative-base" (=? (real-part (log 256 -4))
+ 0.6519359443))
+ (pass-if "log base-one" (= (log 10 1) +inf.0))
+ (pass-if "log base-zero"
+ (catch #t
+ (lambda () (log 10 0) #f)
+ (lambda args #t))))
+
(with-test-prefix "boolean=?"
(pass-if "boolean=? null" (boolean=?))
(pass-if "boolean=? unary" (boolean=? #f))
@@ -172,3 +190,9 @@
(pass-if (not (integer-valued? +0.01i)))
(pass-if (not (integer-valued? -inf.0i))))
+(with-test-prefix "assert"
+ (pass-if "assert returns value" (= 1 (assert 1)))
+ (pass-if "assertion-violation"
+ (guard (condition ((assertion-violation? condition) #t))
+ (assert #f)
+ #f)))
diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test
index df056a416..01d8235fa 100644
--- a/test-suite/tests/r6rs-ports.test
+++ b/test-suite/tests/r6rs-ports.test
@@ -320,6 +320,15 @@
(u8-list->bytevector
(map char->integer (string->list "Port!")))))))
+ (pass-if "bytevector input port can seek to very end"
+ (let ((empty (open-bytevector-input-port '#vu8()))
+ (not-empty (open-bytevector-input-port '#vu8(1 2 3))))
+ (and (begin (set-port-position! empty (port-position empty))
+ (= 0 (port-position empty)))
+ (begin (get-bytevector-n not-empty 3)
+ (set-port-position! not-empty (port-position not-empty))
+ (= 3 (port-position not-empty))))))
+
(pass-if-exception "make-custom-binary-input-port [wrong-num-args]"
exception:wrong-num-args
@@ -397,7 +406,11 @@
(close-port port)
(gc) ; Test for marking a closed port.
- closed?)))
+ closed?))
+
+ (pass-if "standard-input-port is binary"
+ (with-fluids ((%default-port-encoding "UTF-8"))
+ (binary-port? (standard-input-port)))))
(with-test-prefix "8.2.10 Output ports"
@@ -509,7 +522,15 @@
(put-bytevector port source)
(and (= sink-pos (bytevector-length source))
(not eof?)
- (bytevector=? sink source)))))
+ (bytevector=? sink source))))
+
+ (pass-if "standard-output-port is binary"
+ (with-fluids ((%default-port-encoding "UTF-8"))
+ (binary-port? (standard-output-port))))
+
+ (pass-if "standard-error-port is binary"
+ (with-fluids ((%default-port-encoding "UTF-8"))
+ (binary-port? (standard-error-port)))))
(with-test-prefix "8.2.6 Input and output ports"
@@ -565,7 +586,39 @@
(char=? (i/o-encoding-error-char c) #\λ)
(bytevector=? (get) (string->utf8 "The letter ")))))
(put-string tp "The letter λ cannot be represented in Latin-1.")
- #f)))))
+ #f))))
+
+ (pass-if "port-transcoder [binary port]"
+ (not (port-transcoder (open-bytevector-input-port #vu8()))))
+
+ (pass-if "port-transcoder [transcoded port]"
+ (let* ((p (transcoded-port (open-bytevector-input-port (string->utf8 "foo"))
+ (make-transcoder (utf-8-codec))))
+ (t (port-transcoder p)))
+ (and t
+ (transcoder-codec t)
+ (eq? (native-eol-style)
+ (transcoder-eol-style t))
+ (eq? (error-handling-mode replace)
+ (transcoder-error-handling-mode t))))))
+
+(with-test-prefix "8.2.9 Textual input"
+
+ (pass-if "get-string-n [short]"
+ (let ((port (open-input-string "GNU Guile")))
+ (string=? "GNU " (get-string-n port 4))))
+ (pass-if "get-string-n [long]"
+ (let ((port (open-input-string "GNU Guile")))
+ (string=? "GNU Guile" (get-string-n port 256))))
+ (pass-if "get-string-n [eof]"
+ (let ((port (open-input-string "")))
+ (eof-object? (get-string-n port 4))))
+
+ (pass-if "get-string-n! [short]"
+ (let ((port (open-input-string "GNU Guile"))
+ (s (string-copy "Isn't XXX great?")))
+ (and (= 3 (get-string-n! port s 6 3))
+ (string=? s "Isn't GNU great?")))))
;;; Local Variables:
;;; mode: scheme
diff --git a/test-suite/tests/reader.test b/test-suite/tests/reader.test
index 13c852665..f350e73a6 100644
--- a/test-suite/tests/reader.test
+++ b/test-suite/tests/reader.test
@@ -36,6 +36,8 @@
(cons 'read-error "Unknown # object: .*$"))
(define exception:eof-in-string
(cons 'read-error "end of file in string constant$"))
+(define exception:eof-in-symbol
+ (cons 'read-error "end of file while reading symbol$"))
(define exception:illegal-escape
(cons 'read-error "illegal character in escape sequence: .*$"))
(define exception:missing-expression
@@ -253,6 +255,14 @@
(read-string "'abcde")))))
(and (equal? (source-property sexp 'line) 0)
(equal? (source-property sexp 'column) 0))))
+ (pass-if "position of SCSH block comment"
+ ;; In Guile 2.0.0 the reader would not update the port's position
+ ;; when reading an SCSH block comment.
+ (let ((sexp (with-read-options '(positions)
+ (lambda ()
+ (read-string "#!foo\nbar\nbaz\n!#\n(hello world)\n")))))
+ (= 4 (source-property sexp 'line))))
+
(with-test-prefix "r6rs-hex-escapes"
(pass-if-exception "non-hex char in two-digit hex-escape"
exception:illegal-escape
@@ -416,4 +426,18 @@
("#,foo" . (unsyntax foo))
("#,@foo" . (unsyntax-splicing foo)))))
-
+(with-test-prefix "#{}#"
+ (pass-if (equal? (read-string "#{}#") '#{}#))
+ (pass-if (equal? (read-string "#{a}#") 'a))
+ (pass-if (equal? (read-string "#{a b}#") '#{a b}#))
+ (pass-if-exception "#{" exception:eof-in-symbol
+ (read-string "#{"))
+ (pass-if (equal? (read-string "#{a\\x20;b}#") '#{a b}#)))
+
+(begin-deprecated
+ (with-test-prefix "deprecated #{}# escapes"
+ (pass-if (equal? (read-string "#{a\\ b}#") '#{a b}#))))
+
+;;; Local Variables:
+;;; eval: (put 'with-read-options 'scheme-indent-function 1)
+;;; End:
diff --git a/test-suite/tests/srfi-4.test b/test-suite/tests/srfi-4.test
index 0cdfb6699..3a0710222 100644
--- a/test-suite/tests/srfi-4.test
+++ b/test-suite/tests/srfi-4.test
@@ -1,7 +1,7 @@
;;;; srfi-4.test --- Test suite for Guile's SRFI-4 functions. -*- scheme -*-
;;;; Martin Grabmueller, 2001-06-26
;;;;
-;;;; Copyright (C) 2001, 2006, 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001, 2006, 2010, 2011 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,6 +18,7 @@
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(use-modules (srfi srfi-4)
+ (srfi srfi-4 gnu)
(test-suite lib))
(with-test-prefix "u8 vectors"
@@ -396,3 +397,83 @@
(pass-if "+inf.0, -inf.0, +nan.0 in f64vector"
(f64vector? #f64(+inf.0 -inf.0 +nan.0))))
+
+(with-test-prefix "c32 vectors"
+
+ (pass-if "c32vector? success"
+ (c32vector? (c32vector)))
+
+ (pass-if "c32vector? failure"
+ (not (c32vector? (s8vector))))
+
+ (pass-if "c32vector-length success 1"
+ (= (c32vector-length (c32vector)) 0))
+
+ (pass-if "c32vector-length success 2"
+ (= (c32vector-length (c32vector -3-2i)) 1))
+
+ (pass-if "c32vector-length failure"
+ (not (= (c32vector-length (c32vector 3)) 3)))
+
+ (pass-if "c32vector-ref"
+ (= (c32vector-ref (c32vector 1 2+13i 3) 1) 2+13i))
+
+ (pass-if "c32vector-set!/ref"
+ (= (let ((s (make-c32vector 10 0)))
+ (c32vector-set! s 4 33-1i)
+ (c32vector-ref s 4)) 33-1i))
+
+ (pass-if "c32vector->list/list->c32vector"
+ (equal? (c32vector->list (c32vector 1 2 3 4))
+ (c32vector->list (list->c32vector '(1 2 3 4)))))
+
+ (pass-if "c32vector->list/uniform-vector->list"
+ (equal? (c32vector->list (c32vector 1 2 3 4))
+ (uniform-vector->list (c32vector 1 2 3 4))))
+
+ (pass-if "make-c32vector"
+ (equal? (list->c32vector '(7 7 7 7))
+ (make-c32vector 4 7)))
+
+ (pass-if "+inf.0, -inf.0, +nan.0 in c32vector"
+ (c32vector? #c32(+inf.0 -inf.0 +nan.0))))
+
+(with-test-prefix "c64 vectors"
+
+ (pass-if "c64vector? success"
+ (c64vector? (c64vector)))
+
+ (pass-if "c64vector? failure"
+ (not (c64vector? (s8vector))))
+
+ (pass-if "c64vector-length success 1"
+ (= (c64vector-length (c64vector)) 0))
+
+ (pass-if "c64vector-length success 2"
+ (= (c64vector-length (c64vector -3-2i)) 1))
+
+ (pass-if "c64vector-length failure"
+ (not (= (c64vector-length (c64vector 3)) 3)))
+
+ (pass-if "c64vector-ref"
+ (= (c64vector-ref (c64vector 1+2i 2+3i 3) 1) 2+3i))
+
+ (pass-if "c64vector-set!/ref"
+ (= (let ((s (make-c64vector 10 0)))
+ (c64vector-set! s 4 33+1i)
+ (c64vector-ref s 4)) 33+1i))
+
+ (pass-if "c64vector->list/list->c64vector"
+ (equal? (c64vector->list (c64vector 1 2 3 4))
+ (c64vector->list (list->c64vector '(1 2 3 4)))))
+
+ (pass-if "c64vector->list/uniform-vector->list"
+ (equal? (c64vector->list (c64vector 1 2 3 4))
+ (uniform-vector->list (c64vector 1 2 3 4))))
+
+ (pass-if "make-c64vector"
+ (equal? (list->c64vector '(7 7 7 7))
+ (make-c64vector 4 7)))
+
+ (pass-if "+inf.0, -inf.0, +nan.0 in c64vector"
+ (c64vector? #c64(+inf.0 -inf.0 +nan.0))))
diff --git a/test-suite/tests/srfi-9.test b/test-suite/tests/srfi-9.test
index cf933a894..f26a7a2cd 100644
--- a/test-suite/tests/srfi-9.test
+++ b/test-suite/tests/srfi-9.test
@@ -1,7 +1,7 @@
;;;; srfi-9.test --- Test suite for Guile's SRFI-9 functions. -*- scheme -*-
;;;; Martin Grabmueller, 2001-05-10
;;;;
-;;;; Copyright (C) 2001, 2006, 2007, 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001, 2006, 2007, 2010, 2011 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
@@ -93,3 +93,20 @@
;; prior to guile 1.6.9 and 1.8.1 this wan't enforced
(pass-if-exception "set-y! on bar" exception:wrong-type-arg
(set-y! b 99)))
+
+(with-test-prefix "side-effecting arguments"
+
+ (pass-if "predicate"
+ (let ((x 0))
+ (and (foo? (begin (set! x (+ x 1)) f))
+ (= x 1)))))
+
+(with-test-prefix "non-toplevel"
+
+ (define-record-type :frotz (make-frotz a b) frotz?
+ (a frotz-a) (b frotz-b set-frotz-b!))
+
+ (pass-if "construction"
+ (let ((frotz (make-frotz 1 2)))
+ (and (= (frotz-a frotz) 1)
+ (= (frotz-b frotz) 2)))))
diff --git a/test-suite/tests/strings.test b/test-suite/tests/strings.test
index fa8e6e1af..d892b7077 100644
--- a/test-suite/tests/strings.test
+++ b/test-suite/tests/strings.test
@@ -1,23 +1,25 @@
;;;; strings.test --- test suite for Guile's string functions -*- scheme -*-
;;;; Jim Blandy <jimb@red-bean.com> --- August 1999
;;;;
-;;;; Copyright (C) 1999, 2001, 2004, 2005, 2006, 2008, 2009, 2010 Free Software Foundation, Inc.
-;;;;
+;;;; Copyright (C) 1999, 2001, 2004, 2005, 2006, 2008, 2009, 2010,
+;;;; 2011 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 as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
-;;;;
+;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
-;;;;
+;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-strings)
+ #:use-module ((system base compile) #:select (compile))
#:use-module (test-suite lib))
(define exception:read-only-string
@@ -241,6 +243,24 @@
(not (string? 'abc))))
;;
+;; literals
+;;
+
+(with-test-prefix "literals"
+
+ ;; The "Storage Model" section of R5RS reads: "In such systems literal
+ ;; constants and the strings returned by `symbol->string' are
+ ;; immutable objects". `eval' doesn't support it yet, but it doesn't
+ ;; really matter because `eval' doesn't coalesce repeated constants,
+ ;; unlike the bytecode compiler.
+
+ (pass-if-exception "literals are constant"
+ exception:read-only-string
+ (compile '(string-set! "literal string" 0 #\x)
+ #:from 'scheme
+ #:to 'value)))
+
+;;
;; string-null?
;;
diff --git a/test-suite/tests/symbols.test b/test-suite/tests/symbols.test
index c87aa21d1..6fbc6be73 100644
--- a/test-suite/tests/symbols.test
+++ b/test-suite/tests/symbols.test
@@ -1,6 +1,6 @@
;;;; symbols.test --- test suite for Guile's symbols -*- scheme -*-
;;;;
-;;;; Copyright (C) 2001, 2006, 2008, 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001, 2006, 2008, 2009, 2011 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
@@ -151,3 +151,8 @@
(pass-if "accepts embedded NULs"
(> (string-length (symbol->string (gensym "foo\0bar\0braz\0foo\0bar\0braz\0foo\0bar\0braz\0foo\0bar\0braz\0foo\0bar\0braz\0foo\0bar\0braz\0"))) 6)))
+(with-test-prefix "extended read syntax"
+ (pass-if (equal? "#{}#" (object->string (string->symbol ""))))
+ (pass-if (equal? "a" (object->string (string->symbol "a"))))
+ (pass-if (equal? "#{a b}#" (object->string (string->symbol "a b"))))
+ (pass-if (equal? "#{\\x7d;}#" (object->string (string->symbol "}")))))
diff --git a/test-suite/tests/syncase.test b/test-suite/tests/syncase.test
index 5f4856791..6183df813 100644
--- a/test-suite/tests/syncase.test
+++ b/test-suite/tests/syncase.test
@@ -1,6 +1,6 @@
;;;; syncase.test --- test suite for (ice-9 syncase) -*- scheme -*-
;;;;
-;;;; Copyright (C) 2001, 2006, 2009, 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001, 2006, 2009, 2010, 2011 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
@@ -68,6 +68,13 @@
((alist ((key val) ...))
(list '(key . val) ...))))
+(with-test-prefix "with-syntax"
+ (pass-if "definitions allowed in body"
+ (equal? (with-syntax ((a 23))
+ (define b #'a)
+ (syntax->datum b))
+ 23)))
+
(with-test-prefix "tail patterns"
(with-test-prefix "at the outermost level"
(pass-if "non-tail invocation"
@@ -220,3 +227,15 @@
(set! baz 50)
(equal? (+ baz qux)
100)))))
+
+(with-test-prefix "top-level expansions"
+ (pass-if "syntax definitions expanded before other expressions"
+ (eval '(begin
+ (define even?
+ (lambda (x)
+ (or (= x 0) (odd? (- x 1)))))
+ (define-syntax odd?
+ (syntax-rules ()
+ ((odd? x) (not (even? x)))))
+ (even? 10))
+ (current-module))))
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 76c825dd1..8ea244343 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -363,7 +363,18 @@
(lexical #t #t set 1)
(lexical #t #t ref 0)
(lexical #t #t ref 1)
- (call add 2) (call return 1) (unbind))))
+ (call add 2) (call return 1) (unbind)))
+
+ ;; simple bindings in letrec* -> equivalent to letrec
+ (assert-tree-il->glil
+ (letrec* (x y) (xx yy) ((const 1) (const 2))
+ (lexical y yy))
+ (program () (std-prelude 0 1 #f) (label _)
+ (const 2)
+ (bind (y #f 0)) ;; X is removed, and Y is unboxed
+ (lexical #t #f set 0)
+ (lexical #t #f ref 0)
+ (call return 1) (unbind))))
(with-test-prefix "lambda"
(assert-tree-il->glil
diff --git a/test-suite/tests/vlist.test b/test-suite/tests/vlist.test
index f3e0989c1..b590bbda1 100644
--- a/test-suite/tests/vlist.test
+++ b/test-suite/tests/vlist.test
@@ -2,7 +2,7 @@
;;;;
;;;; Ludovic Courtès <ludo@gnu.org>
;;;;
-;;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010, 2011 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
@@ -282,6 +282,18 @@
#t
keys)))))
+ (pass-if "vhash-delete honors HASH"
+ ;; In 2.0.0, `vhash-delete' would construct a new vhash without
+ ;; using the supplied hash procedure, which could lead to
+ ;; inconsistencies.
+ (let* ((s "hello")
+ (vh (fold vhash-consq
+ (vhash-consq s "world" vlist-null)
+ (iota 300)
+ (iota 300))))
+ (and (vhash-assq s vh)
+ (pair? (vhash-assq s (vhash-delete 123 vh eq? hashq))))))
+
(pass-if "vhash-fold"
(let* ((keys '(a b c d e f g d h i))
(values '(1 2 3 4 5 6 7 0 8 9))