(->color bgcolor '(initialize-instance <fix-widget>)))))
(call-next-method widget)
(%trace "; (initialize-instance <fix-widget>) "widget" "width"x"height"\n")
+ (assert-glib-locked '(initialize-instance <fix-widget>))
(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.
(define-method fix-widget-realize-callback ((widget <fix-widget>))
(%trace "; (fix-widget-realize-callback <fix-widget>) "widget"\n")
+ (assert-glib-locked '(fix-widget-realize-callback <fix-widget>))
(let ((geometry (fix-widget-geometry widget))
(attr (malloc (C-sizeof "GdkWindowAttr") '|GdkWindowAttr|))
(main-GdkWindow (fix-widget-window widget))
(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)
(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))
(define-method initialize-instance ((widget <fix-layout>) width height bgcolor)
(call-next-method widget width height bgcolor)
(%trace "; (initialize-instance <fix-layout>) "widget" "width"x"height"\n")
+ (assert-glib-locked '(initialize-instance <fix-layout>))
(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)
(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))
(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!)
(define-method fix-widget-realize-callback ((widget <fix-layout>))
(call-next-method widget)
(%trace "; (fix-widget-realize-callback <fix-layout>) "widget"\n")
+ (assert-glib-locked '(fix-widget-realize-callback <fix-layout>))
#;(let ((style (gtk-widget-style-context widget)))
(C-call "gtk_style_context_set_background"
style (fix-widget-window widget)))
(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))
(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))
(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))
(define-guarantee fix-ink "a <fix-ink>")
(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))))
(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))
(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
(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))
;; 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)
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)
(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))
(recache-line-extent! ink)))))))
(define-method fix-ink-move! ((ink <line-ink>) dx dy)
- (without-interrupts
+ (assert-glib-locked '(fix-ink-move! <line-ink>))
+ (without-interruption
(lambda ()
(let ((vector (line-ink-vector ink))
(extent (fix-ink-extent ink)))
(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)))))
(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))))))
(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))))))
(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)))))
(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))
(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))
(recache-rectangle-extent! ink)))))))
(define-method fix-ink-move! ((ink <rectangle-ink>) dx dy)
- (without-interrupts
+ (assert-glib-locked '(fix-ink-move! <rectangle-ink>))
+ (without-interruption
(lambda ()
(let ((rect (rectangle-ink-rect ink))
(extent (fix-ink-extent ink)))
(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)))))
(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))))))
(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))))))
(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 <polygon-ink>) dx dy)
- (without-interrupts
+ (assert-glib-locked '(fix-ink-move! <polygon-ink>))
+ (without-interruption
(lambda ()
(for-each (lambda (p)
(set-car! p (fix:+ (car p) dx))
(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)))))
(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))))))
(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))))))
(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))
(recache-arc-extent! ink)))))))
(define-method fix-ink-move! ((ink <arc-ink>) dx dy)
- (without-interrupts
+ (assert-glib-locked '(fix-ink-move! <arc-ink>))
+ (without-interruption
(lambda ()
(let ((rect (arc-ink-rect ink))
(extent (fix-ink-extent ink)))
(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)))))
(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))))))
(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))))))
(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))
(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))))))
(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)))
(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)
(define-method fix-ink-draw-callback ((ink <image-ink>) widget window cr area)
(declare (ignore window area))
(%trace2 ";drawing "ink" on "widget"\n")
-
+ (assert-glib-locked '(fix-ink-draw-callback <image-ink>))
(let ((pixbuf (let ((p (image-ink-pixbuf ink)))
(if p (gobject-alien p) #f))))
(if (and pixbuf (not (alien-null? pixbuf)))
(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)))
(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))
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))
(define-method initialize-instance ((loader <pixbuf-loader>))
(call-next-method loader)
+ (assert-glib-locked '(initialize-instance <pixbuf-loader>))
(C-call "gdk_pixbuf_loader_new" (gobject-alien loader))
(g-signal-connect loader (C-callback "size_prepared")
pixbuf-loader-size-prepared)
(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
(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))
(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
(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)
(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)
(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))
clipboard)))
(define (get-atom display symbol)
+ (assert-glib-locked 'get-atom)
(let ((entry (assq symbol (gdk-display/atoms display))))
(if entry
(cdr entry)
(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)
(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))
;;; 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 (<gtk-event-viewer> (constructor ()))
(<scm-widget>)
(define-method initialize-instance ((widget <gtk-event-viewer>))
(call-next-method widget)
(%trace ";\t(initialize-instance <gtk-event-viewer>) "widget"\n")
+ (assert-glib-locked '(initialize-instance <gtk-event-viewer>))
(let ((alien (gobject-alien widget)))
(C-call "gtk_widget_set_has_window" alien 1)
(C-call "gtk_widget_set_can_focus" alien 1))
(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))
(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))
(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"))
(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)))
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))
(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")))
(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!)
(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)))
(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))
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)
(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)
(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)
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.))
(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)))
(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"
(define-method initialize-instance ((object <gobject-with-gerror*>))
(call-next-method object)
+ (assert-glib-locked '(initialize-instance <gobject-with-gerror*>))
(let ((gerror* (gobject-gerror* object)))
(C-call "g_try_malloc0" gerror* (C-sizeof "* GError"))
(error-if-null gerror* "Could not allocate:" gerror*)
(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)
(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"))))
(define-guarantee gtk-css-provider "a <gtk-css-provider>")
(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)
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)
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
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))
(define-guarantee gfile "a <gfile>")
(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))
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
(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))
(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))
(define-method initialize-instance ((label <gtk-label>) string)
(call-next-method label)
+ (assert-glib-locked '(initialize-instance <gtk-label>))
(let ((alien (gobject-alien label)))
(C-call "gtk_label_new" alien (string->utf8 string))
(error-if-null alien "Could not create:" label string)
(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))
\f
(define-method initialize-instance ((button <gtk-button>))
(call-next-method button)
+ (assert-glib-locked '(initialize-instance <gtk-button>))
(let ((alien (gobject-alien button)))
(C-call "gtk_button_new" alien)
(error-if-null alien "Could not create:" button)
(define-method initialize-instance ((button <gtk-check-button>))
(call-next-method button)
+ (assert-glib-locked '(initialize-instance <gtk-check-button>))
(let ((alien (gobject-alien button)))
(C-call "gtk_check_button_new" alien)
(error-if-null alien "Could not create:" button)
(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)))
(define-method initialize-instance ((grid <gtk-grid>))
(call-next-method grid)
+ (assert-glib-locked '(initialize-instance <gtk-grid>))
(let ((alien (gobject-alien grid)))
(C-call "gtk_grid_new" alien)
(error-if-null alien "Could not create:" grid)
(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)
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))
(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"))
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)))
\f
(define-method initialize-instance ((frame <gtk-frame>) label)
(call-next-method frame)
+ (assert-glib-locked '(initialize-instance <gtk-frame>))
(let ((alien (gobject-alien frame)))
(C-call "gtk_frame_new" alien
(if (string-null? label) 0 (string->utf8 label)))
(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)))
(define-guarantee gtk-scrolled-window "a <gtk-scrolled-window>")
(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)
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)))
(define-guarantee gtk-scrolled-view "a <gtk-scrolled-view>")
(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)
(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)))
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)))
(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)))
(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 (<gtk-paned-view> (constructor ()))
(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)
(define-method initialize-instance ((window <gtk-window>) type)
(call-next-method window)
+ (assert-glib-locked '(initialize-instance <gtk-window>))
(let ((type (->window-type type 'gtk-window-new))
(alien (gobject-alien window)))
(C-call "gtk_window_new" alien type)
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)))
(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)))
(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
(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)))
(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|)
(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"
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)
(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
(define-method initialize-instance ((new <scm-widget>))
(call-next-method new)
+ (assert-glib-locked '(initialize-instance <scm-widget>))
(let ((a (gobject-alien new)))
(C-call "scm_widget_new" a)
(if (alien-null? a)
(define-method gtk-widget-destroy-callback ((object <swat-widget>))
(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 <swat-widget>))
+ (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))))))
(define-method initialize-instance ((frame <swat-label>))
(%trace "(initialize-instance <swat-label>) "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
(define-method initialize-instance ((canvas <swat-canvas>) width height)
(%trace "(initialize-instance <swat-canvas>) "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),
(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)))
(swat-group-items group)))
(define-method fix-ink-move! ((group <swat-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! <swat-group>))
+ (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))
(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)
(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)
(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 <swat-button>) string)
(guarantee string? string '(set-text! <swat-button>))
- (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 <swat-label>) string)
(guarantee string? string '(set-text! <swat-label>))
- (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 <swat-checkbutton>) string)
(guarantee string? string '(set-text! <swat-checkbutton>))
- (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 <swat-label>) 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))))
\f
;;;; Canvas Item Configuration
;;; oval -width 2
(define (item-configure! item options)
- (without-interrupts
+ (with-glib-lock
(lambda ()
(let loop ((opts options))
(if (pair? opts)
(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)
(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 <swat-line>) color)
(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:
;;;
event-type handler . substitutions)
(cond ((and (string=? event-type "<Enter>")
(null? substitutions))
- (guarantee-procedure-of-arity handler 0 'add-event-handler!-<swat-button>)
+ (guarantee-procedure-of-arity handler 0
+ 'add-event-handler!-<swat-button>)
(set-gtk-button-clicked-callback!
button (lambda (button) (declare (ignore button)) (handler))))
(else
(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
;;; 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
(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)
;;; 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))
(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)
projects / mit-scheme.git / commitdiff