(load (in-vicinity (library-vicinity) "Gtcl"))
(load (in-vicinity (library-vicinity) "Gtk"))

;;; {Convenient slib tricks}
;;;

(require 'hash-table)
(define aref (hash-inquirer equal?))
(define aset! (hash-associator equal?))
(define (make-table) (make-hash-table 64))


;;; {The Interpreter}
;;;

(set! the-interpreter (tcl-create-interp))
(let ((init-status (tk-init-main-window the-interpreter (or (getenv "DISPLAY") ":0") "gwish" "Gwish")))
  (if (not (eq? #t init-status))
      (error init-status)))
(use-default-tcl-commands)


;;; {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)




(define (kw-find l kw)
  (and (pair? l)
       (or (and (eq? kw (car l)) l)
	   (kw-find (cdr l) kw))))
(define (kw-ref l kw)
  (let ((f (kw-find l kw)))
    (and (pair? f) (pair? (cdr f)) (cadr f))))
(define (kw-set! l kw v)
  (let ((f (kw-find l kw)))
    (if (and (pair? f) (pair? (cdr f)))
	(begin
	  (set-car! (cdr f) v)
	  l)
	(cons kw (cons v l)))))
(define (kw-set l kw v)
  (kw-set! (map (lambda (x) x) l) kw v))

  


;; We run two threads managed using call/cc.  One thread is a stand-alone
;; repl, the other thread is an tk command loop.
;; 
;; Some procedures only work from one or the other of these two threads,
;; so this flag is used to keep track of which is active:
;;
(define tk-executing #t)

;; As an example of when tk-executing is useful, here is how
;; interrupt signals are handled:
;;
(define (user-interrupt)
  (if (or tk-executing callout-executing)
      (display "Tk executing; interrupt ignored.\n")
      (error 'interrupt)))


(define original-input-port *stdin*)

;; stand-alone-repl -- invoke by stand-alone guile at the end of
;; initialization.
;; 
;; This procedure creates the two threads and defines the procedures
;; used to switch between them.
;;
(set! guile-prompt "tk-guile> ")
(define (stand-alone-repl)
  (let* (
	 ; When suspended, the two threads are represented by continuations.
	 ;
	 (repl-continuation #f)
	 (tk-continuation #f)

	 ; Switch procedures to switch threads.
	 ;
	 (switch-to-repl
	  (lambda ()
	    (set! repl-continuation
		  (call-with-current-continuation repl-continuation))))
	 ;
	 ; In addition to switching, this manages tk-executing:
	 ;
	 (switch-to-tk
	  (lambda ()
	    (set! tk-executing #t)
	    (set! tk-continuation
		  (call-with-current-continuation tk-continuation))
	    (set! tk-executing #f)))

	 ; The standard input port is wrapped in a synthetic port
	 ; that does not block.  Whenever a read on this port would
	 ; block, we switch to the tk thread.  Tk itself uses
	 ; switch-to-repl to return execution to the repl thread when
	 ; input is available on stdin.
	 ;
	 (inport (make-non-blocking-port *stdin* switch-to-tk)))

    (verbose 2)	; go for a chatty repl

    ; The gmain.c code that invokes this procedure would be surprised
    ; if it returned more than once or was non-locally exited.
    ; So, create a new dynamic root (see scm.info):
    ;
    (with-dynamic-root
     (lambda ()

       ; sparc the repl
       ;
       (set! repl-continuation
	     (call-with-current-continuation
	      (lambda (c)
		; Create a continuation that stands for the tk
		; event loop.  That loop hasn't been started yet
		; but is in the continuation of this statement.
		; So, the current continuation is useful as the tk 
		; thread at this point.
		;
		(set! tk-continuation c)
		; reading from the non-blocking port...
		(with-input-from-port inport 
		  ; ...start the repl.
		  (lambda () (%%repl-thunk))))))

       ; We know that the continuation of the preceding statement
       ; is only invoked once even though we captured it.
       ; When it is invoked, sparc the tk command loop.
       ; Scheme errors that occur within the loop are caught within
       ; the loop.
       ;
       (tk-top-level switch-to-repl))

     (lambda (error)
       (cond
	((eq? error repl-quit) #t)

	(else
	 ; We know that errors only reach this point that
	 ; are caused within the repl.  Errors during tk commands
	 ; should't reach this point. (An assertion ought to be inserted
	 ; to check this invariant?).
	 ;
	 ; When the repl bombs out, restart it.
	 ;
	 (with-input-from-port inport
	   (lambda () (%%repl-thunk)))))))))


(define (make-non-blocking-port orig-port switch)
  (letrec ((read-char-fn  (lambda args
			    (if (char-ready? orig-port)
				(let ((answer (read-char orig-port)))
				  answer)
				(begin
				  (switch)
				  (read-char orig-port))))))
    (make-soft-port
     (vector #f #f #f
	     read-char-fn
	     (lambda () (close-port orig-port)))
     "r")))


(define stdin-avail #f)

(define (tk-top-level switch)
  (tk-do-one-event TK_ALL_EVENTS)
  (if (= 0 (tk-num-main-windows))
      (quit))
  (if stdin-avail
      (begin
	(set! stdin-avail #f)
	(switch)))
  (tk-top-level switch))

(proc set-stdin-flag args (set! stdin-avail #t) "")
(fileevent "file 0" 'readable 'set-stdin-flag)
(provide 'Gwish)
