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
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
|
# Create a single word alias (proc) for one or more words
# e.g. alias x info exists
# if {[x var]} ...
proc alias {name args} {
set prefix $args
proc $name args prefix {
tailcall {*}$prefix {*}$args
}
}
# Creates an anonymous procedure
proc lambda {arglist args} {
set name [ref {} function lambda.finalizer]
tailcall proc $name $arglist {*}$args
}
proc lambda.finalizer {name val} {
rename $name {}
}
# Like alias, but creates and returns an anonyous procedure
proc curry {args} {
set prefix $args
lambda args prefix {
tailcall {*}$prefix {*}$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
}
# Tcl 8.5 lassign
proc lassign {list args} {
# in case the list is empty...
lappend list {}
uplevel 1 [list foreach $args $list break]
lrange $list [llength $args] end-1
}
# 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] $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
}
|
