stdlib.tcl

   1 # Creates an anonymous procedure
   2 proc lambda {arglist args} {
   3         tailcall proc [ref {} function lambda.finalizer] $arglist {*}$args
   4 }
   5
   6 proc lambda.finalizer {name val} {
   7         rename $name {}
   8 }
   9
  10 # Like alias, but creates and returns an anonyous procedure
  11 proc curry {args} {
  12         alias [ref {} function lambda.finalizer] {*}$args
  13 }
  14
  15 # Returns the given argument.
  16 # Useful with 'local' as follows:
  17 #   proc a {} {...}
  18 #   local function a
  19 #
  20 #   set x [lambda ...]
  21 #   local function $x
  22 #
  23 proc function {value} {
  24         return $value
  25 }
  26
  27 # Returns a list of proc filename line ...
  28 # with 3 entries for each stack frame (proc),
  29 # (deepest level first)
  30 proc stacktrace {} {
  31         set trace {}
  32         foreach level [range 1 [info level]] {
  33                 lassign [info frame -$level] p f l
  34                 lappend trace $p $f $l
  35         }
  36         return $trace
  37 }
  38
  39 # Returns a human-readable version of a stack trace
  40 proc stackdump {stacktrace} {
  41         set result {}
  42         set count 0
  43         foreach {l f p} [lreverse $stacktrace] {
  44                 if {$count} {
  45                         append result \n
  46                 }
  47                 incr count
  48                 if {$p ne ""} {
  49                         append result "in procedure '$p' "
  50                         if {$f ne ""} {
  51                                 append result "called "
  52                         }
  53                 }
  54                 if {$f ne ""} {
  55                         append result "at file \"$f\", line $l"
  56                 }
  57         }
  58         return $result
  59 }
  60
  61 # Sort of replacement for $::errorInfo
  62 # Usage: errorInfo error ?stacktrace?
  63 proc errorInfo {msg {stacktrace ""}} {
  64         if {$stacktrace eq ""} {
  65                 set stacktrace [info stacktrace]
  66         }
  67         lassign $stacktrace p f l
  68         if {$f ne ""} {
  69                 set result "Runtime Error: $f:$l: "
  70         }
  71         append result "$msg\n"
  72         append result [stackdump $stacktrace]
  73
  74         # Remove the trailing newline
  75         string trim $result
  76 }
  77
  78 # Finds the current executable by searching along the path
  79 # Returns the empty string if not found.
  80 proc {info nameofexecutable} {} {
  81         if {[info exists ::jim_argv0]} {
  82                 if {[string match "*/*" $::jim_argv0]} {
  83                         return [file join [pwd] $::jim_argv0]
  84                 }
  85                 foreach path [split [env PATH ""] $::tcl_platform(pathSeparator)] {
  86                         set exec [file join [pwd] [string map {\\ /} $path] $::jim_argv0]
  87                         if {[file executable $exec]} {
  88                                 return $exec
  89                         }
  90                 }
  91         }
  92         return ""
  93 }
  94
  95 # Script-based implementation of 'dict with'
  96 proc {dict with} {dictVar args script} {
  97         upvar $dictVar dict
  98         set keys {}
  99         foreach {n v} [dict get $dict {*}$args] {
 100                 upvar $n var_$n
 101                 set var_$n $v
 102                 lappend keys $n
 103         }
 104         catch {uplevel 1 $script} msg opts
 105         if {[info exists dict] && [dict exists $dict {*}$args]} {
 106                 foreach n $keys {
 107                         if {[info exists var_$n]} {
 108                                 dict set dict {*}$args $n [set var_$n]
 109                         } else {
 110                                 dict unset dict {*}$args $n
 111                         }
 112                 }
 113         }
 114         return {*}$opts $msg
 115 }
 116
 117 # Script-based implementation of 'dict merge'
 118 # This won't get called in the trivial case of no args
 119 proc {dict merge} {dict args} {
 120         foreach d $args {
 121                 # Check for a valid dict
 122                 dict size $d
 123                 foreach {k v} $d {
 124                         dict set dict $k $v
 125                 }
 126         }
 127         return $dict
 128 }