1 # Implements script-based standard commands for Jim Tcl
3 # Creates an anonymous procedure
4 proc lambda
{arglist args
} {
5 tailcall
proc [ref
{} function lambda.finalizer
] $arglist {*}$args
8 proc lambda.finalizer
{name val
} {
12 # Like alias, but creates and returns an anonyous procedure
14 alias
[ref
{} function lambda.finalizer
] {*}$args
17 # Returns the given argument.
18 # Useful with 'local' as follows:
25 proc function
{value
} {
29 # Returns a live stack trace as a list of proc filename line ...
30 # with 3 entries for each stack frame (proc),
31 # (deepest level first)
32 proc stacktrace
{{skip
0}} {
35 foreach level
[range
$skip [info level
]] {
36 lappend trace {*}[info frame -$level]
41 # Returns a human-readable version of a stack trace
42 proc stackdump
{stacktrace
} {
44 foreach {l f p
} [lreverse
$stacktrace] {
47 append line
"in procedure '$p' "
53 append line
"at file \"$f\", line $l"
62 # Sort of replacement for $::errorInfo
63 # Usage: errorInfo error ?stacktrace?
64 proc errorInfo
{msg
{stacktrace
""}} {
65 if {$stacktrace eq
""} {
66 # By default add the stack backtrace and the live stacktrace
67 set stacktrace
[info stacktrace
]
68 # omit the procedure 'errorInfo' from the stack
69 lappend stacktrace
{*}[stacktrace
1]
71 lassign
$stacktrace p f l
73 set result
"$f:$l: Error: "
75 append result
"$msg\n"
76 append result
[stackdump
$stacktrace]
78 # Remove the trailing newline
82 # Needs to be set up by the container app (e.g. jimsh)
83 # Returns the empty string if unknown
84 proc {info nameofexecutable
} {} {
85 if {[exists
::jim::exe]} {
90 # Script-based implementation of 'dict update'
91 proc {dict
update} {&varName args script
} {
95 if {[dict exists
$varName $n]} {
96 set var_
$v [dict get
$varName $n]
99 catch {uplevel 1 $script} msg opts
100 if {[info exists varName
]} {
101 foreach {n v
} $args {
102 if {[info exists var_
$v]} {
103 dict
set varName
$n [set var_
$v]
105 dict
unset varName
$n
112 proc {dict replace
} {dictionary
{args
{key value
}}} {
113 if {[llength ${key value
}] % 2} {
114 tailcall
{dict replace
}
116 tailcall dict merge
$dictionary ${key value
}
119 # Script-based implementation of 'dict lappend'
120 proc {dict
lappend} {varName key
{args value
}} {
122 if {[exists dict
] && [dict exists
$dict $key]} {
123 set list [dict get
$dict $key]
125 lappend list {*}$value
126 dict
set dict
$key $list
129 # Script-based implementation of 'dict append'
130 proc {dict
append} {varName key
{args value
}} {
132 if {[exists dict
] && [dict exists
$dict $key]} {
133 set str
[dict get
$dict $key]
136 dict
set dict
$key $str
139 # Script-based implementation of 'dict incr'
140 proc {dict
incr} {varName key
{increment
1}} {
142 if {[exists dict
] && [dict exists
$dict $key]} {
143 set value
[dict get
$dict $key]
145 incr value
$increment
146 dict
set dict
$key $value
149 # Script-based implementation of 'dict remove'
150 proc {dict remove
} {dictionary
{args key
}} {
152 dict
unset dictionary
$k
157 # Script-based implementation of 'dict for'
158 proc {dict
for} {vars dictionary script
} {
159 if {[llength $vars] != 2} {
160 return -code error "must have exactly two variable names"
162 dict size
$dictionary
163 tailcall
foreach $vars $dictionary $script