stdlib.tcl

   1 # Implements script-based standard commands for Jim Tcl
   2
   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]
   7         }
   8 }
   9
  10 # Creates an anonymous procedure
  11 proc lambda {arglist args} {
  12         tailcall proc [ref {} function lambda.finalizer] $arglist {*}$args
  13 }
  14
  15 proc lambda.finalizer {name val} {
  16         rename $name {}
  17 }
  18
  19 # Like alias, but creates and returns an anonyous procedure
  20 proc curry {args} {
  21         alias [ref {} function lambda.finalizer] {*}$args
  22 }
  23
  24 # Returns the given argument.
  25 # Useful with 'local' as follows:
  26 #   proc a {} {...}
  27 #   local function a
  28 #
  29 #   set x [lambda ...]
  30 #   local function $x
  31 #
  32 proc function {value} {
  33         return $value
  34 }
  35
  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]
  44         }
  45         return $trace
  46 }
  47
  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 "
  57                         }
  58                 }
  59                 if {$f ne ""} {
  60                         append line "at file \"$f\", line $l"
  61                 }
  62                 if {$line ne ""} {
  63                         lappend lines $line
  64                 }
  65         }
  66         join $lines \n
  67 }
  68
  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
  74 }
  75
  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]
  84         }
  85         lassign $stacktrace p f l
  86         if {$f ne ""} {
  87                 set result "$f:$l: Error: "
  88         }
  89         append result "$msg\n"
  90         append result [stackdump $stacktrace]
  91
  92         # Remove the trailing newline
  93         string trim $result
  94 }
  95
  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
 101         }
 102 }
 103
 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]
 111                 }
 112         }
 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
 120                         }
 121                 }
 122         }
 123         return {*}$opts $msg
 124 }
 125
 126 proc {dict replace} {dictionary {args {key value}}} {
 127         if {[llength ${key value}] % 2} {
 128                 tailcall {dict replace}
 129         }
 130         tailcall dict merge $dictionary ${key value}
 131 }
 132
 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]
 138         }
 139         lappend list {*}$value
 140         dict set dict $key $list
 141 }
 142
 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]
 148         }
 149         append str {*}$value
 150         dict set dict $key $str
 151 }
 152
 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]
 158         }
 159         incr value $increment
 160         dict set dict $key $value
 161 }
 162
 163 # Script-based implementation of 'dict remove'
 164 proc {dict remove} {dictionary {args key}} {
 165         foreach k $key {
 166                 dict unset dictionary $k
 167         }
 168         return $dictionary
 169 }
 170
 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"
 175         }
 176         dict size $dictionary
 177         tailcall foreach $vars $dictionary $script
 178 }