summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorandreas_kupries <akupries@shaw.ca>2008-07-21 19:37:35 (GMT)
committerandreas_kupries <akupries@shaw.ca>2008-07-21 19:37:35 (GMT)
commitc24d3516daee359922217e9267ba9e0e8aad1ce0 (patch)
treefafc8c6c64f4ad4f3c2dbb31b0e501a392f1f450
parent42ecaf98ac017a8cb5d769f57fd62677cc92ac4f (diff)
downloadtcl-c24d3516daee359922217e9267ba9e0e8aad1ce0.zip
tcl-c24d3516daee359922217e9267ba9e0e8aad1ce0.tar.gz
tcl-c24d3516daee359922217e9267ba9e0e8aad1ce0.tar.bz2
* generic/tclBasic.c: Extended the existing TIP #280 system (info
* generic/tclCmdAH.c: frame), added the ability to track the * generic/tclCompCmds.c: absolute location of literal procedure * generic/tclCompile.c: arguments, and making this information * generic/tclCompile.h: available to uplevel, eval, and * generic/tclInterp.c: siblings. This allows proper tracking of * generic/tclInt.h: absolute location through custom (Tcl-coded) * generic/tclNamesp.c: control structures based on uplevel, etc. * generic/tclProc.c:
-rw-r--r--ChangeLog12
-rw-r--r--generic/tclBasic.c282
-rw-r--r--generic/tclCmdAH.c9
-rw-r--r--generic/tclCompCmds.c10
-rw-r--r--generic/tclCompile.c49
-rw-r--r--generic/tclCompile.h12
-rw-r--r--generic/tclInt.h41
-rw-r--r--generic/tclInterp.c11
-rw-r--r--generic/tclNamesp.c11
-rw-r--r--generic/tclProc.c10
10 files changed, 391 insertions, 56 deletions
diff --git a/ChangeLog b/ChangeLog
index 3966ff0..53267af 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,15 @@
+2008-07-21 Andreas Kupries <andreask@activestate.com>
+
+ * generic/tclBasic.c: Extended the existing TIP #280 system (info
+ * generic/tclCmdAH.c: frame), added the ability to track the
+ * generic/tclCompCmds.c: absolute location of literal procedure
+ * generic/tclCompile.c: arguments, and making this information
+ * generic/tclCompile.h: available to uplevel, eval, and
+ * generic/tclInterp.c: siblings. This allows proper tracking of
+ * generic/tclInt.h: absolute location through custom (Tcl-coded)
+ * generic/tclNamesp.c: control structures based on uplevel, etc.
+ * generic/tclProc.c:
+
2008-07-07 Andreas Kupries <andreask@activestate.com>
* generic/tclCmdIL.c (InfoFrameCmd): Fixed unsafe idiom of setting
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index fd37b89..4ad59c7 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.28 2007/09/13 16:13:19 das Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.75.2.29 2008/07/21 19:37:40 andreas_kupries Exp $
*/
#include "tclInt.h"
@@ -360,8 +360,10 @@ Tcl_CreateInterp()
iPtr->cmdFramePtr = NULL;
iPtr->linePBodyPtr = (Tcl_HashTable*) ckalloc (sizeof (Tcl_HashTable));
iPtr->lineBCPtr = (Tcl_HashTable*) ckalloc (sizeof (Tcl_HashTable));
+ iPtr->lineLAPtr = (Tcl_HashTable*) ckalloc (sizeof (Tcl_HashTable));
Tcl_InitHashTable(iPtr->linePBodyPtr, TCL_ONE_WORD_KEYS);
Tcl_InitHashTable(iPtr->lineBCPtr, TCL_ONE_WORD_KEYS);
+ Tcl_InitHashTable(iPtr->lineLAPtr, TCL_ONE_WORD_KEYS);
#endif
iPtr->activeVarTracePtr = NULL;
@@ -1204,6 +1206,26 @@ DeleteInterpProc(interp)
Tcl_DeleteHashTable (iPtr->lineBCPtr);
ckfree((char*) iPtr->lineBCPtr);
iPtr->lineBCPtr = NULL;
+
+ /*
+ * Location stack for uplevel/eval/... scripts which were passed
+ * through proc arguments. Actually we track all arguments as we
+ * don't, cannot know which arguments will be used as scripts and
+ * which won't.
+ */
+
+ if (iPtr->lineLAPtr->numEntries) {
+ /*
+ * When the interp goes away we have nothing on the stack, so
+ * there are no arguments, so this table has to be empty.
+ */
+
+ Tcl_Panic ("Argument location tracking table not empty");
+ }
+
+ Tcl_DeleteHashTable (iPtr->lineLAPtr);
+ ckfree((char*) iPtr->lineLAPtr);
+ iPtr->lineLAPtr = NULL;
}
#endif
ckfree((char *) iPtr);
@@ -4005,6 +4027,7 @@ EvalEx(interp, script, numBytes, flags, line)
eeFrame.cmd.str.len --;
}
+ TclArgumentEnter (interp, objv, objectsUsed, &eeFrame);
iPtr->cmdFramePtr = &eeFrame;
#endif
iPtr->numLevels++;
@@ -4013,6 +4036,7 @@ EvalEx(interp, script, numBytes, flags, line)
iPtr->numLevels--;
#ifdef TCL_TIP280
iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr;
+ TclArgumentRelease (interp, objv, objectsUsed);
ckfree ((char*) eeFrame.line);
eeFrame.line = NULL;
@@ -4271,6 +4295,207 @@ TclAdvanceLines (line,start,end)
}
}
}
+
+/*
+ *----------------------------------------------------------------------
+ * Note: The whole data structure access for argument location tracking is
+ * hidden behind these three functions. The only parts open are the lineLAPtr
+ * field in the Interp structure. The CFWord definition is internal to here.
+ * Should make it easier to redo the data structures if we find something more
+ * space/time efficient.
+ */
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclArgumentEnter --
+ *
+ * This procedure is a helper for the TIP #280 uplevel extension.
+ * It enters location references for the arguments of a command to be
+ * invoked. Only the first entry has the actual data, further entries
+ * simply count the usage up.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * May allocate memory.
+ *
+ * TIP #280
+ *----------------------------------------------------------------------
+ */
+
+void
+TclArgumentEnter(interp,objv,objc,cfPtr)
+ Tcl_Interp* interp;
+ Tcl_Obj** objv;
+ int objc;
+ CmdFrame* cfPtr;
+{
+ Interp* iPtr = (Interp*) interp;
+ int new, i;
+ Tcl_HashEntry* hPtr;
+ CFWord* cfwPtr;
+
+ for (i=1; i < objc; i++) {
+ /*
+ * Ignore argument words without line information (= dynamic). If
+ * they are variables they may have location information associated
+ * with that, either through globally recorded 'set' invokations, or
+ * literals in bytecode. Eitehr way there is no need to record
+ * something here.
+ */
+
+ if (cfPtr->line [i] < 0) continue;
+ hPtr = Tcl_CreateHashEntry (iPtr->lineLAPtr, (char*) objv[i], &new);
+ if (new) {
+ /*
+ * The word is not on the stack yet, remember the current location
+ * and initialize references.
+ */
+ cfwPtr = (CFWord*) ckalloc (sizeof (CFWord));
+ cfwPtr->framePtr = cfPtr;
+ cfwPtr->word = i;
+ cfwPtr->refCount = 1;
+ Tcl_SetHashValue (hPtr, cfwPtr);
+ } else {
+ /*
+ * The word is already on the stack, its current location is not
+ * relevant. Just remember the reference to prevent early removal.
+ */
+ cfwPtr = (CFWord*) Tcl_GetHashValue (hPtr);
+ cfwPtr->refCount ++;
+ }
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclArgumentRelease --
+ *
+ * This procedure is a helper for the TIP #280 uplevel extension.
+ * It removes the location references for the arguments of a command
+ * just done. Usage is counted down, the data is removed only when
+ * no user is left over.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * May release memory.
+ *
+ * TIP #280
+ *----------------------------------------------------------------------
+ */
+
+void
+TclArgumentRelease(interp,objv,objc)
+ Tcl_Interp* interp;
+ Tcl_Obj** objv;
+ int objc;
+{
+ Interp* iPtr = (Interp*) interp;
+ Tcl_HashEntry* hPtr;
+ CFWord* cfwPtr;
+ int i;
+
+ for (i=1; i < objc; i++) {
+ hPtr = Tcl_FindHashEntry (iPtr->lineLAPtr, (char *) objv[i]);
+
+ if (!hPtr) { continue; }
+ cfwPtr = (CFWord*) Tcl_GetHashValue (hPtr);
+
+ cfwPtr->refCount --;
+ if (cfwPtr->refCount > 0) { continue; }
+
+ ckfree ((char*) cfwPtr);
+ Tcl_DeleteHashEntry (hPtr);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclArgumentGet --
+ *
+ * This procedure is a helper for the TIP #280 uplevel extension.
+ * It find the location references for a Tcl_Obj, if any.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Writes found location information into the result arguments.
+ *
+ * TIP #280
+ *----------------------------------------------------------------------
+ */
+
+void
+TclArgumentGet(interp,obj,cfPtrPtr,wordPtr)
+ Tcl_Interp* interp;
+ Tcl_Obj* obj;
+ CmdFrame** cfPtrPtr;
+ int* wordPtr;
+{
+ Interp* iPtr = (Interp*) interp;
+ Tcl_HashEntry* hPtr;
+ CmdFrame* framePtr;
+
+ /*
+ * First look for location information recorded in the argument
+ * stack. That is nearest.
+ */
+
+ hPtr = Tcl_FindHashEntry (iPtr->lineLAPtr, (char *) obj);
+ if (hPtr) {
+ CFWord* cfwPtr = (CFWord*) Tcl_GetHashValue (hPtr);
+ *wordPtr = cfwPtr->word;
+ *cfPtrPtr = cfwPtr->framePtr;
+ return;
+ }
+
+ /*
+ * Check if the Tcl_Obj has location information as a bytecode literal. We
+ * have to scan the stack up and check all bytecode frames for a possible
+ * definition.
+ */
+
+ for (framePtr = iPtr->cmdFramePtr;
+ framePtr;
+ framePtr = framePtr->nextPtr) {
+ const ByteCode* codePtr;
+ Tcl_HashEntry* hePtr;
+
+ if (framePtr->type != TCL_LOCATION_BC) continue;
+
+ codePtr = framePtr->data.tebc.codePtr;
+ hePtr = Tcl_FindHashEntry (iPtr->lineBCPtr, (char *) codePtr);
+
+ if (hePtr) {
+ ExtCmdLoc* eclPtr = (ExtCmdLoc*) Tcl_GetHashValue (hePtr);
+ Tcl_HashEntry *hlPtr = Tcl_FindHashEntry (&eclPtr->litIndex, (char *) obj);
+
+ if (hlPtr) {
+ /*
+ * Convert from the current invoker CmdFrame to a CmdFrame
+ * refering to the actual word location. We are directly
+ * manipulating the relevant command frame in the frame stack.
+ * That is no problem because TEBC is already setting the pc
+ * for each invokation, so moving it somewhere will not affect
+ * the following commands.
+ */
+
+ ExtIndex* eiPtr = (ExtIndex*) Tcl_GetHashValue (hlPtr);
+
+ framePtr->data.tebc.pc = codePtr->codeStart + eiPtr->pc;
+ *cfPtrPtr = framePtr;
+ *wordPtr = eiPtr->word;
+ }
+ }
+ }
+}
#endif
/*
@@ -4556,46 +4781,37 @@ TclEvalObjEx(interp, objPtr, flags, invoker, word)
* complex invokations.
*/
- if ((invoker->nline <= word) || (invoker->line[word] < 0)) {
- /* Dynamic script, or dynamic context, force our own
- * context */
-
- script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
- result = Tcl_EvalEx(interp, script, numSrcBytes, flags);
+ CmdFrame ctx = *invoker;
+ int pc = 0;
- } else {
- /* Try to get an absolute context for the evaluation
+ 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;
+ }
- CmdFrame ctx = *invoker;
- int pc = 0;
+ script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
- 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) ||
+ (ctx.type != TCL_LOCATION_SOURCE)) {
+ /* Dynamic script, or dynamic context, force our own
+ * context */
- if (ctx.type == TCL_LOCATION_SOURCE) {
- /* Absolute context to reuse. */
+ result = Tcl_EvalEx(interp, script, numSrcBytes, flags);
+ } else {
+ /* Absolute context available to reuse. */
- iPtr->invokeCmdFramePtr = &ctx;
- iPtr->evalFlags |= TCL_EVAL_CTX;
+ iPtr->invokeCmdFramePtr = &ctx;
+ iPtr->evalFlags |= TCL_EVAL_CTX;
- script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
- result = EvalEx(interp, script, numSrcBytes, flags, ctx.line [word]);
+ result = EvalEx(interp, script, numSrcBytes, flags, ctx.line [word]);
- if (pc) {
- /* Death of SrcInfo reference */
- Tcl_DecrRefCount (ctx.data.eval.path);
- }
- } else {
- /* Dynamic context or script, easier to make our own as
- * well */
- script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
- result = Tcl_EvalEx(interp, script, numSrcBytes, flags);
+ if (pc) {
+ /* Death of SrcInfo reference */
+ Tcl_DecrRefCount (ctx.data.eval.path);
}
}
}
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index 6621714..1b63198 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.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: tclCmdAH.c,v 1.27.2.16 2006/11/28 22:20:00 andreas_kupries Exp $
+ * RCS: @(#) $Id: tclCmdAH.c,v 1.27.2.17 2008/07/21 19:37:41 andreas_kupries Exp $
*/
#include "tclInt.h"
@@ -613,9 +613,12 @@ Tcl_EvalObjCmd(dummy, interp, objc, objv)
#ifndef TCL_TIP280
result = Tcl_EvalObjEx(interp, objv[1], TCL_EVAL_DIRECT);
#else
- /* TIP #280. Make invoking context available to eval'd script */
+ /* TIP #280. Make argument location available to eval'd script */
+ CmdFrame* invoker = iPtr->cmdFramePtr;
+ int word = 1;
+ TclArgumentGet (interp, objv[1], &invoker, &word);
result = TclEvalObjEx(interp, objv[1], TCL_EVAL_DIRECT,
- iPtr->cmdFramePtr,1);
+ invoker, word);
#endif
} else {
/*
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index d2cd4bb..3c83a58 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.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: tclCompCmds.c,v 1.39.2.6 2007/03/01 16:06:19 dkf Exp $
+ * RCS: @(#) $Id: tclCompCmds.c,v 1.39.2.7 2008/07/21 19:37:42 andreas_kupries Exp $
*/
#include "tclInt.h"
@@ -62,7 +62,7 @@ AuxDataType tclForeachInfoType = {
* The return value is a standard Tcl result, which is normally TCL_OK
* unless there was an error while parsing string. If an error occurs
* then the interpreter's result contains a standard error message. If
- * complation fails because the command requires a second level of
+ * compilation fails because the command requires a second level of
* substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the
* command should be compiled "out of line" by emitting code to
* invoke its command procedure (Tcl_AppendObjCmd) at runtime.
@@ -1756,7 +1756,7 @@ TclCompileIncrCmd(interp, parsePtr, envPtr)
* The return value is a standard Tcl result, which is normally TCL_OK
* unless there was an error while parsing string. If an error occurs
* then the interpreter's result contains a standard error message. If
- * complation fails because the command requires a second level of
+ * compilation fails because the command requires a second level of
* substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the
* command should be compiled "out of line" by emitting code to
* invoke its command procedure (Tcl_LappendObjCmd) at runtime.
@@ -1994,7 +1994,7 @@ TclCompileLindexCmd(interp, parsePtr, envPtr)
* The return value is a standard Tcl result, which is normally TCL_OK
* unless there was an error while parsing string. If an error occurs
* then the interpreter's result contains a standard error message. If
- * complation fails because the command requires a second level of
+ * compilation fails because the command requires a second level of
* substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the
* command should be compiled "out of line" by emitting code to
* invoke its command procedure (Tcl_ListObjCmd) at runtime.
@@ -2706,7 +2706,7 @@ TclCompileReturnCmd(interp, parsePtr, envPtr)
* The return value is a standard Tcl result, which is normally TCL_OK
* unless there was an error while parsing string. If an error occurs
* then the interpreter's result contains a standard error message. If
- * complation fails because the set command requires a second level of
+ * compilation fails because the set command requires a second level of
* substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the
* set command should be compiled "out of line" by emitting code to
* invoke its command procedure (Tcl_SetCmd) at runtime.
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 59617b0..d8e22e2 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.8 2007/08/24 11:22:16 msofer Exp $
+ * RCS: @(#) $Id: tclCompile.c,v 1.43.2.9 2008/07/21 19:37:43 andreas_kupries Exp $
*/
#include "tclInt.h"
@@ -702,6 +702,8 @@ TclCleanupByteCode(codePtr)
if (hePtr) {
ExtCmdLoc* eclPtr = (ExtCmdLoc*) Tcl_GetHashValue (hePtr);
int i;
+ Tcl_HashSearch hSearch;
+ Tcl_HashEntry *hlPtr;
if (eclPtr->type == TCL_LOCATION_SOURCE) {
Tcl_DecrRefCount (eclPtr->path);
@@ -714,6 +716,15 @@ TclCleanupByteCode(codePtr)
ckfree ((char*) eclPtr->loc);
}
+ /* Release index of literals as well. */
+ for (hlPtr = Tcl_FirstHashEntry(&eclPtr->litIndex, &hSearch);
+ hlPtr != NULL;
+ hlPtr = Tcl_NextHashEntry(&hSearch)) {
+ ExtIndex* eiPtr = (ExtIndex*) Tcl_GetHashValue (hlPtr);
+ ckfree((char*) eiPtr);
+ Tcl_DeleteHashEntry (hlPtr);
+ }
+ Tcl_DeleteHashTable (&eclPtr->litIndex);
ckfree ((char*) eclPtr);
Tcl_DeleteHashEntry (hePtr);
}
@@ -806,6 +817,7 @@ TclInitCompileEnv(interp, envPtr, string, numBytes, invoker, word)
envPtr->extCmdMapPtr->nloc = 0;
envPtr->extCmdMapPtr->nuloc = 0;
envPtr->extCmdMapPtr->path = NULL;
+ Tcl_InitHashTable(&envPtr->extCmdMapPtr->litIndex, TCL_ONE_WORD_KEYS);
if (invoker == NULL) {
/* Initialize the compiler for relative counting */
@@ -1241,8 +1253,25 @@ TclCompileScript(interp, script, numBytes, nested, envPtr)
cmdPtr);
}
} else {
+ /* Simple argument word of a command. We reach this if
+ * and only if the command word was not compiled for
+ * whatever reason. Register the literal's location
+ * for use by uplevel, etc. commands, should they
+ * encounter it unmodified. We care only if the we are
+ * in a context which already allows absolute
+ * counting.
+ */
+
objIndex = TclRegisterNewLiteral(envPtr,
tokenPtr[1].start, tokenPtr[1].size);
+#ifdef TCL_TIP280
+ if (eclPtr->type == TCL_LOCATION_SOURCE) {
+ TclEnterCmdWordIndex (eclPtr,
+ envPtr->literalArrayPtr[objIndex].objPtr,
+ envPtr->codeNext - envPtr->codeStart,
+ wordIdx);
+ }
+#endif
}
TclEmitPush(objIndex, envPtr);
} else {
@@ -2459,6 +2488,24 @@ EnterCmdWordData(eclPtr, srcOffset, tokenPtr, cmd, len, numWords, line, wlines)
*wlines = wwlines;
eclPtr->nuloc ++;
}
+
+void
+TclEnterCmdWordIndex (eclPtr, obj, pc, word)
+ ExtCmdLoc *eclPtr;
+ Tcl_Obj* obj;
+ int pc;
+ int word;
+{
+ int new;
+ ExtIndex* eiPtr = (ExtIndex*) ckalloc (sizeof (ExtIndex));
+
+ eiPtr->pc = pc;
+ eiPtr->word = word;
+
+ Tcl_SetHashValue (Tcl_CreateHashEntry (&eclPtr->litIndex,
+ (char*) obj, &new),
+ eiPtr);
+}
#endif
/*
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 06414fd..8192aa4 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -9,7 +9,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.h,v 1.33.2.2 2007/09/13 15:28:11 das Exp $
+ * RCS: @(#) $Id: tclCompile.h,v 1.33.2.3 2008/07/21 19:37:43 andreas_kupries Exp $
*/
#ifndef _TCLCOMPILATION
@@ -137,7 +137,7 @@ typedef struct CmdLocation {
typedef struct ECL {
int srcOffset; /* cmd location to find the entry */
- int nline;
+ int nline; /* Number of words in the command */
int* line; /* line information for all words in the command */
} ECL;
typedef struct ExtCmdLoc {
@@ -146,7 +146,15 @@ typedef struct ExtCmdLoc {
ECL* loc; /* Command word locations (lines) */
int nloc; /* Number of allocated entries in 'loc' */
int nuloc; /* Number of used entries in 'loc' */
+ Tcl_HashTable litIndex; /* HashValue is ExtIndex* */
} ExtCmdLoc;
+typedef struct ExtIndex {
+ int pc; /* Instruction pointer of the command in ExtCmdLoc.loc[.] */
+ int word; /* Index of word in ExtCmdLoc.loc[cmd]->line[.] */
+} ExtIndex;
+
+EXTERN void TclEnterCmdWordIndex _ANSI_ARGS_((
+ ExtCmdLoc *eclPtr, Tcl_Obj* obj, int pc, int word));
#endif
/*
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 76544c0..18f1c70 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -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: tclInt.h,v 1.118.2.30 2007/09/13 15:28:13 das Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.118.2.31 2008/07/21 19:37:43 andreas_kupries Exp $
*/
#ifndef _TCLINT
@@ -910,7 +910,13 @@ typedef struct CmdFrame {
#define TCL_LOCATION_PROC (5) /* Location in a dynamic proc */
#define TCL_LOCATION_LAST (6) /* Number of values in the enum */
-#endif
+
+typedef struct CFWord {
+ CmdFrame* framePtr; /* CmdFrame to acess */
+ int word; /* Index of the word in the command */
+ int refCount; /* #times the word is on the stack */
+} CFWord;
+#endif /* TCL_TIP280 */
/*
*----------------------------------------------------------------
@@ -1488,13 +1494,34 @@ typedef struct Interp {
* location information for its
* body. It is keyed by the address of
* the Proc structure for a procedure.
+ * The values are "struct CmdFrame*".
*/
Tcl_HashTable* lineBCPtr;
/* This table remembers for each
* ByteCode object the location
* information for its body. It is
* keyed by the address of the Proc
- * structure for a procedure.
+ * structure for a procedure. The
+ * values are "struct ExtCmdLoc*" (See
+ * tclCompile.h).
+ */
+ Tcl_HashTable* lineLAPtr;
+ /* This table remembers for each
+ * argument of a command on the
+ * execution stack the index of the
+ * argument in the command, and the
+ * location data of the command. It is
+ * keyed by the address of the Tcl_Obj
+ * containing the argument. The values
+ * are "struct CFWord*" (See
+ * tclBasic.c). This allows commands
+ * like uplevel, eval, etc. to find
+ * location information for their
+ * arguments, if they are a proper
+ * literal argument to an invoking
+ * command. Alt view: An index to the
+ * CmdFrame stack keyed by command
+ * argument holders.
*/
#endif
#ifdef TCL_TIP268
@@ -1826,6 +1853,14 @@ EXTERN int TclEvalObjEx _ANSI_ARGS_((Tcl_Interp *interp,
int flags,
CONST CmdFrame* invoker,
int word));
+
+EXTERN void TclArgumentEnter _ANSI_ARGS_((Tcl_Interp* interp,
+ Tcl_Obj* objv[], int objc, CmdFrame* cf));
+EXTERN void TclArgumentRelease _ANSI_ARGS_((Tcl_Interp* interp,
+ Tcl_Obj* objv[], int objc));
+
+EXTERN void TclArgumentGet _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj* obj,
+ CmdFrame** cfPtrPtr, int* wordPtr));
#endif
EXTERN void TclExpandTokenArray _ANSI_ARGS_((
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index bd2db56..88438d7 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInterp.c,v 1.20.2.4 2008/01/30 10:46:56 msofer Exp $
+ * RCS: @(#) $Id: tclInterp.c,v 1.20.2.5 2008/07/21 19:37:43 andreas_kupries Exp $
*/
#include "tclInt.h"
@@ -2094,9 +2094,12 @@ SlaveEval(interp, slaveInterp, objc, objv)
#ifndef TCL_TIP280
result = Tcl_EvalObjEx(slaveInterp, objv[0], 0);
#else
- /* TIP #280 : Make invoker available to eval'd script */
- Interp* iPtr = (Interp*) interp;
- result = TclEvalObjEx(slaveInterp, objv[0], 0, iPtr->cmdFramePtr,0);
+ /* TIP #280 : Make actual argument location available to eval'd script */
+ Interp* iPtr = (Interp*) interp;
+ CmdFrame* invoker = iPtr->cmdFramePtr;
+ int word = 0;
+ TclArgumentGet (interp, objv[0], &invoker, &word);
+ result = TclEvalObjEx(slaveInterp, objv[0], 0, invoker, word);
#endif
} else {
objPtr = Tcl_ConcatObj(objc, objv);
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 8f42df6..07e5ea6 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -19,7 +19,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclNamesp.c,v 1.31.2.14 2007/05/15 18:32:18 dgp Exp $
+ * RCS: @(#) $Id: tclNamesp.c,v 1.31.2.15 2008/07/21 19:37:44 andreas_kupries Exp $
*/
#include "tclInt.h"
@@ -3006,9 +3006,12 @@ NamespaceEvalCmd(dummy, interp, objc, objv)
#ifndef TCL_TIP280
result = Tcl_EvalObjEx(interp, objv[3], 0);
#else
- /* TIP #280 : Make invoker available to eval'd script */
- Interp* iPtr = (Interp*) interp;
- result = TclEvalObjEx(interp, objv[3], 0, iPtr->cmdFramePtr,3);
+ /* TIP #280 : Make actual argument location available to eval'd script */
+ Interp* iPtr = (Interp*) interp;
+ CmdFrame* invoker = iPtr->cmdFramePtr;
+ int word = 3;
+ TclArgumentGet (interp, objv[3], &invoker, &word);
+ result = TclEvalObjEx(interp, objv[3], 0, invoker, word);
#endif
} else {
/*
diff --git a/generic/tclProc.c b/generic/tclProc.c
index d903ae6..b2c2b8d 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.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: tclProc.c,v 1.44.2.7 2007/09/13 15:28:17 das Exp $
+ * RCS: @(#) $Id: tclProc.c,v 1.44.2.8 2008/07/21 19:37:45 andreas_kupries Exp $
*/
#include "tclInt.h"
@@ -735,7 +735,15 @@ Tcl_UplevelObjCmd(dummy, interp, objc, objv)
*/
if (objc == 1) {
+#ifdef TCL_TIP280
+ /* TIP #280. Make argument location available to eval'd script */
+ CmdFrame* invoker = NULL;
+ int word = 0;
+ TclArgumentGet (interp, objv[0], &invoker, &word);
+ result = TclEvalObjEx(interp, objv[0], TCL_EVAL_DIRECT, invoker, word);
+#else
result = Tcl_EvalObjEx(interp, objv[0], TCL_EVAL_DIRECT);
+#endif
} else {
/*
* More than one argument: concatenate them together with spaces