summaryrefslogtreecommitdiffstats
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
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:
-rw-r--r--ChangeLog12
-rw-r--r--generic/tclBasic.c298
-rw-r--r--generic/tclCmdAH.c10
-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.c11
-rw-r--r--generic/tclProc.c12
-rw-r--r--generic/tclVar.c15
-rw-r--r--tools/genStubs.tcl5
-rw-r--r--unix/Makefile.in6
-rw-r--r--win/Makefile.in8
13 files changed, 408 insertions, 72 deletions
diff --git a/ChangeLog b/ChangeLog
index 604c15c..c5f53e1 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -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-21 Pat Thoyts <patthoyts@users.sourceforge.net>
* generic/tclFCmd.c: Inodes on windows are unreliable [Bug 2015723]
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 {
/*
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index e054c29..abcb083 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.93 2008/03/14 16:07:23 dgp Exp $
+ * RCS: @(#) $Id: tclCmdAH.c,v 1.93.2.1 2008/07/21 19:38:17 andreas_kupries Exp $
*/
#include "tclInt.h"
@@ -656,11 +656,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.
*/
+ 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);
} else {
/*
* More than one argument: concatenate them together with spaces
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index bdb81bb..145a7b9 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.146.2.1 2008/05/16 14:27:30 msofer Exp $
+ * RCS: @(#) $Id: tclCompile.c,v 1.146.2.2 2008/07/21 19:38:17 andreas_kupries Exp $
*/
#include "tclInt.h"
@@ -802,6 +802,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);
@@ -814,6 +816,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);
}
@@ -903,6 +914,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) {
/*
@@ -1442,8 +1454,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 */
@@ -2412,6 +2439,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 eee0da9..f1be02c 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.90 2008/02/26 20:28:59 jenglish Exp $
+ * RCS: @(#) $Id: tclCompile.h,v 1.90.2.1 2008/07/21 19:38:18 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 8a71b59..e0e65e4 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.362.2.1 2008/03/31 17:21:14 dgp Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.362.2.2 2008/07/21 19:38:18 andreas_kupries Exp $
*/
#ifndef _TCLINT
@@ -1141,6 +1141,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
@@ -1832,11 +1838,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.
@@ -2430,6 +2451,12 @@ MODULE_SCOPE char tclEmptyString;
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 78772bd..67a031a 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.83.2.1 2008/06/20 19:23:25 dgp Exp $
+ * RCS: @(#) $Id: tclInterp.c,v 1.83.2.2 2008/07/21 19:38:19 andreas_kupries Exp $
*/
#include "tclInt.h"
@@ -2472,11 +2472,15 @@ SlaveEval(
if (objc == 1) {
/*
- * TIP #280: Make invoker available to eval'd script.
+ * TIP #280: Make actual argument location available to eval'd script.
*/
Interp *iPtr = (Interp *) interp;
- result = TclEvalObjEx(slaveInterp, objv[0], 0, iPtr->cmdFramePtr, 0);
+ CmdFrame* invoker = iPtr->cmdFramePtr;
+ int word = 0;
+
+ TclArgumentGet (interp, objv[0], &invoker, &word);
+ result = TclEvalObjEx(slaveInterp, objv[0], 0, invoker, word);
} else {
objPtr = Tcl_ConcatObj(objc, objv);
Tcl_IncrRefCount(objPtr);
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 717eaf9..dab46fc 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.162.2.2 2008/05/22 15:25:54 dgp Exp $
+ * RCS: @(#) $Id: tclNamesp.c,v 1.162.2.3 2008/07/21 19:38:19 andreas_kupries Exp $
*/
#include "tclInt.h"
@@ -3279,12 +3279,15 @@ NamespaceEvalCmd(
if (objc == 4) {
/*
- * TIP #280: Make invoker available to eval'd script.
+ * TIP #280: Make actual argument location available to eval'd script.
*/
- Interp *iPtr = (Interp *) interp;
+ Interp *iPtr = (Interp *) interp;
+ CmdFrame* invoker = iPtr->cmdFramePtr;
+ int word = 3;
- result = TclEvalObjEx(interp, objv[3], 0, iPtr->cmdFramePtr, 3);
+ TclArgumentGet (interp, objv[3], &invoker, &word);
+ result = TclEvalObjEx(interp, objv[3], 0, invoker, word);
} else {
/*
* More than one argument: concatenate them together with spaces
diff --git a/generic/tclProc.c b/generic/tclProc.c
index ce85c7a..f9e6822 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.139 2007/12/13 15:23:20 dgp Exp $
+ * RCS: @(#) $Id: tclProc.c,v 1.139.2.1 2008/07/21 19:38:19 andreas_kupries Exp $
*/
#include "tclInt.h"
@@ -908,7 +908,15 @@ Tcl_UplevelObjCmd(
*/
if (objc == 1) {
- result = Tcl_EvalObjEx(interp, objv[0], TCL_EVAL_DIRECT);
+ /*
+ * 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], 0, invoker, word);
} else {
/*
* More than one argument: concatenate them together with spaces
diff --git a/generic/tclVar.c b/generic/tclVar.c
index 3bcc527..d2314c5 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.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: tclVar.c,v 1.160 2008/03/11 17:23:56 msofer Exp $
+ * RCS: @(#) $Id: tclVar.c,v 1.160.2.1 2008/07/21 19:38:20 andreas_kupries Exp $
*/
#include "tclInt.h"
@@ -67,10 +67,19 @@ VarHashCreateVar(
#define VarHashFindVar(tablePtr, key) \
VarHashCreateVar((tablePtr), (key), NULL)
-
+#ifdef _AIX
+/* Work around AIX cc problem causing crash in TclDeleteVars. Possible
+ * optimizer bug. Do _NOT_ inline this function, this re-activates the
+ * problem.
+ */
+static void
+VarHashInvalidateEntry(Var* varPtr) {
+ varPtr->flags |= VAR_DEAD_HASH;
+}
+#else
#define VarHashInvalidateEntry(varPtr) \
((varPtr)->flags |= VAR_DEAD_HASH)
-
+#endif
#define VarHashDeleteEntry(varPtr) \
Tcl_DeleteHashEntry(&(((VarInHash *) varPtr)->entry))
diff --git a/tools/genStubs.tcl b/tools/genStubs.tcl
index 5bc3984..4050d21 100644
--- a/tools/genStubs.tcl
+++ b/tools/genStubs.tcl
@@ -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: genStubs.tcl,v 1.22 2007/12/13 15:28:40 dgp Exp $
+# RCS: @(#) $Id: genStubs.tcl,v 1.22.2.1 2008/07/21 19:38:21 andreas_kupries Exp $
package require Tcl 8.4
@@ -208,6 +208,9 @@ proc genStubs::rewriteFile {file text} {
set in [open ${file} r]
set out [open ${file}.new w]
+ # Hardwire the genstubs output to Unix eol.
+ fconfigure $out -translation lf
+
while {![eof $in]} {
set line [gets $in]
if {[string match "*!BEGIN!*" $line]} {
diff --git a/unix/Makefile.in b/unix/Makefile.in
index 7ce7fdf..5fe8a5c 100644
--- a/unix/Makefile.in
+++ b/unix/Makefile.in
@@ -4,7 +4,7 @@
# "./configure", which is a configuration script generated by the "autoconf"
# program (constructs like "@foo@" will get replaced in the actual Makefile.
#
-# RCS: @(#) $Id: Makefile.in,v 1.229.2.3 2008/06/26 22:10:24 andreas_kupries Exp $
+# RCS: @(#) $Id: Makefile.in,v 1.229.2.4 2008/07/21 19:38:21 andreas_kupries Exp $
VERSION = @TCL_VERSION@
MAJOR_VERSION = @TCL_MAJOR_VERSION@
@@ -876,8 +876,8 @@ install-private-headers: libraries
$(INSTALL_DATA) tclConfig.h "$(PRIVATE_INCLUDE_INSTALL_DIR)"; \
fi;
-Makefile: $(UNIX_DIR)/Makefile.in $(DLTEST_DIR)/Makefile.in
- $(SHELL) config.status
+#Makefile: $(UNIX_DIR)/Makefile.in $(DLTEST_DIR)/Makefile.in
+# $(SHELL) config.status
#tclConfig.h: $(UNIX_DIR)/tclConfig.h.in
# $(SHELL) config.status
diff --git a/win/Makefile.in b/win/Makefile.in
index f453595..76d9302 100644
--- a/win/Makefile.in
+++ b/win/Makefile.in
@@ -4,7 +4,7 @@
# "./configure", which is a configuration script generated by the "autoconf"
# program (constructs like "@foo@" will get replaced in the actual Makefile.
#
-# RCS: @(#) $Id: Makefile.in,v 1.124 2008/03/12 09:51:39 hobbs Exp $
+# RCS: @(#) $Id: Makefile.in,v 1.124.2.1 2008/07/21 19:38:22 andreas_kupries Exp $
VERSION = @TCL_VERSION@
@@ -717,8 +717,8 @@ gdb: binaries
depend:
-Makefile: $(SRC_DIR)/Makefile.in
- ./config.status
+#Makefile: $(SRC_DIR)/Makefile.in
+# ./config.status
cleanhelp:
$(RM) *.hlp *.cnt *.GID *.rtf man2tcl.exe
@@ -747,4 +747,4 @@ genstubs:
"$(GENERIC_DIR_NATIVE)" \
"$(GENERIC_DIR_NATIVE)\tcl.decls" \
"$(GENERIC_DIR_NATIVE)\tclInt.decls" \
- "$(GENERIC_DIR_NATIVE)\tclTomMath.decls"
+ "$(GENERIC_DIR_NATIVE)\tclTomMath.decls" \ No newline at end of file