(define TCL_VERSION "7.4")
(define TCL_MAJOR_VERSION 7)
(define 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 TCL_OK		0)
(define TCL_ERROR	1)
(define TCL_RETURN	2)
(define TCL_BREAK	3)
(define TCL_CONTINUE	4)

;;; Flag values passed to variable-related procedures.
;;;

(define TCL_GLOBAL_ONLY		1)
(define TCL_APPEND_VALUE	2)
(define TCL_LIST_ELEMENT	4)
(define TCL_TRACE_READS		#x10)
(define TCL_TRACE_WRITES	#x20)
(define TCL_TRACE_UNSETS	#x40)
(define TCL_TRACE_DESTROYED	#x80)
(define TCL_INTERP_DESTROYED	#x100)
(define TCL_LEAVE_ERR_MSG	#x200)

;; 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))))
      
;; Reifying a Tcl command as a Scheme procedure.
;;
(define (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 args)))
		    (if (eq? 0 (car answer))
			(tcl-string-> (cdr answer))
			(throw 'tcl-error (cdr answer)))))))
	   (set-procedure-property! reified 'tk-command #t)
	   reified))))

(define (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 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 tcl-type-converter #f)

;; Default conversions from Scheme to Tcl strings.
;;
(define (->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 (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 the-interpreter #f)


;; Use defined-tcl-command to extend the global namespace
;; with commands from the default Tcl interpreter.
;;
(define (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 (defined-tcl-command name defining?)
  (let ((answer (builtin-variable name)))
    (and (not (variable-bound? answer))
	 (let ((command (reify-tcl-command the-interpreter name)))
	   (and command
		(variable-set! answer command))))
    (and (or defining?
	     (variable-bound? answer))
	 answer)))


;; 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 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 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 (tcl-formals-vars formals)
  (if (not (pair? formals))
      formals
      (cons (if (pair? (car formals))
		(cadar formals)
		(car formals))
	    (tcl-formals-vars (cdr formals)))))

(define (tcl-error . args)
  (apply throw (cons 'tcl-error args)))


(define (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 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 (tcl->number x)
  (cond ((string? x) (string->number x))
	((integer? x) x)
	(#t (tcl-error "Expected integer but got" x))))


(provide 'Gtcl)
