Tk komfortabel 

#!/usr/bin/newlisp

;;
;; file: Tk.lsp
;; provides low-level access to Tcl/Tk
;;

(context 'Tk)

(map set '(myin tcout) (pipe))
(map set '(tcin myout) (pipe))
(process "/usr/bin/wish" tcin tcout)

(define (wish str)
  (write-line myout
    (append
      "if {[catch {puts [" str "]}]}" [text] {
      tk_messageBox -message $errorInfo
      } [/text]))
  (read-line myin))

;;
;; usage example next line:
;;
(wish " bind . <Destroy> {puts {(exit)}} ")

(map constant '(myin tcout tcin myout wish)) 

(define (read-lines chan)
  (local (buf)
    (read chan buf (peek chan))
    (string buf)))

;;
;; process incoming newLISP requests
;;
(define (event-loop (bool true))
  (context MAIN)
  (cond
    ((null? bool) (set 'event-loop-running nil))
    ((null? event-loop-running)
     (set 'event-loop-running true)
     (while event-loop-running
       (local (result)
         (if (catch (eval-string (read-lines myin)) 'result)
             result
             (wish (append
                     "tk_messageBox -icon error -title Error"
                     " -message {" (string result) "}"))))))))

;;
;; file: tk-syntax.lsp
;;

;;
;; String ohne Kontext: 'Tk:a → "a"
;;
(define (string1 s)
  (if (symbol? s)
      (term s)
      (string s)))

;;
;; eval nur, wenn nicht -width, .t, <Return>
;;
(define (evalToStr e)
  (cond ((not (symbol? e))
         (string1 (eval e)))
        ((member ((string1 e) 0) '("-" "." "<"))
         (string1 e))
        ((string1 (eval e)))))

;;
;; evalToStr auf Elemente der Liste a anwenden
;;
(define (argsToList a)
  (map evalToStr a))

;;
;; Lisp-String zu Tcl-String,
;; Sonderzeichen mit Backslash 
;;
(define (escToTcl s)
  (join
    (map (lambda (c)
           (if (member c '(" " "\\" "\"" "{" "}"))
               (append "\\" c)
               c))
         (explode s))))

;;
;; Lisp-Liste zu Tcl-Liste zusammenfügen
;;
(define (argsToTclList a)
  (join (map escToTcl (argsToList a)) " "))

;;
;; Syntax-Maschine
;; Dokumentation siehe HTML
;;
(define-macro (Tk:Tk cmd1 (cmd2 ""))
  (wish
    (append
      (string1 cmd1) " "
      (string1 (if (list? cmd2)
                   (eval cmd2)
                   cmd2)) " "
      (argsToTclList (args)))))


;;
;; file: rep.lsp
;; purpose: read-eval-print loop by Tk text widget
;;

;;
;; tcl script in rep.tcl provides interactive text window
;;
(define (read-eval-print)
  (wish [text]
    destroy .rep
    toplevel .rep
    wm title .rep newLISP
    
    tk appname rep
    
    pack\
    [text .rep.t -font {Mono -15} -undo yes -wrap char\
    -width 40 -height 10 -yscrollcommand ".rep.v set"]\
    -expand yes -fill both -side left
    
    pack\
    [scrollbar .rep.v -orient vertical -command ".rep.t yview"]\
    -side left -fill y
    
    proc newLISP line {
    puts "(Tk:respond $line)"
    }
    
    proc println result {
    .rep.t mark set insert end
    .rep.t insert insert [lindex [list $result] 0]\n
    after idle .rep.t see insert
    }
    
    bind .rep.t <Return> [list apply [list win {
    if {[$win tag ranges sel] eq {}} then {
    set line [$win get {insert linestart} {insert lineend}]
    } else {
    set line [$win get sel.first sel.last]
    }
    newLISP $line
    $win mark set insert end
    $win insert insert \n
    }] %W]
    bind .rep.t <Return> +break
    bind .rep.t <Shift-Return> continue
    [/text])
  (event-loop))

;;
;; escape double quotes the electrical way
;; avoids quoting hell by hand
;;
(define (escape str)
  (join (map (lambda (c)
               (if (member c '("\"" "\\" "$"))
                   (append "\\" c)
                   c))
             (explode str))))

;;
;; print-form of typed Lisp data
;;
(define (typedString el)
  (cond 
    ((string? el) (append "\"" (escape el) "\""))
    ((symbol? el)
     (cond ((= (prefix el) MAIN)
            (term el))
           ((= (prefix el) Tk)
            (append "Tk:" (term el)))
           ((string el))))
    ((list? el) (append {(} (join (map typedString el) { }) {)}))
    ((array? el) (typedString (array-list el)))
    (true (escape (string el)))))

;;
;; the command Tk will send on <Return>
;; "println" is a Tcl script to write in Text window
;;
(define (respond expr)
  (let (a (typedString expr))
    (wish (append "println " (typedString a)))))

(if (2 (main-args))
    (begin
      (map load (2 (main-args)))
      (event-loop true))
    (read-eval-print))

;; eof

19.1.2023