mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-29 08:20:20 +02:00
Code Activity

Experimental hacks emulating the Guile-iii Tk interface.

Browse source
This commit is contained in:
Mikael Djurfeldt 1997-03-01 02:04:54 +00:00
parent 7dd98e0b20
commit c7ec19832b
3 changed files with 549 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

377
ice-9/gtcl.scm Normal file
View file

@ -0,0 +1,377 @@
;;;; 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 gtcl) :use-module (ice-9 debug))
(define-public TCL_VERSION "7.4")
(define-public TCL_MAJOR_VERSION 7)
(define-public TCL_MINOR_VERSION 4)
;;; When a TCL command returns, the string pointer interp->result points to
;;; a string containing return information from the command. In addition,
;;; the command procedure returns an integer value, which is one of the
;;; following:
;;;
;;; TCL_OK Command completed normally; interp->result contains
;;; the command's result.
;;; TCL_ERROR The command couldn't be completed successfully;
;;; interp->result describes what went wrong.
;;; TCL_RETURN The command requests that the current procedure
;;; return; interp->result contains the procedure's
;;; return value.
;;; TCL_BREAK The command requests that the innermost loop
;;; be exited; interp->result is meaningless.
;;; TCL_CONTINUE Go on to the next iteration of the current loop;
;;; interp->result is meaningless.
;;;
(define-public TCL_OK 0)
(define-public TCL_ERROR 1)
(define-public TCL_RETURN 2)
(define-public TCL_BREAK 3)
(define-public TCL_CONTINUE 4)
;;; Flag values passed to variable-related procedures.
;;;
(define-public TCL_GLOBAL_ONLY 1)
(define-public TCL_APPEND_VALUE 2)
(define-public TCL_LIST_ELEMENT 4)
(define-public TCL_TRACE_READS #x10)
(define-public TCL_TRACE_WRITES #x20)
(define-public TCL_TRACE_UNSETS #x40)
(define-public TCL_TRACE_DESTROYED #x80)
(define-public TCL_INTERP_DESTROYED #x100)
(define-public TCL_LEAVE_ERR_MSG #x200)
;;; Flag values to pass to TCL_DoOneEvent to disable searches
;;; for some kinds of events:
;;;
(define-public TCL_DONT_WAIT 2)
(define-public TCL_X_EVENTS 4)
(define-public TCL_FILE_EVENTS 8)
(define-public TCL_TIMER_EVENTS #x10)
(define-public TCL_IDLE_EVENTS #x20)
(define-public TCL_ALL_EVENTS -3)
;; A convenience function for combining flag bits. Like logior, but
;; handles the cases of 0 and 1 arguments.
;;
(define (flags . args)
(cond
((null? args) 0)
((null? (cdr args)) (car args))
(else (apply logior args))))
;; MDJ 961023 <djurfeldt@nada.kth.se>
(define-public (tcl-eval . strings)
; (pk 'cmd strings)
(let* ((cmd (tcl-merge the-interpreter (map ->tcl-arg-string strings)))
(status (tcl-global-eval the-interpreter cmd)))
(if (zero? (car status))
(cdr status)
(error (cdr status)))))
(define uniq-command
(let ((cnt 0))
(lambda (prefix)
(set! cnt (+ cnt 1))
(string-append prefix (number->string cnt)))))
(define (closure->tcl-name p)
;(let ((tcl-name (procedure-property p 'tcl-name)))
;(or #f tcl-name
(let ((name (uniq-command ;(or (procedure-property p 'name)
"*__guile#"))
;(template (procedure-property p 'tcl-calling-convention)))
)
(tcl-create-command the-interpreter name p)
;(set-procedure-property! p 'tcl-name name)
name))
(define (->tcl-arg-string v)
(cond
((symbol? v) v)
((keyword? v) (keyword-dash-symbol v))
((string? v) v)
((number? v) (number->string v))
((eq? #f v) "0")
((eq? #t v) "1")
((closure? v)
(let ((cc (procedure-property v 'tcl-calling-convention)))
(if cc
(string-append (closure->tcl-name v) " " cc)
(closure->tcl-name v))))
(else "")))
(define (tcl-args args)
(cond ((null? args) '())
((symbol? (car args))
(cons (car args) (tcl-args (cdr args))))
((keyword? (car args))
(cons (keyword-dash-symbol (car args)) (tcl-args (cdr args))))
((string? (car args))
(cons (car args) (tcl-args (cdr args))))
((number? (car args))
(cons (number->string (car args)) (tcl-args (cdr args))))
((eq? #f (car args))
(cons "0" (tcl-args (cdr args))))
((eq? #t (car args))
(cons "1" (tcl-args (cdr args))))
((closure? (car args))
(let ((cc (procedure-property (car args) 'tcl-calling-convention)))
(if cc
(cons (string-append (closure->tcl-name (car args)) " " cc)
(tcl-args (cdr args)))
(cons (closure->tcl-name (car args))
(tcl-args (cdr args))))))
(else "")))
;; MDJ 961023 <djurfeldt@nada.kth.se>
(define-public (tcl-command interp name)
(let ((proc
(lambda args
(let ((status (tcl-global-eval
the-interpreter
(tcl-merge interp (map ->tcl-arg-string
(cons name args))))))
(if (zero? (car status))
(cdr status)
(throw 'tcl-error (cdr status)))))))
(set-procedure-property! proc 'name name)
proc))
;; Reifying a Tcl command as a Scheme procedure.
;;
;(define-public (reify-tcl-command interp name)
; (let ((command-object (tcl-command interp name)))
; (and command-object
; (let ((reified
; (lambda args
; (let ((answer
; (tcl-apply-command command-object
; (map (lambda (a)
; (or (procedure-property a 'tk-command)
; a))
; args))))
; (if (eq? 0 (car answer))
; (tcl-string-> (cdr answer))
; (throw 'tcl-error (cdr answer)))))))
; (set-procedure-property! reified 'tk-command name)
; reified))))
(define-public reify-tcl-command tcl-command)
(define-public (tcl-command? p)
(and (procedure? p) (procedure-property 'tcl-command)))
;; Evaluate some code in the scope of a TCL-ERROR handler.
;; The handler returns a conventional Tcl error value (i.e. (cons 1 message))
;; Some type conversion is automaticly done on the return value to put it
;; in a form Tcl will like.
;;
(defmacro-public with-tcl-error-handling body
`(catch 'tcl-error
(lambda () (->tcl-string (begin ,@body)))
(lambda (tag . message)
(cons 1 (apply errcat message)))))
(define (errcat . args)
(apply string-append
(map (lambda (x)
(call-with-output-string
(lambda (p)
((if (string? x) display write) x p)
(display " " p))))
args)))
;; If this is defined to be an unary function, it gets to extend the
;; default type conversion rules for arguments (it is passed otherwise
;; unhandled values).
;;
(define-public tcl-type-converter #f)
;; Default conversions from Scheme to Tcl strings.
;;
(define-public (->tcl-string val)
(cond
((string? val) val)
((symbol? val) val)
((number? val) (number->string val))
((eq? #f val) "0")
((eq? #t val) "1")
((keyword? val) (keyword->symbol val))
(#t "")))
(define (that x) x)
;; Default conversions from Tcl strings to Scheme.
;;
(define-public (tcl-string-> val)
(cond
((string->number val) => that)
((equal? "" val) #f)
(#t val)))
;;; {An Implicit Default Interpreter}
;;;
;;; For programs like "wish" in which there is one designated default
;;; interpreter.
;;;
(define-public the-interpreter #f)
;; Use defined-tcl-command to extend the global namespace
;; with commands from the default Tcl interpreter.
;;
;(define-public (use-default-tcl-commands)
; (set! *top-level-lookup-thunk* defined-tcl-command))
;; If there is a defined variable called NAME, return it.
;; If not, but there is a Tcl command in the default interpreter
;; called NAME, create a variable an initialize it to point to the
;; reified Tcl command.
;;
;; Finally, always return a variable, perhaps undefined, if DEFINING?
;; is a true value.
;;
(define-public (make-tcl-binder interp)
(lambda (m s define?)
(if define?
(let ((b (make-undefined-variable s)))
(module-obarray-set! (module-obarray m) s b)
(if (tcl-defined? the-interpreter s)
(variable-set! b (tcl-command interp s)))
b)
(and (tcl-defined? interp s)
(let ((b (make-undefined-variable s)))
(module-obarray-set! (module-obarray m) s b)
(variable-set! b (tcl-command interp s))
b)))))
;; Used to define Scheme procedures which are also Tcl commands.
;; The declarations syntax is;
;;
;; (proc name (?<calling-convention>? ?.? <formals>) <body>)
;;
;; which is expanded in terms of tcl-lambda.
;;
(defmacro-public proc (name . spec)
`(begin
(define ,name (tcl-lambda ,@ spec))
(tcl-create-command the-interpreter ',name ,name)))
;; Used to define an anonymous Scheme procedure which is suitable
;; for use as a Tcl command.
;;
;; The declaration syntax is:
;;
;; (tcl-lambda (?<calling-convention>? ?.? <formals>) <body>)
;;
;; A <calling-convention> is a string that describes how the procedure
;; should be called when it is used as a Tcl command.
;; If the procedure hash the tcl-name PROC, and the calling convention
;; "%x %y", then the procedure will be called as:
;;
;; PROC %x %y
;;
;; Such calling conventions are useful in cases such as binding a Scheme
;; procedure to Tk event.
;;
;; Formals specifications are as usual except that non-rest parameters
;; can have declarations. Declarations are arbitrary expressions in which
;; the name of the formal is in the second position. The expressions are
;; evaluated in the scope of the formals, and may modify the formals by
;; side effect. Declarations should return a false value to cause an error
;; to be thrown, a true value otherwise.
;;
(defmacro-public tcl-lambda (formals . body)
(let* ((calling-convention (if (and (pair? formals)
(string? (car formals)))
(let ((a (car formals)))
(set! formals (cdr formals))
a)
#f))
(args (tcl-formals-vars formals))
(full-body `(begin
,@(tcl-type-checks formals 1)
,@body)))
`(let ((proc (lambda ,args
(with-tcl-error-handling ,full-body))))
,@(if calling-convention
`((set-procedure-property! proc
'tcl-calling-convention
,calling-convention)
proc)
`(proc)))))
;; From a list of formals, perhaps with declarations, return the
;; formals <<e.g. (a (tcl->int b) . c) => (a b . c) >>
;;
(define-public (tcl-formals-vars formals)
(if (not (pair? formals))
formals
(cons (if (pair? (car formals))
(cadar formals)
(car formals))
(tcl-formals-vars (cdr formals)))))
(define-public (tcl-error . args)
(apply throw (cons 'tcl-error args)))
(define-public (tcl-type-checks formals pos)
(cond
((not (pair? formals)) '())
((not (pair? (car formals)))
(tcl-type-checks (cdr formals) (+ 1 pos)))
(#t (cons (tcl-type-check (car formals))
(tcl-type-checks (cdr formals) (+ 1 pos))))))
(define-public tcl-type-converters
`( (number . ,(lambda (x) (tcl->number x))) ))
(define (tcl-type-check x)
(let ((a (assoc (car x) tcl-type-converters)))
(if (not a)
(error "Unsupported declaration" x)
(list 'set! (cadr x) (cons (cdr a) (cdr x))))))
(define-public (tcl->number x)
(cond ((string? x) (string->number x))
((integer? x) x)
(#t (tcl-error "Expected integer but got" x))))
;;; To support stack handling:
(define v (builtin-variable 'tk-stack-mark))
(variable-set! v ->tcl-string)

90
ice-9/gwish.scm Normal file
View file

@ -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))
(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)))

82
ice-9/nonblocking.scm Normal file
View file

@ -0,0 +1,82 @@
;;;; Copyright (C) 1996 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! *
;;; *******************************
;;; {Non-blocking ports}
;;;
(define-module (ice-9 nonblocking)
:use-module (ice-9 threads))
(define mu (make-mutex))
(define-public repl-input-port-condvar (make-condition-variable))
(define non-blocking-input #f)
(define-public (make-non-blocking-port wait-port read-port)
(letrec ((read-char-fn (lambda args
(if (char-ready? wait-port)
(read-char read-port)
(begin
(wait-condition-variable repl-input-port-condvar
mu)
(unlock-mutex mu)
(read-char-fn))))))
(make-soft-port
(vector #f #f #f
read-char-fn
(lambda () (close-port orig-port)))
"r")))
(define-public repl-input-port (current-input-port))
(define-public basic-repl-input-port repl-input-port)
(define-public handle-input-events
(lambda ()
(if (single-active-thread?)
(select (list basic-repl-input-port) '() '()))
(if (char-ready? basic-repl-input-port)
(signal-condition-variable repl-input-port-condvar)
(yield))))
(define (kick)
(call-with-new-thread
(lambda ()
(error-catching-loop
(lambda ()
(let loop ()
(handle-input-events)
(loop)))))
(lambda args args)))
(define-public (activate-non-blocking-input)
(if (not non-blocking-input)
(begin
(set! repl-input-port (make-non-blocking-port basic-repl-input-port
(current-input-port)))
(set-current-input-port repl-input-port)
(kick)
(set! non-blocking-input #t))))