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

try to sort outputs out

Browse Source 
svn: r16463
This commit is contained in:
Eli Barzilay 2009-10-30 06:42:51 +00:00
parent b7db9e4e67
commit f03518f7cc
2 changed files with 35 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -7,15 +7,17 @@
(define timeout-thread #f) (define timeout-thread #f)
(namespace-variable-value 'real-error-port #f (namespace-variable-value 'real-output-port #f
(lambda () (lambda ()
(let ([err (current-error-port)] (let ([outp (current-output-port)]
[errp (current-error-port)]
[exit (exit-handler)] [exit (exit-handler)]
[errh (uncaught-exception-handler)] [errh (uncaught-exception-handler)]
[esch (error-escape-handler)] [esch (error-escape-handler)]
[cust (current-custodian)] [cust (current-custodian)]
[orig-thread (current-thread)]) [orig-thread (current-thread)])
(namespace-set-variable-value! 'real-error-port err) (namespace-set-variable-value! 'real-output-port outp)
(namespace-set-variable-value! 'real-error-port errp)
(namespace-set-variable-value! 'last-error #f) (namespace-set-variable-value! 'last-error #f)
;; we're loading this for the first time: ;; we're loading this for the first time:
;; make real errors show by remembering the exn ;; make real errors show by remembering the exn

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

@ -51,19 +51,17 @@ transcript.
(defvar building-flat-tests? #f) (defvar building-flat-tests? #f)
(defvar in-drscheme? #f) (defvar in-drscheme? #f)
;; used for quiet testing (quiet.ss) to really show something ;; used when quiet testing (through "quiet.ss") to really show something
(defvar real-output-port #f)
(defvar real-error-port #f) (defvar real-error-port #f)
(define (eprintf* fmt . args)
(let ([msg (apply format fmt args)]
[err (or real-error-port (current-error-port))])
(display msg err)
(flush-output err)))
(define Section-prefix (define Section-prefix
(namespace-variable-value 'Section-prefix #f (lambda () ""))) (namespace-variable-value 'Section-prefix #f (lambda () "")))
(define (Section . args) (define (Section . args)
(eprintf* "~aSection~s\n" Section-prefix args) (let ([p (or real-output-port (current-output-port))])
(fprintf p "~aSection~s\n" Section-prefix args)
(flush-output p))
(set! cur-section args) (set! cur-section args)
#t) #t)
@ -86,6 +84,7 @@ transcript.
[(S sandbox-memory-limit) 100]) ; 100mb per box [(S sandbox-memory-limit) 100]) ; 100mb per box
((S make-evaluator) '(begin) #:requires (list 'scheme)))))]) ((S make-evaluator) '(begin) #:requires (list 'scheme)))))])
(e `(load-relative "testing.ss")) (e `(load-relative "testing.ss"))
(e `(define real-output-port (quote ,real-output-port)))
(e `(define real-error-port (quote ,real-error-port))) (e `(define real-error-port (quote ,real-error-port)))
(e `(define Section-prefix ,Section-prefix)) (e `(define Section-prefix ,Section-prefix))
(e `(load-relative (quote ,file))) (e `(load-relative (quote ,file)))
@ -304,8 +303,11 @@ transcript.
(define (report-errs . final?) (define (report-errs . final?)
(let* ([final? (and (pair? final?) (car final?))] (let* ([final? (and (pair? final?) (car final?))]
[printf (if final? eprintf* printf)]
[ok? (null? errs)]) [ok? (null? errs)])
(parameterize ([current-output-port
(cond [(not ok?) (or real-error-port (current-error-port))]
[final? (or real-output-port (current-output-port))]
[else (current-output-port)])])
(printf "\n~aPerformed ~a expression tests (~a ~a, ~a ~a)\n" (printf "\n~aPerformed ~a expression tests (~a ~a, ~a ~a)\n"
Section-prefix Section-prefix
(+ number-of-tests number-of-error-tests) (+ number-of-tests number-of-error-tests)
@ -318,11 +320,13 @@ transcript.
(printf "~aPassed all tests.\n" Section-prefix) (printf "~aPassed all tests.\n" Section-prefix)
(begin (printf "~aErrors were:\n~a(Section (got expected (call)))\n" (begin (printf "~aErrors were:\n~a(Section (got expected (call)))\n"
Section-prefix Section-prefix) Section-prefix Section-prefix)
(for-each (lambda (l) (printf "~a~s\n" Section-prefix l)) (reverse errs)) (for-each (lambda (l) (printf "~a~s\n" Section-prefix l))
(reverse errs))
(when final? (exit 1)))) (when final? (exit 1))))
(when final? (exit (if ok? 0 1))) (when final? (exit (if ok? 0 1)))
(printf "(Other messages report successful tests of~a.)\n" (printf "(Other messages report successful tests of~a.)\n"
" error-handling behavior"))) " error-handling behavior")
(flush-output))))
(define type? exn:application:type?) (define type? exn:application:type?)
(define arity? exn:application:arity?) (define arity? exn:application:arity?)