release/src/router/usbmodeswitch/jim/stdlib.tcl

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