diff --git a/collects/tests/framework/main.ss b/collects/tests/framework/main.ss index 2629cd0a..d3e4b494 100644 --- a/collects/tests/framework/main.ss +++ b/collects/tests/framework/main.ss @@ -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)) diff --git a/collects/tests/framework/mem.ss b/collects/tests/framework/mem.ss index 59277ed9..37560420 100644 --- a/collects/tests/framework/mem.ss +++ b/collects/tests/framework/mem.ss @@ -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)) diff --git a/collects/tests/framework/test-suite-utils.ss b/collects/tests/framework/test-suite-utils.ss index 1ed306b4..f73e77b7 100644 --- a/collects/tests/framework/test-suite-utils.ss +++ b/collects/tests/framework/test-suite-utils.ss @@ -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)