diff options
Diffstat (limited to 'test-suite/tests')
-rw-r--r-- | test-suite/tests/coding.test | 104 | ||||
-rw-r--r-- | test-suite/tests/continuations.test | 13 | ||||
-rw-r--r-- | test-suite/tests/control.test | 123 | ||||
-rw-r--r-- | test-suite/tests/eval-string.test | 54 | ||||
-rw-r--r-- | test-suite/tests/foreign.test | 54 | ||||
-rw-r--r-- | test-suite/tests/goops.test | 11 | ||||
-rw-r--r-- | test-suite/tests/i18n.test | 89 | ||||
-rw-r--r-- | test-suite/tests/modules.test | 45 | ||||
-rw-r--r-- | test-suite/tests/numbers.test | 53 | ||||
-rw-r--r-- | test-suite/tests/r6rs-base.test | 24 | ||||
-rw-r--r-- | test-suite/tests/r6rs-ports.test | 59 | ||||
-rw-r--r-- | test-suite/tests/reader.test | 26 | ||||
-rw-r--r-- | test-suite/tests/srfi-4.test | 83 | ||||
-rw-r--r-- | test-suite/tests/srfi-9.test | 19 | ||||
-rw-r--r-- | test-suite/tests/strings.test | 28 | ||||
-rw-r--r-- | test-suite/tests/symbols.test | 7 | ||||
-rw-r--r-- | test-suite/tests/syncase.test | 21 | ||||
-rw-r--r-- | test-suite/tests/tree-il.test | 13 | ||||
-rw-r--r-- | test-suite/tests/vlist.test | 14 |
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)) |