mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-04 22:40:25 +02:00
379 lines
12 KiB
Scheme
379 lines
12 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 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)
|