debuggers: import openocd-0.7.0
Initial check-in of openocd-0.7.0 as it can be downloaded from http://sourceforge.net/projects/openocd/files/openocd/0.7.0/ Any modifications will follow. Change-Id: I6949beaefd589e046395ea0cb80f4e1ab1654d55
This commit is contained in:
124
debuggers/openocd/jimtcl/nshelper.tcl
Normal file
124
debuggers/openocd/jimtcl/nshelper.tcl
Normal file
@ -0,0 +1,124 @@
|
||||
proc {namespace delete} {args} {
|
||||
foreach name $args {
|
||||
if {$name ni {:: ""}} {
|
||||
set name [uplevel 1 [list ::namespace canon $name]]
|
||||
foreach i [info commands ${name}::*] { rename $i "" }
|
||||
uplevel #0 [list unset {*}[info globals ${name}::*]]
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
proc {namespace origin} {name} {
|
||||
set nscanon [uplevel 1 [list ::namespace canon $name]]
|
||||
if {[exists -alias $nscanon]} {
|
||||
tailcall {namespace origin} [info alias $nscanon]
|
||||
}
|
||||
if {[exists -command $nscanon]} {
|
||||
return ::$nscanon
|
||||
}
|
||||
if {[exists -command $name]} {
|
||||
return ::$name
|
||||
}
|
||||
|
||||
return -code error "invalid command name \"$name\""
|
||||
}
|
||||
|
||||
proc {namespace which} {{type -command} name} {
|
||||
set nsname ::[uplevel 1 [list ::namespace canon $name]]
|
||||
if {$type eq "-variable"} {
|
||||
return $nsname
|
||||
}
|
||||
if {$type eq "-command"} {
|
||||
if {[exists -command $nsname]} {
|
||||
return $nsname
|
||||
} elseif {[exists -command ::$name]} {
|
||||
return ::$name
|
||||
}
|
||||
return ""
|
||||
}
|
||||
return -code error {wrong # args: should be "namespace which ?-command? ?-variable? name"}
|
||||
}
|
||||
|
||||
|
||||
proc {namespace code} {arg} {
|
||||
if {[string first "::namespace inscope " $arg] == 0} {
|
||||
# Already scoped
|
||||
return $arg
|
||||
}
|
||||
list ::namespace inscope [uplevel 1 ::namespace current] $arg
|
||||
}
|
||||
|
||||
proc {namespace inscope} {name arg args} {
|
||||
tailcall namespace eval $name $arg $args
|
||||
}
|
||||
|
||||
proc {namespace import} {args} {
|
||||
set current [uplevel 1 ::namespace canon]
|
||||
|
||||
foreach pattern $args {
|
||||
foreach cmd [info commands [namespace canon $current $pattern]] {
|
||||
alias ${current}::[namespace tail $cmd] $cmd
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# namespace-aware info commands: procs, channels, globals, locals, vars
|
||||
proc {namespace info} {cmd {pattern *}} {
|
||||
set current [uplevel 1 ::namespace canon]
|
||||
# Now we may need to strip $pattern
|
||||
if {[string first :: $pattern] == 0} {
|
||||
set global 1
|
||||
set prefix ::
|
||||
} else {
|
||||
set global 0
|
||||
set clen [string length $current]
|
||||
incr clen 2
|
||||
}
|
||||
set fqp [namespace canon $current $pattern]
|
||||
switch -glob -- $cmd {
|
||||
co* - p* {
|
||||
if {$global} {
|
||||
set result [info $cmd $fqp]
|
||||
} else {
|
||||
# Add commands in the current namespace
|
||||
set r {}
|
||||
foreach c [info $cmd $fqp] {
|
||||
dict set r [string range $c $clen end] 1
|
||||
}
|
||||
if {[string match co* $cmd]} {
|
||||
# Now in the global namespace
|
||||
foreach c [info -nons commands $pattern] {
|
||||
dict set r $c 1
|
||||
}
|
||||
}
|
||||
set result [dict keys $r]
|
||||
}
|
||||
}
|
||||
ch* {
|
||||
set result [info channels $pattern]
|
||||
}
|
||||
v* {
|
||||
#puts "uplevel #0 info gvars $fqp"
|
||||
set result [uplevel #0 info -nons vars $fqp]
|
||||
}
|
||||
g* {
|
||||
set result [info globals $fqp]
|
||||
}
|
||||
l* {
|
||||
set result [uplevel 1 info -nons locals $pattern]
|
||||
}
|
||||
}
|
||||
if {$global} {
|
||||
set result [lmap p $result { set p $prefix$p }]
|
||||
}
|
||||
return $result
|
||||
}
|
||||
|
||||
proc {namespace upvar} {ns args} {
|
||||
set nscanon ::[uplevel 1 [list ::namespace canon $ns]]
|
||||
set script [list upvar 0]
|
||||
foreach {other local} $args {
|
||||
lappend script ${nscanon}::$other $local
|
||||
}
|
||||
tailcall {*}$script
|
||||
}
|
||||
Reference in New Issue
Block a user