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

Rackety

Browse Source
This commit is contained in:
Robby Findler 2010-12-31 09:58:23 -06:00
parent 3dc5bbd0eb
commit 6f9bcf0001
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
"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
(require mzlib/pconvert
mred
"debug.ss")
(define errs null)
(define sema (make-semaphore 1))
(define (protect f)
(semaphore-wait sema)
(begin0 (f)
(semaphore-post sema)))
(define errs null)
(define sema (make-semaphore 1))
(define (protect f)
(semaphore-wait sema)
(begin0 (f)
(semaphore-post sema)))
(define (exception->string x)
(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)))
(define (exception->string x)
(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 'racket/gui)
(namespace-require 'scheme/gui)
(thread
(lambda ()
(with-handlers ([(lambda (x) #t)
(lambda (x)
(printf "test suite thread died: ~a\n"
(if (exn? x)
(exception->string x)
(format "~s" x))))])
(let ([port (call-with-input-file
(build-path (find-system-path 'temp-dir)
"framework-tests-receive-sexps-port.ss")
read)])
(debug-printf mr-tcp "about to connect to ~a\n" port)
(let*-values ([(in out) (tcp-connect "127.0.0.1" port)])
(let loop ()
(debug-printf mr-tcp "about to read\n")
(let ([sexp (read in)])
(if (eof-object? sexp)
(begin
(debug-printf mr-tcp "got eof\n")
(close-input-port in)
(close-output-port out)
(exit))
(begin
(debug-printf mr-tcp "got expression to evaluate\n")
(write
(let ([these-errs (protect (lambda () (begin0 errs (set! errs null))))])
(if (null? these-errs)
(with-handlers ([(lambda (x) #t)
(lambda (x) (list 'error (exception->string x)))])
(list 'normal (print-convert (eval sexp))))
(list 'last-error
(apply string-append
(map (lambda (x) (string-append (exception->string x) (string #\newline)))
these-errs)))))
out)
(newline out)
(flush-output out)
(loop))))))))))
(void
(thread
(lambda ()
(with-handlers ([(lambda (x) #t)
(lambda (x)
(printf "test suite thread died: ~a\n"
(if (exn? x)
(exception->string x)
(format "~s" x))))])
(let ([port (call-with-input-file
(build-path (find-system-path 'temp-dir)
"framework-tests-receive-sexps-port.ss")
read)])
(debug-printf mr-tcp "about to connect to ~a\n" port)
(let*-values ([(in out) (tcp-connect "127.0.0.1" port)])
(let loop ()
(debug-printf mr-tcp "about to read\n")
(let ([sexp (read in)])
(if (eof-object? sexp)
(begin
(debug-printf mr-tcp "got eof\n")
(close-input-port in)
(close-output-port out)
(exit))
(begin
(debug-printf mr-tcp "got expression to evaluate\n")
(write
(let ([these-errs (protect (lambda () (begin0 errs (set! errs null))))])
(if (null? these-errs)
(with-handlers ([(lambda (x) #t)
(lambda (x) (list 'error (exception->string x)))])
(list 'normal (print-convert (eval sexp))))
(list 'last-error
(apply string-append
(map (lambda (x) (string-append (exception->string x) (string #\newline)))
these-errs)))))
out)
(newline out)
(flush-output out)
(loop)))))))))))
(let ([od (event-dispatch-handler)]
[port (current-output-port)])
(event-dispatch-handler
(lambda (evt)
(parameterize ([uncaught-exception-handler
(let ([oe (uncaught-exception-handler)])
(lambda (exn)
(protect
(lambda ()
(set! errs (cons exn errs))))
(oe exn)))])
(call-with-exception-handler
(lambda (exn)
((uncaught-exception-handler) exn))
(lambda ()
(od evt)))))))
(let ([od (event-dispatch-handler)]
[port (current-output-port)])
(event-dispatch-handler
(lambda (evt)
(parameterize ([uncaught-exception-handler
(let ([oe (uncaught-exception-handler)])
(lambda (exn)
(protect
(lambda ()
(set! errs (cons exn errs))))
(oe exn)))])
(call-with-exception-handler
(lambda (exn)
((uncaught-exception-handler) exn))
(lambda ()
(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
mzlib/cmdline
mzlib/list
mzlib/unitsig
racket/cmdline
racket/unit
"debug.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")
(test