Just warn if "DISPLAY not set". Added gtk-thread-running?.

Do NOT call start_gtk!  Warn during (load-option 'Gtk) and upon every
disk restore thereafter.

diff --git a/src/gtk/gtk.pkg b/src/gtk/gtk.pkg
index d6215366c2247fd3f5ba05cf20be4eaa5e5d72fe..94d470498c5119fd5c89b3c6abbaa39b0db4cee6 100644 (file)
--- a/src/gtk/gtk.pkg
+++ b/src/gtk/gtk.pkg
@@ -313,7 +313,8 @@ USA.
   (files "thread")
   ;;(depends-on "main")
   (export ()
-         stop-gtk-thread)
+         stop-gtk-thread
+         gtk-thread-running?)
   (import (gtk gobject)
          run-gc-cleanups)
   (import (gtk main)

diff --git a/src/gtk/main.scm b/src/gtk/main.scm
index 1535a9bb80c7aa466f9dbca1c80f841c66eb2cab..f7db51471f45cf5843a0e8530afcc811e9409611 100644 (file)
--- a/src/gtk/main.scm
+++ b/src/gtk/main.scm
@@ -39,6 +39,23 @@ USA.
                (start-gtk program-name (vector->list line)))))))))
 
 (define (start-gtk name args)
+  (if (let ((s (get-environment-variable "DISPLAY")))
+       (and (string? s) (not (string-null? s))))
+      (let ((path (system-library-pathname "gtk-shim.so" #f)))
+       (if path
+           (if (file-loadable? path)
+               (start-gtk* name args)
+               (begin
+                 (warn "Gtk shim not loadable")
+                 args))
+           (begin
+             (warn "No Gtk shim")
+             args)))
+      (begin
+       (warn "DISPLAY not set")
+       args)))
+
+(define (start-gtk* name args)
   ;; Call start_gtk.  Signals an error if gtk_init_check returns 0.
   ;; Returns a list of unused ARGS.
   (let ((arg-count (guarantee-list-of-type->length

diff --git a/src/gtk/thread.scm b/src/gtk/thread.scm
index 6a65fb86787682bdd29f2c67acb84efd734635a9..84f4ad269af2ff1cfcc06239cff825eaf019f98f 100644 (file)
--- a/src/gtk/thread.scm
+++ b/src/gtk/thread.scm
@@ -27,17 +27,27 @@ USA.
 
 (define gtk-thread #f)
 
+;;; With the gtk-thread always running, the runtime system should no
+;;; longer use wait-for-io and thus never signal
+;;; condition-type:no-thread!
+
+;;; GC daemons cannot be allowed to run during a callback.  After-gc
+;;; interrupts are currently serviced with interrupt-mask/timer-ok!,
+;;; which might allow a switch to a different thread, which might
+;;; return from a different callback.
+
+;;; The Gtk system's "GC cleanups" are run by gtk-thread sometime
+;;; after a flip.  The secondary gc daemons are also run by gtk-thread
+;;; after some number of flips.
+
 ;; Number of GCs between applications of trigger-secondary-gc-daemons!
 (define secondary-gc-rate 100)
 
-;;; With the following thread always running, the runtime system
-;;; should no longer use wait-for-io, nor need to signal
-;;; condition-type:no-thread!
-
-;;; Note that GC daemons cannot be allowed to run during a callback.
-;;; After-gc interrupts are currently serviced with
-;;; interrupt-mask/timer-ok!, which might allow a switch to a
-;;; different thread, which might return from a different callback.
+(define (gtk-thread-running?)
+  ;; Used by dependent systems, e.g. gtk-screen, to defer while the
+  ;; Gtks are unavailable, e.g. when "DISPLAY not set".
+  (and gtk-thread (memq (thread-execution-state gtk-thread)
+                       '(RUNNING RUNNING-WITHOUT-PREEMPTION))))
 
 (define (create-gtk-thread)
   (if gtk-thread (error "A GTk thread already exists."))