guile-pstk

A Tk interface for Guile (A fork of (and hopefully a future merge?) https://github.com/kikyTokamuro/guile-pstk/).
Log | Files | Refs | README | LICENSE

tk-init.tcl (2193B)

      1 package require Tk
      2 if {[package version tile] != ""} {
      3     package require tile
      4 }
      5 
      6 namespace eval AutoName {
      7     # This closure is used to return names that are never the same.
      8     # Names are either the argument provided to autoName and the
      9     # counter, or the default ## and the counter.
     10     #
     11     # Examples:
     12     # % # When the argument is "moo":
     13     # % ::AutoName::autoName moo #
     14     # moo1
     15     # % # When there are no provided arguments, the default "##" one is used:
     16     # % ::AutoName::autoName
     17     # ##2
     18     variable c 0
     19     proc autoName {{providedName \#\#}} {
     20         variable c
     21         append providedName [incr c]
     22     }
     23     namespace export *
     24 }
     25 
     26 namespace import AutoName::*
     27 
     28 proc callToScm {callKey args} {
     29     global scmVar
     30     if { [catch {
     31             set resultKey [autoName]
     32             puts "(call $callKey \"$resultKey\" $args)"
     33             flush stdout
     34             vwait scmVar($resultKey)
     35             set result $scmVar($resultKey)
     36             unset scmVar($resultKey)
     37             set result
     38         } ]
     39     } { exit 1 }
     40 }
     41 
     42 proc tclListToScmList {l} {
     43     switch [llength $l] {
     44         0 {
     45             return ()
     46         }
     47         1 {
     48             if {[string range $l 0 0] eq "\#"} {
     49                 return $l
     50             }
     51             if {[regexp {^[0-9]+$} $l]} {
     52                 return $l
     53             }
     54             if {[regexp {^[.[:alpha:]][^ ,\"\'\[\]\\;]*$} $l]} {
     55                 return $l
     56             }
     57             set result \"
     58             append result\
     59                 [string map [list \" \\\" \\ \\\\] $l]
     60             append result \"
     61 
     62         }
     63         default {
     64             set result {}
     65             foreach el $l {
     66                 append result " " [tclListToScmList $el]
     67             }
     68             set result [string range $result 1 end]
     69             return "($result)"
     70         }
     71     }
     72 }
     73 
     74 proc evalCmdFromScm {cmd {properly 0}} {
     75     if {[catch {
     76         set result [uplevel \#0 $cmd]
     77     } err]} {
     78         puts "(error \"[string map [list \\ \\\\ \" \\\"] $err]\")"
     79     } elseif $properly {
     80         puts "(return [tclListToScmList $result])"
     81     } else {
     82         puts "(return \"[string map [list \\ \\\\ \" \\\"] $result]\")"
     83     }
     84     flush stdout
     85 }