improve canvas-drawing docs

original commit: 4f56618c6d9a36743f97535ad1d75e5fa36d9d5f

collects/framework/private/canvas.rkt

@@ -152,11 +152,12 @@
                               (set-max-height snip-height))))))))))
       (define/public (recalc-snips)
         (let ([editor (get-editor)])
-          (unless (is-a? editor text:wide-snip<%>)
+          (when editor
-            (error 'recalc-snips "expected a text:wide-snip<%> editor, instead ~e" editor))
+            (unless (is-a? editor text:wide-snip<%>)
-          (when (eq? (send editor get-canvas) this)
+              (error 'recalc-snips "expected a text:wide-snip<%> editor, instead ~e" editor))
-            (for-each (update-snip-size #t) (send editor get-wide-snips))
+            (when (eq? (send editor get-canvas) this)
-            (for-each (update-snip-size #f) (send editor get-tall-snips)))))
+              (for-each (update-snip-size #t) (send editor get-wide-snips))
+              (for-each (update-snip-size #f) (send editor get-tall-snips))))))
       (define/public (add-wide-snip snip)
         (let ([editor (get-editor)])
           (unless (is-a? editor text:wide-snip<%>)

collects/framework/private/color.rkt

@@ -209,7 +209,8 @@ added get-regions
                       (loop (cdr old) (cdr new)))]
                [else
                 (cons (make-new-lexer-state (caar new) (cadar new))
-                      (loop null (cdr new)))]))))
+                      (loop null (cdr new)))])))
+      (update-lexer-state-observers))
 
     
     (define/public (get-regions) 
@@ -236,6 +237,16 @@ added get-regions
              local-edit-sequence? get-styles-fixed has-focus?
              get-fixed-style)
     
+    (define lexers-all-valid? #t)
+    (define/private (update-lexer-state-observers)
+      (define new (for/and ([ls (in-list lexer-states)])
+                    (lexer-state-up-to-date? ls)))
+      (unless (eq? new lexers-all-valid?)
+        (set! lexers-all-valid? new)
+        (on-lexer-valid lexers-all-valid?)))
+    (define/pubment (on-lexer-valid valid?)
+      (inner (void) on-lexer-valid valid?))
+    
     (define/private (reset-tokens)
       (for-each
        (lambda (ls)
@@ -247,6 +258,7 @@ added get-regions
          (set-lexer-state-current-lexer-mode! ls #f)
          (set-lexer-state-parens! ls (new paren-tree% (matches pairs))))
        lexer-states)
+      (update-lexer-state-observers)
       (set! restart-callback #f)
       (set! force-recolor-after-freeze #f)
       (set! colors null)
@@ -374,6 +386,7 @@ added get-regions
                                                        (send valid-tree search-max!)
                                                        (data-lexer-mode (send valid-tree get-root-data))))))
           (set-lexer-state-up-to-date?! ls #f)
+          (update-lexer-state-observers)
           (queue-callback (λ () (colorer-callback)) #f)))
        ((>= edit-start-pos (lexer-state-invalid-tokens-start ls))
         (let-values (((tok-start tok-end valid-tree invalid-tree orig-data)
@@ -454,7 +467,8 @@ added get-regions
           (when (coroutine-run 10 tok-cor)
             (for-each (lambda (ls)
                         (set-lexer-state-up-to-date?! ls #t))
-                      lexer-states)))
+                      lexer-states)
+            (update-lexer-state-observers)))
         #;(printf "end lexing\n")
         #;(printf "begin coloring\n")
         ;; This edit sequence needs to happen even when colors is null

collects/framework/private/frame.rkt

@@ -2445,6 +2445,7 @@
     (define/override (get-editor%) (text:searching-mixin (super get-editor%)))
     (super-new)))
 
+;; code copied to drracket/private/unit.rkt
 (define checkout-or-nightly?
   (or (with-handlers ([exn:fail:filesystem? (λ (x) #f)])
         (directory-exists? (collection-path "repo-time-stamp")))
@@ -2473,8 +2474,10 @@
     (define/override (on-paint)
       (cond
         [on?
+         (define dc (get-dc))
+         (send dc set-font small-control-font)
          (let-values ([(cw ch) (get-client-size)])
-           (send (get-dc) draw-text indicator
+           (send dc draw-text indicator
                  (- (/ cw 2) (/ indicator-width 2))
                  (- (/ ch 2) (/ indicator-height 2))))]))
     (define/public (set-on? new-on?)
@@ -2487,9 +2490,8 @@
     (super-new [stretchable-width #f]
                [style '(transparent)])
     
-    (send (get-dc) set-font small-control-font)
     (define-values (indicator-width indicator-height)
-      (let-values ([(tw th _1 _2) (send (get-dc) get-text-extent indicator)])
+      (let-values ([(tw th _1 _2) (send (get-dc) get-text-extent indicator small-control-font)])
         (values tw th)))
     (min-width (+ (inexact->exact (ceiling indicator-width)) 4))))
 

collects/framework/private/text.rkt

@@ -1,10 +1,4 @@
 #lang racket/unit
-#|
-
-WARNING: printf is rebound in the body of the unit to always
-         print to the original output port.
-
-|#
 
 (require string-constants
          racket/unit
@@ -37,10 +31,7 @@ WARNING: printf is rebound in the body of the unit to always
 (init-depend framework:editor^)
 
 (define original-output-port (current-output-port))
-(define (printf . args) 
+(define (oprintf . args) (apply fprintf original-output-port args))
-  (apply fprintf original-output-port args)
-  (void))
-
 
 (define-struct range (start end caret-space? style color) #:inspector #f)
 (define-struct rectangle (left top right bottom style color) #:inspector #f)
@@ -3728,6 +3719,7 @@ designates the character that triggers autocompletion
              line-paragraph
              line-start-position
              line-end-position
+             get-view-size
              set-padding
              get-padding)
 
@@ -3739,6 +3731,7 @@ designates the character that triggers autocompletion
 
     (define (constructor)
       (super-new)
+      (setup-padding)
       #;
       (define space (text-width dc (number-space+1)))
       #;
@@ -3751,9 +3744,25 @@ designates the character that triggers autocompletion
     ;; add an extra 0 so it looks nice
     (define (number-space+1) (string-append (number-space) "0"))
 
+    (define (repaint)
+      (send this invalidate-bitmap-cache))
+
+    (define padding-dc (new bitmap-dc% [bitmap (make-screen-bitmap 1 1)]))
+    (define (setup-padding)
+      (if (showing-line-numbers?)
+        (let ()
+          (send padding-dc set-font (get-style-font))
+          (define-values (padding-left padding-top padding-right padding-bottom) (get-padding))
+          (define new-padding (text-width padding-dc (number-space+1)))
+          (set-padding new-padding 0 0 0)
+          (when (not (= padding-left new-padding))
+            (repaint)))
+        (set-padding 0 0 0 0)))
+
     ;; call this method with #t or #f to turn on/off line numbers
     (define/public (show-line-numbers! what)
-      (set! show-line-numbers? what))
+      (set! show-line-numbers? what)
+      (setup-padding))
 
     (define/public (showing-line-numbers?)
       show-line-numbers?)
@@ -3769,11 +3778,6 @@ designates the character that triggers autocompletion
                       (send style-list basic-style))])
         (send std get-font)))
 
-    ;; low <= what <= high
-    (define (between low what high)
-      (and (>= what low)
-           (<= what high)))
-
     (define-struct saved-dc-state (pen font foreground-color))
     (define (save-dc-state dc)
       (saved-dc-state (send dc get-pen)
@@ -3855,8 +3859,37 @@ designates the character that triggers autocompletion
                           (min 255 (integer (* 255 green)))
                           (min 255 (integer (* 255 blue)))))
 
-    ;; an offset that looks right
+    ;; adjust space so that we are always at the left-most position where
-    (define magic-space 5)
+    ;; drawing looks right
+    (define (left-space dc dx)
+      (define left (box 0))
+      (define top (box 0))
+      (define width (box 0))
+      (define height (box 0))
+      (send (send this get-admin) get-view left top width height)
+      #|
+      (define width2 (box 0))
+      (define height2 (box 0))
+      (get-view-size width2 height2)
+      |#
+      #;
+      (printf "left ~a top ~a width ~a height ~a width2 ~a height2 ~a\n"
+              (unbox left) (unbox top)
+              (unbox width) (unbox height)
+              (unbox width2) (unbox height2))
+      (+ (unbox left) dx))
+
+    (define/augment (after-insert start length)
+      (setup-padding)
+      (inner (void) after-insert start length))
+
+    (define/augment (after-delete start length)
+      (setup-padding)
+      (inner (void) after-delete start length))
+
+    (define/augment (after-change-style start length)
+      (setup-padding)
+      (inner (void) after-change-style start length))
 
     (define (draw-numbers dc top bottom dx dy start-line end-line)
       (define (draw-text . args)
@@ -3869,11 +3902,10 @@ designates the character that triggers autocompletion
       (for ([line (in-range start-line end-line)])
         (define y (line-location line))
 
-        (when (between top y bottom)
+        (when (<= top y bottom)
           (define view (number->string (add1 (line-paragraph line))))
           (define final-x
-            (+ ;; dx 
+            (+ (left-space dc dx)
-              magic-space
                (case alignment
                  [(left) 0]
                  [(right) (- right-space (text-width dc view) single-space)]
@@ -3890,9 +3922,11 @@ designates the character that triggers autocompletion
 
     ;; draw the line between the line numbers and the actual text
     (define (draw-separator dc top bottom dx dy x)
-      (send dc draw-line (+ magic-space x) (+ dy top) (+ magic-space x) (+ dy bottom))
+      (define line-x (+ (left-space dc dx) x))
-      #;
+      (define line-y1 (+ dy top))
-      (send dc draw-line (+ dx x) (+ dy top) (+ dx x) (+ dy bottom)))
+      (define line-y2 (+ dy bottom))
+      (send dc draw-line line-x line-y1
+                         line-x line-y2))
 
     ;; `line-numbers-space' will get mutated in the `on-paint' method
     ;; (define line-numbers-space 0)
@@ -3932,11 +3966,14 @@ designates the character that triggers autocompletion
     (define/override (on-paint before? dc left top right bottom dx dy draw-caret)
       (if show-line-numbers?
         (begin
+          #;
           (set-padding (text-width dc (number-space+1)) 0 0 0)
           (if before?
             (let ()
+              (define left-most (left-space dc dx))
               (set! old-clipping (send dc get-clipping-region))
               (define saved-dc (save-dc-state dc))
+              (setup-dc dc)
               (define clipped (make-object region% dc))
               (define all (make-object region% dc))
               (define copy (make-object region% dc))
@@ -3950,11 +3987,14 @@ designates the character that triggers autocompletion
                     0 (+ dy top)
                     (text-width dc (number-space+1))
                     (- bottom top))
+              (restore-dc-state dc saved-dc)
               (send copy subtract clipped)
               (send dc set-clipping-region copy))
             (begin
               (send dc set-clipping-region old-clipping)
               (draw-line-numbers dc left top right bottom dx dy))))
+          (void)
+          #;
           (set-padding 0 0 0 0))
       (void)
       #;

collects/framework/splash.rkt

@@ -1,8 +1,9 @@
-#lang scheme/base
+#lang racket/base
 
-(require scheme/class
+(require racket/class
-         scheme/file
+         racket/file
-         scheme/gui/base)
+         racket/gui/base
+         (for-syntax racket/base))
 
 (provide get-splash-bitmap
          set-splash-bitmap
@@ -28,10 +29,37 @@
 (define splash-cache-dc (make-object bitmap-dc%))
 (define splash-eventspace (make-eventspace))
 
+(define (on-splash-eventspace/proc t)
+  (parameterize ([current-eventspace splash-eventspace])
+    (queue-callback t)))
+(define-syntax-rule 
+  (on-splash-eventspace e ...)
+  (on-splash-eventspace/proc (λ () e ...)))
+
+(define (on-splash-eventspace/ret/proc t)
+  (define c (make-channel))
+  (parameterize ([current-eventspace splash-eventspace])
+    (queue-callback
+     (λ ()
+       (channel-put c (t)))))
+  (channel-get c))
+
+(define-syntax (on-splash-eventspace/ret stx)
+  (syntax-case stx ()
+    [(_ e ...)
+     (with-syntax ([line (syntax-line stx)])
+       #'(on-splash-eventspace/ret/proc (λ () e ...))
+       #;
+       #'(begin
+           (printf "starting ~a\n" line)
+           (begin0 
+             (on-splash-eventspace/ret/proc (λ () e ...))
+             (printf "finishing ~a\n" line))))]))
+
 (define (get-splash-bitmap) splash-bitmap)
 (define (set-splash-bitmap bm) 
   (set! splash-bitmap bm)
-  (send splash-canvas on-paint))
+  (on-splash-eventspace (send splash-canvas on-paint)))
 (define (get-splash-canvas) splash-canvas)
 (define (get-splash-eventspace) splash-eventspace)
 
@@ -40,8 +68,8 @@
   (set! splash-paint-callback sp)
   (refresh-splash))
 
-(define (get-splash-width) (send splash-canvas get-width))
+(define (get-splash-width) (on-splash-eventspace/ret (send splash-canvas get-width)))
-(define (get-splash-height) (send splash-canvas get-height))
+(define (get-splash-height) (on-splash-eventspace/ret (send splash-canvas get-height)))
 
 (define (set-splash-event-callback cb) (set! splash-event-callback cb))
 (define (get-splash-event-callback cb) splash-event-callback)
@@ -56,6 +84,26 @@
     (call-splash-paint-callback splash-cache-dc)
     (send splash-cache-dc set-bitmap #f)
     (send splash-canvas on-paint))
+       
+  (define (call-splash-paint-callback dc)
+    (cond
+      [(equal? 1 (procedure-arity splash-paint-callback))
+       (splash-paint-callback dc)]
+      [else 
+       (splash-paint-callback dc 
+                              (send (get-gauge) get-value) 
+                              (send (get-gauge) get-range)
+                              (send splash-canvas get-width)
+                              (send splash-canvas get-height))])
+    (for-each (λ (icon)
+                (send dc draw-bitmap
+                      (icon-bm icon)
+                      (icon-x icon)
+                      (icon-y icon)
+                      'solid
+                      (make-object color% "black")
+                      (send (icon-bm icon) get-loaded-mask)))
+              icons))
   
   (cond
     [(not (is-a? splash-cache-bitmap bitmap%)) (void)]
@@ -65,31 +113,14 @@
      (parameterize ([current-eventspace splash-eventspace])
        (queue-callback
         recompute-bitmap/refresh))]))
-        
-(define (call-splash-paint-callback dc)
-  (cond
-    [(equal? 1 (procedure-arity splash-paint-callback))
-     (splash-paint-callback dc)]
-    [else 
-     (splash-paint-callback dc 
-                            (send (get-gauge) get-value) 
-                            (send (get-gauge) get-range)
-                            (get-splash-width)
-                            (get-splash-height))])
-  (for-each (λ (icon)
-              (send dc draw-bitmap
-                    (icon-bm icon)
-                    (icon-x icon)
-                    (icon-y icon)
-                    'solid
-                    (make-object color% "black")
-                    (send (icon-bm icon) get-loaded-mask)))
-            icons))
 
 (define (set-splash-progress-bar?! b?) 
-  (send gauge-panel change-children
+  (on-splash-eventspace/ret
-        (λ (l) (if b? (list (get-gauge)) '()))))
+   (get-gauge) ;; force the gauge to be created
+   (send gauge-panel change-children
+         (λ (l) (if b? (list (get-gauge)) '())))))
 
+;; the function bound to the variable should only be called on the splash-eventspace main thread
 (define (splash-paint-callback dc)
   (if splash-bitmap
       (send dc draw-bitmap splash-bitmap 0 0)
@@ -111,55 +142,57 @@
   (unless allow-funny? (set! funny? #f))
   (set! splash-title _splash-title)
   (set! splash-max-width (max 1 (splash-get-preference (get-splash-width-preference-name) width-default)))
-  (send (get-gauge) set-range splash-max-width)
-  (send splash-tlw set-label splash-title)
   (let/ec k
     (define (no-splash)
       (set! splash-bitmap #f)
       (set! splash-canvas #f)
       (set! splash-eventspace #f)
       (k (void)))
-  
-    (cond
-      [(or (path? splash-draw-spec)
-           (string? splash-draw-spec))
-       (unless (file-exists? splash-draw-spec)
-         (fprintf (current-error-port) "WARNING: bitmap path ~s not found\n" splash-draw-spec)
-         (no-splash))
-       
-       (set! splash-bitmap (make-object bitmap% splash-draw-spec))
-       (unless (send splash-bitmap ok?)
-         (fprintf (current-error-port) "WARNING: bad bitmap ~s\n" splash-draw-spec)
-         (no-splash))
-       
-       (send splash-canvas min-width (send splash-bitmap get-width))
-       (send splash-canvas min-height (send splash-bitmap get-height))
-       (set! splash-cache-bitmap (make-object bitmap% 
-                                   (send splash-bitmap get-width)
-                                   (send splash-bitmap get-height)))]
-      [(and (vector? splash-draw-spec)
-            (procedure? (vector-ref splash-draw-spec 0))
-            (number? (vector-ref splash-draw-spec 1))
-            (number? (vector-ref splash-draw-spec 2)))
-       (set! splash-paint-callback (vector-ref splash-draw-spec 0))
-       (send splash-canvas min-width (vector-ref splash-draw-spec 1))
-       (send splash-canvas min-height (vector-ref splash-draw-spec 2))
-       (set! splash-cache-bitmap (make-object bitmap% 
-                                   (vector-ref splash-draw-spec 1)
-                                   (vector-ref splash-draw-spec 2)))]
-      [(not splash-draw-spec)
-       (no-splash)]
-      [else
-       (fprintf (current-error-port)
-                "WARNING: unknown splash spec: ~s" splash-draw-spec)
-       (no-splash)])
     
-    (refresh-splash)
+    (on-splash-eventspace/ret
-    (send splash-tlw center 'both)
+     (send (get-gauge) set-range splash-max-width)
-    (thread (λ () (send splash-tlw show #t)))
+     (send splash-tlw set-label splash-title)
-    (sync (system-idle-evt)) ; try to wait for dialog to be shown
+     (cond
-    (flush-display) (yield) (sleep)
+       [(or (path? splash-draw-spec)
-    (flush-display) (yield) (sleep)))
+            (string? splash-draw-spec))
+        (unless (file-exists? splash-draw-spec)
+          (fprintf (current-error-port) "WARNING: bitmap path ~s not found\n" splash-draw-spec)
+          (no-splash))
+        
+        (set! splash-bitmap (make-object bitmap% splash-draw-spec))
+        (unless (send splash-bitmap ok?)
+          (fprintf (current-error-port) "WARNING: bad bitmap ~s\n" splash-draw-spec)
+          (no-splash))
+        
+        (send splash-canvas min-width (send splash-bitmap get-width))
+        (send splash-canvas min-height (send splash-bitmap get-height))
+        (set! splash-cache-bitmap (make-object bitmap% 
+                                    (send splash-bitmap get-width)
+                                    (send splash-bitmap get-height)))]
+       [(and (vector? splash-draw-spec)
+             (procedure? (vector-ref splash-draw-spec 0))
+             (number? (vector-ref splash-draw-spec 1))
+             (number? (vector-ref splash-draw-spec 2)))
+        (set! splash-paint-callback (vector-ref splash-draw-spec 0))
+        (send splash-canvas min-width (vector-ref splash-draw-spec 1))
+        (send splash-canvas min-height (vector-ref splash-draw-spec 2))
+        (set! splash-cache-bitmap (make-object bitmap% 
+                                    (vector-ref splash-draw-spec 1)
+                                    (vector-ref splash-draw-spec 2)))]
+       [(not splash-draw-spec)
+        (no-splash)]
+       [else
+        (fprintf (current-error-port)
+                 "WARNING: unknown splash spec: ~s" splash-draw-spec)
+        (no-splash)])
+     
+     (refresh-splash)
+     
+     (send splash-tlw center 'both)
+     (send splash-tlw show-without-yield)
+     (sync (system-idle-evt)) ; try to wait for dialog to be shown
+     (flush-display) (yield) (sleep)
+     (flush-display) (yield) (sleep))))
 
 (define splash-title "no title")
 
@@ -172,9 +205,10 @@
 (define (close-splash)
   (unless (= splash-max-width splash-current-width)
     (splash-set-preference (get-splash-width-preference-name) (max 1 splash-current-width)))
-  (set! quit-on-close? #f)
+  (on-splash-eventspace/ret (set! quit-on-close? #f))
   (when splash-tlw
-    (send splash-tlw show #f)))
+    (on-splash-eventspace
+     (send splash-tlw show #f))))
 
 (define (shutdown-splash)
   (set! splash-load-handler (λ (old-load f expected) (old-load f expected))))
@@ -190,11 +224,13 @@
 (define (splash-load-handler old-load f expected)
   (set! splash-current-width (+ splash-current-width 1))
   (when (<= splash-current-width splash-max-width)
-    (send (get-gauge) set-value splash-current-width)
+    (let ([splash-save-width splash-current-width])
-    (when (or (not (member (get-gauge) (send gauge-panel get-children)))
+      (on-splash-eventspace
-              ;; when the gauge is not visible, we'll redraw the canvas
+       (send (get-gauge) set-value splash-save-width)
-              (refresh-splash-on-gauge-change? splash-current-width splash-max-width))
+       (when (or (not (member (get-gauge) (send gauge-panel get-children)))
-      (refresh-splash)))
+                 ;; when the gauge is not visible, we'll redraw the canvas regardless
+                 (refresh-splash-on-gauge-change? splash-save-width splash-max-width))
+         (refresh-splash)))))
   (old-load f expected))
 
 (let-values ([(make-compilation-manager-load/use-compiled-handler
@@ -281,6 +317,7 @@
 (define (splash-set-preference name value)
   (put-preferences (list name) (list value)))
 
+;; only modified (or read) on the splash eventspace handler thread
 (define quit-on-close? #t)
 
 (define splash-tlw%
@@ -302,23 +339,28 @@
   (parameterize ([current-eventspace splash-eventspace])
     (new splash-tlw%
       (label splash-title))))
-(send splash-tlw set-alignment 'center 'center)
 
-(define panel (make-object vertical-pane% splash-tlw))
+(define panel (on-splash-eventspace/ret (make-object vertical-pane% splash-tlw)))
-(define splash-canvas (new splash-canvas% [parent panel] [style '(no-autoclear)]))
+(define splash-canvas (on-splash-eventspace/ret (new splash-canvas% [parent panel] [style '(no-autoclear)])))
-(define gauge-panel (make-object horizontal-pane% panel))
+(define gauge-panel (on-splash-eventspace/ret (make-object horizontal-pane% panel)))
+
+;; only called on the splash eventspace main thread
 (define get-gauge
   (let ([gauge #f])
     (λ ()
+      (unless (eq? (current-thread) (eventspace-handler-thread splash-eventspace))
+        (error 'get-gauge "called from the wrong thread"))
       (unless gauge
         (set! gauge
               (if funny?
                   (make-object funny-gauge% gauge-panel)
                   (make-object gauge% #f splash-max-width gauge-panel '(horizontal)))))
       gauge)))
-(send panel stretchable-width #f)
+(on-splash-eventspace/ret
-(send panel stretchable-height #f)
+ (send splash-tlw set-alignment 'center 'center)
-(send gauge-panel set-alignment 'center 'top)
+ (send panel stretchable-width #f)
-(send splash-canvas focus)
+ (send panel stretchable-height #f)
-(send splash-canvas stretchable-width #f)
+ (send gauge-panel set-alignment 'center 'top)
-(send splash-canvas stretchable-height #f)
+ (send splash-canvas focus)
+ (send splash-canvas stretchable-width #f)
+ (send splash-canvas stretchable-height #f))

collects/mred/mred-sig.rkt

@@ -113,6 +113,7 @@ key-event%
 keymap%
 label->plain-label
 labelled-menu-item<%>
+linear-gradient%
 list-box%
 list-control<%>
 make-bitmap
@@ -160,6 +161,7 @@ read-bitmap
 read-editor-global-footer
 read-editor-global-header
 read-editor-version
+radial-gradient%
 region%
 register-collecting-blit
 scroll-event%

collects/mred/private/check.rkt

@@ -146,6 +146,19 @@
     (unless (or (label-string? label) (is-a? label wx:bitmap%))
       (raise-type-error (who->name who) "string (up to 200 characters) or bitmap% object" label)))
 
+  (define (check-label-string-or-bitmap-or-both who label)
+    (unless (or (label-string? label) (is-a? label wx:bitmap%)
+                (and (list? label) 
+                     (= 3 (length label)) 
+                     (is-a? (car label) wx:bitmap%)
+                     (label-string? (cadr label))
+                     (memq (caddr label) '(left right top bottom))))
+      (raise-type-error (who->name who) 
+                        (string-append
+                         "string (up to 200 characters), bitmap% object, or list of bitmap%, "
+                         "string, and image-placement symbol ('left, 'right, 'top, or 'bottom)")
+                        label)))
+
   (define (check-label-string-or-bitmap/false who label)
     (unless (or (not label) (label-string? label) (is-a? label wx:bitmap%))
       (raise-type-error (who->name who) "string (up to 200 characters), bitmap% object, or #f" label)))

collects/mred/private/const.rkt

@@ -38,7 +38,11 @@
   (define arrow-cursor (make-object wx:cursor% 'arrow))
 
   (define default-x-prefix (if (eq? 'unix (system-type))
-			       (let ([v (get-preference '|MrEd:defaultMenuPrefix| (lambda () 'ctl))])
+			       (let ([v (get-preference 
+                                         '|GRacket:defaultMenuPrefix| 
+                                         ;; on fail, fall back to old name of pref:
+                                         (lambda () (get-preference '|MrEd:defaultMenuPrefix| 
+                                                                    (lambda () 'ctl))))])
 				 (if (memq v '(meta ctl alt ctl-m))
 				     v
 				     'ctl))

collects/mred/private/mritem.rkt

@@ -58,10 +58,16 @@
 									   ;; for keyword use
 									   [font no-val])
       (rename [super-set-label set-label])
-      (private-field [label lbl][callback cb] [is-bitmap? (lbl . is-a? . wx:bitmap%)])
+      (private-field [label lbl][callback cb] 
+                     [can-bitmap? (or (lbl . is-a? . wx:bitmap%)
+                                      (pair? lbl))]
+                     [can-string? (or (string? lbl)
+                                      (pair? lbl))])
       (override
 	[get-label (lambda () label)]
-	[get-plain-label (lambda () (and (string? label) (wx:label->plain-label label)))]
+	[get-plain-label (lambda () 
+                           (let ([label (if (pair? label) (cadr label) label)])
+                             (and (string? label) (wx:label->plain-label label))))]
 	[set-label (entry-point
 		    (lambda (l)
 		      ((label-checker)
@@ -69,12 +75,16 @@
 		      (let ([l (if (string? l)
                                  (string->immutable-string l)
                                  l)])
-                        (when (or (and is-bitmap?
+                        (when (or (and can-bitmap?
                                        (l . is-a? . wx:bitmap%))
-                                  (and (not is-bitmap?)
+                                  (and can-string?
                                        (string? l)))
                           (send wx set-label l)
-                          (set! label l)))))])
+                          (if (pair? label)
+                              (if (string? l)
+                                  (set! label (list (car label) l (caddr label)))
+                                  (set! label (list l (cadr label) (caddr label))))
+                              (set! label l))))))])
       (public
 	[hidden-child? (lambda () #f)] ; module-local method
 	[label-checker  (lambda () check-label-string/false)] ; module-local method
@@ -210,7 +220,7 @@
 	[label-checker  (lambda () check-label-string-or-bitmap)]) ; module-local method
       (sequence
 	(let ([cwho '(constructor button)])
-	  (check-label-string-or-bitmap cwho label)
+	  (check-label-string-or-bitmap-or-both cwho label)
 	  (check-container-parent cwho parent)
 	  (check-callback cwho callback)
 	  (check-style cwho #f '(border deleted) style)

collects/mred/private/mrtop.rkt

@@ -139,6 +139,8 @@
         [do-set-status-text (lambda (s)
                               (when status-message
                                 (send status-message set-label s)))])
+      (override
+        [get-client-handle (lambda () (send wx-panel get-client-handle))])
       (sequence 
 	(super-init (lambda () (set! wx (mk-wx finish)) wx) 
                     (lambda () wx-panel) (lambda () mid-panel)

collects/mred/private/mrwindow.rkt

@@ -116,7 +116,7 @@
       get-client-size get-size get-width get-height get-x get-y
       get-cursor set-cursor popup-menu
       show is-shown? on-superwindow-show refresh
-      get-handle))
+      get-handle get-client-handle))
 
   (define-keywords window%-keywords [enabled #t])
 
@@ -173,6 +173,7 @@
 	[get-plain-label (lambda () (and (string? label) (wx:label->plain-label label)))]
 
 	[get-handle (lambda () (send wx get-handle))]
+	[get-client-handle (lambda () (send wx get-client-handle))]
 
 	[accept-drop-files
 	 (entry-point

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

@@ -32,6 +32,11 @@
   (-a _void (clicked: [_id sender])
       (queue-window*-event wxb (lambda (wx) (send wx clicked)))))
 
+(define NSImageLeft 2)
+(define NSImageRight 3)
+(define NSImageBelow 4)
+(define NSImageAbove 5)
+
 (defclass core-button% item%
   (init parent cb label x y w h style font
         [button-type #f])
@@ -57,11 +62,21 @@
        [else
         (if button-type
             (tellv cocoa setTitle: #:type _NSString "")
-            (tellv cocoa setImage: (bitmap->image label)))])
+            (begin
+              (when (pair? label)
+                (tellv cocoa setTitle: #:type _NSString (cadr label))
+                (tellv cocoa setImagePosition: #:type _NSInteger 
+                       (case (caddr label)
+                         [(left) NSImageLeft]
+                         [(right) NSImageRight]
+                         [(top) NSImageAbove]
+                         [(bottom) NSImageBelow])))
+              (tellv cocoa setImage: (bitmap->image (if (pair? label) (car label) label)))))])
       (init-font cocoa font)
       (tellv cocoa sizeToFit)
       (when (and (eq? event-type 'button)
-                 (string? label))
+                 (or (string? label)
+                     (pair? label)))
         (when font
           (let ([n (send font get-point-size)])
             ;; If the font is small, adjust the control size:
@@ -85,10 +100,19 @@
                                            (NSSize-height (NSRect-size frame)))))))
       cocoa))
 
+  (when (pair? label)
+    ;; It looks better to add extra padding around the button:
+    (let ([f (tell #:type _NSRect button-cocoa frame)])
+      (tellv button-cocoa setFrame: #:type _NSRect 
+             (make-NSRect
+              (NSRect-origin f)
+              (make-NSSize (+ (NSSize-width (NSRect-size f)) 2)
+                           (+ (NSSize-height (NSRect-size f)) 4))))))
+  
   (define-values (cocoa image-cocoa)
     (if (and button-type
              (not (string? label)))
-        ;; Check-box image: need an view to join a button and an image view:
+        ;; Check-box image: need a view to join a button and an image view:
         ;; (Could we use the NSImageButtonCell from the radio-box implementation
         ;;  instead?)
         (let* ([frame (tell #:type _NSRect button-cocoa frame)]

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

@@ -238,7 +238,6 @@
               is-window-enabled?
               block-mouse-events
               move get-x get-y
-              on-size
               register-as-child
               get-size get-position
               set-focus
@@ -456,7 +455,9 @@
        (fix-dc)
        (when (is-auto-scroll?)
          (reset-auto-scroll 0 0))
-       (on-size 0 0))
+       (on-size))
+
+     (define/public (on-size) (void))
 
      (define/public (show-scrollbars h? v?)
        (let ([h? (and h? hscroll-ok?)]

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

@@ -63,7 +63,7 @@
         (let ([wx (->wx wxb)])
           (when wx
             (queue-window-event wx (lambda ()
-                                     (send wx on-size 0 0)
+                                     (send wx queue-on-size)
                                      (send wx clean-up)))
             ;; Live resize:
             (constrained-reply (send wx get-eventspace)
@@ -74,7 +74,7 @@
   [-a _void (windowDidMove: [_id notification])
       (when wxb
         (queue-window*-event wxb (lambda (wx)
-                                   (send wx on-size 0 0))))]
+                                   (send wx queue-on-size))))]
   [-a _void (windowDidBecomeMain: [_id notification])
       ;; We check whether the window is visible because
       ;; clicking the dock item tries to resurrect a hidden

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

@@ -591,7 +591,9 @@
             [y (if (= y -11111) (get-y) y)])
         (tellv cocoa setNeedsDisplay: #:type _BOOL #t)
         (tellv cocoa setFrame: #:type _NSRect (make-NSRect (make-NSPoint x (flip y h))
-                                                           (make-NSSize w h)))))
+                                                           (make-NSSize w h))))
+      (queue-on-size))
+
     (define/public (internal-move x y)
       (set-size x y (get-width) (get-height)))
     (define/public (move x y)
@@ -702,7 +704,7 @@
 
     (define/public (on-char s) (void))
     (define/public (on-event m) (void))
-    (define/public (on-size x y) (void))
+    (define/public (queue-on-size) (void))
 
     (define last-l? #f)
     (define last-m? #f)
@@ -725,6 +727,7 @@
       (send (get-parent) end-no-cursor-rects))
 
     (define/public (get-handle) (get-cocoa))
+    (define/public (get-client-handle) (get-cocoa-content))
 
     (define/public (popup-menu m x y)
       (send m do-popup (get-cocoa-content) (get-cocoa-window) x (flip-client y)

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

@@ -22,6 +22,13 @@
 (define-gtk gtk_button_new (_fun -> _GtkWidget))
 (define-gtk gtk_window_set_default (_fun _GtkWidget (_or-null _GtkWidget) -> _void))
 (define-gtk gtk_button_set_label (_fun _GtkWidget _string -> _void))
+(define-gtk gtk_button_set_image (_fun _GtkWidget _GtkWidget -> _void))
+(define-gtk gtk_button_set_image_position (_fun _GtkWidget _int -> _void))
+
+(define GTK_POS_LEFT 0)
+(define GTK_POS_RIGHT 1)
+(define GTK_POS_TOP 2)
+(define GTK_POS_BOTTOM 3)
 
 (define-gtk gtk_container_remove (_fun _GtkWidget _GtkWidget -> _void))
 (define-gtk gtk_bin_get_child (_fun _GtkWidget -> _GtkWidget))
@@ -47,18 +54,35 @@
                     (as-gtk-allocation
                      (gtk_new_with_mnemonic (or (mnemonic-string label) "")))]
                    [else
-                    (let ([pixbuf (bitmap->pixbuf label)])
+                    (let ([pixbuf (bitmap->pixbuf (if (pair? label) 
+                                                      (car label)
+                                                      label))])
                       (atomically
-                       (let ([gtk (as-gtk-allocation (gtk_new))]
+                       (let ([gtk (if (pair? label)
+                                      (as-gtk-allocation (gtk_new_with_mnemonic (cadr label)))
+                                      (as-gtk-allocation (gtk_new)))]
                              [image-gtk (gtk_image_new_from_pixbuf pixbuf)])
                          (release-pixbuf pixbuf)
-                         (gtk_container_add gtk image-gtk)
+                         (if (pair? label)
-                         (gtk_widget_show image-gtk)
+                             (begin
+                               (gtk_button_set_image gtk image-gtk)
+                               (gtk_button_set_image_position 
+                                gtk
+                                (case (caddr label)
+                                  [(left) GTK_POS_LEFT]
+                                  [(right) GTK_POS_RIGHT]
+                                  [(top) GTK_POS_TOP]
+                                  [(bottom) GTK_POS_BOTTOM])))
+                             (begin
+                               (gtk_container_add gtk image-gtk)
+                               (gtk_widget_show image-gtk)))
                          gtk)))])]
              [callback cb]
              [font font]
              [no-show? (memq 'deleted style)])
   (define gtk (get-gtk))
+
+  (define both-labels? (pair? label))
   
   (when (eq? event-type 'button)
     (set-gtk-object-flags! gtk (bitwise-ior (get-gtk-object-flags gtk)
@@ -92,9 +116,12 @@
         (atomically
          (let ([image-gtk (gtk_image_new_from_pixbuf pixbuf)])
            (release-pixbuf pixbuf)
-           (gtk_container_remove gtk (gtk_bin_get_child gtk))
+           (if both-labels?
-           (gtk_container_add gtk image-gtk)
+               (gtk_button_set_image gtk image-gtk)
-           (gtk_widget_show image-gtk))))]))
+               (begin
+                 (gtk_container_remove gtk (gtk_bin_get_child gtk))
+                 (gtk_container_add gtk image-gtk)
+                 (gtk_widget_show image-gtk))))))]))
 
   (define/public (set-border on?)
     (gtk_window_set_default (get-window-gtk) (if on? gtk #f))))

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

@@ -194,7 +194,7 @@
            [gl-config #f])
 
      (inherit get-gtk set-size get-size get-client-size 
-              on-size get-top-win
+              get-top-win
               set-auto-size 
               adjust-client-delta infer-client-delta
               is-auto-scroll? get-virtual-width get-virtual-height
@@ -438,10 +438,9 @@
      (define/override (internal-on-client-size w h)
        (reset-dc))
      (define/override (on-client-size w h) 
-       (let ([xb (box 0)]
+       (on-size))
-             [yb (box 0)])
+
-         (get-size xb yb)
+     (define/public (on-size) (void))
-         (on-size (unbox xb) (unbox yb))))
 
      (define/public (show-scrollbars h? v?)
        (when hscroll-gtk

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

@@ -139,7 +139,7 @@
           style)
     (init [is-dialog? #f])
 
-    (inherit get-gtk set-size on-size
+    (inherit get-gtk set-size
              pre-on-char pre-on-event
              get-client-delta get-size
              get-parent get-eventspace

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

@@ -56,19 +56,19 @@
      (ffi-lib "libgio-2.0-0")
      (ffi-lib "libgdk_pixbuf-2.0-0")
      (ffi-lib "libgdk-win32-2.0-0")]
-    [else (ffi-lib "libgdk-x11-2.0" '("0"))]))
+    [else (ffi-lib "libgdk-x11-2.0" '("0" ""))]))
 (define gdk_pixbuf-lib 
   (case (system-type)
     [(windows)
      (ffi-lib "libgdk_pixbuf-2.0-0")]
     [(unix)
-     (ffi-lib "libgdk_pixbuf-2.0" '("0"))]
+     (ffi-lib "libgdk_pixbuf-2.0" '("0" ""))]
     [else gdk-lib]))
 (define gtk-lib
   (case (system-type)
     [(windows) 
      (ffi-lib "libgtk-win32-2.0-0")]
-    [else (ffi-lib "libgtk-x11-2.0" '("0"))]))
+    [else (ffi-lib "libgtk-x11-2.0" '("0" ""))]))
 
 (define-ffi-definer define-gtk gtk-lib)
 (define-ffi-definer define-gdk gdk-lib)

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

@@ -420,7 +420,8 @@
         (unless (= h -1) (set! save-h h))
         (set! save-w (max save-w client-delta-w))
         (set! save-h (max save-h client-delta-h))
-        (really-set-size gtk x y save-x save-y save-w save-h)))
+        (really-set-size gtk x y save-x save-y save-w save-h)
+        (queue-on-size)))
 
     (define/public (save-size x y w h)
       (set! save-w w)
@@ -441,13 +442,7 @@
         (set! save-h h)
         (queue-on-size)))
 
-    (define on-size-queued? #f)
+    (define/public (queue-on-size) (void))
-    (define/public (queue-on-size)
-      (unless on-size-queued?
-        (set! on-size-queued? #t)
-        (queue-window-event this (lambda () 
-                                   (set! on-size-queued? #f)
-                                   (on-size 0 0)))))
 
     (define client-delta-w 0)
     (define client-delta-h 0)
@@ -605,8 +600,6 @@
     (define/public (on-char e) (void))
     (define/public (on-event e) (void))
 
-    (define/public (on-size w h) (void))
-
     (define/public (register-child child on?)
       (void))
     (define/public (register-child-in-parent on?)
@@ -619,6 +612,7 @@
     (define/public (on-drop-file path) (void))
 
     (define/public (get-handle) (get-gtk))
+    (define/public (get-client-handle) (get-client-gtk))
 
     (define/public (popup-menu m x y)
       (let ([gx (box x)]

collects/mred/private/wx/win32/button.rkt

@@ -3,6 +3,7 @@
          racket/draw
          ffi/unsafe
           "../../syntax.rkt"
+          "../../lock.rkt"
           "../common/event.rkt"
          "item.rkt"
 	 "utils.rkt"
@@ -18,16 +19,23 @@
 
 (define BM_SETSTYLE #x00F4)
 
+(define-kernel32 GetVersion (_wfun -> _DWORD))
+
+(define xp? (= 5 (bitwise-and #xFF (GetVersion))))
+
 (define base-button% 
   (class item%
     (inherit set-control-font auto-size get-hwnd
-             remember-label-bitmap)
+             remember-label-bitmap set-size)
 
     (init parent cb label x y w h style font)
 
     (define callback cb)
 
-    (define bitmap? (label . is-a? . bitmap%))
+    (define bitmap? (or (label . is-a? . bitmap%)
+			(pair? label)))
+    (define orientation (and (pair? label)
+			     (caddr label)))
 
     (define/public (get-class) "PLTBUTTON")
     (define/public (get-flags) BS_PUSHBUTTON)
@@ -37,12 +45,19 @@
                [hwnd 
                 (CreateWindowExW/control 0
                                          (get-class)
-                                         (if (string? label)
+                                         (cond
-                                             label
+					  [(string? label) label]
-                                             "<image>")
+					  [(pair? label) (cadr label)]
+					  [else "<image>"])
                                          (bitwise-ior (get-flags) WS_CHILD WS_CLIPSIBLINGS
                                                       (if bitmap?
-                                                          BS_BITMAP
+							  (case (and (not xp?) 
+								     orientation)
+							    [(#f) BS_BITMAP]
+							    [(left) BS_LEFT]
+							    [(right) BS_RIGHT]
+							    [(top) BS_TOP]
+							    [(bottom) BS_BOTTOM])
                                                           0))
                                          0 0 0 0
                                          (send parent get-client-hwnd)
@@ -52,24 +67,94 @@
                [style style])
 
     (when bitmap?
-      (let ([hbitmap (bitmap->hbitmap label #:bg (get-button-background))])
+      (let ([hbitmap (bitmap->hbitmap (if (pair? label)
+					  (if xp?
+					      (collapse-to-bitmap label font)
+					      (car label))
+					  label)
+				      #:bg (get-button-background))])
         (remember-label-bitmap hbitmap)
         (SendMessageW (get-hwnd) BM_SETIMAGE IMAGE_BITMAP 
                       (cast hbitmap _HBITMAP _LPARAM))))
 
+    (define/private (collapse-to-bitmap label font)
+      ;; XP doesn't handle a combination of string
+      ;; and bitmap labels
+      (let-values ([(w h) (auto-size-button font label
+					    #:resize (lambda (w h)
+						       (values w h)))])
+	 (let* ([bm (make-object bitmap% w h #f #f)]
+		[dc (make-object bitmap-dc% bm)]
+		[h? (memq (caddr label) '(left right))])
+	   (send dc draw-bitmap (car label)
+		 (if h?
+		     (if (eq? (caddr label) 'left)
+			 3
+			 (- w (send (car label) get-width) 3))
+		     (quotient (- w (send (car label) get-width)) 2))
+		 (if h?
+		     (quotient (- h (send (car label) get-height)) 2)
+		     (if (eq? (caddr label) 'top)
+			 3
+			 (- h (send (car label) get-height) 3))))
+	   (send dc set-font (or font (get-default-control-font)))
+	   (let-values ([(tw th ta td) (send dc get-text-extent (cadr label))])
+	     (send dc draw-text (cadr label)
+		   (if h?
+		       (if (eq? (caddr label) 'left)
+			   (- w tw 3)
+			   3)
+		       (quotient (- w tw) 2))
+		   (if h?
+		       (quotient (- h th) 2)
+		       (if (eq? (caddr label) 'top)
+			   (- h th 3)
+			   3))))
+	   (send dc set-bitmap #f)
+	   bm)))
+
     (set-control-font font)
 
     (define/public (get-button-background)
       #xFFFFFF)
 
-    (define/public (auto-size-button font label)
+    (define/public (auto-size-button 
+		    font 
+		    label
+		    #:resize [resize (lambda (w h) (set-size -11111 -11111 w h))])
       (cond
+       [orientation
+	(let ([h? (memq orientation '(left right))])
+	  (auto-size font (list (car label) (cadr label))
+		     0 0 12 8
+		     resize
+		     #:combine-width (if h? + max)
+		     #:combine-height (if h? max +)))]
        [bitmap?
         (auto-size font label 0 0 4 4)]
        [else
         (auto-size font label 60 20 12 0 #:scale-w 1.1 #:scale-h 1.1)]))
     (auto-size-button font label)
 
+    (define xp-label-bitmap (and xp? orientation (car label)))
+    (define xp-label-string (and xp? orientation (string->immutable-string (cadr label))))
+    (define xp-label-font (and xp? orientation font))
+
+    (define/override (set-label s)
+      (if (and orientation xp?)
+	  (atomically
+	   (begin
+	     (if (string? s) 
+		 (set! xp-label-string s)
+		 (set! xp-label-bitmap s))
+	     (super
+	      set-label
+	      (collapse-to-bitmap (list xp-label-bitmap
+					xp-label-string
+					orientation)
+				  xp-label-font))))
+	  (super set-label s)))
+
     (define/override (is-command? cmd)
       (= cmd BN_CLICKED))
 
@@ -88,5 +173,3 @@
 (define button% 
   (class base-button%
     (super-new)))
-
-

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

@@ -86,8 +86,7 @@
               set-control-font
               is-auto-scroll? get-virtual-width get-virtual-height
               reset-auto-scroll
-              refresh-for-autoscroll
+              refresh-for-autoscroll)
-              on-size)
 
      (define hscroll? (memq 'hscroll style))
      (define vscroll? (memq 'vscroll style))
@@ -162,17 +161,21 @@
                  (queue-paint)
                  (if (positive? paint-suspended)
                      (set! suspended-refresh? #t)
-                     (let* ([hbrush (if no-autoclear?
+                     (let ([erase
-                                        #f
+                            (lambda ()
-                                        (if transparent?
+                              (let* ([hbrush (if no-autoclear?
-                                            background-hbrush
+                                                 #f
-                                            (CreateSolidBrush bg-colorref)))])
+                                                 (if transparent?
-                       (when hbrush
+                                                     background-hbrush
-                         (let ([r (GetClientRect canvas-hwnd)])
+                                                     (CreateSolidBrush bg-colorref)))])
-                           (FillRect hdc r hbrush))
+                                (when hbrush
-                         (unless transparent?
+                                  (let ([r (GetClientRect canvas-hwnd)])
-                           (DeleteObject hbrush)))
+                                    (FillRect hdc r hbrush))
+                                  (unless transparent?
+                                    (DeleteObject hbrush)))))])
+                       (when transparent? (erase))
                        (unless (do-canvas-backing-flush hdc)
+                         (unless transparent? (erase))
                          (queue-paint)))))
              (EndPaint w ps)))
          0]
@@ -237,7 +240,9 @@
                 [h (if (= h -1) (- (RECT-bottom r) (RECT-top r)) h)])
            (MoveWindow canvas-hwnd 0 0 (max 1 (- w COMBO-WIDTH)) h #t)
            (MoveWindow combo-hwnd 0 0 (max 1 w) (- h 2) #t)))
-       (on-size 0 0))
+       (on-size))
+
+     (define/public (on-size) (void))
 
      ;; The `queue-paint' and `paint-children' methods
      ;; are defined by `canvas-mixin' from ../common/canvas-mixin

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

@@ -105,7 +105,7 @@
   (inherit get-hwnd 
 	   is-shown?
 	   get-eventspace
-           on-size
+           queue-on-size
            pre-on-char pre-on-event
            reset-cursor-in-child)
 
@@ -215,10 +215,10 @@
       0]
      [(and (= msg WM_SIZE)
            (not (= wParam SIZE_MINIMIZED)))
-      (queue-window-event this (lambda () (on-size 0 0)))
+      (queue-window-event this (lambda () (queue-on-size)))
       (stdret 0 1)]
      [(= msg WM_MOVE)
-      (queue-window-event this (lambda () (on-size 0 0)))
+      (queue-window-event this (lambda () (queue-on-size)))
       (stdret 0 1)]
      [(= msg WM_ACTIVATE)
       (let ([state (LOWORD wParam)]

collects/mred/private/wx/win32/hbitmap.rkt

@@ -4,6 +4,7 @@
          racket/draw
          racket/draw/private/local
          racket/class
+	 "dc.rkt"
          "types.rkt"
          "utils.rkt"
          "const.rkt")
@@ -18,6 +19,18 @@
                          #:bg [bg (GetSysColor COLOR_BTNFACE)])
   (let* ([w (send bm get-width)]
          [h (send bm get-height)]
+	 [bm (if (bm . is-a? . win32-bitmap%)
+		 ;; Windows wants to use the result bitmap
+		 ;; as an ARGB bitmap, but Cairo seems to transfer
+		 ;; RGB win32 bitmaps to RGB win32 bitmaps in a
+		 ;; way that sometimes mangles the alpha; avoid the
+		 ;; problem by first copying to a Cairo memory bitmap.
+		 (let* ([new-b (make-object bitmap% w h #f #f)]
+			[dc (make-object bitmap-dc% new-b)])
+		   (send dc draw-bitmap bm 0 0)
+		   (send dc set-bitmap #f)
+		   new-b)
+		 bm)]
          [mask-bm (or mask-bm
                       (send bm get-loaded-mask))]
          [to-frac (lambda (v) (/ v 255.0))]

collects/mred/private/wx/win32/theme.rkt

@@ -55,8 +55,10 @@
 				      -> (when (negative? r)
 					   (error 'CloseThemeData "failed: ~s" (bitwise-and #xFFFF r))))
   #:wrap (deallocator))
-(define-uxtheme OpenThemeData (_wfun _HWND _string/utf-16 -> _HTHEME)
+(define (maybe-CloseThemeData v) (when v (CloseThemeData v)))
-  #:wrap (allocator CloseThemeData))
+(define-uxtheme OpenThemeData (_wfun _HWND _string/utf-16 -> (_or-null _HTHEME))
+  #:wrap (allocator maybe-CloseThemeData))
+
 (define-uxtheme GetThemeFont (_wfun _HTHEME _HDC _int _int _int (f : (_ptr o _LOGFONT))
 				    -> (r : _HRESULT)
 				    -> (if (negative? r) 

collects/mred/private/wx/win32/window.rkt

@@ -25,6 +25,7 @@
               queue-window-refresh-event
               location->window
               flush-display
+	      get-default-control-font
 
               GetWindowRect
               GetClientRect))
@@ -243,11 +244,12 @@
   (unless (memq 'deleted style)
     (show #t))
   
-  (define/public (on-size w h) (void))
+  (define/public (queue-on-size) (void))
 
   (define/public (on-set-focus) (void))
   (define/public (on-kill-focus) (void))
   (define/public (get-handle) hwnd)
+  (define/public (get-client-handle) (get-client-hwnd))
 
   (define enabled? #t)
   (define parent-enabled? #t)
@@ -313,6 +315,7 @@
         (MoveWindow hwnd x y w h #t))
     (unless (and (= w -1) (= h -1))
       (on-resized))
+    (queue-on-size)
     (refresh))
   (define/public (move x y)
     (set-size x y -1 -1))

collects/mred/private/wxme/editor-canvas.rkt

@@ -288,13 +288,16 @@
     (send admin set-canvas #f)
     #|(super ~)|#)
   
-  (define/override (on-size w h)
+  (define/override (on-size)
     (unless noloop?
-      (unless (and (= w lastwidth)
+      (unless (and media
-                   (= h lastheight))
+                   (send media get-printing))
-        (unless (and media
+        (let-boxes ([w 0]
-                     (send media get-printing))
+                    [h 0])
-          (reset-size)))))
+            (get-size w h)
+          (unless (and (= w lastwidth)
+                       (= h lastheight))
+            (reset-size))))))
 
   (define/private (reset-size)
     (reset-visual #f)
@@ -1131,17 +1134,17 @@
 
   (define/public (do-scroll-to localx localy w h refresh? bias prev? next? only-focus?)
     (and canvas
-         (or (and (or (send canvas is-focus-on?)
+         (or (and (not (send canvas is-focus-on?))
-                      (not only-focus?))
-                  (list (send canvas scroll-to localx localy w h refresh? bias)))
-             (and (not (send canvas is-focus-on?))
                   (or
                    (and prev? 
                         prevadmin
                         (send prevadmin do-scroll-to localx localy w h refresh? bias #t #f #t))
                    (and next? 
                         nextadmin
-                        (send nextadmin do-scroll-to localx localy w h refresh? bias #f #t #t)))))))
+                        (send nextadmin do-scroll-to localx localy w h refresh? bias #f #t #t))))
+             (and (or (not only-focus?)
+                      (send canvas is-focus-on?))
+                  (list (send canvas scroll-to localx localy w h refresh? bias))))))
 
   (def/override (grab-caret [(symbol-in immediate display global) dist])
     (when canvas

collects/mred/private/wxme/editor.rkt

@@ -447,10 +447,6 @@
   (define/public (set-caret-owner snip focus) (void))
   (define/public (read-from-file mf) #f)
 
-  (define/public (do-copy time) (void))
-  (define/public (do-paste time) (void))
-  (define/public (do-paste-x-selection time) (void))
-
   (def/public (do-edit-operation [symbol? op] [any? [recursive? #t]] [exact-integer? [time 0]])
     (if (and recursive?
              s-caret-snip)

collects/mred/private/wxme/pasteboard.rkt

@@ -1751,7 +1751,7 @@
     (copy extend? time)
     (clear))
 
-  (def/override (do-copy [exact-integer? time] [bool? extend?])
+  (def/public (do-copy [exact-integer? time] [bool? extend?])
     (set-common-copy-region-data! #f)
     (let ([sl (if (and extend?
                        copy-style-list)
@@ -1814,10 +1814,10 @@
                 (add-selected snip)
                 (loop (snip->next snip))))))))
 
-  (def/override (do-paste [exact-integer? time])
+  (def/public (do-paste [exact-integer? time])
     (do-generic-paste the-clipboard time))
 
-  (def/override (do-paste-x-selection [exact-integer? time])
+  (def/public (do-paste-x-selection [exact-integer? time])
     (do-generic-paste the-x-selection-clipboard time))
   
   (define/private (generic-paste x-sel? time)
@@ -1907,7 +1907,7 @@
                              [any? [replace-styles? #f]])
     (if (or s-user-locked? 
             (not (zero? write-locked)))
-        'guess ;; FIXME: docs say that this is more specific
+        'standard
         (do-insert-file (method-name 'pasteboard% 'insert-file) f replace-styles?)))
   
   (define/private (do-insert-file who f clear-styles?)

collects/mred/private/wxme/text.rkt

@@ -2032,10 +2032,10 @@
         (copy extend? time start end)
         (delete start end))))
 
-  (def/override (do-copy [exact-nonnegative-integer? startp] 
+  (def/public (do-copy [exact-nonnegative-integer? startp] 
-                         [exact-nonnegative-integer? endp] 
+                       [exact-nonnegative-integer? endp] 
-                         [exact-integer? time] 
+                       [exact-integer? time] 
-                         [bool? extend?])
+                       [bool? extend?])
     (let ([startp (max startp 0)]
           [endp (min endp len)])
       (unless (endp . <= . startp)
@@ -2094,10 +2094,10 @@
         (set! prev-paste-start start)
         (set! prev-paste-end (+ start delta)))))
 
-  (define/override (do-paste start time)
+  (define/public (do-paste start time)
     (do-generic-paste the-clipboard start time))
 
-  (define/override (do-paste-x-selection start time)
+  (define/public (do-paste-x-selection start time)
     (do-generic-paste the-x-selection-clipboard start time))
 
   (define/private (generic-paste x-sel? time start end)
@@ -2592,7 +2592,9 @@
                              [(symbol-in guess same copy standard text text-force-cr) [format 'guess]]
                              [any? [replace-styles? #t]])
     (if (or write-locked? s-user-locked?)
-        'guess ;; FIXME: docs say that this is more specific
+        (if (not (detect-wxme-file (method-name 'text% 'insert-file) f #t))
+            'text
+            'standard)
         (do-insert-file (method-name 'text% 'insert-file) f format replace-styles?)))
 
   (define/private (do-insert-file who f fmt clear-styles?)

collects/mred/private/wxpanel.rkt

@@ -34,7 +34,6 @@
 	[on-set-focus (lambda () (void))]
 	[on-kill-focus (lambda () (void))]
 	[set-focus (lambda () (void))]
-	[on-size (lambda () (void))]
 	[enable (lambda () (void))]
 	[show (lambda (on?) (void))]
         [is-shown? (lambda () #f)]

collects/mred/private/wxtop.rkt

@@ -395,8 +395,8 @@
 	;;            aren't stretchable, frame resized to size of
 	;;            contents.  Each direction is handled
 	;;            independently.
-	[on-size
+	[queue-on-size
-	 (lambda (bad-width bad-height)
+	 (lambda ()
 	   (unless (and already-trying? (not (eq? 'unix (system-type))))
 	     (parameterize ([wx:current-eventspace (get-eventspace)])
 	       (wx:queue-callback (lambda () (resized)) #t))))])

collects/mred/private/wxwindow.rkt

@@ -190,29 +190,28 @@
 			 (as-exit
 			  (lambda ()
 			    (send (get-proxy) on-drop-file f)))))]
-	[on-size (lambda (bad-w bad-h)
+	[queue-on-size
-		   (super on-size bad-w bad-h)
+         (lambda ()
-		   ;; Delay callback to make sure X structures (position) are updated, first.
+           (super queue-on-size)
-		   ;; Also, Windows needs a trampoline.
+           (queue-window-callback
-		   (queue-window-callback
+            this
-		    this
+            (entry-point
-		    (entry-point
+             (lambda ()
-		     (lambda ()
+               (let ([mred (get-mred)])
-		       (let ([mred (get-mred)])
+                 (when mred 
-			 (when mred 
+                   (let* ([w (get-width)]
-			   (let* ([w (get-width)]
+                          [h (get-height)])
-				  [h (get-height)])
+                     (when (not (and (= w old-w) (= h old-h)))
-			     (when (not (and (= w old-w) (= h old-h)))
+                       (set! old-w w)
-			       (set! old-w w)
+                       (set! old-h h)
-			       (set! old-h h)
+                       (as-exit (lambda () (send mred on-size w h)))))
-			       (as-exit (lambda () (send mred on-size w h)))))
+                   (let* ([p (area-parent)]
-			   (let* ([p (area-parent)]
+                          [x (- (get-x) (or (and p (send p dx)) 0))]
-				  [x (- (get-x) (or (and p (send p dx)) 0))]
+                          [y (- (get-y) (or (and p (send p dy)) 0))])
-				  [y (- (get-y) (or (and p (send p dy)) 0))])
+                     (when (not (and (= x old-x) (= y old-y)))
-			     (when (not (and (= x old-x) (= y old-y)))
+                       (set! old-x x)
-			       (set! old-x x)
+                       (set! old-y y)
-			       (set! old-y y)
+                       (as-exit (lambda () (send mred on-move x y)))))))))))]
-			       (as-exit (lambda () (send mred on-move x y)))))))))))]
 	[on-set-focus (lambda () 
                         (super on-set-focus)
                         (when expose-focus? (send (get-proxy) on-focus #t)))]

collects/mrlib/image-core.rkt

@@ -313,8 +313,23 @@ has been moved out).
       (inexact->exact (ceiling (/ y scroll-step))))
 
     (define/override (copy) (make-image shape bb normalized? pinhole))
-    (define/override (draw dc x y left top right bottom dx dy draw-caret?)
+    
-      (render-image this dc x y))
+    (define cached-bitmap #f)
+    
+    (define/override (draw dc x y left top right bottom dx dy draw-caret)
+      (unless cached-bitmap
+        (set! cached-bitmap (make-bitmap (+ (inexact->exact (round (bb-right bb))) 1) 
+                                         (+ (inexact->exact (round (bb-bottom bb))) 1)))
+        (define bdc (make-object bitmap-dc% cached-bitmap))
+        (send bdc erase)
+        (render-image this bdc 0 0)
+        (send bdc set-bitmap #f))
+      
+      (let ([alpha (send dc get-alpha)])
+        (when (pair? draw-caret)
+          (send dc set-alpha (* alpha .5)))
+        (send dc draw-bitmap cached-bitmap x y)
+        (send dc set-alpha alpha)))
     
     (define/override (get-extent dc x y [w #f] [h #f] [descent #f] [space #f] [lspace #f] [rspace #f])
       (send (get-the-snip-class-list) add snip-class)
@@ -1042,31 +1057,44 @@ the mask bitmap and the original bitmap are all together in a single bytes!
     [else 'smoothed]))
 
 (define (mode-color->pen mode color)
-  (case mode
+  (cond
-    [(outline) 
+    [(eq? mode 'outline)
      (cond
        [(pen? color)
         (pen->pen-obj/cache color)]
        [else
         (send the-pen-list find-or-create-pen (get-color-arg color) 0 'solid 'round 'miter)])]
-    [(solid)
+    [else
      (send the-pen-list find-or-create-pen "black" 1 'transparent)]))
 
 (define (mode-color->brush mode color)
-  (case mode
+  (cond
-    [(outline)
+    [(eq? mode 'outline)
      (send the-brush-list find-or-create-brush "black" 'transparent)]
-    [(solid)
+    [else
-     (send the-brush-list find-or-create-brush (get-color-arg color) 'solid)]))
+     ;; this should only be 'solid if we have an old image from a save file somewhere
+     (define extra-alpha (if (eq? mode 'solid)
+                             255
+                             mode))
+     (send the-brush-list find-or-create-brush (get-color-arg color extra-alpha) 'solid)]))
 
-(define (get-color-arg color)
+(define (get-color-arg color [extra-alpha 255])
-  (if (string? color) 
+  (cond
-      color
+    [(string? color) 
-      (make-object color% 
+     (define color-obj (or (send the-color-database find-color color)
-        (color-red color)
+                           (send the-color-database find-color "black")))
-        (color-green color)
+     (make-object color%
-        (color-blue color)
+       (send color-obj red)
-        (/ (color-alpha color) 255))))
+       (send color-obj green)
+       (send color-obj blue)
+       (/ extra-alpha 255))]
+    [else
+     (make-object color% 
+       (color-red color)
+       (color-green color)
+       (color-blue color)
+       (* (/ (color-alpha color) 255)
+          (/ extra-alpha 255)))]))
 
 
 (define (pen->pen-obj/cache pen)

collects/scribblings/framework/color.scrbl

@@ -220,6 +220,15 @@
 
     Must only be called while the tokenizer is started.
   }
+  
+  @defmethod[#:mode augment (on-lexer-valid [valid? boolean?]) any]{
+    This method is an observer for when the lexer is working.
+    It is called when the lexer's state changes from valid to invalid (and back). 
+    The @racket[valid?] argument indicates if the lexer has finished running over the editor (or not).
+    
+    The default method just returns @racket[(void)].
+  }
+  
 }
 @defmixin[color:text-mixin (text:basic<%>) (color:text<%>)]{
   Adds the functionality needed for on-the-fly coloring and parenthesis

collects/scribblings/gui/button-class.scrbl

@@ -7,7 +7,11 @@ Whenever a button is clicked by the user, the button's callback
  procedure is invoked. A callback procedure is provided as an
  initialization argument when each button is created.
 
-@defconstructor[([label (or/c label-string? (is-a?/c bitmap%))]
+@defconstructor[([label (or/c label-string? 
+                              (is-a?/c bitmap%)
+                              (list/c (is-a?/c bitmap%)
+                                      label-string?
+                                      (one-of/c 'left 'top 'right 'bottom)))]
                  [parent (or/c (is-a?/c frame%) (is-a?/c dialog%) 
                                (is-a?/c panel%) (is-a?/c pane%))]
                  [callback ((is-a?/c button%) (is-a?/c control-event%) . -> . any) (lambda (b e) (void))]
@@ -21,10 +25,13 @@ Whenever a button is clicked by the user, the button's callback
                  [stretchable-width any/c #f]
                  [stretchable-height any/c #f])]{
 
-Creates a button with a string or bitmap label.
+Creates a button with a string label, bitmap label, or both.
- @bitmaplabeluse[label]
+ @bitmaplabeluse[label] If @racket[label] is a list, then
+ the button has both a bitmap and string label, and the
+ symbol @racket['left], @racket['top], @racket['right], or @racket['bottom]
+ specifies the location of the image relative to the text on the button.
 
-If @litchar{&} occurs in @scheme[label] (when @scheme[label] is a
+If @litchar{&} occurs in @scheme[label] (when @scheme[label] includes a
 string), it is specially parsed; under Windows and X, the character
 following @litchar{&} is underlined in the displayed control to
 indicate a keyboard mnemonic. (Under Mac OS X, mnemonic underlines are
@@ -56,7 +63,8 @@ on-traverse-char]). @DeletedStyleNote[@scheme[style] @scheme[parent]]{button}
 
 
 @defmethod[#:mode override
-           (set-label [label (or/c label-string? (is-a?/c bitmap%))])
+           (set-label [label (or/c label-string? 
+                                   (is-a?/c bitmap%))])
            void?]{
 
 The same as @xmethod[window<%> set-label] when @scheme[label] is a
@@ -65,5 +73,8 @@ The same as @xmethod[window<%> set-label] when @scheme[label] is a
 Otherwise, sets the bitmap label for a bitmap button. @bitmaplabeluseisbm[label]
  @|bitmapiforiglabel|
 
+If the button has both a string and a bitmap label, then either can be
+ set using @method[button% set-label].
+
 }}
 

collects/scribblings/gui/canvas-class.scrbl

@@ -3,8 +3,9 @@
 
 @defclass/title[canvas% object% (canvas<%>)]{
 
-A @scheme[canvas%] object is a general-purpose window for drawing
+A @scheme[canvas%] object is a general-purpose window for drawing and
- and handling events.
+ handling events. See @racket[canvas<%>] for information about drawing
+ onto a canvas.
 
 
 @defconstructor[([parent (or/c (is-a?/c frame%) (is-a?/c dialog%) 
@@ -52,12 +53,15 @@ The @scheme[style] argument indicates one or more of the following styles:
        @racket['no-autoclear]}
 
  @item{@scheme['no-autoclear] --- prevents automatic erasing of the
-       canvas before calls to @method[canvas% on-paint]} 
+       canvas by the windowing system; see @racket[canvas<%>] for
+       information on canvas refresh}
 
- @item{@scheme['transparent] --- the canvas is automatically ``erased''
+ @item{@scheme['transparent] --- the canvas is ``erased'' by the
- before an update using it's parent window's background; see @racket[canvas<%>]
+ windowing system by letting its parent show through; see
- for information on the interaction of @racket['transparent] and offscreen buffering; 
+ @racket[canvas<%>] for information on window refresh and on the
- the result is undefined if this flag is combined with @scheme['no-autoclear]}
+ interaction of @racket['transparent] and offscreen buffering; the
+ result is undefined if this flag is combined with
+ @scheme['no-autoclear]}
  
  @item{@scheme['no-focus] --- prevents the canvas from accepting the
  keyboard focus when the canvas is clicked, or when the

collects/scribblings/gui/canvas-intf.scrbl

@@ -10,34 +10,76 @@ The @scheme[canvas<%>] interface is implemented by two classes:
 @itemize[
 
  @item{@scheme[canvas%] --- a canvas for arbitrary drawing and
-  event handling}
+  event handling; and}
 
  @item{@scheme[editor-canvas%] --- a canvas for displaying
-  @scheme[editor<%>] objects}
+  @scheme[editor<%>] objects.}
 
 ]
 
-To draw onto a canvas, get its device context (see
+To draw onto a canvas, get its device context via @method[canvas<%>
-@method[canvas<%> get-dc]).
+ get-dc]. There are two basic approaches to updating a canvas:
+
+@itemlist[
+
+ @item{Drawing normally occurs during the canvas's @method[canvas<%>
+       on-paint] callback.  The @racket[canvas%] class supports a
+       @racket[paint-callback] initialization argument to be called
+       from the default @method[canvas<%> on-paint] method.
+
+       A canvas's @method[canvas<%> on-paint] method is called
+       automatically as an event when the windowing system determines
+       that the canvas must be updated, such as when the canvas is
+       first shown or when it is resized. Use the @method[window<%>
+       refresh] method to explicitly trigger an @method[canvas<%>
+       on-paint] call from the windowing system. (Multiple refresh
+       requests before @method[canvas<%> on-paint] can be called are
+       coaleced into a single @method[canvas<%> on-paint] call.)
+
+       Before the windowing system calls @method[canvas<%> on-paint],
+       it may erase the canvas's background (see @method[dc<%>
+       erase]), depending on the style of the canvas (e.g., as
+       determined by the @racket[style] initialization argument for
+       @racket[canvas%]). Even when the canvas's style suppresses
+       explicit clearing of the canvas, a canvas may be erased by the
+       windowing system due to window-moving and -resizing
+       operations. For a transparent canvas, ``erased'' means that the
+       canvas's parent window shows through.}
+
+ @item{Drawing can also occur at any time outside an @method[canvas<%>
+       on-paint] call form the windowing system, including from
+       threads other than the @tech{handler thread} of the canvas's
+       eventspace. Drawing outside an @method[canvas<%> on-paint]
+       callback from the system is transient in the sense that
+       windowing activity can erase the canvas, but the drawing is
+       persistent as long as no windowing refresh is needed.
+
+       Calling an @method[canvas<%> on-paint] method directly is the
+       same as drawing outside an @method[canvas<%> on-paint] callback
+       from the windowing system.}
+
+]
 
 Drawing to a canvas's drawing context actually renders into an
-offscreen buffer. The buffer is automatically flushed to the screen by
+offscreen buffer. The buffer is automatically flushed to the screen
-a background thread, explicitly via the @method[canvas<%> flush]
+asynchronously, explicitly via the @method[canvas<%> flush] method, or
-method, or explicitly via @racket[flush-display]---unless flushing
+explicitly via @racket[flush-display]---unless flushing has been
-has been disabled for the canvas.  The @method[canvas<%>
+disabled for the canvas.  The @method[canvas<%> suspend-flush] method
-suspend-flush] method suspends flushing for a canvas until a matching
+suspends flushing for a canvas until a matching @method[canvas<%>
-@method[canvas<%> resume-flush] calls; calls to @method[canvas<%>
+resume-flush] calls; calls to @method[canvas<%> suspend-flush] and
-suspend-flush] and @method[canvas<%> resume-flush] can be nested, in
+@method[canvas<%> resume-flush] can be nested, in which case flushing
-which case flushing is suspended until the outermost @method[canvas<%>
+is suspended until the outermost @method[canvas<%> suspend-flush] is
-suspend-flush] is balanced by a @method[canvas<%> resume-flush].
+balanced by a @method[canvas<%> resume-flush]. An @method[canvas<%>
+on-paint] call from the windowing system is implicitly wrapped with
+@method[canvas<%> suspend-flush] and @method[canvas<%> resume-flush]
+calls.
 
-In the case of a transparent canvas (i.e., one that is created with
+In the case of a transparent canvas, line and text smoothing can
-@racket['transparent] style), line and text smoothing can depend on
+depend on the window that serves as the canvas's background. For
-the window that serves as the canvas's background. For example,
+example, smoothing may color pixels differently depending on whether
-smoothing may color pixels differently depending on whether the target
+the target context is white or gray.  Background-sensitive smoothing
-context is white or gray.  Background-sensitive smoothing is supported
+is supported only if a relatively small number of drawing commands are
-only if a relatively small number of drawing commands are recorded in
+recorded in the canvas's offscreen buffer, however.
-the canvas's offscreen buffer, however.
 
 
 @defmethod*[([(accept-tab-focus)

collects/scribblings/gui/editor-admin-class.scrbl

@@ -273,8 +273,12 @@ The @scheme[bias] argument is one of:
 The return value is @scheme[#t] if the @techlink{display} is scrolled,
  @scheme[#f] if not (either because the requested region is already
  visible, because the @techlink{display} has zero size, or because the
- editor is currently printing.)
+ editor is currently printing).
 
+If an editor has multiple @techlink{displays}, then if any display
+ currently has the keyboard focus, it is scrolled. Otherwise, the
+ ``primary owner'' of the editor (see @method[editor-canvas%
+ call-as-primary-owner]) is scrolled.
 
 }
 @methimpl{

collects/scribblings/gui/editor-intf.scrbl

@@ -457,11 +457,6 @@ Returns the name of a style to be used for newly inserted text,
 }
 
 
-@defmethod[(do-copy) void?]{
-
-See @xmethod[text% do-copy] or @xmethod[pasteboard% do-copy].}
-
-
 @defmethod[(do-edit-operation [op (or/c 'undo 'redo 'clear 'cut 'copy 'paste 
                                         'kill 'select-all 'insert-text-box 
                                         'insert-pasteboard-box 'insert-image)]
@@ -499,16 +494,6 @@ See @|timediscuss| for a discussion of the @scheme[time] argument. If
 }
 
 
-@defmethod[(do-paste) void?]{
-
-See @xmethod[text% do-paste] or @xmethod[pasteboard% do-paste].}
-
-
-@defmethod[(do-paste-x-selection) void?]{
-
-See @xmethod[text% do-paste-x-selection] or @xmethod[pasteboard% do-paste-x-selection].}
-
-
 @defmethod[(editor-location-to-dc-location [x real?]
                                            [y real?])
            (values real? real?)]{

collects/scribblings/gui/pasteboard-class.scrbl

@@ -499,8 +499,7 @@ Deletes @scheme[snip] when provided, or deletes the currently selected
 }
 
 
-@defmethod[#:mode override 
+@defmethod[(do-copy [time exact-integer?]
-           (do-copy [time exact-integer?]
                     [extend? any/c])
            void?]{
 
@@ -524,8 +523,7 @@ Copies the current selection, extending the current clipboard contexts
 }}
 
 
-@defmethod[#:mode override
+@defmethod[(do-paste [time exact-integer?])
-           (do-paste [time exact-integer?])
            void?]{
 @methspec{
 
@@ -546,8 +544,7 @@ Pastes.
 }}
 
 
-@defmethod[#:mode override
+@defmethod[(do-paste-x-selection [time exact-integer?])
-           (do-paste-x-selection [time exact-integer?])
            void?]{
 @methspec{
 

collects/scribblings/gui/text-class.scrbl

@@ -422,8 +422,7 @@ Deletes the specified range or the currently selected text (when no
 
 }
 
-@defmethod[#:mode override
+@defmethod[(do-copy [start exact-nonnegative-integer?]
-           (do-copy [start exact-nonnegative-integer?]
                     [end exact-nonnegative-integer?]
                     [time exact-integer?]
                     [extend? any/c])
@@ -447,8 +446,7 @@ Copy the data from @scheme[start] to @scheme[end], extending the current
 }}
 
 
-@defmethod[#:mode override
+@defmethod[(do-paste [start exact-nonnegative-integer?]
-           (do-paste [start exact-nonnegative-integer?]
                      [time exact-integer?])
            void?]{
 @methspec{
@@ -469,8 +467,7 @@ Pastes into the @techlink{position} @scheme[start].
 }}
 
 
-@defmethod[#:mode override
+@defmethod[(do-paste-x-selection [start exact-nonnegative-integer?]
-           (do-paste-x-selection [start exact-nonnegative-integer?]
                                  [time exact-integer?])
            void?]{
 @methspec{

collects/scribblings/gui/window-intf.scrbl

@@ -1,5 +1,6 @@
 #lang scribble/doc
-@(require "common.ss")
+@(require "common.ss"
+          (for-label (only-in ffi/unsafe cpointer?)))
 
 @definterface/title[window<%> (area<%>)]{
 
@@ -80,6 +81,25 @@ Note that under X, keyboard focus can move to the menu bar
 }
 
 
+@defmethod[(get-client-handle) cpointer?]{
+
+Returns a handle to the ``inside'' of the window for the current
+platform's GUI toolbox. The value that the pointer represents depends
+on the platform:
+
+@itemize[
+
+ @item{Windows: @tt{HWND}}
+
+ @item{Mac OS X: @tt{NSView}}
+
+ @item{X: @tt{GtkWidget}}
+
+]
+
+See also @method[window<%> get-handle].}
+
+
 @defmethod[(get-client-size)
            (values (integer-in 0 10000)
                    (integer-in 0 10000))]{
@@ -98,7 +118,7 @@ See also
 
 
 @defmethod[(get-cursor)
-           (or/c (is-a?/c cursor%) false/c)]{
+           (or/c (is-a?/c cursor%) #f)]{
 
 Returns the window's cursor, or @scheme[#f] if this window's cursor
  defaults to the parent's cursor.  See
@@ -106,28 +126,25 @@ Returns the window's cursor, or @scheme[#f] if this window's cursor
 
 }
 
-@defmethod[(get-handle)
-           exact-integer?]{
 
-Returns an exact integer representing a handle to the window in the
+@defmethod[(get-handle) cpointer?]{
-current platform's GUI toolbox. Cast this number from a C @tt{long}
+
-to a platform-specific C type:
+Returns a handle to the ``outside'' of the window for the current platform's GUI
+toolbox. The value that the pointer represents depends on the
+platform:
 
 @itemize[
 
  @item{Windows: @tt{HWND}}
 
- @item{Mac OS X: @tt{WindowRef} for a @scheme[top-level-window<%>] object,
+ @item{Mac OS X: @tt{NSWindow} for a @scheme[top-level-window<%>] object,
-       @tt{ControlRef} for other windows}
+       @tt{NSView} for other windows}
 
- @item{X: @tt{Widget*}}
+ @item{X: @tt{GtkWidget}}
 
 ]
 
-Some windows may not have a representation in the platform's GUI level,
+See also @method[window<%> get-client-handle].}
- in which case the result of this method is @scheme[0].
-
-}
 
 
 @defmethod[(get-height)
@@ -141,8 +158,13 @@ See also
 }
 
 @defmethod[(get-label)
-           (or/c label-string? (is-a?/c bitmap%)
+           (or/c label-string? 
-                 (one-of/c 'app 'caution 'stop) false/c)]{
+                 (is-a?/c bitmap%)
+                 (one-of/c 'app 'caution 'stop) 
+                 (list/c (is-a?/c bitmap%)
+                         label-string?
+                         (one-of/c 'left 'top 'right 'bottom))
+                 #f)]{
 
 Gets a window's label, if any. Control windows generally display their
  label in some way. Frames and dialogs display their label as a window
@@ -151,9 +173,10 @@ Gets a window's label, if any. Control windows generally display their
  have bitmap labels (only when they are created with bitmap labels),
  but all other windows have string labels. In addition, a message
  label can be an icon symbol @scheme['app], @scheme['caution], or
- @scheme['stop].
+ @scheme['stop], and a button can have both a bitmap label and a
+ string label (along with a position for the bitmap).
 
-The label string may contain @litchar{&}s, which serve as
+A label string may contain @litchar{&}s, which serve as
  keyboard navigation annotations for controls under Windows and X. The
  ampersands are not part of the displayed label of a control; instead,
  ampersands are removed in the displayed label (under all platforms),
@@ -169,7 +192,7 @@ If the window does not have a label, @scheme[#f] is returned.
 
 
 @defmethod[(get-plain-label)
-           (or/c string false/c)]{
+           (or/c string #f)]{
 
 Like
 @method[window<%> get-label], except that ampersands in the label are removed. If the window has
@@ -467,7 +490,7 @@ Enqueues an event to repaint the window.
 }
 
 
-@defmethod[(set-cursor [cursor (or/c (is-a?/c cursor%) false/c)])
+@defmethod[(set-cursor [cursor (or/c (is-a?/c cursor%) #f)])
            void?]{
 
 Sets the window's cursor. Providing @scheme[#f] instead of a cursor

collects/tests/gracket/draw.rkt

@@ -923,9 +923,40 @@
                               (let ([p (send dc get-pen)])
                                 (send dc set-pen (make-object color% 0 0 0 0.1) 1 'solid)
                                 (send dc set-brush (make-object color% 255 0 200 0.5) 'solid)
-                                (send dc draw-rectangle 250 310 20 20)
+                                (send dc draw-rectangle 250 320 20 20)
                                 (send dc set-brush (make-object color% 0 255 200 0.5) 'solid)
-                                (send dc draw-rectangle 260 320 20 20)
+                                (send dc draw-rectangle 260 330 20 20)
+                                (send dc set-pen p))
+
+                              (let ([p (send dc get-pen)])
+                                (send dc set-pen "white" 1 'transparent)
+                                (send dc set-brush (new brush%
+                                                        [gradient
+                                                         (make-object linear-gradient%
+                                                                      300 0 380 0
+                                                                      (list (list 0.0
+                                                                                  (make-object color% 255 0 0))
+                                                                            (list 0.5
+                                                                                  (make-object color% 0 255 0))
+                                                                            (list 1.0
+                                                                                  (make-object color% 0 0 255 0.0))))]))
+                                (send dc draw-rectangle 300 320 80 20)
+                                (send dc set-pen p))
+
+                              (let ([p (send dc get-pen)])
+                                (send dc set-pen "white" 1 'transparent)
+                                (send dc set-brush (new brush%
+                                                        [gradient
+                                                         (make-object radial-gradient%
+                                                                      360 250 5
+                                                                      365 245 25
+                                                                      (list (list 0.0
+                                                                                  (make-object color% 255 0 0))
+                                                                            (list 0.5
+                                                                                  (make-object color% 0 255 0))
+                                                                            (list 1.0
+                                                                                  (make-object color% 0 0 255 0.0))))]))
+                                (send dc draw-rectangle 338 228 44 44)
                                 (send dc set-pen p))
 
 			      (send dc draw-line 130 310 150 310)

collects/tests/gracket/item.rkt

@@ -1235,6 +1235,55 @@
   (instructions p "button-steps.txt")
   (send f show #t))
 
+(define (image-button-frame)
+  (define f (make-frame frame% "Image Button Test"))
+  (define pt (make-object vertical-panel% f))
+  (define pm (make-object horizontal-panel% f))
+  (define pb (make-object vertical-panel% f))
+  (define pc (make-object horizontal-panel% f))
+  (define bt (new button% [parent pt]
+                  [label (list (read-bitmap
+                                (collection-file-path "foot.png" "icons"))
+                               "Top"
+                               'top)]))
+  (define bl (new button% [parent pm]
+                  [label (list (read-bitmap
+                                (collection-file-path "b-wait.png" "icons"))
+                               "Left"
+                               'left)]))
+  (define br (new button% [parent pm]
+                  [label (list (read-bitmap
+                                (collection-file-path "b-run.png" "icons"))
+                               "Right"
+                               'right)]))
+  (define bb (new button% [parent pb]
+                  [label (list (read-bitmap
+                                (collection-file-path "bug09.png" "icons"))
+                               "Bottom"
+                               'bottom)]))
+  (new button% [parent pc]
+       [label "Strings"]
+       [callback (lambda (b e)
+                   (for ([b (in-list (list bt bl br bb))])
+                     (send b set-label (list->string
+                                        (reverse
+                                         (string->list
+                                          (cadr (send b get-label))))))))])
+  (new button% [parent pc]
+       [label "Bitmaps"]
+       [callback (lambda (b e)
+                   (for ([b (in-list (list bt bl br bb))])
+                     (send b set-label (let ([bm (car (send b get-label))])
+                                         (let* ([bm2 (make-bitmap (send bm get-width)
+                                                                  (send bm get-height))]
+                                                [dc (make-object bitmap-dc% bm2)])
+                                           (send dc scale 1 -1)
+                                           (send dc translate 0 (send bm get-height))
+                                           (send dc draw-bitmap bm 0 0)
+                                           (send dc set-bitmap #f)
+                                           bm2)))))])
+  (send f show #t))
+
 (define (checkbox-frame)
   (define f (make-frame frame% "Checkbox Test"))
   (define p f)
@@ -2223,6 +2272,7 @@
 (make-object button% "Make Button Frame" bp (lambda (b e) (button-frame frame% null)))
 (make-object button% "Make Default Button Frame" bp (lambda (b e) (button-frame frame% '(border))))
 (make-object button% "Make Button Dialog" bp (lambda (b e) (button-frame dialog% null)))
+(make-object button% "Make Image Buttons" bp (lambda (b e) (image-button-frame)))
 (define crp (make-object horizontal-pane% ap))
 (send crp stretchable-height #f)
 (make-object button% "Make Checkbox Frame" crp (lambda (b e) (checkbox-frame)))

doc/release-notes/racket/Draw_and_GUI_5_1.txt

@@ -120,6 +120,8 @@ A `region%' can be created as independent of any `dc<%>', in which
 cases it uses the drawing context's current transformation at the time
 that it is installed as a clipping region.
 
+Brushes now support linear and radial gradients.
+
 The old 'xor mode for pens and brushes is no longer available (since
 it is not supported by Cairo).