...

original commit: 5305c0ca3d1b7cf54708e0b477005eda2454d452

collects/framework/frame.ss

@@ -51,7 +51,7 @@
 		 this))]
 	[on-focus
 	 (lambda (on?)
-	   (super-on-focus)
+	   (super-on-focus on?)
 	   (when on?
 	     (send (group:get-the-frame-group) set-active-frame this)))])
       (public
@@ -409,7 +409,7 @@
 	 (lambda (x)
 	   (when x
 	     (send find-edit set-searching-frame (get-top-level-window)))
-	   (on-focus x))])
+	   (super-on-focus x))])
       (sequence
 	(super-init parent #f '(h-scroll))
 	(set-line-count 2))))
@@ -1005,8 +1005,8 @@
 		  (super-can-close?))))])
       (sequence (apply super-init args))))
 
-  (define empty% (basic-mixin frame%))
-  (define standard-menus% (standard-menus-mixin empty%))
+  (define basic% (basic-mixin frame%))
+  (define standard-menus% (standard-menus-mixin basic%))
   (define editor% (editor-mixin standard-menus%))
 
   (define -text% (text-mixin editor%))

collects/framework/framework.ss

@@ -16,9 +16,9 @@
 	   [core:file : mzlib:file^]
 	   [core:thread : mzlib:thread^]
 	   [framework:keys : framework:keys^]
-	   [framework:test : framework:test^])
-   (link [M : mred-interfaces^ (mred-interfaces@)]
-	 [F : frameworkc^ ((require-relative-library "frameworkc.ss")
+	   [framework:test : framework:test^]
+	   [M : mred-interfaces^])
+   (link [F : frameworkc^ ((require-relative-library "frameworkc.ss")
 			   core:string
 			   core:function
 			   core:pretty-print
@@ -35,4 +35,5 @@
  mzlib:file^
  mzlib:thread^
  (keys : framework:keys^)
- (test : framework:test^))
+ (test : framework:test^)
+ mred-interfaces^)

collects/framework/frameworks.ss

@@ -164,7 +164,7 @@
    file<%>
    file-mixin
 
-   empty%
+   basic%
    standard-menus%
    editor%
    text%

collects/framework/test.ss

@@ -8,4 +8,5 @@
 	[test : framework:test^ ((require-relative-library "testr.ss") mred keys)])
   (export
    (unit test)
-   (unit keys))))
+   (unit keys)
+   (open mred))))

collects/tests/framework/README

@@ -47,13 +47,17 @@ tests.
 - basic connections between classes
 
   | These tests will create objects in various configurations and
-  | trigger situations to test their functionality. Fake user input
-  | expected.
+  | trigger situations to test their functionality. 
 
   - edits to canvases: |# edit-canvas.ss #|
   - canvases to frames: |# canvas-frame.ss #|
   - edits to frames: |# edit-frame.ss #|
 
+- garbage collection: |# gc.ss #|
+
+  | These tests will create objects in various configurations and
+  | make sure that they are garbage collected
+
 - keybindings: |# keys.ss #|
 
   | This tests all of the misc (non-scheme) keybindings

collects/tests/framework/exit.ss

@@ -1,6 +1,6 @@
 '(test 'exit:exit
-      (lambda (x) (not (and (eq? x 'passed)
-			    (not (mred-running?)))))
+      (lambda (x) (and (eq? x 'passed)
+		       (not (mred-running?))))
       (lambda ()
 	(with-handlers ([eof-result? (lambda (x) 'passed)])
 	  (send-sexp-to-mred '(preferences:set 'framework:verify-exit #f))
@@ -8,10 +8,12 @@
 	  'failed)))
 
 (test 'exit:exit
-      (lambda (x) (not (and (eq? x 'passed)
-			    (not (mred-running?)))))
+      (lambda (x) (and (eq? x 'passed)
+		       (not (mred-running?))))
       (lambda ()
 	(with-handlers ([eof-result? (lambda (x) 'passed)])
 	  (send-sexp-to-mred '(preferences:set 'framework:verify-exit #t))
-	  (send-sexp-to-mred '(queue-callback (lambda () (exit:exit))))
+	  (send-sexp-to-mred '(test:run-one (lambda () (exit:exit))))
+	  (wait-for-frame "Warning")
+	  (send-sexp-to-mred '(test:button-push "Quit"))
 	  'failed)))

collects/tests/framework/frame.ss

@@ -0,0 +1,21 @@
+(test
+ 'basic-mixin-creation
+ (lambda (x) x)
+ (lambda ()
+   (send-sexp-to-mred
+    '(send (make-object (frame:basic-mixin frame%) "test") show #t))
+   (wait-for-frame "test")
+   (send-sexp-to-mred
+    '(send (get-top-level-focus-window) show #f))
+   #t))
+
+(test
+ 'basic-mixin-creation
+ (lambda (x) x)
+ (lambda ()
+   (send-sexp-to-mred
+    '(send (make-object (frame:basic-mixin frame%) "test") show #t))
+   (wait-for-frame "test")
+   (send-sexp-to-mred
+    '(send (get-top-level-focus-window) show #f))
+   #t))

collects/tests/framework/framework-test-engine.ss

@@ -1,25 +1,55 @@
-(thread
- (let ([print-convert
-	(parameterize ([current-namespace (make-namespace)])
-	  (require-library "pconvert.ss")
-	  (global-defined-value 'print-convert))])
-   (lambda ()
-     (let*-values ([(in out) (tcp-connect "localhost" (load-relative "receive-sexps-port.ss"))]
-		   [(continue) (make-semaphore 0)])
-       (let loop ()
-	 (let ([sexp (read in)])
-	   (if (eof-object? sexp)
-	       (begin
-		 (close-input-port in)
-		 (close-output-port out)
-		 (exit))
-	       (begin
-		 (write
-		  (with-handlers ([(lambda (x) #t)
-				   (lambda (exn)
-				     (list 'error (if (exn? exn)
-						      (exn-message exn)
-						      (format "~s" exn))))])
-		    (list 'normal (print-convert (eval sexp))))
-		  out)
-		 (loop)))))))))
+(let* ([errs null]
+       [sema (make-semaphore 1)]
+       [protect
+	(lambda (f)
+	  (semaphore-wait sema)
+	  (begin0 (f)
+		  (semaphore-post sema)))])
+  (thread
+   (let ([print-convert
+	  (parameterize ([current-namespace (make-namespace)])
+	    (require-library "pconvert.ss")
+	    (global-defined-value 'print-convert))])
+     (lambda ()
+       (let*-values ([(in out) (tcp-connect "localhost" (load-relative "receive-sexps-port.ss"))]
+		     [(continue) (make-semaphore 0)])
+	 (let loop ()
+	   (let ([sexp (read in)])
+	     (if (eof-object? sexp)
+		 (begin
+		   (close-input-port in)
+		   (close-output-port out)
+		   (exit))
+		 (begin
+		   (write
+		    (let ([these-errs (protect (lambda () (begin0 errs (set! errs null))))])
+		      (if (null? these-errs)
+			  (with-handlers ([(lambda (x) #t)
+					   (lambda (exn)
+					     (list 'error (if (exn? exn)
+							      (exn-message exn)
+							      (format "~s" exn))))])
+			    (list 'normal (print-convert (eval sexp))))
+			  (list 'error
+				(apply string-append
+				       (map (lambda (x)
+					      (string-append
+					       (if (exn? x) (exn-message x) (format "~s" x))
+					       (string #\newline)))
+					    these-errs)))))
+		    
+		    out)
+		   (loop)))))))))
+
+  (let ([od (event-dispatch-handler)]
+	[port (current-output-port)])
+    (event-dispatch-handler
+     (lambda (evt)
+       (parameterize ([current-exception-handler
+		       (let ([oe (current-exception-handler)])
+			 (lambda (exn)
+			   (protect
+			    (lambda ()
+			      (set! errs (cons exn errs))))
+			   (oe exn)))])
+	 (od evt))))))

collects/tests/framework/load.ss

@@ -1,66 +1,107 @@
-(test
- 'testr.ss
- (lambda (x) #f)
- '(parameterize ([current-namespace (make-namespace 'mred)])
-    (require-library "tests.ss" "framework")
-    (invoke-open-unit/sig
-     (compound-unit/sig
-       (import)
-       (link [mred : mred-interfaces^ (mred-interfaces@)]
-	     [keys : framework:keys^ ((require-library "keys.ss" "framework"))]
-	     [test : framework:test^ ((require-library "testr.ss" "framework") mred keys)])
-       (export (unit test))))
-    (global-defined-value 'test:run-one)
-    (global-defined-value 'test:button-push)
-    (void)))
-
-(test
- 'test.ss
- (lambda (x) #f)
- '(parameterize ([current-namespace (make-namespace 'mred)])
-    (require-library "test.ss" "framework")
-    (global-defined-value 'test:run-one)
-    (global-defined-value 'test:button-push)
-    (void)))
-
-(test
- 'mred-interfaces.ss
- (lambda (x)
-   (printf "Called predicate: ~a~n" x)
-   #f)
- '(parameterize ([current-namespace (make-namespace 'mred)])
-    (require-library "mred-interfaces.ss" "framework")
-    (global-defined-value 'mred-interfaces^)
-    (global-defined-value 'mred-interfaces@)
-    (void)))
-
-(test
- 'frameworkr.ss
- (lambda (x) #f)
- '(parameterize ([current-namespace (make-namespace 'mred)])
-    (require-library "frameworks.ss" "framework")
-    (invoke-open-unit/sig
-     (compound-unit/sig
-       (import)
-       (link [mred : mred-interfaces^ (mred-interfaces@)]
-	     [core : mzlib:core^ ((require-library "corer.ss"))]
-	     [framework : framework^ ((require-library "frameworkr.ss" "framework") core mred)])
-       (export (open framework))))
-    (global-defined-value 'test:run-one)
-    (global-defined-value 'test:button-push)
-    (global-defined-value 'frame:basic-mixin)
-    (global-defined-value 'editor:basic-mixin)
-    (global-defined-value 'exit:exit)
-    (void)))
-
-(test
- 'framework.ss
- (lambda (x) #f)
- '(parameterize ([current-namespace (make-namespace 'mred)])
-    (require-library "framework.ss" "framework")
-    (global-defined-value 'test:run-one)
-    (global-defined-value 'test:button-push)
-    (global-defined-value 'frame:basic-mixin)
-    (global-defined-value 'editor:basic-mixin)
-    (global-defined-value 'exit:exit)
-    (void)))
+(let ([pred (lambda (x) (void? x))])
+  (test
+   'macro.ss
+   pred
+   '(parameterize ([current-namespace (make-namespace 'mred)])
+      (require-library "macro.ss" "framework")
+      (global-defined-value 'mixin)
+      (void)))
+  (test
+   'tests.ss
+   (lambda (x) x)
+   '(parameterize ([current-namespace (make-namespace 'mred)])
+      (require-library "tests.ss" "framework")
+      (unit/sig? (require-library "keys.ss" "framework"))))
+  (test
+   'testr.ss
+   pred
+   '(parameterize ([current-namespace (make-namespace 'mred)])
+      (require-library "tests.ss" "framework")
+      (invoke-open-unit/sig
+       (compound-unit/sig
+	 (import)
+	 (link [mred : mred-interfaces^ (mred-interfaces@)]
+	       [keys : framework:keys^ ((require-library "keys.ss" "framework"))]
+	       [test : framework:test^ ((require-library "testr.ss" "framework") mred keys)])
+	 (export (unit test))))
+      (global-defined-value 'test:run-one)
+      (global-defined-value 'test:button-push)
+      (void)))
+  (test
+   'test.ss
+   pred
+   '(parameterize ([current-namespace (make-namespace 'mred)])
+      (require-library "test.ss" "framework")
+      (global-defined-value 'test:run-one)
+      (global-defined-value 'test:button-push)
+      (void)))
+  (test
+   'mred-interfaces.ss
+   pred
+   '(parameterize ([current-namespace (make-namespace 'mred)])
+      (require-library "mred-interfaces.ss" "framework")
+      (global-defined-value 'mred-interfaces^)
+      (global-defined-value 'mred-interfaces@)
+      (void)))
+  (test
+   'mred-interfaces.ss/gen
+   (lambda (x) x)
+   '(parameterize ([current-namespace (make-namespace 'mred)])
+      (require-library "mred-interfaces.ss" "framework")
+      (let ([orig-button% (global-defined-value 'button%)])
+	(invoke-open-unit/sig mred-interfaces@)
+	(let ([first-button% (global-defined-value 'button%)])
+	  (invoke-open-unit/sig mred-interfaces@)
+	  (let ([second-button% (global-defined-value 'button%)])
+	    (and (eq? second-button% first-button%)
+		 (not (eq? first-button% orig-button%))))))))
+  (test
+   'frameworkr.ss
+   pred
+   '(parameterize ([current-namespace (make-namespace 'mred)])
+      (require-library "frameworks.ss" "framework")
+      (invoke-open-unit/sig
+       (compound-unit/sig
+	 (import)
+	 (link [mred : mred-interfaces^ (mred-interfaces@)]
+	       [core : mzlib:core^ ((require-library "corer.ss"))]
+	       [framework : framework^ ((require-library "frameworkr.ss" "framework") core mred)])
+	 (export (open framework))))
+      (global-defined-value 'test:run-one)
+      (global-defined-value 'test:button-push)
+      (global-defined-value 'frame:basic-mixin)
+      (global-defined-value 'editor:basic-mixin)
+      (global-defined-value 'exit:exit)
+      (void)))
+  (test
+   'framework.ss
+   pred
+   '(parameterize ([current-namespace (make-namespace 'mred)])
+      (require-library "framework.ss" "framework")
+      (global-defined-value 'test:run-one)
+      (global-defined-value 'test:button-push)
+      (global-defined-value 'frame:basic-mixin)
+      (global-defined-value 'editor:basic-mixin)
+      (global-defined-value 'exit:exit)
+      (void)))
+  (test
+   'framework.ss/gen
+   (lambda (x) x)
+   '(parameterize ([current-namespace (make-namespace 'mred)])
+      (require-library "pretty.ss")
+      (let* ([op (pretty-print-print-line)]
+	     [np  (lambda x (apply op x))])
+	((global-defined-value 'pretty-print-print-line) np)
+	(require-library "framework.ss" "framework")
+	(eq? np ((global-defined-value 'pretty-print-print-line))))))
+  (test
+   'framework.ss/test.ss
+   (lambda (x) x)
+   '(parameterize ([current-namespace (make-namespace 'mred)])
+      (let ([orig-button% (global-defined-value 'button%)])
+	(require-library "test.ss" "framework")
+	(let* ([test-button% (global-defined-value 'button%)])
+	  (require-library "framework.ss" "framework")
+	  (let* ([fw-button% (global-defined-value 'button%)])
+	    (and (eq? fw-button% test-button%)
+		 (not (eq? fw-button% orig-button%)))))))))

collects/tests/framework/main.ss

@@ -34,12 +34,17 @@
 	     (let-values ([(base _1 _2) (split-path program)])
 	       ((case (system-type)
 		  [(macos) system*]
-		  [else (lambda (x) (begin (process* x) (void)))])
+		  [else (lambda (x) (thread (lambda () (system* x))))])
 		(mred-program-launcher-path "Framework Test Engine")))
 	     (let-values ([(in out) (tcp-accept listener)])
 	       (set! in-port in)
 	       (set! out-port out))
-	     (send-sexp-to-mred '(require-library "framework.ss" "framework")))])
+	     (send-sexp-to-mred
+	      '(let ([s (make-semaphore 0)])
+		 (queue-callback (lambda ()
+				   (require-library "framework.ss" "framework")
+				   (semaphore-post s)))
+		 (semaphore-wait s))))])
       (values
        (lambda ()
 	 (shutdown-mred)
@@ -61,7 +66,7 @@
 		      (or (not (char-ready? in-port))
 			  (not (eof-object? (peek-char in-port)))))
 	   (restart-mred))
-	 (printf "sending to mred:~n")
+	 (printf "~a: sending to mred:~n" section-name)
 	 (parameterize ([pretty-print-print-line
 			 (let ([prompt "  "]
 			       [old-liner (pretty-print-print-line)])
@@ -101,21 +106,27 @@
 		 [(normal) (second answer)]))))))))
 
 (define section-jump void)
+(define section-name "<<setup>>")
 
 (define test
   (case-lambda
-   [(test-name failed? sexp/proc) (test test-name failed? sexp/proc 'section)]
-   [(test-name failed? sexp/proc jump)
+   [(test-name passed? sexp/proc) (test test-name passed? sexp/proc 'section)]
+   [(test-name passed? sexp/proc jump)
     (let ([failed
 	   (with-handlers ([(lambda (x) #t)
 			    (lambda (x)
 			      (if (exn? x)
 				  (exn-message x)
 				  x))])
-	     (failed?
-	      (if (procedure? sexp/proc)
-		  (sexp/proc)
-		  (eval (send-sexp-to-mred sexp/proc)))))])
+	     (let ([result
+		    (if (procedure? sexp/proc)
+			(sexp/proc)
+			(eval (send-sexp-to-mred sexp/proc)))])
+
+	       ;; this is here to help catch any errors in generated events
+	       (send-sexp-to-mred 'check-for-errors)
+
+	       (not (passed? result))))])
       (when failed
 	(printf "FAILED ~a: ~a~n" test-name failed)
 	(case jump
@@ -139,18 +150,21 @@
   (printf "saved preferences file~n")
   (copy-file preferences-file old-preferences-file))
 
+(load-relative "utils.ss")
+
 (let ([all-files (map symbol->string (load-relative "README"))])
   (for-each (lambda (x)
 	      (when (member x all-files)
 		(let ([oh (error-escape-handler)])
 		  (let/ec k
-		    (error-escape-handler (lambda ()
-					    (error-escape-handler oh)
-					    (k (void))))
-		    (set! section-jump k)
-		    (printf "beginning ~a test suite~n" x)
-		    (load-relative x)
-		    (error-escape-handler oh)))))
+		    (fluid-let ([section-name x]
+				[section-jump k])
+		      (error-escape-handler (lambda ()
+					      (error-escape-handler oh)
+					      (k (void))))
+		      (printf "beginning ~a test suite~n" x)
+		      (load-relative x)
+		      (error-escape-handler oh))))))
 	    (if (equal? (vector) argv)
 		all-files
 		(vector->list argv))))

collects/tests/framework/prefs.ss

@@ -1,8 +1,13 @@
-(local [(define pref-file (build-path (find-system-path 'pref-dir) ".mred.prefs"))
+(local [(define pref-file (build-path (find-system-path 'pref-dir)
+				      (case (system-type)
+					[(macos) "MrEd Preferences"]
+					[(windows) "mred.pre"]
+					[(unix) ".mred.prefs"]
+					[else (error 'prefs.ss "unknown os: ~a~n" (system-type))])))
 	(define old-prefs (if (file-exists? pref-file)
 			      (call-with-input-file pref-file read)
 			      null))
-	(define (check-eq? m s) (lambda (t) (if (eq? s t) #f m)))
+	(define (check-eq? s) (lambda (t) (eq? s t)))
 	(define pref-sym 'framework:test-suite)]
 
   (call-with-output-file pref-file
@@ -11,23 +16,27 @@
 			  port))
     'truncate)
   (shutdown-mred)
+
   (test
    'preference-unbound
-   (check-eq? "couldn't remove preference binding" 'passed)
+   (check-eq? 'passed)
    `(with-handlers ([exn:unknown-preference?
 		     (lambda (x)
 		       'passed)])
       (preferences:get ',pref-sym)))
   (test 'preference-set-default/get
-	(check-eq? "set-default followed by get didn't work" 'passed)
+	(check-eq? 'passed)
 	`(begin (preferences:set-default ',pref-sym 'passed symbol?)
 		(preferences:get ',pref-sym)))
   (test 'preference-set/get
-	(check-eq? "set followed by get didn't work" 'new-pref)
+	(check-eq? 'new-pref)
 	`(begin (preferences:set ',pref-sym 'new-pref)
 		(preferences:get ',pref-sym)))
-  (send-sexp-to-mred '(exit:exit))
-  (shutdown-mred)
+  (with-handlers ([eof-result? (lambda (x) (void))])
+    (send-sexp-to-mred '(begin (preferences:set 'framework:verify-exit #f) (exit:exit))))
+
   (test 'preference-get-after-restart
-	(check-eq? "get after restart didn't work" 'new-pref)
-	`(preferences:get ',pref-sym)))
+	(check-eq? 'new-pref)
+	`(begin (preferences:set-default ',pref-sym 'passed symbol?)
+		(preferences:get ',pref-sym))))
+