suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

finish pinning down gtk allocation

Browse Source 
original commit: 43aeaacd7a598f834002b75b1ee72f4b7cd04b85
This commit is contained in:
Matthew Flatt 2010-08-16 08:31:32 -06:00
parent 1752204327
commit a4305ae6a2
14 changed files with 246 additions and 172 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
collects/mred/private/wx/cocoa/README.txt Normal file
View File

@ -0,0 +1,15 @@
Allocation rules:
* Use `as-objc-allocation' when creating a Cocoa object. When the
resulting reference becomes unreachable, the Cocoa object will be
releaset.
* Use `with-autorelease' in atomic mode around calls that autorelease
and where the release should take effect immediate. Do not create
an autorelease pool except in atomic mode.
* Other autoreleased objects may end up in the root pool installed by
"pool.rkt". The root pool is periodically destroyed and replaced;
call `queue-autorelease-flush' if you need to encurage replacement
of the pool.

17
collects/mred/private/wx/gtk/README.txt Normal file
View File

@ -0,0 +1,17 @@
Allocation rules:
* Use `as-gtk-allocation' when creating a Gtk widget that is the main
container for a given window<%> object. When the resulting
reference becomes unreachable, the widget will be released with
gtk_widget_destroy() through a finalizer.
* Use `atomically' to create and attach a sub-widget within the main
widget. Don't use gtk_widget_destroy(); the containing widget will
destroy the enclosing widget.
* For temporary objects, use `atomically' to wrap both the allocation
and release.
Every call to a function whose name contains "new" needs to be in one
of those cases.

122
collects/mred/private/wx/gtk/canvas.rkt
View File

@ -135,7 +135,8 @@
(let ([gc (send wx get-canvas-background-for-clearing)]) (let ([gc (send wx get-canvas-background-for-clearing)])
(when gc (when gc
(gdk_draw_rectangle (widget-window gtk) gc #t (gdk_draw_rectangle (widget-window gtk) gc #t
0 0 32000 32000)))))) 0 0 32000 32000)
(gdk_gc_unref gc))))))
#t)) #t))
(define-signal-handler connect-expose-border "expose-event" (define-signal-handler connect-expose-border "expose-event"
@ -197,61 +198,62 @@
(define-values (client-gtk gtk (define-values (client-gtk gtk
hscroll-adj vscroll-adj hscroll-gtk vscroll-gtk resize-box hscroll-adj vscroll-adj hscroll-gtk vscroll-gtk resize-box
combo-button-gtk) combo-button-gtk)
(cond (atomically ;; need to connect all children to gtk to avoid leaks
[(or (memq 'hscroll style) (cond
(memq 'vscroll style)) [(or (memq 'hscroll style)
(let* ([client-gtk (gtk_drawing_area_new)] (memq 'vscroll style))
[hadj (gtk_adjustment_new 0.0 0.0 1.0 1.0 1.0 1.0)] (let* ([client-gtk (gtk_drawing_area_new)]
[vadj (gtk_adjustment_new 0.0 0.0 1.0 1.0 1.0 1.0)]) [hadj (gtk_adjustment_new 0.0 0.0 1.0 1.0 1.0 1.0)]
(let ([h (gtk_hbox_new #f 0)] [vadj (gtk_adjustment_new 0.0 0.0 1.0 1.0 1.0 1.0)])
[v (gtk_vbox_new #f 0)] (let ([h (as-gtk-allocation (gtk_hbox_new #f 0))]
[v2 (gtk_vbox_new #f 0)] [v (gtk_vbox_new #f 0)]
[h2 (gtk_vbox_new #f 0)] [v2 (gtk_vbox_new #f 0)]
[hscroll (gtk_hscrollbar_new hadj)] [h2 (gtk_vbox_new #f 0)]
[vscroll (gtk_vscrollbar_new vadj)] [hscroll (gtk_hscrollbar_new hadj)]
[resize-box (gtk_drawing_area_new)]) [vscroll (gtk_vscrollbar_new vadj)]
(when has-border? [resize-box (gtk_drawing_area_new)])
(gtk_container_set_border_width h margin)) (when has-border?
(gtk_box_pack_start h v #t #t 0) (gtk_container_set_border_width h margin))
(gtk_box_pack_start v client-gtk #t #t 0) (gtk_box_pack_start h v #t #t 0)
(gtk_box_pack_start h v2 #f #f 0) (gtk_box_pack_start v client-gtk #t #t 0)
(gtk_box_pack_start v2 vscroll #t #t 0) (gtk_box_pack_start h v2 #f #f 0)
(gtk_box_pack_start v h2 #f #f 0) (gtk_box_pack_start v2 vscroll #t #t 0)
(gtk_box_pack_start h2 hscroll #t #t 0) (gtk_box_pack_start v h2 #f #f 0)
(gtk_box_pack_start v2 resize-box #f #f 0) (gtk_box_pack_start h2 hscroll #t #t 0)
(gtk_widget_show hscroll) (gtk_box_pack_start v2 resize-box #f #f 0)
(gtk_widget_show vscroll) (gtk_widget_show hscroll)
(gtk_widget_show h) (gtk_widget_show vscroll)
(gtk_widget_show v) (gtk_widget_show h)
(gtk_widget_show v2) (gtk_widget_show v)
(gtk_widget_show h2) (gtk_widget_show v2)
(gtk_widget_show resize-box) (gtk_widget_show h2)
(gtk_widget_show client-gtk) (gtk_widget_show resize-box)
(unless (memq 'hscroll style) (gtk_widget_show client-gtk)
(gtk_widget_hide hscroll) (unless (memq 'hscroll style)
(gtk_widget_hide resize-box)) (gtk_widget_hide hscroll)
(unless (memq 'vscroll style) (gtk_widget_hide resize-box))
(gtk_widget_hide v2)) (unless (memq 'vscroll style)
(values client-gtk h hadj vadj (gtk_widget_hide v2))
(and (memq 'hscroll style) h2) (values client-gtk h hadj vadj
(and (memq 'vscroll style) v2) (and (memq 'hscroll style) h2)
(and (memq 'hscroll style) (memq 'vscroll style) resize-box) (and (memq 'vscroll style) v2)
#f)))] (and (memq 'hscroll style) (memq 'vscroll style) resize-box)
[is-combo? #f)))]
(let* ([gtk (gtk_combo_box_entry_new_text)] [is-combo?
[orig-entry (gtk_bin_get_child gtk)]) (let* ([gtk (as-gtk-allocation (gtk_combo_box_entry_new_text))]
(values orig-entry gtk #f #f #f #f #f (extract-combo-button gtk)))] [orig-entry (gtk_bin_get_child gtk)])
[has-border? (values orig-entry gtk #f #f #f #f #f (extract-combo-button gtk)))]
(let ([client-gtk (gtk_drawing_area_new)] [has-border?
[h (gtk_hbox_new #f 0)]) (let ([client-gtk (gtk_drawing_area_new)]
(gtk_box_pack_start h client-gtk #t #t 0) [h (as-gtk-allocation (gtk_hbox_new #f 0))])
(gtk_container_set_border_width h margin) (gtk_box_pack_start h client-gtk #t #t 0)
(connect-expose-border h) (gtk_container_set_border_width h margin)
(gtk_widget_show client-gtk) (connect-expose-border h)
(values client-gtk h #f #f #f #f #f #f))] (gtk_widget_show client-gtk)
[else (values client-gtk h #f #f #f #f #f #f))]
(let ([client-gtk (gtk_drawing_area_new)]) [else
(values client-gtk client-gtk #f #f #f #f #f #f))])) (let ([client-gtk (as-gtk-allocation (gtk_drawing_area_new))])
(values client-gtk client-gtk #f #f #f #f #f #f))])))
(super-new [parent parent] (super-new [parent parent]
[gtk gtk] [gtk gtk]
@ -481,15 +483,15 @@
bg-col)) bg-col))
(define/public (set-canvas-background col) (set! bg-col col)) (define/public (set-canvas-background col) (set! bg-col col))
(define/public (get-canvas-background-for-clearing) (define/public (get-canvas-background-for-clearing)
;; called in event-dispatch mode
(if now-drawing? (if now-drawing?
(begin (begin
(set! refresh-after-drawing? #t) (set! refresh-after-drawing? #t)
#f) #f)
(if clear-bg? (if clear-bg?
(let ([conv (lambda (x) (bitwise-ior x (arithmetic-shift x 8)))]) (let* ([conv (lambda (x) (bitwise-ior x (arithmetic-shift x 8)))]
(unless gc [w (widget-window gtk)]
(let ([w (widget-window gtk)]) [gc (gdk_gc_new w)])
(set! gc (gdk_gc_new w))))
(gdk_gc_set_rgb_fg_color gc (make-GdkColor 0 (gdk_gc_set_rgb_fg_color gc (make-GdkColor 0
(conv (color-red bg-col)) (conv (color-red bg-col))
(conv (color-green bg-col)) (conv (color-green bg-col))

2
collects/mred/private/wx/gtk/choice.rkt
View File

@ -35,7 +35,7 @@
choices style font) choices style font)
(inherit get-gtk set-auto-size) (inherit get-gtk set-auto-size)
(define gtk (gtk_combo_box_new_text)) (define gtk (as-gtk-allocation (gtk_combo_box_new_text)))
(define count (length choices)) (define count (length choices))
(for ([l (in-list choices)]) (for ([l (in-list choices)])

8
collects/mred/private/wx/gtk/gauge.rkt
View File

@ -15,6 +15,9 @@
(define-gtk gtk_progress_bar_new (_fun _pointer -> _GtkWidget)) (define-gtk gtk_progress_bar_new (_fun _pointer -> _GtkWidget))
(define-gtk gtk_progress_bar_set_fraction (_fun _GtkWidget _double* -> _void)) (define-gtk gtk_progress_bar_set_fraction (_fun _GtkWidget _double* -> _void))
(define-gtk gtk_progress_bar_set_orientation (_fun _GtkWidget _int -> _void))
(define GTK_PROGRESS_BOTTOM_TO_TOP 2)
(defclass gauge% item% (defclass gauge% item%
(init parent (init parent
@ -26,10 +29,13 @@
(inherit get-gtk set-auto-size) (inherit get-gtk set-auto-size)
(super-new [parent parent] (super-new [parent parent]
[gtk (gtk_progress_bar_new #f)] [gtk (as-gtk-allocation (gtk_progress_bar_new #f))]
[no-show? (memq 'deleted style)]) [no-show? (memq 'deleted style)])
(define gtk (get-gtk)) (define gtk (get-gtk))
(when (memq 'vertical style)
(gtk_progress_bar_set_orientation gtk GTK_PROGRESS_BOTTOM_TO_TOP))
(set-auto-size) (set-auto-size)
(define range rng) (define range rng)

9
collects/mred/private/wx/gtk/group-panel.rkt
View File

@ -2,6 +2,7 @@
(require scheme/class (require scheme/class
scheme/foreign scheme/foreign
"../../syntax.rkt" "../../syntax.rkt"
"../../lock.rkt"
"window.rkt" "window.rkt"
"client-window.rkt" "client-window.rkt"
"panel.rkt" "panel.rkt"
@ -29,9 +30,11 @@
(inherit set-size set-auto-size infer-client-delta (inherit set-size set-auto-size infer-client-delta
get-gtk get-height) get-gtk get-height)
(define gtk (gtk_frame_new label)) (define gtk (as-gtk-allocation (gtk_frame_new label)))
(define client-gtk (gtk_fixed_new)) (define client-gtk
(gtk_container_add gtk client-gtk) (atomically (let ([client-gtk (gtk_fixed_new)])
(gtk_container_add gtk client-gtk)
client-gtk)))
(gtk_widget_show client-gtk) (gtk_widget_show client-gtk)
(super-new [parent parent] (super-new [parent parent]

57
collects/mred/private/wx/gtk/list-box.rkt
View File

@ -75,7 +75,7 @@
(define items choices) (define items choices)
(define data (map (lambda (c) (box #f)) choices)) (define data (map (lambda (c) (box #f)) choices))
(define store (gtk_list_store_new 1 G_TYPE_STRING)) (define store (as-gobject-allocation (gtk_list_store_new 1 G_TYPE_STRING)))
(define (reset-content) (define (reset-content)
(let ([iter (make-GtkTreeIter 0 #f #f #f)]) (let ([iter (make-GtkTreeIter 0 #f #f #f)])
(for ([s (in-list items)]) (for ([s (in-list items)])
@ -88,23 +88,23 @@
(pair? data)) (pair? data))
(set-selection 0))) (set-selection 0)))
(define column (define gtk (as-gtk-allocation (gtk_scrolled_window_new #f #f)))
(let ([renderer (gtk_cell_renderer_text_new)])
(gtk_tree_view_column_new_with_attributes
"column"
renderer
"text"
0
#f)))
(define gtk (gtk_scrolled_window_new #f #f))
(gtk_scrolled_window_set_policy gtk GTK_POLICY_NEVER GTK_POLICY_ALWAYS) (gtk_scrolled_window_set_policy gtk GTK_POLICY_NEVER GTK_POLICY_ALWAYS)
(define client-gtk (define client-gtk
(let* ([client-gtk (gtk_tree_view_new_with_model store)]) (atomically
(gtk_tree_view_set_headers_visible client-gtk #f) (let* ([client-gtk (gtk_tree_view_new_with_model store)]
(gtk_tree_view_append_column client-gtk column) [column (let ([renderer (gtk_cell_renderer_text_new)])
client-gtk)) (gtk_tree_view_column_new_with_attributes
"column"
renderer
"text"
0
#f))])
(gobject-unref store)
(gtk_tree_view_set_headers_visible client-gtk #f)
(gtk_tree_view_append_column client-gtk column)
client-gtk)))
(gtk_container_add gtk client-gtk) (gtk_container_add gtk client-gtk)
(gtk_widget_show client-gtk) (gtk_widget_show client-gtk)
@ -139,11 +139,12 @@
[time-stamp (current-milliseconds)]))))))) [time-stamp (current-milliseconds)])))))))
(define/private (get-iter i) (define/private (get-iter i)
(let ([iter (make-GtkTreeIter 0 #f #f #f)] (atomically
[p (gtk_tree_path_new_from_indices i -1)]) (let ([iter (make-GtkTreeIter 0 #f #f #f)]
(gtk_tree_model_get_iter store iter p) [p (gtk_tree_path_new_from_indices i -1)])
(gtk_tree_path_free p) (gtk_tree_model_get_iter store iter p)
iter)) (gtk_tree_path_free p)
iter)))
(def/public-unimplemented get-label-font) (def/public-unimplemented get-label-font)
@ -155,9 +156,10 @@
(gtk_list_store_set store (get-iter i) 0 s -1)) (gtk_list_store_set store (get-iter i) 0 s -1))
(define/public (set-first-visible-item i) (define/public (set-first-visible-item i)
(let ([p (gtk_tree_path_new_from_indices i -1)]) (atomically
(gtk_tree_view_scroll_to_cell client-gtk p #f #t 0.0 0.0) (let ([p (gtk_tree_path_new_from_indices i -1)])
(gtk_tree_path_free p))) (gtk_tree_view_scroll_to_cell client-gtk p #f #t 0.0 0.0)
(gtk_tree_path_free p))))
(define/public (set choices) (define/public (set choices)
(atomically (atomically
@ -210,10 +212,11 @@
(define/public (get-data i) (unbox (list-ref data i))) (define/public (get-data i) (unbox (list-ref data i)))
(define/public (selected? i) (define/public (selected? i)
(let ([p (gtk_tree_path_new_from_indices i -1)]) (atomically
(begin0 (let ([p (gtk_tree_path_new_from_indices i -1)])
(gtk_tree_selection_path_is_selected selection p) (begin0
(gtk_tree_path_free p)))) (gtk_tree_selection_path_is_selected selection p)
(gtk_tree_path_free p)))))
(define/public (select i [on? #t] [extend? #t]) (define/public (select i [on? #t] [extend? #t])
(atomically (atomically

41
collects/mred/private/wx/gtk/menu-bar.rkt
View File

@ -2,6 +2,7 @@
(require scheme/class (require scheme/class
scheme/foreign scheme/foreign
"../../syntax.rkt" "../../syntax.rkt"
"../../lock.rkt"
"../common/freeze.rkt" "../common/freeze.rkt"
"../common/queue.rkt" "../common/queue.rkt"
"widget.rkt" "widget.rkt"
@ -73,7 +74,7 @@
(define menus null) (define menus null)
(define gtk (gtk_menu_bar_new)) (define gtk (as-gtk-allocation (gtk_menu_bar_new)))
(super-new [gtk gtk]) (super-new [gtk gtk])
(define/public (get-gtk) gtk) (define/public (get-gtk) gtk)
@ -88,15 +89,16 @@
(install-widget-parent top) (install-widget-parent top)
;; return initial size; also, add a menu to make sure there is one, ;; return initial size; also, add a menu to make sure there is one,
;; and force the menu bar to be at least that tall always ;; and force the menu bar to be at least that tall always
(let ([item (gtk_menu_item_new_with_mnemonic "Xyz")]) (atomically
(gtk_menu_shell_append gtk item) (let ([item (gtk_menu_item_new_with_mnemonic "Xyz")])
(gtk_widget_show item) (gtk_menu_shell_append gtk item)
(begin0 (gtk_widget_show item)
(let ([req (make-GtkRequisition 0 0)]) (begin0
(gtk_widget_size_request gtk req) (let ([req (make-GtkRequisition 0 0)])
(gtk_widget_set_usize gtk -1 (GtkRequisition-height req)) (gtk_widget_size_request gtk req)
(GtkRequisition-height req)) (gtk_widget_set_usize gtk -1 (GtkRequisition-height req))
(gtk_container_remove gtk item)))) (GtkRequisition-height req))
(gtk_container_remove gtk item)))))
(define/public (get-top-window) (define/public (get-top-window)
top-wx) top-wx)
@ -129,12 +131,13 @@
(public [append-menu append]) (public [append-menu append])
(define (append-menu menu title) (define (append-menu menu title)
(send menu set-parent this) (send menu set-parent this)
(let* ([item (gtk_menu_item_new_with_mnemonic (fixup-mneumonic title))] (atomically
[item-wx (new top-menu% [parent this] [gtk item])]) (let* ([item (gtk_menu_item_new_with_mnemonic (fixup-mneumonic title))]
(connect-select item) [item-wx (new top-menu% [parent this] [gtk item])])
(set! menus (append menus (list (list item menu item-wx)))) (connect-select item)
(let ([gtk (send menu get-gtk)]) (set! menus (append menus (list (list item menu item-wx))))
(g_object_ref gtk) (let ([gtk (send menu get-gtk)])
(gtk_menu_item_set_submenu item gtk)) (g_object_ref gtk)
(gtk_menu_shell_append gtk item) (gtk_menu_item_set_submenu item gtk))
(gtk_widget_show item)))) (gtk_menu_shell_append gtk item)
(gtk_widget_show item)))))

57
collects/mred/private/wx/gtk/menu.rkt
View File

@ -4,6 +4,7 @@
"widget.rkt" "widget.rkt"
"window.rkt" "window.rkt"
"../../syntax.rkt" "../../syntax.rkt"
"../../lock.rkt"
"types.rkt" "types.rkt"
"const.rkt" "const.rkt"
"utils.rkt" "utils.rkt"
@ -80,7 +81,7 @@
(define cb callback) (define cb callback)
(define gtk (gtk_menu_new)) (define gtk (as-gtk-allocation (gtk_menu_new)))
(define/public (get-gtk) gtk) (define/public (get-gtk) gtk)
(super-new [gtk gtk]) (super-new [gtk gtk])
@ -175,34 +176,36 @@
(public [append-item append]) (public [append-item append])
(define (append-item i label help-str-or-submenu chckable?) (define (append-item i label help-str-or-submenu chckable?)
(let ([item-gtk ((if chckable? (atomically
gtk_check_menu_item_new_with_mnemonic (let ([item-gtk ((if chckable?
gtk_menu_item_new_with_mnemonic) gtk_check_menu_item_new_with_mnemonic
(fixup-mneumonic label))]) gtk_menu_item_new_with_mnemonic)
(if (help-str-or-submenu . is-a? . menu%) (fixup-mneumonic label))])
(let ([submenu help-str-or-submenu]) (if (help-str-or-submenu . is-a? . menu%)
(let ([gtk (send submenu get-gtk)]) (let ([submenu help-str-or-submenu])
(g_object_ref gtk) (let ([gtk (send submenu get-gtk)])
(gtk_menu_item_set_submenu item-gtk gtk) (g_object_ref gtk)
(send submenu set-parent this) (gtk_menu_item_set_submenu item-gtk gtk)
(send submenu set-self-item i (send submenu set-parent this)
(lambda () (gtk_menu_item_set_submenu item-gtk #f))) (send submenu set-self-item i
(set! items (append items (list (list submenu item-gtk label chckable?)))))) (lambda () (gtk_menu_item_set_submenu item-gtk #f)))
(let ([item (new menu-item-handler% (set! items (append items (list (list submenu item-gtk label chckable?))))))
[gtk item-gtk] (let ([item (new menu-item-handler%
[menu this] [gtk item-gtk]
[menu-item i] [menu this]
[parent this])]) [menu-item i]
(set! items (append items (list (list item item-gtk label chckable?)))) [parent this])])
(adjust-shortcut item-gtk label))) (set! items (append items (list (list item item-gtk label chckable?))))
(gtk_menu_shell_append gtk item-gtk) (adjust-shortcut item-gtk label)))
(gtk_widget_show item-gtk))) (gtk_menu_shell_append gtk item-gtk)
(gtk_widget_show item-gtk))))
(define/public (append-separator) (define/public (append-separator)
(let ([item-gtk (gtk_separator_menu_item_new)]) (atomically
(set! items (append items (list (list (new separator-item-handler%) item-gtk #f #f)))) (let ([item-gtk (gtk_separator_menu_item_new)])
(gtk_menu_shell_append gtk item-gtk) (set! items (append items (list (list (new separator-item-handler%) item-gtk #f #f))))
(gtk_widget_show item-gtk))) (gtk_menu_shell_append gtk item-gtk)
(gtk_widget_show item-gtk))))
(def/public-unimplemented select) (def/public-unimplemented select)
(def/public-unimplemented get-font) (def/public-unimplemented get-font)

2
collects/mred/private/wx/gtk/panel.rkt
View File

@ -57,7 +57,7 @@
(inherit set-size get-gtk) (inherit set-size get-gtk)
(super-new [parent parent] (super-new [parent parent]
[gtk (gtk_fixed_new)] ; (gtk_alignment_new 0.0 0.0 1.0 1.0)] [gtk (as-gtk-allocation (gtk_fixed_new))]
[no-show? (memq 'deleted style)]) [no-show? (memq 'deleted style)])
(define gtk (get-gtk)) (define gtk (get-gtk))

45
collects/mred/private/wx/gtk/radio-box.rkt
View File

@ -44,26 +44,28 @@
(inherit set-auto-size (inherit set-auto-size
on-set-focus) on-set-focus)
(define gtk (if (memq 'horizontal style) (define gtk (as-gtk-allocation
(gtk_hbox_new #f 0) (if (memq 'horizontal style)
(gtk_vbox_new #f 0))) (gtk_hbox_new #f 0)
(gtk_vbox_new #f 0))))
(define radio-gtks (for/list ([lbl (in-list labels)]) (define radio-gtks (for/list ([lbl (in-list labels)])
(let ([radio-gtk (cond (atomically
[(string? lbl) (let ([radio-gtk (cond
(gtk_radio_button_new_with_mnemonic #f (mnemonic-string lbl))] [(string? lbl)
[(send lbl ok?) (gtk_radio_button_new_with_mnemonic #f (mnemonic-string lbl))]
(let ([pixbuf (bitmap->pixbuf lbl)]) [(send lbl ok?)
(let ([radio-gtk (gtk_radio_button_new #f)] (let ([pixbuf (bitmap->pixbuf lbl)])
[image-gtk (gtk_image_new_from_pixbuf pixbuf)]) (let ([radio-gtk (gtk_radio_button_new #f)]
(release-pixbuf pixbuf) [image-gtk (gtk_image_new_from_pixbuf pixbuf)])
(gtk_container_add radio-gtk image-gtk) (release-pixbuf pixbuf)
(gtk_widget_show image-gtk) (gtk_container_add radio-gtk image-gtk)
radio-gtk))] (gtk_widget_show image-gtk)
[else radio-gtk))]
(gtk_radio_button_new_with_mnemonic #f "<bad bitmap>")])]) [else
(gtk_box_pack_start gtk radio-gtk #t #t 0) (gtk_radio_button_new_with_mnemonic #f "<bad bitmap>")])])
(gtk_widget_show radio-gtk) (gtk_box_pack_start gtk radio-gtk #t #t 0)
radio-gtk))) (gtk_widget_show radio-gtk)
radio-gtk))))
(for ([radio-gtk (in-list (cdr radio-gtks))]) (for ([radio-gtk (in-list (cdr radio-gtks))])
(let ([g (gtk_radio_button_get_group (car radio-gtks))]) (let ([g (gtk_radio_button_get_group (car radio-gtks))])
(gtk_radio_button_set_group radio-gtk g))) (gtk_radio_button_set_group radio-gtk g)))
@ -108,8 +110,9 @@
(if (= i -1) (if (= i -1)
(when (pair? radio-gtks) (when (pair? radio-gtks)
(unless dummy-gtk (unless dummy-gtk
(set! dummy-gtk (gtk_radio_button_new (set! dummy-gtk (as-gtk-allocation
(gtk_radio_button_get_group (car radio-gtks))))) (gtk_radio_button_new
(gtk_radio_button_get_group (car radio-gtks))))))
(gtk_toggle_button_set_active dummy-gtk #t)) (gtk_toggle_button_set_active dummy-gtk #t))
(gtk_toggle_button_set_active (list-ref radio-gtks i) #t)) (gtk_toggle_button_set_active (list-ref radio-gtks i) #t))
(set! no-clicked? #f))) (set! no-clicked? #f)))

7
collects/mred/private/wx/gtk/slider.rkt
View File

@ -39,9 +39,10 @@
(inherit get-gtk set-auto-size) (inherit get-gtk set-auto-size)
(super-new [parent parent] (super-new [parent parent]
[gtk (if (memq 'vertical style) [gtk (as-gtk-allocation
(gtk_vscale_new #f) (if (memq 'vertical style)
(gtk_hscale_new #f))] (gtk_vscale_new #f)
(gtk_hscale_new #f)))]
[callback cb] [callback cb]
[no-show? (memq 'deleted style)]) [no-show? (memq 'deleted style)])
(define gtk (get-gtk)) (define gtk (get-gtk))

12
collects/mred/private/wx/gtk/utils.rkt
View File

@ -17,6 +17,10 @@
g_object_ref g_object_ref
g_object_unref g_object_unref
gobject-ref
gobject-unref
as-gobject-allocation
as-gtk-allocation as-gtk-allocation
as-gtk-window-allocation as-gtk-window-allocation
@ -90,6 +94,14 @@
(define-gobj g_object_unref (_fun _pointer -> _void)) (define-gobj g_object_unref (_fun _pointer -> _void))
(define-gobj g_object_ref_sink (_fun _pointer -> _pointer)) (define-gobj g_object_ref_sink (_fun _pointer -> _pointer))
(define gobject-unref ((deallocator) g_object_unref))
(define gobject-ref ((allocator gobject-unref) g_object_ref))
(define-syntax-rule (as-gobject-allocation expr)
((gobject-allocator (lambda () expr))))
(define gobject-allocator (allocator gobject-unref))
(define-gtk gtk_widget_destroy (_fun _GtkWidget -> _void)) (define-gtk gtk_widget_destroy (_fun _GtkWidget -> _void))
(define gtk-destroy ((deallocator) (lambda (v) (define gtk-destroy ((deallocator) (lambda (v)

24
collects/mred/private/wx/gtk/widget.rkt
View File

@ -1,12 +1,12 @@
#lang scheme/base #lang racket/base
(require scheme/foreign (require ffi/unsafe
scheme/class racket/class
"../../syntax.rkt" "../../syntax.rkt"
"../../lock.rkt"
"../common/queue.rkt" "../common/queue.rkt"
"queue.rkt" "queue.rkt"
"utils.rkt" "utils.rkt"
"types.rkt") "types.rkt")
(unsafe!)
(provide widget% (provide widget%
gtk->wx gtk->wx
@ -25,13 +25,17 @@
(define-gtk gtk_widget_destroy (_fun _pointer -> _void)) (define-gtk gtk_widget_destroy (_fun _pointer -> _void))
(define-gtk gtk_vbox_new (_fun _gboolean _int -> _GtkWidget)) (define-gtk gtk_vbox_new (_fun _gboolean _int -> _GtkWidget))
(define-gtk gtk_hbox_new (_fun _gboolean _int -> _GtkWidget)) (define-gtk gtk_hbox_new (_fun _gboolean _int -> _GtkWidget))
(define-gtk gtk_box_pack_start (_fun _GtkWidget _GtkWidget _gboolean _gboolean _uint -> _void)) (define-gtk gtk_box_pack_start (_fun _GtkWidget _GtkWidget _gboolean _gboolean _uint -> _void))
(define-gtk gtk_box_pack_end (_fun _GtkWidget _GtkWidget _gboolean _gboolean _uint -> _void)) (define-gtk gtk_box_pack_end (_fun _GtkWidget _GtkWidget _gboolean _gboolean _uint -> _void))
(define-gtk gtk_widget_get_parent (_fun _GtkWidget -> (_or-null _GtkWidget))) (define-gtk gtk_widget_get_parent (_fun _GtkWidget -> (_or-null _GtkWidget)))
(define-signal-handler connect-destroy "destroy"
(_fun _GtkWidget _pointer -> _void)
(lambda (gtk cell)
(free-immobile-cell cell)))
(define widget% (define widget%
(class object% (class object%
(init gtk (init gtk
@ -52,10 +56,12 @@
(super-new) (super-new)
(let ([cell (malloc-immobile-cell (make-weak-box this))]) (atomically
(g_object_set_data gtk "wx" cell) (let ([cell (malloc-immobile-cell (make-weak-box this))])
(for ([gtk (in-list extra-gtks)]) (g_object_set_data gtk "wx" cell)
(g_object_set_data gtk "wx" cell))))) (for ([gtk (in-list extra-gtks)])
(g_object_set_data gtk "wx" cell))
(connect-destroy gtk cell)))))
(define (gtk->wx gtk) (define (gtk->wx gtk)
(let ([ptr (g_object_get_data gtk "wx")]) (let ([ptr (g_object_get_data gtk "wx")])