From 16b34c236a143c7fb3065db28e1b52f1c6012ed2 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 15 Oct 2010 14:24:48 -0600 Subject: [PATCH] gtk: misc fixes --- collects/meta/props | 2 +- collects/mred/private/wx/common/queue.rkt | 1 + collects/mred/private/wx/gtk/frame.rkt | 37 +++++++++++++++++-- collects/mred/private/wx/gtk/procs.rkt | 10 +---- collects/mred/private/wx/gtk/types.rkt | 1 + collects/mred/private/wx/gtk/window.rkt | 1 + collects/mred/private/wx/win32/frame.rkt | 6 +-- collects/mred/private/wx/win32/window.rkt | 2 +- .../scribblings/gui/mouse-event-class.scrbl | 4 +- collects/tests/gracket/{mem.rktl => mem.rkt} | 16 ++++---- 10 files changed, 52 insertions(+), 28 deletions(-) rename collects/tests/gracket/{mem.rktl => mem.rkt} (96%) diff --git a/collects/meta/props b/collects/meta/props index 333ae41972..c349244053 100755 --- a/collects/meta/props +++ b/collects/meta/props @@ -1465,7 +1465,7 @@ path/s is either such a string or a list of them. "collects/tests/gracket/gui.rktl" drdr:command-line (gracket "-f" *) "collects/tests/gracket/item.rkt" drdr:command-line (mzc *) "collects/tests/gracket/loadtest.rktl" drdr:command-line (gracket "-f" *) -"collects/tests/gracket/mem.rktl" drdr:command-line #f +"collects/tests/gracket/mem.rkt" drdr:command-line #f "collects/tests/gracket/paramz.rktl" drdr:command-line (gracket "-f" *) "collects/tests/gracket/png.rktl" drdr:command-line #f "collects/tests/gracket/random.rktl" drdr:command-line #f diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index e99d411a44..1383e84276 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -190,6 +190,7 @@ -> _pointer)) (define (shutdown-eventspace! e ignored) + ;; atomic mode (unless (eventspace-shutdown? e) (set-eventspace-shutdown?! e #t) (semaphore-post (eventspace-done-sema e)) diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index 8b1522cfd7..061e3b4165 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -13,12 +13,14 @@ "window.rkt" "client-window.rkt" "widget.rkt" - "procs.rkt" "cursor.rkt" "pixbuf.rkt" "../common/queue.rkt") -(provide frame%) +(provide frame% + display-origin + display-size + location->window) ;; ---------------------------------------- @@ -121,6 +123,9 @@ (for/fold ([l #f]) ([i (in-list icons)]) (g_list_insert l i -1)))))) +;; used for location->window +(define all-frames (make-hasheq)) + (define frame% (class (client-size-mixin window%) (init parent @@ -296,10 +301,15 @@ (void)) (define/override (direct-show on?) + ;; atomic mode + (if on? + (hash-set! all-frames this #t) + (hash-remove! all-frames this)) (super direct-show on?) (register-frame-shown this on?)) (define/public (destroy) + ;; atomic mode (direct-show #f)) (define/override (on-client-size w h) @@ -366,7 +376,8 @@ (define/public (on-activate on?) (void)) - (def/public-unimplemented designate-root-frame) + (define/public (designate-root-frame) (void)) + (def/public-unimplemented system-menu) (define/public (set-modified mod?) @@ -421,3 +432,23 @@ (string-append s "*") s))))) +;; ---------------------------------------- + +(define-gdk gdk_screen_get_width (_fun _GdkScreen -> _int)) +(define-gdk gdk_screen_get_height (_fun _GdkScreen -> _int)) + +(define (display-origin x y all?) (set-box! x 0) (set-box! y 0)) +(define (display-size w h all?) + (let ([s (gdk_screen_get_default)]) + (set-box! w (gdk_screen_get_width s)) + (set-box! h (gdk_screen_get_height s)))) + +(define (location->window x y) + (for/or ([f (in-hash-keys all-frames)]) + (let ([fx (send f get-x)] + [fw (send f get-width)]) + (and (<= fx x (+ fx fw)) + (let ([fy (send f get-y)] + [fh (send f get-height)]) + (<= fy y (+ fy fh))) + f)))) diff --git a/collects/mred/private/wx/gtk/procs.rkt b/collects/mred/private/wx/gtk/procs.rkt index 7dc0d0ead9..294ec927c8 100644 --- a/collects/mred/private/wx/gtk/procs.rkt +++ b/collects/mred/private/wx/gtk/procs.rkt @@ -11,6 +11,7 @@ "style.rkt" "widget.rkt" "window.rkt" + "frame.rkt" "dc.rkt" "printer-dc.rkt" "gl-context.rkt" @@ -60,7 +61,6 @@ check-for-break) (define-unimplemented find-graphical-system-path) -(define-unimplemented location->window) (define-unimplemented send-event) (define-unimplemented cancel-quit) (define-unimplemented write-resource) @@ -85,14 +85,6 @@ (define (get-control-font-size) 10) ;; FIXME (define (get-control-font-size-in-pixels?) #f) ;; FIXME -(define-gdk gdk_screen_get_width (_fun _GdkScreen -> _int)) -(define-gdk gdk_screen_get_height (_fun _GdkScreen -> _int)) - -(define (display-origin x y all?) (set-box! x 0) (set-box! y 0)) -(define (display-size w h all?) - (let ([s (gdk_screen_get_default)]) - (set-box! w (gdk_screen_get_width s)) - (set-box! h (gdk_screen_get_height s)))) (define (get-display-depth) 32) (define-gdk gdk_display_beep (_fun _GdkDisplay -> _void)) diff --git a/collects/mred/private/wx/gtk/types.rkt b/collects/mred/private/wx/gtk/types.rkt index 8bb4f76120..7d2fd03a2b 100644 --- a/collects/mred/private/wx/gtk/types.rkt +++ b/collects/mred/private/wx/gtk/types.rkt @@ -104,6 +104,7 @@ (define-cstruct _GdkEventCrossing ([type _GdkEventType] [window _GdkWindow] [send_event _byte] + [subwindow _GdkWindow] [time _uint32] [x _double] [y _double] diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index 855fbc2c1c..f68f784a5c 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -478,6 +478,7 @@ (define shown? #f) (define/public (direct-show on?) + ;; atomic mode (if on? (gtk_widget_show gtk) (gtk_widget_hide gtk)) diff --git a/collects/mred/private/wx/win32/frame.rkt b/collects/mred/private/wx/win32/frame.rkt index bb2e852a7e..76c9fc11f4 100644 --- a/collects/mred/private/wx/win32/frame.rkt +++ b/collects/mred/private/wx/win32/frame.rkt @@ -237,8 +237,8 @@ (define/override (get-y) (RECT-top (GetWindowRect hwnd))) - (def/public-unimplemented on-toolbar-click) - (def/public-unimplemented on-menu-click) + (define/public (on-toolbar-click) (void)) + (define/public (on-menu-click) (void)) (define/public (on-menu-command i) (void)) @@ -348,7 +348,7 @@ (define/override (get-top-frame) this) - (def/public-unimplemented designate-root-frame) + (define/public (designate-root-frame) (void)) (def/public-unimplemented system-menu) (define modified? #f) diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index 2de9e475c7..eea9ba4218 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -327,7 +327,7 @@ hwnd (lambda (thunk) (queue-window-event this thunk))))) - (def/public-unimplemented center) + (define/public (center a b) (void)) (define/public (get-parent) parent) (define/public (is-frame?) #f) diff --git a/collects/scribblings/gui/mouse-event-class.scrbl b/collects/scribblings/gui/mouse-event-class.scrbl index 4ba715b867..9c9d2129f3 100644 --- a/collects/scribblings/gui/mouse-event-class.scrbl +++ b/collects/scribblings/gui/mouse-event-class.scrbl @@ -148,7 +148,7 @@ Under Mac OS X, if a control-key press is combined with a mouse button Returns the type of the event; see @scheme[mouse-event%] for information about each event type. See also @method[mouse-event% -set-event-type] . +set-event-type]. } @@ -260,7 +260,7 @@ Under Mac OS X, if a control-key press is combined with a mouse button void?]{ Sets the type of the event; see @scheme[mouse-event%] for information -about each event type. See also @method[mouse-event% get-event-type] . +about each event type. See also @method[mouse-event% get-event-type]. } diff --git a/collects/tests/gracket/mem.rktl b/collects/tests/gracket/mem.rkt similarity index 96% rename from collects/tests/gracket/mem.rktl rename to collects/tests/gracket/mem.rkt index 9255637de5..7e3603eee0 100644 --- a/collects/tests/gracket/mem.rktl +++ b/collects/tests/gracket/mem.rkt @@ -1,5 +1,4 @@ - -; run with gracket -u -- -f mem.rktl +#lang racket/gui (require mzlib/class100) @@ -28,13 +27,12 @@ allocated)) v) -(when subwindows? - (namespace-set-variable-value! - 'sub-collect-frame - (make-object frame% "sub-collect")) - (namespace-set-variable-value! - 'sub-collect-panel - (make-object panel% sub-collect-frame))) +(define sub-collect-frame + (and subwindows? + (make-object frame% "sub-collect"))) +(define sub-collect-panel + (and subwindows? + (make-object panel% sub-collect-frame))) (define permanent-ready? #f) (define mb-lock (make-semaphore 1))