82 lines
2.4 KiB
Scheme
82 lines
2.4 KiB
Scheme
|
|
(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 (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 'scheme/gui)
|
|
|
|
(thread
|
|
(lambda ()
|
|
(with-handlers ([(lambda (x) #t)
|
|
(lambda (x)
|
|
(printf "test suite thread died: ~a\n"
|
|
(if (exn? x)
|
|
(exn-message 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)))))))
|
|
|
|
(yield (make-semaphore 0)))
|