expr-sugar: $() should return non-error codes
[jimtcl.git] / stdlib.tcl
blob37a80070c346d6a9bd152f3551521ae3734cc566
1 # Implements script-based standard commands for Jim Tcl
3 if {![exists -command ref]} {
4 # No support for references, so create a poor-man's reference just good enough for lambda
5 proc ref {args} {{count 0}} {
6 format %08x [incr count]
10 # Creates an anonymous procedure
11 proc lambda {arglist args} {
12 tailcall proc [ref {} function lambda.finalizer] $arglist {*}$args
15 proc lambda.finalizer {name val} {
16 rename $name {}
19 # Like alias, but creates and returns an anonyous procedure
20 proc curry {args} {
21 alias [ref {} function lambda.finalizer] {*}$args
24 # Returns the given argument.
25 # Useful with 'local' as follows:
26 # proc a {} {...}
27 # local function a
29 # set x [lambda ...]
30 # local function $x
32 proc function {value} {
33 return $value
36 # Returns a live stack trace as a list of proc filename line ...
37 # with 3 entries for each stack frame (proc),
38 # (deepest level first)
39 proc stacktrace {{skip 0}} {
40 set trace {}
41 incr skip
42 foreach level [range $skip [info level]] {
43 lappend trace {*}[info frame -$level]
45 return $trace
48 # Returns a human-readable version of a stack trace
49 proc stackdump {stacktrace} {
50 set lines {}
51 foreach {l f p} [lreverse $stacktrace] {
52 set line {}
53 if {$p ne ""} {
54 append line "in procedure '$p' "
55 if {$f ne ""} {
56 append line "called "
59 if {$f ne ""} {
60 append line "at file \"$f\", line $l"
62 if {$line ne ""} {
63 lappend lines $line
66 join $lines \n
69 # Add the given script to $jim::defer, to be evaluated when the current
70 # procedure exits
71 proc defer {script} {
72 upvar jim::defer v
73 lappend v $script
76 # Sort of replacement for $::errorInfo
77 # Usage: errorInfo error ?stacktrace?
78 proc errorInfo {msg {stacktrace ""}} {
79 if {$stacktrace eq ""} {
80 # By default add the stack backtrace and the live stacktrace
81 set stacktrace [info stacktrace]
82 # omit the procedure 'errorInfo' from the stack
83 lappend stacktrace {*}[stacktrace 1]
85 lassign $stacktrace p f l
86 if {$f ne ""} {
87 set result "$f:$l: Error: "
89 append result "$msg\n"
90 append result [stackdump $stacktrace]
92 # Remove the trailing newline
93 string trim $result
96 # Needs to be set up by the container app (e.g. jimsh)
97 # Returns the empty string if unknown
98 proc {info nameofexecutable} {} {
99 if {[exists ::jim::exe]} {
100 return $::jim::exe
104 # Script-based implementation of 'dict update'
105 proc {dict update} {&varName args script} {
106 set keys {}
107 foreach {n v} $args {
108 upvar $v var_$v
109 if {[dict exists $varName $n]} {
110 set var_$v [dict get $varName $n]
113 catch {uplevel 1 $script} msg opts
114 if {[info exists varName]} {
115 foreach {n v} $args {
116 if {[info exists var_$v]} {
117 dict set varName $n [set var_$v]
118 } else {
119 dict unset varName $n
123 return {*}$opts $msg
126 proc {dict replace} {dictionary {args {key value}}} {
127 if {[llength ${key value}] % 2} {
128 tailcall {dict replace}
130 tailcall dict merge $dictionary ${key value}
133 # Script-based implementation of 'dict lappend'
134 proc {dict lappend} {varName key {args value}} {
135 upvar $varName dict
136 if {[exists dict] && [dict exists $dict $key]} {
137 set list [dict get $dict $key]
139 lappend list {*}$value
140 dict set dict $key $list
143 # Script-based implementation of 'dict append'
144 proc {dict append} {varName key {args value}} {
145 upvar $varName dict
146 if {[exists dict] && [dict exists $dict $key]} {
147 set str [dict get $dict $key]
149 append str {*}$value
150 dict set dict $key $str
153 # Script-based implementation of 'dict incr'
154 proc {dict incr} {varName key {increment 1}} {
155 upvar $varName dict
156 if {[exists dict] && [dict exists $dict $key]} {
157 set value [dict get $dict $key]
159 incr value $increment
160 dict set dict $key $value
163 # Script-based implementation of 'dict remove'
164 proc {dict remove} {dictionary {args key}} {
165 foreach k $key {
166 dict unset dictionary $k
168 return $dictionary
171 # Script-based implementation of 'dict for'
172 proc {dict for} {vars dictionary script} {
173 if {[llength $vars] != 2} {
174 return -code error "must have exactly two variable names"
176 dict size $dictionary
177 tailcall foreach $vars $dictionary $script