some fixes prompted by the test suite

original commit: 4f2e59e7a654c9724d546f619589ca68cc334d59

collects/mred/private/wx/cocoa/canvas.rkt

@@ -331,9 +331,12 @@
           (if (or is-combo? (not (memq 'gl style)))
               (tell (tell (if is-combo? MyComboBox MyView) alloc) 
                     initWithFrame: #:type _NSRect r)
+              (let ([pf (gl-config->pixel-format gl-config)])
+                (begin0
                  (tell (tell MyGLView alloc) 
                        initWithFrame: #:type _NSRect r
-                    pixelFormat: (gl-config->pixel-format gl-config))))))
+                       pixelFormat: pf)
+                 (tellv pf release)))))))
      (tell #:type _void cocoa addSubview: content-cocoa)
      (set-ivar! content-cocoa wxb (->wxb this))
 
@@ -462,12 +465,12 @@
        (scroll-page h-scroller h-page)
        (scroll-pos h-scroller h-pos)
        (when h-scroller
-         (tell (scroller-cocoa h-scroller) setEnabled: #:type _BOOL (and h-step (positive? h-len))))
+         (tellv (scroller-cocoa h-scroller) setEnabled: #:type _BOOL (and h-step (positive? h-len))))
        (scroll-range v-scroller v-len)
        (scroll-page v-scroller v-page)
        (scroll-pos v-scroller v-pos)
        (when v-scroller
-         (tell (scroller-cocoa v-scroller) setEnabled: #:type _BOOL (and v-step (positive? v-len)))))
+         (tellv (scroller-cocoa v-scroller) setEnabled: #:type _BOOL (and v-step (positive? v-len)))))
 
      (define/override (reset-dc-for-autoscroll)
        (fix-dc))
@@ -484,12 +487,20 @@
      (define/public (set-scroll-pos which v)
        (update which scroll-pos v))
 
+     (define/private (guard-scroll which v)
+       (if (is-auto-scroll?)
+           0
+           v))
+
      (define/public (get-scroll-page which) 
-       (scroll-page (if (eq? which 'vertical) v-scroller h-scroller)))
+       (guard-scroll which
+                     (scroll-page (if (eq? which 'vertical) v-scroller h-scroller))))
      (define/public (get-scroll-range which)
-       (scroll-range (if (eq? which 'vertical) v-scroller h-scroller)))
+       (guard-scroll which
+                     (scroll-range (if (eq? which 'vertical) v-scroller h-scroller))))
      (define/public (get-scroll-pos which)
-       (scroll-pos (if (eq? which 'vertical) v-scroller h-scroller)))
+       (guard-scroll which
+                     (scroll-pos (if (eq? which 'vertical) v-scroller h-scroller))))
      
      (define v-scroller
        (and vscroll-ok?
@@ -703,7 +714,7 @@
        (when (y . > . 0) (scroll-pos v-scroller (* y (scroll-range v-scroller))))
        (when (is-auto-scroll?) (refresh-for-autoscroll)))
 
-     (def/public-unimplemented warp-pointer)
+     (define/public (warp-pointer x y) (void))
 
      (define/override (get-virtual-h-pos)
        (scroll-pos h-scroller))

collects/mred/private/wx/cocoa/choice.rkt

@@ -58,7 +58,7 @@
                         [time-stamp (current-milliseconds)])))
   
   (define/public (set-selection i)
-    (tell (get-cocoa) selectItemAtIndex: #:type _NSInteger i))
+    (tellv (get-cocoa) selectItemAtIndex: #:type _NSInteger i))
   (define/public (get-selection)
     (tell #:type _NSInteger (get-cocoa) indexOfSelectedItem))
   (define/public (number)

collects/mred/private/wx/cocoa/frame.rkt

@@ -121,7 +121,7 @@
     (inherit get-cocoa get-parent
              get-eventspace
              pre-on-char pre-on-event
-             get-x get-y
+             get-x
              on-new-child)
 
     (super-new [parent parent]
@@ -168,7 +168,8 @@
       (atomically
        (let ([tb (tell (tell NSToolbar alloc) initWithIdentifier: #:type _NSString "Ok")])
          (tellv cocoa setToolbar: tb)
-         (tellv tb setVisible: #:type _BOOL #f))))
+         (tellv tb setVisible: #:type _BOOL #f)
+         (tellv tb release))))
 
     (move -11111 (if (= y -11111) 0 y))
 
@@ -380,6 +381,9 @@
 
     (define/override (flip y h) (flip-screen (+ y h)))
 
+    (define/override (get-y)
+      (- (super get-y) (if caption? 22 0)))
+
     (define/override (set-size x y w h)
       (unless (and (= x -1) (= y -1))
         (move x y))
@@ -399,10 +403,6 @@
                                                  (NSPoint-x (NSRect-origin f)))
                                              ;; keep current y position:
                                              (- (NSPoint-y (NSRect-origin f))
-                                                ;; we have to subtract add the titlebar height, for some reason:
-                                                (if caption?
-                                                    (- 22)
-                                                    0)
                                                 (- h
                                                    (NSSize-height (NSRect-size f)))))
                                (make-NSSize w h))

collects/mred/private/wx/cocoa/gauge.rkt

@@ -32,7 +32,10 @@
   (inherit get-cocoa)
 
   (super-new [parent parent]
-             [cocoa (let ([cocoa (as-objc-allocation
+             [cocoa (let ([cocoa (values ; as-objc-allocation
+                                  ;; We're leaving guages for now. There's some problem
+                                  ;; releasing gauges through a finalizer. My guess is that
+                                  ;; it has something to do with animation in a separate thread.
                                   (tell (tell MyProgressIndicator alloc) init))])
                       (tellv cocoa setIndeterminate: #:type _BOOL #f)
                       (tellv cocoa setMaxValue: #:type _double* rng)
@@ -60,7 +63,8 @@
   (define/public (get-range)
     (inexact->exact (floor (tell #:type _double cocoa maxValue))))
   (define/public (set-range rng)
-    (tellv cocoa setMaxValue: #:type _double* rng))
+    (tellv cocoa setMaxValue: #:type _double* rng)
+    (tellv cocoa setDoubleValue: #:type _double* (min rng (tell #:type _double cocoa doubleValue))))
 
   (define/public (set-value v)
     (tellv cocoa setDoubleValue: #:type _double* v))

collects/mred/private/wx/cocoa/list-box.rkt

@@ -92,7 +92,8 @@
   (tellv cocoa setDocumentView: content-cocoa)
   (tellv cocoa setHasVerticalScroller: #:type _BOOL #t)
   (tellv content-cocoa setHeaderView: #f)
-  (unless (eq? kind 'single)
+  (define allow-multi? (not (eq? kind 'single)))
+  (when allow-multi?
     (tellv content-cocoa setAllowsMultipleSelection: #:type _BOOL #t))
 
   (define/override (get-cocoa-content) content-cocoa)
@@ -174,7 +175,7 @@
           (let ([index (tell (tell NSIndexSet alloc) initWithIndex: #:type _NSUInteger i)])
             (tellv content-cocoa 
                    selectRowIndexes: index
-                   byExtendingSelection: #:type _BOOL extend?))))
+                   byExtendingSelection: #:type _BOOL (and extend? allow-multi?)))))
         (tellv content-cocoa deselectRow: #:type _NSInteger i)))
   (define/public (set-selection i)
     (select i #t #f))

collects/mred/private/wx/cocoa/menu.rkt

@@ -115,7 +115,8 @@
   (def/public-unimplemented set-width)
   (def/public-unimplemented set-title)
 
-  (def/public-unimplemented set-help-string)
+  (define/public (set-help-string m s) (void))
+
   (def/public-unimplemented number)
 
   (define/private (find-pos item)

collects/mred/private/wx/cocoa/panel.rkt

@@ -82,5 +82,5 @@
               (as-objc-allocation
                (tell (tell MyPanelView alloc)
                      initWithFrame: #:type _NSRect (make-NSRect (make-init-point x y)
-                                                                (make-NSSize w h))))]
+                                                                (make-NSSize (max 1 w) (max 1 h)))))]
              [no-show? (memq 'deleted style)]))

collects/mred/private/wx/cocoa/queue.rkt

@@ -214,6 +214,7 @@
 ;; Call this function only in atomic mode:
 (define (check-one-event wait? dequeue?)
   (pre-event-sync wait?)
+  (clean-up-deleted)
   (let ([pool (tell (tell NSAutoreleasePool alloc) init)])
     (when (and events-suspended? wait?)
       (set! was-menu-bar #f)

collects/mred/private/wx/cocoa/radio-box.rkt

@@ -117,11 +117,13 @@
         0
         (set-focus)))
 
-  (define/public (enable-button i on?)
+  (define/private (get-button i)
-    (tellv (tell (get-cocoa)
+    (tell (get-cocoa)
           cellAtRow: #:type _NSUInteger (if horiz? 0 i)
-                 column: #:type _NSUInteger (if horiz? i 0))
+          column: #:type _NSUInteger (if horiz? i 0)))
-           setEnabled: #:type _BOOL on?))
+
+  (define/public (enable-button i on?)
+    (tellv (get-button i) setEnabled: #:type _BOOL on?))
 
   (define/public (set-selection i)
     (if (= i -1)

collects/mred/private/wx/cocoa/utils.rkt

@@ -3,7 +3,8 @@
          ffi/unsafe
          ffi/unsafe/alloc
          ffi/unsafe/define
-         "../common/utils.rkt")
+         "../common/utils.rkt"
+         "../../lock.rkt")
 
 (provide cocoa-lib
          cf-lib
@@ -14,6 +15,7 @@
          define-mz
          as-objc-allocation
          as-objc-allocation-with-retain
+         clean-up-deleted
          retain release
          with-autorelease
          clean-menu-label
@@ -31,8 +33,19 @@
 (define-ffi-definer define-appserv appserv-lib)
 (define-ffi-definer define-appkit appkit-lib)
 
-(define (objc-delete v)
+(define delete-me null)
-  (tellv v release))
+
+(define (objc-delete o)
+  (atomically
+   (set! delete-me (cons o delete-me))))
+
+(define (clean-up-deleted)
+  ;; called outside the event loop to actually delete objects
+  ;; that might otherwise be in use during a callback
+  (for ([o (in-list (begin0
+                     delete-me
+                     (set! delete-me null)))])
+    (tellv o release)))
 
 (define objc-allocator (allocator objc-delete))
 
@@ -59,7 +72,7 @@
   (let ([pool (tell (tell NSAutoreleasePool alloc) init)])
     (begin0
      (thunk)
-     (release pool))))
+     (tellv pool release))))
 
 (define (clean-menu-label str)
   (regexp-replace* #rx"&(.)" str "\\1"))

collects/mred/private/wx/common/backing-dc.rkt

@@ -42,6 +42,8 @@
 
     (super-new)
 
+    (define/override (ok?) #t)
+
     ;; Override this method to get the right size
     (define/public (get-backing-size xb yb)
       (set-box! xb 1)

collects/mred/private/wx/common/queue.rkt

@@ -383,6 +383,10 @@
        [(and (eq? evt 'wait)
              (not handler?))
         #t]
+       ;; `yield' is supposed to return immediately if the
+       ;; event is already ready:
+       [(and (evt? evt) (sync/timeout 0 (wrap-evt evt (lambda (v) (list v)))))
+        => (lambda (v) (car v))]
        [handler?
         (sync (if (eq? evt 'wait) 
                   (wrap-evt e (lambda (_) #t))
@@ -411,18 +415,24 @@
   (eq? e main-eventspace))
 
 (define (queue-callback thunk [high? #t])
-  (queue-event (current-eventspace) thunk (cond
+  (let ([es (current-eventspace)])
+    (when (eventspace-shutdown? es)
+      (error 'queue-callback "eventspace is shutdown: ~e" es))
+    (queue-event es thunk (cond
                            [(not high?) 'lo]
                            [(eq? high? middle-queue-key) 'med]
-                                           [else 'hi])))
+                           [else 'hi]))))
 
 (define middle-queue-key (gensym 'middle))
 
 
-(define (add-timer-callback cb)
+(define (add-timer-callback cb es)
-  (queue-event (current-eventspace) cb 'timer-add))
+  ;; in atomic mode
-(define (remove-timer-callback cb)
+  (queue-event es cb 'timer-add))
-  (queue-event (current-eventspace) cb 'timer-remove))
+(define (remove-timer-callback cb es)
+  ;; in atomic mode
+  (unless (eventspace-shutdown? es)
+    (queue-event es cb 'timer-remove)))
 
 (define (register-frame-shown f on?)
   (queue-event (current-eventspace) f (if on?

collects/mred/private/wx/common/timer.rkt

@@ -15,11 +15,18 @@
   (define current-interval ival)
   (define current-once? (and just-once? #t))
   (define cb #f)
+  (define es (current-eventspace))
+
+  (when (eventspace-shutdown? es)
+    (error (method-name 'timer% 'start) "current eventspace is shutdown: ~e" es))
+
   (def/public (interval) current-interval)
   (define/private (do-start msec once?)
     (as-entry
      (lambda ()
        (do-stop)
+       (when (eventspace-shutdown? es)
+         (error (method-name 'timer% 'start) "current eventspace is shutdown: ~e" es))
        (set! current-interval msec)
        (set! current-once? (and once? #t))
        (letrec ([new-cb
@@ -33,14 +40,14 @@
                                                (when (eq? cb new-cb)
                                                  (do-start msec #f))))))))])
          (set! cb new-cb)
-         (add-timer-callback new-cb)))))
+         (add-timer-callback new-cb es)))))
   (def/public (start [(integer-in 0 1000000000) msec] [any? [once? #f]])
     (do-start msec once?))
   (define/private (do-stop)
     (as-entry
      (lambda ()
        (when cb
-         (remove-timer-callback cb)
+         (remove-timer-callback cb es)
          (set! cb #f)))))
   (def/public (stop) (do-stop))
   (def/public (notify) (notify-cb) (void))

collects/mred/private/wx/gtk/canvas.rkt

@@ -476,14 +476,20 @@
                             (gtk_adjustment_set_value adj v))))))
 
      (define/public (get-scroll-page which) 
-       (->long (dispatch which gtk_adjustment_get_page_size 0)))
+       (if (is-auto-scroll?)
+           0
+           (->long (dispatch which gtk_adjustment_get_page_size 0))))
      (define/public (get-scroll-range which)
+       (if (is-auto-scroll?)
+           0
            (->long (dispatch which (lambda (adj)
                                      (- (gtk_adjustment_get_upper adj)
                                         (gtk_adjustment_get_page_size adj)))
-                         0)))
+                             0))))
      (define/public (get-scroll-pos which)
-       (->long (dispatch which gtk_adjustment_get_value 0)))
+       (if (is-auto-scroll?)
+           0
+           (->long (dispatch which gtk_adjustment_get_value 0))))
      
      (define clear-bg?
        (and (not (memq 'transparent style)) 
@@ -541,12 +547,12 @@
           (when vscroll-adj (gtk_adjustment_set_value vscroll-adj y))))
        (when (is-auto-scroll?) (refresh-for-autoscroll)))
 
-     (def/public-unimplemented warp-pointer)
+     (define/public (warp-pointer x y) (void))
 
      (define/override (get-virtual-h-pos)
-      (gtk_adjustment_get_value hscroll-adj))
+       (inexact->exact (ceiling (gtk_adjustment_get_value hscroll-adj))))
      (define/override (get-virtual-v-pos)
-      (gtk_adjustment_get_value vscroll-adj))
+       (inexact->exact (ceiling (gtk_adjustment_get_value vscroll-adj))))
 
      (define/public (set-resize-corner on?) (void))
 

collects/mred/private/wx/gtk/frame.rkt

@@ -53,6 +53,9 @@
 
 (define-gdk gdk_window_set_cursor (_fun _GdkWindow _pointer -> _void))
 
+(define-gtk gtk_window_iconify (_fun _GtkWindow -> _void))
+(define-gtk gtk_window_deiconify (_fun _GtkWindow -> _void))
+
 (define-cstruct _GdkGeometry ([min_width _int]
                               [min_height _int]
                               [max_width _int]
@@ -429,6 +432,7 @@
         (send in-window enter-window)))
       
     (define maximized? #f)
+    (define is-iconized? #f)
     
     (define/public (is-maximized?)
       maximized?)
@@ -437,11 +441,18 @@
 
     (define/public (on-window-state changed value)
       (when (positive? (bitwise-and changed GDK_WINDOW_STATE_MAXIMIZED))
-        (set! maximized? (positive? (bitwise-and value GDK_WINDOW_STATE_MAXIMIZED)))))
+        (set! maximized? (positive? (bitwise-and value GDK_WINDOW_STATE_MAXIMIZED))))
+      (when (positive? (bitwise-and changed GDK_WINDOW_STATE_ICONIFIED))
+        (set! is-iconized? (positive? (bitwise-and value GDK_WINDOW_STATE_ICONIFIED)))))
+
+    (define/public (iconized?)
+      is-iconized?)
+    (define/public (iconize on?)
+      (if on?
+          (gtk_window_iconify gtk)
+          (gtk_window_deiconify gtk)))
       
-    (def/public-unimplemented iconized?)
     (def/public-unimplemented get-menu-bar)
-    (def/public-unimplemented iconize)
 
     (define/public (set-title s)
       (set! saved-title s)

collects/mred/private/wx/gtk/list-box.rkt

@@ -25,6 +25,9 @@
 (define _GtkCellRenderer (_cpointer 'GtkCellRenderer))
 (define _GtkTreeViewColumn _GtkWidget) ; (_cpointer 'GtkTreeViewColumn)
 
+(define GTK_SELECTION_SINGLE 1)
+(define GTK_SELECTION_MULTIPLE 3)
+
 (define-gtk gtk_scrolled_window_new (_fun _pointer _pointer -> _GtkWidget))
 (define-gtk gtk_scrolled_window_set_policy (_fun _GtkWidget _int _int -> _void))
 
@@ -38,6 +41,7 @@
 (define-gtk gtk_tree_view_column_new_with_attributes (_fun _string _GtkCellRenderer _string _int _pointer -> _GtkTreeViewColumn))
 (define-gtk gtk_tree_view_append_column (_fun _GtkWidget _GtkTreeViewColumn -> _void))
 (define-gtk gtk_tree_view_get_selection (_fun _GtkWidget -> _GtkWidget))
+(define-gtk gtk_tree_selection_set_mode (_fun _GtkWidget _int -> _void))
 (define-gtk gtk_list_store_remove (_fun _GtkListStore _GtkTreeIter-pointer -> _gboolean))
 (define-gtk gtk_tree_model_get_iter (_fun _GtkListStore _GtkTreeIter-pointer _pointer -> _gboolean))
 (define-gtk gtk_tree_view_scroll_to_cell (_fun _GtkWidget _pointer _pointer _gboolean _gfloat _gfloat -> _void))
@@ -112,6 +116,11 @@
   (define selection
     (gtk_tree_view_get_selection client-gtk))
 
+  (gtk_tree_selection_set_mode selection (if (or (eq? kind 'extended)
+                                                 (eq? kind 'multiple))
+                                             GTK_SELECTION_MULTIPLE
+                                             GTK_SELECTION_SINGLE))
+
   (super-new [parent parent]
              [gtk gtk]
              [extra-gtks (list client-gtk selection)]

collects/mred/private/wx/gtk/menu.rkt

@@ -220,7 +220,7 @@
   (def/public-unimplemented set-width)
   (def/public-unimplemented set-title)
 
-  (def/public-unimplemented set-help-string)
+  (define/public (set-help-string m s) (void))
 
   (define/public (number) (length items))
 

collects/mred/private/wx/win32/list-box.rkt

@@ -69,8 +69,8 @@
                                     (if (memq 'hscroll style) WS_HSCROLL 0)
                                     (cond
                                      ;; Win32 sense of "multiple" and "extended" is backwards
-                                     [(memq 'extended style) LBS_MULTIPLESEL]
+                                     [(eq? kind 'extended) LBS_MULTIPLESEL]
-                                     [(memq 'multiple style) LBS_EXTENDEDSEL]
+                                     [(eq? kind 'multiple) LBS_EXTENDEDSEL]
                                      [else 0]))
                        0 0 0 0
                        (send parent get-client-hwnd)

collects/mred/private/wxitem.rkt

@@ -1,8 +1,8 @@
-(module wxitem mzscheme
+(module wxitem racket/base
   (require mzlib/class
 	   mzlib/class100
 	   mzlib/etc
-	   (prefix wx: "kernel.ss")
+	   (prefix-in wx: "kernel.ss")
 	   "lock.ss"
 	   "helper.ss"
 	   "const.ss"
@@ -10,7 +10,7 @@
 	   "check.ss"
 	   "wxwindow.ss")
 
-  (provide (protect make-item%
+  (provide (protect-out make-item%
                         make-control%
                         make-simple-control%
                         wx-button%
@@ -61,8 +61,7 @@
 	       (super set-size x y width height)))])
 
 	(public
-	  [is-enabled?
+	  [is-enabled? (lambda () enabled?)])
-	   (lambda () enabled?)])
 
 	(private-field
 	 ;; Store minimum size of item.  
@@ -207,10 +206,8 @@
 	(apply super-init args)
 	(send (get-parent) set-item-cursor 0 0))))
 
-  (define (make-simple-control% item%)
+  (define (make-simple-control% item% [x-m const-default-x-margin] [y-m const-default-y-margin])
-    (make-control% item%
+    (make-control% item% x-m y-m #f #f))
-		   const-default-x-margin const-default-y-margin 
-		   #f #f))
 
   (define wx-button% (make-window-glue% 
 		      (class100 (make-simple-control% wx:button%) (parent cb label x y w h style font)

collects/mred/private/wxlitem.rkt

@@ -55,12 +55,13 @@
   ;; ----------------------------------------
   
   (define wx-label-panel%
-    (class wx-horizontal-panel% 
+    (class wx-control-horizontal-panel% 
       (init proxy parent label style font halign valign)
       (inherit area-parent)
       (define c #f)
 
       (define/override (enable on?) (if c (send c enable on?) (void)))
+      (define/override (is-enabled?) (if c (send c is-enabled?) #t))
       (define/override (is-window-enabled?) (if c (send c is-window-enabled?) #t))
 
       (super-init #f proxy parent (if (memq 'deleted style) '(deleted) null) #f)
@@ -83,7 +84,7 @@
   ;; ----------------------------------------
 
   (define wx-internal-choice% 
-    (class100 (make-window-glue% (make-simple-control% wx:choice%)) (mred proxy parent cb label x y w h choices style font)
+    (class100 (make-window-glue% (make-simple-control% wx:choice% 0 0)) (mred proxy parent cb label x y w h choices style font)
       (override 
         [handles-key-code 
          (lambda (x alpha? meta?) 
@@ -119,9 +120,7 @@
 
   (define wx-internal-list-box%
     (make-window-glue% 
-     (class100 (make-control% wx:list-box%
+     (class100 (make-control% wx:list-box% 0 0 #t #t) (parent cb label kind x y w h choices style font label-font)
-			      const-default-x-margin const-default-y-margin 
-			      #t #t) (parent cb label kind x y w h choices style font label-font)
        (inherit get-first-item
 		set-first-visible-item)
        (private
@@ -194,7 +193,7 @@
 
   (define wx-internal-radio-box%
     (make-window-glue% 
-     (class100 (make-simple-control% wx:radio-box%) (parent cb label x y w h choices major style font)
+     (class100 (make-simple-control% wx:radio-box% 0 0) (parent cb label x y w h choices major style font)
        (inherit number orig-enable set-selection command)
        (override
 	 [enable
@@ -233,10 +232,21 @@
                              major (filter-style style) font))
       (set-c c #t #t)
 
+      (define enable-vector (make-vector (length choices) #t))
+
       (define/override enable
         (case-lambda
          [(on?) (super enable on?)]
-         [(i on?) (send c enable-button i on?)]))
+         [(i on?) 
+          (when (< -1 i (vector-length enable-vector))
+            (vector-set! enable-vector i on?)
+            (send c enable-button i on?))]))
+      
+      (define/override is-enabled?
+        (case-lambda
+         [() (super is-enabled?)]
+         [(which) (and (< -1 which (vector-length enable-vector))
+                       (vector-ref enable-vector which))]))
 
       (bounce 
        c
@@ -250,9 +260,7 @@
 
   (define wx-internal-gauge%
     (make-window-glue% 
-     (class100 (make-control% wx:gauge% 
+     (class100 (make-control% wx:gauge% 0 0 #f #f)
-			      const-default-x-margin const-default-y-margin 
-			      #f #f)
 	 (parent label range style font)
        (inherit get-client-size get-width get-height set-size 
 		stretchable-in-x stretchable-in-y set-min-height set-min-width
@@ -324,9 +332,7 @@
 
   (define wx-internal-slider%
     (make-window-glue% 
-     (class100 (make-control% wx:slider% 
+     (class100 (make-control% wx:slider% 0 0 #f #f)
-			      const-default-x-margin const-default-y-margin 
-			      #f #f)
 	 (parent func label value min-val max-val style font)
        (inherit set-min-width set-min-height stretchable-in-x stretchable-in-y
 		get-client-size get-width get-height get-parent)

collects/mred/private/wxpanel.rkt

@@ -1,8 +1,8 @@
-(module wxpanel mzscheme
+(module wxpanel racket/base
   (require mzlib/class
 	   mzlib/class100
 	   mzlib/list
-	   (prefix wx: "kernel.ss")
+	   (prefix-in wx: "kernel.ss")
 	   "lock.ss"
 	   "const.ss"
 	   "helper.ss"
@@ -12,11 +12,12 @@
 	   "wxitem.ss"
 	   "wxcontainer.ss")
 
-  (provide (protect wx-panel%
+  (provide (protect-out wx-panel%
                         wx-vertical-panel%
                         wx-vertical-tab-panel%
                         wx-vertical-group-panel%
                         wx-horizontal-panel%
+                        wx-control-horizontal-panel%
                         wx-pane%
                         wx-vertical-pane%
                         wx-horizontal-pane%
@@ -61,8 +62,8 @@
 				  0
 				  2))
 
-  (define (wx-make-basic-panel% wx:panel% stretch?)
+  (define (wx-make-basic-panel% wx:panel% stretch? [x-m 0] [y-m 0])
-    (class100* (wx-make-container% (make-item% wx:panel% 0 0 stretch? stretch?)) (wx-basic-panel<%>) (parent style label)
+    (class100* (wx-make-container% (make-item% wx:panel% x-m y-m stretch? stretch?)) (wx-basic-panel<%>) (parent style label)
 	       (inherit get-x get-y get-width get-height
 			min-width min-height set-min-width set-min-height
 			x-margin y-margin
@@ -476,8 +477,8 @@
       (sequence
 	(apply super-init args))))
 
-  (define (wx-make-panel% wx:panel%)
+  (define (wx-make-panel% wx:panel% [x-m 0] [y-m 0])
-    (class100 (make-container-glue% (make-window-glue% (wx-make-basic-panel% wx:panel% #t))) args
+    (class100 (make-container-glue% (make-window-glue% (wx-make-basic-panel% wx:panel% #t x-m y-m))) args
       (rename [super-on-visible on-visible]
 	      [super-on-active on-active])
       (inherit get-children)
@@ -724,15 +725,18 @@
   (define (wx-make-vertical-panel% wx-linear-panel%) (wx-make-horizontal/vertical-panel% wx-linear-panel% #f))
 
   (define wx-panel% (wx-make-panel% wx:panel%))
+  (define wx-control-panel% (wx-make-panel% wx:panel% const-default-x-margin const-default-y-margin))
   (define wx-tab-panel% (wx-make-panel% wx:tab-panel%))
   (define wx-group-panel% (wx-make-panel% wx:group-panel%))
   (define wx-linear-panel% (wx-make-linear-panel% wx-panel%))
+  (define wx-control-linear-panel% (wx-make-linear-panel% wx-control-panel%))
   (define wx-linear-tab-panel% (wx-make-linear-panel% wx-tab-panel%))
   (define wx-linear-group-panel% (wx-make-linear-panel% wx-group-panel%))
   (define wx-horizontal-panel% (wx-make-horizontal-panel% wx-linear-panel%))
   (define wx-vertical-panel% (wx-make-vertical-panel% wx-linear-panel%))
   (define wx-vertical-tab-panel% (wx-make-vertical-panel% wx-linear-tab-panel%))
   (define wx-vertical-group-panel% (wx-make-vertical-panel% wx-linear-group-panel%))
+  (define wx-control-horizontal-panel% (wx-make-horizontal-panel% wx-control-linear-panel%))
 
   (define wx-pane% (wx-make-pane% wx:windowless-panel% #t))
   (define wx-grow-box-pane%

collects/tests/gracket/dc.rktl

@@ -20,7 +20,11 @@
     (send-generic mdc (make-generic (object-interface mdc) m) . args)
     (error 'bad-dc "~a shouldn't succeed" `(send <bad-dc> ,m ...))))
 
-(define (test-all mdc try)
+(define (good m . args)
+  (send-generic mdc (make-generic (object-interface mdc) m) . args))
+
+(define (test-all mdc try try-ok)
+  (try 'erase)
   (try 'clear)
   (try 'draw-arc 0 0 10 10 0.1 0.2)
   (try 'draw-bitmap bm2 0 0)
@@ -40,34 +44,45 @@
   (try 'end-page)
   (try 'end-doc)
 
-  (try 'get-background)
-  (try 'get-brush)
-  (try 'get-clipping-region)
-  (try 'get-font)
-  (try 'get-pen)
   (try 'get-size)
-  (try 'get-text-background)
-  (try 'get-text-foreground)
-  (try 'get-text-mode)
 
-  (try 'set-background (make-object color% "Yellow"))
+  (try-ok 'get-background)
-  (try 'set-brush (make-object brush% "Yellow" 'solid))
+  (try-ok 'get-brush)
-  (try 'set-clipping-rect 0 0 10 10)
+  (try-ok 'get-clipping-region)
-  (try 'set-clipping-region (make-object region% mdc))
+  (try-ok 'get-font)
-  (try 'set-font (make-object font% 12 'default 'normal 'normal))
+  (try-ok 'get-pen)
-  (try 'set-origin 0 0)
+  (try-ok 'get-text-background)
-  (try 'set-pen (make-object pen% "Yellow" 1 'solid))
+  (try-ok 'get-text-foreground)
-  (try 'set-scale 2 2)
+  (try-ok 'get-text-mode)
-  (try 'set-text-background (make-object color% "Yellow"))
+  (try-ok 'get-alpha)
-  (try 'set-text-foreground (make-object color% "Yellow"))
+  (try-ok 'get-scale)
-  (try 'set-text-mode 'transparent)
+  (try-ok 'get-origin)
+  (try-ok 'get-rotation)
+
+  (try-ok 'set-background (make-object color% "Yellow"))
+  (try-ok 'set-brush (make-object brush% "Yellow" 'solid))
+  (try-ok 'set-clipping-rect 0 0 10 10)
+  (try-ok 'set-clipping-region (make-object region% mdc))
+  (try-ok 'set-font (make-object font% 12 'default 'normal 'normal))
+  (try-ok 'set-origin 0 0)
+  (try-ok 'set-pen (make-object pen% "Yellow" 1 'solid))
+  (try-ok 'set-scale 2 2)
+  (try-ok 'set-alpha 0.75)
+  (try-ok 'set-text-background (make-object color% "Yellow"))
+  (try-ok 'set-text-foreground (make-object color% "Yellow"))
+  (try-ok 'set-text-mode 'transparent)
+
   (try 'try-color (make-object color% "Yellow") (make-object color%)))
 
 (st #f mdc ok?)
-(test-all mdc bad)
+(test-all mdc bad good)
 
 (send mdc set-bitmap bm)
-(test-all mdc (lambda (m . args)
+
+(test-all mdc 
+          (lambda (m . args)
+            (send-generic mdc (make-generic (object-interface mdc) m) . args))
+          (lambda (m . args)
             (send-generic mdc (make-generic (object-interface mdc) m) . args)))
 
 (send mdc set-bitmap #f)

collects/tests/gracket/paramz.rktl

@@ -34,7 +34,7 @@
 
 (define d (make-object dialog% "hello"))
 (thread (lambda () 
-	  (sleep 1)
+	  (sync (system-idle-evt))
 	  (queue-callback (lambda () (set! v 11)))
 	  (send d show #f)))
 (queue-callback (lambda () (set! v 10)))
@@ -57,14 +57,16 @@
 
   (let ([t (thread (lambda ()
                      (send d show #t)))])
-    (let loop () (unless (send d is-shown?) (loop)))
+    (let loop () (unless (send d is-shown?) (sleep) (loop)))
     (st #t d is-shown?)
     (thread-suspend t)
     (stv d show #f)
+    (st #f d is-shown?)
     (let ([t2 (thread (lambda () (send d show #t)))])
-      (sleep 0.1)
+      (yield (system-idle-evt))
+      (st #t d is-shown?)
       (thread-resume t)
-      (sleep 0.1)
+      (yield (system-idle-evt))
       (st #t d is-shown?)
       (test #t 'thread2 (thread-running? t2))
       (stv d show #f)