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 c4aba86bd00a3221a6782885cdf56952264464a5..e496d598b56cb7cbb31859c4dfdd2b0184f284e1 100644 (file)
--- 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 8acc3274ea68e177cbbeeb2925a7a2a008a10d8d..67169a8567defaeaaaa3606ac6c342b4b0899344 100644 (file)
--- 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 <gtk-graphics>) width height)
   (call-next-method graphics width height)
+  (assert-glib-locked '(initialize-instance <gtk-graphics>))
   (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 bb31b30228b58e63309f4ca78f1ef2a6d0ec5921..ef868a71828aedd0109c5d687cd1aa5db0d49da6 100644 (file)
--- 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