diff options
| -rw-r--r-- | ChangeLog | 12 | ||||
| -rw-r--r-- | generic/tclBasic.c | 282 | ||||
| -rw-r--r-- | generic/tclCmdAH.c | 9 | ||||
| -rw-r--r-- | generic/tclCompCmds.c | 10 | ||||
| -rw-r--r-- | generic/tclCompile.c | 49 | ||||
| -rw-r--r-- | generic/tclCompile.h | 12 | ||||
| -rw-r--r-- | generic/tclInt.h | 41 | ||||
| -rw-r--r-- | generic/tclInterp.c | 11 | ||||
| -rw-r--r-- | generic/tclNamesp.c | 11 | ||||
| -rw-r--r-- | generic/tclProc.c | 10 |
10 files changed, 391 insertions, 56 deletions
@@ -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 |