suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

misc (minor) improvements

Browse Source 
svn: r9745
This commit is contained in:
Eli Barzilay 2008-05-08 16:53:27 +00:00
parent 79cc0c2942
commit 862afcfe17
6 changed files with 48 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/tests/framework/README
View File

@ -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
|#)

27
collects/tests/framework/debug.ss
View File

@ -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 ...)))]))

16
collects/tests/framework/main.ss
View File

@ -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>" "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)

18
collects/tests/framework/mem.ss
View File

@ -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)))))

5
collects/tests/framework/panel.ss
View File

@ -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))
)

28
collects/tests/framework/test-suite-utils.ss
View File

@ -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)