summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorandreas_kupries <akupries@shaw.ca>2008-07-23 20:49:50 (GMT)
committerandreas_kupries <akupries@shaw.ca>2008-07-23 20:49:50 (GMT)
commita0900a49110c0eaf5ed791ee35c70b800d3d52ec (patch)
treeb3d4d81cfc5d42e2154a618ae44c9a9da166f612
parent16253514a3a86502bec2e5b592f4c0789641535d (diff)
downloadtcl-a0900a49110c0eaf5ed791ee35c70b800d3d52ec.zip
tcl-a0900a49110c0eaf5ed791ee35c70b800d3d52ec.tar.gz
tcl-a0900a49110c0eaf5ed791ee35c70b800d3d52ec.tar.bz2
* generic/tclBasic.c: Modified TclArgumentGet to reject pure lists
* generic/tclCmdIL.c: immediately, without search. Reworked setup * generic/tclCompile.c: of eoFramePtr, doesn't need the line * tests/info.test: information, more sensible to have everything on line 1 when eval'ing a pure list. Updated the users of the line information to special case this based on the frame type (i.e. TCL_LOCATION_EVAL_LIST). Added a testcase demonstrating the new behaviour.
-rw-r--r--ChangeLog11
-rw-r--r--generic/tclBasic.c47
-rw-r--r--generic/tclCmdIL.c4
-rw-r--r--generic/tclCompile.c8
-rw-r--r--tests/info.test28
5 files changed, 69 insertions, 29 deletions
diff --git a/ChangeLog b/ChangeLog
index a5a8a89..6ab9250 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,14 @@
+2008-07-23 Andreas Kupries <andreask@activestate.com>
+
+ * generic/tclBasic.c: Modified TclArgumentGet to reject pure lists
+ * generic/tclCmdIL.c: immediately, without search. Reworked setup
+ * generic/tclCompile.c: of eoFramePtr, doesn't need the line
+ * tests/info.test: information, more sensible to have everything
+ on line 1 when eval'ing a pure list. Updated the users of the line
+ information to special case this based on the frame type (i.e.
+ TCL_LOCATION_EVAL_LIST). Added a testcase demonstrating the new
+ behaviour.
+
2008-07-23 Miguel Sofer <msofer@users.sf.net>
* generic/tclBasic.c (GetCommandSource): added comment with
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 1730097..da81e9c 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.329 2008/07/23 13:38:22 msofer Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.330 2008/07/23 20:49:50 andreas_kupries Exp $
*/
#include "tclInt.h"
@@ -5534,6 +5534,18 @@ TclArgumentGet(
CmdFrame *framePtr;
/*
+ * An object which either has no string rep or else is a canonical list is
+ * guaranteed to have been generated dynamically: bail out, this cannot
+ * have a usable absolute location. _Do not touch_ the information the set
+ * up by the caller. It knows better than us.
+ */
+
+ if ((!obj->bytes) || ((obj->typePtr == &tclListType) &&
+ ((List *)obj->internalRep.twoPtrValue.ptr1)->canonicalFlag)) {
+ return;
+ }
+
+ /*
* First look for location information recorded in the argument
* stack. That is nearest.
*/
@@ -5745,18 +5757,11 @@ TclNREvalObjEx(
* dynamic execution we ignore the invoker, even if known.
*/
- int line, i, nline;
- char *w;
- Tcl_Obj **elements, *copyPtr = TclListObjCopy(NULL, objPtr);
CmdFrame *eoFramePtr;
- Tcl_ListObjGetElements(NULL, copyPtr,
- &nline, &elements);
-
- eoFramePtr = (CmdFrame *) TclStackAlloc(interp,
- sizeof(CmdFrame) + nline * sizeof(int));
- eoFramePtr->nline = nline;
- eoFramePtr->line = (int *) (eoFramePtr + 1);
+ eoFramePtr = (CmdFrame *) TclStackAlloc(interp, sizeof(CmdFrame));
+ eoFramePtr->nline = 0;
+ eoFramePtr->line = NULL;
eoFramePtr->type = TCL_LOCATION_EVAL_LIST;
eoFramePtr->level = (iPtr->cmdFramePtr == NULL?
@@ -5769,21 +5774,19 @@ TclNREvalObjEx(
eoFramePtr->data.eval.path = NULL;
/*
- * TIP #280 Computes all the line numbers for the words in the
- * command.
+ * TIP #280. We do _not_ compute all the line numbers for the
+ * words in the command. For the eval of a pure list the most
+ * sensible choice is to put all words on line 1. Given that we
+ * neither need memory for them nor compute anything. 'line' is
+ * left NULL. The two places using this information (TclInfoFrame,
+ * and TclInitCompileEnv), are special-cased to use the proper
+ * line number directly instead of accessing the 'line' array.
*/
- line = 1;
- for (i=0; i < eoFramePtr->nline; i++) {
- eoFramePtr->line[i] = line;
- w = TclGetString(elements[i]);
- TclAdvanceLines(&line, w, w + strlen(w));
- }
-
iPtr->cmdFramePtr = eoFramePtr;
TclNRAddCallback(interp, TEOEx_ListCallback, objPtr, eoFramePtr,
- copyPtr, NULL);
+ NULL, NULL);
return Tcl_NREvalObj(interp, objPtr, flags);
}
}
@@ -5952,7 +5955,6 @@ TEOEx_ListCallback(
Interp *iPtr = (Interp *) interp;
Tcl_Obj *objPtr = data[0];
CmdFrame *eoFramePtr = data[1];
- Tcl_Obj *copyPtr = data[2];
/*
* Remove the cmdFrame
@@ -5960,7 +5962,6 @@ TEOEx_ListCallback(
iPtr->cmdFramePtr = eoFramePtr->nextPtr;
TclStackFree(interp, eoFramePtr);
- Tcl_DecrRefCount(copyPtr);
TclDecrRefCount(objPtr);
return result;
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index 9c668c2..ab324de 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.145 2008/07/21 22:22:27 nijtmans Exp $
+ * RCS: @(#) $Id: tclCmdIL.c,v 1.146 2008/07/23 20:49:52 andreas_kupries Exp $
*/
#include "tclInt.h"
@@ -1159,7 +1159,7 @@ TclInfoFrame(
*/
ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], -1));
- ADD_PAIR("line", Tcl_NewIntObj(framePtr->line[0]));
+ ADD_PAIR("line", Tcl_NewIntObj(1));
/*
* We put a duplicate of the command list obj into the result to
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index c754ef1..f484d7b 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.152 2008/07/22 22:24:21 andreas_kupries Exp $
+ * RCS: @(#) $Id: tclCompile.c,v 1.153 2008/07/23 20:49:52 andreas_kupries Exp $
*/
#include "tclInt.h"
@@ -914,9 +914,11 @@ TclInitCompileEnv(
envPtr->extCmdMapPtr->neiloc = 0;
envPtr->extCmdMapPtr->nueiloc = 0;
- if (invoker == NULL) {
+ if ((invoker == NULL) ||
+ (invoker->type == TCL_LOCATION_EVAL_LIST)) {
/*
- * Initialize the compiler for relative counting.
+ * Initialize the compiler for relative counting in case of a
+ * dynamic context.
*/
envPtr->line = 1;
diff --git a/tests/info.test b/tests/info.test
index 43fc794..7fd9ec1 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.51 2008/07/21 22:50:36 andreas_kupries Exp $
+# RCS: @(#) $Id: info.test,v 1.52 2008/07/23 20:49:52 andreas_kupries Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
@@ -1301,6 +1301,32 @@ namespace delete foo
# -------------------------------------------------------------------------
+test info-34.0 {eval pure list, single line} {
+ # 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.
+ #
+ # Problem: At the point where we see the list elements we cannot
+ # distinguish the two cases, thus we cannot switch between
+ # count/not-count, it is has to be one or the other for all
+ # cases. Of the two possibilities miguel convinced me that 'not
+ # counting' is the more proper.
+ set foo {b
+ c}
+ set cmd [list foreach $foo {x y} {
+ set res [join [lrange [etrace] 0 2] \n]
+ break
+ }]
+ 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}}
+
+# -------------------------------------------------------------------------
+
+# -------------------------------------------------------------------------
+
# cleanup
catch {namespace delete test_ns_info1 test_ns_info2}
::tcltest::cleanupTests