summaryrefslogtreecommitdiff
path: root/ice-9/gtcl.scm
diff options
context:
space:
mode:
Diffstat (limited to 'ice-9/gtcl.scm')
-rw-r--r--ice-9/gtcl.scm379
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)