diff options
| -rw-r--r-- | ChangeLog | 16 | ||||
| -rw-r--r-- | generic/tclBasic.c | 8 | ||||
| -rw-r--r-- | generic/tclCompile.c | 36 | ||||
| -rw-r--r-- | tests/info.test | 184 |
4 files changed, 146 insertions, 98 deletions
@@ -1,3 +1,19 @@ +2008-07-28 Andreas Kupries <andreask@activestate.com> + + * generic/tclBasic.c: Added missing release of extended command + word index when deleting an interpreter (DeleteInterpProc). Added + missing ref count when creating an empty string as path (EvalEx). + + * generic/tclCompile.c (TclInitCompileEnv): Made same change to + control flow as in TclEvalObjEx. Not needed while uplevel and + siblings go through the eval-direct code path, however if that + changes (like it did in 8.5+) better to have this in place instead + of re-searching why certain places are without absolute locations. + + * tests/info.test: Added tests 38.*, exactly testing the tracking + of location for uplevel scripts, and made the testsuite fully + usable with and without -singleproc 1. + 2008-07-25 Daniel Steffen <das@users.sourceforge.net> * tests/info.test: Add !singleTestInterp constraint to various tests; diff --git a/generic/tclBasic.c b/generic/tclBasic.c index c91fdc1..4ce4590 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -14,7 +14,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBasic.c,v 1.75.2.32 2008/07/23 20:45:16 andreas_kupries Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.75.2.33 2008/07/28 20:01:07 andreas_kupries Exp $ */ #include "tclInt.h" @@ -1202,6 +1202,10 @@ DeleteInterpProc(interp) ckfree ((char*) eclPtr->loc); } + if (eclPtr->eiloc != NULL) { + ckfree ((char*) eclPtr->eiloc); + } + ckfree ((char*) eclPtr); Tcl_DeleteHashEntry (hPtr); } @@ -3906,10 +3910,10 @@ EvalEx(interp, script, numBytes, flags, line) return TCL_ERROR; } eeFrame.data.eval.path = norm; - Tcl_IncrRefCount (eeFrame.data.eval.path); } else { eeFrame.data.eval.path = Tcl_NewStringObj ("",-1); } + Tcl_IncrRefCount (eeFrame.data.eval.path); } else { /* Set up for plain eval */ diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 59be33a..44ee69b 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -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: tclCompile.c,v 1.43.2.12 2008/07/23 20:45:18 andreas_kupries Exp $ + * RCS: @(#) $Id: tclCompile.c,v 1.43.2.13 2008/07/28 20:01:09 andreas_kupries Exp $ */ #include "tclInt.h" @@ -836,40 +836,48 @@ TclInitCompileEnv(interp, envPtr, string, numBytes, invoker, word) * (line, path, ...). Which may make change the type as well. */ - if ((invoker->nline <= word) || (invoker->line[word] < 0)) { + CmdFrame ctx = *invoker; + int pc = 0; + + if (invoker->type == TCL_LOCATION_BC) { + /* Note: Type BC => ctx.data.eval.path is not used. + * ctx.data.tebc.codePtr is used instead. + */ + TclGetSrcInfoForPc (&ctx); + pc = 1; + } + + if ((ctx.nline <= word) || (ctx.line[word] < 0)) { /* Word is not a literal, relative counting */ envPtr->line = 1; envPtr->extCmdMapPtr->type = (envPtr->procPtr ? TCL_LOCATION_PROC : TCL_LOCATION_BC); - } else { - CmdFrame ctx = *invoker; - int pc = 0; - if (invoker->type == TCL_LOCATION_BC) { - /* Note: Type BC => ctx.data.eval.path is not used. - * ctx.data.tebc.codePtr is used instead. + if (pc && (ctx.type == TCL_LOCATION_SOURCE)) { + /* + * The reference made by 'TclGetSrcInfoForPc' is dead. */ - TclGetSrcInfoForPc (&ctx); - pc = 1; + Tcl_DecrRefCount(ctx.data.eval.path); } - + } else { envPtr->line = ctx.line [word]; envPtr->extCmdMapPtr->type = ctx.type; + envPtr->extCmdMapPtr->path = ctx.data.eval.path; if (ctx.type == TCL_LOCATION_SOURCE) { if (pc) { /* The reference 'TclGetSrcInfoForPc' made is transfered */ - envPtr->extCmdMapPtr->path = ctx.data.eval.path; ctx.data.eval.path = NULL; } else { /* We have a new reference here */ - envPtr->extCmdMapPtr->path = ctx.data.eval.path; - Tcl_IncrRefCount (envPtr->extCmdMapPtr->path); + Tcl_IncrRefCount (ctx.data.eval.path); } } } + + /* ctx going out of scope */ } #endif diff --git a/tests/info.test b/tests/info.test index 9f875ee..b30a4be 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.24.2.10 2008/07/25 21:24:45 das Exp $ +# RCS: @(#) $Id: info.test,v 1.24.2.11 2008/07/28 20:01:12 andreas_kupries Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -728,71 +728,97 @@ proc etrace {} { ## -test info-22.0 {info frame, levels} {tip280 && !singleTestInterp} { +test info-22.0.0 {info frame, levels} {tip280 && !singleTestInterp} { info frame } 7 +test info-22.0.1 {info frame, levels} {tip280 && singleTestInterp} { + info frame +} 10 -test info-22.1 {info frame, bad level relative} {tip280 && !singleTestInterp} { +test info-22.1.0 {info frame, bad level relative} {tip280 && !singleTestInterp} { # catch is another level!, i.e. we have 8, not 7 catch {info frame -8} msg set msg } {bad level "-8"} +test info-22.1.1 {info frame, bad level relative} {tip280 && singleTestInterp} { + # catch is another level!, i.e. we have 11, not 10 + catch {info frame -11} msg + set msg +} {bad level "-11"} -test info-22.2 {info frame, bad level absolute} {tip280 && !singleTestInterp} { +test info-22.2.0 {info frame, bad level absolute} {tip280 && !singleTestInterp} { # catch is another level!, i.e. we have 8, not 7 catch {info frame 9} msg set msg } {bad level "9"} +test info-22.2.1 {info frame, bad level absolute} {tip280 && singleTestInterp} { + # catch is another level!, i.e. we have 12, not 10 + catch {info frame 12} msg + set msg +} {bad level "12"} test info-22.3 {info frame, current, relative} -constraints tip280 -match glob -body { info frame 0 -} -result {type source line 748 file *info.test cmd {info frame 0} proc ::tcltest::RunTest} +} -result {type source line 761 file * cmd {info frame 0} proc ::tcltest::RunTest} test info-22.4 {info frame, current, relative, nested} -constraints tip280 -match glob -body { set res [info frame 0] -} -result {type source line 752 file *info.test cmd {info frame 0} proc ::tcltest::RunTest} +} -result {type source line 765 file * cmd {info frame 0} proc ::tcltest::RunTest} -test info-22.5 {info frame, current, absolute} -constraints {tip280 && !singleTestInterp} -match glob -body { +test info-22.5.0 {info frame, current, absolute} -constraints {tip280 && !singleTestInterp} -match glob -body { reduce [info frame 7] -} -result {type source line 756 file *info.test cmd {info frame 7} proc ::tcltest::RunTest} +} -result {type source line 769 file * cmd {info frame 7} proc ::tcltest::RunTest} +test info-22.5.1 {info frame, current, absolute} -constraints {tip280 && singleTestInterp} -match glob -body { + reduce [info frame 10] +} -result {type source line 772 file * cmd {info frame 10} proc ::tcltest::RunTest} -test info-22.6 {info frame, global, relative} {tip280 && !singleTestInterp} { +test info-22.6.0 {info frame, global, relative} {tip280 && !singleTestInterp} { + reduce [info frame -6] +} {type source line 775 file info.test cmd test\ info-22.6.0\ \{info\ frame,\ global,\ relative\}\ \{tip280\ &&\ !singleTe} +test info-22.6.1 {info frame, global, relative} {tip280 && singleTestInterp} { reduce [info frame -6] -} {type source line 759 file info.test cmd test\ info-22.6\ \{info\ frame,\ global,\ relative\}\ \{tip280\ &&\ !singleTe} +} {type source line 778 file info.test cmd test\ info-22.6.1\ \{info\ frame,\ global,\ relative\}\ \{tip280\ &&\ singleTe proc ::tcltest::runAllTests} -test info-22.7 {info frame, global, absolute} {tip280 && !singleTestInterp} { +test info-22.7.0 {info frame, global, absolute} {tip280 && !singleTestInterp} { reduce [info frame 1] -} {type source line 763 file info.test cmd test\ info-22.7\ \{info\ frame,\ global,\ absolute\}\ \{tip280\ &&\ !singleTe} - -test info-22.8 {info frame, basic trace} -constraints {tip280 && !singleTestInterp} -match glob -body { - join [etrace] \n -} -result {8 {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0} -7 {type source line 768 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 } 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\\ 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 767 file info.test cmd {test info-22.8 {info frame, basic trace} -constraints {tip280 && !singleTestInterp} -match g}}} +} {type source line 782 file info.test cmd test\ info-22.7.0\ \{info\ frame,\ global,\ absolute\}\ \{tip280\ &&\ !singleTe} +test info-22.7.1 {info frame, global, absolute} {tip280 && singleTestInterp} { + reduce [info frame 4] +} {type source line 785 file info.test cmd test\ info-22.7.1\ \{info\ frame,\ global,\ absolute\}\ \{tip280\ &&\ singleTe proc ::tcltest::runAllTests} + +test info-22.8 {info frame, basic trace} -constraints {tip280} -match glob -body { + join [lrange [etrace] 0 1] \n +} -result {* {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0} +* {type source line 790 file info.test cmd etrace proc ::tcltest::RunTest}} ## The line 1966 is off by 5 from the true value of 1971. This is a knownBug, see testcase 30.0 -test info-23.0 {eval'd info frame} {tip280 && !singleTestInterp} { +test info-23.0.0 {eval'd info frame} {tip280 && !singleTestInterp} { eval {info frame} } 8 +test info-23.0.1 {eval'd info frame} {tip280 && singleTestInterp} { + eval {info frame} +} 11 -test info-23.1 {eval'd info frame, semi-dynamic} {tip280 && !singleTestInterp} { +test info-23.1.0 {eval'd info frame, semi-dynamic} {tip280 && !singleTestInterp} { eval info frame } 8 +test info-23.1.1 {eval'd info frame, semi-dynamic} {tip280 && singleTestInterp} { + eval info frame +} 11 -test info-23.2 {eval'd info frame, dynamic} {tip280 && !singleTestInterp} { +test info-23.2.0 {eval'd info frame, dynamic} {tip280 && !singleTestInterp} { set script {info frame} eval $script } 8 +test info-23.2.1 {eval'd info frame, dynamic} {tip280 && singleTestInterp} { + set script {info frame} + eval $script +} 11 test info-23.3 {eval'd info frame, literal} -constraints tip280 -match glob -body { eval { info frame 0 } -} -result {type source line 793 file *info.test cmd {info frame 0} proc ::tcltest::RunTest} +} -result {type source line 819 file *info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-23.4 {eval'd info frame, semi-dynamic} tip280 { eval info frame 0 @@ -803,18 +829,12 @@ test info-23.5 {eval'd info frame, dynamic} tip280 { eval $script } {type eval line 1 cmd {info frame 0} proc ::tcltest::RunTest} -test info-23.6 {eval'd info frame, trace} -constraints {tip280 && !singleTestInterp} -match glob -body { +test info-23.6 {eval'd info frame, trace} -constraints {tip280} -match glob -body { set script {etrace} - join [eval $script] \n -} -result {9 {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0} -8 {type eval line 1 cmd etrace proc ::tcltest::RunTest} -7 {type source line 808 file info.test cmd {eval $script} 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 } 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\\ 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 806 file info.test cmd {test info-23.6 {eval'd info frame, trace} -constraints {tip280 && !singleTestInterp} -match g}}} + join [lrange [eval $script] 0 2] \n +} -result {* {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0} +* {type eval line 1 cmd etrace proc ::tcltest::RunTest} +* {type source line 834 file info.test cmd {eval $script} proc ::tcltest::RunTest}} ## The line 1966 is off by 5 from the true value of 1971. This is a knownBug, see testcase 30.0 # ------------------------------------------------------------------------- @@ -834,7 +854,7 @@ namespace eval foo { test info-24.0 {info frame, interaction, namespace eval} tip280 { reduce [foo::bar] -} {type source line 832 file info.test cmd {info frame 0} proc ::foo::bar level 0} +} {type source line 852 file info.test cmd {info frame 0} proc ::foo::bar level 0} namespace delete foo @@ -848,7 +868,7 @@ if {$flag} { test info-24.1 {info frame, interaction, if} tip280 { reduce [foo::bar] -} {type source line 846 file info.test cmd {info frame 0} proc ::foo::bar level 0} +} {type source line 866 file info.test cmd {info frame 0} proc ::foo::bar level 0} namespace delete foo @@ -863,7 +883,7 @@ while {$flag} { test info-24.2 {info frame, interaction, while} tip280 { reduce [foo::bar] -} {type source line 860 file info.test cmd {info frame 0} proc ::foo::bar level 0} +} {type source line 880 file info.test cmd {info frame 0} proc ::foo::bar level 0} namespace delete foo @@ -876,7 +896,7 @@ catch { test info-24.3 {info frame, interaction, catch} tip280 { reduce [foo::bar] -} {type source line 874 file info.test cmd {info frame 0} proc ::foo::bar level 0} +} {type source line 894 file info.test cmd {info frame 0} proc ::foo::bar level 0} namespace delete foo @@ -890,7 +910,7 @@ foreach var val { test info-24.4 {info frame, interaction, foreach} tip280 { reduce [foo::bar] -} {type source line 887 file info.test cmd {info frame 0} proc ::foo::bar level 0} +} {type source line 907 file info.test cmd {info frame 0} proc ::foo::bar level 0} namespace delete foo @@ -904,7 +924,7 @@ for {} {1} {} { test info-24.5 {info frame, interaction, for} tip280 { reduce [foo::bar] -} {type source line 901 file info.test cmd {info frame 0} proc ::foo::bar level 0} +} {type source line 921 file info.test cmd {info frame 0} proc ::foo::bar level 0} namespace delete foo @@ -916,12 +936,12 @@ eval { test info-25.0 {info frame, proc in eval} tip280 { reduce [bar] -} {type source line 914 file info.test cmd {info frame 0} proc ::bar level 0} +} {type source line 934 file info.test cmd {info frame 0} proc ::bar level 0} proc bar {} {info frame 0} test info-25.1 {info frame, regular proc} tip280 { reduce [bar] -} {type source line 921 file info.test cmd {info frame 0} proc ::bar level 0} +} {type source line 941 file info.test cmd {info frame 0} proc ::bar level 0} rename bar {} @@ -1004,7 +1024,7 @@ switch -exact -- $x { test info-24.6.0 {info frame, interaction, switch, list body} tip280 { reduce [foo::bar] -} {type source line 1001 file info.test cmd {info frame 0} proc ::foo::bar level 0} +} {type source line 1021 file info.test cmd {info frame 0} proc ::foo::bar level 0} namespace delete foo unset x @@ -1019,7 +1039,7 @@ switch -exact -- $x foo { test info-24.6.1 {info frame, interaction, switch, multi-body} tip280 { reduce [foo::bar] -} {type source line 1017 file info.test cmd {info frame 0} proc ::foo::bar level 0} +} {type source line 1037 file info.test cmd {info frame 0} proc ::foo::bar level 0} namespace delete foo unset x @@ -1075,7 +1095,7 @@ namespace delete foo # ------------------------------------------------------------------------- -test info-34.0 {eval pure list, single line} {tip280 && !singleTestInterp} { +test info-34.0 {eval pure list, single line} -constraints {tip280} -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. @@ -1093,9 +1113,9 @@ test info-34.0 {eval pure list, single line} {tip280 && !singleTestInterp} { }] eval $cmd set res -} {10 {type source line 723 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 723 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}} # ------------------------------------------------------------------------- @@ -1128,61 +1148,61 @@ proc datav {} { control y $script } -test info-38.1 {location information for uplevel, dv, direct-var} tip280 { +test info-38.1 {location information for uplevel, dv, direct-var} -constraints tip280 -match glob -body { set script { set y DV. etrace } join [lrange [uplevel \#0 $script] 0 2] \n -} {9 {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0} -8 {type eval line 3 cmd etrace proc ::tcltest::RunTest} -7 {type source line 1136 file info.test cmd {uplevel \#0 $script} proc ::tcltest::RunTest}} +} -result {* {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0} +* {type eval line 3 cmd etrace proc ::tcltest::RunTest} +* {type source line 1156 file info.test cmd {uplevel \\#0 $script} proc ::tcltest::RunTest}} -test info-38.2 {location information for uplevel, dl, direct-literal} tip280 { +test info-38.2 {location information for uplevel, dl, direct-literal} -constraints tip280 -match glob -body { join [lrange [uplevel \#0 { set y DL. etrace }] 0 2] \n -} {9 {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0} -8 {type source line 1144 file info.test cmd etrace proc ::tcltest::RunTest} -7 {type source line 1142 file info.test cmd up proc ::tcltest::RunTest}} +} -result {* {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0} +* {type source line 1164 file info.test cmd etrace proc ::tcltest::RunTest} +* {type source line 1162 file info.test cmd up proc ::tcltest::RunTest}} -test info-38.3 {location information for uplevel, dpv, direct-proc-var} tip280 { +test info-38.3 {location information for uplevel, dpv, direct-proc-var} -constraints tip280 -match glob -body { set script { set y DPV etrace } join [lrange [control y $script] 0 3] \n -} {10 {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0} -9 {type eval line 3 cmd etrace proc ::control} -8 {type source line 1113 file info.test cmd {uplevel 1 $script} proc ::control} -7 {type source line 1155 file info.test cmd {control y $script} proc ::tcltest::RunTest}} +} -result {* {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0} +* {type eval line 3 cmd etrace proc ::control} +* {type source line 1133 file info.test cmd {uplevel 1 $script} proc ::control} +* {type source line 1175 file info.test cmd {control y $script} proc ::tcltest::RunTest}} -test info-38.4 {location information for uplevel, dpv, direct-proc-literal} tip280 { +test info-38.4 {location information for uplevel, dpv, direct-proc-literal} -constraints tip280 -match glob -body { join [lrange [control y { set y DPL etrace }] 0 3] \n -} {10 {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0} -9 {type source line 1164 file info.test cmd etrace proc ::control} -8 {type source line 1113 file info.test cmd {uplevel 1 $script} proc ::control} -7 {type source line 1162 file info.test cmd control proc ::tcltest::RunTest}} +} -result {* {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0} +* {type source line 1184 file info.test cmd etrace proc ::control} +* {type source line 1133 file info.test cmd {uplevel 1 $script} proc ::control} +* {type source line 1182 file info.test cmd control proc ::tcltest::RunTest}} -test info-38.5 {location information for uplevel, ppv, proc-proc-var} tip280 { +test info-38.5 {location information for uplevel, ppv, proc-proc-var} -constraints tip280 -match glob -body { join [lrange [datav] 0 4] \n -} {11 {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0} -10 {type eval line 3 cmd etrace proc ::control} -9 {type source line 1113 file info.test cmd {uplevel 1 $script} proc ::control} -8 {type source line 1128 file info.test cmd {control y $script} proc ::datav level 1} -7 {type source line 1172 file info.test cmd datav proc ::tcltest::RunTest}} +} -result {* {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0} +* {type eval line 3 cmd etrace proc ::control} +* {type source line 1133 file info.test cmd {uplevel 1 $script} proc ::control} +* {type source line 1148 file info.test cmd {control y $script} proc ::datav level 1} +* {type source line 1192 file info.test cmd datav proc ::tcltest::RunTest}} -test info-38.6 {location information for uplevel, ppl, proc-proc-literal} tip280 { +test info-38.6 {location information for uplevel, ppl, proc-proc-literal} -constraints tip280 -match glob -body { join [lrange [datal] 0 4] \n -} {11 {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0} -10 {type source line 1119 file info.test cmd etrace proc ::control} -9 {type source line 1113 file info.test cmd {uplevel 1 $script} proc ::control} -8 {type source line 1117 file info.test cmd control proc ::datal level 1} -7 {type source line 1180 file info.test cmd datal proc ::tcltest::RunTest}} +} -result {* {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0} +* {type source line 1139 file info.test cmd etrace proc ::control} +* {type source line 1133 file info.test cmd {uplevel 1 $script} proc ::control} +* {type source line 1137 file info.test cmd control proc ::datal level 1} +* {type source line 1200 file info.test cmd datal proc ::tcltest::RunTest}} # ------------------------------------------------------------------------- |