* tests/info.test: Tests 38.* added, exactly testing the tracking

	of location for uplevel scripts. Resolved merge conflict on
	info-37.0, switched !singleTestInterp constraint to glob matching
	instead. Ditto info-22.8, removed constraint, more glob matching,
	and reduced the depth of the stack we check. More is coming, right
	now I want to commit the bug fixes.

	* tests/oo.test: Updated oo-22.1 for expanded location tracking.

	* generic/tclCompile.c (TclInitCompileEnv): Reorganized the
	initialization of the #280 location information to match the flow
	in TclEvalObjEx to get more absolute contexts.

	* generic/tclBasic.c (TclEvalObjEx): Added missing cleanup of
	extended location information.

2 files changed, 98 insertions, 18 deletions

diff --git a/tests/info.test b/tests/info.test
index a04e7b5..5b83ed2 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.55 2008/07/25 21:24:01 das Exp $
+# RCS: @(#) $Id: info.test,v 1.56 2008/07/25 22:11:21 andreas_kupries Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest 2
@@ -761,16 +761,11 @@ test info-22.6 {info frame, global, relative} {!singleTestInterp} {
 test info-22.7 {info frame, global, absolute} {!singleTestInterp} {
     reduce [info frame 1]
 } {type source line 761 file info.test cmd test\ info-22.7\ \{info\ frame,\ global,\ absolute\}\ \{!singleTestInter level 0}
-test info-22.8 {info frame, basic trace} -constraints {!singleTestInterp} -match glob -body {
-    join [etrace] \n
-} -result {8 {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0}
-7 {type source line 765 file info.test cmd etrace proc ::tcltest::RunTest}
-6 {type source line * file tcltest.tcl cmd {uplevel 1 $script} proc ::tcltest::RunTest}
-5 {type eval line 1 cmd {::tcltest::RunTest info-22} proc ::tcltest::Eval}
-4 {type source line * file tcltest.tcl cmd {uplevel 1 $script} proc ::tcltest::Eval}
-3 {type eval line 1 cmd ::tcltest::Eval\\ \\\{::tcltest::RunTest\\ info-22 proc ::tcltest::test}
-2 {type source line * file tcltest.tcl cmd {uplevel 1 \[list \[namespace origin Eval\] $command 1\]} proc ::tcltest::test}
-1 {type source line 764 file info.test cmd {test info-22.8 {info frame, basic trace} -constraints {!singleTestInterp} -match glob -bo} level 1}}
+test info-22.8 {info frame, basic trace} -match glob -body {
+    join [lrange [etrace] 0 2] \n
+} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0}
+* {type source line 765 file info.test cmd etrace proc ::tcltest::RunTest}
+* {type source line * file tcltest.tcl cmd {uplevel 1 $script} proc ::tcltest::RunTest}}
 
 ## The line 1967 is off by 5 from the true value of 1972. This is a knownBug, see testcase 30.0
 test info-23.0 {eval'd info frame} {!singleTestInterp} {
@@ -1301,7 +1296,7 @@ namespace delete foo
 
 # -------------------------------------------------------------------------
 
-test info-37.0 {eval pure list, single line} {!singleTestInterp} {
+test info-37.0 {eval pure list, single line} -match glob -body {
     # Basically, counting the newline in the word seen through $foo
     # doesn't really make sense. It makes a bit of sense if the word
     # would have been a string literal in the command list.
@@ -1319,12 +1314,97 @@ test info-37.0 {eval pure list, single line} {!singleTestInterp} {
     }]
     eval $cmd
     set res
-} {10 {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0}
-9 {type eval line 2 cmd etrace proc ::tcltest::RunTest}
-8 {type eval line 1 cmd foreac proc ::tcltest::RunTest}}
+} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0}
+* {type eval line 2 cmd etrace proc ::tcltest::RunTest}
+* {type eval line 1 cmd foreac proc ::tcltest::RunTest}}
 
 # -------------------------------------------------------------------------
 
+# 6 cases.
+## DV. direct-var          - unchanged
+## DPV direct-proc-var     - ditto
+## PPV proc-proc-var       - ditto
+## DL. direct-literal      - now tracking absolute location
+## DPL direct-proc-literal - ditto
+## PPL proc-proc-literal   - ditto
+## ### ### ### ######### ######### #########"
+
+proc control {vv script} {
+    upvar 1 $vv var
+    return [uplevel 1 $script]
+}
+
+proc datal {} {
+    control y {
+	set y PPL
+	etrace
+    }
+}
+
+proc datav {} {
+    set script {
+	set y PPV
+	etrace
+    }
+    control y $script
+}
+
+test info-38.1 {location information for uplevel, dv, direct-var} -match glob -body {
+    set script {
+	set y DV.
+	etrace
+    }
+    join [lrange [uplevel \#0 $script] 0 2] \n
+} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0}
+* {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}}
+
+test info-38.3 {location information for uplevel, dpv, direct-proc-var} -match glob -body {
+    set script {
+	set y DPV
+	etrace
+    }
+    join [lrange [control y $script] 0 3] \n
+} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0}
+* {type eval line 3 cmd etrace proc ::control}
+* {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}}
+
+test info-38.5 {location information for uplevel, ppv, proc-proc-var} -match glob -body {
+    join [lrange [datav] 0 4] \n
+} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0}
+* {type eval line 3 cmd etrace proc ::control}
+* {type source line 1339 file info.test cmd {uplevel 1 $script} proc ::control}
+* {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}}
+
 # -------------------------------------------------------------------------
 
 # cleanup
diff --git a/tests/oo.test b/tests/oo.test
index f9b7be4..8ff06e8 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -7,7 +7,7 @@
 # See the file "license.terms" for information on usage and redistribution of
 # this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: oo.test,v 1.8 2008/07/19 22:50:39 nijtmans Exp $
+# RCS: @(#) $Id: oo.test,v 1.9 2008/07/25 22:11:21 andreas_kupries Exp $
 
 package require TclOO 0.4 ;# Must match value in configure.in
 if {[lsearch [namespace children] ::tcltest] == -1} {
@@ -1685,7 +1685,7 @@ test oo-21.4 {OO: inheritance ordering} -setup {
 test oo-22.1 {OO and info frame} -setup {
     oo::class create c
     c create i
-} -body {
+} -match glob -body {
     oo::define c self method frame {} {
 	info frame 0
     }
@@ -1708,7 +1708,7 @@ test oo-22.1 {OO and info frame} -setup {
     list [i level] [i frames] [dict get [c frame] object]
 } -cleanup {
     c destroy
-} -result {1 {{type proc line 2 cmd {info frame 0} method frames class ::c level 0} {type proc line 2 cmd {info frame 0} method frames object ::i level 0}} ::c}
+} -result {1 {{type source line * file * cmd {info frame 0} method frames class ::c level 0} {type source line * file * cmd {info frame 0} method frames object ::i level 0}} ::c}
 
 # Prove that the issue in [Bug 1865054] isn't an issue any more
 test oo-23.1 {Self-like derivation; complex case!} -setup {