commit 5313f88183fcb8c831ad1986ead1d482b5863efe parent 7de67666d36218c22bf84ff60ca03b225f3477a8 Author: Yuval Langer <yuval.langer@gmail.com> Date: Sun, 16 Jun 2024 02:53:37 +0300 Convert the list of Tcl code lines and their conversion code into a simple long assed list. Diffstat:
| M | pstk.scm | | | 153 | ++++++++++++++++++++++++++++++++++++++----------------------------------------- |
1 file changed, 74 insertions(+), 79 deletions(-)
diff --git a/pstk.scm b/pstk.scm @@ -264,85 +264,80 @@ (define in-callback #f) (define callback-mutex #t) (define ttk-widget-map '()) -(define 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" - "}"))))) +(define tk-init-string "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 +}") (define (report-error x) (newline)