diff options
| -rw-r--r-- | ChangeLog | 13 | ||||
| -rw-r--r-- | generic/tclBasic.c | 300 | ||||
| -rw-r--r-- | generic/tclCmdAH.c | 11 | ||||
| -rw-r--r-- | generic/tclCompile.c | 47 | ||||
| -rw-r--r-- | generic/tclCompile.h | 13 | ||||
| -rw-r--r-- | generic/tclInt.h | 33 | ||||
| -rw-r--r-- | generic/tclInterp.c | 10 | ||||
| -rw-r--r-- | generic/tclNamesp.c | 19 | ||||
| -rw-r--r-- | generic/tclProc.c | 12 | ||||
| -rw-r--r-- | tests/info.test | 14 |
10 files changed, 403 insertions, 69 deletions
@@ -1,3 +1,16 @@ +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: + * tests/info.test: + 2007-02-22 Jan Nijtmans <nijtmans@users.sf.net> * generic/*.c: fix [2021443] inconsistant "wrong # args" messages 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); } /* diff --git a/tests/info.test b/tests/info.test index a83a1fc..43fc794 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.50 2008/07/19 22:50:38 nijtmans Exp $ +# RCS: @(#) $Id: info.test,v 1.51 2008/07/21 22:50:36 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 */info.test 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 */info.test 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 info.test 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} |