From: Matt Birkholz <matt@birkholz.chandler.az.us>
Date: Mon, 5 Sep 2011 23:10:43 +0000 (-0700)
Subject: Just warn if "DISPLAY not set".  Added gtk-thread-running?.
X-Git-Tag: mit-scheme-pucked-9.2.12~622
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=247535dac95ca85dedbfec47ea25adcc9123b41e;p=mit-scheme.git

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 d6215366c..94d470498 100644
--- 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 1535a9bb8..f7db51471 100644
--- 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 6a65fb867..84f4ad269 100644
--- 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."))