summaryrefslogtreecommitdiff
path: root/ice-9/gwish.scm
diff options
context:
space:
mode:
Diffstat (limited to 'ice-9/gwish.scm')
-rw-r--r--ice-9/gwish.scm90
1 files changed, 90 insertions, 0 deletions
diff --git a/ice-9/gwish.scm b/ice-9/gwish.scm
new file mode 100644
index 000000000..8efff185d
--- /dev/null
+++ b/ice-9/gwish.scm
@@ -0,0 +1,90 @@
+;;;; Copyright (C) 1996, 1997 Mikael Djurfeldt
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;;;;
+;;;; The author can be reached at djurfeldt@nada.kth.se
+;;;; Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
+;;;;
+
+
+;;; *******************************
+;;; * Experimental hack *
+;;; * Shouldn't go into snapshots *
+;;; * Don't distribute! *
+;;; *******************************
+
+(define-module (ice-9 gwish)
+ :use-module (guile)
+ :use-module (ice-9 threads)
+ :use-module (ice-9 nonblocking)
+ :use-module (ice-9 gtcl))
+
+
+;;; {The Interpreter}
+;;;
+
+(set! the-interpreter (tcl-create-interp))
+
+(define gtcl-module (local-ref '(app modules ice-9 gtcl)))
+(define tcl-binder (make-tcl-binder the-interpreter))
+
+(set-module-binder! (module-public-interface gtcl-module) tcl-binder)
+
+;;; {Namespace cleaning}
+;;;
+
+;; These are the names of procedures already defined
+;; in Scheme but which, in this context, ought to refer
+;; to Tcl/Tk commands.
+
+(define override-scheme-list '(bind raise))
+
+(for-each
+ (lambda (name)
+ (eval `(set! ,name (reify-tcl-command the-interpreter ',name))))
+ override-scheme-list)
+
+;;; {Non-blocking ports}
+
+(define stdin-avail #t)
+
+(proc set-stdin-flag args (set! stdin-avail #t) "")
+
+(define wait TCL_ALL_EVENTS)
+(define dont-wait (+ wait TCL_DONT_WAIT))
+
+(set! handle-input-events
+ (lambda ()
+ (cond ((single-active-thread?) (tcl-do-one-event wait))
+ ((zero? (tcl-do-one-event dont-wait))
+ (yield)
+ ))
+ (if stdin-avail
+ (begin
+ (set! stdin-avail #f)
+ (signal-condition-variable repl-input-port-condvar)))))
+
+(fileevent 'stdin 'readable 'set-stdin-flag)
+
+(activate-non-blocking-input)
+
+;;; {The application window}
+
+(let ((init-status (tk-init-main-window the-interpreter
+ (or (getenv "DISPLAY") ":0")
+ "gwish"
+ "Gwish")))
+ (if (not (eq? #t init-status))
+ (error init-status)))