blob: 2977933d8d449e0e89140862926e534c14cb0b53 (
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
|
# 'Language' utilities that extend and customize base Tcl.
proc fn {name argNames body} {
lassign [uplevel Evaluator::serializeEnvironment] envArgNames envArgValues
set argNames [linsert $argNames 0 {*}$envArgNames]
uplevel [list set ^$name [list apply [list $argNames $body] {*}$envArgValues]]
}
rename unknown _original_unknown
# Trap resolution of commands so that they can call the lambda in
# lexical scope created by `fn`.
proc unknown {name args} {
set err [catch {set fnVar ^$name; upvar $fnVar fn}]
if {$err == 0 && [info exists fn]} {
uplevel [list {*}$fn {*}$args]
} else {
uplevel [list _original_unknown $name {*}$args]
}
}
namespace eval dictset {
namespace export create add union difference entries size
proc create {args} {
set kvs [list]
foreach k $args { lappend kvs $k true }
dict create {*}$kvs
}
proc add {sv entry} { upvar $sv s; dict set s $entry true }
proc union {s t} { dict merge $s $t }
proc difference {s t} {
dict filter $s script {k v} {expr {![dict exists $t $k]}}
}
proc size {s} { dict size $s }
proc entries {s} { dict keys $s }
namespace ensemble create
}
# Trim indentation in multiline quoted text.
proc undent {msg {whitespaceChars " "}} {
set msgLines [split $msg "\n"]
set maxLength [string length $msg]
set regExp [subst -nocommands {([$whitespaceChars]*)[^$whitespaceChars]}]
set indent [
tcl::mathfunc::min {*}[
lmap x $msgLines {
if {[regexp $regExp $x match whitespace]} {
string length $whitespace
} else {
lindex $maxLength
}
}
]
]
join [ltrim [lmap x $msgLines {string range $x $indent end}]] "\n"
}
# Remove empty items at the beginning and the end of a list.
proc ltrim {list} {
set first [lsearch -not -exact $list {}]
set last [lsearch -not -exact [lreverse $list] {}]
return [
if {$first == -1} {
list
} else {
lrange $list $first end-$last
}
]
}
proc lenumerate {l} {
set ret [list]
for {set i 0} {$i < [llength $l]} {incr i} {
lappend ret $i [lindex $l $i]
}
set ret
}
# Create `dict getdef` / `dict getwithdefault`
# Backported from https://core.tcl-lang.org/tips/doc/trunk/tip/342.md
proc dict_getdef {D args} {
if {[dict exists $D {*}[lrange $args 0 end-1]]} then {
dict get $D {*}[lrange $args 0 end-1]
} else {
lindex $args end
}
}
proc python3 {args} {
exec python3 << [undent [join $args " "]]
}
proc assert condition {
set s "{$condition}"
if {![uplevel 1 expr $s]} {
set errmsg "assertion failed: $condition"
try {
if {[lindex $condition 1] eq "eq" && [string index [lindex $condition 0] 0] eq "$"} {
set errmsg "$errmsg\n[uplevel 1 [list set [string range [lindex $condition 0] 1 end]]] is not equal to [lindex $condition 2]"
}
} on error e {}
return -code error $errmsg
}
}
proc baretime body { string map {" microseconds per iteration" ""} [uplevel [list time $body]] }
# forever { ... } is sort of like while true { ... }, but it yields to
# the event loop after each iteration.
proc forever {body} {
while true {
uplevel $body
update
}
}
namespace import ::tcl::mathop::*
namespace import ::tcl::mathfunc::*
|
