diff --git a/gui-lib/mred/private/wx/gtk/canvas.rkt b/gui-lib/mred/private/wx/gtk/canvas.rkt index d9d05472..07fa9a36 100644 --- a/gui-lib/mred/private/wx/gtk/canvas.rkt +++ b/gui-lib/mred/private/wx/gtk/canvas.rkt @@ -540,9 +540,11 @@ ;; are defined by `canvas-mixin' from ../common/canvas-mixin (define/public (queue-paint) (void)) (define/public (request-canvas-flush-delay) - (request-flush-delay (get-flush-window))) + (unless transparent? + (request-flush-delay (get-flush-window)))) (define/public (cancel-canvas-flush-delay req) - (cancel-flush-delay req)) + (unless transparent? + (cancel-flush-delay req))) (define/public (queue-canvas-refresh-event thunk) (queue-window-refresh-event this thunk)) (define/public (skip-pre-paint?) #f) diff --git a/gui-lib/mred/private/wx/gtk/dc.rkt b/gui-lib/mred/private/wx/gtk/dc.rkt index 872182a5..ab42364e 100644 --- a/gui-lib/mred/private/wx/gtk/dc.rkt +++ b/gui-lib/mred/private/wx/gtk/dc.rkt @@ -51,28 +51,64 @@ [depth _int])) (define-gdk gdk_visual_get_system (_fun -> _GdkVisual-rec-pointer)) -(define x11-bitmap%/gtk2 +(define x11-bitmap% (class bitmap% (init w h gtk) - (super-make-object (make-alternate-bitmap-kind w h (->screen 1.0))) - (define pixmap + (define sf + (if gtk3? + (if gtk + (->screen (gtk_widget_get_scale_factor gtk)) + (display-bitmap-resolution 0 (lambda () 1.0))) + (->screen 1.0))) + (define/private (scale x) + (min (max 1 (ceiling (inexact->exact (* sf x)))) 32000)) + + (define-values (pixmap xdisplay xvisual) (let ([gdk-win (and gtk (widget-window gtk))]) - (gdk_pixmap_new gdk-win - (min (max 1 (->screen w)) 32000) - (min (max 1 (->screen h)) 32000) - (if gdk-win - -1 - (GdkVisual-rec-depth - (gdk_visual_get_system)))))) + (if gtk3? + (let* ([gdk-win (or gdk-win + (gdk_screen_get_root_window + (gdk_screen_get_default)))] + [xdisplay (gdk_x11_display_get_xdisplay + (if gdk-win + (gdk_window_get_display gdk-win) + (gdk_display_get_default)))] + [visual (gdk_window_get_visual gdk-win)]) + (values (XCreatePixmap xdisplay + (gdk_x11_window_get_xid gdk-win) + (scale w) (scale h) + (gdk_visual_get_depth visual)) + xdisplay + (gdk_x11_visual_get_xvisual visual))) + (let ([pixmap (gdk_pixmap_new gdk-win + (scale w) + (scale h) + (if gdk-win + -1 + (GdkVisual-rec-depth + (gdk_visual_get_system))))]) + (values pixmap + (gdk_x11_display_get_xdisplay + (gdk_drawable_get_display pixmap)) + (gdk_x11_visual_get_xvisual + (gdk_drawable_get_visual pixmap))))))) + (define s - (cairo_xlib_surface_create (gdk_x11_display_get_xdisplay - (gdk_drawable_get_display pixmap)) - (gdk_x11_drawable_get_xid pixmap) - (gdk_x11_visual_get_xvisual - (gdk_drawable_get_visual pixmap)) - (->screen w) - (->screen h))) + (cairo_xlib_surface_create xdisplay + (if gtk3? + (cast pixmap _Pixmap _ulong) + (gdk_x11_drawable_get_xid pixmap)) + xvisual + (scale w) + (scale h))) + + (define gl #f) + + (super-make-object (make-alternate-bitmap-kind + w + h + sf)) ;; initialize bitmap to white: (let ([cr (cairo_create s)]) @@ -85,7 +121,6 @@ (define/public (get-gdk-pixmap) pixmap) (define/public (install-gl-context new-gl) (set! gl new-gl)) - (define gl #f) (define/override (get-bitmap-gl-context) gl) (define/override (ok?) #t) @@ -97,20 +132,20 @@ (define/override (release-bitmap-storage) (atomically (cairo_surface_destroy s) - (gobject-unref pixmap) + (if gtk3? + (XFreePixmap xdisplay pixmap) + (gobject-unref pixmap)) (set! s #f))))) -(define x11-bitmap%/gtk3 +(define cairo-bitmap% (class bitmap% (init w h gtk) - (super-make-object w h #f #t (if gtk - (->screen (gtk_widget_get_scale_factor gtk)) - (display-bitmap-resolution 0 (lambda () 1.0)))))) - -(define x11-bitmap% - (if gtk3? - x11-bitmap%/gtk3 - x11-bitmap%/gtk2)) + (super-make-object w h #f #t + (if gtk3? + (if gtk + (->screen (gtk_widget_get_scale_factor gtk)) + (display-bitmap-resolution 0 (lambda () 1.0))) + (->screen 1.0))))) (define win32-bitmap% (class bitmap% @@ -144,10 +179,11 @@ transparent?) (inherit end-delay) (define canvas cnvs) + (define gl #f) + (define can-delay? (not (and gtk3? transparent?))) (super-new [transparent? transparent?]) - (define gl #f) (define/override (get-gl-context) (or gl (let ([v (create-widget-gl-context (send canvas get-client-gtk))]) @@ -157,13 +193,14 @@ (define/override (make-backing-bitmap w h) (cond [(and (eq? 'unix (system-type)) - (or gtk3? (send canvas get-canvas-background))) + (send canvas get-canvas-background)) (make-object x11-bitmap% w h (send canvas get-client-gtk))] [(and (eq? 'windows (system-type)) (send canvas get-canvas-background)) (make-object win32-bitmap% w h (widget-window (send canvas get-client-gtk)))] [else - (super make-backing-bitmap (max 1 w) (max 1 h))])) + ;; Transparent canvas always use a Cairo bitmap: + (make-object cairo-bitmap% (max 1 w) (max 1 h) (send canvas get-client-gtk))])) (define/override (get-backing-size xb yb) (send canvas get-client-size xb yb)) @@ -184,9 +221,12 @@ (send canvas flush)) (define/override (request-delay) - (request-flush-delay (send canvas get-flush-window))) + (if can-delay? + (request-flush-delay (send canvas get-flush-window)) + (void))) (define/override (cancel-delay req) - (cancel-flush-delay req)))) + (when can-delay? + (cancel-flush-delay req))))) (define (do-backing-flush canvas dc win-or-cr) (send dc on-backing-flush diff --git a/gui-lib/mred/private/wx/gtk/gcwin.rkt b/gui-lib/mred/private/wx/gtk/gcwin.rkt index ce3a9098..421d4f3c 100644 --- a/gui-lib/mred/private/wx/gtk/gcwin.rkt +++ b/gui-lib/mred/private/wx/gtk/gcwin.rkt @@ -69,12 +69,6 @@ (define-x11 XMapRaised _fpointer #:fail (lambda () #f)) (define-x11 XUnmapWindow _fpointer #:fail (lambda () #f)) -(define _GdkVisual (_cpointer 'GdkVisual)) -(define-gdk gdk_window_get_visual (_fun _GdkWindow -> _GdkVisual) - #:make-fail make-not-available) -(define-gdk gdk_visual_get_depth (_fun _GdkVisual -> _int) - #:make-fail make-not-available) - (define (bitmap->gc-bitmap bm client-gtk) (cond [gtk3? diff --git a/gui-lib/mred/private/wx/gtk/gl-context.rkt b/gui-lib/mred/private/wx/gtk/gl-context.rkt index 481c6b76..d9539655 100644 --- a/gui-lib/mred/private/wx/gtk/gl-context.rkt +++ b/gui-lib/mred/private/wx/gtk/gl-context.rkt @@ -81,8 +81,7 @@ #:wrap (deallocator)) (define-x11 XSetErrorHandler - (_fun (_fun _Display _XErrorEvent -> _int) - -> (_fun _Display _XErrorEvent -> _int))) + (_fun _fpointer -> _fpointer)) (define-x11 XSync (_fun _Display _int -> _void)) @@ -242,12 +241,15 @@ ;; Sync right now, or the sync further on could crash Racket with an [xcb] error about events ;; happening out of sequence (XSync xdisplay False) - + (define old-handler #f) (define gl (dynamic-wind (λ () - (set! old-handler (XSetErrorHandler flag-x-error-handler))) + (set! old-handler + (XSetErrorHandler (cast flag-x-error-handler + (_fun #:atomic? #t _Display _XErrorEvent -> _int) + _fpointer)))) (λ () (set! create-context-error? #f) (glXCreateNewContext xdisplay cfg GLX_RGBA_TYPE share-gl #t)) @@ -255,11 +257,12 @@ ;; Sync to ensure errors are processed (XSync xdisplay False) (XSetErrorHandler old-handler)))) - + (cond [(and gl create-context-error?) - (log-error "gl-context: glXCreateNewContext raised an error but (contrary to standards) \ -returned a non-NULL context; ignoring possibly corrupt context") + (log-error (string-append + "gl-context: glXCreateNewContext raised an error but (contrary to standards)" + " returned a non-NULL context; ignoring possibly corrupt context")) #f] [else (unless gl @@ -298,8 +301,10 @@ returned a non-NULL context; ignoring possibly corrupt context") (cond [(and gl create-context-error?) - (log-error "gl-context: glXCreateContextAttribsARB raised an error for version ~a.~a but \ -(contrary to standards) returned a non-NULL context; ignoring possibly corrupt context" + (log-error (string-append + "gl-context: glXCreateContextAttribsARB raised an error for version ~a.~a but" + " (contrary to standards) returned a non-NULL context;" + " ignoring possibly corrupt context") gl-major gl-minor) #f] [else @@ -423,12 +428,14 @@ returned a non-NULL context; ignoring possibly corrupt context") (define pixmap (if widget #f (glXCreateGLXPixmap xdisplay (glXGetVisualFromFBConfig xdisplay cfg) - (gdk_x11_drawable_get_xid drawable)))) + (if gtk3? + (cast drawable _Pixmap _ulong) + (gdk_x11_drawable_get_xid drawable))))) (define ctxt (new gl-context% [gl gl] [display display] [drawable drawable] [pixmap pixmap])) ;; Refcount these so they don't go away until the finalizer below destroys the GLXContext (g_object_ref display) - (g_object_ref drawable) + (unless (and gtk3? (not widget)) (g_object_ref drawable)) (register-finalizer ctxt (λ (ctxt) @@ -439,15 +446,14 @@ returned a non-NULL context; ignoring possibly corrupt context") (define xdisplay (gdk_x11_display_get_xdisplay display)) (when pixmap (glXDestroyGLXPixmap xdisplay pixmap)) (glXDestroyContext xdisplay gl) - (g_object_unref drawable) + (unless (and gtk3? (not widget)) (g_object_unref drawable)) (g_object_unref display))) ctxt] [else #f])])) (define (make-gtk-widget-gl-context widget conf) (atomically - (make-gtk-drawable-gl-context widget (widget-window widget) conf -#t))) + (make-gtk-drawable-gl-context widget (widget-window widget) conf #t))) (define (make-gtk-pixmap-gl-context pixmap conf) (atomically diff --git a/gui-lib/mred/private/wx/gtk/window.rkt b/gui-lib/mred/private/wx/gtk/window.rkt index dd6f3c3c..30507389 100644 --- a/gui-lib/mred/private/wx/gtk/window.rkt +++ b/gui-lib/mred/private/wx/gtk/window.rkt @@ -864,12 +864,11 @@ (lambda (win-box) (let ([win (mcar win-box)]) (and win - (unless gtk3? - ;; The freeze/thaw state is actually with the window's - ;; implementation, so force a native implementation of the - ;; window to try to avoid it changing out from underneath - ;; us between the freeze and thaw actions. - (gdk_window_ensure_native win)) + ;; The freeze/thaw state is actually with the window's + ;; implementation, so force a native implementation of the + ;; window to try to avoid it changing out from underneath + ;; us between the freeze and thaw actions. + (gdk_window_ensure_native win) (begin (gdk_window_freeze_updates win) (set-mcdr! win-box (add1 (mcdr win-box))) diff --git a/gui-lib/mred/private/wx/gtk/x11.rkt b/gui-lib/mred/private/wx/gtk/x11.rkt index 2d4d44ab..45eceee6 100644 --- a/gui-lib/mred/private/wx/gtk/x11.rkt +++ b/gui-lib/mred/private/wx/gtk/x11.rkt @@ -10,7 +10,11 @@ gdk_pixmap_new gdk_window_get_display gdk_drawable_get_display + gdk_window_get_visual gdk_drawable_get_visual + gdk_visual_get_best + gdk_screen_get_root_window + gdk_visual_get_depth gdk_x11_drawable_get_xid gdk_x11_display_get_xdisplay gdk_x11_visual_get_xvisual @@ -21,6 +25,7 @@ _Window _Pixmap XCreatePixmap + XFreePixmap XCreateSimpleWindow XDestroyWindow)) @@ -55,6 +60,16 @@ (define-gdk gdk_drawable_get_visual (_fun _GdkDrawable -> _GdkVisual) #:make-fail make-not-available) +(define-gdk gdk_visual_get_best (_fun -> _GdkVisual) + #:make-fail make-not-available) + +(define-gdk gdk_window_get_visual (_fun _GdkWindow -> _GdkVisual) + #:make-fail make-not-available) +(define-gdk gdk_visual_get_depth (_fun _GdkVisual -> _int) + #:make-fail make-not-available) + +(define-gdk gdk_screen_get_root_window (_fun _GdkScreen -> _GdkWindow)) + (define-gtk gdk_x11_window_get_xid (_fun _GdkWindow -> _Window) #:make-fail make-not-available) (define-gdk gdk_x11_drawable_get_xid (_fun _GdkDrawable -> _Drawable) @@ -73,13 +88,13 @@ (define-gdk gdk_x11_screen_get_screen_number (_fun _GdkScreen -> _int) #:make-fail make-not-available) -(define-x11 XFreePixmap (_fun _Display _Pixmap -> _void)) +(define-x11 XFreePixmap (_fun _Display _Pixmap -> _void) + #:wrap (deallocator cadr)) (define-x11 XCreatePixmap (_fun _Display _Window _int _int _int -> _Pixmap) #:wrap (lambda (proc) (lambda (dpy win w h d) - (((allocator ((deallocator) - (lambda (pixmap) - (XFreePixmap dpy pixmap)))) + (((allocator (lambda (pixmap) + (XFreePixmap dpy pixmap))) (lambda () (proc dpy win w h d))))))) (define-x11 XDestroyWindow (_fun _Display _Window -> _void)