mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-08 02:40:17 +02:00
90 lines
2.5 KiB
Scheme
90 lines
2.5 KiB
Scheme
;;;; 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)))
|