...

original commit: f75522f31ed1825eeaba116d1bf0e01cc6028f87

collects/framework/editor.ss

@@ -156,13 +156,11 @@
 	 (lambda (x)
 	   (set! is-locked? x)
 	   (super-lock x))]
-	;[on-new-box
-	; (lambda (type)
-	;   (cond
-	;     [(eq? type 'text) (make-object editor-snip% (make-object text:basic%))]
-	;     [else (make-object editor-snip% (make-object pasteboard:basic%))]))]
-	;; need a snipclass to handle copying/pasting. This isn't enough.
-	)
+	[on-new-box
+	 (lambda (type)
+	   (cond
+	     [(eq? type 'text) (make-object editor-snip% (make-object text:basic%))]
+	     [else (make-object editor-snip% (make-object pasteboard:basic%))]))])
 
 
       (override

collects/framework/main.ss

@@ -50,6 +50,7 @@
 		 class class* class-asi class-asi*
 		 define-some do opt-lambda send*
 		 local catch shared
+                 make-object
 		 unit/sig
 		 with-handlers
 		 interface

collects/tests/framework/group-test.ss

@@ -4,6 +4,7 @@
  (lambda ()
    (send-sexp-to-mred
     '(begin (send (make-object frame:basic% "test") show #t)
+	    (preferences:set 'framework:verify-exit #f)
 	    (preferences:set 'framework:exit-when-no-frames #f)))
    (wait-for-frame "test")
    (send-sexp-to-mred
@@ -18,6 +19,7 @@
  (lambda ()
    (send-sexp-to-mred
     '(begin (send (make-object frame:basic% "test") show #t)
+	    (preferences:set 'framework:verify-exit #t)
 	    (preferences:set 'framework:exit-when-no-frames #t)))
    (wait-for-frame "test")
    (send-sexp-to-mred

collects/tests/framework/handler-test.ss

@@ -10,19 +10,8 @@
 	      (void)))
      (wait-for-frame filename)
      (send-sexp-to-mred
-      `(map (lambda (x) (send x get-label)) (get-top-level-windows)))))
-
-  (test
-   'file-opened
-   (lambda (x) (equal? filename x))
-   (lambda ()
-     (send-sexp-to-mred
-      `(begin (handler:edit-file ,tmp-filename)
-	      (void)))
-     (wait-for-frame filename)
-     (send-sexp-to-mred
-      `(let ([f (car (get-top-level-windows))])
-	 (send (send f get-editor) get-filename)))))
+      `(begin0 (map (lambda (x) (send x get-label)) (get-top-level-windows))
+               (send (car (get-top-level-windows)) close)))))
 
   (test
    'files-opened-twice
@@ -37,4 +26,17 @@
 	      (void)))
      (wait-for-frame filename)
      (send-sexp-to-mred
-      `(map (lambda (x) (send x get-label)) (get-top-level-windows))))))
+      `(begin0 (map (lambda (x) (send x get-label)) (get-top-level-windows))
+               (send (car (get-top-level-windows)) close)))))
+
+  (test
+   'file-opened-in-editor
+   (lambda (x) (equal? filename x))
+   (lambda ()
+     (send-sexp-to-mred
+      `(begin (handler:edit-file ,tmp-filename)
+	      (void)))
+     (wait-for-frame filename)
+     (send-sexp-to-mred
+      `(let ([f (car (get-top-level-windows))])
+	 (send (send f get-editor) get-filename))))))

collects/tests/framework/load.ss

@@ -23,7 +23,8 @@
       (require-library "tests.ss" "framework")
       (require-library "mred-interfaces.ss" "framework")
       (eval
-       '(invoke-open-unit/sig
+       '(define-values/invoke-unit/sig
+         ((unit test : framework:test^))
 	 (compound-unit/sig
 	   (import)
 	   (link [mred : mred-interfaces^ (mred-interfaces@)]
@@ -60,13 +61,14 @@
    'mred-interfaces.ss/gen
    (lambda (x) x)
    '(parameterize ([current-namespace (make-namespace 'mred)])
+      (require-library "invoke.ss")
       (require-library "mred-interfaces.ss" "framework")
       (eval
-       '(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%)])
+       '(let ([orig-button% button%])
+	  (define-values/invoke-unit/sig mred-interfaces^ mred-interfaces@)
+	  (let ([first-button% button%])
+	    (define-values/invoke-unit/sig mred-interfaces^ mred-interfaces@)
+	    (let ([second-button% button%])
 	      (and (eq? second-button% first-button%)
 		   (not (eq? first-button% orig-button%)))))))))
   (test
@@ -76,7 +78,8 @@
       (require-library "frameworks.ss" "framework")
       (require-library "mred-interfaces.ss" "framework")
       (eval
-       '(invoke-open-unit/sig
+       '(define-values/invoke-unit/sig
+         framework^
 	 (compound-unit/sig
 	   (import)
 	   (link [mred : mred-interfaces^ (mred-interfaces@)]

collects/tests/framework/main.ss

@@ -299,10 +299,10 @@
 	
 	(when (file-exists? preferences-file)
 	  (printf "  saving preferences file ~s to ~s~n" preferences-file old-preferences-file)
-	  (when (file-exists? old-preferences-file)
-	    (error 'framework-test "backup preferences file exists, aborting"))
-	  (printf "  saved preferences file~n")
-	  (copy-file preferences-file old-preferences-file))
+	  (if (file-exists? old-preferences-file)
+              (printf "  backup preferences file exists, using that one~n")
+              (begin (copy-file preferences-file old-preferences-file)
+                     (printf "  saved preferences file~n"))))
     
 	(for-each (lambda (x)
 		    (when (member x all-files)

collects/tests/utils/gui.ss

@@ -1,4 +1,6 @@
 (require-library "guis.ss" "tests" "utils")
 
-(invoke-open-unit/sig
- (require-library "guir.ss" "tests" "utils") #f mred^)
+(define-values/invoke-unit/sig test-utils:gui^
+ (require-library "guir.ss" "tests" "utils")
+ #f
+ mred^)