diff options
Diffstat (limited to 'generic/tclBasic.c')
| -rw-r--r-- | generic/tclBasic.c | 298 |
1 files changed, 255 insertions, 43 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 07c2ef7..8c1fe40 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -14,7 +14,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBasic.c,v 1.295 2008/03/14 19:53:10 dgp Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.295.2.1 2008/07/21 19:38:13 andreas_kupries Exp $ */ #include "tclInt.h" @@ -444,8 +444,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; @@ -1411,6 +1413,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); @@ -4291,12 +4313,14 @@ TclEvalEx( eeFramePtr->nline = objectsUsed; eeFramePtr->line = lines; + TclArgumentEnter (interp, objv, objectsUsed, eeFramePtr); iPtr->cmdFramePtr = eeFramePtr; iPtr->numLevels++; code = TclEvalObjvInternal(interp, objectsUsed, objv, parsePtr->commandStart, parsePtr->commandSize, 0); iPtr->numLevels--; iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr; + TclArgumentRelease (interp, objv, objectsUsed); eeFramePtr->line = NULL; eeFramePtr->nline = 0; @@ -4446,6 +4470,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 -- * @@ -4686,66 +4911,53 @@ TclEvalObjEx( * complex 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 ((ctxPtr->nline <= word) || + (ctxPtr->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); } } else { /* |