examples/tcltk/tcltk.scm

   1 ;==============================================================================
   2
   3 ; File: "tcltk.scm", Time-stamp: <2008-12-15 11:52:55 feeley>
   4
   5 ; Copyright (c) 1997-2008 by Marc Feeley, All Rights Reserved.
   6
   7 ; This is the Gambit interface for Tcl/Tk.
   8
   9 ; To compile this file do:
  10 ;
  11 ; gsc -cc-options "-I/usr/X11R6/include" -ld-options "-L/usr/X11R6/lib -ltk -ltcl -lX11" tcltk.scm
  12
  13 ;==============================================================================
  14
  15 (##namespace ("tcltk#"))
  16
  17 (##include "~~lib/gambit#.scm")
  18
  19 (##include "tcltk#.scm")
  20
  21 (declare
  22   (standard-bindings)
  23   (extended-bindings)
  24   (block)
  25   (not safe)
  26 )
  27
  28 ;==============================================================================
  29
  30 ; The following private procedures are defined in this file:
  31 ;
  32 ;   (##tcltk-setup)                      must be called to initialize module
  33 ;   (##tcltk-cleanup)                    must be called to finalize module
  34 ;   (##tcltk-eval cmd)                   evaluates a Tcl command (a string)
  35 ;   (##tcltk-define-procedure name proc) exports a procedure to Tcl
  36 ;   (##tcltk-export-procedure proc)      exports a procedure to Tcl
  37 ;   (##tcltk-remove-procedure name)      removes a procedure exported to Tcl
  38
  39 ;==============================================================================
  40
  41 ; Low-level stuff needed to export Scheme procedures (including
  42 ; closures) to Tcl.
  43
  44 ; Scheme procedures exported to Tcl become Tcl commands named
  45 ; "_p0", "_p1", etc.  When such a Tcl command is invoked, the
  46 ; Scheme procedure bound to the command is called.
  47
  48 (c-declare #<<c-declare-end
  49
  50 #include <tcl.h>
  51 #include <tk.h>
  52
  53 /*
  54  * tcl_interp is a pointer to the Tcl interpreter.  When it is NULL
  55  * the Tcl interpreter has not yet been initialized.
  56  */
  57
  58 ___HIDDEN Tcl_Interp *tcl_interp = NULL;
  59
  60 /*
  61  * The routine tcltk_setup must be called before any of the Tcl
  62  * procedures are used.  It returns a Boolean indicating if the
  63  * initialization was successful.  Afterwards, the routine
  64  * tcltk_cleanup must be called to do cleanup.
  65  */
  66
  67 ___HIDDEN ___BOOL tcltk_setup
  68    ___P((char *exec_path),
  69         (exec_path)
  70 char *exec_path;)
  71 {
  72   Tcl_FindExecutable (exec_path);
  73
  74   if (tcl_interp != NULL)
  75     Tcl_DeleteInterp (tcl_interp);
  76
  77   tcl_interp = Tcl_CreateInterp ();
  78
  79   if (tcl_interp != NULL)
  80     if (Tcl_Init (tcl_interp) == TCL_ERROR ||
  81         Tk_Init (tcl_interp) == TCL_ERROR)
  82       {
  83         Tcl_DeleteInterp (tcl_interp);
  84         tcl_interp = NULL;
  85       }
  86
  87   return (tcl_interp != NULL);
  88 }
  89
  90 ___HIDDEN void tcltk_cleanup ___PVOID
  91 {
  92   if (tcl_interp != NULL)
  93     {
  94       Tcl_DeleteInterp (tcl_interp);
  95       tcl_interp = NULL;
  96     }
  97 }
  98
  99 /*
 100  * The routine tcltk_eval performs the evaluation of a Tcl command.
 101  */
 102
 103 void tcltk_eval_error ___P((char *msg),());
 104
 105 ___HIDDEN char *tcltk_eval
 106    ___P((char *cmd),
 107         (cmd)
 108 char *cmd;)
 109 {
 110   for (;;)
 111     {
 112       if (tcl_interp == NULL)
 113         tcltk_eval_error ("Tcl not initialized");
 114       else if (Tcl_Eval (tcl_interp, cmd) != TCL_OK)
 115         tcltk_eval_error (tcl_interp->result);
 116       else
 117         break;
 118     }
 119
 120   return tcl_interp->result;
 121 }
 122
 123 /*
 124  * The routine scheme_call_cmd is called by Tcl when a Scheme
 125  * procedure is being called.  The client_data parameter points to a
 126  * reference counted object which contains a vector containing the
 127  * Scheme procedure to call (this indirection is required because the
 128  * Scheme procedure may be a MOVABLE object).  The parameters argc and
 129  * argv specify the arguments to pass to the Scheme procedure.  The
 130  * Scheme procedure receives these arguments as strings and must
 131  * return a string result or the value #f.
 132  */
 133
 134 char *tcltk_call ___P((___SCMOBJ vect, char **args),());
 135
 136 ___HIDDEN int scheme_call_cmd
 137    ___P((ClientData client_data,
 138          Tcl_Interp *interp,
 139          int argc,
 140          const char **argv),
 141         (client_data,
 142          interp,
 143          argc,
 144          argv)
 145 ClientData client_data;
 146 Tcl_Interp *interp;
 147 int argc;
 148 const char **argv;)
 149 {
 150   char *result = tcltk_call (___EXT(___data_rc) (___CAST(void*,client_data)),
 151                              ___CAST(char**,argv+1));
 152
 153   /*
 154    * Propagate result to Tcl.
 155    */
 156
 157   if (result == NULL)
 158     {
 159       Tcl_SetResult (interp,
 160                      "",
 161                      TCL_STATIC);
 162     }
 163   else
 164     {
 165       /*
 166        * The resulting C string was dynamically allocated by
 167        * Gambit's C interface.  We have to ensure it is
 168        * deallocated by a call to ___release_string by Tcl
 169        * when it no longer needs the string.
 170        */
 171
 172       Tcl_SetResult (interp,
 173                      result,
 174                      ___CAST(Tcl_FreeProc*,___EXT(___release_string)));
 175     }
 176
 177   return TCL_OK;
 178 }
 179
 180 /*
 181  * The routine scheme_delete_cmd is called by Tcl when a Tcl command
 182  * bound to a Scheme procedure is being deleted.  The client_data
 183  * parameter points to a reference counted object which contains the
 184  * Scheme procedure.  This object needs to be released so that the
 185  * garbage collector can reclaim the Scheme procedure it contains.
 186  */
 187
 188 ___HIDDEN void scheme_delete_cmd
 189    ___P((ClientData client_data),
 190         (client_data)
 191 ClientData client_data;)
 192 {
 193   ___EXT(___release_scmobj) (___EXT(___data_rc) (___CAST(void*,client_data)));
 194   ___EXT(___release_rc) (___CAST(void*,client_data));
 195 }
 196
 197 c-declare-end
 198 )
 199
 200 ; Initialization/finalization of the Tcl/Tk interface.
 201
 202 (define ##tcltk-active? #f)
 203
 204 (define (##tcltk-setup)
 205   (if (##not ##tcltk-active?)
 206       (begin
 207         ((c-lambda (char-string) bool "tcltk_setup")
 208          (##car (##command-line)))
 209         (set! ##tcltk-active? #t))))
 210
 211 (define (##tcltk-cleanup)
 212   (if ##tcltk-active?
 213       (begin
 214         (set! ##tcltk-active? #f)
 215         ((c-lambda () void "tcltk_cleanup")))))
 216
 217 ; (##tcltk-call vect args) is called by scheme_call_cmd when the
 218 ; Scheme procedure contained in "vect" is being called by Tcl with
 219 ; the list of arguments "args", which is a list of strings.
 220
 221 (c-define (##tcltk-call vect args)
 222           (scheme-object nonnull-char-string-list) char-string "tcltk_call" ""
 223   (let ((proc (##vector-ref vect 0)))
 224     (let ((result (##apply proc args)))
 225       (if (##string? result)
 226           result
 227           #f))))
 228
 229 ; (##tcltk-unique-id) returns a new exact integer each time it is
 230 ; called.
 231
 232 (define ##tcltk-unique-id
 233   (let ((counter 0))
 234     (lambda ()
 235       (let loop ()
 236         (let* ((n counter)
 237                (n+1 (##+ n 1))) ; note: context switch is possible in ##+
 238           (declare (not interrupts-enabled))
 239           (if (##not (##eq? n counter)) ; update counter atomically
 240               (loop)
 241               (begin
 242                 (set! counter n+1)
 243                 n)))))))
 244
 245 ; (##tcltk-export-procedure proc) defines a new Tcl command that
 246 ; invokes the Scheme procedure "proc" (a procedure which accepts
 247 ; string arguments and returns a string result or #f).
 248 ; ##tcltk-export-procedure returns the name of the Tcl command (which
 249 ; is of the form "_pN", where N is an integer).
 250
 251 (define (##tcltk-export-procedure proc)
 252   (let ((id (##tcltk-unique-id)))
 253     (let ((name (##string-append "_p" (##number->string id 10))))
 254       (if (##tcltk-define-procedure name proc)
 255           name
 256           (error "this procedure could not be exported to Tcl:" proc)))))
 257
 258 ; (##tcltk-remove-procedure name) removes a procedure that was
 259 ; exported to Tcl under the name "name".  This allows the Scheme
 260 ; runtime system to reclaim the Scheme procedure.
 261
 262 (define (##tcltk-remove-procedure name)
 263   (##tcltk-eval (##string-append "rename " name " {}")))
 264
 265 ; The call (##tcltk-eval cmd) evaluates the Tcl command "cmd" and
 266 ; returns the evaluation result as a string.  If a Tcl evaluation
 267 ; error occurs, the error will be propagated to Scheme which will
 268 ; signal the error.  tcltk-eval only returns if the Tcl command was
 269 ; evaluated without error.
 270
 271 (define ##tcltk-eval
 272   (c-lambda (char-string) char-string "tcltk_eval"))
 273
 274 (c-define (##tcltk-eval-error msg) (char-string) void "tcltk_eval_error" ""
 275   (error (##string-append "[Tcl evaluation error] " msg))
 276   (##tcltk-eval-error msg)) ; never return
 277
 278 ;------------------------------------------------------------------------------
 279
 280 ; Definition of a Tcl command.
 281 ;
 282 ; The call (##tcltk-define-procedure name proc) defines the Tcl command
 283 ; "name" (a string) to be the Scheme procedure "proc" (a procedure
 284 ; which accepts string arguments and returns a string result or #f).
 285 ; ##tcltk-define-procedure returns #f if the command could not be
 286 ; defined.
 287
 288 (define ##tcltk-define-procedure
 289   (c-lambda (char-string scheme-object)
 290             scheme-object
 291             #<<c-lambda-end
 292
 293   if (tcl_interp == NULL)
 294     ___result = ___FAL;
 295   else
 296     {
 297       void *cd = ___EXT(___alloc_rc) (0);
 298
 299       /*
 300        * "cd" is the client data that will be passed to
 301        * scheme_call_cmd and scheme_delete_cmd.  It is a reference
 302        * counted object that contains a ___STILL Scheme vector
 303        * containing the Scheme procedure.  The routine
 304        * scheme_delete_cmd is responsible for releasing "cd" and the
 305        * Scheme vector.
 306        */
 307
 308       if (cd == NULL)
 309         ___result = ___FAL;
 310       else
 311         {
 312           /*
 313            * Setup the client data.
 314            */
 315
 316           ___SCMOBJ vect = ___EXT(___make_vector) (1, ___FAL, ___STILL);
 317
 318           if (___FIXNUMP(vect))
 319             {
 320               ___EXT(___release_rc) (cd);
 321               ___result = ___FAL;
 322             }
 323           else
 324             {
 325               ___FIELD(vect,0) = ___arg2;
 326               ___EXT(___set_data_rc) (cd, vect);
 327
 328               /*
 329                * Create the Tcl command.
 330                */
 331
 332               ___result = ___BOOLEAN (Tcl_CreateCommand
 333                                         (tcl_interp,
 334                                          ___arg1,
 335                                          scheme_call_cmd,
 336                                          ___CAST(ClientData,cd),
 337                                          scheme_delete_cmd)
 338                                       != NULL);
 339             }
 340         }
 341     }
 342
 343 c-lambda-end
 344 ))
 345
 346 ;------------------------------------------------------------------------------
 347
 348 ; Event loop.
 349
 350 ;(define ##tcltk-main-loop
 351 ;  (c-lambda () void "Tk_MainLoop"))
 352
 353 (define ##tcltk-do-one-event
 354   (c-lambda ()
 355             scheme-object
 356             "___result = ___BOOLEAN (Tcl_DoOneEvent (TCL_DONT_WAIT));"))
 357
 358 (define ##tcltk-event-handling-mutex
 359   (##make-mutex 'tcltk-event-handling-mutex))
 360
 361 (define (tcltk#enable-event-handling)
 362   (mutex-unlock! ##tcltk-event-handling-mutex))
 363
 364 (define (tcltk#disable-event-handling)
 365   (mutex-lock! ##tcltk-event-handling-mutex))
 366
 367 (tcltk#disable-event-handling)
 368
 369 (define ##tcltk-event-loop-thread #f)
 370 (define ##tcltk-exit-should-terminate? #f)
 371
 372 (define (tcltk#start-event-loop-thread)
 373   (if (##not ##tcltk-event-loop-thread)
 374       (set! ##tcltk-event-loop-thread
 375             (##parameterize
 376              ##current-user-interrupt-handler
 377              (lambda () #f) ; prevent user interrupts
 378              (lambda ()
 379                (##thread-start!
 380                 (##make-thread
 381                  (lambda ()
 382                    (let loop ()
 383                      (tcltk#disable-event-handling)
 384                      (tcltk#enable-event-handling)
 385                      (if ##tcltk-active?
 386                          (if (##tcltk-do-one-event) ; polling is portable...
 387                              (begin
 388                                (set! ##tcltk-exit-should-terminate? #t)
 389                                (loop))
 390                              (begin
 391                                (##thread-sleep! 0.03)
 392                                (loop)))))
 393 (pretty-print 'exiting-event-loop)
 394 )
 395                  'tcltk-event-loop
 396                  (##make-tgroup 'tcltk-event-loop #f))))))))
 397
 398 '
 399 (define (tcltk#start-event-loop-thread)
 400   (let loop ()
 401     (if ##tcltk-active?
 402         (if (##tcltk-do-one-event) ; polling is portable...
 403             (begin
 404               (set! ##tcltk-exit-should-terminate? #t)
 405               (loop))
 406             (begin
 407               (##thread-sleep! 0.03)
 408               (loop))))))
 409
 410 (define (tcltk#join-event-loop-thread)
 411   (if ##tcltk-event-loop-thread
 412       (##thread-join! ##tcltk-event-loop-thread #f #f)))
 413
 414 (define (##tcltk-terminate)
 415   (pretty-print (list '(##tcltk-terminate) ##tcltk-exit-should-terminate?: ##tcltk-exit-should-terminate?))
 416   (set! ##tcltk-exit-should-terminate? #t)
 417   (##exit))
 418
 419 (define (##tcltk-exit)
 420   (pretty-print (list '(##tcltk-exit) ##tcltk-exit-should-terminate?: ##tcltk-exit-should-terminate?))
 421   (if ##tcltk-exit-should-terminate?
 422       (##tcltk-cleanup))
 423   (tcltk#enable-event-handling)
 424   (tcltk#join-event-loop-thread)
 425   (##tcltk-cleanup))
 426
 427 ;------------------------------------------------------------------------------
 428
 429 ; Widgets are represented with procedures.
 430
 431 (define tcltk#make-widget #f) ; prevent inlining of tcltk#make-widget
 432 (set! tcltk#make-widget
 433   (lambda (name proc)
 434     (lambda args
 435       (if (and (##pair? args)
 436                (##eq? (##car args) ##tcltk-widget-code))
 437           name
 438           (proc name args)))))
 439
 440 (define tcltk#root-window
 441   (tcltk#make-widget "." ##tcltk-apply))
 442
 443 (define ##tcltk-widget-code
 444   (##closure-code tcltk#root-window))
 445
 446 (define (tcltk#widget? obj)
 447   (and (##procedure? obj)
 448        (##closure? obj)
 449        (##eq? (##closure-code obj) ##tcltk-widget-code)))
 450
 451 (define (tcltk#widget-name widget)
 452   (widget ##tcltk-widget-code))
 453
 454 ;------------------------------------------------------------------------------
 455
 456 ; Construction of Tcl command lines.
 457
 458 (define (##tcltk-cmd-line-begin)
 459   (##list '()))
 460
 461 (define (##tcltk-cmd-line-end cmd-line)
 462   (let ((lst (##car cmd-line)))
 463     (let loop1 ((n 0) (x lst))
 464       (if (##pair? x)
 465           (loop1 (##fixnum.+ n (##string-length (##car x))) (##cdr x))
 466           (let ((result (##make-string n #\space)))
 467             (let loop2 ((k (##fixnum.- n 1)) (x lst))
 468               (if (##pair? x)
 469                   (let ((s (##car x)))
 470                     (let loop3 ((i k) (j (##fixnum.- (##string-length s) 1)))
 471                       (if (##fixnum.< j 0)
 472                           (loop2 i (##cdr x))
 473                           (begin
 474                             (##string-set! result i (##string-ref s j))
 475                             (loop3 (##fixnum.- i 1) (##fixnum.- j 1))))))
 476                   result)))))))
 477
 478 (define (##tcltk-cmd-line-add-string! str cmd-line)
 479   (##set-car! cmd-line (##cons str (##car cmd-line))))
 480
 481 (define (##tcltk-cmd-line-add-substring! str start end cmd-line)
 482   (if (##fixnum.< start end)
 483     (if (and (##fixnum.= start 0) (##fixnum.= end (##string-length str)))
 484         (##tcltk-cmd-line-add-string! str cmd-line)
 485         (##tcltk-cmd-line-add-string! (##substring str start end) cmd-line))))
 486
 487 (define (##tcltk-cmd-line-add-quoted-string! str cmd-line)
 488
 489   (define hex-digits "0123456789abcdef")
 490
 491   (let ((n (##string-length str)))
 492     (let loop ((i 0)
 493                (j 0)
 494                (force-quotes? (##fixnum.= (##string-length str) 0))
 495                (quote-written? #f))
 496
 497       (define (add-quoted-substring!)
 498         (if (##not quote-written?)
 499             (##tcltk-cmd-line-add-string! "\"" cmd-line))
 500         (if (and (##fixnum.= i 0) (##fixnum.= j n))
 501             (##tcltk-cmd-line-add-string! str cmd-line)
 502             (##tcltk-cmd-line-add-string! (##substring str i j) cmd-line)))
 503
 504       (if (##fixnum.< j n)
 505           (let ((c (##string-ref str j)))
 506             (cond ((##char=? c #\space)
 507                    (loop i
 508                          (##fixnum.+ j 1)
 509                          #t
 510                          quote-written?))
 511                   ((or (##char=? c #\") ; characters which need escaping
 512                        (##char=? c #\\)
 513                        (##char=? c #\$)
 514                        (##char=? c #\[)
 515                        (##char=? c #\])
 516                        (##char=? c #\{)
 517                        (##char=? c #\}))
 518                    (add-quoted-substring!)
 519                    (##tcltk-cmd-line-add-string! "\\" cmd-line)
 520                    (loop j
 521                          (##fixnum.+ j 1)
 522                          #t
 523                          #t))
 524                   (else
 525                    (let ((x (##fixnum.<-char c)))
 526                      (cond ((##fixnum.< x 32) ; escape control characters
 527                             (add-quoted-substring!)
 528                             (##tcltk-cmd-line-add-string!
 529                              (##string
 530                               #\\
 531                               #\0
 532                               (##string-ref hex-digits (##fixnum.quotient x 8))
 533                               (##string-ref hex-digits (##fixnum.modulo x 8)))
 534                              cmd-line)
 535                             (loop (##fixnum.+ j 1)
 536                                   (##fixnum.+ j 1)
 537                                   #t
 538                                   #t))
 539                            ((##fixnum.< 255 x) ; escape non-ISO-8859-1 chars
 540                             (add-quoted-substring!)
 541                             (##tcltk-cmd-line-add-string!
 542                              (##string
 543                               #\\
 544                               #\u
 545                               (##string-ref
 546                                hex-digits
 547                                (##fixnum.modulo (##fixnum.quotient x 4096) 16))
 548                               (##string-ref
 549                                hex-digits
 550                                (##fixnum.modulo (##fixnum.quotient x 256) 16))
 551                               (##string-ref
 552                                hex-digits
 553                                (##fixnum.modulo (##fixnum.quotient x 16) 16))
 554                               (##string-ref
 555                                hex-digits
 556                                (##fixnum.modulo x 16)))
 557                              cmd-line)
 558                             (loop (##fixnum.+ j 1)
 559                                   (##fixnum.+ j 1)
 560                                   #t
 561                                   #t))
 562                            (else
 563                             (loop i
 564                                   (##fixnum.+ j 1)
 565                                   force-quotes?
 566                                   quote-written?)))))))
 567           (if (or force-quotes? quote-written?)
 568               (begin
 569                 (add-quoted-substring!)
 570                 (##tcltk-cmd-line-add-string! "\"" cmd-line))
 571               (##tcltk-cmd-line-add-string! str cmd-line))))))
 572
 573 (define (##tcltk-apply command args)
 574   (let ((cmd-line (##tcltk-cmd-line-begin)))
 575
 576     (define (add-quoted-string str)
 577       (##tcltk-cmd-line-add-quoted-string! str cmd-line))
 578
 579     (define (add-quoted obj)
 580       (cond ((##string? obj)
 581              (add-quoted-string obj))
 582             ((##symbol? obj)
 583              (add-quoted-string (##symbol->string obj)))
 584             ((##keyword? obj)
 585              (add-quoted-string (##string-append "-" (##keyword->string obj))))
 586             ((##real? obj)
 587              (add-quoted-string (##number->string obj 10)))
 588             ((tcltk#widget? obj)
 589              (add-quoted-string (tcltk#widget-name obj)))
 590             ((##procedure? obj)
 591              (add-quoted-string (##tcltk-export-procedure obj)))
 592             ((or (##null? obj) (##pair? obj))
 593              (##tcltk-cmd-line-add-string! "{" cmd-line)
 594              (add-quoted-list obj)
 595              (##tcltk-cmd-line-add-string! "}" cmd-line))
 596             ((##eq? obj #t)
 597              (add-quoted-string "true"))
 598             ((##eq? obj #f)
 599              (add-quoted-string "false"))
 600             (else
 601              (error "this argument is incompatible with Tcl:" obj))))
 602
 603     (define (add-quoted-list lst)
 604       (let loop ((lst lst) (first? #t))
 605         (if (##pair? lst)
 606             (let ((arg (##car lst)))
 607               (if (##not first?)
 608                   (##tcltk-cmd-line-add-string! " " cmd-line))
 609               (add-quoted arg)
 610               (loop (##cdr lst) #f)))))
 611
 612     (add-quoted command)
 613     (if (##pair? args)
 614         (begin
 615           (##tcltk-cmd-line-add-string! " " cmd-line)
 616           (add-quoted-list args)))
 617 ;    (display (##tcltk-cmd-line-end cmd-line))(newline)
 618     (##tcltk-eval (##tcltk-cmd-line-end cmd-line))))
 619
 620 (define (##tcltk-widget command path-name-or-parent args)
 621   (let ((path-name
 622          (cond ((tcltk#widget? path-name-or-parent)
 623                 (let* ((id
 624                         (##tcltk-unique-id))
 625                        (suffix
 626                         (##string-append "._w" (##number->string id 10))))
 627                   (if (##eq? path-name-or-parent tcltk#root-window)
 628                       suffix
 629                       (##string-append
 630                        (tcltk#widget-name path-name-or-parent)
 631                        suffix))))
 632                ((##string? path-name-or-parent)
 633                 path-name-or-parent)
 634                (else
 635                 (error "widget path-name must be a string or the parent widget")))))
 636     (tcltk#make-widget
 637      (##tcltk-apply command (##cons path-name args))
 638      ##tcltk-apply)))
 639
 640 ;------------------------------------------------------------------------------
 641
 642 (define (tcltk#set-variable! name val)
 643   (if (##string? name)
 644       (##tcltk-apply "set" (##list name val))
 645       (error "invalid Tcl variable name:" name)))
 646
 647 (define (tcltk#get-variable name)
 648   (if (##string? name)
 649       (##tcltk-apply "set" (##list name))
 650       (error "invalid Tcl variable name:" name)))
 651
 652 ;------------------------------------------------------------------------------
 653
 654 (define (tcltk#define-procedure name proc)
 655   (if (##string? name)
 656       (if (##procedure? proc)
 657           (##tcltk-define-procedure name proc)
 658           (error "procedure expected"))
 659       (error "invalid Tcl procedure name:" name)))
 660
 661 (define (tcltk#export-procedure proc)
 662   (if (##procedure? proc)
 663       (##tcltk-export-procedure proc)
 664       (error "procedure expected")))
 665
 666 (define (tcltk#remove-procedure name)
 667   (if (##string? name)
 668       (##tcltk-remove-procedure name)
 669       (error "invalid Tcl procedure name:" name)))
 670
 671 ;------------------------------------------------------------------------------
 672
 673 (define (tcltk#tcl command . args)
 674   (##tcltk-apply command args))
 675
 676 (define (tcltk#bell . args)
 677   (##tcltk-apply "bell" args))
 678
 679 (define (tcltk#bind . args)
 680   (##tcltk-apply "bind" args))
 681
 682 (define (tcltk#bindtags . args)
 683   (##tcltk-apply "bindtags" args))
 684
 685 (define (tcltk#bitmap . args)
 686   (##tcltk-apply "bitmap" args))
 687
 688 (define (tcltk#button path-name-or-parent . args)
 689   (##tcltk-widget "button" path-name-or-parent args))
 690
 691 (define (tcltk#canvas path-name-or-parent . args)
 692   (##tcltk-widget "canvas" path-name-or-parent args))
 693
 694 (define (tcltk#checkbutton path-name-or-parent . args)
 695   (##tcltk-widget "checkbutton" path-name-or-parent args))
 696
 697 (define (tcltk#clipboard . args)
 698   (##tcltk-apply "clipboard" args))
 699
 700 (define (tcltk#destroy . args)
 701   (##tcltk-apply "destroy" args))
 702
 703 (define (tcltk#entry path-name-or-parent . args)
 704   (##tcltk-widget "entry" path-name-or-parent args))
 705
 706 (define (tcltk#event . args)
 707   (##tcltk-apply "event" args))
 708
 709 (define (tcltk#focus . args)
 710   (##tcltk-apply "focus" args))
 711
 712 (define (tcltk#font . args)
 713   (##tcltk-apply "font" args))
 714
 715 (define (tcltk#frame path-name-or-parent . args)
 716   (##tcltk-widget "frame" path-name-or-parent args))
 717
 718 (define (tcltk#grab . args)
 719   (##tcltk-apply "grab" args))
 720
 721 (define (tcltk#grid . args)
 722   (##tcltk-apply "grid" args))
 723
 724 (define (tcltk#image . args)
 725   (##tcltk-apply "image" args))
 726
 727 (define (tcltk#label path-name-or-parent . args)
 728   (##tcltk-widget "label" path-name-or-parent args))
 729
 730 (define (tcltk#listbox path-name-or-parent . args)
 731   (##tcltk-widget "listbox" path-name-or-parent args))
 732
 733 (define (tcltk#lower . args)
 734   (##tcltk-apply "lower" args))
 735
 736 (define (tcltk#menu path-name-or-parent . args)
 737   (##tcltk-widget "menu" path-name-or-parent args))
 738
 739 (define (tcltk#menubutton path-name-or-parent . args)
 740   (##tcltk-widget "menubutton" path-name-or-parent args))
 741
 742 (define (tcltk#message path-name-or-parent . args)
 743   (##tcltk-widget "message" path-name-or-parent args))
 744
 745 (define (tcltk#option . args)
 746   (##tcltk-apply "option" args))
 747
 748 (define (tcltk#pack . args)
 749   (##tcltk-apply "pack" args))
 750
 751 (define (tcltk#photo . args)
 752   (##tcltk-apply "photo" args))
 753
 754 (define (tcltk#place . args)
 755   (##tcltk-apply "place" args))
 756
 757 (define (tcltk#radiobutton path-name-or-parent . args)
 758   (##tcltk-widget "radiobutton" path-name-or-parent args))
 759
 760 (define (tcltk#raise . args)
 761   (##tcltk-apply "raise" args))
 762
 763 (define (tcltk#scale path-name-or-parent . args)
 764   (##tcltk-widget "scale" path-name-or-parent args))
 765
 766 (define (tcltk#scrollbar path-name-or-parent . args)
 767   (##tcltk-widget "scrollbar" path-name-or-parent args))
 768
 769 (define (tcltk#selection . args)
 770   (##tcltk-apply "selection" args))
 771
 772 (define (tcltk#send . args)
 773   (##tcltk-apply "send" args))
 774
 775 (define (tcltk#text path-name-or-parent . args)
 776   (##tcltk-widget "text" path-name-or-parent args))
 777
 778 (define (tcltk#tk . args)
 779   (##tcltk-apply "tk" args))
 780
 781 (define (tcltk#tk_bisque . args)
 782   (##tcltk-apply "tk_bisque" args))
 783
 784 (define (tcltk#tk_chooseColor . args)
 785   (##tcltk-apply "tk_chooseColor" args))
 786
 787 (define (tcltk#tk_dialog . args)
 788   (##tcltk-apply "tk_dialog" args))
 789
 790 (define (tcltk#tk_focusFollowsMouse . args)
 791   (##tcltk-apply "tk_focusFollowsMouse" args))
 792
 793 (define (tcltk#tk_focusNext . args)
 794   (##tcltk-apply "tk_focusNext" args))
 795
 796 (define (tcltk#tk_focusPrev . args)
 797   (##tcltk-apply "tk_focusPrev" args))
 798
 799 (define (tcltk#tk_getOpenFile . args)
 800   (##tcltk-apply "tk_getOpenFile" args))
 801
 802 (define (tcltk#tk_getSaveFile . args)
 803   (##tcltk-apply "tk_getSaveFile" args))
 804
 805 (define (tcltk#tk_menuSetFocus . args)
 806   (##tcltk-apply "tk_menuSetFocus" args))
 807
 808 (define (tcltk#tk_messageBox . args)
 809   (##tcltk-apply "tk_messageBox" args))
 810
 811 (define (tcltk#tk_optionMenu . args)
 812   (##tcltk-apply "tk_optionMenu" args))
 813
 814 (define (tcltk#tk_popup . args)
 815   (##tcltk-apply "tk_popup" args))
 816
 817 (define (tcltk#tk_setPalette . args)
 818   (##tcltk-apply "tk_setPalette" args))
 819
 820 (define (tcltk#tk_textCopy . args)
 821   (##tcltk-apply "tk_textCopy" args))
 822
 823 (define (tcltk#tk_textCut . args)
 824   (##tcltk-apply "tk_textCut" args))
 825
 826 (define (tcltk#tk_textPaste . args)
 827   (##tcltk-apply "tk_textPaste" args))
 828
 829 (define (tcltk#tkerror . args)
 830   (##tcltk-apply "tkerror" args))
 831
 832 (define (tcltk#tkwait . args)
 833   (##tcltk-apply "tkwait" args))
 834
 835 (define (tcltk#toplevel path-name-or-parent . args)
 836   (##tcltk-widget "toplevel" path-name-or-parent args))
 837
 838 (define (tcltk#winfo . args)
 839   (##tcltk-apply "winfo" args))
 840
 841 (define (tcltk#wm . args)
 842   (##tcltk-apply "wm" args))
 843
 844 (define (tcltk#update . args)
 845   (##tcltk-apply "update" args))
 846
 847 ;------------------------------------------------------------------------------
 848
 849 ; Initialize Tcl/Tk.
 850
 851 (if (##tcltk-setup)
 852
 853     (begin
 854
 855       (##add-exit-job! ##tcltk-exit)
 856
 857       (tcltk#bind root-window
 858                   "<Destroy>"
 859                   ##tcltk-terminate)
 860
 861       (tcltk#bind 'all
 862                   "<F10>"
 863                   (lambda () ((##current-user-interrupt-handler))))
 864
 865       (tcltk#start-event-loop-thread))
 866
 867     (error "could not initialize Tcl/Tk"))
 868
 869 ;==============================================================================