..

original commit: 6ef809f710782f04f04e1545f7faad76bd37ead8

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

collects/tests/framework/mem.ss

@@ -34,10 +34,21 @@
         (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)]
@@ -57,18 +68,37 @@
                        (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 insert "Nothing!\n"))
+              (send text end-edit-sequence)))
           
           (update-gui)
-        (make-object button% "Collect" f (lambda (x y)
+          
+          (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)(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)))
+          (make-object button% "Close" vp (lambda (x y) (send f show #f)))
           (send f show #t)))))
   
   (define (test-frame-allocate %)
@@ -132,5 +162,4 @@
   
   (test-frame-allocate 'frame:pasteboard%)
   (test-frame-allocate 'frame:pasteboard-info-file%)
-(done)
+  (done))
-)

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
@@ -32,6 +33,8 @@
    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))
   (define (reset-section-jump!) (set! section-jump #f))
@@ -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)