From 32d107e23b1d9d75d74c00fdd52dde8992156169 Mon Sep 17 00:00:00 2001 From: andreas_kupries Date: Mon, 16 Jun 2008 20:44:30 +0000 Subject: * generic/tclCmdIL.c (TclInfoFrame): Backport of fix made on the * tests/info.test: head branch :: Moved the code looking up the information for key 'proc' out of the TCL_LOCATION_BC branch to after the switch, this is common to all frame types. Updated the testsuite to match. This was exposed by the 2008-06-08 commit (Miguel), switching uplevel from direct eval to compilation. Fixes [Bug 1987851]. --- ChangeLog | 10 +++++++ generic/tclCmdIL.c | 87 +++++++++++++++++++++++++++++------------------------- tests/info.test | 16 +++++----- 3 files changed, 64 insertions(+), 49 deletions(-) diff --git a/ChangeLog b/ChangeLog index 586941a..e79000e 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,13 @@ +2008-06-16 Andreas Kupries + + * generic/tclCmdIL.c (TclInfoFrame): Backport of fix made on the + * tests/info.test: head branch :: Moved the code looking up the + information for key 'proc' out of the TCL_LOCATION_BC branch to + after the switch, this is common to all frame types. Updated the + testsuite to match. This was exposed by the 2008-06-08 commit + (Miguel), switching uplevel from direct eval to compilation. Fixes + [Bug 1987851]. + 2008-06-12 Daniel Steffen * unix/Makefile.in: add complete deps on tclDTrace.h. diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index d76b49f..5555c99 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.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: tclCmdIL.c,v 1.137 2008/03/14 19:46:17 dgp Exp $ + * RCS: @(#) $Id: tclCmdIL.c,v 1.137.2.1 2008/06/16 20:44:31 andreas_kupries Exp $ */ #include "tclInt.h" @@ -1125,6 +1125,8 @@ TclInfoFrame( "eval", "eval", "eval", "precompiled", "source", "proc" }; Tcl_Obj *tmpObj; + Proc *procPtr = + framePtr->framePtr ? framePtr->framePtr->procPtr : NULL; /* * Pull the information and construct the dictionary to return, as list. @@ -1181,8 +1183,6 @@ TclInfoFrame( * Execution of bytecode. Talk to the BC engine to fill out the frame. */ - Proc *procPtr = - framePtr->framePtr ? framePtr->framePtr->procPtr : NULL; CmdFrame *fPtr; fPtr = (CmdFrame *) TclStackAlloc(interp, sizeof(CmdFrame)); @@ -1216,44 +1216,6 @@ TclInfoFrame( ADD_PAIR("cmd", Tcl_NewStringObj(fPtr->cmd.str.cmd, fPtr->cmd.str.len)); - - if (procPtr != NULL) { - Tcl_HashEntry *namePtr = procPtr->cmdPtr->hPtr; - - if (namePtr) { - /* - * This is a regular command. - */ - - char *procName = Tcl_GetHashKey(namePtr->tablePtr, namePtr); - char *nsName = procPtr->cmdPtr->nsPtr->fullName; - - ADD_PAIR("proc", Tcl_NewStringObj(nsName, -1)); - - if (strcmp(nsName, "::") != 0) { - Tcl_AppendToObj(lv[lc-1], "::", -1); - } - Tcl_AppendToObj(lv[lc-1], procName, -1); - } else if (procPtr->cmdPtr->clientData) { - ExtraFrameInfo *efiPtr = procPtr->cmdPtr->clientData; - int i; - - /* - * This is a non-standard command. Luckily, it's told us how - * to render extra information about its frame. - */ - - for (i=0 ; ilength ; i++) { - lv[lc++] = Tcl_NewStringObj(efiPtr->fields[i].name, -1); - if (efiPtr->fields[i].proc) { - lv[lc++] = efiPtr->fields[i].proc( - efiPtr->fields[i].clientData); - } else { - lv[lc++] = efiPtr->fields[i].clientData; - } - } - } - } TclStackFree(interp, fPtr); break; } @@ -1282,6 +1244,49 @@ TclInfoFrame( } /* + * 'proc'. Common to all frame types. Conditional on having an associated + * Procedure CallFrame. + */ + + if (procPtr != NULL) { + Tcl_HashEntry *namePtr = procPtr->cmdPtr->hPtr; + + if (namePtr) { + /* + * This is a regular command. + */ + + char *procName = Tcl_GetHashKey(namePtr->tablePtr, namePtr); + char *nsName = procPtr->cmdPtr->nsPtr->fullName; + + ADD_PAIR("proc", Tcl_NewStringObj(nsName, -1)); + + if (strcmp(nsName, "::") != 0) { + Tcl_AppendToObj(lv[lc-1], "::", -1); + } + Tcl_AppendToObj(lv[lc-1], procName, -1); + } else if (procPtr->cmdPtr->clientData) { + ExtraFrameInfo *efiPtr = procPtr->cmdPtr->clientData; + int i; + + /* + * This is a non-standard command. Luckily, it's told us how to + * render extra information about its frame. + */ + + for (i=0 ; ilength ; i++) { + lv[lc++] = Tcl_NewStringObj(efiPtr->fields[i].name, -1); + if (efiPtr->fields[i].proc) { + lv[lc++] = + efiPtr->fields[i].proc(efiPtr->fields[i].clientData); + } else { + lv[lc++] = efiPtr->fields[i].clientData; + } + } + } + } + + /* * 'level'. Common to all frame types. Conditional on having an associated * _visible_ CallFrame. */ diff --git a/tests/info.test b/tests/info.test index a6fa48d..63b8a79 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 2007/12/13 15:26:06 dgp Exp $ +# RCS: @(#) $Id: info.test,v 1.47.2.1 2008/06/16 20:44:32 andreas_kupries Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -748,13 +748,13 @@ test info-22.2 {info frame, bad level absolute} {!singleTestInterp} { } {bad level "9"} test info-22.3 {info frame, current, relative} { info frame 0 -} {type eval line 2 cmd {info frame 0}} +} {type eval line 2 cmd {info frame 0} proc ::tcltest::RunTest} test info-22.4 {info frame, current, relative, nested} { set res [info frame 0] -} {type eval line 2 cmd {info frame 0}} +} {type eval line 2 cmd {info frame 0} proc ::tcltest::RunTest} test info-22.5 {info frame, current, absolute} {!singleTestInterp} { reduce [info frame 7] -} {type eval line 2 cmd {info frame 7}} +} {type eval line 2 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} @@ -787,14 +787,14 @@ test info-23.3 {eval'd info frame, literal} { eval { info frame 0 } -} {type eval line 2 cmd {info frame 0}} +} {type eval line 2 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}} +} {type eval line 1 cmd {info frame 0} proc ::tcltest::RunTest} test info-23.5 {eval'd info frame, dynamic} { set script {info frame 0} eval $script -} {type eval line 1 cmd {info frame 0}} +} {type eval line 1 cmd {info frame 0} proc ::tcltest::RunTest} test info-23.6 {eval'd info frame, trace} {knownBug !singleTestInterp} { set script {etrace} join [eval $script] \n @@ -982,7 +982,7 @@ test info-31.5 {for, script in variable} { test info-31.6 {eval, script in variable} { eval $body set res -} {type eval line 3 cmd {info frame 0}} +} {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest} # ------------------------------------------------------------------------- -- cgit v0.12