summaryrefslogtreecommitdiffstats
path: root/generic/tclBasic.c
diff options
context:
space:
mode:
authorandreas_kupries <akupries@shaw.ca>2008-07-21 19:38:09 (GMT)
committerandreas_kupries <akupries@shaw.ca>2008-07-21 19:38:09 (GMT)
commitee9aa214c65a48c44f14e0b78ea877cb7c8ea28f (patch)
tree496a640f3a50041bbfbbababc8dcd88e0d08d729 /generic/tclBasic.c
parent5784ef17a727e040f9964e60b26b181df02c47d2 (diff)
downloadtcl-ee9aa214c65a48c44f14e0b78ea877cb7c8ea28f.zip
tcl-ee9aa214c65a48c44f14e0b78ea877cb7c8ea28f.tar.gz
tcl-ee9aa214c65a48c44f14e0b78ea877cb7c8ea28f.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:
Diffstat (limited to 'generic/tclBasic.c')
-rw-r--r--generic/tclBasic.c298
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 {
/*