diff --git a/collects/tests/framework/debug.ss b/collects/tests/framework/debug.ss new file mode 100644 index 00000000..ca19a0a8 --- /dev/null +++ b/collects/tests/framework/debug.ss @@ -0,0 +1,43 @@ +(module debug-printf mzscheme + (provide debug-printf debug-when) + + ;; all of the steps in the tcp connection + (define tcp? #f) + + ;; administrative messages about preferences files and + ;; command line flags + (define admin? #f) + + ;; tests that passed and those that failed + (define schedule? #t) + + ;; of the sexpression transactions between mz and mred + (define messages? #f) + + (define-syntax debug-printf + (lambda (stx) + (syntax-case stx () + [(_ flag rest ...) + (syntax (debug-when flag (printf rest ...)))]))) + + (define-syntax debug-when + (lambda (stx) + (syntax-case stx (tcp admin schedule messages) + [(_ tcp rest ...) + (syntax + (when tcp? + rest ...))] + [(_ admin rest ...) + (syntax + (when admin? + rest ...))] + [(_ schedule rest ...) + (syntax + (when schedule? + rest ...))] + [(_ messages rest ...) + (syntax + (when messages? + rest ...))] + [(_ unk rest ...) + (raise-syntax-error 'debug-when "unknown flag" stx (syntax unk))])))) diff --git a/collects/tests/framework/framework-test-engine.ss b/collects/tests/framework/framework-test-engine.ss index 3050e09c..3c2a3652 100644 --- a/collects/tests/framework/framework-test-engine.ss +++ b/collects/tests/framework/framework-test-engine.ss @@ -1,6 +1,11 @@ +(require (lib "errortrace.ss" "errortrace")) + (module framework-test-engine mzscheme (require (lib "pconvert.ss") - (lib "mred.ss" "mred")) + (lib "mred.ss" "mred") + (lib "errortrace.ss" "errortrace") + "debug.ss" + ) (define errs null) (define sema (make-semaphore 1)) @@ -9,50 +14,44 @@ (begin0 (f) (semaphore-post sema))) -#| - (define (exception->string x) - (if (exn? x) - (if (defined? 'print-error-trace) - (let ([p (open-output-string)]) - (print-error-trace p x) - (string-append (exn-message x) (string #\newline) (get-output-string p))) - (exn-message x)) - (format "~s" x))) -|# - (define (exception->string x) (if (exn? x) +; (let ([p (open-output-string)]) +; (print-error-trace p x) +; (string-append (exn-message x) (string #\newline) (get-output-string p))) (exn-message x) (format "~s" x))) (thread (lambda () - (let*-values ([(in out) (tcp-connect "localhost" - (load - (build-path - (collection-path "tests" "framework") - "receive-sexps-port.ss")))] - [(continue) (make-semaphore 0)]) - (let loop () - (let ([sexp (read in)]) - (if (eof-object? sexp) - (begin - (close-input-port in) - (close-output-port out) - (exit)) - (begin - (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 'error - (apply string-append - (map (lambda (x) (string-append (exception->string x) (string #\newline))) - these-errs))))) - out) - (loop)))))))) + (let ([port (load + (build-path + (collection-path "tests" "framework") + "receive-sexps-port.ss"))]) + (debug-printf tcp "about to connect to ~a~n" port) + (let*-values ([(in out) (tcp-connect "localhost" port)]) + (let loop () + (debug-printf tcp "about to read~n") + (let ([sexp (read in)]) + (debug-printf tcp "got something~n") + (if (eof-object? sexp) + (begin + (close-input-port in) + (close-output-port out) + (exit)) + (begin + (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 'error + (apply string-append + (map (lambda (x) (string-append (exception->string x) (string #\newline))) + these-errs))))) + out) + (loop))))))))) (let ([od (event-dispatch-handler)] [port (current-output-port)]) @@ -65,4 +64,6 @@ (lambda () (set! errs (cons exn errs)))) (oe exn)))]) - (od evt)))))) + (od evt))))) + + (yield (make-semaphore 0))) diff --git a/collects/tests/framework/load.ss b/collects/tests/framework/load.ss index 40a58e78..302c70b5 100644 --- a/collects/tests/framework/load.ss +++ b/collects/tests/framework/load.ss @@ -7,14 +7,19 @@ (test (string->symbol file) void? - `(parameterize ([current-namespace (make-namespace 'mred)]) - (require (lib ,file "framework")) - ,exp - (void)))) + `(parameterize ([current-namespace (make-namespace)]) + (eval '(require (lib ,file "framework"))) + (with-handlers ([(lambda (x) #t) + (lambda (x) + (if (exn? x) + (exn-message x) + (format "~s" x)))]) + (eval ',exp) + (void))))) (load-framework-automatically #f) - (test/load "prefs-file-unit.ss" 'framework:preferences@) + (test/load "prefs-file-unit.ss" 'framework:prefs-file@) (test/load "prefs-file.ss" 'get-preferences-filename) (test/load "gui-utils-unit.ss" 'framework:gui-utils@) diff --git a/collects/tests/framework/main.ss b/collects/tests/framework/main.ss index 8e38cc5c..f74928e5 100644 --- a/collects/tests/framework/main.ss +++ b/collects/tests/framework/main.ss @@ -2,6 +2,7 @@ (require (lib "launcher.ss" "launcher") (lib "cmdline.ss") (lib "unitsig.ss") + "debug.ss" "test-suite-utils.ss") ;; must be run in the right context... @@ -46,7 +47,7 @@ (if (file-exists? saved-command-line-file) (begin (let ([result (call-with-input-file saved-command-line-file read)]) - (printf "reusing command-line arguments: ~s~n" result) + (debug-printf admin "reusing command-line arguments: ~s~n" result) result)) (vector)) argv)) @@ -62,11 +63,11 @@ 'truncate) (when (file-exists? preferences-file) - (printf " saving preferences file ~s to ~s~n" preferences-file old-preferences-file) + (debug-printf admin " saving preferences file ~s to ~s~n" preferences-file old-preferences-file) (if (file-exists? old-preferences-file) - (printf " backup preferences file exists, using that one~n") + (debug-printf admin " backup preferences file exists, using that one~n") (begin (copy-file preferences-file old-preferences-file) - (printf " saved preferences file~n")))) + (debug-printf admin " saved preferences file~n")))) (with-handlers ([(lambda (x) #f) (lambda (x) (display (exn-message x)) (newline))]) @@ -82,30 +83,29 @@ (lambda () (with-handlers ([(lambda (x) #t) (lambda (exn) - (printf "~a~n" (if (exn? exn) (exn-message exn) exn)))]) - (printf "beginning ~a test suite~n" x) + (debug-printf schedule "~a~n" (if (exn? exn) (exn-message exn) exn)))]) + (debug-printf schedule "beginning ~a test suite~n" x) (dynamic-require `(lib ,x "tests" "framework") #f) - - (printf "PASSED ~a test suite~n" x))) + (debug-printf schedule "PASSED ~a test suite~n" x))) (lambda () (reset-section-name!) (reset-section-jump!)))))) files-to-process)) - (printf " restoring preferences file ~s to ~s~n" old-preferences-file preferences-file) + (debug-printf admin " restoring preferences file ~s to ~s~n" old-preferences-file preferences-file) (when (file-exists? preferences-file) (unless (file-exists? old-preferences-file) (error 'framework-test "lost preferences file backup!")) (delete-file preferences-file) (copy-file old-preferences-file preferences-file) (delete-file old-preferences-file)) - (printf " restored preferences file~n") + (debug-printf admin " restored preferences file~n") (shutdown-listener) (unless (null? failed-tests) - (printf "FAILED tests:~n") + (debug-printf schedule "FAILED tests:~n") (for-each (lambda (failed-test) - (printf " ~a // ~a~n" (car failed-test) (cdr failed-test))) + (debug-printf schedule " ~a // ~a~n" (car failed-test) (cdr failed-test))) failed-tests))) \ No newline at end of file diff --git a/collects/tests/framework/test-suite-utils.ss b/collects/tests/framework/test-suite-utils.ss index 62d1aa68..be91f1fb 100644 --- a/collects/tests/framework/test-suite-utils.ss +++ b/collects/tests/framework/test-suite-utils.ss @@ -1,7 +1,8 @@ (module test-suite-utils mzscheme (require (lib "launcher.ss" "launcher") (lib "pretty.ss") - (lib "list.ss")) + (lib "list.ss") + "debug.ss") (provide test-name @@ -68,9 +69,11 @@ (lambda (p) (write next p)) 'truncate) - (printf " tcp-listen failed for port ~a, attempting ~a~n" - port next) + (debug-printf tcp " tcp-listen failed for port ~a, attempting ~a~n" + port + next) (loop)))]) + (debug-printf tcp "listening to ~a~n" port) (tcp-listen port))))) (define in-port #f) @@ -83,6 +86,7 @@ [(macos) system*] [else (lambda (x) (thread (lambda () (system* x))))]) (mred-program-launcher-path "Framework Test Engine")) + (debug-printf tcp "accepting listener~n") (let-values ([(in out) (tcp-accept listener)]) (set! in-port in) (set! out-port out)) @@ -104,6 +108,7 @@ (define shutdown-listener (lambda () (shutdown-mred) + (debug-printf tcp "closing listener~n") (tcp-close listener))) (define shutdown-mred @@ -146,17 +151,18 @@ (let ([show-text (lambda (sexp) - (parameterize ([pretty-print-print-line - (let ([prompt " "] - [old-liner (pretty-print-print-line)]) - (lambda (ln port ol cols) - (let ([ov (old-liner ln port ol cols)]) - (if ln - (begin (display prompt port) - (+ (string-length prompt) ov)) - ov))))]) - (pretty-print sexp) - (newline)))]) + (debug-when messages + (parameterize ([pretty-print-print-line + (let ([prompt " "] + [old-liner (pretty-print-print-line)]) + (lambda (ln port ol cols) + (let ([ov (old-liner ln port ol cols)]) + (if ln + (begin (display prompt port) + (+ (string-length prompt) ov)) + ov))))]) + (pretty-print sexp) + (newline))))]) (unless (and in-port out-port (with-handlers ([tcp-error? @@ -164,7 +170,7 @@ (or (not (char-ready? in-port)) (not (eof-object? (peek-char in-port)))))) (restart-mred)) - (printf " ~a // ~a: sending to mred:~n" section-name test-name) + (debug-printf messages " ~a // ~a: sending to mred:~n" section-name test-name) (show-text sexp) (with-handlers ([(lambda (x) #t) (lambda (x) @@ -210,7 +216,7 @@ (error 'send-sexp-to-mred "mred raised \"~a\"" (second answer))] [(cant-read) (error 'mred/cant-parse (second answer))] [(normal) - (printf " ~a // ~a: received from mred:~n" section-name test-name) + (debug-printf messages " ~a // ~a: received from mred:~n" section-name test-name) (show-text (second answer)) (eval (second answer))])))))))) @@ -235,7 +241,7 @@ (send-sexp-to-mred ''check-for-errors)))]) (not (passed? result))))]) (when failed - (printf "FAILED ~a: ~a~n" failed test-name) + (debug-printf schedule "FAILED ~a: ~a~n" failed test-name) (set! failed-tests (cons (cons section-name test-name) failed-tests)) (case jump [(section) (section-jump)]