some fixes prompted by the test suite

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

@@ -30,7 +30,8 @@
           (cairo_destroy cr))
         s))
 
-    (define/override (ok?) #t)
+    (define/override (ok?) (and s #t))
+
     (define/override (is-color?) #t)
 
     (define/override (get-cairo-surface) s)

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/racket/draw/bitmap-dc.rkt

@@ -23,6 +23,8 @@
     (when _bm
       (do-set-bitmap _bm #f))
 
+    (define/override (ok?) (and c #t))
+
     (define/private (do-set-bitmap v reset?)
       (when c
         (cairo_destroy c)
@@ -79,7 +81,8 @@
   (class (dc-mixin bitmap-dc-backend%)
     (inherit draw-bitmap-section
              internal-set-bitmap
-             internal-get-bitmap)
+             internal-get-bitmap
+             get-size)
     
     (super-new)
 
@@ -99,10 +102,11 @@
         (set-argb-pixels x y 1 1 s)))
 
     (def/public (get-pixel [real? x][real? y][color% c])
+      (let-values ([(w h) (get-size)])
         (let ([b (make-bytes 4)])
           (get-argb-pixels x y 1 1 b)
           (send c set (bytes-ref b 1) (bytes-ref b 2) (bytes-ref b 3))
-        #t))
+          (and (<= 0 x w) (<= 0 y h)))))
 
     (def/public (set-argb-pixels [exact-nonnegative-integer? x]
                                  [exact-nonnegative-integer? y]

collects/racket/draw/bitmap.rkt

@@ -114,8 +114,9 @@
          #f)]
        [([(make-alts path-string? input-port?) filename]
          [kind-symbol? [kind 'unknown]]
-         [(make-or-false color%) [bg-color #f]])
+         [(make-or-false color%) [bg-color #f]]
-        (let-values ([(s b&w?) (do-load-bitmap filename kind bg-color)]
+         [any? [complain-on-failure? #f]])
+        (let-values ([(s b&w?) (do-load-bitmap filename kind bg-color complain-on-failure?)]
                      [(alpha?) (memq kind '(unknown/alpha gif/alpha jpeg/alpha
                                                           png/alpha xbm/alpha xpm/alpha 
                                                           bmp/alpha))]
@@ -218,18 +219,23 @@
 
     (def/public (load-bitmap [(make-alts path-string? input-port?) in]
                              [kind-symbol? [kind 'unknown]]
-                             [(make-or-false color%) [bg #f]])
+                             [(make-or-false color%) [bg #f]]
+                             [any? [complain-on-failure? #f]])
       (check-alternate 'load-bitmap)
       (release-bitmap-storage)
-      (set!-values (s b&w?) (do-load-bitmap in kind bg))
+      (set!-values (s b&w?) (do-load-bitmap in kind bg complain-on-failure?))
       (set! width (if s (cairo_image_surface_get_width s) 0))
       (set! height (if s (cairo_image_surface_get_height s) 0)))
 
-    (define/private (do-load-bitmap in kind bg)
+    (define/private (do-load-bitmap in kind bg complain-on-failure?)
       (if (path-string? in)
+          (with-handlers ([exn:fail? (lambda (exn)
+                                       (if complain-on-failure?
+                                           (raise exn)
+                                           (values #f #f)))])
             (call-with-input-file*
              in
-           (lambda (in) (do-load-bitmap in kind bg)))
+             (lambda (in) (do-load-bitmap in kind bg #f))))
           (case kind
            [(unknown unknown/mask unknown/alpha)
             (let ([starts? (lambda (s)
@@ -242,20 +248,21 @@
                                     (if (eq? kind 'unknown/mask) 
                                         'png/mask
                                         'png))
-                                bg)]
+                                bg
+                                complain-on-failure?)]
                [(starts? #"\xFF\xD8\xFF")
-                (do-load-bitmap in 'jpeg bg)]
+                (do-load-bitmap in 'jpeg bg complain-on-failure?)]
                [(starts? #"GIF8")
-                (do-load-bitmap in 'gif bg)]
+                (do-load-bitmap in 'gif bg complain-on-failure?)]
                [(starts? #"BM")
-                (do-load-bitmap in 'bmp bg)]
+                (do-load-bitmap in 'bmp bg complain-on-failure?)]
                [(starts? #"#define")
-                (do-load-bitmap in 'xbm bg)]
+                (do-load-bitmap in 'xbm bg complain-on-failure?)]
                [(starts? #"/* XPM */")
-                (do-load-bitmap in 'xpm bg)]
+                (do-load-bitmap in 'xpm bg complain-on-failure?)]
                [else
                 ;; unrecognized file type; try to parse as XBM
-                (do-load-bitmap in 'xbm bg)]))]
+                (do-load-bitmap in 'xbm bg complain-on-failure?)]))]
            [(png png/mask png/alpha)
             ;; Using the Cairo PNG support is about twice as fast, but we have
             ;; less control, and there are problems making deallocation reliable

collects/racket/draw/dc.rkt

@@ -189,7 +189,7 @@
           1
           0))
 
-    (define/public (ok?) (and (get-cr) #t))
+    (define/public (ok?) #t)
 
     (define/public (dc-adjust-smoothing s) s)
 
@@ -241,7 +241,7 @@
     (inherit flush-cr get-cr release-cr end-cr init-cr-matrix get-pango
              install-color dc-adjust-smoothing reset-clip
              collapse-bitmap-b&w? call-with-cr-lock
-             can-combine-text? can-mask-bitmap?)
+             ok? can-combine-text? can-mask-bitmap?)
 
     (define-syntax-rule (with-cr default cr . body)
       ;; Faster:
@@ -363,7 +363,8 @@
         (set! origin-y oy)
         (reset-effective!)
         (reset-matrix)))
-    (def/public (get-origin) (values origin-x origin-y))
+    (def/public (get-origin) 
+      (values origin-x origin-y))
 
     (def/public (set-rotation [real? th])
       (unless (and (equal? rotation th))
@@ -527,7 +528,7 @@
          [pen-style-symbol? style])
         (do-set-pen! (send the-pen-list find-or-create-pen col width style))
         (reset-align!)]
-       (method-name 'dc% 'set-pen)))
+       (method-name 'dc<%> 'set-pen)))
 
     (define/public (get-pen) pen)
 
@@ -548,7 +549,7 @@
        [([(make-alts string? color%) col]
          [brush-style-symbol? style])
         (do-set-brush! (send the-brush-list find-or-create-brush col style))]
-       (method-name 'dc% 'set-brush)))
+       (method-name 'dc<%> 'set-brush)))
 
     (define/public (get-brush) brush)
 
@@ -568,6 +569,10 @@
     (def/public (get-text-background) text-bg)
     (def/public (get-background) bg)
 
+    (define/override (get-size)
+      (check-ok 'get-size)
+      (super get-size))
+
     (def/public (suspend-flush) (void))
     (def/public (resume-flush) (void))
 
@@ -576,7 +581,16 @@
     (def/public (get-text-mode) text-mode)
 
     (def/public (try-color [color% c] [color% dest])
-      (send dest set (color-red c) (color-green c) (color-blue c)))
+      (check-ok 'try-color)
+      (if (collapse-bitmap-b&w?)
+          (let ([v (if (= 255
+                          (color-red c)
+                          (color-green c) 
+                          (color-blue c))
+                       255
+                       0)])
+            (send dest set v v v))
+          (send dest set (color-red c) (color-green c) (color-blue c))))
 
     (define clipping-region #f)
 
@@ -621,16 +635,20 @@
         (send r set-rectangle x y w h)
         (do-set-clipping-region r)))
 
+    (define/private (check-ok who)
+      (unless (ok?)
+        (raise-mismatch-error (method-name 'dc<%> who) "drawing context is not ok: " this)))
+
     (define/public (clear)
       (with-cr
-       (void)
+       (check-ok 'erase)
        cr
        (install-color cr bg 1.0)
        (cairo_paint cr)))
 
     (define/override (erase)
       (with-cr
-       (void)
+       (check-ok 'erase)
        cr
        (cairo_set_operator cr CAIRO_OPERATOR_CLEAR)
        (cairo_set_source_rgba cr 1.0 1.0 1.0 1.0)
@@ -640,7 +658,7 @@
     (def/public (copy [real? x] [real? y] [nonnegative-real? w] [nonnegative-real? h]
                       [real? x2] [real? y2])
       (with-cr
-       (void)
+       (check-ok 'copy)
        cr
        (cairo_set_source_surface cr
                                  (cairo_get_target cr)
@@ -830,11 +848,12 @@
               (cairo_set_dash cr #() 0)))))
       (flush-cr))
     
-    (define/public (draw-arc x y
+    (define/private (do-draw-arc who 
+                                 x y
                                  width height
                                  start-radians end-radians)
       (with-cr 
-       (void)
+       (check-ok who)
        cr
        (let ([draw-one (lambda (align-x align-y brush? pen? d)
                          (let* ([orig-x x]
@@ -870,15 +889,19 @@
          (when (pen-draws?)
            (draw-one (lambda (x) (align-x x)) (lambda (y) (align-y y)) #f #t 1.0)))))
 
+    (def/public (draw-arc [real? x] [real? y] [nonnegative-real? width] [nonnegative-real? height]
+                          [real? start-radians] [real? end-radians])
+      (do-draw-arc 'draw-arc x y width height 0 2pi))
+
     (def/public (draw-ellipse [real? x] [real? y] [nonnegative-real? width] [nonnegative-real? height])
-      (draw-arc x y width height 0 2pi))
+      (do-draw-arc 'draw-ellipse x y width height 0 2pi))
 
     (def/public (draw-line [real? x1] [real? y1] [real? x2] [real? y2])
       (let ([dot (if (and (= x1 x2) (= y1 y2))
                      0.1
                      0)])
         (with-cr
-         (void)
+         (check-ok 'draw-line)
          cr
          (cairo_new_path cr)
          (cairo_move_to cr (align-x x1) (align-y y1))
@@ -887,7 +910,7 @@
     
     (def/public (draw-point [real? x] [real? y])
       (with-cr
-       (void)
+       (check-ok 'draw-point)
        cr
        (cairo_new_path cr)
        (let ([x (align-x x)]
@@ -898,18 +921,19 @@
 
     (def/public (draw-lines [(make-alts (make-list point%) list-of-pair-of-real?) pts]
                             [real? [x 0.0]] [real? [y 0.0]])
-      (do-draw-lines pts x y #f))
+      (do-draw-lines 'draw-lines pts x y #f))
 
     (def/public (draw-polygon [(make-alts (make-list point%) list-of-pair-of-real?) pts]
                               [real? [x 0.0]] [real? [y 0.0]]
                               [(symbol-in odd-even winding) [fill-style 'odd-even]])
-      (do-draw-lines pts x y fill-style))
+      (do-draw-lines 'draw-polygon pts x y fill-style))
 
-    (define/public (do-draw-lines pts x y fill-style)
+    (define/public (do-draw-lines who pts x y fill-style)
-      (unless (or (null? pts)
+      (if (or (null? pts)
               (null? (cdr pts)))
+          (check-ok who)
           (with-cr
-         (void)
+           (check-ok who)
            cr
            (cairo_new_path cr)
            (if (pair? (car pts))
@@ -928,7 +952,7 @@
     
     (def/public (draw-rectangle [real? x] [real? y] [nonnegative-real? width] [nonnegative-real? height])
       (with-cr
-       (void)
+       (check-ok 'draw-rectangle)
        cr
        ;; have to do pen separate from brush for 
        ;; both alignment and height/width adjustment
@@ -946,7 +970,7 @@
     (def/public (draw-rounded-rectangle [real? x] [real? y] [nonnegative-real? width] [nonnegative-real? height]
                                         [real? [radius -0.25]])
       (with-cr
-       (void)
+       (check-ok 'draw-rounded-rectangle)
        cr
        ;; have to do pen separate from brush for 
        ;; both alignment and height/width adjustment
@@ -966,7 +990,7 @@
 
     (def/public (draw-spline [real? x1] [real? y1] [real? x2] [real? y2] [real? x3] [real? y3])
       (with-cr
-       (void)
+       (check-ok 'draw-spline)
        cr
        (cairo_new_path cr)
        (cairo_move_to cr (align-x x1) (align-y y1))
@@ -991,7 +1015,7 @@
                            [real? [dy 0]]
                            [(symbol-in odd-even winding) [fill-style 'odd-even]])
       (with-cr
-       (void)
+       (check-ok 'draw-path)
        cr
        (cairo_save cr)
        (cairo_set_fill_rule cr (if (eq? fill-style 'winding)
@@ -1013,13 +1037,12 @@
              (draw cr #t #t)))
        (cairo_restore cr)))
 
-    (inherit get-size)
     (def/public (draw-text [string? s] [real? x] [real? y]
                            [any? [combine? #f]]
                            [exact-nonnegative-integer? [offset 0]]
                            [real? [angle 0.0]])
       (with-cr
-       (void)
+       (check-ok 'draw-text)
        cr
        (do-text cr #t s x y font combine? offset angle)
        (flush-cr)))
@@ -1036,6 +1059,7 @@
                                  [(make-or-false font%) [use-font font]]
                                  [any? [combine? #f]]
                                  [exact-nonnegative-integer? [offset 0]])
+      (check-ok 'get-text-extent)
       (let ([use-font (or use-font font)])
         ;; Try to used cached size info, first:
         (let-values ([(w h d a)
@@ -1397,13 +1421,14 @@
       10.0)
 
     (def/public (start-doc [string? desc])
-      (void))
+      (check-ok 'start-doc))
     (def/public (end-doc)
+      (check-ok 'end-doc)
       (end-cr))
     (def/public (start-page)
-      (void))
+      (check-ok 'start-page))
     (def/public (end-page)
-      (with-cr (void) cr (cairo_show_page cr)))
+      (with-cr (check-ok 'end-page) cr (cairo_show_page cr)))
 
     (def/public (draw-bitmap [bitmap% src]
                              [real? dest-x]
@@ -1411,10 +1436,12 @@
                              [(symbol-in solid opaque xor) [style 'solid]]
                              [(make-or-false color%) [color black]]
                              [(make-or-false bitmap%) [mask #f]])
-      (draw-bitmap-section src 
+      (draw-bitmap-section/mask-offset 'draw-bitmap
+                                       src 
                                        dest-x dest-y 
                                        0 0
                                        (send src get-width) (send src get-height)
+                                       0 0
                                        style color mask))
 
     (def/public (draw-bitmap-section [bitmap% src]
@@ -1427,11 +1454,14 @@
                                      [(symbol-in solid opaque xor) [style 'solid]]
                                      [(make-or-false color%) [color black]]
                                      [(make-or-false bitmap%) [mask #f]])
-      (draw-bitmap-section/mask-offset src dest-x dest-y src-x src-y src-w src-h src-x src-y
+      (draw-bitmap-section/mask-offset 'draw-bitmap-section
+                                       src dest-x dest-y src-x src-y src-w src-h src-x src-y
                                        style color mask))
 
-    (define/public (draw-bitmap-section/mask-offset src dest-x dest-y src-x src-y src-w src-h msrc-x msrc-y
+    (define/public (draw-bitmap-section/mask-offset who
+                                                    src dest-x dest-y src-x src-y src-w src-h msrc-x msrc-y
                                                     style color mask)
+      (check-ok who)
       (let-values ([(src src-x src-y)
                     (if (and (alpha . < . 1.0)
                              (send src is-color?))
@@ -1594,7 +1624,7 @@
              [tmp-dc (make-object -bitmap-dc% tmp-bm)])
         (send tmp-dc set-alpha alpha)
         (send tmp-dc set-background bg)
-        (send tmp-dc draw-bitmap-section/mask-offset src 0 0 src-x src-y src-w src-h msrc-x msrc-y
+        (send tmp-dc draw-bitmap-section/mask-offset 'internal src 0 0 src-x src-y src-w src-h msrc-x msrc-y
               style color mask)
         (send tmp-dc set-bitmap #f)
         tmp-bm))

collects/racket/draw/post-script-dc.rkt

@@ -83,6 +83,8 @@
     
     (when s (cairo_surface_destroy s))
 
+    (define/override (ok?) (and c #t))
+
     (define/override (get-cr) c)
 
     (def/override (get-size)

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)