gtk win32 canvas back-end

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

@@ -5,6 +5,7 @@
          "types.rkt"
          "window.rkt"
          "x11.rkt"
+         "win32.rkt"
 	 "../../lock.rkt"
          "../common/backing-dc.rkt"
          racket/draw/cairo
@@ -46,6 +47,32 @@
        (gobject-unref pixmap)
        (set! s #f)))))
 
+(define win32-bitmap%
+  (class bitmap%
+    (init w h gdk-win)
+    (super-make-object (make-alternate-bitmap-kind w h))
+
+    (define s
+      (if gdk-win
+	  (cairo_win32_surface_create_with_dib CAIRO_FORMAT_RGB24 w h)
+	  (atomically
+	   (let ([hdc (GetDC (gdk_win32_drawable_get_handle gdk-win))])
+	     (begin0
+	      (cairo_win32_surface_create_with_ddb hdc
+						   CAIRO_FORMAT_RGB24 w h)
+	      (ReleaseDC hdc))))))
+
+    (define/override (ok?) #t)
+    (define/override (is-color?) #t)
+    (define/override (has-alpha-channel?) #f)
+
+    (define/override (get-cairo-surface) s)
+
+    (define/override (release-bitmap-storage)
+      (atomically
+       (cairo_surface_destroy s)
+       (set! s #f)))))
+
 (define dc%
   (class backing-dc%
     (init [(cnvs canvas)])
@@ -54,11 +81,17 @@
     (super-new)
 
     (define/override (make-backing-bitmap w h [any-bg? #f])
-      (if (and (or any-bg?
-                   (send canvas get-canvas-background))
-               (eq? 'unix (system-type)))
-          (make-object x11-bitmap% w h (widget-window (send canvas get-client-gtk)))
-          (super make-backing-bitmap w h)))
+      (cond
+       [(and (eq? 'unix (system-type))
+	     (or any-bg?
+		 (send canvas get-canvas-background)))
+	(make-object x11-bitmap% w h (widget-window (send canvas get-client-gtk)))]
+       [(and (eq? 'windows (system-type))
+	     (or any-bg?
+		 (send canvas get-canvas-background)))
+	(make-object win32-bitmap% w h (widget-window (send canvas get-client-gtk)))]
+       [else
+	(super make-backing-bitmap w h)]))
 
     (define/override (get-backing-size xb yb)
       (send canvas get-client-size xb yb))

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

@@ -0,0 +1,26 @@
+#lang racket/base
+(require ffi/unsafe
+         ffi/unsafe/define
+         "utils.rkt")
+
+(provide gdk_win32_drawable_get_handle
+	 GetDC
+	 ReleaseDC)
+
+(define user32-lib
+  (cond
+   [(eq? 'windows (system-type))
+    (ffi-lib "user32.dll")]
+   [else #f]))
+
+(define-ffi-definer define-user32 user32-lib)
+
+(define _GdkDrawable _pointer)
+
+(define-gdk gdk_win32_drawable_get_handle (_fun _GdkDrawable -> _pointer)
+  #:make-fail make-not-available)
+
+(define-user32 GetDC (_fun #:abi 'stdcall _pointer -> _pointer)
+  #:make-fail make-not-available)
+(define-user32 ReleaseDC (_fun #:abi 'stdcall _pointer -> _void)
+  #:make-fail make-not-available)

collects/racket/draw/cairo.rkt

@@ -17,11 +17,6 @@
      (ffi-lib "libfontconfig-1")
      (ffi-lib "libcairo-2")]))
 
-(define gdk-lib 
-  (case (system-type)
-    [(unix) (ffi-lib "libgdk-x11-2.0" '("0"))]
-    [else #f]))
-
 (define-ffi-definer define-cairo cairo-lib
   #:provide provide-protected)
 
@@ -76,6 +71,15 @@
   #:make-fail make-not-available
   #:wrap (allocator cairo_surface_destroy))
 
+(define-cairo cairo_win32_surface_create_with_dib 
+  (_fun _int _int _int -> _cairo_surface_t)
+  #:make-fail make-not-available
+  #:wrap (allocator cairo_surface_destroy))
+(define-cairo cairo_win32_surface_create_with_ddb 
+  (_fun _pointer _int _int _int -> _cairo_surface_t)
+  #:make-fail make-not-available
+  #:wrap (allocator cairo_surface_destroy))
+
 (define-cairo cairo_create (_fun _cairo_surface_t -> _cairo_t)
   #:wrap (allocator cairo_destroy))