From: Matt Birkholz Date: Sun, 11 Mar 2018 23:05:37 +0000 (-0700) Subject: gtk: Lock glib in users hello, fix-layout-demo, and gtk-graphics. X-Git-Tag: mit-scheme-pucked-x11-0.2.2~51 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=7aa24ef6d13de10a394a5d5fda9c1356b4c4ebc1;p=mit-scheme.git gtk: Lock glib in users hello, fix-layout-demo, and gtk-graphics. --- diff --git a/src/gtk/fix-demo.scm b/src/gtk/fix-demo.scm index c4aba86bd..e496d598b 100644 --- a/src/gtk/fix-demo.scm +++ b/src/gtk/fix-demo.scm @@ -27,57 +27,71 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define blink? #t) (define spin? #t) +(define (make-fix-layout-widgets) + (with-glib-lock + (lambda () + (let* ((window (let ((w (gtk-window-new 'toplevel))) + (gtk-widget-set-opacity w 0.90) + (gtk-window-set-title w "fix-layout-demo") + (set-gtk-window-delete-event-callback! + w (lambda (w) (%trace ";closed "w"\n") 0)) + (gtk-container-set-border-width w 5) + w)) + (scroller1 (gtk-scrolled-view-new)) + (scroller2 (gtk-scrolled-view-new)) + (layout1 (let ((l (make-demo-layout 200 200))) + (gtk-widget-set-hexpand l #t) + (gtk-widget-set-vexpand l #t) + (set-scm-widget-minimum-size! l 40 40) + l)) + (layout2 (let ((l (make-demo-layout 200 300))) + (gtk-widget-set-hexpand l #t) + (gtk-widget-set-vexpand l #t) + (set-scm-widget-minimum-size! l 40 60) + l)) + (paned (gtk-paned-view-new 'vertical))) + + (gtk-container-add scroller1 layout1) + (gtk-paned-pack1 paned scroller1 'resize #f) + (gtk-container-add scroller2 layout2) + (gtk-paned-pack2 paned scroller2 'resize #f) + (gtk-container-add window paned) + (gtk-widget-show-all window) + (values layout1 layout2))))) + (define (make-fix-layout-demo) - (let* ((window (let ((w (gtk-window-new 'toplevel))) - (gtk-widget-set-opacity w 0.90) - (gtk-window-set-title w "fix-layout-demo") - (set-gtk-window-delete-event-callback! - w (lambda (w) (%trace ";closed "w"\n") 0)) - (gtk-container-set-border-width w 5) - w)) - (scroller1 (gtk-scrolled-view-new)) - (scroller2 (gtk-scrolled-view-new)) - (layout1 (let ((l (make-demo-layout 200 200))) - (gtk-widget-set-hexpand l #t) - (gtk-widget-set-vexpand l #t) - (set-scm-widget-minimum-size! l 40 40) - l)) - (layout2 (let ((l (make-demo-layout 200 300))) - (gtk-widget-set-hexpand l #t) - (gtk-widget-set-vexpand l #t) - (set-scm-widget-minimum-size! l 40 60) - l)) - (paned (gtk-paned-view-new 'vertical))) - - (gtk-container-add scroller1 layout1) - (gtk-paned-pack1 paned scroller1 'resize #f) - (gtk-container-add scroller2 layout2) - (gtk-paned-pack2 paned scroller2 'resize #f) - (gtk-container-add window paned) - (gtk-widget-show-all window) - - (let ((drawing (make-demo-drawing layout1))) - (let ((cursor1 (make-cursor-ink)) - (cursor2 (make-cursor-ink))) - (fix-drawing-add-ink! drawing cursor1 'bottom) - (fix-drawing-add-ink! drawing cursor2 'bottom) - (set-demo-drawing-cursor-inks! - drawing (list (list cursor1 layout1) (list cursor2 layout2)))) - - (set-fix-layout-drawing! layout1 drawing 75 50) - (set-fix-layout-drawing! layout2 drawing 75 50) - ;; Attach widgets to drawing BEFORE starting blink/spin threads. - (if blink? - (let ((thread (start-blinking drawing))) - (%trace ";cursor blinker: "thread"\n")) - (%trace ";cursor blinking disabled\n")) - (if spin? - (let ((thread (start-spinning drawing))) - (%trace ";ring spinner: "thread"\n")) - (%trace ";ring spinning disabled\n"))) - (gtk-widget-grab-focus layout1) - (%trace ";created "layout1" and "layout2"\n")) - unspecific) + (with-values make-fix-layout-widgets + (lambda (layout1 layout2) + (let ((drawing + (with-glib-lock + (lambda () + (let ((drawing (make-demo-drawing layout1))) + (let ((cursor1 (make-cursor-ink)) + (cursor2 (make-cursor-ink))) + (fix-drawing-add-ink! drawing cursor1 'bottom) + (fix-drawing-add-ink! drawing cursor2 'bottom) + (set-demo-drawing-cursor-inks! + drawing (list (list cursor1 layout1) + (list cursor2 layout2)))) + + ;; Attach widgets to drawing BEFORE starting threads. + (set-fix-layout-drawing! layout1 drawing 75 50) + (set-fix-layout-drawing! layout2 drawing 75 50) + + drawing))))) + (if blink? + (let ((thread (start-blinking drawing))) + (%trace ";cursor blinker: "thread"\n")) + (%trace ";cursor blinking disabled\n")) + (if spin? + (let ((thread (start-spinning drawing))) + (%trace ";ring spinner: "thread"\n")) + (%trace ";ring spinning disabled\n"))) + (with-glib-lock + (lambda () + (gtk-widget-grab-focus layout1))) + (%trace ";created "layout1" and "layout2"\n") + unspecific))) (define (make-cursor-ink) (let ((cursor (make-rectangle-ink))) @@ -298,7 +312,8 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (let ((x (fix:- x half-width)) (width (fix:* 2 half-width))) (%trace2 ";spinning to "width"\n") - (set-arc-ink! arc x y width height))) + (with-glib-lock + (lambda () (set-arc-ink! arc x y width height))))) (let ((widgets (fix-drawing-widgets drawing))) (if (null? widgets) (%trace ";spinning ended\n") @@ -317,16 +332,20 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (%trace ";blinking started\n") (let loop () ;; Off! - (for-each (lambda (cursor.widgets) - (set-fix-ink-widgets! (car cursor.widgets) '())) - (demo-drawing-cursor-inks drawing)) + (with-glib-lock + (lambda () + (for-each (lambda (cursor.widgets) + (set-fix-ink-widgets! (car cursor.widgets) '())) + (demo-drawing-cursor-inks drawing)))) (%trace2 ";blinked off\n") (sleep-current-thread 500) ;; On! - (for-each (lambda (cursor.widgets) - (set-fix-ink-widgets! (car cursor.widgets) - (cdr cursor.widgets))) - (demo-drawing-cursor-inks drawing)) + (with-glib-lock + (lambda () + (for-each (lambda (cursor.widgets) + (set-fix-ink-widgets! (car cursor.widgets) + (cdr cursor.widgets))) + (demo-drawing-cursor-inks drawing)))) (%trace2 ";blinked on\n") (sleep-current-thread 500) (if (any (lambda (cursor.widgets) diff --git a/src/gtk/gtk-graphics.scm b/src/gtk/gtk-graphics.scm index 8acc3274e..67169a856 100644 --- a/src/gtk/gtk-graphics.scm +++ b/src/gtk/gtk-graphics.scm @@ -41,6 +41,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define-method initialize-instance ((graphics ) width height) (call-next-method graphics width height) + (assert-glib-locked '(initialize-instance )) (let ((cr (cairo-create (surface-ink-surface graphics))) (factor (->flonum (/ (min (-1+ width) (-1+ height)) 2)))) (if (not (flo:positive? factor)) @@ -74,21 +75,23 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (guarantee positive-fixnum? height 'gtk-graphics/open) (if no-window? (make-device (make-gtk-graphics width height)) - (let ((window (gtk-window-new 'toplevel)) - (scroller (gtk-scrolled-view-new)) - (layout (make-fix-layout width height 'white)) - (drawing (make-fix-drawing)) - (graphics (make-gtk-graphics width height))) - (fix-drawing-add-ink! drawing graphics) - (set-fix-drawing-size! drawing width height) - (set-fix-layout-drawing! layout drawing 0 0) - (gtk-widget-set-hexpand layout #t) - (gtk-widget-set-vexpand layout #t) - (gtk-container-add scroller layout) - (gtk-container-set-border-width window 5) - (gtk-container-add window scroller) - (gtk-widget-show-all window) - (make-device graphics))))) + (with-glib-lock + (lambda () + (let ((window (gtk-window-new 'toplevel)) + (scroller (gtk-scrolled-view-new)) + (layout (make-fix-layout width height 'white)) + (drawing (make-fix-drawing)) + (graphics (make-gtk-graphics width height))) + (fix-drawing-add-ink! drawing graphics) + (set-fix-drawing-size! drawing width height) + (set-fix-layout-drawing! layout drawing 0 0) + (gtk-widget-set-hexpand layout #t) + (gtk-widget-set-vexpand layout #t) + (gtk-container-add scroller layout) + (gtk-container-set-border-width window 5) + (gtk-container-add window scroller) + (gtk-widget-show-all window) + (make-device graphics))))))) (define (toplevel graphics) (let ((widgets (fix-drawing-widgets (fix-ink-drawing graphics)))) @@ -102,15 +105,17 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (error "gtk-graphics/toplevel ambiguous")))) (define (gtk-graphics/close device) - (let ((graphics (graphics-device/descriptor device))) - (let ((toplevel (toplevel graphics)) - (surface (surface-ink-surface graphics)) - (cr (gtk-graphics-context graphics))) - (gtk-widget-destroy toplevel) - (set-surface-ink-surface! graphics #f) - (cairo-surface-destroy surface) - (set-gtk-graphics-context! graphics #f) - (cairo-destroy cr)))) + (with-glib-lock + (lambda () + (let ((graphics (graphics-device/descriptor device))) + (let ((toplevel (toplevel graphics)) + (surface (surface-ink-surface graphics)) + (cr (gtk-graphics-context graphics))) + (gtk-widget-destroy toplevel) + (set-surface-ink-surface! graphics #f) + (cairo-surface-destroy surface) + (set-gtk-graphics-context! graphics #f) + (cairo-destroy cr)))))) (define (gtk-graphics/device-coordinate-limits device) (let ((extent (fix-ink-extent (graphics-device/descriptor device)))) @@ -276,14 +281,18 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (gtk-graphics/set-background-color device name) (let ((graphics (graphics-device/descriptor device))) (if (not (string=? name (gtk-graphics-bgcolor-name graphics))) - (let ((new (->color name 'gtk-graphics/set-background-color))) + (let ((new (with-glib-lock + (lambda () + (->color name 'gtk-graphics/set-background-color))))) (set-gtk-graphics-bgcolor! graphics new) (set-gtk-graphics-bgcolor-name! graphics name))))) (define (gtk-graphics/set-foreground-color device name) (let ((graphics (graphics-device/descriptor device))) (if (not (string=? name (gtk-graphics-fgcolor-name graphics))) - (let ((new (->color name 'gtk-graphics/set-foreground-color))) + (let ((new (with-glib-lock + (lambda () + (->color name 'gtk-graphics/set-foreground-color))))) (set-gtk-graphics-fgcolor! graphics new) (set-gtk-graphics-fgcolor-name! graphics name) (cairo-set-source-color (gtk-graphics-context graphics) new))))) diff --git a/src/gtk/hello.scm b/src/gtk/hello.scm index bb31b3022..ef868a718 100644 --- a/src/gtk/hello.scm +++ b/src/gtk/hello.scm @@ -4,27 +4,29 @@ This is Havoc Pennington's Hello World example from GGAD, wrapped in Scheme. |# (define (hello) - (let ((window (gtk-window-new 'toplevel)) - (button (gtk-button-new)) - (label (gtk-label-new "Hello, World!"))) - (gtk-container-add button label) - (gtk-container-add window button) - (gtk-window-set-title window "Hello") - (gtk-container-set-border-width button 10) - (let ((counter 0)) - (set-gtk-window-delete-event-callback! - window - (lambda (window) - (outf-error ";Bite me "(- 2 counter)" times.\n") - (set! counter (1+ counter)) - ;; Three or more is the charm. - (if (> counter 2) 0 1))) - (set-gtk-button-clicked-callback! - button - (lambda (button) - (let ((text (gtk-label-get-text label))) - (gtk-label-set-text - label (list->string (reverse! (string->list text))))) - unspecific))) - (gtk-widget-show-all window) - window)) \ No newline at end of file + (with-glib-lock + (lambda () + (let ((window (gtk-window-new 'toplevel)) + (button (gtk-button-new)) + (label (gtk-label-new "Hello, World!"))) + (gtk-container-add button label) + (gtk-container-add window button) + (gtk-window-set-title window "Hello") + (gtk-container-set-border-width button 10) + (let ((counter 0)) + (set-gtk-window-delete-event-callback! + window + (lambda (window) + (outf-error ";Bite me "(- 2 counter)" times.\n") + (set! counter (1+ counter)) + ;; Three or more is the charm. + (if (> counter 2) 0 1))) + (set-gtk-button-clicked-callback! + button + (lambda (button) + (let ((text (gtk-label-get-text label))) + (gtk-label-set-text + label (list->string (reverse! (string->list text))))) + unspecific))) + (gtk-widget-show-all window) + window)))) \ No newline at end of file