* 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.

6 files changed, 211 insertions, 99 deletions

diff --git a/ChangeLog b/ChangeLog
index ff7ad5a..b0cb633 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,18 @@
+2008-07-25  Andreas Kupries  <andreask@activestate.com>
+
+	* 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.
+
 2008-07-23  Andreas Kupries  <andreask@activestate.com>
 
 	* tests/info.test: Reordered the tests to have monotonously
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 9cb5707..917a8a5 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.295.2.4 2008/07/23 20:47:30 andreas_kupries Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.295.2.5 2008/07/25 20:30:34 andreas_kupries Exp $
  */
 
 #include "tclInt.h"
@@ -1409,6 +1409,10 @@ DeleteInterpProc(
 		ckfree((char *) eclPtr->loc);
 	    }
 
+	    if (eclPtr->eiloc != NULL) {
+		ckfree((char *) eclPtr->eiloc);
+	    }
+
 	    ckfree((char *) eclPtr);
 	    Tcl_DeleteHashEntry(hPtr);
 	}
@@ -4755,7 +4759,7 @@ TclArgumentGet(interp,obj,cfPtrPtr,wordPtr)
 	    ((List *)obj->internalRep.twoPtrValue.ptr1)->canonicalFlag)) {
 	return;
     }
-    
+
     /*
      * First look for location information recorded in the argument
      * stack. That is nearest.
@@ -4920,79 +4924,80 @@ TclEvalObjEx(
 
     Tcl_IncrRefCount(objPtr);
 
-    if (flags & TCL_EVAL_DIRECT) {
-	/*
-	 * We're not supposed to use the compiler or byte-code interpreter.
-	 * Let Tcl_EvalEx evaluate the command directly (and probably more
-	 * slowly).
-	 *
-	 * Pure List Optimization (no string representation). In this case, we
-	 * can safely use Tcl_EvalObjv instead and get an appreciable
-	 * improvement in 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 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 internal rep).
-	 */
+    /* Pure List Optimization (no string representation). In this case, we can
+     * safely use Tcl_EvalObjv instead and get an appreciable improvement in
+     * 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
+     * internal rep).
+     */
 
-	if (objPtr->typePtr == &tclListType) {	/* is a list... */
-	    List *listRepPtr = objPtr->internalRep.twoPtrValue.ptr1;
+    if (objPtr->typePtr == &tclListType) {	/* is a list... */
+	List *listRepPtr = objPtr->internalRep.twoPtrValue.ptr1;
 
-	    if (objPtr->bytes == NULL ||	/* ...without a string rep */
-		    listRepPtr->canonicalFlag) {/* ...or that is canonical */
-		/*
-		 * TIP #280 Structures for tracking lines. As we know that
-		 * this is dynamic execution we ignore the invoker, even if
-		 * known.
-		 */
+	if (objPtr->bytes == NULL ||	/* ...without a string rep */
+	    listRepPtr->canonicalFlag) {/* ...or that is canonical */
+	    /*
+	     * TIP #280 Structures for tracking lines. As we know that this is
+	     * dynamic execution we ignore the invoker, even if known.
+	     */
 
-		int nelements;
-		Tcl_Obj **elements, *copyPtr = TclListObjCopy(NULL, objPtr);
-		CmdFrame *eoFramePtr = (CmdFrame *)
-			TclStackAlloc(interp, sizeof(CmdFrame));
+	    int nelements;
+	    Tcl_Obj **elements, *copyPtr = TclListObjCopy(NULL, objPtr);
+	    CmdFrame *eoFramePtr = (CmdFrame *)
+		TclStackAlloc(interp, sizeof(CmdFrame));
 
-		eoFramePtr->type = TCL_LOCATION_EVAL_LIST;
-		eoFramePtr->level = (iPtr->cmdFramePtr == NULL?
-			1 : iPtr->cmdFramePtr->level + 1);
-		eoFramePtr->framePtr = iPtr->framePtr;
-		eoFramePtr->nextPtr = iPtr->cmdFramePtr;
+	    eoFramePtr->type = TCL_LOCATION_EVAL_LIST;
+	    eoFramePtr->level = (iPtr->cmdFramePtr == NULL?
+				 1 : iPtr->cmdFramePtr->level + 1);
+	    eoFramePtr->framePtr = iPtr->framePtr;
+	    eoFramePtr->nextPtr = iPtr->cmdFramePtr;
 
-		eoFramePtr->nline = 0;
-		eoFramePtr->line = NULL;
+	    eoFramePtr->nline = 0;
+	    eoFramePtr->line = NULL;
 
-		eoFramePtr->cmd.listPtr  = objPtr;
-		Tcl_IncrRefCount(eoFramePtr->cmd.listPtr);
-		eoFramePtr->data.eval.path = NULL;
+	    eoFramePtr->cmd.listPtr  = objPtr;
+	    Tcl_IncrRefCount(eoFramePtr->cmd.listPtr);
+	    eoFramePtr->data.eval.path = NULL;
 
-		/*
-		 * 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.
-		 */
+	    /*
+	     * 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.
+	     */
 
-		Tcl_ListObjGetElements(NULL, copyPtr,
-				       &nelements, &elements);
+	    Tcl_ListObjGetElements(NULL, copyPtr,
+				   &nelements, &elements);
 
-		iPtr->cmdFramePtr = eoFramePtr;
-		result = Tcl_EvalObjv(interp, nelements, elements,
-			flags);
+	    iPtr->cmdFramePtr = eoFramePtr;
+	    result = Tcl_EvalObjv(interp, nelements, elements,
+				  flags);
 
-		Tcl_DecrRefCount(copyPtr);
-		iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr;
-		Tcl_DecrRefCount(eoFramePtr->cmd.listPtr);
-		TclStackFree(interp, eoFramePtr);
+	    Tcl_DecrRefCount(copyPtr);
+	    iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr;
+	    Tcl_DecrRefCount(eoFramePtr->cmd.listPtr);
+	    TclStackFree(interp, eoFramePtr);
 
-		goto done;
-	    }
+	    goto done;
 	}
+    }
+
+    if (flags & TCL_EVAL_DIRECT) {
+	/*
+	 * We're not supposed to use the compiler or byte-code interpreter.
+	 * Let Tcl_EvalEx evaluate the command directly (and probably more
+	 * slowly).
+	 */
 
 	/*
 	 * TIP #280. Propagate context as much as we can. Especially if the
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index e557860..3c7ca6e 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.146.2.5 2008/07/23 20:47:32 andreas_kupries Exp $
+ * RCS: @(#) $Id: tclCompile.c,v 1.146.2.6 2008/07/25 20:30:44 andreas_kupries Exp $
  */
 
 #include "tclInt.h"
@@ -933,7 +933,22 @@ TclInitCompileEnv(
 	 * ...) which may make change the type as well.
 	 */
 
-	if ((invoker->nline <= word) || (invoker->line[word] < 0)) {
+	CmdFrame* ctxPtr = (CmdFrame *) TclStackAlloc(interp, sizeof(CmdFrame));
+	int pc = 0;
+
+	*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.
 	     */
@@ -941,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);
+		    Tcl_IncrRefCount(ctxPtr->data.eval.path);
 		}
 	    }
-	    TclStackFree(interp, ctxPtr);
 	}
+
+	TclStackFree(interp, ctxPtr);
     }
 
     envPtr->auxDataArrayPtr = envPtr->staticAuxDataArraySpace;
diff --git a/generic/tclProc.c b/generic/tclProc.c
index f9e6822..2b7c5f7 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.139.2.1 2008/07/21 19:38:19 andreas_kupries Exp $
+ * RCS: @(#) $Id: tclProc.c,v 1.139.2.2 2008/07/25 20:30:47 andreas_kupries Exp $
  */
 
 #include "tclInt.h"
@@ -2162,7 +2162,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/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