..
original commit: 6ef809f710782f04f04e1545f7faad76bd37ead8
This commit is contained in:
Robby Findler
parent
258a2c2fca
commit
187faed0a1
|
|
@ -21,9 +21,13 @@
|
|||
"README"))))
|
||||
|
||||
(define all? #f)
|
||||
(define 3m? #f)
|
||||
(define files-to-process null)
|
||||
(define command-line-flags
|
||||
`((once-each
|
||||
[("--3m")
|
||||
,(lambda (flag) (use-3m #t))
|
||||
("Run the tests using a 3m mred")]
|
||||
[("-a" "--all")
|
||||
,(lambda (flag)
|
||||
(set! all? #t))
|
||||
|
|
|
|||
|
|
@ -1,136 +1,165 @@
|
|||
(module mem mzscheme
|
||||
(require "test-suite-utils.ss")
|
||||
|
||||
; mem-boxes : (list-of (list string (list-of (weak-box TST))))
|
||||
(send-sexp-to-mred '(define mem-boxes null))
|
||||
|
||||
(define mem-count 10)
|
||||
|
||||
(define (test-allocate tag open close)
|
||||
(send-sexp-to-mred
|
||||
`(let ([new-boxes
|
||||
(let loop ([n ,mem-count])
|
||||
(cond
|
||||
[(zero? n) null]
|
||||
[else
|
||||
(let* ([o (,open)]
|
||||
[b (make-weak-box o)])
|
||||
(,close o)
|
||||
(cons b (loop (- n 1))))]))])
|
||||
(sleep/yield 1/10) (collect-garbage)
|
||||
(sleep/yield 1/10) (collect-garbage)
|
||||
(sleep/yield 1/10) (collect-garbage)
|
||||
(set! mem-boxes (cons (list ,tag new-boxes) mem-boxes)))))
|
||||
|
||||
(define (done)
|
||||
(send-sexp-to-mred
|
||||
`(begin
|
||||
(yield) (collect-garbage)
|
||||
(yield) (collect-garbage)
|
||||
(yield) (collect-garbage)
|
||||
(yield) (collect-garbage)
|
||||
(yield) (collect-garbage)
|
||||
(yield) (collect-garbage)
|
||||
(let* ([f (make-object dialog% "Results" #f 300 500)]
|
||||
[text (make-object text%)]
|
||||
[ec (make-object editor-canvas% f text)]
|
||||
[anything? #f])
|
||||
(define (update-gui)
|
||||
(send text erase)
|
||||
(let ([anything? #f])
|
||||
(for-each
|
||||
(lambda (boxl)
|
||||
(let* ([tag (car boxl)]
|
||||
[boxes (cadr boxl)]
|
||||
[calc-results
|
||||
(lambda ()
|
||||
(let loop ([boxes boxes]
|
||||
[n 0])
|
||||
(cond
|
||||
[(null? boxes) n]
|
||||
[else (if (weak-box-value (car boxes))
|
||||
(loop (cdr boxes) (+ n 1))
|
||||
(loop (cdr boxes) n))])))])
|
||||
(let ([res (calc-results)])
|
||||
(when (> res 0)
|
||||
(set! anything? #t)
|
||||
(send text insert (format "~a: ~a of ~a\n" tag res ,mem-count))))))
|
||||
(reverse mem-boxes))
|
||||
(unless anything?
|
||||
(send text insert "Nothing!\n"))))
|
||||
|
||||
(update-gui)
|
||||
(make-object button% "Collect" f (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)(collect-garbage)(collect-garbage)(collect-garbage)
|
||||
(collect-garbage)(collect-garbage)(collect-garbage)(collect-garbage)
|
||||
(update-gui)))
|
||||
(make-object button% "Close" f (lambda (x y) (send f show #f)))
|
||||
(send f show #t)))))
|
||||
|
||||
(define (test-frame-allocate %)
|
||||
(let ([name (symbol->string %)])
|
||||
(send-sexp-to-mred '(preferences:set 'framework:exit-when-no-frames #f))
|
||||
(test-allocate name
|
||||
`(lambda () (let ([f (make-object ,% ,name)])
|
||||
(send f show #t)
|
||||
(yield) (yield)
|
||||
f))
|
||||
`(lambda (f)
|
||||
(yield) (yield)
|
||||
(send f close)
|
||||
(when (send f is-shown?)
|
||||
(error 'test-frame-allocate "~a instance didn't close" ',%))
|
||||
(yield) (yield)))
|
||||
(send-sexp-to-mred '(preferences:set 'framework:exit-when-no-frames #t))))
|
||||
|
||||
(test-allocate "frame%"
|
||||
'(lambda () (let ([f (make-object frame% "test frame")])
|
||||
(send f show #t)
|
||||
f))
|
||||
'(lambda (f) (send f show #f)))
|
||||
|
||||
|
||||
(define (test-editor-allocate object-name)
|
||||
(test-allocate (symbol->string object-name)
|
||||
`(lambda () (make-object ,object-name))
|
||||
'(lambda (e) (send e on-close))))
|
||||
|
||||
(test-editor-allocate 'text:basic%)
|
||||
(test-editor-allocate 'text:keymap%)
|
||||
(test-editor-allocate 'text:autowrap%)
|
||||
(test-editor-allocate 'text:file%)
|
||||
(test-editor-allocate 'text:clever-file-format%)
|
||||
(test-editor-allocate 'text:backup-autosave%)
|
||||
(test-editor-allocate 'text:searching%)
|
||||
(test-editor-allocate 'text:info%)
|
||||
|
||||
(test-editor-allocate 'pasteboard:basic%)
|
||||
(test-editor-allocate 'pasteboard:keymap%)
|
||||
(test-editor-allocate 'pasteboard:file%)
|
||||
(test-editor-allocate 'pasteboard:backup-autosave%)
|
||||
(test-editor-allocate 'pasteboard:info%)
|
||||
|
||||
(test-editor-allocate 'scheme:text%)
|
||||
|
||||
(test-allocate "text:return%"
|
||||
'(lambda () (make-object text:return% void))
|
||||
'(lambda (t) (void)))
|
||||
|
||||
(test-frame-allocate 'frame:basic%)
|
||||
(test-frame-allocate 'frame:info%)
|
||||
(test-frame-allocate 'frame:text-info%)
|
||||
(test-frame-allocate 'frame:pasteboard-info%)
|
||||
(test-frame-allocate 'frame:standard-menus%)
|
||||
|
||||
(test-frame-allocate 'frame:text%)
|
||||
(test-frame-allocate 'frame:text-info-file%)
|
||||
(test-frame-allocate 'frame:searchable%)
|
||||
|
||||
(test-frame-allocate 'frame:pasteboard%)
|
||||
(test-frame-allocate 'frame:pasteboard-info-file%)
|
||||
(done)
|
||||
)
|
||||
|
||||
; mem-boxes : (list-of (list string (list-of (weak-box TST))))
|
||||
(send-sexp-to-mred '(define mem-boxes null))
|
||||
|
||||
(define mem-count 10)
|
||||
|
||||
(define (test-allocate tag open close)
|
||||
(send-sexp-to-mred
|
||||
`(let ([new-boxes
|
||||
(let loop ([n ,mem-count])
|
||||
(cond
|
||||
[(zero? n) null]
|
||||
[else
|
||||
(let* ([o (,open)]
|
||||
[b (make-weak-box o)])
|
||||
(,close o)
|
||||
(cons b (loop (- n 1))))]))])
|
||||
(sleep/yield 1/10) (collect-garbage)
|
||||
(sleep/yield 1/10) (collect-garbage)
|
||||
(sleep/yield 1/10) (collect-garbage)
|
||||
(set! mem-boxes (cons (list ,tag new-boxes) mem-boxes)))))
|
||||
|
||||
(define (done)
|
||||
(send-sexp-to-mred
|
||||
`(begin
|
||||
(yield) (collect-garbage)
|
||||
(yield) (collect-garbage)
|
||||
(yield) (collect-garbage)
|
||||
(yield) (collect-garbage)
|
||||
(yield) (collect-garbage)
|
||||
(yield) (collect-garbage)
|
||||
(let* ([f (make-object dialog% "Results" #f 300 500)]
|
||||
[text (make-object text%)]
|
||||
[ec (make-object editor-canvas% f text)]
|
||||
[hp (instantiate horizontal-panel% ()
|
||||
(parent f)
|
||||
(stretchable-width #f)
|
||||
(stretchable-height #f))]
|
||||
[vp (instantiate vertical-panel% ()
|
||||
(parent hp)
|
||||
(stretchable-width #f)
|
||||
(stretchable-height #f))]
|
||||
[gc-canvas (make-object canvas% hp '(border))]
|
||||
[anything? #f])
|
||||
|
||||
(define (update-gui)
|
||||
(send text erase)
|
||||
(let ([anything? #f])
|
||||
(send text begin-edit-sequence)
|
||||
(for-each
|
||||
(lambda (boxl)
|
||||
(let* ([tag (car boxl)]
|
||||
[boxes (cadr boxl)]
|
||||
[calc-results
|
||||
(lambda ()
|
||||
(let loop ([boxes boxes]
|
||||
[n 0])
|
||||
(cond
|
||||
[(null? boxes) n]
|
||||
[else (if (weak-box-value (car boxes))
|
||||
(loop (cdr boxes) (+ n 1))
|
||||
(loop (cdr boxes) n))])))])
|
||||
(let ([res (calc-results)])
|
||||
(when (> res 0)
|
||||
(set! anything? #t)
|
||||
(send text insert (format "~a: ~a of ~a\n" tag res ,mem-count))))))
|
||||
(reverse mem-boxes))
|
||||
(unless anything?
|
||||
(send text insert "Nothing!\n"))
|
||||
(send text end-edit-sequence)))
|
||||
|
||||
(update-gui)
|
||||
|
||||
(let ([onb (icon:get-gc-on-bitmap)]
|
||||
[offb (icon:get-gc-off-bitmap)])
|
||||
(when (and (send onb ok?)
|
||||
(send offb ok?))
|
||||
(send* gc-canvas
|
||||
(min-client-width (max (send gc-canvas min-width) (send onb get-width)))
|
||||
(min-client-height (max (send gc-canvas min-height) (send onb get-height)))
|
||||
(stretchable-width #f)
|
||||
(stretchable-height #f))
|
||||
(register-collecting-blit gc-canvas
|
||||
0 0
|
||||
(send onb get-width)
|
||||
(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% "Close" vp (lambda (x y) (send f show #f)))
|
||||
(send f show #t)))))
|
||||
|
||||
(define (test-frame-allocate %)
|
||||
(let ([name (symbol->string %)])
|
||||
(send-sexp-to-mred '(preferences:set 'framework:exit-when-no-frames #f))
|
||||
(test-allocate name
|
||||
`(lambda () (let ([f (make-object ,% ,name)])
|
||||
(send f show #t)
|
||||
(yield) (yield)
|
||||
f))
|
||||
`(lambda (f)
|
||||
(yield) (yield)
|
||||
(send f close)
|
||||
(when (send f is-shown?)
|
||||
(error 'test-frame-allocate "~a instance didn't close" ',%))
|
||||
(yield) (yield)))
|
||||
(send-sexp-to-mred '(preferences:set 'framework:exit-when-no-frames #t))))
|
||||
|
||||
(test-allocate "frame%"
|
||||
'(lambda () (let ([f (make-object frame% "test frame")])
|
||||
(send f show #t)
|
||||
f))
|
||||
'(lambda (f) (send f show #f)))
|
||||
|
||||
|
||||
(define (test-editor-allocate object-name)
|
||||
(test-allocate (symbol->string object-name)
|
||||
`(lambda () (make-object ,object-name))
|
||||
'(lambda (e) (send e on-close))))
|
||||
|
||||
(test-editor-allocate 'text:basic%)
|
||||
(test-editor-allocate 'text:keymap%)
|
||||
(test-editor-allocate 'text:autowrap%)
|
||||
(test-editor-allocate 'text:file%)
|
||||
(test-editor-allocate 'text:clever-file-format%)
|
||||
(test-editor-allocate 'text:backup-autosave%)
|
||||
(test-editor-allocate 'text:searching%)
|
||||
(test-editor-allocate 'text:info%)
|
||||
|
||||
(test-editor-allocate 'pasteboard:basic%)
|
||||
(test-editor-allocate 'pasteboard:keymap%)
|
||||
(test-editor-allocate 'pasteboard:file%)
|
||||
(test-editor-allocate 'pasteboard:backup-autosave%)
|
||||
(test-editor-allocate 'pasteboard:info%)
|
||||
|
||||
(test-editor-allocate 'scheme:text%)
|
||||
|
||||
(test-allocate "text:return%"
|
||||
'(lambda () (make-object text:return% void))
|
||||
'(lambda (t) (void)))
|
||||
|
||||
(test-frame-allocate 'frame:basic%)
|
||||
(test-frame-allocate 'frame:info%)
|
||||
(test-frame-allocate 'frame:text-info%)
|
||||
(test-frame-allocate 'frame:pasteboard-info%)
|
||||
(test-frame-allocate 'frame:standard-menus%)
|
||||
|
||||
(test-frame-allocate 'frame:text%)
|
||||
(test-frame-allocate 'frame:text-info-file%)
|
||||
(test-frame-allocate 'frame:searchable%)
|
||||
|
||||
(test-frame-allocate 'frame:pasteboard%)
|
||||
(test-frame-allocate 'frame:pasteboard-info-file%)
|
||||
(done))
|
||||
|
|
|
|||
|
|
@ -15,6 +15,7 @@
|
|||
|
||||
load-framework-automatically
|
||||
shutdown-listener shutdown-mred mred-running?
|
||||
use-3m
|
||||
send-sexp-to-mred queue-sexp-to-mred
|
||||
test
|
||||
wait-for-frame
|
||||
|
|
@ -31,6 +32,8 @@
|
|||
set-section-name!
|
||||
set-only-these-tests!
|
||||
get-only-these-tests)
|
||||
|
||||
(define use-3m (make-parameter #f))
|
||||
|
||||
(define section-jump void)
|
||||
(define (set-section-jump! _s) (set! section-jump _s))
|
||||
|
|
@ -84,16 +87,32 @@
|
|||
(define (restart-mred)
|
||||
(shutdown-mred)
|
||||
(case (system-type)
|
||||
[(macos) (system* (mred-program-launcher-path "Framework Test Engine"))]
|
||||
[(macos) (system*
|
||||
(mred-program-launcher-path
|
||||
(if (use-3m)
|
||||
"Framework Test Engine3m"
|
||||
"Framework Test Engine")))]
|
||||
[(macosx)
|
||||
(thread
|
||||
(lambda ()
|
||||
(system*
|
||||
(build-path (collection-path "mzlib") 'up 'up "bin" "mred")
|
||||
(build-path (collection-path "mzlib")
|
||||
'up
|
||||
'up
|
||||
"bin"
|
||||
(if (use-3m)
|
||||
"mred3m"
|
||||
"mred"))
|
||||
"-mvqt"
|
||||
(build-path (collection-path "tests" "framework")
|
||||
"framework-test-engine.ss"))))]
|
||||
[else (thread (lambda () (system* (mred-program-launcher-path "Framework Test Engine"))))])
|
||||
[else (thread
|
||||
(lambda ()
|
||||
(system*
|
||||
(mred-program-launcher-path
|
||||
(if (use-3m)
|
||||
"Framework Test Engine3m"
|
||||
"Framework Test Engine")))))])
|
||||
(debug-printf mz-tcp "accepting listener~n")
|
||||
(let-values ([(in out) (tcp-accept listener)])
|
||||
(set! in-port in)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user