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
parent
66128ed43b
commit
bbf54efde9
|
|
@ -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?)
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
|
||||
(load-relative "loadtest.ss")
|
||||
|
||||
(SECTION 'awk)
|
||||
(Section 'awk)
|
||||
|
||||
(require (lib "awk.ss"))
|
||||
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
|
||||
(require (lib "boundmap.ss" "syntax"))
|
||||
|
||||
(SECTION 'BOUNDMAP)
|
||||
(Section 'boundmap)
|
||||
|
||||
(test #t bound-identifier-mapping? (make-bound-identifier-mapping))
|
||||
|
||||
|
|
@ -126,4 +126,4 @@
|
|||
(set! l (cons y l))))
|
||||
l)))))
|
||||
|
||||
(report-errs)
|
||||
(report-errs)
|
||||
|
|
|
|||
|
|
@ -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"))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
|
||||
(load-relative "loadtest.ss")
|
||||
|
||||
(SECTION 'COMMAND-LINE)
|
||||
(Section 'command-line)
|
||||
|
||||
(require (lib "cmdline.ss"))
|
||||
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
|
||||
(load-relative "loadtest.ss")
|
||||
|
||||
(SECTION 'compat)
|
||||
(Section 'compat)
|
||||
|
||||
(require (lib "compat.ss"))
|
||||
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
(lib "class.ss")
|
||||
(lib "etc.ss"))
|
||||
|
||||
(SECTION 'contract)
|
||||
(Section 'contract)
|
||||
|
||||
(parameterize ([error-print-width 200])
|
||||
(let ()
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
|
||||
(load-relative "loadtest.ss")
|
||||
|
||||
(SECTION 'date)
|
||||
(Section 'date)
|
||||
|
||||
(require (lib "date.ss"))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
|
||||
(load-relative "loadtest.ss")
|
||||
|
||||
(SECTION 'deep)
|
||||
(Section 'deep)
|
||||
|
||||
; Test deep stacks
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
|
||||
(load-relative "loadtest.ss")
|
||||
|
||||
(SECTION 'embed)
|
||||
(Section 'embed)
|
||||
|
||||
(require (lib "embed.ss" "compiler")
|
||||
(lib "process.ss"))
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
|
||||
(load-relative "loadtest.ss")
|
||||
|
||||
(SECTION 'etc)
|
||||
(Section 'etc)
|
||||
|
||||
(require (lib "etc.ss"))
|
||||
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@
|
|||
;; test that expansion preserves source location information
|
||||
;; for fully expanded terms
|
||||
|
||||
(SECTION 'EXPAND)
|
||||
(Section 'expand)
|
||||
|
||||
(let ()
|
||||
(define (compare-expansion stx)
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
|
||||
(load-relative "loadtest.ss")
|
||||
|
||||
(SECTION 'file)
|
||||
(Section 'file)
|
||||
|
||||
(require (lib "file.ss")
|
||||
(lib "process.ss")
|
||||
|
|
|
|||
|
|
@ -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")])
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
|
||||
(load-relative "loadtest.ss")
|
||||
|
||||
(SECTION 'function)
|
||||
(Section 'function)
|
||||
|
||||
(require (lib "list.ss"))
|
||||
(require (lib "etc.ss"))
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@
|
|||
|
||||
(load-relative "loadtest.ss")
|
||||
|
||||
(SECTION 'imap)
|
||||
(Section 'imap)
|
||||
|
||||
(require (lib "mzssl.ss" "openssl")
|
||||
(lib "imap.ss" "net")
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
|
||||
(load-relative "loadtest.ss")
|
||||
|
||||
(SECTION 'kw)
|
||||
(Section 'kw)
|
||||
|
||||
(require (lib "kw.ss"))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,3 +1,3 @@
|
|||
|
||||
(unless (namespace-variable-value 'SECTION #f (lambda () #f))
|
||||
(unless (namespace-variable-value 'Section #f (lambda () #f))
|
||||
(load-relative "testing.ss"))
|
||||
|
|
|
|||
|
|
@ -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?)
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
|
||||
(load-relative "loadtest.ss")
|
||||
|
||||
(SECTION 'macrolib)
|
||||
(Section 'macrolib)
|
||||
|
||||
(require (lib "etc.ss"))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
(load-relative "../loadtest.ss")
|
||||
(SECTION 'MATCH-PERFORMANCE)
|
||||
(Section 'match-performance)
|
||||
|
||||
(require (lib "pretty.ss"))
|
||||
(require-for-syntax (lib "pretty.ss"))
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
(load-relative "../loadtest.ss")
|
||||
(SECTION 'MATCH)
|
||||
(Section 'match)
|
||||
(require (lib "match.ss"))
|
||||
;(require "../match.ss")
|
||||
|
||||
|
|
@ -8541,4 +8541,4 @@
|
|||
|
||||
(test-all2)
|
||||
|
||||
(report-errs)
|
||||
(report-errs)
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
(load-relative "../loadtest.ss")
|
||||
(SECTION 'PLT-MATCH)
|
||||
(Section 'plt-match)
|
||||
|
||||
|
||||
(require (lib "plt-match.ss"))
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
(load-relative "../loadtest.ss")
|
||||
(SECTION 'MATCH-PERFORMANCE)
|
||||
(Section 'match-performance)
|
||||
|
||||
(require (lib "pretty.ss"))
|
||||
(require-for-syntax (lib "pretty.ss"))
|
||||
|
|
@ -341,4 +341,4 @@
|
|||
; (list 0 2 3 1 7 7 1 2)
|
||||
; (list 9 6 8 5 3 9 7 4))
|
||||
|
||||
; )
|
||||
; )
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
(load-relative "../loadtest.ss")
|
||||
(SECTION 'MATCH-PERFORMANCE)
|
||||
(Section 'match-performance)
|
||||
|
||||
(require (lib "pretty.ss"))
|
||||
(require-for-syntax (lib "pretty.ss"))
|
||||
|
|
@ -275,4 +275,4 @@
|
|||
|
||||
))
|
||||
|
||||
(report-errs)
|
||||
(report-errs)
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
(load-relative "../loadtest.ss")
|
||||
(SECTION 'MATCH-PERFORMANCE)
|
||||
(Section 'match-performance)
|
||||
|
||||
(require (lib "pretty.ss"))
|
||||
(require-for-syntax (lib "pretty.ss"))
|
||||
|
|
@ -186,4 +186,4 @@
|
|||
|
||||
))
|
||||
|
||||
(report-errs)
|
||||
(report-errs)
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
|
||||
(load-relative "loadtest.ss")
|
||||
|
||||
(SECTION 'md5)
|
||||
(Section 'md5)
|
||||
|
||||
(require (lib "md5.ss"))
|
||||
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
|
||||
(load-relative "loadtest.ss")
|
||||
|
||||
(SECTION 'MODDEP)
|
||||
(Section 'moddep)
|
||||
|
||||
(require (lib "moddep.ss" "syntax"))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
|
||||
(load-relative "loadtest.ss")
|
||||
|
||||
(SECTION 'module)
|
||||
(Section 'module)
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
|
|
|||
|
|
@ -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")
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
|
||||
(load-relative "loadtest.ss")
|
||||
|
||||
(SECTION 'namespaces)
|
||||
(Section 'namespaces)
|
||||
|
||||
(arity-test eval 1 2)
|
||||
(arity-test compile 1 1)
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@
|
|||
|
||||
(require (lib "class.ss"))
|
||||
|
||||
(SECTION 'OBJECT)
|
||||
(Section 'object)
|
||||
|
||||
(define (stx-test e)
|
||||
(syntax-test (datum->syntax-object #f e #f)))
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@
|
|||
|
||||
(require (lib "class.ss"))
|
||||
|
||||
(SECTION 'OBJECT)
|
||||
(Section 'object)
|
||||
|
||||
;; ------------------------------------------------------------
|
||||
;; Test syntax errors
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
|
||||
(load-relative "loadtest.ss")
|
||||
|
||||
(SECTION 'OpenSSL)
|
||||
(Section 'openssl)
|
||||
|
||||
(require (lib "mzssl.ss" "openssl"))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
|
||||
(load-relative "loadtest.ss")
|
||||
|
||||
(SECTION 'optimization)
|
||||
(Section 'optimization)
|
||||
|
||||
;; Check JIT inlining of primitives:
|
||||
(parameterize ([current-namespace (make-namespace)]
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@
|
|||
|
||||
(load-relative "loadtest.ss")
|
||||
|
||||
(SECTION 'pack)
|
||||
(Section 'pack)
|
||||
|
||||
(require (lib "pack.ss" "setup")
|
||||
(lib "unpack.ss" "setup")
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
(require (lib "package.ss"))
|
||||
|
||||
|
||||
(SECTION 'packages)
|
||||
(Section 'packages)
|
||||
|
||||
(define expand-test-use-toplevel? #t)
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
|
||||
(load-relative "loadtest.ss")
|
||||
|
||||
(SECTION 'PATH)
|
||||
(Section 'path)
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
|
||||
(load-relative "loadtest.ss")
|
||||
|
||||
(SECTION 'pconvert)
|
||||
(Section 'pconvert)
|
||||
|
||||
(require (lib "unit.ss")
|
||||
(lib "file.ss")
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
|
||||
(load-relative "loadtest.ss")
|
||||
|
||||
(SECTION 'PORT)
|
||||
(Section 'port)
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Tests for progress events and commits
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
|
||||
(load-relative "loadtest.ss")
|
||||
|
||||
(SECTION 'port)
|
||||
(Section 'port)
|
||||
|
||||
(define SLEEP-TIME 0.1)
|
||||
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@
|
|||
|
||||
(load-relative "loadtest.ss")
|
||||
|
||||
(SECTION 'PRETTY)
|
||||
(Section 'pretty)
|
||||
|
||||
(require (lib "pretty.ss"))
|
||||
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
|
||||
(load-relative "loadtest.ss")
|
||||
|
||||
(SECTION 'READING)
|
||||
(Section 'reading)
|
||||
(define readstr
|
||||
(lambda (s)
|
||||
(let* ([o (open-input-string s)]
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
|
||||
(load-relative "loadtest.ss")
|
||||
|
||||
(SECTION 'serialization)
|
||||
(Section 'serialization)
|
||||
|
||||
(require (lib "serialize.ss"))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,13 +1,13 @@
|
|||
|
||||
(load-relative "loadtest.ss")
|
||||
|
||||
(SECTION 'shared)
|
||||
(Section 'shared)
|
||||
|
||||
(require (lib "shared.ss"))
|
||||
|
||||
(load-relative "shared-tests.ss")
|
||||
|
||||
|
||||
(require mzscheme)
|
||||
(load-relative "shared-tests.ss")
|
||||
|
||||
|
||||
(report-errs)
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
|
||||
(load-relative "loadtest.ss")
|
||||
|
||||
(SECTION 'mzlib-string)
|
||||
(Section 'mzlib-string)
|
||||
|
||||
(require (lib "string.ss"))
|
||||
|
||||
|
|
|
|||
|
|
@ -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)]
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
|
||||
(load-relative "loadtest.ss")
|
||||
|
||||
(SECTION 'structlib)
|
||||
(Section 'structlib)
|
||||
|
||||
(require (lib "struct.ss"))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
|
||||
(load-relative "loadtest.ss")
|
||||
|
||||
(SECTION 'stx)
|
||||
(Section 'stx)
|
||||
|
||||
(test #t syntax? (datum->syntax-object #f 'hello #f))
|
||||
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
@ -253,7 +253,7 @@
|
|||
(fprintf w "~a~n" in)
|
||||
(when out
|
||||
(test out (lambda (ignored) (read-line r)) in)))
|
||||
|
||||
|
||||
(test-line "17" "(display 17) (newline)")
|
||||
|
||||
(close-input-port r)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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])
|
||||
|
|
|
|||
|
|
@ -24,10 +24,10 @@
|
|||
The test form has these two shapes:
|
||||
|
||||
(test <expected> <procdure> <argument1> <argument2> ...)
|
||||
|
||||
|
||||
(test <expected> <symbolic-name> <expression>)
|
||||
|
||||
In the first case, it applies the result of <procedure>
|
||||
In the first case, it applies the result of <procedure>
|
||||
to the results of <argument1> etc and compares that (with equal?)
|
||||
to the result of the <expected>
|
||||
|
||||
|
|
@ -36,29 +36,34 @@ the results of that (with equal?) to the value of the
|
|||
<expected>. In this case, <symbolic-name> must evaluate to
|
||||
something that isn't a procedure. That name is used in the
|
||||
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)
|
||||
|
|
@ -100,7 +99,7 @@ transcript.
|
|||
(cons exn? (cons exn-continuation-marks continuation-mark-set?))
|
||||
(cons exn:fail:contract:variable? (cons exn:fail:contract:variable-id symbol?))
|
||||
(cons exn:fail:syntax? (cons exn:fail:syntax-exprs (lambda (x) (and (list? x) (andmap syntax? x)))))
|
||||
|
||||
|
||||
(cons exn:fail:read? (cons exn:fail:read-srclocs (lambda (x) (and (list? x) (andmap srcloc? x)))))))
|
||||
|
||||
(define exn:application:mismatch? exn:fail:contract?)
|
||||
|
|
@ -110,13 +109,12 @@ transcript.
|
|||
(define mz-test-syntax-errors-allowed? #t)
|
||||
|
||||
(define thunk-error-test
|
||||
(case-lambda
|
||||
(case-lambda
|
||||
[(th expr) (thunk-error-test th expr exn:application:type?)]
|
||||
[(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)]
|
||||
|
|
@ -139,7 +137,7 @@ transcript.
|
|||
(lambda (row)
|
||||
(let ([pred? (car row)])
|
||||
(when (pred? e)
|
||||
(set! number-of-exn-tests
|
||||
(set! number-of-exn-tests
|
||||
(add1 number-of-exn-tests))
|
||||
(let ([sel (cadr row)]
|
||||
[pred? (cddr row)])
|
||||
|
|
@ -147,10 +145,10 @@ transcript.
|
|||
(printf " WRONG EXN ELEM ~s: ~s " sel e)
|
||||
(record-error (list e (cons 'exn-elem sel) expr)))))))
|
||||
exn-table)
|
||||
|
||||
|
||||
(old-handler e))])
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
(lambda ()
|
||||
(current-error-port (current-output-port))
|
||||
(current-exception-handler test-exn-handler)
|
||||
(error-escape-handler test-handler))
|
||||
|
|
@ -161,21 +159,15 @@ transcript.
|
|||
(record-error (list v 'Error expr))
|
||||
(newline)
|
||||
#f))
|
||||
(lambda ()
|
||||
(lambda ()
|
||||
(current-error-port orig-err-port)
|
||||
(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
|
||||
|
|
@ -187,15 +179,16 @@ transcript.
|
|||
[(_ e)
|
||||
(syntax
|
||||
(err/rt-test e exn:application:type?))])))
|
||||
|
||||
|
||||
(define no-extra-if-tests? #f)
|
||||
|
||||
(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
|
||||
(define arity-test
|
||||
(case-lambda
|
||||
[(f min max except)
|
||||
(letrec ([aok?
|
||||
|
|
@ -232,21 +225,21 @@ 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")
|
||||
exn)
|
||||
(record-error (list exn
|
||||
(record-error (list exn
|
||||
(if ok-type?
|
||||
'exn-field
|
||||
'exn-type)
|
||||
(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?)
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
|
||||
(load-relative "loadtest.ss")
|
||||
|
||||
(SECTION 'threads)
|
||||
(Section 'threads)
|
||||
|
||||
(define SLEEP-TIME 0.1)
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
|
||||
(load-relative "loadtest.ss")
|
||||
|
||||
(SECTION 'thread)
|
||||
(Section 'thread)
|
||||
|
||||
(require (lib "thread.ss"))
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
|
||||
(load-relative "loadtest.ss")
|
||||
|
||||
(SECTION 'UDP)
|
||||
(Section 'udp)
|
||||
|
||||
(define udp1 (udp-open-socket))
|
||||
(define us1 (make-bytes 10))
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
|
||||
(load-relative "loadtest.ss")
|
||||
|
||||
(SECTION 'unicode)
|
||||
(Section 'unicode)
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; UTF-8 boundary tests based on Markus Kuhn's test suite
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
|
||||
(load-relative "loadtest.ss")
|
||||
|
||||
(SECTION 'unit)
|
||||
(Section 'unit)
|
||||
(require (lib "unit.ss"))
|
||||
|
||||
(syntax-test #'(unit))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
|
||||
(load-relative "loadtest.ss")
|
||||
|
||||
(SECTION 'wills)
|
||||
(Section 'wills)
|
||||
|
||||
(test #f will-executor? 5)
|
||||
(test #t will-executor? (make-will-executor))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user