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

Rackety

Browse Source 
original commit: 6f9bcf00015433a8a781ab832247deaaa7307869
This commit is contained in:
Robby Findler 2010-12-31 09:58:23 -06:00
parent 5007b385dd
commit c4dd75a553
4 changed files with 82 additions and 81 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/framework/private/panel.rkt
View File

@ -1,4 +1,4 @@
#lang scheme/unit #lang racket/unit
(require mzlib/class (require mzlib/class
"sig.ss" "sig.ss"

152
collects/tests/framework/framework-test-engine.rkt
View File

@ -1,81 +1,83 @@
#lang racket/base
(require mzlib/pconvert
racket/tcp
racket/class
racket/gui/base
"debug.ss")
(module framework-test-engine mzscheme (define errs null)
(require mzlib/pconvert (define sema (make-semaphore 1))
mred (define (protect f)
"debug.ss") (semaphore-wait sema)
(begin0 (f)
(semaphore-post sema)))
(define errs null) (define (exception->string x)
(define sema (make-semaphore 1)) (if (exn? x)
(define (protect f) (let ([p (open-output-string)])
(semaphore-wait sema) (parameterize ([current-error-port p])
(begin0 (f) ((error-display-handler) (exn-message x) x))
(semaphore-post sema))) (get-output-string p))
(format "uncaught exn: ~s" x)))
(define (exception->string x) (namespace-require 'racket/gui)
(if (exn? x)
(let ([p (open-output-string)])
(parameterize ([current-error-port p])
((error-display-handler) (exn-message x) x))
(get-output-string p))
(format "uncaught exn: ~s" x)))
(namespace-require 'scheme/gui) (void
(thread
(thread (lambda ()
(lambda () (with-handlers ([(lambda (x) #t)
(with-handlers ([(lambda (x) #t) (lambda (x)
(lambda (x) (printf "test suite thread died: ~a\n"
(printf "test suite thread died: ~a\n" (if (exn? x)
(if (exn? x) (exception->string x)
(exception->string x) (format "~s" x))))])
(format "~s" x))))]) (let ([port (call-with-input-file
(let ([port (call-with-input-file (build-path (find-system-path 'temp-dir)
(build-path (find-system-path 'temp-dir) "framework-tests-receive-sexps-port.ss")
"framework-tests-receive-sexps-port.ss") read)])
read)]) (debug-printf mr-tcp "about to connect to ~a\n" port)
(debug-printf mr-tcp "about to connect to ~a\n" port) (let*-values ([(in out) (tcp-connect "127.0.0.1" port)])
(let*-values ([(in out) (tcp-connect "127.0.0.1" port)]) (let loop ()
(let loop () (debug-printf mr-tcp "about to read\n")
(debug-printf mr-tcp "about to read\n") (let ([sexp (read in)])
(let ([sexp (read in)]) (if (eof-object? sexp)
(if (eof-object? sexp) (begin
(begin (debug-printf mr-tcp "got eof\n")
(debug-printf mr-tcp "got eof\n") (close-input-port in)
(close-input-port in) (close-output-port out)
(close-output-port out) (exit))
(exit)) (begin
(begin (debug-printf mr-tcp "got expression to evaluate\n")
(debug-printf mr-tcp "got expression to evaluate\n") (write
(write (let ([these-errs (protect (lambda () (begin0 errs (set! errs null))))])
(let ([these-errs (protect (lambda () (begin0 errs (set! errs null))))]) (if (null? these-errs)
(if (null? these-errs) (with-handlers ([(lambda (x) #t)
(with-handlers ([(lambda (x) #t) (lambda (x) (list 'error (exception->string x)))])
(lambda (x) (list 'error (exception->string x)))]) (list 'normal (print-convert (eval sexp))))
(list 'normal (print-convert (eval sexp)))) (list 'last-error
(list 'last-error (apply string-append
(apply string-append (map (lambda (x) (string-append (exception->string x) (string #\newline)))
(map (lambda (x) (string-append (exception->string x) (string #\newline))) these-errs)))))
these-errs))))) out)
out) (newline out)
(newline out) (flush-output out)
(flush-output out) (loop)))))))))))
(loop))))))))))
(let ([od (event-dispatch-handler)] (let ([od (event-dispatch-handler)]
[port (current-output-port)]) [port (current-output-port)])
(event-dispatch-handler (event-dispatch-handler
(lambda (evt) (lambda (evt)
(parameterize ([uncaught-exception-handler (parameterize ([uncaught-exception-handler
(let ([oe (uncaught-exception-handler)]) (let ([oe (uncaught-exception-handler)])
(lambda (exn) (lambda (exn)
(protect (protect
(lambda () (lambda ()
(set! errs (cons exn errs)))) (set! errs (cons exn errs))))
(oe exn)))]) (oe exn)))])
(call-with-exception-handler (call-with-exception-handler
(lambda (exn) (lambda (exn)
((uncaught-exception-handler) exn)) ((uncaught-exception-handler) exn))
(lambda () (lambda ()
(od evt))))))) (od evt)))))))
(yield (make-semaphore 0))) (yield (make-semaphore 0))

7
collects/tests/framework/main.rkt
View File

@ -1,8 +1,7 @@
#lang mzscheme #lang racket/base
(require launcher (require launcher
mzlib/cmdline racket/cmdline
mzlib/list racket/unit
mzlib/unitsig
"debug.ss" "debug.ss"
"test-suite-utils.ss") "test-suite-utils.ss")

2
collects/tests/framework/panel.rkt
View File

@ -1,4 +1,4 @@
#lang mzscheme #lang racket/base
(require "test-suite-utils.ss") (require "test-suite-utils.ss")
(test (test