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

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

View File

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

View File

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

View File

@ -17,10 +17,10 @@
(let ([f (lambda () #&7)])
(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
(list boolean? char? null? number? pair? procedure? string? symbol? vector?))
(define type-examples
@ -41,7 +41,7 @@
t))
type-examples))
(SECTION 6 1)
(Section 6 1)
(test #f not #t)
(test #f not 3)
(test #f not (list 3))
@ -57,7 +57,7 @@
(test #f boolean? '())
(arity-test boolean? 1 1)
(SECTION 6 2)
(Section 6 2)
(test #t eqv? 'a 'a)
(test #f eqv? 'a 'b)
(test #t eqv? 2 2)
@ -118,7 +118,7 @@
(arity-test eqv? 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 . ()))))))
(define x (list 'a 'b 'c))
(define y x)
@ -350,7 +350,7 @@
(test #t immutable? (string->immutable-string "hi"))
(test #t immutable? (string->immutable-string (string-copy "hi")))
(SECTION 6 4)
(Section 6 4)
(test #t symbol? 'foo)
(test #t symbol? (car '(a b)))
(test #f symbol? "bar")
@ -399,7 +399,7 @@
(arity-test symbol? 1 1)
(SECTION 6 6)
(Section 6 6)
(define (char-tests)
(test #t eqv? '#\ #\Space)
@ -649,7 +649,7 @@
(test-up/down char-upcase 'char-upcase lowers (map cons lowers uppers))
(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? "")
(arity-test string? 1 1)
@ -1265,7 +1265,7 @@
(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? '#())
(arity-test vector? 1 1)
@ -1311,7 +1311,7 @@
(arity-test vector-fill! 2 2)
(err/rt-test (vector-fill! '(1 2 3) 0))
(SECTION 6 9)
(Section 6 9)
(test #t procedure? car)
(test #f procedure? 'car)
(test #t procedure? (lambda (x) (* x x)))
@ -1436,7 +1436,7 @@
(define (test-cont)
(newline)
(display ";testing continuations; ")
(SECTION 6 9)
(Section 6 9)
(test #t leaf-eq? '(a (b (c))) '((a) b c))
(test #f leaf-eq? '(a (b (c))) '((a) b c d))
'(report-errs))
@ -1776,7 +1776,7 @@
(newline)
(display ";testing scheme 4 functions; ")
(SECTION 6 7)
(Section 6 7)
(test '(#\P #\space #\l) string->list "P l")
(test '() string->list "")
(test "1\\\"" list->string '(#\1 #\\ #\"))
@ -1787,7 +1787,7 @@
(err/rt-test (list->string 'hello))
(err/rt-test (list->string '(#\h . #\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 '() vector->list '#())
(test '#(dididit dah) list->vector '(dididit dah))

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -1,13 +1,11 @@
(load-relative "loadtest.ss")
(SECTION 'foreign)
(Section 'foreign)
(require (lib "foreign.ss"))
(unsafe!)
(require (lib "etc.ss"))
(let ([big/little
(if (system-big-endian?) (lambda (x y) x) (lambda (x y) y))]
[p (malloc _int32)])
@ -21,7 +19,7 @@
(test (big/little 3 2) ptr-ref p _int8 2)
(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")]
[o (build-path (current-directory) "foreign-test.o")]
[so (build-path (current-directory) "foreign-test.so")])

View File

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

View File

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

View File

@ -1,7 +1,7 @@
(load-relative "loadtest.ss")
(SECTION 'kw)
(Section 'kw)
(require (lib "kw.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"))

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -1,7 +1,7 @@
(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)))]
[(prop:p2 p2? p2-ref) (make-struct-type-property 'prop2)]

View File

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

View File

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

View File

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

View File

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

View File

@ -63,18 +63,18 @@
(test-values '(1 2) (lambda () (with-handlers ([void void])
(values 1 2))))
(SECTION 4 1 2)
(Section 4 1 2)
(test '(quote a) 'quote (quote 'a))
(test '(quote a) 'quote ''a)
(syntax-test #'quote)
(syntax-test #'(quote))
(syntax-test #'(quote 1 2))
(SECTION 4 1 3)
(Section 4 1 3)
(test 12 (if #f + *) 3 4)
(syntax-test #'(+ 3 . 4))
(SECTION 4 1 4)
(Section 4 1 4)
(test 8 (lambda (x) (+ x x)) 4)
(define reverse-subtract
(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]))
(SECTION 4 1 5)
(Section 4 1 5)
(test 'yes 'if (if (> 3 2) 'yes 'no))
(test 'no 'if (if (> 2 3) 'yes 'no))
(test '1 'if (if (> 3 2) (- 3 2) (+ 3 2)))
@ -214,7 +214,7 @@
(syntax-test #'(unless 1 . 2))
(error-test #'(unless (values 1 2) 0) arity?)
(SECTION 4 1 6)
(Section 4 1 6)
(define x 2)
(test 3 'define (+ x 1))
(set! x 4)
@ -261,7 +261,7 @@
(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)
((< 3 2) 'less)))
(test 'equal 'cond (cond ((> 3 3) 'greater)
@ -355,7 +355,7 @@
(error-test #'(and #t (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 'second 'let (let ((x 2) (y 3)) (* x y) 'second))
(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))))))
(SECTION 4 2 3)
(Section 4 2 3)
(define x 0)
(define (test-begin bg nested-bg)
(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?
(SECTION 4 2 5)
(Section 4 2 5)
(define f-check #t)
(define f (delay (begin (set! f-check #f) 5)))
(test #t (lambda () f-check))
@ -632,7 +632,7 @@
(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 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))
@ -695,7 +695,7 @@
(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)))
(test 6 'define (add3 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 #f (define ed-t3 3) (define ed-t3 -3)))
(SECTION 5 2 2)
(Section 5 2 2)
(test 45 'define
(let ((x 5))
(define foo (lambda (y) (bar x y)))
@ -842,7 +842,7 @@
(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))
(i 0 (+ i 1)))
((= i 5) vec)
@ -880,7 +880,7 @@
(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 0))
@ -904,7 +904,7 @@
(syntax-test #'(let/ec k . 1))
(syntax-test #'(let/ec 1 1))
(SECTION 'fluid-let)
(Section 'fluid-let)
(define x 1)
(define y -1)
(define (get-x) x)
@ -935,7 +935,7 @@
(syntax-test #'(fluid-let ([x 5]) . 9))
(syntax-test #'(fluid-let ([x 5]) 9 . 10))
(SECTION 'parameterize)
(Section 'parameterize)
(test 5 'parameterize (parameterize () 5))
(test 6 'parameterize (parameterize ([error-print-width 10]) 6))
@ -985,7 +985,7 @@
(arity-test check-parameter-procedure 1 1)
|#
(SECTION 'time)
(Section 'time)
(test 1 'time (time 1))
(test -1 'time (time (cons 1 2) -1))
(test-values '(-1 1) (lambda () (time (values -1 1))))
@ -994,7 +994,7 @@
(syntax-test #'(time . 1))
(syntax-test #'(time 1 . 2))
(SECTION 'compiler)
(Section 'compiler)
; Tests specifically aimed at the compiler
(error-test #'(let ([x (values 1 2)]) x) exn:application:arity?)
; Known primitive
@ -1021,7 +1021,7 @@
; Known local with revsed arguments:
(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 #'(let ([#%datum 5])

View File

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

View File

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

View File

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

View File

@ -1,7 +1,7 @@
(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 pipe with 3 threads, all writing to the same output string

View File

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

View File

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

View File

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

View File

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

View File

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