From 4819a5befc336eb974ac83e7b8cd60cb3b4b695b Mon Sep 17 00:00:00 2001 From: Miguel Sofer Date: Sun, 8 Jun 2008 03:21:30 +0000 Subject: * 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: --- ChangeLog | 10 ++++ generic/tclBasic.c | 148 +++++++++++++++++++++++++------------------------- generic/tclCompCmds.c | 128 +++++++++++++++++++++++++++---------------- generic/tclCompile.c | 37 +++++++++++-- generic/tclCompile.h | 4 +- generic/tclExecute.c | 21 ++++++- generic/tclProc.c | 4 +- tests/uplevel.test | 69 ++++++++++++++++++++++- 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 + * 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 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 -- cgit v0.12