diff --git a/collects/tests/framework/README b/collects/tests/framework/README index 8b9b976e..e957acee 100644 --- a/collects/tests/framework/README +++ b/collects/tests/framework/README @@ -1,5 +1,5 @@ (#| - Framework Test Suite Overview + Framework Test Suite Overview Each test will rely on the sucessfully completion of all of the ones before it. In addition, all test suites rely on the sucessful @@ -70,7 +70,7 @@ signal failures when there aren't any. - interactive tests | these tests require intervention by people. Clicking and whatnot - + - panel:single |# panel.ss #| - garbage collection: |# mem.ss #| @@ -78,5 +78,4 @@ signal failures when there aren't any. | These tests will create objects in various configurations and | make sure that they are garbage collected - |#) diff --git a/collects/tests/framework/debug.ss b/collects/tests/framework/debug.ss index 5cb8f439..14dbef2d 100644 --- a/collects/tests/framework/debug.ss +++ b/collects/tests/framework/debug.ss @@ -1,5 +1,5 @@ #lang mzscheme -(provide debug-printf debug-when) +(provide debug-printf debug-when interactive?) ;; all of the steps in the tcp connection (define mz-tcp? #f) @@ -12,20 +12,23 @@ ;; tests that passed and those that failed (define schedule? #t) +;; are we running in interactive mode? +(define interactive? (if (getenv "PLT_BUILD") #f #t)) + ;; all of the sexpression transactions between mz and mred -(define messages? (if (getenv "PLT_BUILD") #f #t)) +(define messages? interactive?) (define-syntax (debug-when stx) (syntax-case stx (mr-tcp mz-tcp admin schedule messages) - [(_ mr-tcp rest ...) #'(when mr-tcp? (let () rest ...))] - [(_ mz-tcp rest ...) #'(when mz-tcp? (let () rest ...))] - [(_ admin rest ...) #'(when admin? (let () rest ...))] - [(_ schedule rest ...) #'(when schedule? (let () rest ...))] - [(_ messages rest ...) #'(when messages? (let () rest ...))] + [(_ mr-tcp rest ...) #'(when mr-tcp? (let () rest ...))] + [(_ mz-tcp rest ...) #'(when mz-tcp? (let () rest ...))] + [(_ admin rest ...) #'(when admin? (let () rest ...))] + [(_ schedule rest ...) #'(when schedule? (let () rest ...))] + [(_ interactive rest ...) #'(when interactive? (let () rest ...))] + [(_ messages rest ...) #'(when messages? (let () rest ...))] [(_ unk rest ...) (raise-syntax-error #f "unknown flag" stx #'unk)])) -(define-syntax debug-printf - (lambda (stx) - (syntax-case stx () - [(_ flag fmt x ...) - #'(debug-when flag (printf ">> ~a: ~a" 'flag (format fmt x ...)))]))) +(define-syntax (debug-printf stx) + (syntax-case stx () + [(_ flag fmt x ...) + #'(debug-when flag (printf ">> ~a: ~a" 'flag (format fmt x ...)))])) diff --git a/collects/tests/framework/main.ss b/collects/tests/framework/main.ss index ac7bea7b..ea29643f 100644 --- a/collects/tests/framework/main.ss +++ b/collects/tests/framework/main.ss @@ -6,13 +6,11 @@ "debug.ss" "test-suite-utils.ss") -(define argv (current-command-line-arguments)) - (define preferences-file (find-system-path 'pref-file)) (define old-preferences-file (let-values ([(base name _2) (split-path preferences-file)]) - (build-path base (string-append (path->string name) ".save")))) + (build-path base (string-append (path-element->string name) ".save")))) (define all-files (map symbol->string @@ -21,7 +19,6 @@ read))) (define all? #f) -(define 3m? #f) (define files-to-process null) (define command-line-flags `((once-each @@ -36,10 +33,11 @@ (or (get-only-these-tests) null)))) ("Only run test named " "test-name")]))) -(parse-command-line "framework-test" argv command-line-flags - (lambda (collected . files) - (set! files-to-process (if (or all? (null? files)) all-files files))) - `("Names of the tests; defaults to all tests")) +(parse-command-line + "framework-test" (current-command-line-arguments) command-line-flags + (lambda (collected . files) + (set! files-to-process (if (or all? (null? files)) all-files files))) + `("Names of the tests; defaults to all tests")) (when (file-exists? preferences-file) (debug-printf admin " saving preferences file ~s to ~s\n" @@ -63,7 +61,7 @@ (set-section-name! x) (set-section-jump! k)) (lambda () - (with-handlers ([(lambda (x) #t) + (with-handlers ([(lambda (_) #t) (lambda (exn) (debug-printf schedule "~a\n" (if (exn? exn) diff --git a/collects/tests/framework/mem.ss b/collects/tests/framework/mem.ss index abcccc41..3e35e33b 100644 --- a/collects/tests/framework/mem.ss +++ b/collects/tests/framework/mem.ss @@ -97,16 +97,14 @@ (send onb get-height) onb offb))) - (make-object button% - "Collect" - vp - (lambda (x y) - (send text erase) - (send text insert "Collecting Garbage\n") - (collect-garbage)(collect-garbage)(collect-garbage) - (collect-garbage)(collect-garbage)(collect-garbage) - (collect-garbage)(collect-garbage)(collect-garbage) - (update-gui))) + (make-object button% "Collect" vp + (lambda (x y) + (send text erase) + (send text insert "Collecting Garbage\n") + (collect-garbage)(collect-garbage)(collect-garbage) + (collect-garbage)(collect-garbage)(collect-garbage) + (collect-garbage)(collect-garbage)(collect-garbage) + (update-gui))) (make-object button% "Close" vp (lambda (x y) (send f show #f))) (send f show #t))))) diff --git a/collects/tests/framework/panel.ss b/collects/tests/framework/panel.ss index 4b3a7b1f..899df78f 100644 --- a/collects/tests/framework/panel.ss +++ b/collects/tests/framework/panel.ss @@ -1,5 +1,5 @@ -(module panel mzscheme - (require "test-suite-utils.ss") +#lang mzscheme +(require "test-suite-utils.ss") (test 'single-panel @@ -132,4 +132,3 @@ (yield semaphore) (send f show #f) result)) -) diff --git a/collects/tests/framework/test-suite-utils.ss b/collects/tests/framework/test-suite-utils.ss index 3da90873..821b9e32 100644 --- a/collects/tests/framework/test-suite-utils.ss +++ b/collects/tests/framework/test-suite-utils.ss @@ -153,25 +153,25 @@ (lambda (sexp) (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))))]) + (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? - (lambda (x) #f)]) + (with-handlers ([tcp-error? (lambda (x) #f)]) (or (not (char-ready? in-port)) (not (eof-object? (peek-char in-port)))))) (restart-mred)) - (debug-printf messages " ~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 ([exn:fail? (lambda (x)