pstk.scm

; PS/Tk -- A Portable Scheme Interface to the Tk GUI Toolkit
; Copyright (C) 2021-2022 Daniil Archangelsky aka Kiky Tokamuro
; Copyright (C) 2008 Kenneth A Dickey
; Copyright (C) 2006-2008 Nils M Holm
; Copyright (C) 2004 Wolf-Dieter Busch
; All rights reserved.
;
; Redistribution and use in source and binary forms, with or without
; modification, are permitted provided that the following conditions
; are met:
; 1. Redistributions of source code must retain the above copyright
;    notice, this list of conditions and the following disclaimer.
; 2. Redistributions in binary form must reproduce the above copyright
;    notice, this list of conditions and the following disclaimer in the
;    documentation and/or other materials provided with the distribution.
;
; THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
; OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
; SUCH DAMAGE.
;
; PS/Tk is based on Chicken/Tk by Wolf-Dieter Busch (2004):
; http://wolf-dieter-busch.de/html/Software/Tools/ChickenTk.htm
; which is in turn based on Scheme_wish by Sven Hartrumpf (1997, 1998):
; http://pi7.fernuni-hagen.de/hartrumpf/scheme_wish.scm
;
; These are the changes that I (Nils) made to turn Chicken/Tk into PS/Tk:
;
; - Removed all Chicken-isms except for PROCESS.
; - All PS/Tk function names begin with TK/ or TK-:
;     EVAL-WISH   --> TK-EVAL-WISH
;     GET-TK-VAR  --> TK-GET-VAR
;     SET-TK-VAR! --> TK-SET-VAR!
;     START-TK    --> TK-START
;     END-TK      --> TK-END
;     EVENT-LOOP  --> TK-EVENT-LOOP
; - Added TK-DISPATCH-EVENT.
; - Added TK-WAIT-FOR-WINDOW because TK/WAIT returned too early.
; - Removed some unused functions and variables.
; - Replaced keyword lists with property lists.
; - Removed ScrolledText compound widget.
; - Removed :WIDGET-NAME option.
; - Added a PLT Scheme version of RUN-PROGRAM.
;
; Contributions (in order of appearance):
; - Jens Axel Soegaard: PLT Scheme/Windows RUN-PROGRAM.
; - Taylor R Campbell: Scheme48 RUN-PROGRAM, portable GENSYM, and some R5RS
;   portability fixes.
; - Jeffrey T. Read: Gambit hacks (RUN-PROGRAM, keyword hack).
; - Marc Feeley: Various versions of RUN-PROGRAM (Bigloo, Gauche, Guile,
;   Kawa, Scsh, Stklos), SRFI-88 keyword auto-detection, some bug fixes.
; - David St-Hilaire: suggested catching unspecific value in form->string.
; - Ken Dickey: added Ikarus Scheme
; - Ken Dickey: added Larceny Scheme
; Thank you!
;
; Change Log:
; 2022-03-07 Added tk-throw for turn Tk error to Scheme errors
;            Added application termination in case of error in pipe to scheme process
; 2022-03-05 Rewrited on Guile module
;            Changed "_IONBF" to 'none
; 2021-12-01 Deleted all non Guile sections.
;            Changed "set-batch-mode?!" to "ensure-batch-mode!".
;            Deleted the "bottom" function call.
; 2008-06-22 Added Larceny Scheme support.
; 2008-02-29 Added R6RS (Ikarus Scheme) support, added TTK/STYLE.
; 2007-06-27 Renamed source file to pstk.scm.
; 2007-06-27 Re-factored some large procedures, applied some cosmetics.
; 2007-06-26 FORM->STRING catches unspecific values now, so event handlers
;            no longer have to return specific values.
; 2007-06-26 Re-imported the following ports from the processio/v1 snowball:
;            Bigloo, Gauche, Guile, Kawa, Scsh, Stklos.
; 2007-06-26 Added auto-detection of SRFI-88 keywords.
; 2007-03-03 Removed callback mutex, because it blocked some redraw
;            operations. Use TK-WITH-LOCK to protect critical sections.
; 2007-02-03 Added Tile support: TTK-MAP-WIDGETS, TTK/AVAILABLE-THEMES,
;            TTK/SET-THEME.
; 2007-01-20 Added (Petite) Chez Scheme port.
; 2007-01-06 Fix: TK-WAIT-FOR-WINDOW requires nested callbacks.
; 2007-01-05 Added code to patch through fatal TCL messages.
; 2007-01-05 Protected call-backs by a mutex, so accidental double
;            clicks, etc cannot mess up program state.
; 2006-12-21 Made FORM->STRING accept '().
; 2006-12-18 Installing WM_DELETE_WINDOW handler in TK-START now, so it does
;            not get reset in TK-EVENT-LOOP.
; 2006-12-18 Made TK-START and TK-END return () instead of #<unspecific>
;            (which crashes FORM->STRING).
; 2006-12-12 Fixed some wrong Tcl quotation (introduced by myself).
; 2006-12-09 Added TK/BELL procedure.
; 2006-12-08 Replaced ATOM->STRING by FORM->STRING.
; 2006-12-06 Added TK-WAIT-UNTIL-VISIBLE.
; 2006-12-03 Made more variables local to outer LETREC.
; 2006-12-03 Added Gambit port and keywords hack.
; 2006-12-02 Added Scheme 48 port, portable GENSYM, R5RS fixes.
; 2006-12-02 Added PLT/Windows port.

(define-module (pstk)
  #:export (*wish-program*
	    *wish-debug-input*
	    *wish-debug-output*
	    tk
	    tk-throw
	    tk-dispatch-event
	    tk-end
	    tk-eval
	    tk-event-loop
	    tk-get-var
	    tk-id->widget
	    tk-set-var!
	    tk-start
	    tk-var
	    tk-wait-for-window
	    tk-wait-until-visible
	    tk-with-lock
	    tk/after
	    tk/appname
	    tk/bell
	    tk/bgerror
	    tk/bind
	    tk/bindtags
	    tk/caret
	    tk/choose-color
	    tk/choose-directory
	    tk/clipboard
	    tk/destroy
	    tk/dialog
	    tk/event
	    tk/focus
	    tk/focus-follows-mouse
	    tk/focus-next
	    tk/focus-prev
	    tk/get-open-file
	    tk/get-save-file
	    tk/grab
	    tk/grid
	    tk/image
	    tk/lower
	    tk/message-box
	    tk/option
	    tk/pack
	    tk/place
	    tk/popup
	    tk/raise
	    tk/scaling
	    tk/selection
	    tk/update
	    tk/useinputmethods
	    tk/wait
	    tk/windowingsystem
	    tk/winfo
	    tk/wm
	    ttk-map-widgets
	    ttk/available-themes
	    ttk/set-theme
	    ttk/style))

(use-modules (srfi srfi-88))

(define *wish-program* "tclsh")
(define *wish-debug-input* #f)
(define *wish-debug-output* #f)

(define *use-keywords?*
  (or (not (symbol? 'text:))
      (not (symbol? ':text))
      (string=? "text" (symbol->string 'text:))
      (string=? "text" (symbol->string ':text))))

(define tk #f)
(define tk-dispatch-event #f)
(define tk-end #f)
(define tk-eval #f)
(define tk-event-loop #f)
(define tk-get-var #f)
(define tk-id->widget #f)
(define tk-set-var! #f)
(define tk-start #f)
(define tk-var #f)
(define tk-wait-for-window #f)
(define tk-wait-until-visible #f)
(define tk-with-lock #f)
(define tk/after #f)
(define tk/appname #f)
(define tk/bell #f)
(define tk/bgerror #f)
(define tk/bind #f)
(define tk/bindtags #f)
(define tk/caret #f)
(define tk/choose-color #f)
(define tk/choose-directory #f)
(define tk/clipboard #f)
(define tk/destroy #f)
(define tk/dialog #f)
(define tk/event #f)
(define tk/focus #f)
(define tk/focus-follows-mouse #f)
(define tk/focus-next #f)
(define tk/focus-prev #f)
(define tk/get-open-file #f)
(define tk/get-save-file #f)
(define tk/grab #f)
(define tk/grid #f)
(define tk/image #f)
(define tk/lower #f)
(define tk/message-box #f)
(define tk/option #f)
(define tk/pack #f)
(define tk/place #f)
(define tk/popup #f)
(define tk/raise #f)
(define tk/scaling #f)
(define tk/selection #f)
(define tk/update #f)
(define tk/useinputmethods #f)
(define tk/wait #f)
(define tk/windowingsystem #f)
(define tk/winfo #f)
(define tk/wm #f)
(define ttk-map-widgets #f)
(define ttk/available-themes #f)
(define ttk/set-theme #f)
(define ttk/style #f)

(define tk-throw
  (let ((enabled #f))
    (lambda (args)
      (if (null? args)
	  enabled
	  (set! enabled (car args))))))

(define ->string
  (lambda (x)
    (cond ((string? x) x)
	  ((symbol? x) (symbol->string x))
	  ((char?   x) (string x))
	  ((number? x) (number->string x))
	  (else 
	   (let ((out (open-output-string)))
	     (display x out)
	     (get-output-string out))))))

(letrec
  ((nl (string #\newline))
   (wish-input #f)
   (wish-output #f)
   (tk-is-running #f)
   (tk-ids+widgets '())
   (tk-widgets '())
   (commands-invoked-by-tk '())
   (inverse-commands-invoked-by-tk '())
   (in-callback #f)
   (callback-mutex #t)
   (ttk-widget-map '())
   (tk-init-string
     (apply string-append
            (apply append
                   (map (lambda (s)
                          (list s (string #\newline)))
			'("package require Tk"
			  "if {[package version tile] != \"\"} {"
			  "    package require tile"
			  "}"
			  ""
			  "namespace eval AutoName {"
			  "    variable c 0"
			  "    proc autoName {{result \\#\\#}} {"
			  "        variable c"
			  "        append result [incr c]"
			  "    }"
			  "    namespace export *"
			  "}"
			  ""
			  "namespace import AutoName::*"
			  ""
			  "proc callToScm {callKey args} {"
			  "    global scmVar"
			  "    if { [catch {"
                          "            set resultKey [autoName]"
                          "            puts \"(call $callKey \\\"$resultKey\\\" $args)\""
                          "            flush stdout"
                          "            vwait scmVar($resultKey)"
                          "            set result $scmVar($resultKey)"
                          "            unset scmVar($resultKey)"
                          "            set result"
			  "        } ]"
			  "    } { exit 1 }"
			  "}"
			  ""
			  "proc tclListToScmList {l} {"
			  "    switch [llength $l] {"
			  "        0 {"
			  "            return ()"
			  "        }"
			  "        1 {"
			  "            if {[string range $l 0 0] eq \"\\#\"} {"
			  "                return $l"
			  "            }"
			  "            if {[regexp {^[0-9]+$} $l]} {"
			  "                return $l"
			  "            }"
			  "            if {[regexp {^[.[:alpha:]][^ ,\\\"\\'\\[\\]\\\\;]*$} $l]} {"
			  "                return $l"
			  "            }"
			  "            set result \\\""
			  "            append result\\"
			  "                [string map [list \\\" \\\\\\\" \\\\ \\\\\\\\] $l]"
			  "            append result \\\""
			  ""
			  "        }"
			  "        default {"
			  "            set result {}"
			  "            foreach el $l {"
			  "                append result \" \" [tclListToScmList $el]"
			  "            }"
			  "            set result [string range $result 1 end]"
			  "            return \"($result)\""
			  "        }"
			  "    }"
			  "}"
			  ""
			  "proc evalCmdFromScm {cmd {properly 0}} {"
			  "    if {[catch {"
			  "        set result [uplevel \\#0 $cmd]"
			  "    } err]} {"
			  "        puts \"(error \\\"[string map [list \\\\ \\\\\\\\ \\\" \\\\\\\"] $err]\\\")\""
			  "    } elseif $properly {"
			  "        puts \"(return [tclListToScmList $result])\""
			  "    } else {"
			  "        puts \"(return \\\"[string map [list \\\\ \\\\\\\\ \\\" \\\\\\\"] $result]\\\")\""
			  "    }"
			  "    flush stdout"
			  "}")))))
   
   (report-error
    (lambda (x)
      (newline)
      (display x)
      (newline)
      (when (tk-throw)
	(error 'tk (->string x)))))

   (run-program
    (lambda (program)
      (letrec
          ((open-i/o-process
            (lambda (prog . args)
              (let ((c2p (pipe))
                    (p2c (pipe)))
		(setvbuf (cdr c2p) 'none)
		(setvbuf (cdr p2c) 'none)
		(let ((pid (primitive-fork)))
                  (cond ((= pid 0)
			 (ensure-batch-mode!)
			 (let ((input-fdes (fileno (car p2c)))
                               (output-fdes (fileno (cdr c2p))))
			   (port-for-each
                            (lambda (pt-entry)
                              (false-if-exception
                               (let ((pt-fileno (fileno pt-entry)))
				 (if (not (or (= pt-fileno input-fdes)
                                              (= pt-fileno output-fdes)))
                                     (close-fdes pt-fileno))))))
			   (cond ((not (= input-fdes 0))
				  (if (= output-fdes 0)
				      (set! output-fdes (dup->fdes 0)))
				  (dup2 input-fdes 0)))
			   (if (not (= output-fdes 1))
                               (dup2 output-fdes 1))
			   (apply execlp prog prog args)))
			(else
			 (close-port (cdr c2p))
			 (close-port (car p2c))
			 (cons (car c2p)
                               (cdr p2c)))))))))
        (let* ((in/out
                (open-i/o-process "/bin/sh" "-c"
                                  (string-append "exec " program)))
               (in (car in/out))
               (out (cdr in/out)))
          (list in out)))))
   
   (flush-output-port force-output)

   (flush-wish
    (lambda ()
      (flush-output-port wish-input)))

   (option?
    (lambda (x)
      (or (and *use-keywords?*
               (keyword? x))
          (and (symbol? x)
               (let* ((s (symbol->string x))
                      (n (string-length s)))
                 (char=? #\: (string-ref s (- n 1))))))))
   
   (make-option-string
    (lambda (x)
      (if (and *use-keywords?*
               (keyword? x))
          (string-append " -" (keyword->string x))
          (let ((s (symbol->string x)))
            (string-append " -" 
			   (substring s 0 (- (string-length s) 1)))))))
   
   (improper-list->string
    (lambda (a first)
      (cond ((pair? a)
             (cons (string-append (if first "" " ")
                                  (form->string (car a)))
                   (improper-list->string (cdr a) #f)))
            ((null? a) '())
            (else (list (string-append " . " (form->string a)))))))
   
   (form->string
    (lambda (x)
      (cond ((eq? #t x) "#t")
            ((eq? #f x) "#f")
            ((number? x) (number->string x))
            ((symbol? x) (symbol->string x))
            ((string? x) x)
            ((null? x) "()")
            ((pair? x)
             (string-append "("
			    (apply string-append
				   (improper-list->string x #t))
			    ")"))
            ((eof-object? x) "#<eof>")
            (else "#<other>"))))
   
   (string-translate
    (lambda (s map)
      (letrec
          ((s-prepend (lambda (s1 s2)
			(cond ((null? s1) s2)
			      (else (s-prepend (cdr s1) (cons (car s1) s2))))))
           (s-xlate (lambda (s r)
		      (cond ((null? s) (reverse r))
			    (else (let ((n (assv (car s) map)))
				    (cond (n (s-xlate (cdr s)
						      (s-prepend (string->list (cdr n)) r)))
					  (else (s-xlate (cdr s)
							 (cons (car s) r))))))))))
	(list->string
         (s-xlate (string->list s) '())))))
   
   (string-trim-left
    (lambda (str)
      (cond ((string=? str "") "")
            ((string=? (substring str 0 1) " ")
             (string-trim-left (substring str 1
					  (string-length str))))
            (else str))))
   
   (get-property
    (lambda (key args . thunk)
      (cond ((null? args)
             (cond ((null? thunk) #f)
		   (else ((car thunk)))))
            ((eq? key (car args))
             (cond ((pair? (cdr args)) (cadr args))
		   (else (report-error (list 'get-property key args)))))
            ((or (not (pair? (cdr args)))
		 (not (pair? (cddr args))))
             (report-error (list 'get-property key args)))
            (else (apply get-property key (cddr args) thunk)))))
   
   (tcl-true?
    (let ((false-values
           `(0 "0" 'false "false" ,(string->symbol "0"))))
      (lambda (obj) (not (memv obj false-values)))))
   
   (widget?
    (lambda (x)
      (and (memq x tk-widgets) #t)))
   
   (call-by-key
    (lambda (key resultvar . args)
      (cond ((and in-callback (pair? callback-mutex)) #f)
            (else (set! in-callback (cons #t in-callback))
		  (let* ((cmd (get-property key commands-invoked-by-tk))
			 (result (apply cmd args))
			 (str (string-trim-left
                               (scheme-arglist->tk-argstring
                                (list result)))))
                    (set-var! resultvar str)
                    (set! in-callback (cdr in-callback))
                    result)))))
   
   (gen-symbol
    (let ((counter 0))
      (lambda ()
        (let ((sym (string-append "g" (number->string counter))))
          (set! counter (+ counter 1))
          (string->symbol sym)))))
   
   (widget-name
    (lambda (x)
      (let ((name (form->string x)))
        (cond ((member name ttk-widget-map)
               (string-append "ttk::" name))
              (else name)))))
   
   (make-widget-by-id
    (lambda (type id . options)
      (let
          ((result
            (lambda (command . args)
              (case command
                ((get-id) id)
                ((create-widget)
                 (let* ((widget-type (widget-name (car args)))
                        (id-prefix (if (string=? id ".") "" id))
                        (id-suffix (form->string (gen-symbol)))
                        (new-id (string-append id-prefix "." id-suffix))
                        (options (cdr args)))
                   (eval-wish
                    (string-append
                     widget-type
                     " "
                     new-id
                     (scheme-arglist->tk-argstring options)))
                   (apply make-widget-by-id
                          (append (list widget-type new-id)
                                  options))))
                ((configure)
                 (cond ((null? args)
			(eval-wish
                         (string-append id " " (form->string command))))
                       ((null? (cdr args))
			(eval-wish
                         (string-append
                          id
                          " "
                          (form->string command)
                          (scheme-arglist->tk-argstring args))))
                       (else
			(eval-wish
                         (string-append
                          id
                          " "
                          (form->string command)
                          (scheme-arglist->tk-argstring args)))
			(do ((args args (cddr args)))
                            ((null? args) '())
                          (let ((key (car args)) (val (cadr args)))
                            (cond ((null? options)
				   (set! options (list key val)))
				  ((not (memq key options))
				   (set! options
					 (cons key (cons val options))))
				  (else (set-car! (cdr (memq key options))
						  val))))))))
                ((cget)
                 (let ((key (car args)))
                   (get-property
                    key
                    options
                    (lambda ()
                      (eval-wish
                       (string-append
                        id
                        " cget"
                        (scheme-arglist->tk-argstring args)))))))
                ((call exec)
                 (eval-wish
                  (string-trim-left
                   (scheme-arglist->tk-argstring args))))
                (else
                 (eval-wish
                  (string-append
                   id
                   " "
                   (form->string command)
                   (scheme-arglist->tk-argstring args))))))))
        (set! tk-widgets (cons result tk-widgets))
        (set! tk-ids+widgets
              (cons (string->symbol id)
                    (cons result tk-ids+widgets)))
        result)))
   
   (scheme-arg->tk-arg
    (lambda (x)
      (cond ((eq? x #f) " 0")
            ((eq? x #t) " 1")
            ((eq? x '()) " {}")
            ((option? x) (make-option-string x))
            ((widget? x) (string-append " " (x 'get-id)))
            ((and (pair? x) (procedure? (car x)))
             (let* ((lambda-term (car x))
                    (rest (cdr x))
                    (l (memq lambda-term
                             inverse-commands-invoked-by-tk))
                    (keystr (if l (form->string (cadr l))
                                (symbol->string (gen-symbol)))))
               (if (not l)
                   (let ((key (string->symbol keystr)))
                     (set! inverse-commands-invoked-by-tk
                           (cons lambda-term
				 (cons key
                                       inverse-commands-invoked-by-tk)))
                     (set! commands-invoked-by-tk
                           (cons key
				 (cons lambda-term
                                       commands-invoked-by-tk)))))
               (string-append " {callToScm "
                              keystr
                              (scheme-arglist->tk-argstring rest)
                              "}")))
            ((procedure? x)
             (scheme-arglist->tk-argstring `((,x))))
            ((list? x)
             (cond ((eq? (car x) '+)
                    (let ((result (string-trim-left
                                   (scheme-arglist->tk-argstring
                                    (cdr x)))))
                      (cond ((string=? result "") " +")
			    ((string=? "{" (substring result 0 1))
                             (string-append
                              " {+ "
                              (substring result 1
					 (string-length result))))
			    (else (string-append " +" result)))))
                   ((and (= (length x) 3)
			 (equal? (car x) (string->symbol "@"))
			 (number? (cadr x))
			 (number? (caddr x)))
                    (string-append
                     "@"
                     (number->string (cadr x))
                     ","
                     (number->string (caddr x))))
                   (else
                    (string-append
                     " {"
                     (string-trim-left
                      (scheme-arglist->tk-argstring x))
                     "}"))))
            ((pair? x)
             (string-append
              " "
              (form->string (car x))
              "."
              (form->string (cdr x))))
            ((string? x)
             (if (string->number x)
                 (string-append " " x)
                 (string-append
                  " \""
                  (string-translate x
				    '((#\\ . "\\\\") (#\" . "\\\"")
				      (#\[ . "\\u005b") (#\] . "\\]")
				      (#\$ . "\\u0024")
				      (#\{ . "\\{") (#\} . "\\}")))
                  "\"")))
            (else (string-append " " (form->string x))))))
   
   (scheme-arglist->tk-argstring
    (lambda (args)
      (apply string-append
             (map scheme-arg->tk-arg
                  args))))
   
   (make-wish-func
    (lambda (tkname)
      (let ((name (form->string tkname)))
        (lambda args
          (eval-wish
           (string-append
            name
            (scheme-arglist->tk-argstring args)))))))
   
   (read-wish
    (lambda ()
      (let ((term (read wish-output)))
        (cond (*wish-debug-output*
               (display "wish->scheme: ")
               (write term)
               (newline)))
        term)))
   
   (wish
    (lambda arguments
      (for-each
       (lambda (argument)
         (cond (*wish-debug-input*
		(display "scheme->wish: ")
		(display argument)
		(newline)))
         (display argument wish-input)
         (newline wish-input)
         (flush-wish))
       arguments)))
   
   (start-wish
    (lambda ()
      (let ((result (run-program *wish-program*)))
        (set! wish-input (cadr result))
        (set! wish-output (car result)))))
   
   (read-line
    (lambda (in)
      (letrec
          ((collect-chars
            (lambda (c s)
              (cond ((or (eof-object? c) (char=? c #\newline))
                     (apply string (reverse s)))
                    (else (collect-chars (read-char in) (cons c s))))))
           (first-char
            (read-char in)))
        (cond ((eof-object? first-char) first-char)
              (else (collect-chars first-char '()))))))
   
   (eval-wish
    (lambda (cmd)
      (wish (string-append
             "evalCmdFromScm \""
             (string-translate cmd
			       '((#\\ . "\\\\") (#\" . "\\\"")))
             "\""))
      (let again ((result (read-wish)))
        (cond ((not (pair? result))
               (report-error (string-append
			      "An error occurred inside Tcl/Tk" nl
			      " --> " (form->string result)
			      " " (read-line wish-output))))
              ((eq? (car result) 'return)
               (cadr result))
              ((eq? (car result) 'call)
               (apply call-by-key (cdr result))
               (again (read-wish)))
              ((eq? (car result) 'error)
               (report-error (string-append
			      "An error occurred inside Tcl/Tk" nl
			      " " cmd nl
			      " --> " (cadr result))))
              (else (report-error result))))))
   
   (id->widget
    (lambda (id)
      (get-property
       (string->symbol (form->string id))
       tk-ids+widgets
       (lambda ()
         (if (tcl-true? (tk/winfo 'exists id))
             (make-widget-by-id
              (tk/winfo 'class id)
              (form->string id))
             #f)))))
   
   (var
    (lambda (varname)
      (set-var! varname "")
      (string-append
       "::scmVar("
       (form->string varname)
       ")")))
   
   (get-var
    (lambda (varname)
      (eval-wish
       (string-append
        "set ::scmVar("
        (form->string varname)
        ")"))))
   
   (set-var!
    (lambda (varname value)
      (eval-wish
       (string-append
        "set ::scmVar("
        (form->string varname)
        ") {"
        (form->string value)
        "}"))))
   
   (start
    (lambda ()
      (start-wish)
      (wish tk-init-string)
      (set! tk-ids+widgets '())
      (set! tk-widgets '())
      (set! in-callback #f)
      (set! tk (make-widget-by-id 'toplevel "." 'class: 'Wish))
      (set! commands-invoked-by-tk '())
      (set! inverse-commands-invoked-by-tk '())
      (tk/wm 'protocol tk 'WM_DELETE_WINDOW end-tk)))
   
   (end-tk
    (lambda ()
      (set! tk-is-running #f)
      (wish "after 200 exit")))
   
   (dispatch-event
    (lambda ()
      (let ((tk-statement (read-wish)))
        (if (and (list? tk-statement)
                 (eq? (car tk-statement) 'call))
            (apply call-by-key (cdr tk-statement))))))
   
   (loop
    (lambda ()
      (cond ((not tk-is-running)
             (if wish-output
		 (tk/wm 'protocol tk 'WM_DELETE_WINDOW '())))
            (else (dispatch-event)
		  (loop)))))
   
   (event-loop
    (lambda ()
      (set! tk-is-running #t)
      (loop)))
   
   (map-ttk-widgets
    (lambda (x)
      (cond ((eq? x 'all)
             (set! ttk-widget-map '("button" "checkbutton" "radiobutton"
                                    "menubutton" "label" "entry" "frame"
                                    "labelframe" "scrollbar" "notebook"
                                    "progressbar" "combobox" "separator"
                                    "scale" "sizegrip" "treeview")))
            ((eq? x 'none)
             (set! ttk-widget-map '()))
            ((pair? x) (set! ttk-widget-map
                             (map form->string x)))
            (else (report-error
                   (string-append
                    "Argument to TTK-MAP-WIDGETS must be "
                    "ALL, NONE or a list of widget types."))))))
   
   (string-split
    (lambda (c s)
      (letrec
          ((split (lambda (i k tmp res)
		    (cond ((= i k)
			   (if (null? tmp) res (cons tmp res)))
			  ((char=? (string-ref s i) c)
			   (split (+ i 1) k "" (cons tmp res)))
			  (else (split (+ i 1) k
				       (string-append tmp
						      (string (string-ref s i)))
				       res))))))
        (reverse (split 0 (string-length s) "" '())))))
   
   (ttk-available-themes
    (lambda ()
      (string-split #\space (eval-wish "ttk::style theme names"))))
   
   (do-wait-for-window
    (lambda (w)
      (dispatch-event)
      (cond ((equal? (tk/winfo 'exists w) "0") '())
            (else (do-wait-for-window w)))))
   
   (wait-for-window
    (lambda (w)
      (let ((outer-allow callback-mutex))
        (set! callback-mutex #t)
        (do-wait-for-window w)
        (set! callback-mutex outer-allow))))
   
   (wait-until-visible
    (lambda (w)
      (tk/wait 'visibility w)))
   
   (lock!
    (lambda ()
      (set! callback-mutex
            (cons callback-mutex #t))))
   
   (unlock!
    (lambda ()
      (if (pair? callback-mutex)
          (set! callback-mutex
                (cdr callback-mutex)))))
   
   (with-lock
    (lambda (thunk)
      (lock!)
      (thunk)
      (unlock!))))

  (set! tk-eval eval-wish)
  (set! tk-id->widget id->widget)
  (set! tk-var var)
  (set! tk-get-var get-var)
  (set! tk-set-var! set-var!)
  (set! tk-start start)
  (set! tk-end end-tk)
  (set! tk-dispatch-event dispatch-event)
  (set! tk-event-loop event-loop)
  (set! tk-wait-for-window wait-for-window)
  (set! tk-wait-until-visible wait-until-visible)
  (set! tk-with-lock with-lock)
  (set! tk/after (make-wish-func 'after))
  (set! tk/bell (make-wish-func 'bell))
  (set! tk/update (make-wish-func 'update))
  (set! tk/clipboard (make-wish-func 'clipboard))
  (set! tk/bgerror (make-wish-func 'bgerror))
  (set! tk/bind (make-wish-func 'bind))
  (set! tk/bindtags (make-wish-func 'bindtags))
  (set! tk/destroy (make-wish-func 'destroy))
  (set! tk/event (make-wish-func 'event))
  (set! tk/focus (make-wish-func 'focus))
  (set! tk/grab (make-wish-func 'grab))
  (set! tk/grid (make-wish-func 'grid))
  (set! tk/image (make-wish-func 'image))
  (set! tk/lower (make-wish-func 'lower))
  (set! tk/option (make-wish-func 'option))
  (set! tk/pack (make-wish-func 'pack))
  (set! tk/place (make-wish-func 'place))
  (set! tk/raise (make-wish-func 'raise))
  (set! tk/selection (make-wish-func 'selection))
  (set! tk/winfo (make-wish-func 'winfo))
  (set! tk/wm (make-wish-func 'wm))
  (set! tk/choose-color (make-wish-func "tk_chooseColor"))
  (set! tk/choose-directory (make-wish-func "tk_chooseDirectory"))
  (set! tk/dialog (make-wish-func "tk_dialog"))
  (set! tk/get-open-file (make-wish-func "tk_getOpenFile"))
  (set! tk/get-save-file (make-wish-func "tk_getSaveFile"))
  (set! tk/message-box (make-wish-func "tk_messageBox"))
  (set! tk/focus-follows-mouse (make-wish-func "tk_focusFollowsMouse"))
  (set! tk/focus-next (make-wish-func "tk_focusNext"))
  (set! tk/focus-prev (make-wish-func "tk_focusPrev"))
  (set! tk/popup (make-wish-func "tk_popup"))
  (set! tk/wait (lambda args (make-wish-func 'tkwait)))
  (set! tk/appname (make-wish-func "tk appname"))
  (set! tk/caret (make-wish-func "tk caret"))
  (set! tk/scaling (make-wish-func "tk scaling"))
  (set! tk/useinputmethods (make-wish-func "tk useinputmethods"))
  (set! tk/windowingsystem (make-wish-func "tk windowingsystem"))
  (set! ttk/available-themes ttk-available-themes)
  (set! ttk/set-theme (make-wish-func "ttk::style theme use"))
  (set! ttk/style (make-wish-func "ttk::style"))
  (set! ttk-map-widgets map-ttk-widgets))