fix get-face-list 'mono under Mac OS X and X, and delay showing children of a frame during a container sequence

svn: r6563

original commit: 1131abd11f6fd8b46c0f8f74c9cf2e7629961eeb

collects/mred/private/wxcanvas.ss

@@ -62,6 +62,7 @@
   (define wx-canvas% 
     (make-canvas-glue%
      (class100 (make-control% wx:canvas% 0 0 #t #t) (parent x y w h style gl-config)
+       (inherit get-top-level)
        (private-field
 	[tabable? #f])
        (public
@@ -74,13 +75,16 @@
 	  (lambda (code alpha? meta?)
 	    (or meta? (not tabable?)))])
        (sequence
-	 (super-init style parent x y w h style "canvas" gl-config)))))
+	 (super-init style parent x y w h (cons 'deleted style) "canvas" gl-config)
+         (unless (memq 'deleted style)
+           (send (get-top-level) show-control this #t))))))
 
   (define (make-editor-canvas% %)
     (class100 % (parent x y w h name style spp init-buffer)
       (inherit get-editor force-redraw
 	       call-as-primary-owner min-height get-size
-	       get-hard-minimum-size set-min-height)
+	       get-hard-minimum-size set-min-height
+               get-top-level)
       (private-field
        [fixed-height? #f]
        [fixed-height-lines 0]
@@ -195,7 +199,9 @@
 			(when fixed-height? (update-size)))])
       
       (sequence
-	(super-init style parent x y w h (or name "") style spp init-buffer)
+	(super-init style parent x y w h (or name "") (cons 'deleted style) spp init-buffer)
+        (unless (memq 'deleted style)
+          (send (get-top-level) show-control this #t))
 	(when init-buffer
 	  (let ([mred (wx->mred this)])
 	    (when mred

collects/mred/private/wxitem.ss

@@ -40,7 +40,7 @@
     (lambda (item% x-margin-w y-margin-h stretch-x stretch-y)
       (class100 (wx-make-window% item% #f) (window-style . args)
 	(inherit get-width get-height get-x get-y
-		 get-parent get-client-size)
+		 get-parent get-client-size get-top-level)
 	(private-field [enabled? #t])
 	(override
 	  [enable
@@ -197,6 +197,7 @@
 	  (set-min-height (init-min (get-height)))
 
 	  (unless (memq 'deleted window-style)
+            (send (get-top-level) show-control this #t)
 	    ;; For a pane[l], the creator must call the equivalent of the following,
 	    ;;  delaying to let the panel's wx field get initialized before
 	    ;;  panel-sizing methods are called
@@ -233,7 +234,7 @@
 				     (as-exit
 				      (lambda ()
 					(command (make-object wx:control-event% 'button)))))])
-			(sequence (super-init style parent cb label x y w h style font)
+			(sequence (super-init style parent cb label x y w h (cons 'deleted style) font)
 				  (when border?
 				    (send (get-top-level) add-border-button this))))))
   (define wx-check-box% (class100 (make-window-glue% (make-simple-control% wx:check-box%)) (mred proxy parent cb label x y w h style font)
@@ -244,17 +245,17 @@
 					(lambda ()
 					  (set-value (not (get-value)))
 					  (command (make-object wx:control-event% 'check-box)))))])
-			  (sequence (super-init mred proxy style parent cb label x y w h style font))))
+			  (sequence (super-init mred proxy style parent cb label x y w h (cons 'deleted style) font))))
   (define wx-choice% (class100 (make-window-glue% (make-simple-control% wx:choice%)) (mred proxy parent cb label x y w h choices style font)
 		       (override 
 			 [handles-key-code 
 			  (lambda (x alpha? meta?) 
 			    (or (memq x '(up down))
 				(and alpha? (not meta?))))])
-		       (sequence (super-init mred proxy style parent cb label x y w h choices style font))))
+		       (sequence (super-init mred proxy style parent cb label x y w h choices (cons 'deleted style) font))))
   (define wx-message% (class100 (make-window-glue% (make-simple-control% wx:message%)) (mred proxy parent label x y style font)
 			(override [gets-focus? (lambda () #f)])
-			(sequence (super-init mred proxy style parent label x y style font))))
+			(sequence (super-init mred proxy style parent label x y (cons 'deleted style) font))))
 
   (define wx-gauge%
     (make-window-glue% 
@@ -270,7 +271,7 @@
 	;; # pixels per unit of value.
 	[pixels-per-value 1])
        (sequence
-	 (super-init style parent label range -1 -1 -1 -1 style font)
+	 (super-init style parent label range -1 -1 -1 -1 (cons 'deleted style) font)
 
 	 (let-values ([(client-width client-height) (get-two-int-values 
 						     (lambda (a b) (get-client-size a b)))])
@@ -337,7 +338,7 @@
 			      [(wheel-up) (scroll -1) #t]
 			      [(wheel-down) (scroll 1) #t]
 			      [else #f])))])
-       (sequence (super-init style parent cb label kind x y w h choices style font label-font)))))
+       (sequence (super-init style parent cb label kind x y w h choices (cons 'deleted style) font label-font)))))
 
   (define wx-radio-box%
     (make-window-glue% 
@@ -365,7 +366,7 @@
 			      (set-selection i)
 			      (command (make-object wx:control-event% 'radio-box)))))])
 
-       (sequence (super-init style parent cb label x y w h choices major style font))
+       (sequence (super-init style parent cb label x y w h choices major (cons 'deleted style) font))
 
        (private-field [enable-vector (make-vector (number) #t)]))))
 
@@ -385,7 +386,7 @@
        ;; which looks bad.
        
        (sequence
-	 (super-init style parent func label value min-val max-val -1 -1 -1 style font)
+	 (super-init style parent func label value min-val max-val -1 -1 -1 (cons 'deleted style) font)
 	 
 	 (let-values ([(client-w client-h) (get-two-int-values (lambda (a b)
 								 (get-client-size a b)))])

collects/mred/private/wxpanel.ss

@@ -34,6 +34,7 @@
 	[on-size (lambda () (void))]
 	[enable (lambda () (void))]
 	[show (lambda (on?) (void))]
+        [is-shown? (lambda () #f)]
 	[is-shown-to-root? (lambda () (send parent is-shown-to-root?))]
 	[is-enabled-to-root? (lambda () (send parent is-enabled-to-root?))]
 	[get-parent (lambda () parent)]
@@ -454,7 +455,9 @@
 		     child-infos
 		     placements))])
 	       (sequence
-		 (super-init style parent -1 -1 0 0 style))))
+		 (super-init style parent -1 -1 0 0 (cons 'deleted style))
+                 (unless (memq 'deleted style)
+                   (send (get-top-level) show-control this #t)))))
 
   (define (wx-make-pane% wx:panel% stretch?)
     (class100 (make-container-glue% (make-glue% (wx-make-basic-panel% wx:panel% stretch?))) args

collects/mred/private/wxtop.ss

@@ -95,7 +95,8 @@
 
        [parent-for-center parent]
 
-       [show-ht (make-hash-table)])
+       [show-ht (make-hash-table)]
+       [fake-show-ht (make-hash-table)])
       
       (override
 	[enable
@@ -196,6 +197,13 @@
 	   (when perform-updates?
 	     (when pending-redraws?
 	       (force-redraw))
+	     (when (positive? (hash-table-count fake-show-ht))
+	       (let ([t fake-show-ht])
+		 (set! fake-show-ht (make-hash-table))
+		 (hash-table-for-each
+		  t
+		  (lambda (win v?)
+		    (send win really-show #t)))))
 	     (when (positive? (hash-table-count show-ht))
 	       (let ([t show-ht])
 		 (set! show-ht (make-hash-table))
@@ -220,6 +228,21 @@
 	       (send child show show?)
 	       (hash-table-put! show-ht child show?)))]
 
+        [show-control
+         (lambda (child on?)
+           (if (or perform-updates?
+                   (not on?)
+                   (child . is-a? . wx-frame%)
+                   (child . is-a? . wx-dialog%))
+               (send child really-show on?)
+               (begin
+                 (if on?
+                     (hash-table-put! fake-show-ht child #t)
+                     (begin
+                       (hash-table-remove! show-ht child)
+                       (hash-table-remove! fake-show-ht child)))
+                 (send child fake-show on?))))]
+
 	;; force-redraw: receives a message from to redraw the
 	;; entire frame.
 	;; input: none

collects/mred/private/wxwindow.ss

@@ -52,7 +52,8 @@
 	(rename [super-enable enable])
 	
 	(private-field
-	 [can-accept-drag? #f])
+	 [can-accept-drag? #f]
+         [fake-shown? #f])
 
 	(public
 	  [accept-drag? (lambda () can-accept-drag?)]
@@ -77,11 +78,24 @@
 		   (set! top-level window)]
 		  [else (loop (send window get-parent))])))
 	     top-level)])
+        (public
+          [really-show
+           (lambda (on?)
+             (set! fake-shown? #f)
+             (super show on?))]
+          [fake-show
+           (lambda (on?)
+             (set! fake-shown? on?))])
 	(override
 	  [show
 	   (lambda (on?)
 	     (queue-visible)
-	     (super show on?))]
+             (send (get-top-level) show-control this on?))]
+          [is-shown?
+           (lambda ()
+             (or fake-shown?
+                 (super is-shown?)))]
+
 	  [enable
 	   (lambda (on?)
 	     (queue-active)