1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
|
# Creates an anonymous procedure
proc lambda {arglist args} {
tailcall proc [ref {} function lambda.finalizer] $arglist {*}$args
}
proc lambda.finalizer {name val} {
rename $name {}
}
# Like alias, but creates and returns an anonyous procedure
proc curry {args} {
alias [ref {} function lambda.finalizer] {*}$args
}
# Returns the given argument.
# Useful with 'local' as follows:
# proc a {} {...}
# local function a
#
# set x [lambda ...]
# local function $x
#
proc function {value} {
return $value
}
# Returns a list of proc filename line ...
# with 3 entries for each stack frame (proc),
# (deepest level first)
proc stacktrace {} {
set trace {}
foreach level [range 1 [info level]] {
lassign [info frame -$level] p f l
lappend trace $p $f $l
}
return $trace
}
# Returns a human-readable version of a stack trace
proc stackdump {stacktrace} {
set result {}
set count 0
foreach {l f p} [lreverse $stacktrace] {
if {$count} {
append result \n
}
incr count
if {$p ne ""} {
append result "in procedure '$p' "
if {$f ne ""} {
append result "called "
}
}
if {$f ne ""} {
append result "at file \"$f\", line $l"
}
}
return $result
}
# Sort of replacement for $::errorInfo
# Usage: errorInfo error ?stacktrace?
proc errorInfo {msg {stacktrace ""}} {
if {$stacktrace eq ""} {
set stacktrace [info stacktrace]
}
lassign $stacktrace p f l
if {$f ne ""} {
set result "Runtime Error: $f:$l: "
}
append result "$msg\n"
append result [stackdump $stacktrace]
# Remove the trailing newline
string trim $result
}
# Finds the current executable by searching along the path
# Returns the empty string if not found.
proc {info nameofexecutable} {} {
if {[info exists ::jim_argv0]} {
if {[string match "*/*" $::jim_argv0]} {
return [file join [pwd] $::jim_argv0]
}
foreach path [split [env PATH ""] $::tcl_platform(pathSeparator)] {
set exec [file join [pwd] [string map {\\ /} $path] $::jim_argv0]
if {[file executable $exec]} {
return $exec
}
}
}
return ""
}
# Script-based implementation of 'dict with'
proc {dict with} {dictVar args script} {
upvar $dictVar dict
set keys {}
foreach {n v} [dict get $dict {*}$args] {
upvar $n var_$n
set var_$n $v
lappend keys $n
}
catch {uplevel 1 $script} msg opts
if {[info exists dict] && [dict exists $dict {*}$args]} {
foreach n $keys {
if {[info exists var_$n]} {
dict set dict {*}$args $n [set var_$n]
} else {
dict unset dict {*}$args $n
}
}
}
return {*}$opts $msg
}
# Script-based implementation of 'dict merge'
# This won't get called in the trivial case of no args
proc {dict merge} {dict args} {
foreach d $args {
# Check for a valid dict
dict size $d
foreach {k v} $d {
dict set dict $k $v
}
}
return $dict
}
|
