* doc/interp.n: [3081184] TIP #378.

	* doc/tclvars.n: Performance fix for TIP #280.
	* generic/tclBasic.c:
	* generic/tclExecute.c:
	* generic/tclInt.h:
	* generic/tclInterp.c:
	* tests/info.test:
	* tests/interp.test:

2 files changed, 157 insertions, 39 deletions

diff --git a/tests/info.test b/tests/info.test
index b668669..dbf9b18 100644
--- a/tests/info.test
+++ b/tests/info.test
@@ -13,7 +13,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: info.test,v 1.47.2.12 2010/08/03 16:50:49 andreas_kupries Exp $
+# RCS: @(#) $Id: info.test,v 1.47.2.13 2010/11/15 21:32:32 andreas_kupries Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest 2
@@ -689,7 +689,6 @@ test info-21.5 {miscellaneous error conditions} -returnCodes error -body {
 ##
 # ### ### ### ######### ######### #########
 ## info frame
-
 ## Helper
 # For the more complex results we cut the file name down to remove
 # path dependencies, and we use only part of the first line of the
@@ -697,7 +696,6 @@ test info-21.5 {miscellaneous error conditions} -returnCodes error -body {
 # test case may appear in some results, but the result is part of the
 # testcase. An infinite string would be required to describe that. The
 # cutting-down breaks this.
-
 proc reduce {frame} {
     set  pos [lsearch -exact $frame cmd]
     incr pos
@@ -714,7 +712,9 @@ proc reduce {frame} {
     }
     set frame
 }
-
+proc subinterp {} { interp create sub ; interp debug sub -frame 1;
+    interp eval sub [list proc reduce [info args reduce] [info body reduce]]
+}
 ## Helper
 # Generate a stacktrace from the current location to top.  This code
 # not only depends on the exact location of things, but also on the
@@ -1364,14 +1364,14 @@ test info-38.1 {location information for uplevel, dv, direct-var} -match glob -b
 * {type eval line 3 cmd etrace proc ::tcltest::RunTest}
 * {type source line 1362 file info.test cmd {uplevel \\#0 $script} proc ::tcltest::RunTest}}
 
-test info-38.2 {location information for uplevel, dl, direct-literal} -match glob -body {
-    join [lrange [uplevel \#0 {
-	set y DL.
-	etrace
-    }] 0 2] \n
-} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0}
-* {type source line 1370 file info.test cmd etrace proc ::tcltest::RunTest}
-* {type source line 1368 file info.test cmd uplevel\\ \\\\ proc ::tcltest::RunTest}}
+# 38.2 moved to bottom to not disturb other tests with the necessary changes to this one.
+
+
+
+
+
+
+
 
 test info-38.3 {location information for uplevel, dpv, direct-proc-var} -match glob -body {
     set script {
@@ -1384,15 +1384,15 @@ test info-38.3 {location information for uplevel, dpv, direct-proc-var} -match g
 * {type source line 1339 file info.test cmd {uplevel 1 $script} proc ::control}
 * {type source line 1381 file info.test cmd {control y $script} proc ::tcltest::RunTest}}
 
-test info-38.4 {location information for uplevel, dpv, direct-proc-literal} -match glob -body {
-    join [lrange [control y {
-	set y DPL
-	etrace
-    }] 0 3] \n
-} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0}
-* {type source line 1390 file info.test cmd etrace proc ::control}
-* {type source line 1339 file info.test cmd {uplevel 1 $script} proc ::control}
-* {type source line 1388 file info.test cmd control proc ::tcltest::RunTest}}
+# 38.4 moved to bottom to not disturb other tests with the necessary changes to this one.
+
+
+
+
+
+
+
+
 
 test info-38.5 {location information for uplevel, ppv, proc-proc-var} -match glob -body {
     join [lrange [datav] 0 4] \n
@@ -1402,13 +1402,13 @@ test info-38.5 {location information for uplevel, ppv, proc-proc-var} -match glo
 * {type source line 1354 file info.test cmd {control y $script} proc ::datav level 1}
 * {type source line 1398 file info.test cmd datav proc ::tcltest::RunTest}}
 
-test info-38.6 {location information for uplevel, ppl, proc-proc-literal} -match glob -body {
-    join [lrange [datal] 0 4] \n
-} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0}
-* {type source line 1345 file info.test cmd etrace proc ::control}
-* {type source line 1339 file info.test cmd {uplevel 1 $script} proc ::control}
-* {type source line 1343 file info.test cmd control proc ::datal level 1}
-* {type source line 1406 file info.test cmd datal proc ::tcltest::RunTest}}
+# 38.6 moved to bottom to not disturb other tests with the necessary changes to this one.
+
+
+
+
+
+
 
 # -------------------------------------------------------------------------
 # literal sharing
@@ -1536,26 +1536,26 @@ test info-30.12 {bs+nl in computed word, nested eval} {
 } {   type source line 1534 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
 
 test info-30.13 {bs+nl in literal words, uplevel script, with nested words} {
-    uplevel #0 {
+    subinterp ; set res [interp eval sub { uplevel #0 {
 	if {1} \
 	    {
 		set ::res \
 		    [reduce [info frame 0]];# line 1543
 	    }
     }
-    set res
-} {type source line 1543 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
+    set res }] ; interp delete sub ; set res
+} {type source line 1543 file info.test cmd {info frame 0} level 0}
 
 test info-30.14 {bs+nl, literal word, uplevel through proc} {
-    proc abra {script} {
+    subinterp ; set res [interp eval sub { proc abra {script} {
 	uplevel 1 $script
     }
     set res [abra {
 	return "\
-[reduce [info frame 0]]";# line 1555
+ [reduce [info frame 0]]";# line 1555
     }]
     rename abra {}
-    set res
+    set res }] ; interp delete sub ; set res
 } { type source line 1555 file info.test cmd {info frame 0} proc ::abra}
 
 test info-30.15 {bs+nl in literal words, nested proc body, compiled} {
@@ -1742,6 +1742,81 @@ test info-39.1 {location information not confused by literal sharing, bug 293308
 type source line 1722 file info.test cmd print_one proc ::test_info_frame level 1}
 
 # -------------------------------------------------------------------------
+# Tests moved to the end to not disturb other tests and their locations.
+
+test info-38.6 {location information for uplevel, ppl, proc-proc-literal} -match glob -setup {subinterp} -body {
+    interp eval sub {
+	proc etrace {} {
+	    set res {}
+	    set level [info frame]
+	    while {$level} {
+		lappend res [list $level [reduce [info frame $level]]]
+		incr level -1
+	    }
+	    return $res
+	}
+	proc control {vv script} {
+	    upvar 1 $vv var
+	    return [uplevel 1 $script]
+	}
+	proc datal {} {
+	    control y {
+		set y PPL
+		etrace
+	    }
+	}
+	join [lrange [datal] 0 4] \n
+    }
+} -result {* {type source line 1753 file info.test cmd {info frame $level} proc ::etrace level 0}
+* {type source line 1765 file info.test cmd etrace proc ::control}
+* {type source line 1760 file info.test cmd {uplevel 1 $script} proc ::control}
+* {type source line 1763 file info.test cmd control proc ::datal level 1}
+* {type source line 1768 file info.test cmd datal level 2}} -cleanup {interp delete sub}
+
+test info-38.4 {location information for uplevel, dpv, direct-proc-literal} -match glob -setup {subinterp} -body {
+    interp eval sub {
+	proc etrace {} {
+	    set res {}
+	    set level [info frame]
+	    while {$level} {
+		lappend res [list $level [reduce [info frame $level]]]
+		incr level -1
+	    }
+	    return $res
+	}
+	proc control {vv script} {
+	    upvar 1 $vv var
+	    return [uplevel 1 $script]
+	}
+	join [lrange [control y {
+	    set y DPL
+	    etrace
+	}] 0 3] \n
+    }
+} -result {* {type source line 1782 file info.test cmd {info frame $level} proc ::etrace level 0}
+* {type source line 1793 file info.test cmd etrace proc ::control}
+* {type source line 1789 file info.test cmd {uplevel 1 $script} proc ::control}
+* {type source line 1791 file info.test cmd control level 1}} -cleanup {interp delete sub}
+
+test info-38.2 {location information for uplevel, dl, direct-literal} -match glob -setup {subinterp} -body {
+    interp eval sub {
+	proc etrace {} {
+	    set res {}
+	    set level [info frame]
+	    while {$level} {
+		lappend res [list $level [reduce [info frame $level]]]
+		incr level -1
+	    }
+	    return $res
+	}
+	join [lrange [uplevel \#0 {
+	    set y DL.
+	    etrace
+	}] 0 2] \n
+    }
+} -result {* {type source line 1807 file info.test cmd {info frame $level} proc ::etrace level 0}
+* {type source line 1814 file info.test cmd etrace level 1}
+* {type source line 1812 file info.test cmd uplevel\\ \\\\ level 1}} -cleanup {interp delete sub}
 
 # cleanup
 catch {namespace delete test_ns_info1 test_ns_info2}
diff --git a/tests/interp.test b/tests/interp.test
index 3a0c6a5..224ec11 100644
--- a/tests/interp.test
+++ b/tests/interp.test
@@ -10,7 +10,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: interp.test,v 1.54.2.3 2009/12/29 13:13:18 dkf Exp $
+# RCS: @(#) $Id: interp.test,v 1.54.2.4 2010/11/15 21:32:32 andreas_kupries Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest 2.1
@@ -31,7 +31,7 @@ test interp-1.1 {options for interp command} {
 } {1 {wrong # args: should be "interp cmd ?arg ...?"}}
 test interp-1.2 {options for interp command} {
     list [catch {interp frobox} msg] $msg
-} {1 {bad option "frobox": must be alias, aliases, bgerror, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}}
+} {1 {bad option "frobox": must be alias, aliases, bgerror, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}}
 test interp-1.3 {options for interp command} {
     interp delete
 } ""
@@ -49,13 +49,13 @@ test interp-1.6 {options for interp command} {
 } {1 {wrong # args: should be "interp slaves ?path?"}}
 test interp-1.7 {options for interp command} {
     list [catch {interp hello} msg] $msg
-} {1 {bad option "hello": must be alias, aliases, bgerror, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}}
+} {1 {bad option "hello": must be alias, aliases, bgerror, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}}
 test interp-1.8 {options for interp command} {
     list [catch {interp -froboz} msg] $msg
-} {1 {bad option "-froboz": must be alias, aliases, bgerror, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}}
+} {1 {bad option "-froboz": must be alias, aliases, bgerror, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}}
 test interp-1.9 {options for interp command} {
     list [catch {interp -froboz -safe} msg] $msg
-} {1 {bad option "-froboz": must be alias, aliases, bgerror, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}} 
+} {1 {bad option "-froboz": must be alias, aliases, bgerror, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}} 
 test interp-1.10 {options for interp command} {
     list [catch {interp target} msg] $msg
 } {1 {wrong # args: should be "interp target path alias"}}
@@ -3503,6 +3503,49 @@ test interp-37.1 {safe interps and min() and max(): Bug 2895741} -setup {
     interp delete a
 } -result {26 26}
 
+test interp-38.1 {interp debug one-way switch} -setup {
+    catch {interp delete a}
+    interp create a
+    interp debug a -frame 1
+} -body {
+    # TIP #3xx interp debug frame is a one-way switch
+    interp debug a -frame 0
+} -cleanup {
+    interp delete a
+} -result {1}
+test interp-38.2 {interp debug env var} -setup {
+    catch {interp delete a}
+    set ::env(TCL_INTERP_DEBUG_FRAME) 1
+    interp create a
+} -body {
+    interp debug a
+} -cleanup {
+    unset ::env(TCL_INTERP_DEBUG_FRAME)
+    interp delete a
+} -result {-frame 1}
+test interp-38.3 {interp debug wrong args} -body {
+    interp debug
+} -returnCodes {
+    error
+} -result {wrong # args: should be "interp debug path ?-frame ?bool??"}
+test interp-38.4 {interp debug basic setup} -body {
+    interp debug {}
+} -result {-frame 0}
+test interp-38.5 {interp debug basic setup} -body {
+    interp debug {} -f
+} -result {0}
+test interp-38.6 {interp debug basic setup} -body {
+    interp debug -frames
+} -returnCodes error -result {could not find interpreter "-frames"}
+test interp-38.7 {interp debug basic setup} -body {
+    interp debug {} -frames
+} -returnCodes error -result {bad debug option "-frames": must be -frame}
+test interp-38.8 {interp debug basic setup} -body {
+    interp debug {} -frame 0 bogus
+} -returnCodes {
+    error
+} -result {wrong # args: should be "interp debug path ?-frame ?bool??"}
+
 # cleanup
 foreach i [interp slaves] {
     interp delete $i