diff options
Diffstat (limited to 'ice-9/gtcl.scm')
-rw-r--r-- | ice-9/gtcl.scm | 379 |
1 files changed, 379 insertions, 0 deletions
diff --git a/ice-9/gtcl.scm b/ice-9/gtcl.scm new file mode 100644 index 000000000..bacccb043 --- /dev/null +++ b/ice-9/gtcl.scm @@ -0,0 +1,379 @@ +;;;; 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)) + +(read-set! keywords 'prefix) + +(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) |