mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-17 09:10:22 +02:00
Code Activity

Merge remote branch 'origin/stable-2.0'

Browse source 
Conflicts:
	GUILE-VERSION
	test-suite/tests/srfi-4.test
This commit is contained in:
Andy Wingo 2011-04-11 23:30:52 +02:00
commit 21c05db45b
182 changed files with 21314 additions and 18452 deletions
Download patch file Download diff file Expand all files Collapse all files

104
test-suite/tests/coding.test Normal file
View file

@ -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")))

13
test-suite/tests/continuations.test
View file

@ -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"

123
test-suite/tests/control.test
View file

@ -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))

54
test-suite/tests/eval-string.test Normal file
View file

@ -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))))

54
test-suite/tests/foreign.test
View file

@ -27,6 +27,14 @@
#:use-module (srfi srfi-26)
#: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"
@ -66,6 +74,17 @@
(pass-if "not equal?"
(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?
@ -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)))
@ -266,6 +311,13 @@
(pass-if "int8, pointer, short, double"
(let ((layout (list int8 '* short double))
(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))))

11
test-suite/tests/goops.test
View file

@ -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))

89
test-suite/tests/i18n.test
View file

@ -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<?"
@ -191,6 +213,24 @@
(and (char-locale-ci<? #\o #\œ %french-utf8-locale)
(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"
@ -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))))))

45
test-suite/tests/modules.test
View file

@ -144,6 +144,51 @@
(eq? (module-public-interface the-scm-module) the-scm-module)))
;;;
;;; 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.

53
test-suite/tests/numbers.test
View file

@ -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
@ -4541,6 +4546,54 @@
(pass-if (= #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
(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
;;;

24
test-suite/tests/r6rs-base.test
View file

@ -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)))

59
test-suite/tests/r6rs-ports.test
View file

@ -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

24
test-suite/tests/reader.test
View file

@ -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:

83
test-suite/tests/srfi-4.test
View file

@ -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))))

19
test-suite/tests/srfi-9.test
View file

@ -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)))))

28
test-suite/tests/strings.test
View file

@ -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
@ -240,6 +242,24 @@
(pass-if "symbol"
(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?
;;

7
test-suite/tests/symbols.test
View file

@ -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 "}")))))

21
test-suite/tests/syncase.test
View file

@ -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))))

13
test-suite/tests/tree-il.test
View file

@ -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

14
test-suite/tests/vlist.test
View file

@ -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))