summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
authorandreas_kupries <akupries@shaw.ca>2008-07-25 20:30:24 (GMT)
committerandreas_kupries <akupries@shaw.ca>2008-07-25 20:30:24 (GMT)
commitab493437ef6fb750de339bb51d29743250bcde32 (patch)
tree87d311ea52aa54f2769f6a3585c367411bdd337e /tests
parent0165e5e6989f8b3baad4c63d67077cdb388dd9bf (diff)
downloadtcl-ab493437ef6fb750de339bb51d29743250bcde32.zip
tcl-ab493437ef6fb750de339bb51d29743250bcde32.tar.gz
tcl-ab493437ef6fb750de339bb51d29743250bcde32.tar.bz2
* tests/info.test: Tests 38.* added, exactly testing the tracking
of location for uplevel scripts. * 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): Moved the pure-list optimization out of the eval-direct code path to be done always, i.e. even when a compile is requested. This way we do not loose the association between #280 location information and the list elements, if any.
Diffstat (limited to 'tests')
-rw-r--r--tests/compile.test4
-rw-r--r--tests/info.test111
2 files changed, 100 insertions, 15 deletions
diff --git a/tests/compile.test b/tests/compile.test
index fe2deea..6785855 100644
--- a/tests/compile.test
+++ b/tests/compile.test
@@ -11,7 +11,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: compile.test,v 1.48 2007/12/13 15:26:06 dgp Exp $
+# RCS: @(#) $Id: compile.test,v 1.48.2.1 2008/07/25 20:30:58 andreas_kupries Exp $
package require tcltest 2
namespace import -force ::tcltest::*
@@ -276,7 +276,7 @@ test compile-11.9 {Tcl_Append*: ensure Tcl_ResetResult is used properly} {
# TclReleaseLiteral. They are only effective when tcl is compiled
# with TCL_MEM_DEBUG
#
-# Special test for leak on interp delete [Bug 467523].
+# Special test for leak on interp delete [Bug 467523].
test compile-12.1 {testing literal leak on interp delete} -setup {
proc getbytes {} {
set lines [split [memory info] "\n"]
diff --git a/tests/info.test b/tests/info.test
index 66b19b4..2596dea 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.4 2008/07/23 21:42:45 andreas_kupries Exp $
+# RCS: @(#) $Id: info.test,v 1.47.2.5 2008/07/25 20:30:58 andreas_kupries Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
@@ -746,15 +746,15 @@ test info-22.2 {info frame, bad level absolute} {!singleTestInterp} {
catch {info frame 9} msg
set msg
} {bad level "9"}
-test info-22.3 {info frame, current, relative} {
+test info-22.3 {info frame, current, relative} -match glob -body {
info frame 0
-} {type eval line 2 cmd {info frame 0} proc ::tcltest::RunTest}
-test info-22.4 {info frame, current, relative, nested} {
+} -result {type source line 750 file * cmd {info frame 0} proc ::tcltest::RunTest}
+test info-22.4 {info frame, current, relative, nested} -match glob -body {
set res [info frame 0]
-} {type eval line 2 cmd {info frame 0} proc ::tcltest::RunTest}
-test info-22.5 {info frame, current, absolute} {!singleTestInterp} {
+} -result {type source line 753 file * cmd {info frame 0} proc ::tcltest::RunTest}
+test info-22.5 {info frame, current, absolute} -constraints {!singleTestInterp} -match glob -body {
reduce [info frame 7]
-} {type eval line 2 cmd {info frame 7} proc ::tcltest::RunTest}
+} -result {type source line 756 file * cmd {info frame 7} proc ::tcltest::RunTest}
test info-22.6 {info frame, global, relative} {!singleTestInterp} {
reduce [info frame -6]
} {type source line 758 file info.test cmd test\ info-22.6\ \{info\ frame,\ global,\ relative\}\ \{!singleTestInter level 0}
@@ -783,11 +783,11 @@ test info-23.2 {eval'd info frame, dynamic} {!singleTestInterp} {
set script {info frame}
eval $script
} 8
-test info-23.3 {eval'd info frame, literal} {
+test info-23.3 {eval'd info frame, literal} -match glob -body {
eval {
info frame 0
}
-} {type eval line 2 cmd {info frame 0} proc ::tcltest::RunTest}
+} -result {type source line 788 file * cmd {info frame 0} proc ::tcltest::RunTest}
test info-23.4 {eval'd info frame, semi-dynamic} {
eval info frame 0
} {type eval line 1 cmd {info frame 0} proc ::tcltest::RunTest}
@@ -1301,7 +1301,7 @@ namespace delete foo
# -------------------------------------------------------------------------
-test info-37.0 {eval pure list, single line} {
+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 +1319,97 @@ test info-37.0 {eval pure list, single line} {
}]
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