diff options
| -rw-r--r-- | ChangeLog | 18 | ||||
| -rw-r--r-- | generic/tclBasic.c | 9 | ||||
| -rw-r--r-- | generic/tclCompile.c | 44 | ||||
| -rw-r--r-- | generic/tclProc.c | 4 | ||||
| -rw-r--r-- | tests/info.test | 110 | ||||
| -rw-r--r-- | tests/oo.test | 6 |
6 files changed, 152 insertions, 39 deletions
@@ -1,3 +1,21 @@ +2008-07-25 Andreas Kupries <andreask@activestate.com> + + * 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. + 2008-07-25 Daniel Steffen <das@users.sourceforge.net> * tests/info.test (info-37.0): Add !singleTestInterp constraint; diff --git a/generic/tclBasic.c b/generic/tclBasic.c index da81e9c..eb5e1c8 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -16,7 +16,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.330 2008/07/23 20:49:50 andreas_kupries Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.331 2008/07/25 22:11:19 andreas_kupries Exp $ */ #include "tclInt.h" @@ -1515,6 +1515,10 @@ DeleteInterpProc( ckfree((char *) eclPtr->loc); } + if (eclPtr->eiloc != NULL) { + ckfree((char *) eclPtr->eiloc); + } + ckfree((char *) eclPtr); Tcl_DeleteHashEntry(hPtr); } @@ -5741,6 +5745,9 @@ TclNREvalObjEx( * execution speed. This is because it allows us to avoid a setFromAny * step that would just pack everything into a string and back out again. * + * This also preserves any associations between list elements and location + * information for such elements. + * * This restriction has been relaxed a bit by storing in lists whether * they are "canonical" or not (a canonical list being one that is either * pure or that has its string rep derived by UpdateStringOfList from the diff --git a/generic/tclCompile.c b/generic/tclCompile.c index f484d7b..2d040b4 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.153 2008/07/23 20:49:52 andreas_kupries Exp $ + * RCS: @(#) $Id: tclCompile.c,v 1.154 2008/07/25 22:11:20 andreas_kupries Exp $ */ #include "tclInt.h" @@ -932,7 +932,23 @@ TclInitCompileEnv( * ...) which may make change the type as well. */ - if ((invoker->nline <= word) || (invoker->line[word] < 0)) { + CmdFrame *ctxPtr; + int pc = 0; + + ctxPtr = (CmdFrame *) TclStackAlloc(interp, sizeof(CmdFrame)); + *ctxPtr = *invoker; + + if (invoker->type == TCL_LOCATION_BC) { + /* + * Note: Type BC => ctx.data.eval.path is not used. + * ctx.data.tebc.codePtr is used instead. + */ + + TclGetSrcInfoForPc(ctxPtr); + pc = 1; + } + + if ((ctxPtr->nline <= word) || (ctxPtr->line[word] < 0)) { /* * Word is not a literal, relative counting. */ @@ -940,45 +956,37 @@ TclInitCompileEnv( envPtr->line = 1; envPtr->extCmdMapPtr->type = (envPtr->procPtr ? TCL_LOCATION_PROC : TCL_LOCATION_BC); - } else { - CmdFrame *ctxPtr; - int pc = 0; - - ctxPtr = (CmdFrame *) TclStackAlloc(interp, sizeof(CmdFrame)); - *ctxPtr = *invoker; - if (invoker->type == TCL_LOCATION_BC) { + if (pc && (ctxPtr->type == TCL_LOCATION_SOURCE)) { /* - * Note: Type BC => ctx.data.eval.path is not used. - * ctx.data.tebc.codePtr is used instead. + * The reference made by 'TclGetSrcInfoForPc' is dead. */ - - TclGetSrcInfoForPc(ctxPtr); - pc = 1; + Tcl_DecrRefCount(ctxPtr->data.eval.path); } - + } else { envPtr->line = ctxPtr->line[word]; envPtr->extCmdMapPtr->type = ctxPtr->type; if (ctxPtr->type == TCL_LOCATION_SOURCE) { + envPtr->extCmdMapPtr->path = ctxPtr->data.eval.path; + if (pc) { /* * The reference 'TclGetSrcInfoForPc' made is transfered. */ - envPtr->extCmdMapPtr->path = ctxPtr->data.eval.path; ctxPtr->data.eval.path = NULL; } else { /* * We have a new reference here. */ - envPtr->extCmdMapPtr->path = ctxPtr->data.eval.path; Tcl_IncrRefCount(envPtr->extCmdMapPtr->path); } } - TclStackFree(interp, ctxPtr); } + + TclStackFree(interp, ctxPtr); } envPtr->auxDataArrayPtr = envPtr->staticAuxDataArraySpace; diff --git a/generic/tclProc.c b/generic/tclProc.c index 9947549..63aa7d5 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclProc.c,v 1.151 2008/07/21 22:50:36 andreas_kupries Exp $ + * RCS: @(#) $Id: tclProc.c,v 1.152 2008/07/25 22:11:21 andreas_kupries Exp $ */ #include "tclInt.h" @@ -2281,7 +2281,7 @@ TclProcCleanupProc( /* * TIP #280: Release the location data associated with this Proc * structure, if any. The interpreter may not exist (For example for - * procbody structurues created by tbcload. + * procbody structures created by tbcload. */ if (!iPtr) { 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 { |