Rackety
original commit: 6f9bcf00015433a8a781ab832247deaaa7307869
This commit is contained in:
parent
5007b385dd
commit
c4dd75a553
|
@ -1,4 +1,4 @@
|
||||||
#lang scheme/unit
|
#lang racket/unit
|
||||||
|
|
||||||
(require mzlib/class
|
(require mzlib/class
|
||||||
"sig.ss"
|
"sig.ss"
|
||||||
|
|
|
@ -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))
|
||||||
|
|
|
@ -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")
|
||||||
|
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
#lang mzscheme
|
#lang racket/base
|
||||||
(require "test-suite-utils.ss")
|
(require "test-suite-utils.ss")
|
||||||
|
|
||||||
(test
|
(test
|
||||||
|
|
Loading…
Reference in New Issue
Block a user