summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog10
-rw-r--r--generic/tclBasic.c148
-rw-r--r--generic/tclCompCmds.c128
-rw-r--r--generic/tclCompile.c37
-rw-r--r--generic/tclCompile.h4
-rw-r--r--generic/tclExecute.c21
-rw-r--r--generic/tclProc.c4
-rw-r--r--tests/uplevel.test69
8 files changed, 287 insertions, 134 deletions
diff --git a/ChangeLog b/ChangeLog
index cb4114c..0df1673 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,13 @@
+2008-06-08 Miguel Sofer <msofer@users.sf.net>
+ * generic/tclBasic.c: Compilation of uplevel scripts, allow
+ * generic/tclCompCmds.c: non-body compiled scripts to access the
+ * generic/tclCompile.c: LVT (but not to extend it) and enable the
+ * generic/tclCompile.h: canonical list opt to sidestep the
+ * generic/tclExecute.c: compiler. This is [Patch 1973096]
+ * generic/tclProc.c:
+ * tests/uplevel.test:
+
+
2008-06-06 Andreas Kupries <andreask@activestate.com>
TIP #230 IMPLEMENTATION
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 57fefe2..9210fd7 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.300 2008/05/31 19:56:06 dkf Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.301 2008/06/08 03:21:31 msofer Exp $
*/
#include "tclInt.h"
@@ -4578,85 +4578,85 @@ TclEvalObjEx(
Tcl_IncrRefCount(objPtr);
+ /*
+ * Pure List Optimization (no string representation). In this case, we
+ * can safely use Tcl_EvalObjv instead and get an appreciable
+ * improvement in execution speed. This is because it allows us to
+ * avoid a setFromAny step that would just pack everything into a
+ * string and back out again.
+ *
+ * This restriction has been relaxed a bit by storing in lists whether
+ * they are "canonical" or not (a canonical list being one that is
+ * either pure or that has its string rep derived by
+ * UpdateStringOfList from the internal rep).
+ */
+
+ if (objPtr->typePtr == &tclListType) { /* is a list... */
+ List *listRepPtr = objPtr->internalRep.twoPtrValue.ptr1;
+
+ if (objPtr->bytes == NULL || /* ...without a string rep */
+ listRepPtr->canonicalFlag) {/* ...or that is canonical */
+ /*
+ * TIP #280 Structures for tracking lines. As we know that
+ * this is dynamic execution we ignore the invoker, even if
+ * known.
+ */
+
+ int line, i;
+ char *w;
+ Tcl_Obj **elements, *copyPtr = TclListObjCopy(NULL, objPtr);
+ CmdFrame *eoFramePtr = (CmdFrame *)
+ TclStackAlloc(interp, sizeof(CmdFrame));
+
+ eoFramePtr->type = TCL_LOCATION_EVAL_LIST;
+ eoFramePtr->level = (iPtr->cmdFramePtr == NULL?
+ 1 : iPtr->cmdFramePtr->level + 1);
+ eoFramePtr->framePtr = iPtr->framePtr;
+ eoFramePtr->nextPtr = iPtr->cmdFramePtr;
+
+ Tcl_ListObjGetElements(NULL, copyPtr,
+ &(eoFramePtr->nline), &elements);
+ eoFramePtr->line = (int *)
+ ckalloc(eoFramePtr->nline * sizeof(int));
+
+ eoFramePtr->cmd.listPtr = objPtr;
+ Tcl_IncrRefCount(eoFramePtr->cmd.listPtr);
+ eoFramePtr->data.eval.path = NULL;
+
+ /*
+ * TIP #280 Computes all the line numbers for the words in the
+ * command.
+ */
+
+ line = 1;
+ for (i=0; i < eoFramePtr->nline; i++) {
+ eoFramePtr->line[i] = line;
+ w = TclGetString(elements[i]);
+ TclAdvanceLines(&line, w, w + strlen(w));
+ }
+
+ iPtr->cmdFramePtr = eoFramePtr;
+ result = Tcl_EvalObjv(interp, eoFramePtr->nline, elements,
+ flags);
+
+ Tcl_DecrRefCount(copyPtr);
+ iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr;
+ Tcl_DecrRefCount(eoFramePtr->cmd.listPtr);
+ ckfree((char *) eoFramePtr->line);
+ eoFramePtr->line = NULL;
+ eoFramePtr->nline = 0;
+ TclStackFree(interp, eoFramePtr);
+
+ goto done;
+ }
+ }
+
if (flags & TCL_EVAL_DIRECT) {
/*
* We're not supposed to use the compiler or byte-code interpreter.
* Let Tcl_EvalEx evaluate the command directly (and probably more
* slowly).
*
- * Pure List Optimization (no string representation). In this case, we
- * can safely use Tcl_EvalObjv instead and get an appreciable
- * improvement in execution speed. This is because it allows us to
- * avoid a setFromAny step that would just pack everything into a
- * string and back out again.
- *
- * This restriction has been relaxed a bit by storing in lists whether
- * they are "canonical" or not (a canonical list being one that is
- * either pure or that has its string rep derived by
- * UpdateStringOfList from the internal rep).
- */
-
- if (objPtr->typePtr == &tclListType) { /* is a list... */
- List *listRepPtr = objPtr->internalRep.twoPtrValue.ptr1;
-
- if (objPtr->bytes == NULL || /* ...without a string rep */
- listRepPtr->canonicalFlag) {/* ...or that is canonical */
- /*
- * TIP #280 Structures for tracking lines. As we know that
- * this is dynamic execution we ignore the invoker, even if
- * known.
- */
-
- int line, i;
- char *w;
- Tcl_Obj **elements, *copyPtr = TclListObjCopy(NULL, objPtr);
- CmdFrame *eoFramePtr = (CmdFrame *)
- TclStackAlloc(interp, sizeof(CmdFrame));
-
- eoFramePtr->type = TCL_LOCATION_EVAL_LIST;
- eoFramePtr->level = (iPtr->cmdFramePtr == NULL?
- 1 : iPtr->cmdFramePtr->level + 1);
- eoFramePtr->framePtr = iPtr->framePtr;
- eoFramePtr->nextPtr = iPtr->cmdFramePtr;
-
- Tcl_ListObjGetElements(NULL, copyPtr,
- &(eoFramePtr->nline), &elements);
- eoFramePtr->line = (int *)
- ckalloc(eoFramePtr->nline * sizeof(int));
-
- eoFramePtr->cmd.listPtr = objPtr;
- Tcl_IncrRefCount(eoFramePtr->cmd.listPtr);
- eoFramePtr->data.eval.path = NULL;
-
- /*
- * TIP #280 Computes all the line numbers for the words in the
- * command.
- */
-
- line = 1;
- for (i=0; i < eoFramePtr->nline; i++) {
- eoFramePtr->line[i] = line;
- w = TclGetString(elements[i]);
- TclAdvanceLines(&line, w, w + strlen(w));
- }
-
- iPtr->cmdFramePtr = eoFramePtr;
- result = Tcl_EvalObjv(interp, eoFramePtr->nline, elements,
- flags);
-
- Tcl_DecrRefCount(copyPtr);
- iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr;
- Tcl_DecrRefCount(eoFramePtr->cmd.listPtr);
- ckfree((char *) eoFramePtr->line);
- eoFramePtr->line = NULL;
- eoFramePtr->nline = 0;
- TclStackFree(interp, eoFramePtr);
-
- goto done;
- }
- }
-
- /*
* TIP #280. Propagate context as much as we can. Especially if the
* script to evaluate is a single literal it makes sense to look if
* our context is one with absolute line numbers we can then track
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 87cb891..ac0b2c2 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.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: tclCompCmds.c,v 1.144 2008/05/07 09:07:11 dkf Exp $
+ * RCS: @(#) $Id: tclCompCmds.c,v 1.145 2008/06/08 03:21:32 msofer Exp $
*/
#include "tclInt.h"
@@ -131,6 +131,14 @@
((envPtr)->exceptArrayPtr[(index)].targetType = CurrentOffset(envPtr))
/*
+ * Check if there is an LVT for compiled locals
+ */
+
+#define EnvHasLVT(envPtr) \
+ (envPtr->procPtr || envPtr->iPtr->varFramePtr->localCachePtr)
+
+
+/*
* Prototypes for procedures defined later in this file:
*/
@@ -173,8 +181,7 @@ static void CompileReturnInternal(CompileEnv *envPtr,
* Flags bits used by PushVarName.
*/
-#define TCL_CREATE_VAR 1 /* Create a compiled local if none is found */
-#define TCL_NO_LARGE_INDEX 2 /* Do not return localIndex value > 255 */
+#define TCL_NO_LARGE_INDEX 1 /* Do not return localIndex value > 255 */
/*
* The structures below define the AuxData types defined in this file.
@@ -259,7 +266,7 @@ TclCompileAppendCmd(
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
- PushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
+ PushVarName(interp, varTokenPtr, envPtr, 0,
&localIndex, &simpleVarName, &isScalar,
mapPtr->loc[eclIndex].line[1]);
@@ -390,7 +397,7 @@ TclCompileCatchCmd(
* (not in a procedure), don't compile it inline: the payoff is too small.
*/
- if ((parsePtr->numWords >= 3) && (envPtr->procPtr == NULL)) {
+ if ((parsePtr->numWords >= 3) && !EnvHasLVT(envPtr)) {
return TCL_ERROR;
}
@@ -414,8 +421,11 @@ TclCompileCatchCmd(
return TCL_ERROR;
}
resultIndex = TclFindCompiledLocal(resultNameTokenPtr[1].start,
- resultNameTokenPtr[1].size, /*create*/ 1, envPtr->procPtr);
-
+ resultNameTokenPtr[1].size, /*create*/ 1, envPtr);
+ if (resultIndex < 0) {
+ return TCL_ERROR;
+ }
+
/* DKF */
if (parsePtr->numWords == 4) {
optsNameTokenPtr = TokenAfter(resultNameTokenPtr);
@@ -428,7 +438,10 @@ TclCompileCatchCmd(
return TCL_ERROR;
}
optsIndex = TclFindCompiledLocal(optsNameTokenPtr[1].start,
- optsNameTokenPtr[1].size, /*create*/ 1, envPtr->procPtr);
+ optsNameTokenPtr[1].size, /*create*/ 1, envPtr);
+ if (optsIndex < 0) {
+ return TCL_ERROR;
+ }
}
}
@@ -633,7 +646,6 @@ TclCompileDictSetCmd(
{
Tcl_Token *tokenPtr;
int numWords, i;
- Proc *procPtr = envPtr->procPtr;
DefineLineInformation; /* TIP #280 */
Tcl_Token *varTokenPtr;
int dictVarIndex, nameChars;
@@ -643,7 +655,7 @@ TclCompileDictSetCmd(
* There must be at least one argument after the command.
*/
- if (parsePtr->numWords < 4 || procPtr == NULL) {
+ if (parsePtr->numWords < 4) {
return TCL_ERROR;
}
@@ -662,7 +674,10 @@ TclCompileDictSetCmd(
if (!TclIsLocalScalar(name, nameChars)) {
return TCL_ERROR;
}
- dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, procPtr);
+ dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr);
+ if (dictVarIndex < 0) {
+ return TCL_ERROR;
+ }
/*
* Remaining words (key path and value to set) can be handled normally.
@@ -693,7 +708,6 @@ TclCompileDictIncrCmd(
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
- Proc *procPtr = envPtr->procPtr;
DefineLineInformation; /* TIP #280 */
Tcl_Token *varTokenPtr, *keyTokenPtr;
int dictVarIndex, nameChars, incrAmount;
@@ -703,7 +717,7 @@ TclCompileDictIncrCmd(
* There must be at least two arguments after the command.
*/
- if (parsePtr->numWords < 3 || parsePtr->numWords > 4 || procPtr == NULL) {
+ if (parsePtr->numWords < 3 || parsePtr->numWords > 4) {
return TCL_ERROR;
}
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
@@ -751,7 +765,10 @@ TclCompileDictIncrCmd(
if (!TclIsLocalScalar(name, nameChars)) {
return TCL_ERROR;
}
- dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, procPtr);
+ dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr);
+ if (dictVarIndex < 0) {
+ return TCL_ERROR;
+ }
/*
* Emit the key and the code to actually do the increment.
@@ -808,7 +825,6 @@ TclCompileDictForCmd(
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
- Proc *procPtr = envPtr->procPtr;
DefineLineInformation; /* TIP #280 */
Tcl_Token *varsTokenPtr, *dictTokenPtr, *bodyTokenPtr;
int keyVarIndex, valueVarIndex, nameChars, loopRange, catchRange;
@@ -824,7 +840,7 @@ TclCompileDictForCmd(
* There must be at least three argument after the command.
*/
- if (parsePtr->numWords != 4 || procPtr == NULL) {
+ if (parsePtr->numWords != 4) {
return TCL_ERROR;
}
@@ -859,16 +875,20 @@ TclCompileDictForCmd(
ckfree((char *) argv);
return TCL_ERROR;
}
- keyVarIndex = TclFindCompiledLocal(argv[0], nameChars, 1, procPtr);
+ keyVarIndex = TclFindCompiledLocal(argv[0], nameChars, 1, envPtr);
nameChars = strlen(argv[1]);
if (!TclIsLocalScalar(argv[1], nameChars)) {
ckfree((char *) argv);
return TCL_ERROR;
}
- valueVarIndex = TclFindCompiledLocal(argv[1], nameChars, 1, procPtr);
+ valueVarIndex = TclFindCompiledLocal(argv[1], nameChars, 1, envPtr);
ckfree((char *) argv);
+ if ((keyVarIndex < 0) || (valueVarIndex < 0)) {
+ return TCL_ERROR;
+ }
+
/*
* Allocate a temporary variable to store the iterator reference. The
* variable will contain a Tcl_DictSearch reference which will be
@@ -876,7 +896,10 @@ TclCompileDictForCmd(
* (at which point it should also have been finished with).
*/
- infoIndex = TclFindCompiledLocal(NULL, 0, 1, procPtr);
+ infoIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+ if (infoIndex < 0) {
+ return TCL_ERROR;
+ }
/*
* Preparation complete; issue instructions. Note that this code issues
@@ -1007,7 +1030,6 @@ TclCompileDictUpdateCmd(
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
- Proc *procPtr = envPtr->procPtr;
DefineLineInformation; /* TIP #280 */
const char *name;
int i, nameChars, dictIndex, numVars, range, infoIndex;
@@ -1019,7 +1041,7 @@ TclCompileDictUpdateCmd(
* There must be at least one argument after the command.
*/
- if (parsePtr->numWords < 5 || procPtr == NULL) {
+ if (parsePtr->numWords < 5) {
return TCL_ERROR;
}
@@ -1048,7 +1070,10 @@ TclCompileDictUpdateCmd(
if (!TclIsLocalScalar(name, nameChars)) {
return TCL_ERROR;
}
- dictIndex = TclFindCompiledLocal(name, nameChars, 1, procPtr);
+ dictIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr);
+ if (dictIndex < 0) {
+ return TCL_ERROR;
+ }
/*
* Assemble the instruction metadata. This is complex enough that it is
@@ -1093,7 +1118,12 @@ TclCompileDictUpdateCmd(
*/
duiPtr->varIndices[i] =
- TclFindCompiledLocal(name, nameChars, 1, procPtr);
+ TclFindCompiledLocal(name, nameChars, 1, envPtr);
+ if (duiPtr->varIndices[i] < 0) {
+ ckfree((char *) duiPtr);
+ TclStackFree(interp, keyTokenPtrs);
+ return TCL_ERROR;
+ }
tokenPtr = TokenAfter(tokenPtr);
}
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
@@ -1173,7 +1203,6 @@ TclCompileDictAppendCmd(
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
- Proc *procPtr = envPtr->procPtr;
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
int i, dictVarIndex;
@@ -1184,7 +1213,7 @@ TclCompileDictAppendCmd(
* speed quite so much. ;-)
*/
- if (parsePtr->numWords<4 || parsePtr->numWords>100 || procPtr==NULL) {
+ if (parsePtr->numWords<4 || parsePtr->numWords>100) {
return TCL_ERROR;
}
@@ -1202,7 +1231,10 @@ TclCompileDictAppendCmd(
if (!TclIsLocalScalar(name, nameChars)) {
return TCL_ERROR;
}
- dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, procPtr);
+ dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr);
+ if (dictVarIndex < 0) {
+ return TCL_ERROR;
+ }
}
/*
@@ -1235,7 +1267,6 @@ TclCompileDictLappendCmd(
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
- Proc *procPtr = envPtr->procPtr;
DefineLineInformation; /* TIP #280 */
Tcl_Token *varTokenPtr, *keyTokenPtr, *valueTokenPtr;
int dictVarIndex, nameChars;
@@ -1245,7 +1276,7 @@ TclCompileDictLappendCmd(
* There must be three arguments after the command.
*/
- if (parsePtr->numWords != 4 || procPtr == NULL) {
+ if (parsePtr->numWords != 4) {
return TCL_ERROR;
}
@@ -1260,7 +1291,10 @@ TclCompileDictLappendCmd(
if (!TclIsLocalScalar(name, nameChars)) {
return TCL_ERROR;
}
- dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, procPtr);
+ dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr);
+ if (dictVarIndex < 0) {
+ return TCL_ERROR;
+ }
CompileWord(envPtr, keyTokenPtr, interp, 3);
CompileWord(envPtr, valueTokenPtr, interp, 4);
TclEmitInstInt4( INST_DICT_LAPPEND, dictVarIndex, envPtr);
@@ -1702,13 +1736,13 @@ TclCompileForeachCmd(
firstValueTemp = -1;
for (loopIndex = 0; loopIndex < numLists; loopIndex++) {
tempVar = TclFindCompiledLocal(NULL, /*nameChars*/ 0,
- /*create*/ 1, procPtr);
+ /*create*/ 1, envPtr);
if (loopIndex == 0) {
firstValueTemp = tempVar;
}
}
loopCtTemp = TclFindCompiledLocal(NULL, /*nameChars*/ 0,
- /*create*/ 1, procPtr);
+ /*create*/ 1, envPtr);
/*
* Create and initialize the ForeachInfo and ForeachVarList data
@@ -1732,7 +1766,7 @@ TclCompileForeachCmd(
int nameChars = strlen(varName);
varListPtr->varIndexes[j] = TclFindCompiledLocal(varName,
- nameChars, /*create*/ 1, procPtr);
+ nameChars, /*create*/ 1, envPtr);
}
infoPtr->varLists[loopIndex] = varListPtr;
}
@@ -2356,7 +2390,7 @@ TclCompileIncrCmd(
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
- PushVarName(interp, varTokenPtr, envPtr, TCL_NO_LARGE_INDEX|TCL_CREATE_VAR,
+ PushVarName(interp, varTokenPtr, envPtr, TCL_NO_LARGE_INDEX,
&localIndex, &simpleVarName, &isScalar,
mapPtr->loc[eclIndex].line[1]);
@@ -2499,7 +2533,7 @@ TclCompileLappendCmd(
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
- PushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
+ PushVarName(interp, varTokenPtr, envPtr, 0,
&localIndex, &simpleVarName, &isScalar,
mapPtr->loc[eclIndex].line[1]);
@@ -2606,7 +2640,7 @@ TclCompileLassignCmd(
* Generate the next variable name.
*/
- PushVarName(interp, tokenPtr, envPtr, TCL_CREATE_VAR, &localIndex,
+ PushVarName(interp, tokenPtr, envPtr, 0, &localIndex,
&simpleVarName, &isScalar, mapPtr->loc[eclIndex].line[idx+2]);
/*
@@ -2943,7 +2977,7 @@ TclCompileLsetCmd(
*/
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
- PushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
+ PushVarName(interp, varTokenPtr, envPtr, 0,
&localIndex, &simpleVarName, &isScalar,
mapPtr->loc[eclIndex].line[1]);
@@ -3445,7 +3479,7 @@ TclCompileSetCmd(
*/
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
- PushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
+ PushVarName(interp, varTokenPtr, envPtr, 0,
&localIndex, &simpleVarName, &isScalar,
mapPtr->loc[eclIndex].line[1]);
@@ -4873,7 +4907,7 @@ PushVarName(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Token *varTokenPtr, /* Points to a variable token. */
CompileEnv *envPtr, /* Holds resulting instructions. */
- int flags, /* TCL_CREATE_VAR or TCL_NO_LARGE_INDEX. */
+ int flags, /* TCL_NO_LARGE_INDEX. */
int *localIndexPtr, /* Must not be NULL. */
int *simpleVarNamePtr, /* Must not be NULL. */
int *isScalarPtr, /* Must not be NULL. */
@@ -5038,10 +5072,9 @@ PushVarName(
* push its name and look it up at runtime.
*/
- if ((envPtr->procPtr != NULL) && !hasNsQualifiers) {
+ if (!hasNsQualifiers) {
localIndex = TclFindCompiledLocal(name, nameChars,
- /*create*/ flags & TCL_CREATE_VAR,
- envPtr->procPtr);
+ 1, envPtr);
if ((flags & TCL_NO_LARGE_INDEX) && (localIndex > 255)) {
/*
* We'll push the name.
@@ -5255,7 +5288,7 @@ CompileComparisonOpCmd(
return TCL_ERROR;
} else {
- int tmpIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr->procPtr);
+ int tmpIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr);
int words;
tokenPtr = TokenAfter(parsePtr->tokenPtr);
@@ -5701,7 +5734,7 @@ IndexTailVarIfKnown(
* only one.
*/
- if (envPtr->procPtr == NULL) {
+ if (!EnvHasLVT(envPtr)) {
return -1;
}
@@ -5752,8 +5785,7 @@ IndexTailVarIfKnown(
}
localIndex = TclFindCompiledLocal(tailName, len,
- /*create*/ TCL_CREATE_VAR,
- envPtr->procPtr);
+ 1, envPtr);
Tcl_DecrRefCount(tailPtr);
return localIndex;
}
@@ -5849,7 +5881,7 @@ TclCompileUpvarCmd(
localTokenPtr = TokenAfter(otherTokenPtr);
CompileWord(envPtr, otherTokenPtr, interp, 1);
- PushVarName(interp, localTokenPtr, envPtr, TCL_CREATE_VAR,
+ PushVarName(interp, localTokenPtr, envPtr, 0,
&localIndex, &simpleVarName, &isScalar,
mapPtr->loc[eclIndex].line[1]);
@@ -5942,7 +5974,7 @@ TclCompileNamespaceCmd(
localTokenPtr = TokenAfter(otherTokenPtr);
CompileWord(envPtr, otherTokenPtr, interp, 1);
- PushVarName(interp, localTokenPtr, envPtr, TCL_CREATE_VAR,
+ PushVarName(interp, localTokenPtr, envPtr, 0,
&localIndex, &simpleVarName, &isScalar,
mapPtr->loc[eclIndex].line[1]);
@@ -6444,7 +6476,7 @@ TclCompileInfoExistsCmd(
*/
tokenPtr = TokenAfter(parsePtr->tokenPtr);
- PushVarName(interp, tokenPtr, envPtr, TCL_CREATE_VAR, &localIndex,
+ PushVarName(interp, tokenPtr, envPtr, 0, &localIndex,
&simpleVarName, &isScalar, mapPtr->loc[eclIndex].line[1]);
/*
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index fd6f25e..187d81e 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.148 2008/05/30 22:54:28 dkf Exp $
+ * RCS: @(#) $Id: tclCompile.c,v 1.149 2008/06/08 03:21:33 msofer Exp $
*/
#include "tclInt.h"
@@ -1657,7 +1657,7 @@ TclCompileTokens(
localVar = -1;
if (localVarName != -1) {
localVar = TclFindCompiledLocal(name, nameBytes, localVarName,
- envPtr->procPtr);
+ envPtr);
}
if (localVar < 0) {
TclEmitPush(TclRegisterNewLiteral(envPtr, name, nameBytes),
@@ -2096,18 +2096,47 @@ TclFindCompiledLocal(
int nameBytes, /* Number of bytes in the name. */
int create, /* If 1, allocate a local frame entry for the
* variable if it is new. */
- register Proc *procPtr) /* Points to structure describing procedure
- * containing the variable reference. */
+ CompileEnv *envPtr) /* Points to the current compile environment*/
{
register CompiledLocal *localPtr;
int localVar = -1;
register int i;
+ Proc *procPtr;
/*
* If not creating a temporary, does a local variable of the specified
* name already exist?
*/
+ procPtr = envPtr->procPtr;
+
+ if (procPtr == NULL) {
+ /*
+ * Compiling a non-body script: give it read access to the LVT in the
+ * current localCache
+ */
+
+ LocalCache *cachePtr = envPtr->iPtr->varFramePtr->localCachePtr;
+ char *localName;
+ Tcl_Obj **varNamePtr;
+ int len;
+
+ if (!cachePtr || !name) {
+ return -1;
+ }
+
+ varNamePtr = &cachePtr->varName0;
+ for (i=0; i < cachePtr->numVars; varNamePtr++, i++) {
+ if (*varNamePtr) {
+ localName = Tcl_GetStringFromObj(*varNamePtr, &len);
+ if ((len == nameBytes) && !strncmp(name, localName, len)) {
+ return i;
+ }
+ }
+ }
+ return -1;
+ }
+
if (name != NULL) {
int localCt = procPtr->numCompiledLocals;
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 06447df..7e6ff50 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.91 2008/05/02 10:27:05 dkf Exp $
+ * RCS: @(#) $Id: tclCompile.h,v 1.92 2008/06/08 03:21:33 msofer Exp $
*/
#ifndef _TCLCOMPILATION
@@ -888,7 +888,7 @@ MODULE_SCOPE int TclExecuteByteCode(Tcl_Interp *interp,
ByteCode *codePtr);
MODULE_SCOPE void TclFinalizeAuxDataTypeTable(void);
MODULE_SCOPE int TclFindCompiledLocal(const char *name, int nameChars,
- int create, Proc *procPtr);
+ int create, CompileEnv *envPtr);
MODULE_SCOPE LiteralEntry * TclLookupLiteralEntry(Tcl_Interp *interp,
Tcl_Obj *objPtr);
MODULE_SCOPE int TclFixupForwardJump(CompileEnv *envPtr,
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 89c2066..5bbc366 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -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: tclExecute.c,v 1.371 2008/04/27 22:21:30 dkf Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.372 2008/06/08 03:21:33 msofer Exp $
*/
#include "tclInt.h"
@@ -1463,7 +1463,18 @@ TclCompEvalObj(
}
}
- /*
+ if (codePtr->procPtr == NULL) {
+ /*
+ * Check that any compiled locals do refer to the current proc
+ * environment! If not, recompile.
+ */
+
+ if (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr) {
+ goto recompileObj;
+ }
+ }
+
+ /*
* Increment the code's ref count while it is being executed. If
* afterwards no references to it remain, free the code.
*/
@@ -1493,7 +1504,11 @@ TclCompEvalObj(
tclByteCodeType.setFromAnyProc(interp, objPtr);
iPtr->invokeCmdFramePtr = NULL;
codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
- goto runCompiledObj;
+ if (iPtr->varFramePtr->localCachePtr) {
+ codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr;
+ codePtr->localCachePtr->refCount++;
+ }
+ goto runCompiledObj;
done:
iPtr->numLevels--;
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 8aa8779..85f49f9 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.140 2008/04/27 22:21:32 dkf Exp $
+ * RCS: @(#) $Id: tclProc.c,v 1.141 2008/06/08 03:21:33 msofer Exp $
*/
#include "tclInt.h"
@@ -908,7 +908,7 @@ Tcl_UplevelObjCmd(
*/
if (objc == 1) {
- result = Tcl_EvalObjEx(interp, objv[0], TCL_EVAL_DIRECT);
+ result = Tcl_EvalObjEx(interp, objv[0], 0);
} else {
/*
* More than one argument: concatenate them together with spaces
diff --git a/tests/uplevel.test b/tests/uplevel.test
index b8bbbb7..f676290 100644
--- a/tests/uplevel.test
+++ b/tests/uplevel.test
@@ -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: uplevel.test,v 1.8 2004/05/19 10:47:28 dkf Exp $
+# RCS: @(#) $Id: uplevel.test,v 1.9 2008/06/08 03:21:33 msofer Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -126,6 +126,73 @@ test uplevel-6.1 {uplevel and shadowed cmds} {
lappend res [namespace eval ns1 a2]
} {::ns1 :: ::ns1 ::}
+#
+# These tests verify that upleveled scripts run in the correct level and access
+# the proper variables.
+#
+
+test uplevel-7.1 {var access, no LVT in either level} -setup {
+ set x 1
+ unset -nocomplain y z
+} -body {
+ namespace eval foo {
+ set x 2
+ set y 2
+ uplevel 1 {
+ set x 3
+ set y 3
+ set z 3
+ }
+ }
+ list $x $y $z
+} -cleanup {
+ namespace delete foo
+ unset -nocomplain x y z
+} -result {3 3 3}
+
+test uplevel-7.2 {var access, no LVT in upper level} -setup {
+ set x 1
+ unset -nocomplain y z
+} -body {
+ proc foo {} {
+ set x 2
+ set y 2
+ uplevel 1 {
+ set x 3
+ set y 3
+ set z 3
+ }
+ }
+ foo
+ list $x $y $z
+} -cleanup {
+ rename foo {}
+ unset -nocomplain x y z
+} -result {3 3 3}
+
+test uplevel-7.3 {var access, LVT in upper level} -setup {
+ proc moo {} {
+ set x 1; #var in LVT
+ unset -nocomplain y z
+ foo
+ list $x $y $z
+ }
+} -body {
+ proc foo {} {
+ set x 2
+ set y 2
+ uplevel 1 {
+ set x 3
+ set y 3
+ set z 3
+ }
+ }
+ foo
+ moo
+} -cleanup {
+ rename foo {}
+ rename moo {}
+} -result {3 3 3}
# cleanup
::tcltest::cleanupTests