From 6f9bcf00015433a8a781ab832247deaaa7307869 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 31 Dec 2010 09:58:23 -0600 Subject: [PATCH] Rackety --- collects/framework/private/panel.rkt | 2 +- .../tests/framework/framework-test-engine.rkt | 152 +++++++++--------- collects/tests/framework/main.rkt | 7 +- collects/tests/framework/panel.rkt | 2 +- 4 files changed, 82 insertions(+), 81 deletions(-) diff --git a/collects/framework/private/panel.rkt b/collects/framework/private/panel.rkt index e2350acfed..86d5650933 100644 --- a/collects/framework/private/panel.rkt +++ b/collects/framework/private/panel.rkt @@ -1,4 +1,4 @@ -#lang scheme/unit +#lang racket/unit (require mzlib/class "sig.ss" diff --git a/collects/tests/framework/framework-test-engine.rkt b/collects/tests/framework/framework-test-engine.rkt index d32fa75d43..54e22cd820 100644 --- a/collects/tests/framework/framework-test-engine.rkt +++ b/collects/tests/framework/framework-test-engine.rkt @@ -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)) diff --git a/collects/tests/framework/main.rkt b/collects/tests/framework/main.rkt index fffa613611..e4d3caec26 100644 --- a/collects/tests/framework/main.rkt +++ b/collects/tests/framework/main.rkt @@ -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") diff --git a/collects/tests/framework/panel.rkt b/collects/tests/framework/panel.rkt index cdca9c6bef..aa1f5d4c74 100644 --- a/collects/tests/framework/panel.rkt +++ b/collects/tests/framework/panel.rkt @@ -1,4 +1,4 @@ -#lang mzscheme +#lang racket/base (require "test-suite-utils.ss") (test