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

..

Browse Source 
original commit: 6ef809f710782f04f04e1545f7faad76bd37ead8
This commit is contained in:
Robby Findler 2003-04-30 21:05:22 +00:00
parent 258a2c2fca
commit 187faed0a1
3 changed files with 189 additions and 137 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -21,9 +21,13 @@
"README")))) "README"))))
(define all? #f) (define all? #f)
(define 3m? #f)
(define files-to-process null) (define files-to-process null)
(define command-line-flags (define command-line-flags
`((once-each `((once-each
[("--3m")
,(lambda (flag) (use-3m #t))
("Run the tests using a 3m mred")]
[("-a" "--all") [("-a" "--all")
,(lambda (flag) ,(lambda (flag)
(set! all? #t)) (set! all? #t))

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

@ -1,136 +1,165 @@
(module mem mzscheme (module mem mzscheme
(require "test-suite-utils.ss") (require "test-suite-utils.ss")
; mem-boxes : (list-of (list string (list-of (weak-box TST)))) ; mem-boxes : (list-of (list string (list-of (weak-box TST))))
(send-sexp-to-mred '(define mem-boxes null)) (send-sexp-to-mred '(define mem-boxes null))
(define mem-count 10) (define mem-count 10)
(define (test-allocate tag open close) (define (test-allocate tag open close)
(send-sexp-to-mred (send-sexp-to-mred
`(let ([new-boxes `(let ([new-boxes
(let loop ([n ,mem-count]) (let loop ([n ,mem-count])
(cond (cond
[(zero? n) null] [(zero? n) null]
[else [else
(let* ([o (,open)] (let* ([o (,open)]
[b (make-weak-box o)]) [b (make-weak-box o)])
(,close o) (,close o)
(cons b (loop (- n 1))))]))]) (cons b (loop (- n 1))))]))])
(sleep/yield 1/10) (collect-garbage) (sleep/yield 1/10) (collect-garbage)
(sleep/yield 1/10) (collect-garbage) (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))))) (set! mem-boxes (cons (list ,tag new-boxes) mem-boxes)))))
(define (done) (define (done)
(send-sexp-to-mred (send-sexp-to-mred
`(begin `(begin
(yield) (collect-garbage) (yield) (collect-garbage)
(yield) (collect-garbage) (yield) (collect-garbage)
(yield) (collect-garbage) (yield) (collect-garbage)
(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)] (let* ([f (make-object dialog% "Results" #f 300 500)]
[text (make-object text%)] [text (make-object text%)]
[ec (make-object editor-canvas% f text)] [ec (make-object editor-canvas% f text)]
[anything? #f]) [hp (instantiate horizontal-panel% ()
(define (update-gui) (parent f)
(send text erase) (stretchable-width #f)
(let ([anything? #f]) (stretchable-height #f))]
(for-each [vp (instantiate vertical-panel% ()
(lambda (boxl) (parent hp)
(let* ([tag (car boxl)] (stretchable-width #f)
[boxes (cadr boxl)] (stretchable-height #f))]
[calc-results [gc-canvas (make-object canvas% hp '(border))]
(lambda () [anything? #f])
(let loop ([boxes boxes]
[n 0]) (define (update-gui)
(cond (send text erase)
[(null? boxes) n] (let ([anything? #f])
[else (if (weak-box-value (car boxes)) (send text begin-edit-sequence)
(loop (cdr boxes) (+ n 1)) (for-each
(loop (cdr boxes) n))])))]) (lambda (boxl)
(let ([res (calc-results)]) (let* ([tag (car boxl)]
(when (> res 0) [boxes (cadr boxl)]
(set! anything? #t) [calc-results
(send text insert (format "~a: ~a of ~a\n" tag res ,mem-count)))))) (lambda ()
(reverse mem-boxes)) (let loop ([boxes boxes]
(unless anything? [n 0])
(send text insert "Nothing!\n")))) (cond
[(null? boxes) n]
(update-gui) [else (if (weak-box-value (car boxes))
(make-object button% "Collect" f (lambda (x y) (loop (cdr boxes) (+ n 1))
(send text erase) (loop (cdr boxes) n))])))])
(send text insert "Collecting Garbage\n") (let ([res (calc-results)])
(collect-garbage)(collect-garbage)(collect-garbage)(collect-garbage) (when (> res 0)
(collect-garbage)(collect-garbage)(collect-garbage)(collect-garbage) (set! anything? #t)
(collect-garbage)(collect-garbage)(collect-garbage)(collect-garbage) (send text insert (format "~a: ~a of ~a\n" tag res ,mem-count))))))
(collect-garbage)(collect-garbage)(collect-garbage)(collect-garbage) (reverse mem-boxes))
(update-gui))) (unless anything?
(make-object button% "Close" f (lambda (x y) (send f show #f))) (send text insert "Nothing!\n"))
(send f show #t))))) (send text end-edit-sequence)))
(define (test-frame-allocate %) (update-gui)
(let ([name (symbol->string %)])
(send-sexp-to-mred '(preferences:set 'framework:exit-when-no-frames #f)) (let ([onb (icon:get-gc-on-bitmap)]
(test-allocate name [offb (icon:get-gc-off-bitmap)])
`(lambda () (let ([f (make-object ,% ,name)]) (when (and (send onb ok?)
(send f show #t) (send offb ok?))
(yield) (yield) (send* gc-canvas
f)) (min-client-width (max (send gc-canvas min-width) (send onb get-width)))
`(lambda (f) (min-client-height (max (send gc-canvas min-height) (send onb get-height)))
(yield) (yield) (stretchable-width #f)
(send f close) (stretchable-height #f))
(when (send f is-shown?) (register-collecting-blit gc-canvas
(error 'test-frame-allocate "~a instance didn't close" ',%)) 0 0
(yield) (yield))) (send onb get-width)
(send-sexp-to-mred '(preferences:set 'framework:exit-when-no-frames #t)))) (send onb get-height)
onb offb)))
(test-allocate "frame%"
'(lambda () (let ([f (make-object frame% "test frame")]) (make-object button%
(send f show #t) "Collect"
f)) vp
'(lambda (f) (send f show #f))) (lambda (x y)
(send text erase)
(send text insert "Collecting Garbage\n")
(define (test-editor-allocate object-name) (collect-garbage)(collect-garbage)(collect-garbage)
(test-allocate (symbol->string object-name) (collect-garbage)(collect-garbage)(collect-garbage)
`(lambda () (make-object ,object-name)) (collect-garbage)(collect-garbage)(collect-garbage)
'(lambda (e) (send e on-close)))) (update-gui)))
(make-object button% "Close" vp (lambda (x y) (send f show #f)))
(test-editor-allocate 'text:basic%) (send f show #t)))))
(test-editor-allocate 'text:keymap%)
(test-editor-allocate 'text:autowrap%) (define (test-frame-allocate %)
(test-editor-allocate 'text:file%) (let ([name (symbol->string %)])
(test-editor-allocate 'text:clever-file-format%) (send-sexp-to-mred '(preferences:set 'framework:exit-when-no-frames #f))
(test-editor-allocate 'text:backup-autosave%) (test-allocate name
(test-editor-allocate 'text:searching%) `(lambda () (let ([f (make-object ,% ,name)])
(test-editor-allocate 'text:info%) (send f show #t)
(yield) (yield)
(test-editor-allocate 'pasteboard:basic%) f))
(test-editor-allocate 'pasteboard:keymap%) `(lambda (f)
(test-editor-allocate 'pasteboard:file%) (yield) (yield)
(test-editor-allocate 'pasteboard:backup-autosave%) (send f close)
(test-editor-allocate 'pasteboard:info%) (when (send f is-shown?)
(error 'test-frame-allocate "~a instance didn't close" ',%))
(test-editor-allocate 'scheme:text%) (yield) (yield)))
(send-sexp-to-mred '(preferences:set 'framework:exit-when-no-frames #t))))
(test-allocate "text:return%"
'(lambda () (make-object text:return% void)) (test-allocate "frame%"
'(lambda (t) (void))) '(lambda () (let ([f (make-object frame% "test frame")])
(send f show #t)
(test-frame-allocate 'frame:basic%) f))
(test-frame-allocate 'frame:info%) '(lambda (f) (send f show #f)))
(test-frame-allocate 'frame:text-info%)
(test-frame-allocate 'frame:pasteboard-info%)
(test-frame-allocate 'frame:standard-menus%) (define (test-editor-allocate object-name)
(test-allocate (symbol->string object-name)
(test-frame-allocate 'frame:text%) `(lambda () (make-object ,object-name))
(test-frame-allocate 'frame:text-info-file%) '(lambda (e) (send e on-close))))
(test-frame-allocate 'frame:searchable%)
(test-editor-allocate 'text:basic%)
(test-frame-allocate 'frame:pasteboard%) (test-editor-allocate 'text:keymap%)
(test-frame-allocate 'frame:pasteboard-info-file%) (test-editor-allocate 'text:autowrap%)
(done) (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))

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

@ -15,6 +15,7 @@
load-framework-automatically load-framework-automatically
shutdown-listener shutdown-mred mred-running? shutdown-listener shutdown-mred mred-running?
use-3m
send-sexp-to-mred queue-sexp-to-mred send-sexp-to-mred queue-sexp-to-mred
test test
wait-for-frame wait-for-frame
@ -31,6 +32,8 @@
set-section-name! set-section-name!
set-only-these-tests! set-only-these-tests!
get-only-these-tests) get-only-these-tests)
(define use-3m (make-parameter #f))
(define section-jump void) (define section-jump void)
(define (set-section-jump! _s) (set! section-jump _s)) (define (set-section-jump! _s) (set! section-jump _s))
@ -84,16 +87,32 @@
(define (restart-mred) (define (restart-mred)
(shutdown-mred) (shutdown-mred)
(case (system-type) (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) [(macosx)
(thread (thread
(lambda () (lambda ()
(system* (system*
(build-path (collection-path "mzlib") 'up 'up "bin" "mred") (build-path (collection-path "mzlib")
'up
'up
"bin"
(if (use-3m)
"mred3m"
"mred"))
"-mvqt" "-mvqt"
(build-path (collection-path "tests" "framework") (build-path (collection-path "tests" "framework")
"framework-test-engine.ss"))))] "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") (debug-printf mz-tcp "accepting listener~n")
(let-values ([(in out) (tcp-accept listener)]) (let-values ([(in out) (tcp-accept listener)])
(set! in-port in) (set! in-port in)