stdlib.tcl

   1 # Implements script-based standard commands for Jim Tcl
   2
   3 # Creates an anonymous procedure
   4 proc lambda {arglist args} {
   5         tailcall proc [ref {} function lambda.finalizer] $arglist {*}$args
   6 }
   7
   8 proc lambda.finalizer {name val} {
   9         rename $name {}
  10 }
  11
  12 # Like alias, but creates and returns an anonyous procedure
  13 proc curry {args} {
  14         alias [ref {} function lambda.finalizer] {*}$args
  15 }
  16
  17 # Returns the given argument.
  18 # Useful with 'local' as follows:
  19 #   proc a {} {...}
  20 #   local function a
  21 #
  22 #   set x [lambda ...]
  23 #   local function $x
  24 #
  25 proc function {value} {
  26         return $value
  27 }
  28
  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]
  37         }
  38         return $trace
  39 }
  40
  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 "
  50                         }
  51                 }
  52                 if {$f ne ""} {
  53                         append line "at file \"$f\", line $l"
  54                 }
  55                 if {$line ne ""} {
  56                         lappend lines $line
  57                 }
  58         }
  59         join $lines \n
  60 }
  61
  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]
  70         }
  71         lassign $stacktrace p f l
  72         if {$f ne ""} {
  73                 set result "$f:$l: Error: "
  74         }
  75         append result "$msg\n"
  76         append result [stackdump $stacktrace]
  77
  78         # Remove the trailing newline
  79         string trim $result
  80 }
  81
  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]} {
  86                 return $::jim::exe
  87         }
  88 }
  89
  90 # Script-based implementation of 'dict update'
  91 proc {dict update} {&varName args script} {
  92         set keys {}
  93         foreach {n v} $args {
  94                 upvar $v var_$v
  95                 if {[dict exists $varName $n]} {
  96                         set var_$v [dict get $varName $n]
  97                 }
  98         }
  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]
 104                         } else {
 105                                 dict unset varName $n
 106                         }
 107                 }
 108         }
 109         return {*}$opts $msg
 110 }
 111
 112 proc {dict replace} {dictionary {args {key value}}} {
 113         if {[llength ${key value}] % 2} {
 114                 tailcall {dict replace}
 115         }
 116         tailcall dict merge $dictionary ${key value}
 117 }
 118
 119 # Script-based implementation of 'dict lappend'
 120 proc {dict lappend} {varName key {args value}} {
 121         upvar $varName dict
 122         if {[exists dict] && [dict exists $dict $key]} {
 123                 set list [dict get $dict $key]
 124         }
 125         lappend list {*}$value
 126         dict set dict $key $list
 127 }
 128
 129 # Script-based implementation of 'dict append'
 130 proc {dict append} {varName key {args value}} {
 131         upvar $varName dict
 132         if {[exists dict] && [dict exists $dict $key]} {
 133                 set str [dict get $dict $key]
 134         }
 135         append str {*}$value
 136         dict set dict $key $str
 137 }
 138
 139 # Script-based implementation of 'dict incr'
 140 proc {dict incr} {varName key {increment 1}} {
 141         upvar $varName dict
 142         if {[exists dict] && [dict exists $dict $key]} {
 143                 set value [dict get $dict $key]
 144         }
 145         incr value $increment
 146         dict set dict $key $value
 147 }
 148
 149 # Script-based implementation of 'dict remove'
 150 proc {dict remove} {dictionary {args key}} {
 151         foreach k $key {
 152                 dict unset dictionary $k
 153         }
 154         return $dictionary
 155 }
 156
 157 # Script-based implementation of 'dict values'
 158 proc {dict values} {dictionary {pattern *}} {
 159         dict keys [lreverse $dictionary] $pattern
 160 }
 161
 162 # Script-based implementation of 'dict for'
 163 proc {dict for} {vars dictionary script} {
 164         if {[llength $vars] != 2} {
 165                 return -code error "must have exactly two variable names"
 166         }
 167         dict size $dictionary
 168         tailcall foreach $vars $dictionary $script
 169 }