blob: b4a9a69a7bb3a5a2403d858b79614fabfb321a4c (
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
|
# 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
}
# 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
}
|
