...

original commit: a6f1127374e372b5695cfb7ac26090647877825e

collects/framework/frame.ss

@@ -787,8 +787,8 @@
 			(send offb ok?))
 	       (register-collecting-blit gc-canvas 
 					 0 0
-					 (icon:get-gc-width)
-					 (icon:get-gc-height)
+					 (send onb get-width)
+					 (send onb get-height)
 					 onb offb))))])
       
       (sequence
@@ -798,13 +798,18 @@
 		  (list rest-panel))))
 	(register-gc-blit)
 	
-	(let ([gc-width (icon:get-gc-width)]
-	      [gc-height (icon:get-gc-height)])
-	  (send* gc-canvas
-		 (min-client-width gc-width)
-		 (min-client-height gc-height)
-		 (stretchable-width #f)
-		 (stretchable-height #f)))
+	(let* ([gcb (icon:get-gc-on-bitmap)]
+	       [gc-width (if (send gcb ok?)
+			     (send gcb get-width)
+			     10)]
+	       [gc-height (if (send gcb ok?)
+			      (send gcb get-height)
+			      10)])
+	  '(send* gc-canvas
+		  (min-client-width gc-width)
+		  (min-client-height gc-height)
+		  (stretchable-width #f)
+		  (stretchable-height #f)))
 	(send* (get-info-panel) 
 	       (set-alignment 'right 'center)
 	       (stretchable-height #f)

collects/framework/frameworks.ss

@@ -202,9 +202,7 @@
    get-anchor-bdc
    
    get-gc-on-bitmap
-   get-gc-off-bitmap
-   get-gc-width
-   get-gc-height))
+   get-gc-off-bitmap))
 
 (define-signature framework:keymap^
   (set-keymap-error-handler

collects/framework/icon.ss

@@ -66,12 +66,6 @@
       (set! gc-on-bitmap ((load-icon "recycle.gif" 'gif)))))
 
   (define (get-gc-on-bitmap) (fetch) gc-on-bitmap)
-  (define (get-gc-width) (fetch) (if (send gc-on-bitmap ok?)
-				     (send gc-on-bitmap get-width)
-				     10))
-  (define (get-gc-height) (fetch) (if (send gc-on-bitmap ok?)
-				      (send gc-on-bitmap get-height)
-				      10))
   
   (define get-gc-off-bitmap
     (let ([bitmap #f])
@@ -79,8 +73,11 @@
 	(if bitmap
 	    bitmap
 	    (begin
-	      (let ([bdc (make-object bitmap-dc%)])
-		(set! bitmap (make-object bitmap% (get-gc-width) (get-gc-height)))
+	      (let ([bdc (make-object bitmap-dc%)]
+		    [onb (get-gc-on-bitmap)])
+		(set! bitmap (make-object bitmap%
+			       (send onb get-width)
+			       (send onb get-height)))
 		(send bdc set-bitmap bitmap)
 		(send bdc clear)
 		(send bdc set-bitmap #f)

collects/tests/framework/main.ss

@@ -12,7 +12,9 @@
   ((struct eof-result ())
    load-framework-automatically
    shutdown-listener shutdown-mred mred-running? send-sexp-to-mred
-   test wait-for-frame))
+   test
+   wait-for-frame
+   wait-for))
 
 (define-signature internal-TestSuite^
   ((open TestSuite^)
@@ -178,18 +180,21 @@
 		  [(continue) (void)]
 		  [else (jump)])))))]))
 
-    (define (wait-for-frame name)
+    (define (wait-for sexp)
       (let ([timeout 10]
 	    [pause-time 1/2])
 	(send-sexp-to-mred
 	 `(let loop ([n ,(/ timeout pause-time)])
 	    (if (zero? n)
-		(error 'wait-for-mred-frame
-		       ,(format "after ~a seconds, frame labelled ~s didn't appear" timeout name))
-		(let ([win (get-top-level-focus-window)])
-		  (unless (and win (string=? (send win get-label) ,name))
-		    (sleep ,pause-time)
-		    (loop (- n 1)))))))))))
+		(error 'wait-for
+		       ,(format "after ~a seconds, ~s didn't come true" timeout sexp))
+		(unless ,sexp
+		  (sleep ,pause-time)
+		  (loop (- n 1))))))))
+
+    (define (wait-for-frame name)
+      (wait-for `(let ([win (get-top-level-focus-window)])
+		   (and win (string=? (send win get-label) ,name)))))))
 
 (define Engine
   (unit/sig Engine^

collects/tests/framework/pasteboard.ss

@@ -0,0 +1,44 @@
+(define (test-creation frame class name)
+  (test
+   name
+   (lambda (x) #t)
+   (lambda ()
+     (send-sexp-to-mred
+      `(let* ([% (class-asi ,frame
+		   (override
+		     [get-editor%
+		      (lambda ()
+			,class)]))]
+	      [f (make-object % "test pasteboard")])
+	 (send f show #t)))
+      (wait-for-frame "test pasteboard")
+      (send-sexp-to-mred
+       `(send (get-top-level-focus-window) show #f)))))
+
+(test-creation 'frame:editor%
+	       '(editor:basic-mixin pasteboard%)
+	       'editor:basic-mixin-creation)
+(test-creation 'frame:editor%
+	       'pasteboard:basic%
+	       'pasteboard:basic-creation)
+
+(test-creation 'frame:editor%
+	       '(editor:file-mixin pasteboard:basic%)
+	       'editor:file-mixin-creation)
+(test-creation 'frame:editor%
+	       'pasteboard:file%
+	       'pasteboard:file-creation)
+
+(test-creation 'frame:editor%
+	       '(editor:backup-autosave-mixin pasteboard:file%)
+	       'editor:backup-autosave-mixin-creation)
+(test-creation 'frame:editor%
+	       'pasteboard:backup-autosave%
+	       'pasteboard:backup-autosave-creation)
+
+(test-creation 'frame:pasteboard-info%
+	       '(editor:info-mixin pasteboard:backup-autosave%)
+	       'editor:info-mixin-creation)
+(test-creation 'frame:pasteboard-info%
+	       'pasteboard:info%
+	       'pasteboard:info-creation)

collects/tests/framework/text.ss

@@ -10,6 +10,9 @@
 	      [f (make-object % "test text")])
 	 (send f show #t)))
       (wait-for-frame "test text")
+      (send-sexp-to-mred
+       `(test:keypress #\a))
+      (wait-for `(string=? "a" (send (send (get-top-level-focus-window) get-editor) get-text)))
       (send-sexp-to-mred
        `(send (get-top-level-focus-window) show #f)))))