jim.c: make lindex work as identity function.
[jimtcl.git] / stdlib.tcl
blobd0256d0c02e6ce26c6ff4fbb6462445b3c501738
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} {
9 rename $name {}
12 # Like alias, but creates and returns an anonyous procedure
13 proc curry {args} {
14 alias [ref {} function lambda.finalizer] {*}$args
17 # Returns the given argument.
18 # Useful with 'local' as follows:
19 # proc a {} {...}
20 # local function a
22 # set x [lambda ...]
23 # local function $x
25 proc function {value} {
26 return $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}} {
33 set trace {}
34 incr skip
35 foreach level [range $skip [info level]] {
36 lappend trace {*}[info frame -$level]
38 return $trace
41 # Returns a human-readable version of a stack trace
42 proc stackdump {stacktrace} {
43 set lines {}
44 foreach {l f p} [lreverse $stacktrace] {
45 set line {}
46 if {$p ne ""} {
47 append line "in procedure '$p' "
48 if {$f ne ""} {
49 append line "called "
52 if {$f ne ""} {
53 append line "at file \"$f\", line $l"
55 if {$line ne ""} {
56 lappend lines $line
59 join $lines \n
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
72 if {$f ne ""} {
73 set result "Runtime Error: $f:$l: "
75 append result "$msg\n"
76 append result [stackdump $stacktrace]
78 # Remove the trailing newline
79 string trim $result
82 # Finds the current executable by searching along the path
83 # Returns the empty string if not found.
84 proc {info nameofexecutable} {} {
85 if {[info exists ::jim_argv0]} {
86 if {[string match "*/*" $::jim_argv0]} {
87 return [file join [pwd] $::jim_argv0]
89 foreach path [split [env PATH ""] $::tcl_platform(pathSeparator)] {
90 set exec [file join [pwd] [string map {\\ /} $path] $::jim_argv0]
91 if {[file executable $exec]} {
92 return $exec
96 return ""
99 # Script-based implementation of 'dict with'
100 proc {dict with} {&dictVar {args key} script} {
101 set keys {}
102 foreach {n v} [dict get $dictVar {*}$key] {
103 upvar $n var_$n
104 set var_$n $v
105 lappend keys $n
107 catch {uplevel 1 $script} msg opts
108 if {[info exists dictVar] && ([llength $key] == 0 || [dict exists $dictVar {*}$key])} {
109 foreach n $keys {
110 if {[info exists var_$n]} {
111 dict set dictVar {*}$key $n [set var_$n]
112 } else {
113 dict unset dictVar {*}$key $n
117 return {*}$opts $msg
120 # Script-based implementation of 'dict update'
121 proc {dict update} {&varName args script} {
122 set keys {}
123 foreach {n v} $args {
124 upvar $v var_$v
125 if {[dict exists $varName $n]} {
126 set var_$v [dict get $varName $n]
129 catch {uplevel 1 $script} msg opts
130 if {[info exists varName]} {
131 foreach {n v} $args {
132 if {[info exists var_$v]} {
133 dict set varName $n [set var_$v]
134 } else {
135 dict unset varName $n
139 return {*}$opts $msg
142 # Script-based implementation of 'dict merge'
143 # This won't get called in the trivial case of no args
144 proc {dict merge} {dict args} {
145 foreach d $args {
146 # Check for a valid dict
147 dict size $d
148 foreach {k v} $d {
149 dict set dict $k $v
152 return $dict
155 proc {dict replace} {dictionary {args {key value}}} {
156 if {[llength ${key value}] % 2} {
157 tailcall {dict replace}
159 tailcall dict merge $dictionary ${key value}
162 # Script-based implementation of 'dict lappend'
163 proc {dict lappend} {varName key {args value}} {
164 upvar $varName dict
165 if {[exists dict] && [dict exists $dict $key]} {
166 set list [dict get $dict $key]
168 lappend list {*}$value
169 dict set dict $key $list
172 # Script-based implementation of 'dict append'
173 proc {dict append} {varName key {args value}} {
174 upvar $varName dict
175 if {[exists dict] && [dict exists $dict $key]} {
176 set str [dict get $dict $key]
178 append str {*}$value
179 dict set dict $key $str
182 # Script-based implementation of 'dict incr'
183 proc {dict incr} {varName key {increment 1}} {
184 upvar $varName dict
185 if {[exists dict] && [dict exists $dict $key]} {
186 set value [dict get $dict $key]
188 incr value $increment
189 dict set dict $key $value
192 # Script-based implementation of 'dict remove'
193 proc {dict remove} {dictionary {args key}} {
194 foreach k $key {
195 dict unset dictionary $k
197 return $dictionary
200 # Script-based implementation of 'dict values'
201 proc {dict values} {dictionary {pattern *}} {
202 dict keys [lreverse $dictionary] $pattern
205 # Script-based implementation of 'dict for'
206 proc {dict for} {vars dictionary script} {
207 if {[llength $vars] != 2} {
208 return -code error "must have exactly two variable names"
210 dict size $dictionary
211 tailcall foreach $vars $dictionary $script