blob: 37a80070c346d6a9bd152f3551521ae3734cc566 (
plain)
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
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
|
# Implements script-based standard commands for Jim Tcl
if {![exists -command ref]} {
# No support for references, so create a poor-man's reference just good enough for lambda
proc ref {args} {{count 0}} {
format %08x [incr count]
}
}
# 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 live stack trace as a list of proc filename line ...
# with 3 entries for each stack frame (proc),
# (deepest level first)
proc stacktrace {{skip 0}} {
set trace {}
incr skip
foreach level [range $skip [info level]] {
lappend trace {*}[info frame -$level]
}
return $trace
}
# Returns a human-readable version of a stack trace
proc stackdump {stacktrace} {
set lines {}
foreach {l f p} [lreverse $stacktrace] {
set line {}
if {$p ne ""} {
append line "in procedure '$p' "
if {$f ne ""} {
append line "called "
}
}
if {$f ne ""} {
append line "at file \"$f\", line $l"
}
if {$line ne ""} {
lappend lines $line
}
}
join $lines \n
}
# Add the given script to $jim::defer, to be evaluated when the current
# procedure exits
proc defer {script} {
upvar jim::defer v
lappend v $script
}
# Sort of replacement for $::errorInfo
# Usage: errorInfo error ?stacktrace?
proc errorInfo {msg {stacktrace ""}} {
if {$stacktrace eq ""} {
# By default add the stack backtrace and the live stacktrace
set stacktrace [info stacktrace]
# omit the procedure 'errorInfo' from the stack
lappend stacktrace {*}[stacktrace 1]
}
lassign $stacktrace p f l
if {$f ne ""} {
set result "$f:$l: Error: "
}
append result "$msg\n"
append result [stackdump $stacktrace]
# Remove the trailing newline
string trim $result
}
# Needs to be set up by the container app (e.g. jimsh)
# Returns the empty string if unknown
proc {info nameofexecutable} {} {
if {[exists ::jim::exe]} {
return $::jim::exe
}
}
# Script-based implementation of 'dict update'
proc {dict update} {&varName args script} {
set keys {}
foreach {n v} $args {
upvar $v var_$v
if {[dict exists $varName $n]} {
set var_$v [dict get $varName $n]
}
}
catch {uplevel 1 $script} msg opts
if {[info exists varName]} {
foreach {n v} $args {
if {[info exists var_$v]} {
dict set varName $n [set var_$v]
} else {
dict unset varName $n
}
}
}
return {*}$opts $msg
}
proc {dict replace} {dictionary {args {key value}}} {
if {[llength ${key value}] % 2} {
tailcall {dict replace}
}
tailcall dict merge $dictionary ${key value}
}
# Script-based implementation of 'dict lappend'
proc {dict lappend} {varName key {args value}} {
upvar $varName dict
if {[exists dict] && [dict exists $dict $key]} {
set list [dict get $dict $key]
}
lappend list {*}$value
dict set dict $key $list
}
# Script-based implementation of 'dict append'
proc {dict append} {varName key {args value}} {
upvar $varName dict
if {[exists dict] && [dict exists $dict $key]} {
set str [dict get $dict $key]
}
append str {*}$value
dict set dict $key $str
}
# Script-based implementation of 'dict incr'
proc {dict incr} {varName key {increment 1}} {
upvar $varName dict
if {[exists dict] && [dict exists $dict $key]} {
set value [dict get $dict $key]
}
incr value $increment
dict set dict $key $value
}
# Script-based implementation of 'dict remove'
proc {dict remove} {dictionary {args key}} {
foreach k $key {
dict unset dictionary $k
}
return $dictionary
}
# Script-based implementation of 'dict for'
proc {dict for} {vars dictionary script} {
if {[llength $vars] != 2} {
return -code error "must have exactly two variable names"
}
dict size $dictionary
tailcall foreach $vars $dictionary $script
}
|
