suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Better output: using quiet.ss will show nothing except for section

Browse Source 
headers and errors (if any).  Also, using quiet.ss will exit with an
error code if there were errors.

svn: r3655
This commit is contained in:
Eli Barzilay 2006-07-07 23:46:35 +00:00
parent 66128ed43b
commit bbf54efde9
71 changed files with 207 additions and 217 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/tests/mzscheme/async-channel.ss
View File

@ -4,7 +4,7 @@
(require (lib "async-channel.ss")) (require (lib "async-channel.ss"))
(SECTION 'async-channel) (Section 'async-channel)
(arity-test make-async-channel 0 1) (arity-test make-async-channel 0 1)
(err/rt-test (make-async-channel 0) exn?) (err/rt-test (make-async-channel 0) exn?)

2
collects/tests/mzscheme/awk.ss
View File

@ -1,7 +1,7 @@
(load-relative "loadtest.ss") (load-relative "loadtest.ss")
(SECTION 'awk) (Section 'awk)
(require (lib "awk.ss")) (require (lib "awk.ss"))

26
collects/tests/mzscheme/basic.ss
View File

@ -17,10 +17,10 @@
(let ([f (lambda () #&7)]) (let ([f (lambda () #&7)])
(test #t eq? (f) (f))) (test #t eq? (f) (f)))
(SECTION 2 1);; test that all symbol characters are supported. (Section 2 1);; test that all symbol characters are supported.
'(+ - ... !.. $.+ %.- &.! *.: /:. :+. <-. =. >. ?. ~. _. ^.) '(+ - ... !.. $.+ %.- &.! *.: /:. :+. <-. =. >. ?. ~. _. ^.)
(SECTION 3 4) (Section 3 4)
(define disjoint-type-functions (define disjoint-type-functions
(list boolean? char? null? number? pair? procedure? string? symbol? vector?)) (list boolean? char? null? number? pair? procedure? string? symbol? vector?))
(define type-examples (define type-examples
@ -41,7 +41,7 @@
t)) t))
type-examples)) type-examples))
(SECTION 6 1) (Section 6 1)
(test #f not #t) (test #f not #t)
(test #f not 3) (test #f not 3)
(test #f not (list 3)) (test #f not (list 3))
@ -57,7 +57,7 @@
(test #f boolean? '()) (test #f boolean? '())
(arity-test boolean? 1 1) (arity-test boolean? 1 1)
(SECTION 6 2) (Section 6 2)
(test #t eqv? 'a 'a) (test #t eqv? 'a 'a)
(test #f eqv? 'a 'b) (test #f eqv? 'a 'b)
(test #t eqv? 2 2) (test #t eqv? 2 2)
@ -118,7 +118,7 @@
(arity-test eqv? 2 2) (arity-test eqv? 2 2)
(arity-test equal? 2 2) (arity-test equal? 2 2)
(SECTION 6 3) (Section 6 3)
(test '(a b c d e) 'dot '(a . (b . (c . (d . (e . ())))))) (test '(a b c d e) 'dot '(a . (b . (c . (d . (e . ()))))))
(define x (list 'a 'b 'c)) (define x (list 'a 'b 'c))
(define y x) (define y x)
@ -350,7 +350,7 @@
(test #t immutable? (string->immutable-string "hi")) (test #t immutable? (string->immutable-string "hi"))
(test #t immutable? (string->immutable-string (string-copy "hi"))) (test #t immutable? (string->immutable-string (string-copy "hi")))
(SECTION 6 4) (Section 6 4)
(test #t symbol? 'foo) (test #t symbol? 'foo)
(test #t symbol? (car '(a b))) (test #t symbol? (car '(a b)))
(test #f symbol? "bar") (test #f symbol? "bar")
@ -399,7 +399,7 @@
(arity-test symbol? 1 1) (arity-test symbol? 1 1)
(SECTION 6 6) (Section 6 6)
(define (char-tests) (define (char-tests)
(test #t eqv? '#\ #\Space) (test #t eqv? '#\ #\Space)
@ -649,7 +649,7 @@
(test-up/down char-upcase 'char-upcase lowers (map cons lowers uppers)) (test-up/down char-upcase 'char-upcase lowers (map cons lowers uppers))
(test-up/down char-downcase 'char-downcase uppers (map cons uppers lowers)) (test-up/down char-downcase 'char-downcase uppers (map cons uppers lowers))
(SECTION 6 7) (Section 6 7)
(test #t string? "The word \"recursion\\\" has many meanings.") (test #t string? "The word \"recursion\\\" has many meanings.")
(test #t string? "") (test #t string? "")
(arity-test string? 1 1) (arity-test string? 1 1)
@ -1265,7 +1265,7 @@
(arity-test regexp-replace 3 3) (arity-test regexp-replace 3 3)
(arity-test regexp-replace* 3 3) (arity-test regexp-replace* 3 3)
(SECTION 6 8) (Section 6 8)
(test #t vector? '#(0 (2 2 2 2) "Anna")) (test #t vector? '#(0 (2 2 2 2) "Anna"))
(test #t vector? '#()) (test #t vector? '#())
(arity-test vector? 1 1) (arity-test vector? 1 1)
@ -1311,7 +1311,7 @@
(arity-test vector-fill! 2 2) (arity-test vector-fill! 2 2)
(err/rt-test (vector-fill! '(1 2 3) 0)) (err/rt-test (vector-fill! '(1 2 3) 0))
(SECTION 6 9) (Section 6 9)
(test #t procedure? car) (test #t procedure? car)
(test #f procedure? 'car) (test #f procedure? 'car)
(test #t procedure? (lambda (x) (* x x))) (test #t procedure? (lambda (x) (* x x)))
@ -1436,7 +1436,7 @@
(define (test-cont) (define (test-cont)
(newline) (newline)
(display ";testing continuations; ") (display ";testing continuations; ")
(SECTION 6 9) (Section 6 9)
(test #t leaf-eq? '(a (b (c))) '((a) b c)) (test #t leaf-eq? '(a (b (c))) '((a) b c))
(test #f leaf-eq? '(a (b (c))) '((a) b c d)) (test #f leaf-eq? '(a (b (c))) '((a) b c d))
'(report-errs)) '(report-errs))
@ -1776,7 +1776,7 @@
(newline) (newline)
(display ";testing scheme 4 functions; ") (display ";testing scheme 4 functions; ")
(SECTION 6 7) (Section 6 7)
(test '(#\P #\space #\l) string->list "P l") (test '(#\P #\space #\l) string->list "P l")
(test '() string->list "") (test '() string->list "")
(test "1\\\"" list->string '(#\1 #\\ #\")) (test "1\\\"" list->string '(#\1 #\\ #\"))
@ -1787,7 +1787,7 @@
(err/rt-test (list->string 'hello)) (err/rt-test (list->string 'hello))
(err/rt-test (list->string '(#\h . #\e))) (err/rt-test (list->string '(#\h . #\e)))
(err/rt-test (list->string '(#\h 1 #\e))) (err/rt-test (list->string '(#\h 1 #\e)))
(SECTION 6 8) (Section 6 8)
(test '(dah dah didah) vector->list '#(dah dah didah)) (test '(dah dah didah) vector->list '#(dah dah didah))
(test '() vector->list '#()) (test '() vector->list '#())
(test '#(dididit dah) list->vector '(dididit dah)) (test '#(dididit dah) list->vector '(dididit dah))

2
collects/tests/mzscheme/boundmap-test.ss
View File

@ -2,7 +2,7 @@
(require (lib "boundmap.ss" "syntax")) (require (lib "boundmap.ss" "syntax"))
(SECTION 'BOUNDMAP) (Section 'boundmap)
(test #t bound-identifier-mapping? (make-bound-identifier-mapping)) (test #t bound-identifier-mapping? (make-bound-identifier-mapping))

2
collects/tests/mzscheme/char-set.ss
View File

@ -1,7 +1,7 @@
(load-relative "loadtest.ss") (load-relative "loadtest.ss")
(SECTION 'char-set/SRFI-14) (Section 'char-set/srfi-14)
(require (lib "char-set.ss" "srfi" "14")) (require (lib "char-set.ss" "srfi" "14"))

2
collects/tests/mzscheme/cmdline.ss
View File

@ -1,7 +1,7 @@
(load-relative "loadtest.ss") (load-relative "loadtest.ss")
(SECTION 'COMMAND-LINE) (Section 'command-line)
(require (lib "cmdline.ss")) (require (lib "cmdline.ss"))

2
collects/tests/mzscheme/compat.ss
View File

@ -2,7 +2,7 @@
(load-relative "loadtest.ss") (load-relative "loadtest.ss")
(SECTION 'compat) (Section 'compat)
(require (lib "compat.ss")) (require (lib "compat.ss"))

2
collects/tests/mzscheme/contmark.ss
View File

@ -4,7 +4,7 @@
(require (lib "unit.ss")) (require (lib "unit.ss"))
(SECTION 'continuation-marks) (Section 'continuation-marks)
(define (extract-current-continuation-marks key) (define (extract-current-continuation-marks key)
(continuation-mark-set->list (current-continuation-marks) key)) (continuation-mark-set->list (current-continuation-marks) key))

2
collects/tests/mzscheme/contract-test.ss
View File

@ -3,7 +3,7 @@
(lib "class.ss") (lib "class.ss")
(lib "etc.ss")) (lib "etc.ss"))
(SECTION 'contract) (Section 'contract)
(parameterize ([error-print-width 200]) (parameterize ([error-print-width 200])
(let () (let ()

2
collects/tests/mzscheme/date.ss
View File

@ -1,7 +1,7 @@
(load-relative "loadtest.ss") (load-relative "loadtest.ss")
(SECTION 'date) (Section 'date)
(require (lib "date.ss")) (require (lib "date.ss"))

2
collects/tests/mzscheme/deep.ss
View File

@ -1,7 +1,7 @@
(load-relative "loadtest.ss") (load-relative "loadtest.ss")
(SECTION 'deep) (Section 'deep)
; Test deep stacks ; Test deep stacks

2
collects/tests/mzscheme/embed.ss
View File

@ -1,7 +1,7 @@
(load-relative "loadtest.ss") (load-relative "loadtest.ss")
(SECTION 'embed) (Section 'embed)
(require (lib "embed.ss" "compiler") (require (lib "embed.ss" "compiler")
(lib "process.ss")) (lib "process.ss"))

2
collects/tests/mzscheme/etc.ss
View File

@ -1,7 +1,7 @@
(load-relative "loadtest.ss") (load-relative "loadtest.ss")
(SECTION 'etc) (Section 'etc)
(require (lib "etc.ss")) (require (lib "etc.ss"))

2
collects/tests/mzscheme/expand.ss
View File

@ -6,7 +6,7 @@
;; test that expansion preserves source location information ;; test that expansion preserves source location information
;; for fully expanded terms ;; for fully expanded terms
(SECTION 'EXPAND) (Section 'expand)
(let () (let ()
(define (compare-expansion stx) (define (compare-expansion stx)

14
collects/tests/mzscheme/file.ss
View File

@ -3,7 +3,7 @@
(define testing.ss (build-path (current-load-relative-directory) "testing.ss")) (define testing.ss (build-path (current-load-relative-directory) "testing.ss"))
(SECTION 6 10 1) (Section 6 10 1)
(test #t input-port? (current-input-port)) (test #t input-port? (current-input-port))
(test #t output-port? (current-output-port)) (test #t output-port? (current-output-port))
(test #t output-port? (current-error-port)) (test #t output-port? (current-error-port))
@ -30,7 +30,7 @@
(err/rt-test (current-input-port (current-output-port))) (err/rt-test (current-input-port (current-output-port)))
(err/rt-test (current-output-port (current-input-port))) (err/rt-test (current-output-port (current-input-port)))
(err/rt-test (current-error-port (current-input-port))) (err/rt-test (current-error-port (current-input-port)))
(SECTION 6 10 2) (Section 6 10 2)
(test #\; peek-char this-file) (test #\; peek-char this-file)
(arity-test peek-char 0 2) (arity-test peek-char 0 2)
(arity-test peek-char-or-special 0 2) (arity-test peek-char-or-special 0 2)
@ -69,7 +69,7 @@
(test display-test-obj read test-file) (test display-test-obj read test-file)
(test load-test-obj read test-file) (test load-test-obj read test-file)
(close-input-port test-file)) (close-input-port test-file))
(SECTION 6 10 3) (Section 6 10 3)
(define write-test-obj (define write-test-obj
'(#t #f #\a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))) '(#t #f #\a () 9739 -3 . #((test) "te \" \" st" "" test #() b c)))
(define display-test-obj (define display-test-obj
@ -1035,11 +1035,11 @@
; -------------------------------------------------- ; --------------------------------------------------
(SECTION 6 10 4) (Section 6 10 4)
(load "tmp1") (load "tmp1")
(test write-test-obj 'load foo) (test write-test-obj 'load foo)
(SECTION 'INEXACT-I/IO) (Section 'inexact-i/io)
(define wto write-test-obj) (define wto write-test-obj)
(define dto display-test-obj) (define dto display-test-obj)
(define lto load-test-obj) (define lto load-test-obj)
@ -1064,7 +1064,7 @@
(define badc-range-start 0) (define badc-range-start 0)
(define badc-range-end 255) (define badc-range-end 255)
(SECTION 'PRINTF) (Section 'printf)
(define (test-format format) (define (test-format format)
(test "~" format "~~") (test "~" format "~~")
(test "hello---~---there" format "~a---~~---~a" "hello" 'there) (test "hello---~---there" format "~a---~~---~a" "hello" 'there)
@ -1305,7 +1305,7 @@
(arity-test udp-send-ready-evt 1 1) (arity-test udp-send-ready-evt 1 1)
(arity-test udp-receive-ready-evt 1 1) (arity-test udp-receive-ready-evt 1 1)
(SECTION 'file-after-udp) (Section 'file-after-udp)
;;---------------------------------------------------------------------- ;;----------------------------------------------------------------------
;; Security guards: ;; Security guards:

2
collects/tests/mzscheme/filelib.ss
View File

@ -1,7 +1,7 @@
(load-relative "loadtest.ss") (load-relative "loadtest.ss")
(SECTION 'file) (Section 'file)
(require (lib "file.ss") (require (lib "file.ss")
(lib "process.ss") (lib "process.ss")

6
collects/tests/mzscheme/foreign-test.ss
View File

@ -1,13 +1,11 @@
(load-relative "loadtest.ss") (load-relative "loadtest.ss")
(SECTION 'foreign) (Section 'foreign)
(require (lib "foreign.ss")) (require (lib "foreign.ss"))
(unsafe!) (unsafe!)
(require (lib "etc.ss"))
(let ([big/little (let ([big/little
(if (system-big-endian?) (lambda (x y) x) (lambda (x y) y))] (if (system-big-endian?) (lambda (x y) x) (lambda (x y) y))]
[p (malloc _int32)]) [p (malloc _int32)])
@ -21,7 +19,7 @@
(test (big/little 3 2) ptr-ref p _int8 2) (test (big/little 3 2) ptr-ref p _int8 2)
(test (big/little 4 1) ptr-ref p _int8 3)) (test (big/little 4 1) ptr-ref p _int8 3))
(require (lib "compile.ss" "dynext") (lib "link.ss" "dynext")) (require (lib "compile.ss" "dynext") (lib "link.ss" "dynext") (lib "etc.ss"))
(let ([c (build-path (this-expression-source-directory) "foreign-test.c")] (let ([c (build-path (this-expression-source-directory) "foreign-test.c")]
[o (build-path (current-directory) "foreign-test.o")] [o (build-path (current-directory) "foreign-test.o")]
[so (build-path (current-directory) "foreign-test.so")]) [so (build-path (current-directory) "foreign-test.so")])

2
collects/tests/mzscheme/function.ss
View File

@ -1,7 +1,7 @@
(load-relative "loadtest.ss") (load-relative "loadtest.ss")
(SECTION 'function) (Section 'function)
(require (lib "list.ss")) (require (lib "list.ss"))
(require (lib "etc.ss")) (require (lib "etc.ss"))

2
collects/tests/mzscheme/imap.ss
View File

@ -8,7 +8,7 @@
(load-relative "loadtest.ss") (load-relative "loadtest.ss")
(SECTION 'imap) (Section 'imap)
(require (lib "mzssl.ss" "openssl") (require (lib "mzssl.ss" "openssl")
(lib "imap.ss" "net") (lib "imap.ss" "net")

2
collects/tests/mzscheme/kw.ss
View File

@ -1,7 +1,7 @@
(load-relative "loadtest.ss") (load-relative "loadtest.ss")
(SECTION 'kw) (Section 'kw)
(require (lib "kw.ss")) (require (lib "kw.ss"))

2
collects/tests/mzscheme/loadtest.ss
View File

@ -1,3 +1,3 @@
(unless (namespace-variable-value 'SECTION #f (lambda () #f)) (unless (namespace-variable-value 'Section #f (lambda () #f))
(load-relative "testing.ss")) (load-relative "testing.ss"))

2
collects/tests/mzscheme/macro.ss
View File

@ -1,7 +1,7 @@
(load-relative "loadtest.ss") (load-relative "loadtest.ss")
(SECTION 'MACRO) (Section 'macro)
(error-test #'(define-syntaxes () (values 1)) exn:application:arity?) (error-test #'(define-syntaxes () (values 1)) exn:application:arity?)
(error-test #'(define-syntaxes () (values 1 2)) exn:application:arity?) (error-test #'(define-syntaxes () (values 1 2)) exn:application:arity?)

2
collects/tests/mzscheme/macrolib.ss
View File

@ -1,7 +1,7 @@
(load-relative "loadtest.ss") (load-relative "loadtest.ss")
(SECTION 'macrolib) (Section 'macrolib)
(require (lib "etc.ss")) (require (lib "etc.ss"))

2
collects/tests/mzscheme/match/match-performance.ss
View File

@ -1,5 +1,5 @@
(load-relative "../loadtest.ss") (load-relative "../loadtest.ss")
(SECTION 'MATCH-PERFORMANCE) (Section 'match-performance)
(require (lib "pretty.ss")) (require (lib "pretty.ss"))
(require-for-syntax (lib "pretty.ss")) (require-for-syntax (lib "pretty.ss"))

2
collects/tests/mzscheme/match/match-test.ss
View File

@ -1,5 +1,5 @@
(load-relative "../loadtest.ss") (load-relative "../loadtest.ss")
(SECTION 'MATCH) (Section 'match)
(require (lib "match.ss")) (require (lib "match.ss"))
;(require "../match.ss") ;(require "../match.ss")

2
collects/tests/mzscheme/match/plt-match-test.ss
View File

@ -1,5 +1,5 @@
(load-relative "../loadtest.ss") (load-relative "../loadtest.ss")
(SECTION 'PLT-MATCH) (Section 'plt-match)
(require (lib "plt-match.ss")) (require (lib "plt-match.ss"))

2
collects/tests/mzscheme/match/rand-list-perf.ss
View File

@ -1,5 +1,5 @@
(load-relative "../loadtest.ss") (load-relative "../loadtest.ss")
(SECTION 'MATCH-PERFORMANCE) (Section 'match-performance)
(require (lib "pretty.ss")) (require (lib "pretty.ss"))
(require-for-syntax (lib "pretty.ss")) (require-for-syntax (lib "pretty.ss"))

2
collects/tests/mzscheme/match/rand-vec-perf.ss
View File

@ -1,5 +1,5 @@
(load-relative "../loadtest.ss") (load-relative "../loadtest.ss")
(SECTION 'MATCH-PERFORMANCE) (Section 'match-performance)
(require (lib "pretty.ss")) (require (lib "pretty.ss"))
(require-for-syntax (lib "pretty.ss")) (require-for-syntax (lib "pretty.ss"))

2
collects/tests/mzscheme/match/short-rand-list.scm
View File

@ -1,5 +1,5 @@
(load-relative "../loadtest.ss") (load-relative "../loadtest.ss")
(SECTION 'MATCH-PERFORMANCE) (Section 'match-performance)
(require (lib "pretty.ss")) (require (lib "pretty.ss"))
(require-for-syntax (lib "pretty.ss")) (require-for-syntax (lib "pretty.ss"))

2
collects/tests/mzscheme/md5.ss
View File

@ -1,7 +1,7 @@
(load-relative "loadtest.ss") (load-relative "loadtest.ss")
(SECTION 'md5) (Section 'md5)
(require (lib "md5.ss")) (require (lib "md5.ss"))

2
collects/tests/mzscheme/moddep.ss
View File

@ -2,7 +2,7 @@
(load-relative "loadtest.ss") (load-relative "loadtest.ss")
(SECTION 'MODDEP) (Section 'moddep)
(require (lib "moddep.ss" "syntax")) (require (lib "moddep.ss" "syntax"))

2
collects/tests/mzscheme/module.ss
View File

@ -1,7 +1,7 @@
(load-relative "loadtest.ss") (load-relative "loadtest.ss")
(SECTION 'module) (Section 'module)
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

4
collects/tests/mzscheme/mzthr.ss
View File

@ -1,8 +1,8 @@
(if (not (defined? 'SECTION)) (if (not (defined? 'Section))
(load-relative "testing.ss")) (load-relative "testing.ss"))
(SECTION 'mzlib-threads) (Section 'mzlib-threads)
(require-library "thread.ss") (require-library "thread.ss")

2
collects/tests/mzscheme/name.ss
View File

@ -6,7 +6,7 @@
(require (lib "class.ss")) (require (lib "class.ss"))
(require (lib "unit.ss")) (require (lib "unit.ss"))
(SECTION 'NAMES) (Section 'names)
(arity-test object-name 1 1) (arity-test object-name 1 1)
(test #f object-name 0) (test #f object-name 0)

2
collects/tests/mzscheme/namespac.ss
View File

@ -1,7 +1,7 @@
(load-relative "loadtest.ss") (load-relative "loadtest.ss")
(SECTION 'namespaces) (Section 'namespaces)
(arity-test eval 1 2) (arity-test eval 1 2)
(arity-test compile 1 1) (arity-test compile 1 1)

14
collects/tests/mzscheme/number.ss
View File

@ -1,9 +1,9 @@
(load-relative "loadtest.ss") (load-relative "loadtest.ss")
(SECTION 'numbers) (Section 'numbers)
(SECTION 6 5 5) (Section 6 5 5)
(test #f number? 'a) (test #f number? 'a)
(test #f complex? 'a) (test #f complex? 'a)
(test #f real? 'a) (test #f real? 'a)
@ -1618,7 +1618,7 @@
(newline) (newline)
(display ";testing inexact numbers; ") (display ";testing inexact numbers; ")
(newline) (newline)
(SECTION 6 5 5) (Section 6 5 5)
(test #t inexact? f3.9) (test #t inexact? f3.9)
(test #f exact? f3.9) (test #f exact? f3.9)
(test #t 'inexact? (inexact? (max f3.9 4))) (test #t 'inexact? (inexact? (max f3.9 4)))
@ -1818,7 +1818,7 @@
(remainder n1 n2))))) (remainder n1 n2)))))
(SECTION 6 5 5) (Section 6 5 5)
(test -2147483648 - 2147483648) (test -2147483648 - 2147483648)
(test 2147483648 - -2147483648) (test 2147483648 - -2147483648)
@ -1843,7 +1843,7 @@
(test #t 'remainder (tb 281474976710655 65535)) (test #t 'remainder (tb 281474976710655 65535))
(test #t 'remainder (tb 281474976710654 65535)) (test #t 'remainder (tb 281474976710654 65535))
(SECTION 6 5 6) (Section 6 5 6)
(test 281474976710655 string->number "281474976710655") (test 281474976710655 string->number "281474976710655")
(test "281474976710655" number->string 281474976710655) (test "281474976710655" number->string 281474976710655)
(test "-4" number->string -4 16) (test "-4" number->string -4 16)
@ -1852,7 +1852,7 @@
(test "30000000" number->string #x30000000 16) (test "30000000" number->string #x30000000 16)
(SECTION 6 5 6) (Section 6 5 6)
(test "0" number->string 0) (test "0" number->string 0)
(test "100" number->string 100) (test "100" number->string 100)
(test "100" number->string 256 16) (test "100" number->string 256 16)
@ -1987,7 +1987,7 @@
(err/rt-test (current-pseudo-random-generator 10)) (err/rt-test (current-pseudo-random-generator 10))
(SECTION 'bignum) (Section 'bignum)
(test #t = 0 0) (test #t = 0 0)
(test #f = 0 (expt 2 32)) (test #f = 0 (expt 2 32))

2
collects/tests/mzscheme/object-old.ss
View File

@ -5,7 +5,7 @@
(require (lib "class.ss")) (require (lib "class.ss"))
(SECTION 'OBJECT) (Section 'object)
(define (stx-test e) (define (stx-test e)
(syntax-test (datum->syntax-object #f e #f))) (syntax-test (datum->syntax-object #f e #f)))

2
collects/tests/mzscheme/object.ss
View File

@ -5,7 +5,7 @@
(require (lib "class.ss")) (require (lib "class.ss"))
(SECTION 'OBJECT) (Section 'object)
;; ------------------------------------------------------------ ;; ------------------------------------------------------------
;; Test syntax errors ;; Test syntax errors

2
collects/tests/mzscheme/oee.ss
View File

@ -1,7 +1,7 @@
; Test the oe extension ; Test the oe extension
(if (not (defined? 'SECTION)) (if (not (defined? 'Section))
(load-relative "testing.ss")) (load-relative "testing.ss"))
(define b1 (class object% () (public [z1 7][z2 8]) (sequence (super-init)))) (define b1 (class object% () (public [z1 7][z2 8]) (sequence (super-init))))

2
collects/tests/mzscheme/openssl.ss
View File

@ -1,7 +1,7 @@
(load-relative "loadtest.ss") (load-relative "loadtest.ss")
(SECTION 'OpenSSL) (Section 'openssl)
(require (lib "mzssl.ss" "openssl")) (require (lib "mzssl.ss" "openssl"))

2
collects/tests/mzscheme/optimize.ss
View File

@ -1,7 +1,7 @@
(load-relative "loadtest.ss") (load-relative "loadtest.ss")
(SECTION 'optimization) (Section 'optimization)
;; Check JIT inlining of primitives: ;; Check JIT inlining of primitives:
(parameterize ([current-namespace (make-namespace)] (parameterize ([current-namespace (make-namespace)]

2
collects/tests/mzscheme/pack.ss
View File

@ -4,7 +4,7 @@
(load-relative "loadtest.ss") (load-relative "loadtest.ss")
(SECTION 'pack) (Section 'pack)
(require (lib "pack.ss" "setup") (require (lib "pack.ss" "setup")
(lib "unpack.ss" "setup") (lib "unpack.ss" "setup")

2
collects/tests/mzscheme/package.ss
View File

@ -3,7 +3,7 @@
(require (lib "package.ss")) (require (lib "package.ss"))
(SECTION 'packages) (Section 'packages)
(define expand-test-use-toplevel? #t) (define expand-test-use-toplevel? #t)

2
collects/tests/mzscheme/param.ss
View File

@ -1,7 +1,7 @@
(load-relative "loadtest.ss") (load-relative "loadtest.ss")
(SECTION 'parameters) (Section 'parameters)
(let ([p (open-output-file "tmp5" 'replace)]) (let ([p (open-output-file "tmp5" 'replace)])
(display (compile '(cons 1 2)) p) (display (compile '(cons 1 2)) p)

2
collects/tests/mzscheme/path.ss
View File

@ -1,7 +1,7 @@
(load-relative "loadtest.ss") (load-relative "loadtest.ss")
(SECTION 'PATH) (Section 'path)
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

2
collects/tests/mzscheme/pconvert.ss
View File

@ -1,7 +1,7 @@
(load-relative "loadtest.ss") (load-relative "loadtest.ss")
(SECTION 'pconvert) (Section 'pconvert)
(require (lib "unit.ss") (require (lib "unit.ss")
(lib "file.ss") (lib "file.ss")

2
collects/tests/mzscheme/port.ss
View File

@ -1,7 +1,7 @@
(load-relative "loadtest.ss") (load-relative "loadtest.ss")
(SECTION 'PORT) (Section 'port)
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Tests for progress events and commits ;; Tests for progress events and commits

2
collects/tests/mzscheme/portlib.ss
View File

@ -1,7 +1,7 @@
(load-relative "loadtest.ss") (load-relative "loadtest.ss")
(SECTION 'port) (Section 'port)
(define SLEEP-TIME 0.1) (define SLEEP-TIME 0.1)

2
collects/tests/mzscheme/pretty.ss
View File

@ -10,7 +10,7 @@
(load-relative "loadtest.ss") (load-relative "loadtest.ss")
(SECTION 'PRETTY) (Section 'pretty)
(require (lib "pretty.ss")) (require (lib "pretty.ss"))

30
collects/tests/mzscheme/quiet.ss
View File

@ -1,17 +1,17 @@
(namespace-variable-value (namespace-variable-value 'quiet-load #f
'quiet-load (lambda ()
#f (namespace-set-variable-value! 'quiet-load
(lambda () (let ([argv (current-command-line-arguments)])
(namespace-set-variable-value! (if (= 1 (vector-length argv)) (vector-ref argv 0) "all.ss")))))
'quiet-load
(let ([argv (current-command-line-arguments)])
(if (= 1 (vector-length argv)) (vector-ref argv 0) "all.ss")))))
(let ([p (make-output-port 'quiet (namespace-variable-value 'real-error-port #f
always-evt (lambda ()
(lambda (str s e nonblock? breakable?) (- e s)) (namespace-set-variable-value! 'real-error-port (current-error-port))))
void)])
(parameterize ([current-output-port p]) (let ([p (make-output-port
(load-relative quiet-load)) 'quiet always-evt (lambda (str s e nonblock? breakable?) (- e s))
(report-errs)) void)])
(parameterize ([current-output-port p] [current-error-port p])
(load-relative quiet-load))
(report-errs #t))

2
collects/tests/mzscheme/read.ss
View File

@ -1,7 +1,7 @@
(load-relative "loadtest.ss") (load-relative "loadtest.ss")
(SECTION 'READING) (Section 'reading)
(define readstr (define readstr
(lambda (s) (lambda (s)
(let* ([o (open-input-string s)] (let* ([o (open-input-string s)]

2
collects/tests/mzscheme/readtable.ss
View File

@ -1,7 +1,7 @@
(load-relative "loadtest.ss") (load-relative "loadtest.ss")
(SECTION 'READTABLE) (Section 'readtable)
(require (rename (lib "port.ss") relocate-input-port relocate-input-port)) (require (rename (lib "port.ss") relocate-input-port relocate-input-port))
(define (shift-rt-port p deltas) (define (shift-rt-port p deltas)

2
collects/tests/mzscheme/restart.ss
View File

@ -3,7 +3,7 @@
(require (lib "restart.ss")) (require (lib "restart.ss"))
(SECTION 'restart) (Section 'restart)
(test #t restart-mzscheme #("ignore-me") values #("-qmv") void) (test #t restart-mzscheme #("ignore-me") values #("-qmv") void)
(let ([test-in-out (let ([test-in-out

2
collects/tests/mzscheme/serialize.ss
View File

@ -2,7 +2,7 @@
(load-relative "loadtest.ss") (load-relative "loadtest.ss")
(SECTION 'serialization) (Section 'serialization)
(require (lib "serialize.ss")) (require (lib "serialize.ss"))

2
collects/tests/mzscheme/shared.ss
View File

@ -1,7 +1,7 @@
(load-relative "loadtest.ss") (load-relative "loadtest.ss")
(SECTION 'shared) (Section 'shared)
(require (lib "shared.ss")) (require (lib "shared.ss"))

2
collects/tests/mzscheme/string.ss
View File

@ -1,7 +1,7 @@
(load-relative "loadtest.ss") (load-relative "loadtest.ss")
(SECTION 'mzlib-string) (Section 'mzlib-string)
(require (lib "string.ss")) (require (lib "string.ss"))

2
collects/tests/mzscheme/struct.ss
View File

@ -1,7 +1,7 @@
(load-relative "loadtest.ss") (load-relative "loadtest.ss")
(SECTION 'STRUCT) (Section 'struct)
(let-values ([(prop:p p? p-ref) (make-struct-type-property 'prop (lambda (x y) (add1 x)))] (let-values ([(prop:p p? p-ref) (make-struct-type-property 'prop (lambda (x y) (add1 x)))]
[(prop:p2 p2? p2-ref) (make-struct-type-property 'prop2)] [(prop:p2 p2? p2-ref) (make-struct-type-property 'prop2)]

2
collects/tests/mzscheme/structlib.ss
View File

@ -1,7 +1,7 @@
(load-relative "loadtest.ss") (load-relative "loadtest.ss")
(SECTION 'structlib) (Section 'structlib)
(require (lib "struct.ss")) (require (lib "struct.ss"))

2
collects/tests/mzscheme/stx.ss
View File

@ -1,7 +1,7 @@
(load-relative "loadtest.ss") (load-relative "loadtest.ss")
(SECTION 'stx) (Section 'stx)
(test #t syntax? (datum->syntax-object #f 'hello #f)) (test #t syntax? (datum->syntax-object #f 'hello #f))

2
collects/tests/mzscheme/subprocess.ss
View File

@ -3,7 +3,7 @@
(require (lib "process.ss")) (require (lib "process.ss"))
(SECTION 'SUBPROCESS) (Section 'subprocess)
(define self (find-executable-path (find-system-path 'exec-file) #f)) (define self (find-executable-path (find-system-path 'exec-file) #f))
(define cat (find-executable-path "cat" #f)) (define cat (find-executable-path "cat" #f))

2
collects/tests/mzscheme/sync.ss
View File

@ -2,7 +2,7 @@
(load-relative "loadtest.ss") (load-relative "loadtest.ss")
(SECTION 'synchronization) (Section 'synchronization)
(define SYNC-SLEEP-DELAY 0.025) (define SYNC-SLEEP-DELAY 0.025)
(define SYNC-BUSY-DELAY 0.1) ; go a little slower to check busy waits (define SYNC-BUSY-DELAY 0.1) ; go a little slower to check busy waits

38
collects/tests/mzscheme/syntax.ss
View File

@ -63,18 +63,18 @@
(test-values '(1 2) (lambda () (with-handlers ([void void]) (test-values '(1 2) (lambda () (with-handlers ([void void])
(values 1 2)))) (values 1 2))))
(SECTION 4 1 2) (Section 4 1 2)
(test '(quote a) 'quote (quote 'a)) (test '(quote a) 'quote (quote 'a))
(test '(quote a) 'quote ''a) (test '(quote a) 'quote ''a)
(syntax-test #'quote) (syntax-test #'quote)
(syntax-test #'(quote)) (syntax-test #'(quote))
(syntax-test #'(quote 1 2)) (syntax-test #'(quote 1 2))
(SECTION 4 1 3) (Section 4 1 3)
(test 12 (if #f + *) 3 4) (test 12 (if #f + *) 3 4)
(syntax-test #'(+ 3 . 4)) (syntax-test #'(+ 3 . 4))
(SECTION 4 1 4) (Section 4 1 4)
(test 8 (lambda (x) (+ x x)) 4) (test 8 (lambda (x) (+ x x)) 4)
(define reverse-subtract (define reverse-subtract
(lambda (x y) (- y x))) (lambda (x y) (- y x)))
@ -174,7 +174,7 @@
(syntax-test #'(case-lambda [(y) 7] [(x x) 8])) (syntax-test #'(case-lambda [(y) 7] [(x x) 8]))
(syntax-test #'(case-lambda [(y) 7] [(x . x) 8])) (syntax-test #'(case-lambda [(y) 7] [(x . x) 8]))
(SECTION 4 1 5) (Section 4 1 5)
(test 'yes 'if (if (> 3 2) 'yes 'no)) (test 'yes 'if (if (> 3 2) 'yes 'no))
(test 'no 'if (if (> 2 3) 'yes 'no)) (test 'no 'if (if (> 2 3) 'yes 'no))
(test '1 'if (if (> 3 2) (- 3 2) (+ 3 2))) (test '1 'if (if (> 3 2) (- 3 2) (+ 3 2)))
@ -214,7 +214,7 @@
(syntax-test #'(unless 1 . 2)) (syntax-test #'(unless 1 . 2))
(error-test #'(unless (values 1 2) 0) arity?) (error-test #'(unless (values 1 2) 0) arity?)
(SECTION 4 1 6) (Section 4 1 6)
(define x 2) (define x 2)
(test 3 'define (+ x 1)) (test 3 'define (+ x 1))
(set! x 4) (set! x 4)
@ -261,7 +261,7 @@
(error-test #'(set! unbound-variable 5) exn:fail:contract:variable?) (error-test #'(set! unbound-variable 5) exn:fail:contract:variable?)
(SECTION 4 2 1) (Section 4 2 1)
(test 'greater 'cond (cond ((> 3 2) 'greater) (test 'greater 'cond (cond ((> 3 2) 'greater)
((< 3 2) 'less))) ((< 3 2) 'less)))
(test 'equal 'cond (cond ((> 3 3) 'greater) (test 'equal 'cond (cond ((> 3 3) 'greater)
@ -355,7 +355,7 @@
(error-test #'(and #t (values 1 2) 8) arity?) (error-test #'(and #t (values 1 2) 8) arity?)
(error-test #'(or #f (values 1 2) 8) arity?) (error-test #'(or #f (values 1 2) 8) arity?)
(SECTION 4 2 2) (Section 4 2 2)
(test 6 'let (let ((x 2) (y 3)) (* x y))) (test 6 'let (let ((x 2) (y 3)) (* x y)))
(test 'second 'let (let ((x 2) (y 3)) (* x y) 'second)) (test 'second 'let (let ((x 2) (y 3)) (* x y) 'second))
(test 6 'let-values (let-values (((x) 2) ((y) 3)) (* x y))) (test 6 'let-values (let-values (((x) 2) ((y) 3)) (* x y)))
@ -538,7 +538,7 @@
(wrap 7 '((begin) (begin) (begin (define x 7) (begin) x))) (wrap 7 '((begin) (begin) (begin (define x 7) (begin) x)))
(wrap 7 '((begin (begin (begin (define x 7) (begin) x)))))) (wrap 7 '((begin (begin (begin (define x 7) (begin) x))))))
(SECTION 4 2 3) (Section 4 2 3)
(define x 0) (define x 0)
(define (test-begin bg nested-bg) (define (test-begin bg nested-bg)
(let* ([make-args (let* ([make-args
@ -615,7 +615,7 @@
(error-test #'(begin (define foo (let/cc k k)) (foo 10)) exn:application:type?) ; not exn:application:continuation? (error-test #'(begin (define foo (let/cc k k)) (foo 10)) exn:application:type?) ; not exn:application:continuation?
(SECTION 4 2 5) (Section 4 2 5)
(define f-check #t) (define f-check #t)
(define f (delay (begin (set! f-check #f) 5))) (define f (delay (begin (set! f-check #f) 5)))
(test #t (lambda () f-check)) (test #t (lambda () f-check))
@ -632,7 +632,7 @@
(syntax-test #'(delay 1 . 2)) (syntax-test #'(delay 1 . 2))
(syntax-test #'(delay 1 2)) (syntax-test #'(delay 1 2))
(SECTION 4 2 6) (Section 4 2 6)
(test '(list 3 4) 'quasiquote `(list ,(+ 1 2) 4)) (test '(list 3 4) 'quasiquote `(list ,(+ 1 2) 4))
(test '(list a (quote a)) 'quasiquote (let ((name 'a)) `(list ,name ',name))) (test '(list a (quote a)) 'quasiquote (let ((name 'a)) `(list ,name ',name)))
(test '(a 3 4 5 6 b) 'quasiquote `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b)) (test '(a 3 4 5 6 b) 'quasiquote `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b))
@ -695,7 +695,7 @@
(error-test #'`(10 ,(values 1 2)) arity?) (error-test #'`(10 ,(values 1 2)) arity?)
(error-test #'`(10 ,@(values 1 2)) arity?) (error-test #'`(10 ,@(values 1 2)) arity?)
(SECTION 5 2 1) (Section 5 2 1)
(define add3 (lambda (x) (+ x 3))) (define add3 (lambda (x) (+ x 3)))
(test 6 'define (add3 3)) (test 6 'define (add3 3))
(define (add3 x) (+ x 3)) (define (add3 x) (+ x 3))
@ -782,7 +782,7 @@
(syntax-test #'(if #t (define ed-t3 3) (define ed-t3 -3))) (syntax-test #'(if #t (define ed-t3 3) (define ed-t3 -3)))
(syntax-test #'(if #f (define ed-t3 3) (define ed-t3 -3))) (syntax-test #'(if #f (define ed-t3 3) (define ed-t3 -3)))
(SECTION 5 2 2) (Section 5 2 2)
(test 45 'define (test 45 'define
(let ((x 5)) (let ((x 5))
(define foo (lambda (y) (bar x y))) (define foo (lambda (y) (bar x y)))
@ -842,7 +842,7 @@
(test 87 (lambda () (define x 87) (begin) (begin x))) (test 87 (lambda () (define x 87) (begin) (begin x)))
(SECTION 4 2 4) (Section 4 2 4)
(test '#(0 1 2 3 4) 'do (do ((vec (make-vector 5)) (test '#(0 1 2 3 4) 'do (do ((vec (make-vector 5))
(i 0 (+ i 1))) (i 0 (+ i 1)))
((= i 5) vec) ((= i 5) vec)
@ -880,7 +880,7 @@
(syntax-test #'(do ((x 1)) (#t . 5) 5)) (syntax-test #'(do ((x 1)) (#t . 5) 5))
(syntax-test #'(do ((x 1)) (#t 5) . 5)) (syntax-test #'(do ((x 1)) (#t 5) . 5))
(SECTION 'let/cc) (Section 'let/cc)
(test 0 'let/cc (let/cc k (k 0) 1)) (test 0 'let/cc (let/cc k (k 0) 1))
(test 0 'let/cc (let/cc k 0)) (test 0 'let/cc (let/cc k 0))
@ -904,7 +904,7 @@
(syntax-test #'(let/ec k . 1)) (syntax-test #'(let/ec k . 1))
(syntax-test #'(let/ec 1 1)) (syntax-test #'(let/ec 1 1))
(SECTION 'fluid-let) (Section 'fluid-let)
(define x 1) (define x 1)
(define y -1) (define y -1)
(define (get-x) x) (define (get-x) x)
@ -935,7 +935,7 @@
(syntax-test #'(fluid-let ([x 5]) . 9)) (syntax-test #'(fluid-let ([x 5]) . 9))
(syntax-test #'(fluid-let ([x 5]) 9 . 10)) (syntax-test #'(fluid-let ([x 5]) 9 . 10))
(SECTION 'parameterize) (Section 'parameterize)
(test 5 'parameterize (parameterize () 5)) (test 5 'parameterize (parameterize () 5))
(test 6 'parameterize (parameterize ([error-print-width 10]) 6)) (test 6 'parameterize (parameterize ([error-print-width 10]) 6))
@ -985,7 +985,7 @@
(arity-test check-parameter-procedure 1 1) (arity-test check-parameter-procedure 1 1)
|# |#
(SECTION 'time) (Section 'time)
(test 1 'time (time 1)) (test 1 'time (time 1))
(test -1 'time (time (cons 1 2) -1)) (test -1 'time (time (cons 1 2) -1))
(test-values '(-1 1) (lambda () (time (values -1 1)))) (test-values '(-1 1) (lambda () (time (values -1 1))))
@ -994,7 +994,7 @@
(syntax-test #'(time . 1)) (syntax-test #'(time . 1))
(syntax-test #'(time 1 . 2)) (syntax-test #'(time 1 . 2))
(SECTION 'compiler) (Section 'compiler)
; Tests specifically aimed at the compiler ; Tests specifically aimed at the compiler
(error-test #'(let ([x (values 1 2)]) x) exn:application:arity?) (error-test #'(let ([x (values 1 2)]) x) exn:application:arity?)
; Known primitive ; Known primitive
@ -1021,7 +1021,7 @@
; Known local with revsed arguments: ; Known local with revsed arguments:
(test 10 (letrec ([f (lambda (a b) (if (zero? a) b (f b a)))]) f) 10 0) (test 10 (letrec ([f (lambda (a b) (if (zero? a) b (f b a)))]) f) 10 0)
(SECTION '#%datum-et-al) (Section '#%datum-et-al)
(syntax-test #'#%datum) (syntax-test #'#%datum)
(syntax-test #'(let ([#%datum 5]) (syntax-test #'(let ([#%datum 5])

126
collects/tests/mzscheme/testing.ss
View File

@ -40,25 +40,30 @@ transcript.
|# |#
(define teval eval) (define teval eval)
(namespace-variable-value (define-syntax defvar
'building-flat-tests? (syntax-rules ()
#f [(_ name val)
(lambda () (namespace-variable-value 'name #f
(namespace-set-variable-value! 'building-flat-tests? #f))) (lambda () (namespace-set-variable-value! 'name val)))]))
(namespace-variable-value
'in-drscheme?
#f
(lambda ()
(namespace-set-variable-value! 'in-drscheme? #f)))
(define SECTION (lambda args (defvar building-flat-tests? #f)
(let ([ep (current-error-port)]) (defvar in-drscheme? #f)
(display "SECTION" ep) (write args ep) (newline ep)
(set! cur-section args) #t))) ;; used for quiet testing (quiet.ss) to really show something
(define record-error (lambda (e) (set! errs (cons (list cur-section e) errs)))) (defvar real-error-port #f)
(define (eprintf* fmt . args)
(let ([msg (apply format fmt args)])
(display msg (or real-error-port (current-error-port)))))
(define (Section . args)
(eprintf* "Section~s\n" args)
(set! cur-section args)
#t)
(define (record-error e)
(set! errs (cons (list cur-section e) errs)))
(print-struct #t) (print-struct #t)
@ -66,23 +71,17 @@ transcript.
(define number-of-error-tests 0) (define number-of-error-tests 0)
(define number-of-exn-tests 0) (define number-of-exn-tests 0)
(define test (define (test expect fun . args)
(lambda (expect fun . args) (set! number-of-tests (add1 number-of-tests))
(set! number-of-tests (add1 number-of-tests)) (printf "~s ==> " (cons fun args))
(write (cons fun args)) (flush-output)
(display " ==> ") (let ([res (if (procedure? fun) (apply fun args) (car args))])
(flush-output) (printf "~s\n" res)
((lambda (res) (let ([ok? (equal? expect res)])
(write res) (unless ok?
(newline) (record-error (list res expect (cons fun args)))
(cond ((not (equal? expect res)) (printf " BUT EXPECTED ~s\n" expect))
(record-error (list res expect (cons fun args))) ok?)))
(display " BUT EXPECTED ")
(write expect)
(newline)
#f)
(else #t)))
(if (procedure? fun) (apply fun args) (car args)))))
(define (nonneg-exact? x) (define (nonneg-exact? x)
@ -115,8 +114,7 @@ transcript.
[(th expr exn?) [(th expr exn?)
(set! expr (syntax-object->datum expr)) (set! expr (syntax-object->datum expr))
(set! number-of-error-tests (add1 number-of-error-tests)) (set! number-of-error-tests (add1 number-of-error-tests))
(write expr) (printf "~s =e=> " expr)
(display " =e=> ")
(flush-output) (flush-output)
(call/ec (lambda (escape) (call/ec (lambda (escape)
(let* ([old-esc-handler (error-escape-handler)] (let* ([old-esc-handler (error-escape-handler)]
@ -166,16 +164,10 @@ transcript.
(current-exception-handler old-handler) (current-exception-handler old-handler)
(error-escape-handler old-esc-handler))))))])) (error-escape-handler old-esc-handler))))))]))
(namespace-variable-value (defvar error-test
'error-test (case-lambda
#f
(lambda ()
(namespace-set-variable-value!
'error-test
(case-lambda
[(expr) (error-test expr exn:application:type?)] [(expr) (error-test expr exn:application:type?)]
[(expr exn?) [(expr exn?) (thunk-error-test (lambda () (eval expr)) expr exn?)]))
(thunk-error-test (lambda () (eval expr)) expr exn?)]))))
(require (rename mzscheme err:mz:lambda lambda)) ; so err/rt-test works with beginner.ss (require (rename mzscheme err:mz:lambda lambda)) ; so err/rt-test works with beginner.ss
(define-syntax err/rt-test (define-syntax err/rt-test
@ -193,7 +185,8 @@ transcript.
(define (syntax-test expr) (define (syntax-test expr)
(error-test expr exn:fail:syntax?) (error-test expr exn:fail:syntax?)
(unless no-extra-if-tests? (unless no-extra-if-tests?
(error-test (datum->syntax-object expr `(if #f ,expr) expr) exn:fail:syntax?))) (error-test (datum->syntax-object expr `(if #f ,expr) expr)
exn:fail:syntax?)))
(define arity-test (define arity-test
(case-lambda (case-lambda
@ -232,9 +225,9 @@ transcript.
(let ([v (with-handlers ([void (let ([v (with-handlers ([void
(lambda (exn) (lambda (exn)
(if (check? exn) (if (check? exn)
(printf " ~a~n" (exn-message exn)) (printf " ~a\n" (exn-message exn))
(let ([ok-type? (exn:application:arity? exn)]) (let ([ok-type? (exn:application:arity? exn)])
(printf " WRONG EXN ~a: ~s~n" (printf " WRONG EXN ~a: ~s\n"
(if ok-type? (if ok-type?
"FIELD" "FIELD"
"TYPE") "TYPE")
@ -246,7 +239,7 @@ transcript.
(cons f args))))) (cons f args)))))
(done (void)))]) (done (void)))])
(apply f args))]) (apply f args))])
(printf "~s~n BUT EXPECTED ERROR~n" v) (printf "~s\n BUT EXPECTED ERROR\n" v)
(record-error (list v 'Error (cons f args))))))]) (record-error (list v 'Error (cons f args))))))])
(let loop ([n 0][l '()]) (let loop ([n 0][l '()])
(unless (>= n min) (unless (>= n min)
@ -270,25 +263,24 @@ transcript.
(define (test-values l thunk) (define (test-values l thunk)
(test l call-with-values thunk list)) (test l call-with-values thunk list))
(define (report-errs) (define (report-errs . final?)
(printf "~nPerformed ~a expression tests (~a good expressions, ~a bad expressions)~n" (let* ([final? (and (pair? final?) (car final?))]
(+ number-of-tests number-of-error-tests) [printf (if final? eprintf* printf)]
number-of-tests [ok? (null? errs)])
number-of-error-tests) (printf "\nPerformed ~a expression tests (~a ~a, ~a ~a)\n"
(printf "and ~a exception field tests.~n~n" (+ number-of-tests number-of-error-tests)
number-of-exn-tests) number-of-tests "good expressions"
(if (null? errs) number-of-error-tests "bad expressions")
(display "Passed all tests.") (printf "and ~a exception field tests.\n\n"
(begin number-of-exn-tests)
(display "Errors were:") (if ok?
(newline) (printf "Passed all tests.\n")
(display "(SECTION (got expected (call)))") (begin (printf "Errors were:\n(Section (got expected (call)))\n")
(newline) (for-each (lambda (l) (printf "~s\n" l)) errs)
(for-each (lambda (l) (write l) (newline)) (when final? (exit 1))))
errs))) (when final? (exit (if ok? 0 1)))
(newline) (printf "(Other messages report successful tests of~a.)\n"
(display "(Other messages report successful tests of error-handling behavior.)") " error-handling behavior")))
(newline))
(define type? exn:application:type?) (define type? exn:application:type?)
(define arity? exn:application:arity?) (define arity? exn:application:arity?)

2
collects/tests/mzscheme/thread.ss
View File

@ -2,7 +2,7 @@
(load-relative "loadtest.ss") (load-relative "loadtest.ss")
(SECTION 'threads) (Section 'threads)
(define SLEEP-TIME 0.1) (define SLEEP-TIME 0.1)

2
collects/tests/mzscheme/threadlib.ss
View File

@ -1,7 +1,7 @@
(load-relative "loadtest.ss") (load-relative "loadtest.ss")
(SECTION 'thread) (Section 'thread)
(require (lib "thread.ss")) (require (lib "thread.ss"))

2
collects/tests/mzscheme/thrport.ss
View File

@ -1,7 +1,7 @@
(load-relative "loadtest.ss") (load-relative "loadtest.ss")
(SECTION 'multi-threaded-ports) (Section 'multi-threaded-ports)
; Read from file with 3 threads, all writing to the same pipe ; Read from file with 3 threads, all writing to the same pipe
; read from pipe with 3 threads, all writing to the same output string ; read from pipe with 3 threads, all writing to the same output string

2
collects/tests/mzscheme/udp.ss
View File

@ -1,7 +1,7 @@
(load-relative "loadtest.ss") (load-relative "loadtest.ss")
(SECTION 'UDP) (Section 'udp)
(define udp1 (udp-open-socket)) (define udp1 (udp-open-socket))
(define us1 (make-bytes 10)) (define us1 (make-bytes 10))

2
collects/tests/mzscheme/unicode.ss
View File

@ -1,7 +1,7 @@
(load-relative "loadtest.ss") (load-relative "loadtest.ss")
(SECTION 'unicode) (Section 'unicode)
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; UTF-8 boundary tests based on Markus Kuhn's test suite ;; UTF-8 boundary tests based on Markus Kuhn's test suite

2
collects/tests/mzscheme/unit.ss
View File

@ -1,7 +1,7 @@
(load-relative "loadtest.ss") (load-relative "loadtest.ss")
(SECTION 'unit) (Section 'unit)
(require (lib "unit.ss")) (require (lib "unit.ss"))
(syntax-test #'(unit)) (syntax-test #'(unit))

2
collects/tests/mzscheme/unitsig.ss
View File

@ -5,7 +5,7 @@
(require (lib "unitsig.ss")) (require (lib "unitsig.ss"))
(require (lib "include.ss")) (require (lib "include.ss"))
(SECTION 'unit/sig) (Section 'unit/sig)
(syntax-test #'(define-signature)) (syntax-test #'(define-signature))
(syntax-test #'(define-signature)) (syntax-test #'(define-signature))

2
collects/tests/mzscheme/will.ss
View File

@ -1,7 +1,7 @@
(load-relative "loadtest.ss") (load-relative "loadtest.ss")
(SECTION 'wills) (Section 'wills)
(test #f will-executor? 5) (test #f will-executor? 5)
(test #t will-executor? (make-will-executor)) (test #t will-executor? (make-will-executor))