sitetool/runtk.lsp

   1 ; Start a sub process that runs "wish"
   2 ; Use as:
   3 ; (tk ....) to deliver tk (wish) text
   4 ; (tk:hanshake ....) does the same
   5 ; (tk:stop) to stop the sub process
   6 (context 'tk)
   7
   8 (map set '(myin tcout) (pipe))
   9 (map set '(tcin myout) (pipe))
  10
  11 (setf TAG "newLISP: " TAG* (length TAG))
  12
  13 (set 'SUB (process "/usr/bin/wish" tcin tcout))
  14
  15 (define (tk:tk) (apply handshake (args)))
  16
  17 (define (read-tcl (DISCARD nil))
  18   (let ((BUFFER ""))
  19     (when (read myin BUFFER 10000)
  20       (unless DISCARD (println BUFFER)))))
  21
  22 ; function to pass commands to Tcl/Tk
  23 (define (handshake)
  24   (let (str "")
  25     (write-line myout
  26                 (format "if { [catch { puts [%s] }] } { %s }"
  27                         (apply string (args))
  28                         "tk_messageBox -message $errorInfo; exit" ))
  29     (read-tcl true)
  30     str))
  31
  32 (define (load-tcl FILE)
  33   (write myout (read-file FILE)))
  34
  35 (define (read-loop)
  36   (let ((FD nil) (BUFFER))
  37     (while (and (setf FD (net-select (list 0 myin) "r" -1)) (member myin FD))
  38       (when (> (read myin BUFFER 100000))
  39         (if (starts-with BUFFER TAG)
  40             (eval-string (TAG* BUFFER) MAIN)
  41           (println BUFFER)
  42           )))))
  43
  44 (context MAIN)
  45
  46 ;; exit when main window is closed
  47 ;(tk "bind . <Destroy> {puts {newLISP: (exit)}}")
  48
  49 "runtk.lsp"