From: Matt Birkholz Date: Sun, 11 Mar 2018 04:08:12 +0000 (-0700) Subject: gtk: Serialize callouts to glib. Banish without-interrupts. X-Git-Tag: mit-scheme-pucked-x11-0.2.2~59 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=facb628102190e1141d17bcac7879cd5cd1b9ee6;p=mit-scheme.git gtk: Serialize callouts to glib. Banish without-interrupts. --- diff --git a/src/gtk/fix-layout.scm b/src/gtk/fix-layout.scm index 4be56302a..d371f304c 100644 --- a/src/gtk/fix-layout.scm +++ b/src/gtk/fix-layout.scm @@ -55,6 +55,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (->color bgcolor '(initialize-instance ))))) (call-next-method widget) (%trace "; (initialize-instance ) "widget" "width"x"height"\n") + (assert-glib-locked '(initialize-instance )) (set-scm-widget-natural-size! widget width height) (set-fix-widget-%background-color! widget bg) ;; Init. size, for a realize signal arriving before an allocation. @@ -73,6 +74,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define-method fix-widget-realize-callback ((widget )) (%trace "; (fix-widget-realize-callback ) "widget"\n") + (assert-glib-locked '(fix-widget-realize-callback )) (let ((geometry (fix-widget-geometry widget)) (attr (malloc (C-sizeof "GdkWindowAttr") '|GdkWindowAttr|)) (main-GdkWindow (fix-widget-window widget)) @@ -130,6 +132,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (height (C-> GtkAllocation "GtkAllocation height")) (rect (fix-widget-geometry widget))) (%trace "; allocated "width"x"height" at "x","y" for "widget"\n") + (assert-glib-locked 'allocate-callback) (C-call "gtk_widget_set_allocation" (gobject-alien widget) GtkAllocation) (set-fix-rect! rect x y width height) (if (fix-widget-realized? widget) @@ -175,6 +178,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (map car alist)))) (cursor (make-alien '|GdkCursor|)) (display (make-alien '|GdkDisplay|))) + (assert-glib-locked 'set-fix-widget-pointer-shape!) ;; GC-protect cursor! (C-call "gtk_widget_get_display" display (gobject-alien widget)) (C-call "gdk_cursor_new_for_display" cursor display (cdr name.value)) @@ -364,6 +368,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define-method initialize-instance ((widget ) width height bgcolor) (call-next-method widget width height bgcolor) (%trace "; (initialize-instance ) "widget" "width"x"height"\n") + (assert-glib-locked '(initialize-instance )) (set-fix-rect! (fix-layout-view widget) 0 0 width height) (set-gtk-widget-draw-callback! widget layout-draw-callback) (set-scm-widget-set-scroll-adjustments-callback! widget adjustments-callback) @@ -486,6 +491,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (scroll widget new-x new-y) ;; Scroll if more than 25% will remain in the window, else jump. + (assert-glib-locked 'scroll) (if (fix-widget-realized? widget) (let ((view (fix-layout-view widget))) (let ((old-x (fix-rect-x view)) @@ -522,15 +528,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (adjust-adjustments widget))) (define (set-fix-layout-drawing! widget drawing x y) - ;; Need to add widget to drawing and drawing to widget. Either way, - ;; asynchronous exposures may be handled inconsistently. Rather - ;; than lock up the machine with without-interrupts, rely on the - ;; all-encompassing update queued at the end, AFTER the pair of - ;; links is in place. - ;; - ;; Setting the drawing first to cut off its flow of damage areas - ;; first. Expose handlers should have few chances to serve exposes - ;; from the old drawing before the widget sees the new one. + (assert-glib-locked 'set-fix-layout-drawing!) (guarantee-fix-layout widget 'set-fix-layout-drawing!) (guarantee-fix-drawing drawing 'set-fix-layout-drawing!) (guarantee fixnum? x 'set-fix-layout-drawing!) @@ -565,6 +563,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define-method fix-widget-realize-callback ((widget )) (call-next-method widget) (%trace "; (fix-widget-realize-callback ) "widget"\n") + (assert-glib-locked '(fix-widget-realize-callback )) #;(let ((style (gtk-widget-style-context widget))) (C-call "gtk_style_context_set_background" style (fix-widget-window widget))) @@ -584,9 +583,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (adjust-adjustments widget))) (define (connect-adjustment old-adjustment new-alien widget setter) - ;; Disconnects OLD-ADJUSTMENT (if any) and applies SETTER to WIDGET - ;; and the new adjustment (if any). - + (assert-glib-locked 'connect-adjustment) (let ((old-alien (and old-adjustment (gobject-alien old-adjustment)))) ;; Disconnect. (cond ((not old-adjustment)) @@ -608,7 +605,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (make-adjustment-value-changed-callback widget) (named-lambda (fix-layout-adjustment-value-changed-callback adjustment) (%trace2 ";adjustment-value-changed "widget" "adjustment"\n") - + (assert-glib-locked 'make-adjustment-value-changed-callback) (let ((window-extent (fix-layout-view widget)) (vadjustment (fix-layout-vadjustment widget)) (hadjustment (fix-layout-hadjustment widget)) @@ -705,6 +702,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (drawing-damage ink #!optional rect) ;; Invalidates any widget extents affected by RECT in INK. By ;; default, RECT is INK's entire extent. + (assert-glib-locked 'drawing-damage) (let ((extent (if (default-object? rect) (fix-ink-extent ink) rect)) @@ -836,8 +834,9 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define-guarantee fix-ink "a ") (define (set-fix-ink-%position! ink x y) + (assert-glib-locked 'set-fix-ink-%position!) (let ((extent (fix-ink-extent ink))) - (without-interrupts + (without-interruption (lambda () (if (not (and (fix:= x (fix-rect-x extent)) (fix:= y (fix-rect-y extent)))) @@ -847,8 +846,9 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (drawing-damage ink))))))) (define (set-fix-ink! ink x y width height) + (assert-glib-locked 'set-fix-ink!) (let ((extent (fix-ink-extent ink))) - (without-interrupts + (without-interruption (lambda () (if (not (and (fix:= x (fix-rect-x extent)) (fix:= y (fix-rect-y extent)) @@ -860,7 +860,8 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (drawing-damage ink))))))) (define (set-fix-ink-widgets! ink widgets) - (without-interrupts + (assert-glib-locked 'set-fix-ink-widgets!) + (without-interruption (lambda () (if (not (equal? widgets (fix-ink-widgets ink))) (begin @@ -869,16 +870,19 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (drawing-damage ink)))))) (define (fix-ink-remove! ink) + (assert-glib-locked 'fix-ink-remove!) (guarantee-fix-ink ink 'fix-ink-remove!) (let ((drawing (fix-ink-drawing ink))) (cond ((not drawing) unspecific) ((not (memq ink (fix-drawing-display-list drawing))) (warn "Could not remove ink:" ink drawing)) (else - (set-fix-drawing-display-list! - drawing (delq! ink (fix-drawing-display-list drawing))) - (drawing-damage ink) - (set-fix-ink-drawing! ink #f))))) + (without-interruption + (lambda () + (set-fix-drawing-display-list! + drawing (delq! ink (fix-drawing-display-list drawing))) + (drawing-damage ink) + (set-fix-ink-drawing! ink #f))))))) ;; For the convenience of SWAT's canvas item group, mostly. (define-generic fix-ink-move! (ink dx dy)) @@ -887,7 +891,8 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. ;; that needs to be updated when you move. This is not a default ;; method, else things might (only) appear to work. (define-integrable (generic-fix-ink-move! ink dx dy) - (without-interrupts + (assert-glib-locked 'generic-fix-ink-move!) + (without-interruption (lambda () (let ((extent (fix-ink-extent ink))) (drawing-damage ink) @@ -979,6 +984,8 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. 2))))) (define (recache-line-extent! ink) + (assert-without-interruption 'recache-line-extent!) + (assert-glib-locked 'recache-line-extent!) (with-fix-rect (line-ink-vector ink) (lambda (x1 y1 dx dy) @@ -998,11 +1005,12 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (drawing-damage ink)))))) (define (set-line-ink! ink x1 y1 x2 y2) + (assert-glib-locked 'set-line-ink!) (guarantee fixnum? x1 'set-line-ink!) (guarantee fixnum? y1 'set-line-ink!) (guarantee fixnum? x2 'set-line-ink!) (guarantee fixnum? y2 'set-line-ink!) - (without-interrupts + (without-interruption (lambda () (let ((vector (line-ink-vector ink)) (dx (fix:- x2 x1)) @@ -1016,7 +1024,8 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (recache-line-extent! ink))))))) (define-method fix-ink-move! ((ink ) dx dy) - (without-interrupts + (assert-glib-locked '(fix-ink-move! )) + (without-interruption (lambda () (let ((vector (line-ink-vector ink)) (extent (fix-ink-extent ink))) @@ -1030,9 +1039,10 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (get-option ink 'LINE-WIDTH '())) (define (set-line-ink-width! ink width) + (assert-glib-locked 'set-line-ink-width!) (guarantee-line-ink ink 'set-line-ink-width!) (guarantee positive-fixnum? width 'set-line-ink-width!) - (without-interrupts + (without-interruption (lambda () (if (set-option!? ink 'LINE-WIDTH (->flonum width)) (recache-line-extent! ink))))) @@ -1042,9 +1052,10 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (get-option ink 'COLOR '())) (define (set-line-ink-color! ink color) + (assert-glib-locked 'set-line-ink-color!) (guarantee-line-ink ink 'set-line-ink-color!) (let ((color (->color color 'set-line-ink-color!))) - (without-interrupts + (without-interruption (lambda () (if (set-option!? ink 'COLOR color) (drawing-damage ink)))))) @@ -1054,10 +1065,11 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (get-option ink 'DASH-COLOR '())) (define (set-line-ink-dash-color! ink color) + (assert-glib-locked 'set-line-ink-dash-color!) (guarantee-line-ink ink 'set-line-ink-dash-color!) (let ((color (cond ((eq? color '()) '()) (else (->color color 'set-line-ink-dash-color!))))) - (without-interrupts + (without-interruption (lambda () (if (set-option!? ink 'DASH-COLOR color) (drawing-damage ink)))))) @@ -1067,10 +1079,11 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (get-option ink 'DASHES '())) (define (set-line-ink-dashes! ink lengths) + (assert-glib-locked 'set-line-ink-dashes!) (guarantee-line-ink ink 'set-line-ink-dashes!) (guarantee-list-of-type lengths flo:flonum? "list of flonums" 'set-line-ink-dashes!) - (without-interrupts + (without-interruption (lambda () (if (set-option!? ink 'DASHES lengths) (drawing-damage ink))))) @@ -1141,11 +1154,12 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (drawing-damage ink))))) (define (set-rectangle-ink! ink x y width height) + (assert-glib-locked 'set-rectangle-ink!) (guarantee fixnum? x 'set-rectangle-ink!) (guarantee fixnum? y 'set-rectangle-ink!) (guarantee-size width 'set-rectangle-ink!) (guarantee-size height 'set-rectangle-ink!) - (without-interrupts + (without-interruption (lambda () (let ((rect (rectangle-ink-rect ink))) (if (not (and (fix:= x (fix-rect-x rect)) @@ -1157,9 +1171,10 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (recache-rectangle-extent! ink))))))) (define (set-rectangle-ink-position! ink x y) + (assert-glib-locked 'set-rectangle-ink-position!) (guarantee fixnum? x 'set-rectangle-ink-position!) (guarantee fixnum? y 'set-rectangle-ink-position!) - (without-interrupts + (without-interruption (lambda () (let ((rect (rectangle-ink-rect ink))) (if (not (and (fix:= x (fix-rect-x rect)) @@ -1169,7 +1184,8 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (recache-rectangle-extent! ink))))))) (define-method fix-ink-move! ((ink ) dx dy) - (without-interrupts + (assert-glib-locked '(fix-ink-move! )) + (without-interruption (lambda () (let ((rect (rectangle-ink-rect ink)) (extent (fix-ink-extent ink))) @@ -1183,9 +1199,10 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (get-option ink 'LINE-WIDTH '())) (define (set-rectangle-ink-width! ink width) + (assert-glib-locked 'set-rectangle-ink-width!) (guarantee-rectangle-ink ink 'set-rectangle-ink-width!) (guarantee positive-fixnum? width 'set-rectangle-ink-width!) - (without-interrupts + (without-interruption (lambda () (if (set-option!? ink 'LINE-WIDTH (->flonum width)) (recache-rectangle-extent! ink))))) @@ -1195,9 +1212,10 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (get-option ink 'OUTLINE '())) (define (set-rectangle-ink-color! ink color) + (assert-glib-locked 'set-rectangle-ink-color!) (guarantee-rectangle-ink ink 'set-rectangle-ink-color!) (let ((color (->color color 'set-rectangle-ink-color!))) - (without-interrupts + (without-interruption (lambda () (if (set-option!? ink 'OUTLINE color) (drawing-damage ink)))))) @@ -1207,9 +1225,10 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (get-option ink 'FILL '())) (define (set-rectangle-ink-fill-color! ink color) + (assert-glib-locked 'set-rectangle-ink-fill-color!) (guarantee-rectangle-ink ink 'set-rectangle-ink-fill-color!) (let ((color (->color color 'set-rectangle-ink-fill-color!))) - (without-interrupts + (without-interruption (lambda () (if (set-option!? ink 'FILL color) (drawing-damage ink)))))) @@ -1278,19 +1297,21 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (drawing-damage ink))))))) (define (set-polygon-ink! ink vertices) + (assert-glib-locked 'set-polygon-ink!) (if (or (null? vertices) (not (every (lambda (p) (and (pair? p) (fixnum? (car p)) (fixnum? (cdr p)))) vertices))) (error:wrong-type-argument vertices "a list of pairs of fixnums" 'SET-POLYGON-INK!)) - (without-interrupts + (without-interruption (lambda () (set-polygon-ink-vertices! ink vertices) (recache-polygon-extent! ink)))) (define-method fix-ink-move! ((ink ) dx dy) - (without-interrupts + (assert-glib-locked '(fix-ink-move! )) + (without-interruption (lambda () (for-each (lambda (p) (set-car! p (fix:+ (car p) dx)) @@ -1305,9 +1326,10 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (get-option ink 'LINE-WIDTH '())) (define (set-polygon-ink-width! ink width) + (assert-glib-locked 'set-polygon-ink-width!) (guarantee-polygon-ink ink 'set-polygon-ink-width!) (guarantee positive-fixnum? width 'set-polygon-ink-width!) - (without-interrupts + (without-interruption (lambda () (if (set-option!? ink 'LINE-WIDTH (->flonum width)) (recache-polygon-extent! ink))))) @@ -1317,9 +1339,10 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (get-option ink 'OUTLINE '())) (define (set-polygon-ink-color! ink color) + (assert-glib-locked 'set-polygon-ink-color!) (guarantee-polygon-ink ink 'set-polygon-ink-color!) (let ((color (->color color 'set-polygon-ink-color!))) - (without-interrupts + (without-interruption (lambda () (if (set-option!? ink 'OUTLINE color) (drawing-damage ink)))))) @@ -1329,9 +1352,10 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (get-option ink 'FILL '())) (define (set-polygon-ink-fill-color! ink color) + (assert-glib-locked 'set-polygon-ink-fill-color!) (guarantee-polygon-ink ink 'set-polygon-ink-fill-color!) (let ((color (->color color 'set-polygon-ink-fill-color!))) - (without-interrupts + (without-interruption (lambda () (if (set-option!? ink 'FILL color) (drawing-damage ink)))))) @@ -1394,11 +1418,12 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (drawing-damage ink))))) (define (set-arc-ink! ink x y width height) + (assert-glib-locked 'set-arc-ink!) (guarantee fixnum? x 'set-arc-ink!) (guarantee fixnum? y 'set-arc-ink!) (guarantee-size width 'set-arc-ink!) (guarantee-size height 'set-arc-ink!) - (without-interrupts + (without-interruption (lambda () (let ((rect (arc-ink-rect ink))) (if (not (and (fix:= x (fix-rect-x rect)) @@ -1410,7 +1435,8 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (recache-arc-extent! ink))))))) (define-method fix-ink-move! ((ink ) dx dy) - (without-interrupts + (assert-glib-locked '(fix-ink-move! )) + (without-interruption (lambda () (let ((rect (arc-ink-rect ink)) (extent (fix-ink-extent ink))) @@ -1450,9 +1476,10 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (get-option ink 'LINE-WIDTH '())) (define (set-arc-ink-width! ink width) + (assert-glib-locked 'set-arc-ink-width!) (guarantee-arc-ink ink 'set-arc-ink-width!) (guarantee positive-fixnum? width 'set-arc-ink-width!) - (without-interrupts + (without-interruption (lambda () (if (set-option!? ink 'LINE-WIDTH (->flonum width)) (recache-arc-extent! ink))))) @@ -1462,9 +1489,10 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (get-option ink 'OUTLINE '())) (define (set-arc-ink-color! ink color) + (assert-glib-locked 'set-arc-ink-color!) (guarantee-arc-ink ink 'set-arc-ink-color!) (let ((color (->color color 'set-arc-ink-color!))) - (without-interrupts + (without-interruption (lambda () (if (set-option!? ink 'OUTLINE color) (drawing-damage ink)))))) @@ -1474,9 +1502,10 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (get-option ink 'FILL '())) (define (set-arc-ink-fill-color! ink color) + (assert-glib-locked 'set-arc-ink-fill-color!) (guarantee-arc-ink ink 'set-arc-ink-fill-color!) (let ((color (->color color 'set-arc-ink-fill-color!))) - (without-interrupts + (without-interruption (lambda () (if (set-option!? ink 'FILL color) (drawing-damage ink)))))) @@ -1511,9 +1540,10 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (draw-ink-options ink))) (define (set-text-ink-position! ink x y) + (assert-glib-locked 'set-text-ink-position!) (guarantee fixnum? x 'set-text-ink-position!) (guarantee fixnum? y 'set-text-ink-position!) - (without-interrupts + (without-interruption (lambda () (let ((rect (fix-ink-extent ink))) (if (not (and (fix:= x (fix-rect-x rect)) @@ -1540,9 +1570,10 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (get-option ink 'COLOR '())) (define (set-text-ink-color! ink color) + (assert-glib-locked 'set-text-ink-color!) (guarantee-text-ink ink 'set-text-ink-color!) (let ((color (->color color 'set-text-ink-color!))) - (without-interrupts + (without-interruption (lambda () (if (set-option!? ink 'COLOR color) (drawing-damage ink)))))) @@ -1597,10 +1628,11 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (set-simple-text-ink-text! ink widget text) ;; The TEXT string is shared. + (assert-glib-locked 'set-simple-text-ink-text!) (guarantee-simple-text-ink ink 'set-simple-text-ink-text!) (guarantee-gtk-widget widget 'set-simple-text-ink-text!) (guarantee string? text 'set-simple-text-ink-text!) - (without-interrupts + (without-interruption (lambda () (let ((old (simple-text-ink-text ink))) (if (not (and old (string=? text old))) @@ -1625,9 +1657,10 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (get-option ink 'FONT #f)) (define (set-simple-text-ink-font! ink font) + (assert-glib-locked 'set-simple-text-ink-font!) (guarantee-simple-text-ink ink 'set-simple-text-ink-font!) (let ((new (->pango-font-description font 'set-simple-text-ink-font!))) - (without-interrupts + (without-interruption (lambda () (let ((layout (simple-text-ink-pango-layout ink))) (if (and (set-option!? ink 'FONT new) layout) @@ -1695,7 +1728,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define-method fix-ink-draw-callback ((ink ) widget window cr area) (declare (ignore window area)) (%trace2 ";drawing "ink" on "widget"\n") - + (assert-glib-locked '(fix-ink-draw-callback )) (let ((pixbuf (let ((p (image-ink-pixbuf ink))) (if p (gobject-alien p) #f)))) (if (and pixbuf (not (alien-null? pixbuf))) @@ -1745,6 +1778,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (cairo-paint cr)))) (define (get-exposed ink window) + (assert-glib-locked 'get-exposed) (or (surface-ink-exposed ink) (let ((extent (fix-ink-extent ink)) (scale (C-call "gdk_window_get_scale_factor" window))) diff --git a/src/gtk/gdk.scm b/src/gtk/gdk.scm index 3ac76fbe9..7a3848f72 100644 --- a/src/gtk/gdk.scm +++ b/src/gtk/gdk.scm @@ -29,6 +29,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (error:wrong-type-argument object "a GdkWindow address" operator))) (define (gdk-window-create-similar-surface window width height) + (assert-glib-locked 'gdk-window-create-similar-surface) (let ((surface (make-alien '|cairo_surface_t|)) (copy (make-alien '|cairo_surface_t|))) (add-glib-cleanup surface (make-cairo-surface-cleanup copy)) @@ -39,6 +40,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. surface)) (define (gdk-window-create-similar-image-surface window width height scale) + (assert-glib-locked 'gdk-window-create-similar-image-surface) (let ((surface (make-alien '|cairo_surface_t|)) (copy (make-alien '|cairo_surface_t|))) (add-glib-cleanup surface (make-cairo-surface-cleanup copy)) @@ -75,6 +77,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define-method initialize-instance ((loader )) (call-next-method loader) + (assert-glib-locked '(initialize-instance )) (C-call "gdk_pixbuf_loader_new" (gobject-alien loader)) (g-signal-connect loader (C-callback "size_prepared") pixbuf-loader-size-prepared) @@ -85,14 +88,16 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (pixbuf-loader-size-prepared loader width height) (%trace "; pixbuf-loader-size-prepared "loader" "width" "height"\n") + (assert-glib-locked 'pixbuf-loader-size-prepared) (let ((size (pixbuf-loader-size loader))) - (if size (error "Pixbuf loader already has a size:" loader)) + (if size (outf-error ";pixbuf loader already has a size: "loader"\n")) (set-pixbuf-loader-size! loader (cons width height)) (let ((receiver (pixbuf-loader-size-hook loader))) (if receiver (receiver width height))))) (define (pixbuf-loader-area-prepared loader) (%trace "; pixbuf-loader-area-prepared "loader"\n") + (assert-glib-locked 'pixbuf-loader-area-prepared) (let* ((alien (gobject-alien loader)) (pixbuf (let ((p (pixbuf-loader-pixbuf loader))) (if p @@ -107,24 +112,23 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (pixbuf-loader-area-updated loader x y width height) (%trace "; pixbuf-loader-area-updated "loader" "x","y" "width"x"height"\n") + (assert-glib-locked 'pixbuf-loader-area-updated) (let ((receiver (pixbuf-loader-update-hook loader))) (if receiver (receiver x y width height)))) (define (load-pixbuf-from-port loader input-port) - (without-interrupts - (lambda () - (if (pixbuf-loader-port loader) - (error "Pixbuf loader has already started:" loader)) - (set-pixbuf-loader-port! loader input-port) - (let ((thread (create-pixbuf-loader-thread loader))) - (set-pixbuf-loader-thread! loader thread) - (detach-thread thread))))) + (if (pixbuf-loader-port loader) + (error "Pixbuf loader has already started:" loader)) + (set-pixbuf-loader-port! loader input-port) + (detach-thread (create-pixbuf-loader-thread loader)) + unspecific) (define (create-pixbuf-loader-thread loader) (create-thread #f - (lambda () + (named-lambda (load-pixbuf) (%trace "; "loader" started in "(current-thread)"\n") + (set-pixbuf-loader-thread! loader (current-thread)) (let ((port (pixbuf-loader-port loader)) (alien (gobject-alien loader)) (gerror* (make-gerror-pointer)) @@ -132,11 +136,10 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (C->= gerror* "* GError" 0) (define (note-done) + (assert-without-interruption 'load-pixbuf) (gerror-pointer-free gerror*) - (without-interrupts - (lambda () - (set-pixbuf-loader-closed?! loader #t) - (close-input-port port))) + (set-pixbuf-loader-closed?! loader #t) + (close-input-port port) (%trace "; "loader" closed by "(current-thread)"\n") (let ((proc (pixbuf-loader-close-hook loader))) (if proc @@ -152,34 +155,47 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (set-pixbuf-loader-error-message! loader message)) (note-done)) + (define-integrable (with-glib-atom thunk) + (with-glib-lock + (lambda () + (without-interruption thunk)))) + (let loop () (let ((n (read-bytevector! buffer port))) (cond ((eof-object? n) - (if (fix:zero? (C-call "gdk_pixbuf_loader_close" - alien gerror*)) - (note-error) - (note-done))) + (with-glib-atom + (lambda () + (if (fix:zero? (C-call "gdk_pixbuf_loader_close" + alien gerror*)) + (note-error) + (note-done))))) ((or (not (fix:fixnum? n)) (fix:zero? n)) - (note-error)) + (with-glib-atom note-error)) ((not (fix:zero? - (C-call "gdk_pixbuf_loader_write" - alien buffer n gerror*))) + (with-glib-lock + (lambda () + (C-call "gdk_pixbuf_loader_write" + alien buffer n gerror*))))) (loop)) (else - (note-error))))))))) + (with-glib-atom note-error))))))))) (define (make-gerror-pointer) - (let ((alien (make-alien '(* |GError|))) - (copy (make-alien '(* |GError|)))) - (add-glib-cleanup alien (make-gerror-pointer-cleanup copy)) - (C-call "g_try_malloc0" copy (C-sizeof "* GError")) - (copy-alien-address! alien copy) - (error-if-null alien "Could not create:" alien) - alien)) + (with-glib-lock + (lambda () + (let ((alien (make-alien '(* |GError|))) + (copy (make-alien '(* |GError|)))) + (add-glib-cleanup alien (make-gerror-pointer-cleanup copy)) + (C-call "g_try_malloc0" copy (C-sizeof "* GError")) + (copy-alien-address! alien copy) + (error-if-null alien "Could not create:" alien) + alien)))) (define (make-gerror-pointer-cleanup copy) (named-lambda (cleanup-gerror-pointer) + (assert-glib-locked 'cleanup-gerror-pointer) + (assert-without-interruption 'cleanup-gerror-pointer) (if (not (alien-null? copy)) (let ((gerror (make-alien '|GError|))) (C-> copy "* GError" gerror) @@ -189,33 +205,33 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (alien-null! copy))))) (define (gerror-pointer-free gerror*) - (without-interrupts - (lambda () - (if (not (alien-null? gerror*)) - (begin - (execute-glib-cleanup gerror*) - (alien-null! gerror*)))))) + (assert-glib-locked 'gerror-pointer-free) + (assert-without-interruption 'gerror-pointer-free) + (if (not (alien-null? gerror*)) + (begin + (execute-glib-cleanup gerror*) + (alien-null! gerror*)))) (define (load-pixbuf-from-file loader filename) (load-pixbuf-from-port loader (open-binary-input-file (->namestring (->truename filename))))) (define (set-pixbuf-loader-size-hook! loader receiver) - (without-interrupts + (with-glib-lock ; serialize with loader thread (lambda () (%set-pixbuf-loader-size-hook! loader receiver) (let ((size (pixbuf-loader-size loader))) (if size (receiver (car size) (cdr size))))))) (define (set-pixbuf-loader-pixbuf-hook! loader receiver) - (without-interrupts + (with-glib-lock ; serialize with loader thread (lambda () (%set-pixbuf-loader-pixbuf-hook! loader receiver) (let ((pixbuf (pixbuf-loader-pixbuf loader))) (if pixbuf (receiver pixbuf)))))) (define (set-pixbuf-loader-close-hook! loader thunk) - (without-interrupts + (with-glib-lock ; serialize with loader thread (lambda () (%set-pixbuf-loader-close-hook! loader thunk) (if (pixbuf-loader-closed? loader) @@ -257,6 +273,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (vector-set! callback-idv 0 #f))))) (define (clipboard display) + (assert-glib-locked 'clipboard) (or (gdk-display/clipboard display) (let ((atom (get-atom display '|CLIPBOARD|)) (gdkdisplay (gdk-display/alien display)) @@ -266,6 +283,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. clipboard))) (define (get-atom display symbol) + (assert-glib-locked 'get-atom) (let ((entry (assq symbol (gdk-display/atoms display)))) (if entry (cdr entry) @@ -279,6 +297,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (gdk-display-set-clipboard-text display string) (%trace "; gdk-display-set-clipboard-text "display"\n") + (assert-glib-locked 'gdk-display-set-clipboard-text) (let ((string-bv (string->utf8 string))) (C-call "gtk_clipboard_set_text" (clipboard display) @@ -286,6 +305,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (gdk-display-get-clipboard-text display msec) (%trace "; gdk-display-get-clipboard-text "display" "msec"\n") + (assert-glib-locked 'gdk-display-get-clipboard-text) (if (vector-ref (gdk-display/callback-idv display) 0) (error "Operation pending:" display)) (let ((queue (gdk-display/queue display)) diff --git a/src/gtk/gtk-ev.scm b/src/gtk/gtk-ev.scm index ba38abd27..63ea0e1ca 100644 --- a/src/gtk/gtk-ev.scm +++ b/src/gtk/gtk-ev.scm @@ -25,14 +25,16 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. ;;; package: (gtk event-viewer) (define (make-gtk-event-viewer-demo) - (let ((window (gtk-window-new 'toplevel)) - (gtk-ev (make-gtk-event-viewer))) - (gtk-window-set-default-size window 450 300) - (gtk-container-add window gtk-ev) - (gtk-window-set-title window "gtk-event-viewer") - (gtk-container-set-border-width window 10) - (gtk-widget-show-all window) - gtk-ev)) + (with-glib-lock + (lambda () + (let ((window (gtk-window-new 'toplevel)) + (gtk-ev (make-gtk-event-viewer))) + (gtk-window-set-default-size window 450 300) + (gtk-container-add window gtk-ev) + (gtk-window-set-title window "gtk-event-viewer") + (gtk-container-set-border-width window 10) + (gtk-widget-show-all window) + gtk-ev)))) (define-class ( (constructor ())) () @@ -61,6 +63,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define-method initialize-instance ((widget )) (call-next-method widget) (%trace ";\t(initialize-instance ) "widget"\n") + (assert-glib-locked '(initialize-instance )) (let ((alien (gobject-alien widget))) (C-call "gtk_widget_set_has_window" alien 1) (C-call "gtk_widget_set_can_focus" alien 1)) @@ -72,6 +75,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (realize-callback widget) (%trace2 ";realize "widget"\n") + (assert-glib-locked 'realize-callback) (let ((alien (gobject-alien widget)) (attr (malloc (C-sizeof "GdkWindowAttr") '|GdkWindowAttr|)) (main-GdkWindow (gtk-event-viewer-window widget)) @@ -128,6 +132,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (unrealize-callback widget) (%trace2 ";unrealize "widget"\n") + (assert-glib-locked 'unrealize-callback) ;; Destroy our event window. (let ((event-GdkWindow (gtk-event-viewer-event-window widget))) (if (not (alien-null? event-GdkWindow)) @@ -140,6 +145,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (size-allocate-callback widget GtkAllocation) (%trace2 ";size-allocate "widget"\n") + (assert-glib-locked 'size-allocate-callback) (let ((x (C-> GtkAllocation "GtkAllocation x")) (y (C-> GtkAllocation "GtkAllocation y")) (width (C-> GtkAllocation "GtkAllocation width")) @@ -200,6 +206,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (paint-window widget cr) (%trace2 ";(paint-window "widget" "cr")\n") + (assert-glib-locked 'paint-window) (let ((alien (gobject-alien widget)) (style (make-alien '|GtkStyleContext|)) (event-box (gtk-event-viewer-event-box widget))) @@ -278,6 +285,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. unspecific)) (define (push-text ev lines) + (assert-glib-locked 'push-text) (set-gtk-event-viewer-buffer! ev (append lines (gtk-event-viewer-buffer ev))) (if (gtk-widget-drawable? ev) (let ((a (gobject-alien ev)) @@ -303,6 +311,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (string-append (symbol->string (C-enum "GdkEventType" type)) "\n"))) (define (any-event-line GdkEvent) + (assert-glib-locked 'any-event-line) (let ((event-time (C-call "gdk_event_get_time" GdkEvent)) (addr (alien/address-string (C-> GdkEvent "GdkEvent any window"))) (send (if (not (= 0 (C-> GdkEvent "GdkEvent any send_event"))) diff --git a/src/gtk/gtk-widget.scm b/src/gtk/gtk-widget.scm index b36094fa1..237d1b1e7 100644 --- a/src/gtk/gtk-widget.scm +++ b/src/gtk/gtk-widget.scm @@ -36,6 +36,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (set-gtk-adjustment! adjustment value lower upper page-size step-incr page-incr) + (assert-glib-locked set-gtk-adjustment!) (guarantee-live-gtk-adjustment adjustment 'set-gtk-adjustment!) (guarantee real? lower 'set-gtk-adjustment!) (guarantee real? upper 'set-gtk-adjustment!) @@ -128,6 +129,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define-generic gtk-widget-destroy-callback (widget)) (define (gtk-widget-destroy widget) + (assert-glib-locked 'gtk-widget-destroy) (guarantee-live-gtk-widget widget 'gtk-widget-destroy) (C-call "gtk_widget_destroy" (gobject-alien widget))) @@ -147,51 +149,63 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (gobject-unref! widget)))) (define (gtk-widget-realized? widget) + (assert-glib-locked 'gtk-widget-realized?) (guarantee-live-gtk-widget widget 'gtk-widget-realized?) (not (zero? (C-call "gtk_widget_get_realized" (gobject-alien widget))))) (define (gtk-widget-has-focus? widget) + (assert-glib-locked 'gtk-widget-has-focus?) (guarantee-live-gtk-widget widget 'gtk-widget-has-focus?) (not (zero? (C-call "gtk_widget_has_focus" (gobject-alien widget))))) (define (gtk-widget-drawable? widget) + (assert-glib-locked 'gtk-widget-drawable?) (guarantee-gtk-widget widget 'gtk-widget-drawable?) (not (zero? (C-call "gtk_widget_is_drawable" (gobject-alien widget))))) (define (gtk-widget-grab-focus widget) + (assert-glib-locked 'gtk-widget-grab-focus) (guarantee-gtk-widget widget 'gtk-widget-grab-focus) (C-call "gtk_widget_grab_focus" (gobject-alien widget))) (define (gtk-widget-show widget) + (assert-glib-locked 'gtk-widget-show) (guarantee-gtk-widget widget 'gtk-widget-show) (C-call "gtk_widget_show" (gobject-alien widget))) (define (gtk-widget-show-all widget) + (assert-glib-locked 'gtk-widget-show-all) (guarantee-gtk-widget widget 'gtk-widget-show-all) (C-call "gtk_widget_show_all" (gobject-alien widget))) (define (gtk-widget-error-bell widget) + (assert-glib-locked 'gtk-widget-error-bell) (guarantee-gtk-widget widget 'gtk-widget-error-bell) (C-call "gtk_widget_error_bell" (gobject-alien widget))) (define (gtk-widget-queue-draw widget) + (assert-glib-locked 'gtk-widget-queue-draw) (guarantee-gtk-widget widget 'gtk-widget-queue-draw) (C-call "gtk_widget_queue_draw" (gobject-alien widget))) (define (gtk-widget-queue-resize widget) + (assert-glib-locked 'gtk-widget-queue-resize) (guarantee-gtk-widget widget 'gtk-widget-queue-resize) (C-call "gtk_widget_queue_resize" (gobject-alien widget))) (define (gtk-widget-queue-resize-no-redraw widget) + (assert-glib-locked 'gtk-widget-queue-resize-no-redraw) (guarantee-gtk-widget widget 'gtk-widget-queue-resize-no-redraw) (C-call "gtk_widget_queue_resize_no_redraw" (gobject-alien widget))) (define (gtk-widget-get-pango-context widget) + (assert-glib-locked 'gtk-widget-get-pango-context) (guarantee-gtk-widget widget 'gtk-widget-get-pango-context) (C-call "gtk_widget_get_pango_context" (make-alien '|PangoContext|) (gobject-alien widget))) (define (gtk-widget-create-pango-layout widget #!optional text) + (assert-glib-locked 'gtk-widget-create-pango-layout) (guarantee-gtk-widget widget 'gtk-widget-create-pango-layout) (if (not (default-object? text)) (guarantee string? text 'gtk-widget-create-pango-layout)) @@ -204,6 +218,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. layout)) (define (gtk-widget-get-size widget) + (assert-glib-locked 'gtk-widget-get-size) (let ((alien (gobject-alien widget)) (allocation (malloc (C-sizeof "GtkAllocation") '|GtkAllocation|))) (C-call "gtk_widget_get_allocation" alien allocation) @@ -218,15 +233,18 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (error:wrong-type-argument object "a positive fixnum, 0 or -1" operator))) (define (gtk-widget-set-size-request widget width height) + (assert-glib-locked 'gtk-widget-set-size-request) (guarantee-gtk-widget widget 'gtk-widget-set-size-request) (guarantee-size width 'gtk-widget-set-size-request) (guarantee-size height 'gtk-widget-set-size-request) (C-call "gtk_widget_set_size_request" (gobject-alien widget) width height)) (define (gtk-widget-set-hexpand widget expand?) + (assert-glib-locked 'gtk-widget-set-hexpand) (C-call "gtk_widget_set_hexpand" (gobject-alien widget) (if expand? 1 0))) (define (gtk-widget-set-vexpand widget expand?) + (assert-glib-locked 'gtk-widget-set-vexpand) (C-call "gtk_widget_set_vexpand" (gobject-alien widget) (if expand? 1 0))) (define (set-gtk-widget-size-allocate-callback! widget callback) @@ -262,6 +280,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (make-event-callback callback) (named-lambda (event-callback widget event) + (assert-glib-locked 'event-callback) (let ((handled? (callback widget event))) (cond ((eq? handled? #t) 1) ((eq? handled? #f) 0) @@ -269,6 +288,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. 0))))) (define (gtk-widget-set-opacity widget opacity) + (assert-glib-locked 'gtk-widget-set-opacity) (guarantee-gtk-widget widget 'gtk-widget-set-opacity) (guarantee real? opacity 'gtk-widget-set-opacity) (if (not (<= 0. opacity 1.)) @@ -276,6 +296,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (C-call "gtk_widget_set_opacity" (gobject-alien widget) opacity)) (define (gtk-widget-set-name widget name) + (assert-glib-locked 'gtk-widget-set-name) (guarantee-gtk-widget widget 'gtk-widget-set-name) (guarantee string? name 'gtk-widget-set-name) (C-call "gtk_widget_set_name" (gobject-alien widget) (string->utf8 name))) @@ -302,6 +323,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define-guarantee gtk-style-context "a GtkStyleContext alien") (define (gtk-style-context-add-provider style-context css-provider priority) + (assert-glib-locked 'gtk-style-context-add-provider) (guarantee-gtk-style-context style-context 'gtk-style-context-add-provider) (guarantee-gtk-css-provider css-provider 'gtk-style-context-add-provider) (C-call "gtk_style_context_add_provider" @@ -330,6 +352,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define-method initialize-instance ((object )) (call-next-method object) + (assert-glib-locked '(initialize-instance )) (let ((gerror* (gobject-gerror* object))) (C-call "g_try_malloc0" gerror* (C-sizeof "* GError")) (error-if-null gerror* "Could not allocate:" gerror*) @@ -337,6 +360,8 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (make-gerror*-cleanup gerror*) (named-lambda (gerror*-cleanup) + (assert-glib-locked 'gerror*-cleanup) + (assert-without-interruption 'gerror*-cleanup) (if (not (alien-null? gerror*)) (let ((gerror (make-alien '|GError|))) (C-> gerror* "* GError" gerror) @@ -346,6 +371,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (alien-null! gerror*))))) (define (error-if-gerror* gerror* message . data) + (assert-glib-locked 'error-if-gerror*) (let ((gerror (C-> gerror* "* GError"))) (if (not (alien-null? gerror)) (let ((errmsg (c-peek-cstring (C-> gerror "GError message")))) @@ -361,6 +387,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define-guarantee gtk-css-provider "a ") (define (gtk-css-provider-new) + (assert-glib-locked 'gtk-css-provider-new) (let* ((object (make-gtk-css-provider)) (alien (gobject-alien object))) (C-call "gtk_css_provider_new" alien) @@ -369,6 +396,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. object)) (define (gtk-css-provider-get-default) + (assert-glib-locked 'gtk-css-provider-get-default) (let* ((object (make-gtk-css-provider)) (alien (gobject-alien object))) (C-call "gtk_css_provider_get_default" alien) @@ -377,6 +405,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. object)) (define (gtk-css-provider-get-named name variant) + (assert-glib-locked 'gtk-css-provider-get-named) (guarantee string? name 'gtk-css-provider-get-named) (let* ((v (if (eq? #f variant) 0 @@ -392,6 +421,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. object)) (define (gtk-css-provider-load-from-data provider string) + (assert-glib-locked 'gtk-css-provider-load-from-data) (guarantee-gtk-css-provider provider 'gtk-css-provider-load-from-data) (guarantee string? string 'gtk-css-provider-load-from-data) (let ((alien (gobject-alien provider)) @@ -403,6 +433,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define-guarantee gfile "a ") (define (gtk-css-provider-load-from-file provider gfile) + (assert-glib-locked 'gtk-css-provider-load-from-file) (guarantee-gtk-css-provider provider 'gtk-css-provider-load-from-file) (guarantee-gfile gfile 'gtk-css-provider-load-from-file) (let ((alien (gobject-alien provider)) @@ -413,6 +444,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. provider gfile))) (define (gtk-css-provider-load-from-path provider pathname) + (assert-glib-locked 'gtk-css-provider-load-from-path) (guarantee-gtk-css-provider provider 'gtk-css-provider-load-from-file) (let ((namestring (->namestring (pathname-simplify @@ -445,24 +477,27 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (if (pair? c) (car c) #f))) (define (gtk-container-add parent child) + (assert-glib-locked 'gtk-container-add) (guarantee-gtk-container parent 'gtk-container-add) (guarantee-gtk-widget child 'gtk-container-add) (container-add! parent child) (C-call "gtk_container_add" (gobject-alien parent) (gobject-alien child))) (define (gtk-container-remove parent child) + (assert-glib-locked 'gtk-container-remove) (guarantee-gtk-container parent 'gtk-container-remove) (guarantee-gtk-widget child 'gtk-container-remove) (container-remove! parent child) (C-call "gtk_container_remove" (gobject-alien parent) (gobject-alien child))) (define (gtk-container-set-border-width container width) + (assert-glib-locked 'gtk-container-set-border-width) (guarantee-gtk-container container 'gtk-container-set-border-width) (guarantee positive-fixnum? width 'gtk-container-set-border-width) (C-call "gtk_container_set_border_width" (gobject-alien container) width)) (define (container-add! container child) - (without-interrupts + (without-interruption (lambda () (if (gtk-widget-parent child) (error "Already a child:" child)) @@ -473,7 +508,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (set-gtk-widget-parent! child container)))) (define (container-remove! container child) - (without-interrupts + (without-interruption (lambda () (if (not (eq? container (gtk-widget-parent child))) (error "Not parent:" container child)) @@ -491,6 +526,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define-method initialize-instance ((label ) string) (call-next-method label) + (assert-glib-locked '(initialize-instance )) (let ((alien (gobject-alien label))) (C-call "gtk_label_new" alien (string->utf8 string)) (error-if-null alien "Could not create:" label string) @@ -502,17 +538,20 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (make-gtk-label string)) (define (gtk-label-get-text label) + (assert-glib-locked 'gtk-label-get-text) (guarantee-gtk-label label 'gtk-label-get-text) (let ((retval (make-alien '|gchar|))) (C-call "gtk_label_get_text" retval (gobject-alien label)) (c-peek-cstring retval))) (define (gtk-label-set-text label string) + (assert-glib-locked 'gtk-label-set-text) (guarantee-gtk-label label 'gtk-label-set-text) (guarantee string? string 'gtk-label-set-text) (C-call "gtk_label_set_text" (gobject-alien label) (string->utf8 string))) (define (gtk-label-set-width-chars label n-chars) + (assert-glib-locked 'gtk-label-set-width-chars) (guarantee non-negative-fixnum? n-chars 'set-label-width!) (C-call "gtk_label_set_width_chars" (gobject-alien label) n-chars)) @@ -524,6 +563,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define-method initialize-instance ((button )) (call-next-method button) + (assert-glib-locked '(initialize-instance )) (let ((alien (gobject-alien button))) (C-call "gtk_button_new" alien) (error-if-null alien "Could not create:" button) @@ -547,6 +587,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define-method initialize-instance ((button )) (call-next-method button) + (assert-glib-locked '(initialize-instance )) (let ((alien (gobject-alien button))) (C-call "gtk_check_button_new" alien) (error-if-null alien "Could not create:" button) @@ -554,11 +595,13 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (set-gtk-widget-destroy-callback! button)) (define (gtk-check-button-get-active button) + (assert-glib-locked 'gtk-check-button-get-active) (guarantee-gtk-check-button button 'gtk-check-button-get-active) (not (fix:zero? (C-call "gtk_toggle_button_get_active" (gobject-alien button))))) (define (gtk-check-button-set-active button active?) + (assert-glib-locked 'gtk-check-button-set-active) (guarantee-gtk-check-button button 'gtk-check-button-set-active) (C-call "gtk_toggle_button_set_active" (gobject-alien button) (if active? 1 0))) @@ -582,6 +625,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define-method initialize-instance ((grid )) (call-next-method grid) + (assert-glib-locked '(initialize-instance )) (let ((alien (gobject-alien grid))) (C-call "gtk_grid_new" alien) (error-if-null alien "Could not create:" grid) @@ -589,26 +633,31 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (set-gtk-widget-destroy-callback! grid)) (define (gtk-grid-set-row-homogeneous grid homogeneous?) + (assert-glib-locked 'gtk-grid-set-row-homogeneous) (guarantee-gtk-grid grid 'gtk-grid-set-row-homogeneous) (C-call "gtk_grid_set_row_homogeneous" (gobject-alien grid) (if homogeneous? 1 0))) (define (gtk-grid-set-column-homogeneous grid homogeneous?) + (assert-glib-locked 'gtk-grid-set-column-homogeneous) (guarantee-gtk-grid grid 'gtk-grid-set-column-homogeneous) (C-call "gtk_grid_set_column_homogeneous" (gobject-alien grid) (if homogeneous? 1 0))) (define (gtk-grid-set-row-spacing grid spacing) + (assert-glib-locked 'gtk-grid-set-row-spacing) (guarantee-gtk-grid grid 'gtk-grid-set-row-spacing) (guarantee non-negative-fixnum? spacing 'gtk-grid-set-row-spacing) (C-call "gtk_grid_set_row_spacing" (gobject-alien grid) spacing)) (define (gtk-grid-set-column-spacing grid spacing) + (assert-glib-locked 'gtk-grid-set-column-spacing) (guarantee-gtk-grid grid 'gtk-grid-set-column-spacing) (guarantee non-negative-fixnum? spacing 'gtk-grid-set-column-spacing) (C-call "gtk_grid_set_column_spacing" (gobject-alien grid) spacing)) (define (gtk-grid-attach grid widget left top width height) + (assert-glib-locked 'gtk-grid-attach) (guarantee-gtk-grid grid 'gtk-grid-attach) (guarantee-gtk-widget widget 'gtk-grid-attach) (guarantee fixnum? left 'gtk-grid-attach) @@ -620,6 +669,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. left top width height)) (define (gtk-grid-attach-next-to grid child sibling side width height) + (assert-glib-locked 'gtk-grid-attach-next-to) (guarantee-gtk-grid grid 'gtk-grid-attach-next-to) (guarantee-gtk-widget child 'gtk-grid-attach-next-to) (if sibling (guarantee-gtk-widget sibling 'gtk-grid-attach-next-to)) @@ -643,6 +693,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (else (error:wrong-type-argument object "a GtkPositionType" operator)))) (define (gtk-orientable-get-orientation orientable) + (assert-glib-locked 'gtk-orientable-get-orientation) (let ((o (C-call "gtk_orientable_get_orientation" (gobject-alien orientable)))) (cond ((int:= o (C-enum "GTK_ORIENTATION_VERTICAL")) @@ -661,6 +712,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. operator)))) (define (gtk-orientable-set-orientation orientable orientation) + (assert-glib-locked 'gtk-orientable-set-orientation) (C-call "gtk_orientable_set_orientation" (gobject-alien orientable) (->gtk-orientation orientation 'gtk-orientable-set-orientation))) @@ -672,6 +724,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define-method initialize-instance ((frame ) label) (call-next-method frame) + (assert-glib-locked '(initialize-instance )) (let ((alien (gobject-alien frame))) (C-call "gtk_frame_new" alien (if (string-null? label) 0 (string->utf8 label))) @@ -684,6 +737,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (make-gtk-frame label)) (define (gtk-frame-set-shadow-type frame type) + (assert-glib-locked 'gtk-frame-set-shadow-type) (let ((t (->gtk-shadow-type type 'gtk-frame-set-shadow-type))) (C-call "gtk_frame_set_shadow_type" (gobject-alien frame) t))) @@ -705,6 +759,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define-guarantee gtk-scrolled-window "a ") (define (gtk-scrolled-window-new) + (assert-glib-locked 'gtk-scrolled-window-new) (let* ((window (make-gtk-scrolled-window)) (alien (gobject-alien window))) (C-call "gtk_scrolled_window_new" alien 0 0) @@ -714,12 +769,14 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. window)) (define (gtk-scrolled-window-set-policy window horizontal vertical) + (assert-glib-locked 'gtk-scrolled-window-set-policy) (guarantee-gtk-scrolled-window window 'gtk-scrolled-window-set-policy) (C-call "gtk_scrolled_window_set_policy" (gobject-alien window) (->policy horizontal 'gtk-scrolled-window-set-policy) (->policy vertical 'gtk-scrolled-window-set-policy))) (define (gtk-scrolled-window-set-placement window placement) + (assert-glib-locked 'gtk-scrolled-window-set-placement) (guarantee-gtk-scrolled-window window 'gtk-scrolled-window-set-placement) (C-call "gtk_scrolled_window_set_placement" (gobject-alien window) (->placement placement 'gtk-scrolled-window-set-placement))) @@ -749,6 +806,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define-guarantee gtk-scrolled-view "a ") (define (gtk-scrolled-view-new) + (assert-glib-locked 'gtk-scrolled-view-new) (let* ((window (make-gtk-scrolled-view)) (alien (gobject-alien window))) (C-call "gtk_scrolled_view_new" alien 0 0) @@ -765,6 +823,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (child2 define standard accessor gtk-paned-get-child2 initial-value #f)) (define (gtk-paned-new orientation) + (assert-glib-locked 'gtk-paned-new) (let ((orient (->gtk-orientation orientation 'gtk-paned-new)) (paned (make-gtk-paned))) (let ((alien (gobject-alien paned))) @@ -775,6 +834,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. paned)) (define (gtk-paned-pack1 paned child1 resize? shrink?) + (assert-glib-locked 'gtk-paned-pack1) (guarantee-gtk-widget child1 'gtk-paned-pack1) (let ((existing (gtk-paned-get-child1 paned))) (if (and existing (not (gtk-widget-destroyed? existing))) @@ -785,6 +845,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (if resize? 1 0) (if shrink? 1 0))) (define (gtk-paned-pack2 paned child2 resize? shrink?) + (assert-glib-locked 'gtk-paned-pack2) (guarantee-gtk-widget child2 'gtk-paned-pack2) (let ((existing (gtk-paned-get-child2 paned))) (if (and existing (not (gtk-widget-destroyed? existing))) @@ -795,9 +856,11 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (if resize? 1 0) (if shrink? 1 0))) (define (gtk-paned-get-position paned) + (assert-glib-locked 'gtk-paned-get-position) (C-call "gtk_paned_get_position" (gobject-alien paned))) (define (gtk-paned-set-position paned child1-size) + (assert-glib-locked 'gtk-paned-set-position) (C-call "gtk_paned_set_position" (gobject-alien paned) child1-size)) (define-class ( (constructor ())) @@ -811,6 +874,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (gtk-paned-view-init paned orientation) ;; Used by Edwin's gtk-vpaned-new and gtk-hpaned-new. + (assert-glib-locked 'gtk-paned-view-init) (let ((orient (->gtk-orientation orientation 'gtk-paned-view-init)) (alien (gobject-alien paned))) (C-call "gtk_paned_view_new" alien orient) @@ -828,6 +892,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define-method initialize-instance ((window ) type) (call-next-method window) + (assert-glib-locked '(initialize-instance )) (let ((type (->window-type type 'gtk-window-new)) (alien (gobject-alien window))) (C-call "gtk_window_new" alien type) @@ -851,17 +916,20 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. type "a symbol -- one of TOPLEVEL or POPUP" operator)))) (define (gtk-window-set-accept-focus window accept?) + (assert-glib-locked 'gtk-window-set-accept-focus) (guarantee-gtk-window window 'gtk-window-set-accept-focus) (C-call "gtk_window_set_accept_focus" (gobject-alien window) (if (eq? accept? #f) 0 1))) (define (gtk-window-set-title window title) + (assert-glib-locked 'gtk-window-set-title) (guarantee-gtk-window window 'gtk-window-set-title) (guarantee string? title 'gtk-window-set-title) (C-call "gtk_window_set_title" (gobject-alien window) (string->utf8 title))) (define (gtk-window-set-type-hint window hint) + (assert-glib-locked 'gtk-window-set-type-hint) (guarantee-gtk-window window 'gtk-window-set-type-hint) (let ((type-hint (->type-hint hint 'gtk-window-set-type-hint))) (C-call "gtk_window_set_type_hint" (gobject-alien window) type-hint))) @@ -885,6 +953,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (else (error:wrong-type-argument object "a GdkWindow type hint" operator)))) (define (gtk-window-get-default-size window receiver) + (assert-glib-locked 'gtk-window-get-default-size) (guarantee-gtk-window window 'gtk-window-get-default-size) (let* ((*width (malloc (fix:* 2 (C-sizeof "gint")) 'gint)) (*height (alien-byte-increment *width (C-sizeof "gint") 'gint))) @@ -896,12 +965,14 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (receiver width height)))) (define (gtk-window-set-default-size window width height) + (assert-glib-locked 'gtk-window-set-default-size) (guarantee-gtk-window window 'gtk-window-set-default-size) (guarantee integer? width 'gtk-window-set-default-size) (guarantee integer? height 'gtk-window-set-default-size) (C-call "gtk_window_set_default_size" (gobject-alien window) width height)) (define (gtk-window-set-geometry-hints window widget . hints) + (assert-glib-locked 'gtk-window-set-geometry-hints) (guarantee-gtk-window window 'gtk-window-set-geometry-hints) (guarantee-gtk-widget widget 'gtk-window-set-geometry-hints) (guarantee-restricted-keyword-list @@ -1002,12 +1073,14 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (free geometry))) (define (gtk-window-resize window width height) + (assert-glib-locked 'gtk-window-resize) (guarantee-gtk-window window 'gtk-window-resize) (guarantee positive-fixnum? width 'gtk-window-resize) (guarantee positive-fixnum? height 'gtk-window-resize) (C-call "gtk_window_resize" (gobject-alien window) width height)) (define (gtk-window-present window) + (assert-glib-locked 'gtk-window-present) (guarantee-gtk-window window 'gtk-window-present) (C-call "gtk_window_present" (gobject-alien window))) @@ -1025,6 +1098,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define gtk-clipboard-timeout 5000) (define (gtk-window-get-clipboard-text window) + (assert-glib-locked 'gtk-window-get-clipboard-text) (guarantee-gtk-window window 'gtk-window-get-clipboard-text) (let* ((gdkdisplay (C-call "gtk_widget_get_display" (make-alien '|GtkDisplay|) @@ -1033,6 +1107,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (gdk-display-get-clipboard-text gdk-display gtk-clipboard-timeout))) (define (gtk-window-set-clipboard-text window string) + (assert-glib-locked 'gtk-window-set-clipboard-text) (guarantee-gtk-window window 'gtk-window-set-clipboard-text) (guarantee string? string 'gtk-window-set-clipboard-text) (let* ((gdkdisplay (C-call "gtk_widget_get_display" diff --git a/src/gtk/main.scm b/src/gtk/main.scm index 3a8d8baa8..2996a480f 100644 --- a/src/gtk/main.scm +++ b/src/gtk/main.scm @@ -93,7 +93,9 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. words-bv) (C->= count-var "int" (+ 1 arg-count)) (C->= vector-var "* * char" vector) - (if (fix:zero? (C-call "gtk_init_check" count-var vector-var)) + (if (fix:zero? (with-glib-lock + (lambda () + (C-call "gtk_init_check" count-var vector-var)))) (warn "Could not initialize Gtk.") (let ((new-argc (C-> count-var "int"))) (C-> vector-var "* * char" vector-scan) @@ -112,6 +114,6 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (C-call "gtk_time_slice_window_p")) (define (gtk-time-slice-window! open?) - (C-call "gtk_time_slice_window" (if open? 1 0))) + (with-glib-lock (lambda () (C-call "gtk_time_slice_window" (if open? 1 0))))) (initialize-package!) \ No newline at end of file diff --git a/src/gtk/scm-widget.scm b/src/gtk/scm-widget.scm index c63d6f349..999fcf7e6 100644 --- a/src/gtk/scm-widget.scm +++ b/src/gtk/scm-widget.scm @@ -30,6 +30,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define-method initialize-instance ((new )) (call-next-method new) + (assert-glib-locked '(initialize-instance )) (let ((a (gobject-alien new))) (C-call "scm_widget_new" a) (if (alien-null? a) diff --git a/src/gtk/swat.scm b/src/gtk/swat.scm index 1dd54b2dd..6a85969cf 100644 --- a/src/gtk/swat.scm +++ b/src/gtk/swat.scm @@ -52,13 +52,11 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define-method gtk-widget-destroy-callback ((object )) (call-next-method object) - (let ((on-death (without-interrupts - (lambda () - (let ((on-death (swat-widget-on-death object))) - (if on-death (set-swat-widget-on-death! object #f)) - on-death))))) + (assert-glib-locked '(gtk-widget-destroy-callback )) + (let ((on-death (swat-widget-on-death object))) (if on-death (begin + (set-swat-widget-on-death! object #f) (%trace "on-death "object": "on-death) ((cdr on-death)))))) @@ -90,11 +88,13 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define-method initialize-instance ((frame )) (%trace "(initialize-instance ) "frame) (call-next-method frame "") - (gtk-container-add frame (gtk-label-new ""))) + (with-glib-lock + (lambda () (gtk-container-add frame (gtk-label-new ""))))) (define (set-label-relief! label relief) (let ((gtk-shadow-type (relief->gtk-shadow-type relief))) - (gtk-frame-set-shadow-type label gtk-shadow-type))) + (with-glib-lock + (lambda () (gtk-frame-set-shadow-type label gtk-shadow-type))))) (define (relief->gtk-shadow-type relief) (case relief @@ -143,7 +143,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define-method initialize-instance ((canvas ) width height) (%trace "(initialize-instance ) "canvas" "width"x"height) (call-next-method canvas width height '()) - (set-fix-layout-drawing! canvas (make-fix-drawing) 0 0)) + (set-fix-layout-drawing! canvas (with-glib-lock make-fix-drawing) 0 0)) (define (set-swat-canvas-handler! canvas type.modifiers handler) ;; type.modifiers is e.g. (press 3 control), (double-press 1), @@ -208,7 +208,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (guarantee fixnum? dx 'item-move!) (guarantee fixnum? dy 'item-move!) (if (not (and (fix:zero? dx) (fix:zero? dy))) - (without-interrupts + (with-glib-lock (lambda () (fix-ink-move! item dx dy) (let ((group (swat-ink-group item))) @@ -239,15 +239,14 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (swat-group-items group))) (define-method fix-ink-move! ((group ) dx dy) - (without-interrupts - (lambda () - (let ((extent (fix-ink-extent group))) - (fix-rect-move! extent dx dy) - (for-each (lambda (i) (fix-ink-move! i dx dy)) - (swat-group-items group)))))) + (assert-glib-locked '(fix-ink-move! )) + (let ((extent (fix-ink-extent group))) + (fix-rect-move! extent dx dy) + (for-each (lambda (i) (fix-ink-move! i dx dy)) + (swat-group-items group)))) (define (group-add! group item) - (without-interrupts + (with-glib-lock (lambda () (let ((items (swat-group-items group)) (extent (fix-ink-extent group)) @@ -263,7 +262,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (set-swat-ink-group! item group))))) (define (group-remove! group item) - (without-interrupts + (with-glib-lock (lambda () (let ((items (swat-group-items group))) (define (topmost group) @@ -628,13 +627,15 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (if (swat-widget-realized? widget) (realize-option widget name spec))) (define (realize-option widget name spec) - #;(case name - ((foreground) (set-gtk-widget-fg-color! widget spec 'normal)) - ((background) (set-gtk-widget-bg-color! widget spec 'normal)) - ((activeforeground) (set-gtk-widget-fg-color! widget spec 'active)) - ((activebackground) (set-gtk-widget-bg-color! widget spec 'active)) - ((font) (set-gtk-widget-font! widget spec)) - (else (warn "Cannot realize widget option:" name spec widget))) + #;(with-glib-lock + (lambda () + (case name + ((foreground) (set-gtk-widget-fg-color! widget spec 'normal)) + ((background) (set-gtk-widget-bg-color! widget spec 'normal)) + ((activeforeground) (set-gtk-widget-fg-color! widget spec 'active)) + ((activebackground) (set-gtk-widget-bg-color! widget spec 'active)) + ((font) (set-gtk-widget-font! widget spec)) + (else (warn "Cannot realize widget option:" name spec widget))))) (warn "Cannot realize widget option:" name spec widget)) (define (realize-options widget) @@ -645,42 +646,54 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define-integrable (set-width! widget width) (if (swat-label? widget) - (gtk-label-set-width-chars (gtk-bin-child widget) width) + (with-glib-lock + (lambda () + (gtk-label-set-width-chars (gtk-bin-child widget) width))) (warn "Unimplemented:" '-width widget))) (define-generic set-text! (widget string)) (define-method set-text! ((button ) string) (guarantee string? string '(set-text! )) - (let ((label (gtk-bin-child button))) - (if (not label) - (gtk-container-add button (gtk-label-new string)) - (gtk-label-set-text label string)))) + (with-glib-lock + (lambda () + (let ((label (gtk-bin-child button))) + (if (not label) + (gtk-container-add button (gtk-label-new string)) + (gtk-label-set-text label string)))))) (define-method set-text! ((label ) string) (guarantee string? string '(set-text! )) - (gtk-label-set-text (gtk-bin-child label) string)) + (with-glib-lock + (lambda () + (gtk-label-set-text (gtk-bin-child label) string)))) (define-method set-text! ((button ) string) (guarantee string? string '(set-text! )) - (let ((label (gtk-bin-child button))) - (if (not label) - (gtk-container-add button (gtk-label-new string)) - (gtk-label-set-text label string)))) + (with-glib-lock + (lambda () + (let ((label (gtk-bin-child button))) + (if (not label) + (gtk-container-add button (gtk-label-new string)) + (gtk-label-set-text label string)))))) (define-generic set-textvariable! (widget active-variable)) (define-method set-textvariable! ((widget ) variable) (set-active-variable-frob! variable (make-label-frobbery widget)) (set-active-variable-value! variable - (gtk-label-get-text (gtk-bin-child widget))) + (with-glib-lock + (lambda () + (gtk-label-get-text (gtk-bin-child widget))))) (set-active-variable-value-initialized?! variable #t)) (define (make-label-frobbery label) (named-lambda (label-frobbery value) (%trace "label-frobbage "label" "value) (if (string? value) - (gtk-label-set-text (gtk-bin-child label) value) + (with-glib-lock + (lambda () + (gtk-label-set-text (gtk-bin-child label) value))) (warn "Bogus text for swat-label frobbery:" value label)))) ;;;; Canvas Item Configuration @@ -700,7 +713,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. ;;; oval -width 2 (define (item-configure! item options) - (without-interrupts + (with-glib-lock (lambda () (let loop ((opts options)) (if (pair? opts) @@ -742,7 +755,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (set-swat-line-arrow-head! line #f))))) (define (make-arrow-head line end) - (let ((head (make-swat-polygon))) + (let ((head (with-glib-lock make-swat-polygon))) (set-polygon-ink-fill-color! head (let ((c (line-ink-color line))) (if (null? c) "black" c))) (update-arrow-head head line end) @@ -755,24 +768,26 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (with-fix-rect (line-ink-vector line) (lambda (startx starty dx dy) - (let ((matrix (cairo-rotation-matrix - (flo:atan2 (flo:- 0. (->flonum dy)) (->flonum dx))))) - (cairo-matrix-scale! - matrix - (->flonum (let ((w (line-ink-width line))) - (if (null? w) 1 w)))) - (cairo-matrix-translate! - matrix - (->flonum (if (eq? end 'FIRST) startx (+ startx dx))) - (->flonum (if (eq? end 'FIRST) starty (+ starty dy)))) - (let ((pt (cairo-point 0. 0.))) - (map (lambda (pair) - (set-x! pt (->flonum (car pair))) - (set-y! pt (->flonum (cdr pair))) - (cairo-transform! pt matrix) - (cons (round->exact (x pt)) - (round->exact (y pt)))) - '((0 . 0) (-10 . 2) (-10 . -2) (0 . 0))))))))) + (with-glib-lock + (lambda () + (let ((matrix (cairo-rotation-matrix + (flo:atan2 (flo:- 0. (->flonum dy)) (->flonum dx))))) + (cairo-matrix-scale! + matrix + (->flonum (let ((w (line-ink-width line))) + (if (null? w) 1 w)))) + (cairo-matrix-translate! + matrix + (->flonum (if (eq? end 'FIRST) startx (+ startx dx))) + (->flonum (if (eq? end 'FIRST) starty (+ starty dy)))) + (let ((pt (cairo-point 0. 0.))) + (map (lambda (pair) + (set-x! pt (->flonum (car pair))) + (set-y! pt (->flonum (cdr pair))) + (cairo-transform! pt matrix) + (cons (round->exact (x pt)) + (round->exact (y pt)))) + '((0 . 0) (-10 . 2) (-10 . -2) (0 . 0))))))))))) (define-generic set-item-fill! (item color)) (define-method set-item-fill! ((item ) color) @@ -840,11 +855,11 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (add-child! object child . others) (if (null? others) - (gtk-container-add object child) + (with-glib-lock (lambda () (gtk-container-add object child))) (error "unimplemented"))) (define (remove-child! object child) - (gtk-container-remove object child)) + (with-glib-lock (lambda () (gtk-container-remove object child)))) ;;; Ask-widget in the examples: ;;; @@ -903,7 +918,8 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. event-type handler . substitutions) (cond ((and (string=? event-type "") (null? substitutions)) - (guarantee-procedure-of-arity handler 0 'add-event-handler!-) + (guarantee-procedure-of-arity handler 0 + 'add-event-handler!-) (set-gtk-button-clicked-callback! button (lambda (button) (declare (ignore button)) (handler)))) (else @@ -1060,22 +1076,29 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (list (%open (reverse! objects) "SWAT")))))) (define (%open children title) - (let ((window (gtk-window-new 'toplevel)) - (grid (gtk-grid-new))) - (gtk-grid-set-row-spacing grid 5) - (gtk-grid-set-column-spacing grid 5) - (gtk-orientable-set-orientation grid 'horizontal) - (for-each (lambda (child) (gtk-container-add grid child)) children) - (gtk-window-set-title window title) - (gtk-container-add window grid) - (gtk-widget-show-all window) - window)) + (with-glib-lock + (lambda () + (let ((window (gtk-window-new 'toplevel)) + (grid (gtk-grid-new))) + (gtk-grid-set-row-spacing grid 5) + (gtk-grid-set-column-spacing grid 5) + (gtk-orientable-set-orientation grid 'horizontal) + (for-each (lambda (child) (gtk-container-add grid child)) children) + (gtk-window-set-title window title) + (gtk-container-add window grid) + (gtk-widget-show-all window) + window)))) (define (swat-close child) (let ((parent (gtk-widget-parent child))) - (if parent (swat-close parent) - (if (gtk-window? child) - (gtk-widget-destroy child) + (if parent + (swat-close parent) + (or (with-glib-lock + (lambda () + (and (gtk-window? child) + (begin + (gtk-widget-destroy child) + #t)))) (error "unexpected top-level widget" child))))) ;;; * widget @@ -1084,19 +1107,19 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. ;;; make-active-variable, initialize-widgets!. (define (make-button #!optional options) - (let ((button (make-swat-button))) + (let ((button (with-glib-lock make-swat-button))) (if (not (default-object? options)) (widget-configure! button options)) button)) (define (make-label #!optional options) - (let ((label (make-swat-label))) + (let ((label (with-glib-lock make-swat-label))) (if (not (default-object? options)) (widget-configure! label options)) label)) (define (make-checkbutton options) - (let ((button (make-swat-checkbutton))) + (let ((button (with-glib-lock make-swat-checkbutton))) (set-gtk-check-button-toggled-callback! button checkbutton-toggled-callback) (let ((active (find-option options '-variable #f))) (if active @@ -1110,9 +1133,10 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (make-checkbutton-frobbery button) (named-lambda (checkbutton-frobbery value) (%trace "checkbutton-frobbery: setting "button" to "value) - (gtk-check-button-set-active button value))) + (with-glib-lock (lambda () (gtk-check-button-set-active button value))))) (define (checkbutton-toggled-callback button) + (assert-glib-locked 'checkbutton-toggled-callback) (let ((variable (swat-checkbutton-swat-variable button)) (callback (swat-checkbutton-swat-callback button))) (if (or variable callback) @@ -1137,16 +1161,20 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. ;;; make-hbox, make-array-box. (define (make-hbox . kids) - (let ((grid (gtk-grid-new))) - (gtk-orientable-set-orientation grid 'horizontal) - (for-each (lambda (kid) (gtk-container-add grid kid)) kids) - grid)) + (with-glib-lock + (lambda () + (let ((grid (gtk-grid-new))) + (gtk-orientable-set-orientation grid 'horizontal) + (for-each (lambda (kid) (gtk-container-add grid kid)) kids) + grid)))) (define (make-vbox . kids) - (let ((grid (gtk-grid-new))) - (gtk-orientable-set-orientation grid 'vertical) - (for-each (lambda (kid) (gtk-container-add grid kid)) kids) - grid)) + (with-glib-lock + (lambda () + (let ((grid (gtk-grid-new))) + (gtk-orientable-set-orientation grid 'vertical) + (for-each (lambda (kid) (gtk-container-add grid kid)) kids) + grid)))) (define (box-children box) (gtk-container-children box)) @@ -1162,7 +1190,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (make-canvas options) (let ((width (find-option options '-width #f)) (height (find-option options '-height #f))) - (let ((canvas (make-swat-canvas width height))) + (let ((canvas (with-glib-lock (lambda () (make-swat-canvas width height))))) (%trace "make-canvas "options": configuring "canvas) (widget-configure! canvas (delete-options! '(-width -height) options)) (%trace "make-canvas "options": "canvas)