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

Merge branch 'master' of git://git.savannah.gnu.org/guile

Browse source
This commit is contained in:
Julian Graham 2009-06-02 09:35:02 -04:00
commit 2f9ae9b104
158 changed files with 17374 additions and 3404 deletions
Download patch file Download diff file Expand all files Collapse all files

3
test-suite/Makefile.am
View file

@ -26,6 +26,7 @@ SCM_TESTS = tests/alist.test \
tests/arbiters.test \
tests/asm-to-bytecode.test \
tests/bit-operations.test \
tests/bytevectors.test \
tests/c-api.test \
tests/chars.test \
tests/common-list.test \
@ -62,6 +63,7 @@ SCM_TESTS = tests/alist.test \
tests/q.test \
tests/r4rs.test \
tests/r5rs_pitfall.test \
tests/r6rs-ports.test \
tests/ramap.test \
tests/reader.test \
tests/receive.test \
@ -93,6 +95,7 @@ SCM_TESTS = tests/alist.test \
tests/syntax.test \
tests/threads.test \
tests/time.test \
tests/tree-il.test \
tests/unif.test \
tests/version.test \
tests/weaks.test

40
test-suite/lib.scm
View file

@ -317,20 +317,24 @@
(set! run-test local-run-test))
;;; A short form for tests that are expected to pass, taken from Greg.
(defmacro pass-if (name . rest)
(if (and (null? rest) (pair? name))
;; presume this is a simple test, i.e. (pass-if (even? 2))
;; where the body should also be the name.
`(run-test ',name #t (lambda () ,name))
`(run-test ,name #t (lambda () ,@rest))))
(define-syntax pass-if
(syntax-rules ()
((_ name)
;; presume this is a simple test, i.e. (pass-if (even? 2))
;; where the body should also be the name.
(run-test 'name #t (lambda () name)))
((_ name rest ...)
(run-test name #t (lambda () rest ...)))))
;;; A short form for tests that are expected to fail, taken from Greg.
(defmacro expect-fail (name . rest)
(if (and (null? rest) (pair? name))
;; presume this is a simple test, i.e. (expect-fail (even? 2))
;; where the body should also be the name.
`(run-test ',name #f (lambda () ,name))
`(run-test ,name #f (lambda () ,@rest))))
(define-syntax expect-fail
(syntax-rules ()
((_ name)
;; presume this is a simple test, i.e. (expect-fail (even? 2))
;; where the body should also be the name.
(run-test 'name #f (lambda () name)))
((_ name rest ...)
(run-test name #f (lambda () rest ...)))))
;;; A helper function to implement the macros that test for exceptions.
(define (run-test-exception name exception expect-pass thunk)
@ -362,12 +366,16 @@
(apply throw key proc message rest))))))))
;;; A short form for tests that expect a certain exception to be thrown.
(defmacro pass-if-exception (name exception body . rest)
`(,run-test-exception ,name ,exception #t (lambda () ,body ,@rest)))
(define-syntax pass-if-exception
(syntax-rules ()
((_ name exception body rest ...)
(run-test-exception name exception #t (lambda () body rest ...)))))
;;; A short form for tests expected to fail to throw a certain exception.
(defmacro expect-fail-exception (name exception body . rest)
`(,run-test-exception ,name ,exception #f (lambda () ,body ,@rest)))
(define-syntax expect-fail-exception
(syntax-rules ()
((_ name exception body rest ...)
(run-test-exception name exception #f (lambda () body rest ...)))))
;;;; TEST NAMES

531
test-suite/tests/bytevectors.test Normal file
View file

@ -0,0 +1,531 @@
;;;; bytevectors.test --- Exercise the R6RS bytevector API.
;;;;
;;;; Copyright (C) 2009 Free Software Foundation, Inc.
;;;; Ludovic Courtès
;;;;
;;;; 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 2.1 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-bytevector)
:use-module (test-suite lib)
:use-module (rnrs bytevector))
;;; Some of the tests in here are examples taken from the R6RS Standard
;;; Libraries document.
(with-test-prefix "2.2 General Operations"
(pass-if "native-endianness"
(not (not (memq (native-endianness) '(big little)))))
(pass-if "make-bytevector"
(and (bytevector? (make-bytevector 20))
(bytevector? (make-bytevector 20 3))))
(pass-if "bytevector-length"
(= (bytevector-length (make-bytevector 20)) 20))
(pass-if "bytevector=?"
(and (bytevector=? (make-bytevector 20 7)
(make-bytevector 20 7))
(not (bytevector=? (make-bytevector 20 7)
(make-bytevector 20 0))))))
(with-test-prefix "2.3 Operations on Bytes and Octets"
(pass-if "bytevector-{u8,s8}-ref"
(equal? '(-127 129 -1 255)
(let ((b1 (make-bytevector 16 -127))
(b2 (make-bytevector 16 255)))
(list (bytevector-s8-ref b1 0)
(bytevector-u8-ref b1 0)
(bytevector-s8-ref b2 0)
(bytevector-u8-ref b2 0)))))
(pass-if "bytevector-{u8,s8}-set!"
(equal? '(-126 130 -10 246)
(let ((b (make-bytevector 16 -127)))
(bytevector-s8-set! b 0 -126)
(bytevector-u8-set! b 1 246)
(list (bytevector-s8-ref b 0)
(bytevector-u8-ref b 0)
(bytevector-s8-ref b 1)
(bytevector-u8-ref b 1)))))
(pass-if "bytevector->u8-list"
(let ((lst '(1 2 3 128 150 255)))
(equal? lst
(bytevector->u8-list
(let ((b (make-bytevector 6)))
(for-each (lambda (i v)
(bytevector-u8-set! b i v))
(iota 6)
lst)
b)))))
(pass-if "u8-list->bytevector"
(let ((lst '(1 2 3 128 150 255)))
(equal? lst
(bytevector->u8-list (u8-list->bytevector lst)))))
(pass-if "bytevector-uint-{ref,set!} [small]"
(let ((b (make-bytevector 15)))
(bytevector-uint-set! b 0 #x1234
(endianness little) 2)
(equal? (bytevector-uint-ref b 0 (endianness big) 2)
#x3412)))
(pass-if "bytevector-uint-set! [large]"
(let ((b (make-bytevector 16)))
(bytevector-uint-set! b 0 (- (expt 2 128) 3)
(endianness little) 16)
(equal? (bytevector->u8-list b)
'(253 255 255 255 255 255 255 255
255 255 255 255 255 255 255 255))))
(pass-if "bytevector-uint-{ref,set!} [large]"
(let ((b (make-bytevector 120)))
(bytevector-uint-set! b 0 (- (expt 2 128) 3)
(endianness little) 16)
(equal? (bytevector-uint-ref b 0 (endianness little) 16)
#xfffffffffffffffffffffffffffffffd)))
(pass-if "bytevector-sint-ref [small]"
(let ((b (u8-list->bytevector '(#xff #xf0 #xff))))
(equal? (bytevector-sint-ref b 0 (endianness big) 2)
(bytevector-sint-ref b 1 (endianness little) 2)
-16)))
(pass-if "bytevector-sint-ref [large]"
(let ((b (make-bytevector 50)))
(bytevector-uint-set! b 0 (- (expt 2 128) 3)
(endianness little) 16)
(equal? (bytevector-sint-ref b 0 (endianness little) 16)
-3)))
(pass-if "bytevector-sint-set! [small]"
(let ((b (make-bytevector 3)))
(bytevector-sint-set! b 0 -16 (endianness big) 2)
(bytevector-sint-set! b 1 -16 (endianness little) 2)
(equal? (bytevector->u8-list b)
'(#xff #xf0 #xff)))))
(with-test-prefix "2.4 Operations on Integers of Arbitrary Size"
(pass-if "bytevector->sint-list"
(let ((b (u8-list->bytevector '(1 2 3 255 1 2 1 2))))
(equal? (bytevector->sint-list b (endianness little) 2)
'(513 -253 513 513))))
(pass-if "bytevector->uint-list"
(let ((b (u8-list->bytevector '(2 1 255 3 2 1 2 1))))
(equal? (bytevector->uint-list b (endianness big) 2)
'(513 65283 513 513))))
(pass-if "bytevector->uint-list [empty]"
(let ((b (make-bytevector 0)))
(null? (bytevector->uint-list b (endianness big) 2))))
(pass-if-exception "bytevector->sint-list [out-of-range]"
exception:out-of-range
(bytevector->sint-list (make-bytevector 6) (endianness little) 8))
(pass-if "bytevector->sint-list [off-by-one]"
(equal? (bytevector->sint-list (make-bytevector 31 #xff)
(endianness little) 8)
'(-1 -1 -1)))
(pass-if "{sint,uint}-list->bytevector"
(let ((b1 (sint-list->bytevector '(513 -253 513 513)
(endianness little) 2))
(b2 (uint-list->bytevector '(513 65283 513 513)
(endianness little) 2))
(b3 (u8-list->bytevector '(1 2 3 255 1 2 1 2))))
(and (bytevector=? b1 b2)
(bytevector=? b2 b3))))
(pass-if "sint-list->bytevector [limits]"
(bytevector=? (sint-list->bytevector '(-32768 32767)
(endianness big) 2)
(let ((bv (make-bytevector 4)))
(bytevector-u8-set! bv 0 #x80)
(bytevector-u8-set! bv 1 #x00)
(bytevector-u8-set! bv 2 #x7f)
(bytevector-u8-set! bv 3 #xff)
bv)))
(pass-if-exception "sint-list->bytevector [out-of-range]"
exception:out-of-range
(sint-list->bytevector (list 0 0 (expt 2 16)) (endianness big)
2))
(pass-if-exception "uint-list->bytevector [out-of-range]"
exception:out-of-range
(uint-list->bytevector '(0 -1) (endianness big) 2)))
(with-test-prefix "2.5 Operations on 16-Bit Integers"
(pass-if "bytevector-u16-ref"
(let ((b (u8-list->bytevector
'(255 255 255 255 255 255 255 255
255 255 255 255 255 255 255 253))))
(and (equal? (bytevector-u16-ref b 14 (endianness little))
#xfdff)
(equal? (bytevector-u16-ref b 14 (endianness big))
#xfffd))))
(pass-if "bytevector-s16-ref"
(let ((b (u8-list->bytevector
'(255 255 255 255 255 255 255 255
255 255 255 255 255 255 255 253))))
(and (equal? (bytevector-s16-ref b 14 (endianness little))
-513)
(equal? (bytevector-s16-ref b 14 (endianness big))
-3))))
(pass-if "bytevector-s16-ref [unaligned]"
(let ((b (u8-list->bytevector '(#xff #xf0 #xff))))
(equal? (bytevector-s16-ref b 1 (endianness little))
-16)))
(pass-if "bytevector-{u16,s16}-ref"
(let ((b (make-bytevector 2)))
(bytevector-u16-set! b 0 44444 (endianness little))
(and (equal? (bytevector-u16-ref b 0 (endianness little))
44444)
(equal? (bytevector-s16-ref b 0 (endianness little))
(- 44444 65536)))))
(pass-if "bytevector-native-{u16,s16}-{ref,set!}"
(let ((b (make-bytevector 2)))
(bytevector-u16-native-set! b 0 44444)
(and (equal? (bytevector-u16-native-ref b 0)
44444)
(equal? (bytevector-s16-native-ref b 0)
(- 44444 65536)))))
(pass-if "bytevector-s16-{ref,set!} [unaligned]"
(let ((b (make-bytevector 3)))
(bytevector-s16-set! b 1 -77 (endianness little))
(equal? (bytevector-s16-ref b 1 (endianness little))
-77))))
(with-test-prefix "2.6 Operations on 32-bit Integers"
(pass-if "bytevector-u32-ref"
(let ((b (u8-list->bytevector
'(255 255 255 255 255 255 255 255
255 255 255 255 255 255 255 253))))
(and (equal? (bytevector-u32-ref b 12 (endianness little))
#xfdffffff)
(equal? (bytevector-u32-ref b 12 (endianness big))
#xfffffffd))))
(pass-if "bytevector-s32-ref"
(let ((b (u8-list->bytevector
'(255 255 255 255 255 255 255 255
255 255 255 255 255 255 255 253))))
(and (equal? (bytevector-s32-ref b 12 (endianness little))
-33554433)
(equal? (bytevector-s32-ref b 12 (endianness big))
-3))))
(pass-if "bytevector-{u32,s32}-ref"
(let ((b (make-bytevector 4)))
(bytevector-u32-set! b 0 2222222222 (endianness little))
(and (equal? (bytevector-u32-ref b 0 (endianness little))
2222222222)
(equal? (bytevector-s32-ref b 0 (endianness little))
(- 2222222222 (expt 2 32))))))
(pass-if "bytevector-{u32,s32}-native-{ref,set!}"
(let ((b (make-bytevector 4)))
(bytevector-u32-native-set! b 0 2222222222)
(and (equal? (bytevector-u32-native-ref b 0)
2222222222)
(equal? (bytevector-s32-native-ref b 0)
(- 2222222222 (expt 2 32)))))))
(with-test-prefix "2.7 Operations on 64-bit Integers"
(pass-if "bytevector-u64-ref"
(let ((b (u8-list->bytevector
'(255 255 255 255 255 255 255 255
255 255 255 255 255 255 255 253))))
(and (equal? (bytevector-u64-ref b 8 (endianness little))
#xfdffffffffffffff)
(equal? (bytevector-u64-ref b 8 (endianness big))
#xfffffffffffffffd))))
(pass-if "bytevector-s64-ref"
(let ((b (u8-list->bytevector
'(255 255 255 255 255 255 255 255
255 255 255 255 255 255 255 253))))
(and (equal? (bytevector-s64-ref b 8 (endianness little))
-144115188075855873)
(equal? (bytevector-s64-ref b 8 (endianness big))
-3))))
(pass-if "bytevector-{u64,s64}-ref"
(let ((b (make-bytevector 8))
(big 9333333333333333333))
(bytevector-u64-set! b 0 big (endianness little))
(and (equal? (bytevector-u64-ref b 0 (endianness little))
big)
(equal? (bytevector-s64-ref b 0 (endianness little))
(- big (expt 2 64))))))
(pass-if "bytevector-{u64,s64}-native-{ref,set!}"
(let ((b (make-bytevector 8))
(big 9333333333333333333))
(bytevector-u64-native-set! b 0 big)
(and (equal? (bytevector-u64-native-ref b 0)
big)
(equal? (bytevector-s64-native-ref b 0)
(- big (expt 2 64))))))
(pass-if "ref/set! with zero"
(let ((b (make-bytevector 8)))
(bytevector-s64-set! b 0 -1 (endianness big))
(bytevector-u64-set! b 0 0 (endianness big))
(= 0 (bytevector-u64-ref b 0 (endianness big))))))
(with-test-prefix "2.8 Operations on IEEE-754 Representations"
(pass-if "bytevector-ieee-single-native-{ref,set!}"
(let ((b (make-bytevector 4))
(number 3.00))
(bytevector-ieee-single-native-set! b 0 number)
(equal? (bytevector-ieee-single-native-ref b 0)
number)))
(pass-if "bytevector-ieee-single-{ref,set!}"
(let ((b (make-bytevector 8))
(number 3.14))
(bytevector-ieee-single-set! b 0 number (endianness little))
(bytevector-ieee-single-set! b 4 number (endianness big))
(equal? (bytevector-ieee-single-ref b 0 (endianness little))
(bytevector-ieee-single-ref b 4 (endianness big)))))
(pass-if "bytevector-ieee-single-{ref,set!} [unaligned]"
(let ((b (make-bytevector 9))
(number 3.14))
(bytevector-ieee-single-set! b 1 number (endianness little))
(bytevector-ieee-single-set! b 5 number (endianness big))
(equal? (bytevector-ieee-single-ref b 1 (endianness little))
(bytevector-ieee-single-ref b 5 (endianness big)))))
(pass-if "bytevector-ieee-double-native-{ref,set!}"
(let ((b (make-bytevector 8))
(number 3.14))
(bytevector-ieee-double-native-set! b 0 number)
(equal? (bytevector-ieee-double-native-ref b 0)
number)))
(pass-if "bytevector-ieee-double-{ref,set!}"
(let ((b (make-bytevector 16))
(number 3.14))
(bytevector-ieee-double-set! b 0 number (endianness little))
(bytevector-ieee-double-set! b 8 number (endianness big))
(equal? (bytevector-ieee-double-ref b 0 (endianness little))
(bytevector-ieee-double-ref b 8 (endianness big))))))
(define (with-locale locale thunk)
;; Run THUNK under LOCALE.
(let ((original-locale (setlocale LC_ALL)))
(catch 'system-error
(lambda ()
(setlocale LC_ALL locale))
(lambda (key . args)
(throw 'unresolved)))
(dynamic-wind
(lambda ()
#t)
thunk
(lambda ()
(setlocale LC_ALL original-locale)))))
(define (with-latin1-locale thunk)
;; Try out several ISO-8859-1 locales and run THUNK under the one that
;; works (if any).
(define %locales
(map (lambda (name)
(string-append name ".ISO-8859-1"))
'("fr_FR" "es_ES" "en_GB" "en_US" "de_DE" "pt_PT")))
(let loop ((locales %locales))
(if (null? locales)
(throw 'unresolved)
(catch 'unresolved
(lambda ()
(with-locale (car locales) thunk))
(lambda (key . args)
(loop (cdr locales)))))))
;; Default to the C locale for the following tests.
(setlocale LC_ALL "C")
(with-test-prefix "2.9 Operations on Strings"
(pass-if "string->utf8"
(let* ((str "hello, world")
(utf8 (string->utf8 str)))
(and (bytevector? utf8)
(= (bytevector-length utf8)
(string-length str))
(equal? (string->list str)
(map integer->char (bytevector->u8-list utf8))))))
(pass-if "string->utf8 [latin-1]"
(with-latin1-locale
(lambda ()
(let* ((str "hé, ça va bien ?")
(utf8 (string->utf8 str)))
(and (bytevector? utf8)
(= (bytevector-length utf8)
(+ 2 (string-length str))))))))
(pass-if "string->utf16"
(let* ((str "hello, world")
(utf16 (string->utf16 str)))
(and (bytevector? utf16)
(= (bytevector-length utf16)
(* 2 (string-length str)))
(equal? (string->list str)
(map integer->char
(bytevector->uint-list utf16
(endianness big) 2))))))
(pass-if "string->utf16 [little]"
(let* ((str "hello, world")
(utf16 (string->utf16 str (endianness little))))
(and (bytevector? utf16)
(= (bytevector-length utf16)
(* 2 (string-length str)))
(equal? (string->list str)
(map integer->char
(bytevector->uint-list utf16
(endianness little) 2))))))
(pass-if "string->utf32"
(let* ((str "hello, world")
(utf32 (string->utf32 str)))
(and (bytevector? utf32)
(= (bytevector-length utf32)
(* 4 (string-length str)))
(equal? (string->list str)
(map integer->char
(bytevector->uint-list utf32
(endianness big) 4))))))
(pass-if "string->utf32 [little]"
(let* ((str "hello, world")
(utf32 (string->utf32 str (endianness little))))
(and (bytevector? utf32)
(= (bytevector-length utf32)
(* 4 (string-length str)))
(equal? (string->list str)
(map integer->char
(bytevector->uint-list utf32
(endianness little) 4))))))
(pass-if "utf8->string"
(let* ((utf8 (u8-list->bytevector (map char->integer
(string->list "hello, world"))))
(str (utf8->string utf8)))
(and (string? str)
(= (string-length str)
(bytevector-length utf8))
(equal? (string->list str)
(map integer->char (bytevector->u8-list utf8))))))
(pass-if "utf8->string [latin-1]"
(with-latin1-locale
(lambda ()
(let* ((utf8 (string->utf8 "hé, ça va bien ?"))
(str (utf8->string utf8)))
(and (string? str)
(= (string-length str)
(- (bytevector-length utf8) 2)))))))
(pass-if "utf16->string"
(let* ((utf16 (uint-list->bytevector (map char->integer
(string->list "hello, world"))
(endianness big) 2))
(str (utf16->string utf16)))
(and (string? str)
(= (* 2 (string-length str))
(bytevector-length utf16))
(equal? (string->list str)
(map integer->char
(bytevector->uint-list utf16 (endianness big)
2))))))
(pass-if "utf16->string [little]"
(let* ((utf16 (uint-list->bytevector (map char->integer
(string->list "hello, world"))
(endianness little) 2))
(str (utf16->string utf16 (endianness little))))
(and (string? str)
(= (* 2 (string-length str))
(bytevector-length utf16))
(equal? (string->list str)
(map integer->char
(bytevector->uint-list utf16 (endianness little)
2))))))
(pass-if "utf32->string"
(let* ((utf32 (uint-list->bytevector (map char->integer
(string->list "hello, world"))
(endianness big) 4))
(str (utf32->string utf32)))
(and (string? str)
(= (* 4 (string-length str))
(bytevector-length utf32))
(equal? (string->list str)
(map integer->char
(bytevector->uint-list utf32 (endianness big)
4))))))
(pass-if "utf32->string [little]"
(let* ((utf32 (uint-list->bytevector (map char->integer
(string->list "hello, world"))
(endianness little) 4))
(str (utf32->string utf32 (endianness little))))
(and (string? str)
(= (* 4 (string-length str))
(bytevector-length utf32))
(equal? (string->list str)
(map integer->char
(bytevector->uint-list utf32 (endianness little)
4)))))))
;;; Local Variables:
;;; coding: latin-1
;;; mode: scheme
;;; End:

43
test-suite/tests/compiler.test
View file

@ -18,45 +18,10 @@
(define-module (test-suite tests compiler)
:use-module (test-suite lib)
:use-module (test-suite guile-test)
:use-module (system vm program))
:use-module (system base compile))
(with-test-prefix "environments"
(with-test-prefix "basic"
(pass-if "compile-time-environment in evaluator"
(eq? (primitive-eval '(compile-time-environment)) #f))
(pass-if "compile-time-environment in compiler"
(equal? (compile '(compile-time-environment))
(cons (current-module)
(cons '() '()))))
(let ((env (compile
'(let ((x 0)) (set! x 1) (compile-time-environment)))))
(pass-if "compile-time-environment in compiler, heap-allocated var"
(equal? env
(cons (current-module)
(cons '((x . 0)) '(1)))))
;; fixme: compiling with #t or module
(pass-if "recompiling with environment"
(equal? ((compile '(lambda () x) #:env env))
1))
(pass-if "recompiling with environment/2"
(equal? ((compile '(lambda () (set! x (1+ x)) x) #:env env))
2))
(pass-if "recompiling with environment/3"
(equal? ((compile '(lambda () x) #:env env))
2))
)
(pass-if "compile environment is #f"
(equal? ((compile '(lambda () 10)))
10))
(pass-if "compile environment is a module"
(equal? ((compile '(lambda () 10) #:env (current-module)))
10))
)
(pass-if "compile to value"
(equal? (compile 1) 1)))

25
test-suite/tests/eval.test
View file

@ -24,6 +24,9 @@
(define exception:bad-expression
(cons 'syntax-error "Bad expression"))
(define exception:failed-match
(cons 'syntax-error "failed to match any pattern"))
;;;
;;; miscellaneous
@ -85,17 +88,19 @@
;; Macros are accepted as function parameters.
;; Functions that 'apply' macros are rewritten!!!
(expect-fail-exception "macro as argument"
exception:wrong-type-arg
(let ((f (lambda (p a b) (p a b))))
(f and #t #t)))
(pass-if-exception "macro as argument"
exception:failed-match
(primitive-eval
'(let ((f (lambda (p a b) (p a b))))
(f and #t #t))))
(expect-fail-exception "passing macro as parameter"
exception:wrong-type-arg
(let* ((f (lambda (p a b) (p a b)))
(foo (procedure-source f)))
(f and #t #t)
(equal? (procedure-source f) foo)))
(pass-if-exception "passing macro as parameter"
exception:failed-match
(primitive-eval
'(let* ((f (lambda (p a b) (p a b)))
(foo (procedure-source f)))
(f and #t #t)
(equal? (procedure-source f) foo))))
))

455
test-suite/tests/r6rs-ports.test Normal file
View file

@ -0,0 +1,455 @@
;;;; r6rs-ports.test --- Exercise the R6RS I/O port API.
;;;;
;;;; Copyright (C) 2009 Free Software Foundation, Inc.
;;;; Ludovic Courtès
;;;;
;;;; 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 2.1 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-io-ports)
:use-module (test-suite lib)
:use-module (srfi srfi-1)
:use-module (srfi srfi-11)
:use-module (rnrs io ports)
:use-module (rnrs bytevector))
;;; All these tests assume Guile 1.8's port system, where characters are
;;; treated as octets.
(with-test-prefix "7.2.5 End-of-File Object"
(pass-if "eof-object"
(and (eqv? (eof-object) (eof-object))
(eq? (eof-object) (eof-object)))))
(with-test-prefix "7.2.8 Binary Input"
(pass-if "get-u8"
(let ((port (open-input-string "A")))
(and (= (char->integer #\A) (get-u8 port))
(eof-object? (get-u8 port)))))
(pass-if "lookahead-u8"
(let ((port (open-input-string "A")))
(and (= (char->integer #\A) (lookahead-u8 port))
(not (eof-object? port))
(= (char->integer #\A) (get-u8 port))
(eof-object? (get-u8 port)))))
(pass-if "get-bytevector-n [short]"
(let* ((port (open-input-string "GNU Guile"))
(bv (get-bytevector-n port 4)))
(and (bytevector? bv)
(equal? (bytevector->u8-list bv)
(map char->integer (string->list "GNU "))))))
(pass-if "get-bytevector-n [long]"
(let* ((port (open-input-string "GNU Guile"))
(bv (get-bytevector-n port 256)))
(and (bytevector? bv)
(equal? (bytevector->u8-list bv)
(map char->integer (string->list "GNU Guile"))))))
(pass-if-exception "get-bytevector-n with closed port"
exception:wrong-type-arg
(let ((port (%make-void-port "r")))
(close-port port)
(get-bytevector-n port 3)))
(pass-if "get-bytevector-n! [short]"
(let* ((port (open-input-string "GNU Guile"))
(bv (make-bytevector 4))
(read (get-bytevector-n! port bv 0 4)))
(and (equal? read 4)
(equal? (bytevector->u8-list bv)
(map char->integer (string->list "GNU "))))))
(pass-if "get-bytevector-n! [long]"
(let* ((str "GNU Guile")
(port (open-input-string str))
(bv (make-bytevector 256))
(read (get-bytevector-n! port bv 0 256)))
(and (equal? read (string-length str))
(equal? (map (lambda (i)
(bytevector-u8-ref bv i))
(iota read))
(map char->integer (string->list str))))))
(pass-if "get-bytevector-some [simple]"
(let* ((str "GNU Guile")
(port (open-input-string str))
(bv (get-bytevector-some port)))
(and (bytevector? bv)
(equal? (bytevector->u8-list bv)
(map char->integer (string->list str))))))
(pass-if "get-bytevector-some [only-some]"
(let* ((str "GNU Guile")
(index 0)
(port (make-soft-port
(vector #f #f #f
(lambda ()
(if (>= index (string-length str))
(eof-object)
(let ((c (string-ref str index)))
(set! index (+ index 1))
c)))
(lambda () #t)
(lambda ()
;; Number of readily available octets: falls to
;; zero after 4 octets have been read.
(- 4 (modulo index 5))))
"r"))
(bv (get-bytevector-some port)))
(and (bytevector? bv)
(= index 4)
(= (bytevector-length bv) index)
(equal? (bytevector->u8-list bv)
(map char->integer (string->list "GNU "))))))
(pass-if "get-bytevector-all"
(let* ((str "GNU Guile")
(index 0)
(port (make-soft-port
(vector #f #f #f
(lambda ()
(if (>= index (string-length str))
(eof-object)
(let ((c (string-ref str index)))
(set! index (+ index 1))
c)))
(lambda () #t)
(let ((cont? #f))
(lambda ()
;; Number of readily available octets: falls to
;; zero after 4 octets have been read and then
;; starts again.
(let ((a (if cont?
(- (string-length str) index)
(- 4 (modulo index 5)))))
(if (= 0 a) (set! cont? #t))
a))))
"r"))
(bv (get-bytevector-all port)))
(and (bytevector? bv)
(= index (string-length str))
(= (bytevector-length bv) (string-length str))
(equal? (bytevector->u8-list bv)
(map char->integer (string->list str)))))))
(define (make-soft-output-port)
(let* ((bv (make-bytevector 1024))
(read-index 0)
(write-index 0)
(write-char (lambda (chr)
(bytevector-u8-set! bv write-index
(char->integer chr))
(set! write-index (+ 1 write-index)))))
(make-soft-port
(vector write-char
(lambda (str) ;; write-string
(for-each write-char (string->list str)))
(lambda () #t) ;; flush-output
(lambda () ;; read-char
(if (>= read-index (bytevector-length bv))
(eof-object)
(let ((c (bytevector-u8-ref bv read-index)))
(set! read-index (+ read-index 1))
(integer->char c))))
(lambda () #t)) ;; close-port
"rw")))
(with-test-prefix "7.2.11 Binary Output"
(pass-if "put-u8"
(let ((port (make-soft-output-port)))
(put-u8 port 77)
(equal? (get-u8 port) 77)))
(pass-if "put-bytevector [2 args]"
(let ((port (make-soft-output-port))
(bv (make-bytevector 256)))
(put-bytevector port bv)
(equal? (bytevector->u8-list bv)
(bytevector->u8-list
(get-bytevector-n port (bytevector-length bv))))))
(pass-if "put-bytevector [3 args]"
(let ((port (make-soft-output-port))
(bv (make-bytevector 256))
(start 10))
(put-bytevector port bv start)
(equal? (drop (bytevector->u8-list bv) start)
(bytevector->u8-list
(get-bytevector-n port (- (bytevector-length bv) start))))))
(pass-if "put-bytevector [4 args]"
(let ((port (make-soft-output-port))
(bv (make-bytevector 256))
(start 10)
(count 77))
(put-bytevector port bv start count)
(equal? (take (drop (bytevector->u8-list bv) start) count)
(bytevector->u8-list
(get-bytevector-n port count)))))
(pass-if-exception "put-bytevector with closed port"
exception:wrong-type-arg
(let* ((bv (make-bytevector 4))
(port (%make-void-port "w")))
(close-port port)
(put-bytevector port bv))))
(with-test-prefix "7.2.7 Input Ports"
;; This section appears here so that it can use the binary input
;; primitives.
(pass-if "open-bytevector-input-port [1 arg]"
(let* ((str "Hello Port!")
(bv (u8-list->bytevector (map char->integer
(string->list str))))
(port (open-bytevector-input-port bv))
(read-to-string
(lambda (port)
(let loop ((chr (read-char port))
(result '()))
(if (eof-object? chr)
(apply string (reverse! result))
(loop (read-char port)
(cons chr result)))))))
(equal? (read-to-string port) str)))
(pass-if-exception "bytevector-input-port is read-only"
exception:wrong-type-arg
(let* ((str "Hello Port!")
(bv (u8-list->bytevector (map char->integer
(string->list str))))
(port (open-bytevector-input-port bv #f)))
(write "hello" port)))
(pass-if "bytevector input port supports seeking"
(let* ((str "Hello Port!")
(bv (u8-list->bytevector (map char->integer
(string->list str))))
(port (open-bytevector-input-port bv #f)))
(and (port-has-port-position? port)
(= 0 (port-position port))
(port-has-set-port-position!? port)
(begin
(set-port-position! port 6)
(= 6 (port-position port)))
(bytevector=? (get-bytevector-all port)
(u8-list->bytevector
(map char->integer (string->list "Port!")))))))
(pass-if-exception "make-custom-binary-input-port [wrong-num-args]"
exception:wrong-num-args
;; Prior to Guile-R6RS-Libs 0.2, the last 3 arguments were wrongfully
;; optional.
(make-custom-binary-input-port "port" (lambda args #t)))
(pass-if "make-custom-binary-input-port"
(let* ((source (make-bytevector 7777))
(read! (let ((pos 0)
(len (bytevector-length source)))
(lambda (bv start count)
(let ((amount (min count (- len pos))))
(if (> amount 0)
(bytevector-copy! source pos
bv start amount))
(set! pos (+ pos amount))
amount))))
(port (make-custom-binary-input-port "the port" read!
#f #f #f)))
(bytevector=? (get-bytevector-all port) source)))
(pass-if "custom binary input port does not support `port-position'"
(let* ((str "Hello Port!")
(source (open-bytevector-input-port
(u8-list->bytevector
(map char->integer (string->list str)))))
(read! (lambda (bv start count)
(let ((r (get-bytevector-n! source bv start count)))
(if (eof-object? r)
0
r))))
(port (make-custom-binary-input-port "the port" read!
#f #f #f)))
(not (or (port-has-port-position? port)
(port-has-set-port-position!? port)))))
(pass-if "custom binary input port supports `port-position'"
(let* ((str "Hello Port!")
(source (open-bytevector-input-port
(u8-list->bytevector
(map char->integer (string->list str)))))
(read! (lambda (bv start count)
(let ((r (get-bytevector-n! source bv start count)))
(if (eof-object? r)
0
r))))
(get-pos (lambda ()
(port-position source)))
(set-pos! (lambda (pos)
(set-port-position! source pos)))
(port (make-custom-binary-input-port "the port" read!
get-pos set-pos! #f)))
(and (port-has-port-position? port)
(= 0 (port-position port))
(port-has-set-port-position!? port)
(begin
(set-port-position! port 6)
(= 6 (port-position port)))
(bytevector=? (get-bytevector-all port)
(u8-list->bytevector
(map char->integer (string->list "Port!")))))))
(pass-if "custom binary input port `close-proc' is called"
(let* ((closed? #f)
(read! (lambda (bv start count) 0))
(get-pos (lambda () 0))
(set-pos! (lambda (pos) #f))
(close! (lambda () (set! closed? #t)))
(port (make-custom-binary-input-port "the port" read!
get-pos set-pos!
close!)))
(close-port port)
closed?)))
(with-test-prefix "8.2.10 Output ports"
(pass-if "open-bytevector-output-port"
(let-values (((port get-content)
(open-bytevector-output-port #f)))
(let ((source (make-bytevector 7777)))
(put-bytevector port source)
(and (bytevector=? (get-content) source)
(bytevector=? (get-content) (make-bytevector 0))))))
(pass-if "open-bytevector-output-port [put-u8]"
(let-values (((port get-content)
(open-bytevector-output-port)))
(put-u8 port 77)
(and (bytevector=? (get-content) (make-bytevector 1 77))
(bytevector=? (get-content) (make-bytevector 0)))))
(pass-if "open-bytevector-output-port [display]"
(let-values (((port get-content)
(open-bytevector-output-port)))
(display "hello" port)
(and (bytevector=? (get-content) (string->utf8 "hello"))
(bytevector=? (get-content) (make-bytevector 0)))))
(pass-if "bytevector output port supports `port-position'"
(let-values (((port get-content)
(open-bytevector-output-port)))
(let ((source (make-bytevector 7777))
(overwrite (make-bytevector 33)))
(and (port-has-port-position? port)
(port-has-set-port-position!? port)
(begin
(put-bytevector port source)
(= (bytevector-length source)
(port-position port)))
(begin
(set-port-position! port 10)
(= 10 (port-position port)))
(begin
(put-bytevector port overwrite)
(bytevector-copy! overwrite 0 source 10
(bytevector-length overwrite))
(= (port-position port)
(+ 10 (bytevector-length overwrite))))
(bytevector=? (get-content) source)
(bytevector=? (get-content) (make-bytevector 0))))))
(pass-if "make-custom-binary-output"
(let ((port (make-custom-binary-output-port "cbop"
(lambda (x y z) 0)
#f #f #f)))
(and (output-port? port)
(binary-port? port)
(not (port-has-port-position? port))
(not (port-has-set-port-position!? port)))))
(pass-if "make-custom-binary-output-port [partial writes]"
(let* ((source (uint-list->bytevector (iota 333)
(native-endianness) 2))
(sink (make-bytevector (bytevector-length source)))
(sink-pos 0)
(eof? #f)
(write! (lambda (bv start count)
(if (= 0 count)
(begin
(set! eof? #t)
0)
(let ((u8 (bytevector-u8-ref bv start)))
;; Get one byte at a time.
(bytevector-u8-set! sink sink-pos u8)
(set! sink-pos (+ 1 sink-pos))
1))))
(port (make-custom-binary-output-port "cbop" write!
#f #f #f)))
(put-bytevector port source)
(and (= sink-pos (bytevector-length source))
(not eof?)
(bytevector=? sink source))))
(pass-if "make-custom-binary-output-port [full writes]"
(let* ((source (uint-list->bytevector (iota 333)
(native-endianness) 2))
(sink (make-bytevector (bytevector-length source)))
(sink-pos 0)
(eof? #f)
(write! (lambda (bv start count)
(if (= 0 count)
(begin
(set! eof? #t)
0)
(begin
(bytevector-copy! bv start
sink sink-pos
count)
(set! sink-pos (+ sink-pos count))
count))))
(port (make-custom-binary-output-port "cbop" write!
#f #f #f)))
(put-bytevector port source)
(and (= sink-pos (bytevector-length source))
(not eof?)
(bytevector=? sink source)))))
;;; Local Variables:
;;; coding: latin-1
;;; mode: scheme
;;; End:

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

@ -35,6 +35,8 @@
(cons 'read-error "end of file in string constant$"))
(define exception:illegal-escape
(cons 'read-error "illegal character in escape sequence: .*$"))
(define exception:missing-expression
(cons 'read-error "no expression after #;"))
(define (read-string s)
@ -194,3 +196,36 @@
(and (equal? (source-property sexp 'line) 0)
(equal? (source-property sexp 'column) 0)))))
(with-test-prefix "#;"
(for-each
(lambda (pair)
(pass-if (car pair)
(equal? (with-input-from-string (car pair) read) (cdr pair))))
'(("#;foo 10". 10)
("#;(10 20 30) foo" . foo)
("#; (10 20 30) foo" . foo)
("#;\n10\n20" . 20)))
(pass-if "#;foo"
(eof-object? (with-input-from-string "#;foo" read)))
(pass-if-exception "#;"
exception:missing-expression
(with-input-from-string "#;" read))
(pass-if-exception "#;("
exception:eof
(with-input-from-string "#;(" read)))
(with-test-prefix "#'"
(for-each
(lambda (pair)
(pass-if (car pair)
(equal? (with-input-from-string (car pair) read) (cdr pair))))
'(("#'foo". (syntax foo))
("#`foo" . (quasisyntax foo))
("#,foo" . (unsyntax foo))
("#,@foo" . (unsyntax-splicing foo)))))

7
test-suite/tests/srfi-17.test
View file

@ -50,6 +50,9 @@
(define %some-variable #f)
(define exception:bad-quote
'(syntax-error . "quote: bad syntax"))
(with-test-prefix "set!"
(with-test-prefix "target is not procedure with setter"
@ -59,7 +62,7 @@
(set! (symbol->string 'x) 1))
(pass-if-exception "(set! '#f 1)"
exception:bad-variable
exception:bad-quote
(eval '(set! '#f 1) (interaction-environment))))
(with-test-prefix "target uses macro"
@ -72,7 +75,7 @@
;; The `(quote x)' below used to be memoized as an infinite list before
;; Guile 1.8.3.
(pass-if-exception "(set! 'x 1)"
exception:bad-variable
exception:bad-quote
(eval '(set! 'x 1) (interaction-environment)))))
;;

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

@ -21,8 +21,13 @@
(define-module (test-suite test-srfi-18)
#:use-module (test-suite lib))
(and (provided? 'threads)
(use-modules (srfi srfi-18))
;; two expressions so that the srfi-18 import is in effect for expansion
;; of the rest
(if (provided? 'threads)
(use-modules (srfi srfi-18)))
(and
(provided? 'threads)
(with-test-prefix "current-thread"

2
test-suite/tests/srfi-31.test
View file

@ -23,7 +23,7 @@
(with-test-prefix "rec special form"
(pass-if-exception "bogus variable" '(misc-error . ".*")
(rec #:foo))
(sc-expand '(rec #:foo)))
(pass-if "rec expressions"
(let ((ones-list (rec ones (cons 1 (delay ones)))))

414
test-suite/tests/syntax.test
View file

@ -21,6 +21,11 @@
:use-module (test-suite lib))
(define exception:generic-syncase-error
(cons 'syntax-error "source expression failed to match"))
(define exception:unexpected-syntax
(cons 'syntax-error "unexpected syntax"))
(define exception:bad-expression
(cons 'syntax-error "Bad expression"))
@ -29,22 +34,32 @@
(define exception:missing-expr
(cons 'syntax-error "Missing expression"))
(define exception:missing-body-expr
(cons 'syntax-error "Missing body expression"))
(cons 'syntax-error "no expressions in body"))
(define exception:extra-expr
(cons 'syntax-error "Extra expression"))
(define exception:illegal-empty-combination
(cons 'syntax-error "Illegal empty combination"))
(define exception:bad-lambda
'(syntax-error . "bad lambda"))
(define exception:bad-let
'(syntax-error . "bad let "))
(define exception:bad-letrec
'(syntax-error . "bad letrec "))
(define exception:bad-set!
'(syntax-error . "bad set!"))
(define exception:bad-quote
'(syntax-error . "quote: bad syntax"))
(define exception:bad-bindings
(cons 'syntax-error "Bad bindings"))
(define exception:bad-binding
(cons 'syntax-error "Bad binding"))
(define exception:duplicate-binding
(cons 'syntax-error "Duplicate binding"))
(cons 'syntax-error "duplicate bound variable"))
(define exception:bad-body
(cons 'misc-error "^bad body"))
(define exception:bad-formals
(cons 'syntax-error "Bad formals"))
'(syntax-error . "invalid parameter list"))
(define exception:bad-formal
(cons 'syntax-error "Bad formal"))
(define exception:duplicate-formal
@ -67,13 +82,13 @@
(with-test-prefix "Bad argument list"
(pass-if-exception "improper argument list of length 1"
exception:wrong-num-args
exception:generic-syncase-error
(eval '(let ((foo (lambda (x y) #t)))
(foo . 1))
(interaction-environment)))
(pass-if-exception "improper argument list of length 2"
exception:wrong-num-args
exception:generic-syncase-error
(eval '(let ((foo (lambda (x y) #t)))
(foo 1 . 2))
(interaction-environment))))
@ -88,7 +103,7 @@
;; Fixed on 2001-3-3
(pass-if-exception "empty parentheses \"()\""
exception:illegal-empty-combination
exception:unexpected-syntax
(eval '()
(interaction-environment)))))
@ -106,28 +121,32 @@
(with-test-prefix "unquote-splicing"
(pass-if-exception "extra arguments"
exception:missing/extra-expr
(quasiquote ((unquote-splicing (list 1 2) (list 3 4)))))))
'(syntax-error . "unquote-splicing takes exactly one argument")
(eval '(quasiquote ((unquote-splicing (list 1 2) (list 3 4))))
(interaction-environment)))))
(with-test-prefix "begin"
(pass-if "legal (begin)"
(begin)
#t)
(eval '(begin (begin) #t) (interaction-environment)))
(with-test-prefix "unmemoization"
;; FIXME. I have no idea why, but the expander is filling in (if #f
;; #f) as the second arm of the if, if the second arm is missing. I
;; thought I made it not do that. But in the meantime, let's adapt,
;; since that's not what we're testing.
(pass-if "normal begin"
(let ((foo (lambda () (if (= 1 1) (begin (+ 1) (+ 2))))))
(foo) ; make sure, memoization has been performed
(let ((foo (lambda () (if (= 1 1) (begin (+ 1) (+ 2)) #f))))
(equal? (procedure-source foo)
'(lambda () (if (= 1 1) (begin (+ 1) (+ 2)))))))
'(lambda () (if (= 1 1) (begin (+ 1) (+ 2)) #f)))))
(pass-if "redundant nested begin"
(let ((foo (lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3)))))))
(let ((foo (lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3))) #f))))
(foo) ; make sure, memoization has been performed
(equal? (procedure-source foo)
'(lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3))))))))
'(lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3))) #f)))))
(pass-if "redundant begin at start of body"
(let ((foo (lambda () (begin (+ 1) (+ 2))))) ; should be optimized
@ -135,10 +154,20 @@
(equal? (procedure-source foo)
'(lambda () (begin (+ 1) (+ 2)))))))
(expect-fail-exception "illegal (begin)"
exception:bad-body
(if #t (begin))
#t))
(pass-if-exception "illegal (begin)"
exception:generic-syncase-error
(eval '(begin (if #t (begin)) #t) (interaction-environment))))
(define-syntax matches?
(syntax-rules (_)
((_ (op arg ...) pat) (let ((x (op arg ...)))
(matches? x pat)))
((_ x ()) (null? x))
((_ x (a . b)) (and (pair? x)
(matches? (car x) a)
(matches? (cdr x) b)))
((_ x _) #t)
((_ x pat) (equal? x 'pat))))
(with-test-prefix "lambda"
@ -146,30 +175,28 @@
(pass-if "normal lambda"
(let ((foo (lambda () (lambda (x y) (+ x y)))))
((foo) 1 2) ; make sure, memoization has been performed
(equal? (procedure-source foo)
'(lambda () (lambda (x y) (+ x y))))))
(matches? (procedure-source foo)
(lambda () (lambda (_ _) (+ _ _))))))
(pass-if "lambda with documentation"
(let ((foo (lambda () (lambda (x y) "docstring" (+ x y)))))
((foo) 1 2) ; make sure, memoization has been performed
(equal? (procedure-source foo)
'(lambda () (lambda (x y) "docstring" (+ x y)))))))
(matches? (procedure-source foo)
(lambda () (lambda (_ _) "docstring" (+ _ _)))))))
(with-test-prefix "bad formals"
(pass-if-exception "(lambda)"
exception:missing-expr
exception:bad-lambda
(eval '(lambda)
(interaction-environment)))
(pass-if-exception "(lambda . \"foo\")"
exception:bad-expression
exception:bad-lambda
(eval '(lambda . "foo")
(interaction-environment)))
(pass-if-exception "(lambda \"foo\")"
exception:missing-expr
exception:bad-lambda
(eval '(lambda "foo")
(interaction-environment)))
@ -179,22 +206,22 @@
(interaction-environment)))
(pass-if-exception "(lambda (x 1) 2)"
exception:bad-formal
exception:bad-formals
(eval '(lambda (x 1) 2)
(interaction-environment)))
(pass-if-exception "(lambda (1 x) 2)"
exception:bad-formal
exception:bad-formals
(eval '(lambda (1 x) 2)
(interaction-environment)))
(pass-if-exception "(lambda (x \"a\") 2)"
exception:bad-formal
exception:bad-formals
(eval '(lambda (x "a") 2)
(interaction-environment)))
(pass-if-exception "(lambda (\"a\" x) 2)"
exception:bad-formal
exception:bad-formals
(eval '(lambda ("a" x) 2)
(interaction-environment))))
@ -202,20 +229,20 @@
;; Fixed on 2001-3-3
(pass-if-exception "(lambda (x x) 1)"
exception:duplicate-formal
exception:bad-formals
(eval '(lambda (x x) 1)
(interaction-environment)))
;; Fixed on 2001-3-3
(pass-if-exception "(lambda (x x x) 1)"
exception:duplicate-formal
exception:bad-formals
(eval '(lambda (x x x) 1)
(interaction-environment))))
(with-test-prefix "bad body"
(pass-if-exception "(lambda ())"
exception:missing-expr
exception:bad-lambda
(eval '(lambda ())
(interaction-environment)))))
@ -225,9 +252,8 @@
(pass-if "normal let"
(let ((foo (lambda () (let ((i 1) (j 2)) (+ i j)))))
(foo) ; make sure, memoization has been performed
(equal? (procedure-source foo)
'(lambda () (let ((i 1) (j 2)) (+ i j)))))))
(matches? (procedure-source foo)
(lambda () (let ((_ 1) (_ 2)) (+ _ _)))))))
(with-test-prefix "bindings"
@ -238,42 +264,42 @@
(with-test-prefix "bad bindings"
(pass-if-exception "(let)"
exception:missing-expr
exception:bad-let
(eval '(let)
(interaction-environment)))
(pass-if-exception "(let 1)"
exception:missing-expr
exception:bad-let
(eval '(let 1)
(interaction-environment)))
(pass-if-exception "(let (x))"
exception:missing-expr
exception:bad-let
(eval '(let (x))
(interaction-environment)))
(pass-if-exception "(let ((x)))"
exception:missing-expr
exception:bad-let
(eval '(let ((x)))
(interaction-environment)))
(pass-if-exception "(let (x) 1)"
exception:bad-binding
exception:bad-let
(eval '(let (x) 1)
(interaction-environment)))
(pass-if-exception "(let ((x)) 3)"
exception:bad-binding
exception:bad-let
(eval '(let ((x)) 3)
(interaction-environment)))
(pass-if-exception "(let ((x 1) y) x)"
exception:bad-binding
exception:bad-let
(eval '(let ((x 1) y) x)
(interaction-environment)))
(pass-if-exception "(let ((1 2)) 3)"
exception:bad-variable
exception:bad-let
(eval '(let ((1 2)) 3)
(interaction-environment))))
@ -287,12 +313,12 @@
(with-test-prefix "bad body"
(pass-if-exception "(let ())"
exception:missing-expr
exception:bad-let
(eval '(let ())
(interaction-environment)))
(pass-if-exception "(let ((x 1)))"
exception:missing-expr
exception:bad-let
(eval '(let ((x 1)))
(interaction-environment)))))
@ -307,19 +333,19 @@
(with-test-prefix "bad bindings"
(pass-if-exception "(let x (y))"
exception:missing-expr
exception:bad-let
(eval '(let x (y))
(interaction-environment))))
(with-test-prefix "bad body"
(pass-if-exception "(let x ())"
exception:missing-expr
exception:bad-let
(eval '(let x ())
(interaction-environment)))
(pass-if-exception "(let x ((y 1)))"
exception:missing-expr
exception:bad-let
(eval '(let x ((y 1)))
(interaction-environment)))))
@ -329,19 +355,16 @@
(pass-if "normal let*"
(let ((foo (lambda () (let* ((x 1) (y 2)) (+ x y)))))
(foo) ; make sure, memoization has been performed
(equal? (procedure-source foo)
'(lambda () (let* ((x 1) (y 2)) (+ x y))))))
(matches? (procedure-source foo)
(lambda () (let ((_ 1)) (let ((_ 2)) (+ _ _)))))))
(pass-if "let* without bindings"
(let ((foo (lambda () (let ((x 1) (y 2))
(let* ()
(and (= x 1) (= y 2)))))))
(foo) ; make sure, memoization has been performed
(equal? (procedure-source foo)
'(lambda () (let ((x 1) (y 2))
(let* ()
(and (= x 1) (= y 2)))))))))
(matches? (procedure-source foo)
(lambda () (let ((_ 1) (_ 2))
(if (= _ 1) (= _ 2) #f)))))))
(with-test-prefix "bindings"
@ -361,59 +384,59 @@
(with-test-prefix "bad bindings"
(pass-if-exception "(let*)"
exception:missing-expr
exception:generic-syncase-error
(eval '(let*)
(interaction-environment)))
(pass-if-exception "(let* 1)"
exception:missing-expr
exception:generic-syncase-error
(eval '(let* 1)
(interaction-environment)))
(pass-if-exception "(let* (x))"
exception:missing-expr
exception:generic-syncase-error
(eval '(let* (x))
(interaction-environment)))
(pass-if-exception "(let* (x) 1)"
exception:bad-binding
exception:generic-syncase-error
(eval '(let* (x) 1)
(interaction-environment)))
(pass-if-exception "(let* ((x)) 3)"
exception:bad-binding
exception:generic-syncase-error
(eval '(let* ((x)) 3)
(interaction-environment)))
(pass-if-exception "(let* ((x 1) y) x)"
exception:bad-binding
exception:generic-syncase-error
(eval '(let* ((x 1) y) x)
(interaction-environment)))
(pass-if-exception "(let* x ())"
exception:bad-bindings
exception:generic-syncase-error
(eval '(let* x ())
(interaction-environment)))
(pass-if-exception "(let* x (y))"
exception:bad-bindings
exception:generic-syncase-error
(eval '(let* x (y))
(interaction-environment)))
(pass-if-exception "(let* ((1 2)) 3)"
exception:bad-variable
exception:generic-syncase-error
(eval '(let* ((1 2)) 3)
(interaction-environment))))
(with-test-prefix "bad body"
(pass-if-exception "(let* ())"
exception:missing-expr
exception:generic-syncase-error
(eval '(let* ())
(interaction-environment)))
(pass-if-exception "(let* ((x 1)))"
exception:missing-expr
exception:generic-syncase-error
(eval '(let* ((x 1)))
(interaction-environment)))))
@ -423,9 +446,8 @@
(pass-if "normal letrec"
(let ((foo (lambda () (letrec ((i 1) (j 2)) (+ i j)))))
(foo) ; make sure, memoization has been performed
(equal? (procedure-source foo)
'(lambda () (letrec ((i 1) (j 2)) (+ i j)))))))
(matches? (procedure-source foo)
(lambda () (letrec ((_ 1) (_ 2)) (+ _ _)))))))
(with-test-prefix "bindings"
@ -437,47 +459,47 @@
(with-test-prefix "bad bindings"
(pass-if-exception "(letrec)"
exception:missing-expr
exception:bad-letrec
(eval '(letrec)
(interaction-environment)))
(pass-if-exception "(letrec 1)"
exception:missing-expr
exception:bad-letrec
(eval '(letrec 1)
(interaction-environment)))
(pass-if-exception "(letrec (x))"
exception:missing-expr
exception:bad-letrec
(eval '(letrec (x))
(interaction-environment)))
(pass-if-exception "(letrec (x) 1)"
exception:bad-binding
exception:bad-letrec
(eval '(letrec (x) 1)
(interaction-environment)))
(pass-if-exception "(letrec ((x)) 3)"
exception:bad-binding
exception:bad-letrec
(eval '(letrec ((x)) 3)
(interaction-environment)))
(pass-if-exception "(letrec ((x 1) y) x)"
exception:bad-binding
exception:bad-letrec
(eval '(letrec ((x 1) y) x)
(interaction-environment)))
(pass-if-exception "(letrec x ())"
exception:bad-bindings
exception:bad-letrec
(eval '(letrec x ())
(interaction-environment)))
(pass-if-exception "(letrec x (y))"
exception:bad-bindings
exception:bad-letrec
(eval '(letrec x (y))
(interaction-environment)))
(pass-if-exception "(letrec ((1 2)) 3)"
exception:bad-variable
exception:bad-letrec
(eval '(letrec ((1 2)) 3)
(interaction-environment))))
@ -491,12 +513,12 @@
(with-test-prefix "bad body"
(pass-if-exception "(letrec ())"
exception:missing-expr
exception:bad-letrec
(eval '(letrec ())
(interaction-environment)))
(pass-if-exception "(letrec ((x 1)))"
exception:missing-expr
exception:bad-letrec
(eval '(letrec ((x 1)))
(interaction-environment)))))
@ -508,17 +530,17 @@
(let ((foo (lambda (x) (if x (+ 1) (+ 2)))))
(foo #t) ; make sure, memoization has been performed
(foo #f) ; make sure, memoization has been performed
(equal? (procedure-source foo)
'(lambda (x) (if x (+ 1) (+ 2))))))
(matches? (procedure-source foo)
(lambda (_) (if _ (+ 1) (+ 2))))))
(pass-if "if without else"
(expect-fail "if without else"
(let ((foo (lambda (x) (if x (+ 1)))))
(foo #t) ; make sure, memoization has been performed
(foo #f) ; make sure, memoization has been performed
(equal? (procedure-source foo)
'(lambda (x) (if x (+ 1))))))
(pass-if "if #f without else"
(expect-fail "if #f without else"
(let ((foo (lambda () (if #f #f))))
(foo) ; make sure, memoization has been performed
(equal? (procedure-source foo)
@ -527,12 +549,12 @@
(with-test-prefix "missing or extra expressions"
(pass-if-exception "(if)"
exception:missing/extra-expr
exception:generic-syncase-error
(eval '(if)
(interaction-environment)))
(pass-if-exception "(if 1 2 3 4)"
exception:missing/extra-expr
exception:generic-syncase-error
(eval '(if 1 2 3 4)
(interaction-environment)))))
@ -594,78 +616,77 @@
(eq? 'ok (cond (#t identity =>) (else #f)))))
(pass-if-exception "missing recipient"
'(syntax-error . "Missing recipient")
'(syntax-error . "cond: wrong number of receiver expressions")
(cond (#t identity =>)))
(pass-if-exception "extra recipient"
'(syntax-error . "Extra expression")
'(syntax-error . "cond: wrong number of receiver expressions")
(cond (#t identity => identity identity))))
(with-test-prefix "unmemoization"
;; FIXME: the (if #f #f) is a hack!
(pass-if "normal clauses"
(let ((foo (lambda (x) (cond ((= x 1) 'bar) ((= x 2) 'baz)))))
(foo 1) ; make sure, memoization has been performed
(foo 2) ; make sure, memoization has been performed
(let ((foo (lambda () (cond ((= x 1) 'bar) ((= x 2) 'baz)))))
(equal? (procedure-source foo)
'(lambda (x) (cond ((= x 1) 'bar) ((= x 2) 'baz))))))
'(lambda () (if (= x 1) 'bar (if (= x 2) 'baz (if #f #f)))))))
(pass-if "else"
(let ((foo (lambda () (cond (else 'bar)))))
(foo) ; make sure, memoization has been performed
(equal? (procedure-source foo)
'(lambda () (cond (else 'bar))))))
'(lambda () 'bar))))
;; FIXME: the (if #f #f) is a hack!
(pass-if "=>"
(let ((foo (lambda () (cond (#t => identity)))))
(foo) ; make sure, memoization has been performed
(equal? (procedure-source foo)
'(lambda () (cond (#t => identity)))))))
(matches? (procedure-source foo)
(lambda () (let ((_ #t))
(if _ (identity _) (if #f #f))))))))
(with-test-prefix "bad or missing clauses"
(pass-if-exception "(cond)"
exception:missing-clauses
exception:generic-syncase-error
(eval '(cond)
(interaction-environment)))
(pass-if-exception "(cond #t)"
exception:bad-cond-clause
exception:generic-syncase-error
(eval '(cond #t)
(interaction-environment)))
(pass-if-exception "(cond 1)"
exception:bad-cond-clause
exception:generic-syncase-error
(eval '(cond 1)
(interaction-environment)))
(pass-if-exception "(cond 1 2)"
exception:bad-cond-clause
exception:generic-syncase-error
(eval '(cond 1 2)
(interaction-environment)))
(pass-if-exception "(cond 1 2 3)"
exception:bad-cond-clause
exception:generic-syncase-error
(eval '(cond 1 2 3)
(interaction-environment)))
(pass-if-exception "(cond 1 2 3 4)"
exception:bad-cond-clause
exception:generic-syncase-error
(eval '(cond 1 2 3 4)
(interaction-environment)))
(pass-if-exception "(cond ())"
exception:bad-cond-clause
exception:generic-syncase-error
(eval '(cond ())
(interaction-environment)))
(pass-if-exception "(cond () 1)"
exception:bad-cond-clause
exception:generic-syncase-error
(eval '(cond () 1)
(interaction-environment)))
(pass-if-exception "(cond (1) 1)"
exception:bad-cond-clause
exception:generic-syncase-error
(eval '(cond (1) 1)
(interaction-environment))))
@ -683,7 +704,7 @@
(with-test-prefix "case is hygienic"
(pass-if-exception "bound 'else is handled correctly"
exception:bad-case-labels
exception:generic-syncase-error
(eval '(let ((else #f)) (case 1 (else #f)))
(interaction-environment))))
@ -691,79 +712,83 @@
(pass-if "normal clauses"
(let ((foo (lambda (x) (case x ((1) 'bar) ((2) 'baz) (else 'foobar)))))
(foo 1) ; make sure, memoization has been performed
(foo 2) ; make sure, memoization has been performed
(foo 3) ; make sure, memoization has been performed
(equal? (procedure-source foo)
'(lambda (x) (case x ((1) 'bar) ((2) 'baz) (else 'foobar))))))
(matches? (procedure-source foo)
(lambda (_)
(if ((@@ (guile) memv) _ '(1))
'bar
(if ((@@ (guile) memv) _ '(2))
'baz
'foobar))))))
(pass-if "empty labels"
(let ((foo (lambda (x) (case x ((1) 'bar) (() 'baz) (else 'foobar)))))
(foo 1) ; make sure, memoization has been performed
(foo 2) ; make sure, memoization has been performed
(foo 3) ; make sure, memoization has been performed
(equal? (procedure-source foo)
'(lambda (x) (case x ((1) 'bar) (() 'baz) (else 'foobar)))))))
(matches? (procedure-source foo)
(lambda (_)
(if ((@@ (guile) memv) _ '(1))
'bar
(if ((@@ (guile) memv) _ '())
'baz
'foobar)))))))
(with-test-prefix "bad or missing clauses"
(pass-if-exception "(case)"
exception:missing-clauses
exception:generic-syncase-error
(eval '(case)
(interaction-environment)))
(pass-if-exception "(case . \"foo\")"
exception:bad-expression
exception:generic-syncase-error
(eval '(case . "foo")
(interaction-environment)))
(pass-if-exception "(case 1)"
exception:missing-clauses
exception:generic-syncase-error
(eval '(case 1)
(interaction-environment)))
(pass-if-exception "(case 1 . \"foo\")"
exception:bad-expression
exception:generic-syncase-error
(eval '(case 1 . "foo")
(interaction-environment)))
(pass-if-exception "(case 1 \"foo\")"
exception:bad-case-clause
exception:generic-syncase-error
(eval '(case 1 "foo")
(interaction-environment)))
(pass-if-exception "(case 1 ())"
exception:bad-case-clause
exception:generic-syncase-error
(eval '(case 1 ())
(interaction-environment)))
(pass-if-exception "(case 1 (\"foo\"))"
exception:bad-case-clause
exception:generic-syncase-error
(eval '(case 1 ("foo"))
(interaction-environment)))
(pass-if-exception "(case 1 (\"foo\" \"bar\"))"
exception:bad-case-labels
exception:generic-syncase-error
(eval '(case 1 ("foo" "bar"))
(interaction-environment)))
(pass-if-exception "(case 1 ((2) \"bar\") . \"foo\")"
exception:bad-expression
exception:generic-syncase-error
(eval '(case 1 ((2) "bar") . "foo")
(interaction-environment)))
(pass-if-exception "(case 1 ((2) \"bar\") (else))"
exception:bad-case-clause
exception:generic-syncase-error
(eval '(case 1 ((2) "bar") (else))
(interaction-environment)))
(pass-if-exception "(case 1 (else #f) . \"foo\")"
exception:bad-expression
exception:generic-syncase-error
(eval '(case 1 (else #f) . "foo")
(interaction-environment)))
(pass-if-exception "(case 1 (else #f) ((1) #t))"
exception:misplaced-else-clause
exception:generic-syncase-error
(eval '(case 1 (else #f) ((1) #t))
(interaction-environment)))))
@ -780,14 +805,6 @@
(eval '(define round round) m)
(eq? (module-ref m 'round) round)))
(with-test-prefix "currying"
(pass-if "(define ((foo)) #f)"
(eval '(begin
(define ((foo)) #t)
((foo)))
(interaction-environment))))
(with-test-prefix "unmemoization"
(pass-if "definition unmemoized without prior execution"
@ -809,7 +826,7 @@
(with-test-prefix "missing or extra expressions"
(pass-if-exception "(define)"
exception:missing-expr
exception:generic-syncase-error
(eval '(define)
(interaction-environment)))))
@ -886,34 +903,10 @@
'ok)
(bar))
(foo)
(equal?
(matches?
(procedure-source foo)
'(lambda () (letrec ((bar (lambda () (quote ok)))) (bar)))))
(interaction-environment))))
(with-test-prefix "do"
(with-test-prefix "unmemoization"
(pass-if "normal case"
(let ((foo (lambda () (do ((i 1 (+ i 1)) (j 2))
((> i 9) (+ i j))
(identity i)))))
(foo) ; make sure, memoization has been performed
(equal? (procedure-source foo)
'(lambda () (do ((i 1 (+ i 1)) (j 2))
((> i 9) (+ i j))
(identity i))))))
(pass-if "reduced case"
(let ((foo (lambda () (do ((i 1 (+ i 1)) (j 2 j)) ; redundant step for j
((> i 9) (+ i j))
(identity i)))))
(foo) ; make sure, memoization has been performed
(equal? (procedure-source foo)
'(lambda () (do ((i 1 (+ i 1)) (j 2)) ; no redundancy here
((> i 9) (+ i j))
(identity i))))))))
(lambda () (letrec ((_ (lambda () (quote ok)))) (_)))))
(current-module))))
(with-test-prefix "set!"
@ -922,50 +915,50 @@
(pass-if "normal set!"
(let ((foo (lambda (x) (set! x (+ 1 x)))))
(foo 1) ; make sure, memoization has been performed
(equal? (procedure-source foo)
'(lambda (x) (set! x (+ 1 x)))))))
(matches? (procedure-source foo)
(lambda (_) (set! _ (+ 1 _)))))))
(with-test-prefix "missing or extra expressions"
(pass-if-exception "(set!)"
exception:missing/extra-expr
exception:bad-set!
(eval '(set!)
(interaction-environment)))
(pass-if-exception "(set! 1)"
exception:missing/extra-expr
exception:bad-set!
(eval '(set! 1)
(interaction-environment)))
(pass-if-exception "(set! 1 2 3)"
exception:missing/extra-expr
exception:bad-set!
(eval '(set! 1 2 3)
(interaction-environment))))
(with-test-prefix "bad variable"
(pass-if-exception "(set! \"\" #t)"
exception:bad-variable
exception:bad-set!
(eval '(set! "" #t)
(interaction-environment)))
(pass-if-exception "(set! 1 #t)"
exception:bad-variable
exception:bad-set!
(eval '(set! 1 #t)
(interaction-environment)))
(pass-if-exception "(set! #t #f)"
exception:bad-variable
exception:bad-set!
(eval '(set! #t #f)
(interaction-environment)))
(pass-if-exception "(set! #f #t)"
exception:bad-variable
exception:bad-set!
(eval '(set! #f #t)
(interaction-environment)))
(pass-if-exception "(set! #\\space #f)"
exception:bad-variable
exception:bad-set!
(eval '(set! #\space #f)
(interaction-environment)))))
@ -974,12 +967,12 @@
(with-test-prefix "missing or extra expression"
(pass-if-exception "(quote)"
exception:missing/extra-expr
exception:bad-quote
(eval '(quote)
(interaction-environment)))
(pass-if-exception "(quote a b)"
exception:missing/extra-expr
exception:bad-quote
(eval '(quote a b)
(interaction-environment)))))
@ -1010,46 +1003,27 @@
(do ((n 0 (1+ n)))
((> n 5))
(pass-if n
(let ((cond (make-iterations-cond n)))
(while (cond)))
#t)))
(eval `(letrec ((make-iterations-cond
(lambda (n)
(lambda ()
(cond ((not n)
(error "oops, condition re-tested after giving false"))
((= 0 n)
(set! n #f)
#f)
(else
(set! n (1- n))
#t))))))
(let ((cond (make-iterations-cond ,n)))
(while (cond))
#t))
(interaction-environment)))))
(pass-if "initially false"
(while #f
(unreachable))
#t)
(with-test-prefix "in empty environment"
;; an environment with no bindings at all
(define empty-environment
(make-module 1))
;; these tests are 'unresolved because to work with ice-9 syncase it was
;; necessary to drop the unquote from `do' in the implementation, and
;; unfortunately that makes `while' depend on its evaluation environment
(pass-if "empty body"
(throw 'unresolved)
(eval `(,while #f)
empty-environment)
#t)
(pass-if "initially false"
(throw 'unresolved)
(eval `(,while #f
#f)
empty-environment)
#t)
(pass-if "iterating"
(throw 'unresolved)
(let ((cond (make-iterations-cond 3)))
(eval `(,while (,cond)
123 456)
empty-environment))
#t))
(with-test-prefix "iterations"
(do ((n 0 (1+ n)))
((> n 5))
@ -1063,8 +1037,9 @@
(with-test-prefix "break"
(pass-if-exception "too many args" exception:wrong-num-args
(while #t
(break 1)))
(eval '(while #t
(break 1))
(interaction-environment)))
(with-test-prefix "from cond"
(pass-if "first"
@ -1135,8 +1110,9 @@
(with-test-prefix "continue"
(pass-if-exception "too many args" exception:wrong-num-args
(while #t
(continue 1)))
(eval '(while #t
(continue 1))
(interaction-environment)))
(with-test-prefix "from cond"
(do ((n 0 (1+ n)))

67
test-suite/tests/threads.test
View file

@ -21,6 +21,20 @@
:use-module (ice-9 threads)
:use-module (test-suite lib))
(define (asyncs-still-working?)
(let ((a #f))
(system-async-mark (lambda ()
(set! a #t)))
;; The point of the following (equal? ...) is to go through
;; primitive code (scm_equal_p) that includes a SCM_TICK call and
;; hence gives system asyncs a chance to run. Of course the
;; evaluator (eval.i.c) also calls SCM_TICK regularly, but in the
;; near future we may be using the VM instead of the traditional
;; compiler, and then we will still want asyncs-still-working? to
;; work. (The VM should probably have SCM_TICK calls too, but
;; let's not rely on that here.)
(equal? '(a b c) '(a b c))
a))
(if (provided? 'threads)
(begin
@ -101,6 +115,9 @@
(with-test-prefix "n-for-each-par-map"
(pass-if "asyncs are still working 2"
(asyncs-still-working?))
(pass-if "0 in limit 10"
(n-for-each-par-map 10 noop noop '())
#t)
@ -143,12 +160,18 @@
(with-test-prefix "lock-mutex"
(pass-if "asyncs are still working 3"
(asyncs-still-working?))
(pass-if "timed locking fails if timeout exceeded"
(let ((m (make-mutex)))
(lock-mutex m)
(let ((t (begin-thread (lock-mutex m (+ (current-time) 1)))))
(not (join-thread t)))))
(pass-if "asyncs are still working 6"
(asyncs-still-working?))
(pass-if "timed locking succeeds if mutex unlocked within timeout"
(let* ((m (make-mutex))
(c (make-condition-variable))
@ -164,7 +187,12 @@
(unlock-mutex cm)
(sleep 1)
(unlock-mutex m)
(join-thread t)))))
(join-thread t))))
(pass-if "asyncs are still working 7"
(asyncs-still-working?))
)
;;
;; timed mutex unlocking
@ -172,12 +200,18 @@
(with-test-prefix "unlock-mutex"
(pass-if "asyncs are still working 5"
(asyncs-still-working?))
(pass-if "timed unlocking returns #f if timeout exceeded"
(let ((m (make-mutex))
(c (make-condition-variable)))
(lock-mutex m)
(not (unlock-mutex m c (current-time)))))
(pass-if "asyncs are still working 4"
(asyncs-still-working?))
(pass-if "timed unlocking returns #t if condition signaled"
(let ((m1 (make-mutex))
(m2 (make-mutex))
@ -226,7 +260,36 @@
(pass-if "timed joining succeeds if thread exits within timeout"
(let ((t (begin-thread (begin (sleep 1) #t))))
(join-thread t (+ (current-time) 2)))))
(join-thread t (+ (current-time) 2))))
(pass-if "asyncs are still working 1"
(asyncs-still-working?))
;; scm_join_thread_timed has a SCM_TICK in the middle of it,
;; to allow asyncs to run (including signal delivery). We
;; used to have a bug whereby if the joined thread terminated
;; at the same time as the joining thread is in this SCM_TICK,
;; scm_join_thread_timed would not notice and would hang
;; forever. So in this test we are setting up the following
;; sequence of events.
;; T=0 other thread is created and starts running
;; T=2 main thread sets up an async that will sleep for 10 seconds
;; T=2 main thread calls join-thread, which will...
;; T=2 ...call the async, which starts sleeping
;; T=5 other thread finishes its work and terminates
;; T=7 async completes, main thread continues inside join-thread.
(pass-if "don't hang when joined thread terminates in SCM_TICK"
(let ((other-thread (make-thread sleep 5)))
(letrec ((delay-count 10)
(aproc (lambda ()
(set! delay-count (- delay-count 1))
(if (zero? delay-count)
(sleep 5)
(system-async-mark aproc)))))
(sleep 2)
(system-async-mark aproc)
(join-thread other-thread)))
#t))
;;
;; thread cancellation

467
test-suite/tests/tree-il.test Normal file
View file

@ -0,0 +1,467 @@
;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*-
;;;; Andy Wingo <wingo@pobox.com> --- May 2009
;;;;
;;;; Copyright (C) 2009 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 2.1 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 tree-il)
#:use-module (test-suite lib)
#:use-module (system base compile)
#:use-module (system base pmatch)
#:use-module (language tree-il)
#:use-module (language glil))
;; Of course, the GLIL that is emitted depends on the source info of the
;; input. Here we're not concerned about that, so we strip source
;; information from the incoming tree-il.
(define (strip-source x)
(post-order! (lambda (x) (set! (tree-il-src x) #f))
x))
(define-syntax assert-scheme->glil
(syntax-rules ()
((_ in out)
(let ((tree-il (strip-source
(compile 'in #:from 'scheme #:to 'tree-il))))
(pass-if 'in
(equal? (unparse-glil (compile tree-il #:from 'tree-il #:to 'glil))
'out))))))
(define-syntax assert-tree-il->glil
(syntax-rules ()
((_ in out)
(pass-if 'in
(let ((tree-il (strip-source (parse-tree-il 'in))))
(equal? (unparse-glil (compile tree-il #:from 'tree-il #:to 'glil))
'out))))))
(define-syntax assert-tree-il->glil/pmatch
(syntax-rules ()
((_ in pat test ...)
(let ((exp 'in))
(pass-if 'in
(let ((glil (unparse-glil
(compile (strip-source (parse-tree-il exp))
#:from 'tree-il #:to 'glil))))
(pmatch glil
(pat (guard test ...) #t)
(else #f))))))))
(with-test-prefix "void"
(assert-tree-il->glil
(void)
(program 0 0 0 0 () (void) (call return 1)))
(assert-tree-il->glil
(begin (void) (const 1))
(program 0 0 0 0 () (const 1) (call return 1)))
(assert-tree-il->glil
(apply (primitive +) (void) (const 1))
(program 0 0 0 0 () (void) (const 1) (call add 2) (call return 1))))
(with-test-prefix "application"
(assert-tree-il->glil
(apply (toplevel foo) (const 1))
(program 0 0 0 0 () (toplevel ref foo) (const 1) (call goto/args 1)))
(assert-tree-il->glil/pmatch
(begin (apply (toplevel foo) (const 1)) (void))
(program 0 0 0 0 () (toplevel ref foo) (const 1) (mv-call 1 ,l1)
(call drop 1) (branch br ,l2)
(label ,l3) (mv-bind () #f) (unbind)
(label ,l4)
(void) (call return 1))
(and (eq? l1 l3) (eq? l2 l4)))
(assert-tree-il->glil
(apply (toplevel foo) (apply (toplevel bar)))
(program 0 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call call 0)
(call goto/args 1))))
(with-test-prefix "conditional"
(assert-tree-il->glil/pmatch
(if (const #t) (const 1) (const 2))
(program 0 0 0 0 () (const #t) (branch br-if-not ,l1)
(const 1) (call return 1)
(label ,l2) (const 2) (call return 1))
(eq? l1 l2))
(assert-tree-il->glil/pmatch
(begin (if (const #t) (const 1) (const 2)) (const #f))
(program 0 0 0 0 () (const #t) (branch br-if-not ,l1) (branch br ,l2)
(label ,l3) (label ,l4) (const #f) (call return 1))
(eq? l1 l3) (eq? l2 l4))
(assert-tree-il->glil/pmatch
(apply (primitive null?) (if (const #t) (const 1) (const 2)))
(program 0 0 0 0 () (const #t) (branch br-if-not ,l1)
(const 1) (branch br ,l2)
(label ,l3) (const 2) (label ,l4)
(call null? 1) (call return 1))
(eq? l1 l3) (eq? l2 l4)))
(with-test-prefix "primitive-ref"
(assert-tree-il->glil
(primitive +)
(program 0 0 0 0 () (toplevel ref +) (call return 1)))
(assert-tree-il->glil
(begin (primitive +) (const #f))
(program 0 0 0 0 () (const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (primitive +))
(program 0 0 0 0 () (toplevel ref +) (call null? 1)
(call return 1))))
(with-test-prefix "lexical refs"
(assert-tree-il->glil
(let (x) (y) ((const 1)) (lexical x y))
(program 0 0 1 0 ()
(const 1) (bind (x local 0)) (local set 0)
(local ref 0) (call return 1)
(unbind)))
(assert-tree-il->glil
(let (x) (y) ((const 1)) (begin (lexical x y) (const #f)))
(program 0 0 1 0 ()
(const 1) (bind (x local 0)) (local set 0)
(const #f) (call return 1)
(unbind)))
(assert-tree-il->glil
(let (x) (y) ((const 1)) (apply (primitive null?) (lexical x y)))
(program 0 0 1 0 ()
(const 1) (bind (x local 0)) (local set 0)
(local ref 0) (call null? 1) (call return 1)
(unbind))))
(with-test-prefix "lexical sets"
(assert-tree-il->glil
(let (x) (y) ((const 1)) (set! (lexical x y) (const 2)))
(program 0 0 0 1 ()
(const 1) (bind (x external 0)) (external set 0 0)
(const 2) (external set 0 0) (void) (call return 1)
(unbind)))
(assert-tree-il->glil
(let (x) (y) ((const 1)) (begin (set! (lexical x y) (const 2)) (const #f)))
(program 0 0 0 1 ()
(const 1) (bind (x external 0)) (external set 0 0)
(const 2) (external set 0 0) (const #f) (call return 1)
(unbind)))
(assert-tree-il->glil
(let (x) (y) ((const 1))
(apply (primitive null?) (set! (lexical x y) (const 2))))
(program 0 0 0 1 ()
(const 1) (bind (x external 0)) (external set 0 0)
(const 2) (external set 0 0) (void) (call null? 1) (call return 1)
(unbind))))
(with-test-prefix "module refs"
(assert-tree-il->glil
(@ (foo) bar)
(program 0 0 0 0 ()
(module public ref (foo) bar)
(call return 1)))
(assert-tree-il->glil
(begin (@ (foo) bar) (const #f))
(program 0 0 0 0 ()
(module public ref (foo) bar) (call drop 1)
(const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (@ (foo) bar))
(program 0 0 0 0 ()
(module public ref (foo) bar)
(call null? 1) (call return 1)))
(assert-tree-il->glil
(@@ (foo) bar)
(program 0 0 0 0 ()
(module private ref (foo) bar)
(call return 1)))
(assert-tree-il->glil
(begin (@@ (foo) bar) (const #f))
(program 0 0 0 0 ()
(module private ref (foo) bar) (call drop 1)
(const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (@@ (foo) bar))
(program 0 0 0 0 ()
(module private ref (foo) bar)
(call null? 1) (call return 1))))
(with-test-prefix "module sets"
(assert-tree-il->glil
(set! (@ (foo) bar) (const 2))
(program 0 0 0 0 ()
(const 2) (module public set (foo) bar)
(void) (call return 1)))
(assert-tree-il->glil
(begin (set! (@ (foo) bar) (const 2)) (const #f))
(program 0 0 0 0 ()
(const 2) (module public set (foo) bar)
(const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (set! (@ (foo) bar) (const 2)))
(program 0 0 0 0 ()
(const 2) (module public set (foo) bar)
(void) (call null? 1) (call return 1)))
(assert-tree-il->glil
(set! (@@ (foo) bar) (const 2))
(program 0 0 0 0 ()
(const 2) (module private set (foo) bar)
(void) (call return 1)))
(assert-tree-il->glil
(begin (set! (@@ (foo) bar) (const 2)) (const #f))
(program 0 0 0 0 ()
(const 2) (module private set (foo) bar)
(const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (set! (@@ (foo) bar) (const 2)))
(program 0 0 0 0 ()
(const 2) (module private set (foo) bar)
(void) (call null? 1) (call return 1))))
(with-test-prefix "toplevel refs"
(assert-tree-il->glil
(toplevel bar)
(program 0 0 0 0 ()
(toplevel ref bar)
(call return 1)))
(assert-tree-il->glil
(begin (toplevel bar) (const #f))
(program 0 0 0 0 ()
(toplevel ref bar) (call drop 1)
(const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (toplevel bar))
(program 0 0 0 0 ()
(toplevel ref bar)
(call null? 1) (call return 1))))
(with-test-prefix "toplevel sets"
(assert-tree-il->glil
(set! (toplevel bar) (const 2))
(program 0 0 0 0 ()
(const 2) (toplevel set bar)
(void) (call return 1)))
(assert-tree-il->glil
(begin (set! (toplevel bar) (const 2)) (const #f))
(program 0 0 0 0 ()
(const 2) (toplevel set bar)
(const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (set! (toplevel bar) (const 2)))
(program 0 0 0 0 ()
(const 2) (toplevel set bar)
(void) (call null? 1) (call return 1))))
(with-test-prefix "toplevel defines"
(assert-tree-il->glil
(define bar (const 2))
(program 0 0 0 0 ()
(const 2) (toplevel define bar)
(void) (call return 1)))
(assert-tree-il->glil
(begin (define bar (const 2)) (const #f))
(program 0 0 0 0 ()
(const 2) (toplevel define bar)
(const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (define bar (const 2)))
(program 0 0 0 0 ()
(const 2) (toplevel define bar)
(void) (call null? 1) (call return 1))))
(with-test-prefix "constants"
(assert-tree-il->glil
(const 2)
(program 0 0 0 0 ()
(const 2) (call return 1)))
(assert-tree-il->glil
(begin (const 2) (const #f))
(program 0 0 0 0 ()
(const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (const 2))
(program 0 0 0 0 ()
(const 2) (call null? 1) (call return 1))))
(with-test-prefix "lambda"
(assert-tree-il->glil
(lambda (x) (y) () (const 2))
(program 0 0 0 0 ()
(program 1 0 0 0 ()
(bind (x local 0))
(const 2) (call return 1))
(call return 1)))
(assert-tree-il->glil
(lambda (x x1) (y y1) () (const 2))
(program 0 0 0 0 ()
(program 2 0 0 0 ()
(bind (x local 0) (x1 local 1))
(const 2) (call return 1))
(call return 1)))
(assert-tree-il->glil
(lambda x y () (const 2))
(program 0 0 0 0 ()
(program 1 1 0 0 ()
(bind (x local 0))
(const 2) (call return 1))
(call return 1)))
(assert-tree-il->glil
(lambda (x . x1) (y . y1) () (const 2))
(program 0 0 0 0 ()
(program 2 1 0 0 ()
(bind (x local 0) (x1 local 1))
(const 2) (call return 1))
(call return 1)))
(assert-tree-il->glil
(lambda (x . x1) (y . y1) () (lexical x y))
(program 0 0 0 0 ()
(program 2 1 0 0 ()
(bind (x local 0) (x1 local 1))
(local ref 0) (call return 1))
(call return 1)))
(assert-tree-il->glil
(lambda (x . x1) (y . y1) () (lexical x1 y1))
(program 0 0 0 0 ()
(program 2 1 0 0 ()
(bind (x local 0) (x1 local 1))
(local ref 1) (call return 1))
(call return 1)))
(assert-tree-il->glil
(lambda (x) (x1) () (lambda (y) (y1) () (lexical x x1)))
(program 0 0 0 0 ()
(program 1 0 0 1 ()
(bind (x external 0))
(local ref 0) (external set 0 0)
(program 1 0 0 0 ()
(bind (y local 0))
(external ref 1 0) (call return 1))
(call return 1))
(call return 1))))
(with-test-prefix "sequence"
(assert-tree-il->glil
(begin (begin (const 2) (const #f)) (const #t))
(program 0 0 0 0 ()
(const #t) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (begin (const #f) (const 2)))
(program 0 0 0 0 ()
(const 2) (call null? 1) (call return 1))))
;; FIXME: binding info for or-hacked locals might bork the disassembler,
;; and could be tightened in any case
(with-test-prefix "the or hack"
(assert-tree-il->glil/pmatch
(let (x) (y) ((const 1))
(if (lexical x y)
(lexical x y)
(let (a) (b) ((const 2))
(lexical a b))))
(program 0 0 1 0 ()
(const 1) (bind (x local 0)) (local set 0)
(local ref 0) (branch br-if-not ,l1)
(local ref 0) (call return 1)
(label ,l2)
(const 2) (bind (a local 0)) (local set 0)
(local ref 0) (call return 1)
(unbind)
(unbind))
(eq? l1 l2))
(assert-tree-il->glil/pmatch
(let (x) (y) ((const 1))
(if (lexical x y)
(lexical x y)
(let (a) (b) ((const 2))
(lexical x y))))
(program 0 0 2 0 ()
(const 1) (bind (x local 0)) (local set 0)
(local ref 0) (branch br-if-not ,l1)
(local ref 0) (call return 1)
(label ,l2)
(const 2) (bind (a local 1)) (local set 1)
(local ref 0) (call return 1)
(unbind)
(unbind))
(eq? l1 l2)))
(with-test-prefix "apply"
(assert-tree-il->glil
(apply (primitive @apply) (toplevel foo) (toplevel bar))
(program 0 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call goto/apply 2)))
(assert-tree-il->glil/pmatch
(begin (apply (primitive @apply) (toplevel foo) (toplevel bar)) (void))
(program 0 0 0 0 ()
(toplevel ref apply) (toplevel ref foo) (toplevel ref bar) (mv-call 2 ,l1)
(call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind)
(label ,l4)
(void) (call return 1))
(and (eq? l1 l3) (eq? l2 l4)))
(assert-tree-il->glil
(apply (toplevel foo) (apply (toplevel @apply) (toplevel bar) (toplevel baz)))
(program 0 0 0 0 ()
(toplevel ref foo)
(toplevel ref bar) (toplevel ref baz) (call apply 2)
(call goto/args 1))))
(with-test-prefix "call/cc"
(assert-tree-il->glil
(apply (primitive @call-with-current-continuation) (toplevel foo))
(program 0 0 0 0 () (toplevel ref foo) (call goto/cc 1)))
(assert-tree-il->glil/pmatch
(begin (apply (primitive @call-with-current-continuation) (toplevel foo)) (void))
(program 0 0 0 0 ()
(toplevel ref call-with-current-continuation) (toplevel ref foo) (mv-call 1 ,l1)
(call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind)
(label ,l4)
(void) (call return 1))
(and (eq? l1 l3) (eq? l2 l4)))
(assert-tree-il->glil
(apply (toplevel foo)
(apply (toplevel @call-with-current-continuation) (toplevel bar)))
(program 0 0 0 0 ()
(toplevel ref foo)
(toplevel ref bar) (call call/cc 1)
(call goto/args 1))))