summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
authorandreas_kupries <akupries@shaw.ca>2008-07-21 22:50:30 (GMT)
committerandreas_kupries <akupries@shaw.ca>2008-07-21 22:50:30 (GMT)
commitd0b609270a5168026fc5df405c4245ae2e33deed (patch)
tree29f73567f546804a17604f4a80c01c4551d51979 /generic
parent57bdff7e68cb1e0fe66a2671b18ce67ecbb79e69 (diff)
downloadtcl-d0b609270a5168026fc5df405c4245ae2e33deed.zip
tcl-d0b609270a5168026fc5df405c4245ae2e33deed.tar.gz
tcl-d0b609270a5168026fc5df405c4245ae2e33deed.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: * tests/info.test:
Diffstat (limited to 'generic')
-rw-r--r--generic/tclBasic.c300
-rw-r--r--generic/tclCmdAH.c11
-rw-r--r--generic/tclCompile.c47
-rw-r--r--generic/tclCompile.h13
-rw-r--r--generic/tclInt.h33
-rw-r--r--generic/tclInterp.c10
-rw-r--r--generic/tclNamesp.c19
-rw-r--r--generic/tclProc.c12
8 files changed, 383 insertions, 62 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index c7faf44..9ccc388 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.321 2008/07/21 21:54:06 das Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.322 2008/07/21 22:50:34 andreas_kupries Exp $
*/
#include "tclInt.h"
@@ -497,8 +497,10 @@ Tcl_CreateInterp(void)
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);
iPtr->activeVarTracePtr = NULL;
@@ -1517,6 +1519,26 @@ DeleteInterpProc(
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;
}
Tcl_DeleteHashTable(&iPtr->varTraces);
@@ -5058,9 +5080,11 @@ TclEvalEx(
eeFramePtr->nline = objectsUsed;
eeFramePtr->line = lines;
+ TclArgumentEnter (interp, objv, objectsUsed, eeFramePtr);
iPtr->cmdFramePtr = eeFramePtr;
code = TclEvalObjv(interp, objectsUsed, objv, TCL_EVAL_NOERR, NULL);
iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr;
+ TclArgumentRelease (interp, objv, objectsUsed);
eeFramePtr->line = NULL;
eeFramePtr->nline = 0;
@@ -5210,6 +5234,207 @@ TclAdvanceLines(
/*
*----------------------------------------------------------------------
+ * 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;
+ }
+ }
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
*
* Tcl_Eval --
*
@@ -5494,65 +5719,52 @@ TclNREvalObjEx(
* invokations.
*/
- if ((invoker->nline <= word) || (invoker->line[word] < 0)) {
+ int pc = 0;
+ CmdFrame *ctxPtr = (CmdFrame *)
+ TclStackAlloc(interp, sizeof(CmdFrame));
+
+ *ctxPtr = *invoker;
+ if (invoker->type == TCL_LOCATION_BC) {
+ /*
+ * Note: Type BC => ctxPtr->data.eval.path is not used.
+ * ctxPtr->data.tebc.codePtr is used instead.
+ */
+
+ TclGetSrcInfoForPc(ctxPtr);
+ pc = 1;
+ }
+
+ script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
+
+ if ((invoker->nline <= word) ||
+ (invoker->line[word] < 0) ||
+ (ctxPtr->type != TCL_LOCATION_SOURCE)) {
/*
* Dynamic script, or dynamic context, force our own context.
*/
- script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
result = Tcl_EvalEx(interp, script, numSrcBytes, flags);
} else {
/*
- * Try to get an absolute context for the evaluation.
+ * Absolute context to reuse.
*/
- int pc = 0;
- CmdFrame *ctxPtr = (CmdFrame *)
- TclStackAlloc(interp, sizeof(CmdFrame));
+ iPtr->invokeCmdFramePtr = ctxPtr;
+ iPtr->evalFlags |= TCL_EVAL_CTX;
- *ctxPtr = *invoker;
- if (invoker->type == TCL_LOCATION_BC) {
- /*
- * Note: Type BC => ctxPtr->data.eval.path is not used.
- * ctxPtr->data.tebc.codePtr is used instead.
- */
-
- TclGetSrcInfoForPc(ctxPtr);
- pc = 1;
- }
+ result = TclEvalEx(interp, script, numSrcBytes, flags,
+ ctxPtr->line[word]);
- if (ctxPtr->type == TCL_LOCATION_SOURCE) {
+ if (pc) {
/*
- * Absolute context to reuse.
+ * Death of SrcInfo reference.
*/
-
- iPtr->invokeCmdFramePtr = ctxPtr;
- iPtr->evalFlags |= TCL_EVAL_CTX;
-
- script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
- result = TclEvalEx(interp, script, numSrcBytes, flags,
- ctxPtr->line[word]);
-
- if (pc) {
- /*
- * Death of SrcInfo reference.
- */
-
- Tcl_DecrRefCount(ctxPtr->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);
+
+ Tcl_DecrRefCount(ctxPtr->data.eval.path);
}
-
- TclStackFree(interp, ctxPtr);
}
+ TclStackFree(interp, ctxPtr);
}
TclDecrRefCount(objPtr);
return result;
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index 303ecd5..6f4778b 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -10,7 +10,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.98 2008/07/21 22:22:27 nijtmans Exp $
+ * RCS: @(#) $Id: tclCmdAH.c,v 1.99 2008/07/21 22:50:34 andreas_kupries Exp $
*/
#include "tclInt.h"
@@ -657,10 +657,15 @@ Tcl_EvalObjCmd(
if (objc == 2) {
/*
- * TIP #280. Make invoking context available to eval'd script.
+ * TIP #280. Make argument location available to eval'd script.
*/
- result = TclEvalObjEx(interp, objv[1], TCL_EVAL_DIRECT, iPtr->cmdFramePtr, 1);
+ CmdFrame* invoker = iPtr->cmdFramePtr;
+ int word = 1;
+ TclArgumentGet (interp, objv[1], &invoker, &word);
+
+ result = TclEvalObjEx(interp, objv[1], TCL_EVAL_DIRECT,
+ invoker, word);
} else {
/*
* More than one argument: concatenate them together with spaces
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 187d81e..88d8b86 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.149 2008/06/08 03:21:33 msofer Exp $
+ * RCS: @(#) $Id: tclCompile.c,v 1.150 2008/07/21 22:50:34 andreas_kupries Exp $
*/
#include "tclInt.h"
@@ -801,6 +801,8 @@ TclCleanupByteCode(
if (hePtr) {
ExtCmdLoc *eclPtr = Tcl_GetHashValue(hePtr);
int i;
+ Tcl_HashSearch hSearch;
+ Tcl_HashEntry *hlPtr;
if (eclPtr->type == TCL_LOCATION_SOURCE) {
Tcl_DecrRefCount(eclPtr->path);
@@ -813,6 +815,15 @@ TclCleanupByteCode(
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);
}
@@ -902,6 +913,7 @@ TclInitCompileEnv(
envPtr->extCmdMapPtr->nloc = 0;
envPtr->extCmdMapPtr->nuloc = 0;
envPtr->extCmdMapPtr->path = NULL;
+ Tcl_InitHashTable(&envPtr->extCmdMapPtr->litIndex, TCL_ONE_WORD_KEYS);
if (invoker == NULL) {
/*
@@ -1441,8 +1453,23 @@ TclCompileScript(
TclHideLiteral(interp, envPtr, objIndex);
}
} 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);
+
+ if (eclPtr->type == TCL_LOCATION_SOURCE) {
+ TclEnterCmdWordIndex (eclPtr,
+ envPtr->literalArrayPtr[objIndex].objPtr,
+ envPtr->codeNext - envPtr->codeStart,
+ wordIdx);
+ }
}
TclEmitPush(objIndex, envPtr);
} /* for loop */
@@ -2442,6 +2469,24 @@ EnterCmdWordData(
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);
+}
+
/*
*----------------------------------------------------------------------
*
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 21ff9cc..a27bbd9 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.93 2008/07/13 09:03:33 msofer Exp $
+ * RCS: @(#) $Id: tclCompile.h,v 1.94 2008/07/21 22:50:34 andreas_kupries Exp $
*/
#ifndef _TCLCOMPILATION
@@ -129,7 +129,7 @@ typedef struct CmdLocation {
typedef struct ECL {
int srcOffset; /* Command 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;
@@ -141,8 +141,17 @@ 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 a command in ExtCmdLoc.loc[.] */
+ int word; /* Index of word in ExtCmdLoc.loc[cmd]->line[.] */
+} ExtIndex;
+
+EXTERN void TclEnterCmdWordIndex (ExtCmdLoc *eclPtr, Tcl_Obj* obj,
+ int pc, int word);
+
/*
* CompileProcs need the ability to record information during compilation that
* can be used by bytecode instructions during execution. The AuxData
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 1857153..7614f32 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -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: tclInt.h,v 1.375 2008/07/21 16:26:06 msofer Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.376 2008/07/21 22:50:34 andreas_kupries Exp $
*/
#ifndef _TCLINT
@@ -1150,6 +1150,12 @@ typedef struct CmdFrame {
} cmd;
} CmdFrame;
+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;
+
/*
* The following macros define the allowed values for the type field of the
* CmdFrame structure above. Some of the values occur only in the extended
@@ -1862,11 +1868,26 @@ typedef struct Interp {
Tcl_HashTable *linePBodyPtr;/* This table remembers for each statically
* defined procedure the location information
* for its body. It is keyed by the address of
- * the Proc structure for a procedure. */
+ * 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. */
+ * Proc 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. */
/*
* TIP #268. The currently active selection mode, i.e. the package require
* preferences.
@@ -2486,6 +2507,12 @@ MODULE_SCOPE int TclEvalObjv(Tcl_Interp *interp, int objc,
MODULE_SCOPE void TclAdvanceLines(int *line, const char *start,
const char *end);
+MODULE_SCOPE void TclArgumentEnter(Tcl_Interp* interp,
+ Tcl_Obj* objv[], int objc, CmdFrame* cf);
+MODULE_SCOPE void TclArgumentRelease(Tcl_Interp* interp,
+ Tcl_Obj* objv[], int objc);
+MODULE_SCOPE void TclArgumentGet(Tcl_Interp* interp, Tcl_Obj* obj,
+ CmdFrame** cfPtrPtr, int* wordPtr);
MODULE_SCOPE int TclArraySet(Tcl_Interp *interp,
Tcl_Obj *arrayNameObj, Tcl_Obj *arrayElemObj);
MODULE_SCOPE double TclBignumToDouble(mp_int *bignum);
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index b4b89a4..6c55d97 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -10,7 +10,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.91 2008/07/19 22:50:40 nijtmans Exp $
+ * RCS: @(#) $Id: tclInterp.c,v 1.92 2008/07/21 22:50:35 andreas_kupries Exp $
*/
#include "tclInt.h"
@@ -2614,7 +2614,7 @@ SlaveEval(
if (objc == 1) {
/*
- * TIP #280: Make invoker available to eval'd script.
+ * TIP #280: Make actual argument location available to eval'd script.
*
* Do not let any intReps accross, with the exception of
* bytecodes. The intrep spoiling is due to happen anyway when
@@ -2622,6 +2622,8 @@ SlaveEval(
*/
Interp *iPtr = (Interp *) interp;
+ CmdFrame* invoker = iPtr->cmdFramePtr;
+ int word = 0;
objPtr = objv[0];
if (objPtr->typePtr
@@ -2631,8 +2633,10 @@ SlaveEval(
TclFreeIntRep(objPtr);
objPtr->typePtr = NULL;
}
+
+ TclArgumentGet (interp, objPtr, &invoker, &word);
- result = TclEvalObjEx(slaveInterp, objPtr, 0, iPtr->cmdFramePtr, 0);
+ result = TclEvalObjEx(slaveInterp, objPtr, 0, invoker, word);
} else {
objPtr = Tcl_ConcatObj(objc, objv);
Tcl_IncrRefCount(objPtr);
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index cf7e250..3eda959 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -23,7 +23,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.170 2008/07/21 16:26:08 msofer Exp $
+ * RCS: @(#) $Id: tclNamesp.c,v 1.171 2008/07/21 22:50:36 andreas_kupries Exp $
*/
#include "tclInt.h"
@@ -3265,6 +3265,8 @@ NamespaceEvalCmd(
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
+ CmdFrame* invoker;
+ int word;
Tcl_Namespace *namespacePtr;
CallFrame *framePtr, **framePtrPtr;
Tcl_Obj *objPtr;
@@ -3312,7 +3314,14 @@ NamespaceEvalCmd(
framePtr->objv = objv;
if (objc == 4) {
- objPtr = objv[3];
+ /*
+ * TIP #280: Make actual argument location available to eval'd script.
+ */
+
+ objPtr = objv[3];
+ invoker = iPtr->cmdFramePtr;
+ word = 3;
+ TclArgumentGet (interp, objPtr, &invoker, &word);
} else {
/*
* More than one argument: concatenate them together with spaces
@@ -3320,7 +3329,9 @@ NamespaceEvalCmd(
* object when it decrements its refcount after eval'ing it.
*/
- objPtr = Tcl_ConcatObj(objc-3, objv+3);
+ objPtr = Tcl_ConcatObj(objc-3, objv+3);
+ invoker = NULL;
+ word = 0;
}
/*
@@ -3329,7 +3340,7 @@ NamespaceEvalCmd(
TclNRAddCallback(interp, NsEval_Callback, namespacePtr, "eval",
NULL, NULL);
- return TclNREvalObjEx(interp, objPtr, 0, iPtr->cmdFramePtr, 3);
+ return TclNREvalObjEx(interp, objPtr, 0, invoker, word);
}
static int
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 713ee18..9947549 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.150 2008/07/21 03:43:32 msofer Exp $
+ * RCS: @(#) $Id: tclProc.c,v 1.151 2008/07/21 22:50:36 andreas_kupries Exp $
*/
#include "tclInt.h"
@@ -919,6 +919,8 @@ TclNRUplevelObjCmd(
{
register Interp *iPtr = (Interp *) interp;
+ CmdFrame* invoker = NULL;
+ int word = 0;
int result;
CallFrame *savedVarFramePtr, *framePtr;
Tcl_Obj *objPtr;
@@ -955,7 +957,13 @@ TclNRUplevelObjCmd(
*/
if (objc == 1) {
+ /*
+ * TIP #280. Make actual argument location available to eval'd script
+ */
+
+ TclArgumentGet (interp, objv[0], &invoker, &word);
objPtr = objv[0];
+
} else {
/*
* More than one argument: concatenate them together with spaces
@@ -968,7 +976,7 @@ TclNRUplevelObjCmd(
TclNRAddCallback(interp, Uplevel_Callback, savedVarFramePtr, NULL, NULL,
NULL);
- return TclNREvalObjEx(interp, objPtr, 0, NULL, 0);
+ return TclNREvalObjEx(interp, objPtr, 0, invoker, word);
}
/*