1 # Creates an anonymous procedure
2 proc lambda
{arglist args
} {
3 tailcall
proc [ref
{} function lambda.finalizer
] $arglist {*}$args
6 proc lambda.finalizer
{name val
} {
10 # Like alias, but creates and returns an anonyous procedure
12 alias
[ref
{} function lambda.finalizer
] {*}$args
15 # Returns the given argument.
16 # Useful with 'local' as follows:
23 proc function
{value
} {
27 # Returns a live stack trace as a list of proc filename line ...
28 # with 3 entries for each stack frame (proc),
29 # (deepest level first)
30 proc stacktrace
{{skip
0}} {
33 foreach level
[range
$skip [info level
]] {
34 lappend trace {*}[info frame -$level]
39 # Returns a human-readable version of a stack trace
40 proc stackdump
{stacktrace
} {
42 foreach {l f p
} [lreverse
$stacktrace] {
45 append line
"in procedure '$p' "
51 append line
"at file \"$f\", line $l"
60 # Sort of replacement for $::errorInfo
61 # Usage: errorInfo error ?stacktrace?
62 proc errorInfo
{msg
{stacktrace
""}} {
63 if {$stacktrace eq
""} {
64 # By default add the stack backtrace and the live stacktrace
65 set stacktrace
[info stacktrace
]
66 # omit the procedure 'errorInfo' from the stack
67 lappend stacktrace
{*}[stacktrace
1]
69 lassign
$stacktrace p f l
71 set result
"Runtime Error: $f:$l: "
73 append result
"$msg\n"
74 append result
[stackdump
$stacktrace]
76 # Remove the trailing newline
80 # Finds the current executable by searching along the path
81 # Returns the empty string if not found.
82 proc {info nameofexecutable
} {} {
83 if {[info exists
::jim_argv0]} {
84 if {[string match
"*/*" $::jim_argv0]} {
85 return [file join [pwd] $::jim_argv0]
87 foreach path
[split [env PATH
""] $::tcl_platform(pathSeparator
)] {
88 set exec [file join [pwd] [string map
{\\ /} $path] $::jim_argv0]
89 if {[file executable
$exec]} {
97 # Script-based implementation of 'dict with'
98 proc {dict with
} {&dictVar
{args key
} script
} {
100 foreach {n v
} [dict get
$dictVar {*}$key] {
105 catch {uplevel 1 $script} msg opts
106 if {[info exists dictVar
] && ([llength $key] == 0 ||
[dict exists
$dictVar {*}$key])} {
108 if {[info exists var_
$n]} {
109 dict
set dictVar
{*}$key $n [set var_
$n]
111 dict
unset dictVar
{*}$key $n
118 # Script-based implementation of 'dict update'
119 proc {dict
update} {&varName args script
} {
121 foreach {n v
} $args {
123 if {[dict exists
$varName $n]} {
124 set var_
$v [dict get
$varName $n]
127 catch {uplevel 1 $script} msg opts
128 if {[info exists varName
]} {
129 foreach {n v
} $args {
130 if {[info exists var_
$v]} {
131 dict
set varName
$n [set var_
$v]
133 dict
unset varName
$n
140 # Script-based implementation of 'dict merge'
141 # This won't get called in the trivial case of no args
142 proc {dict merge
} {dict args
} {
144 # Check for a valid dict
153 proc {dict replace
} {dictionary
{args
{key value
}}} {
154 if {[llength ${key value
}] % 2} {
155 tailcall
{dict replace
}
157 tailcall dict merge
$dictionary ${key value
}
160 # Script-based implementation of 'dict lappend'
161 proc {dict
lappend} {varName key
{args value
}} {
163 if {[exists dict
] && [dict exists
$dict $key]} {
164 set list [dict get
$dict $key]
166 lappend list {*}$value
167 dict
set dict
$key $list
170 # Script-based implementation of 'dict append'
171 proc {dict
append} {varName key
{args value
}} {
173 if {[exists dict
] && [dict exists
$dict $key]} {
174 set str
[dict get
$dict $key]
177 dict
set dict
$key $str
180 # Script-based implementation of 'dict incr'
181 proc {dict
incr} {varName key
{increment
1}} {
183 if {[exists dict
] && [dict exists
$dict $key]} {
184 set value
[dict get
$dict $key]
186 incr value
$increment
187 dict
set dict
$key $value
190 # Script-based implementation of 'dict remove'
191 proc {dict remove
} {dictionary
{args key
}} {
193 dict
unset dictionary
$k
198 # Script-based implementation of 'dict values'
199 proc {dict values
} {dictionary
{pattern
*}} {
200 dict keys
[lreverse
$dictionary] $pattern
203 # Script-based implementation of 'dict for'
204 proc {dict
for} {vars dictionary script
} {
205 if {[llength $vars] != 2} {
206 return -code error "must have exactly two variable names"
208 dict size
$dictionary
209 tailcall
foreach $vars $dictionary $script