diff options
Diffstat (limited to 'ice-9/gwish.scm')
-rw-r--r-- | ice-9/gwish.scm | 90 |
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))) |