stdlib.tcl

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