diff options
| -rw-r--r-- | ChangeLog | 9 | ||||
| -rw-r--r-- | generic/tclBasic.c | 10 | ||||
| -rw-r--r-- | generic/tclCompCmds.c | 533 | ||||
| -rw-r--r-- | generic/tclCompile.c | 11 | ||||
| -rw-r--r-- | generic/tclCompile.h | 15 | ||||
| -rw-r--r-- | generic/tclExecute.c | 127 | ||||
| -rw-r--r-- | generic/tclInt.h | 14 | ||||
| -rw-r--r-- | generic/tclVar.c | 5 |
8 files changed, 639 insertions, 85 deletions
@@ -1,3 +1,12 @@ +2007-04-02 Miguel Sofer <msofer@users.sf.net> + + * generic/tclBasic.c: Added bytecode compilers for the + * generic/tclCompCmds.c: variable linking commands: 'global', + * generic/tclCompile.h: 'variable', 'upvar', 'namespace upvar' + * generic/tclExecute.c: [Patch 1688593] + * generic/tclInt.h: + * generic/tclVar.c: + 2007-04-02 Don Porter <dgp@users.sourceforge.net> * generic/tclBasic.c: Replace arrays on the C stack and ckalloc diff --git a/generic/tclBasic.c b/generic/tclBasic.c index d35dd6c..56282b7 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.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: tclBasic.c,v 1.240 2007/04/02 18:48:03 dgp Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.241 2007/04/03 01:34:35 msofer Exp $ */ #include "tclInt.h" @@ -141,7 +141,7 @@ static const CmdInfo builtInCmds[] = { {"for", Tcl_ForObjCmd, TclCompileForCmd, 1}, {"foreach", Tcl_ForeachObjCmd, TclCompileForeachCmd, 1}, {"format", Tcl_FormatObjCmd, NULL, 1}, - {"global", Tcl_GlobalObjCmd, NULL, 1}, + {"global", Tcl_GlobalObjCmd, TclCompileGlobalCmd, 1}, {"if", Tcl_IfObjCmd, TclCompileIfCmd, 1}, {"incr", Tcl_IncrObjCmd, TclCompileIncrCmd, 1}, {"info", Tcl_InfoObjCmd, NULL, 1}, @@ -160,7 +160,7 @@ static const CmdInfo builtInCmds[] = { {"lsearch", Tcl_LsearchObjCmd, NULL, 1}, {"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, 1}, {"lsort", Tcl_LsortObjCmd, NULL, 1}, - {"namespace", Tcl_NamespaceObjCmd, NULL, 1}, + {"namespace", Tcl_NamespaceObjCmd, TclCompileNamespaceCmd, 1}, {"package", Tcl_PackageObjCmd, NULL, 1}, {"proc", Tcl_ProcObjCmd, NULL, 1}, {"regexp", Tcl_RegexpObjCmd, TclCompileRegexpCmd, 1}, @@ -177,8 +177,8 @@ static const CmdInfo builtInCmds[] = { {"unload", Tcl_UnloadObjCmd, NULL, 1}, {"unset", Tcl_UnsetObjCmd, NULL, 1}, {"uplevel", Tcl_UplevelObjCmd, NULL, 1}, - {"upvar", Tcl_UpvarObjCmd, NULL, 1}, - {"variable", Tcl_VariableObjCmd, NULL, 1}, + {"upvar", Tcl_UpvarObjCmd, TclCompileUpvarCmd, 1}, + {"variable", Tcl_VariableObjCmd, TclCompileVariableCmd, 1}, {"while", Tcl_WhileObjCmd, TclCompileWhileCmd, 1}, /* diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 86736ac..91344a5 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.104 2007/03/30 16:38:06 dgp Exp $ + * RCS: @(#) $Id: tclCompCmds.c,v 1.105 2007/04/03 01:34:36 msofer Exp $ */ #include "tclInt.h" @@ -4295,74 +4295,6 @@ PrintJumptableInfo( /* *---------------------------------------------------------------------- * - * TclCompileVariableCmd -- - * - * Procedure called to reserve the local variables for the "variable" - * command. The command itself is *not* compiled. - * - * Results: - * Always returns TCL_ERROR. - * - * Side effects: - * Indexed local variables are added to the environment. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileVariableCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *varTokenPtr; - int i, numWords; - const char *varName, *tail; - - if (envPtr->procPtr == NULL) { - return TCL_ERROR; - } - - numWords = parsePtr->numWords; - - varTokenPtr = TokenAfter(parsePtr->tokenPtr); - for (i = 1; i < numWords; i += 2) { - /* - * Skip non-literals. - */ - - if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - continue; - } - - varName = varTokenPtr[1].start; - tail = varName + varTokenPtr[1].size - 1; - - /* - * Skip if it looks like it might be an array or an empty string. - */ - - if ((*tail == ')') || (tail < varName)) { - continue; - } - - while ((tail > varName) && ((*tail != ':') || (*(tail-1) != ':'))) { - tail--; - } - if ((*tail == ':') && (tail > varName)) { - tail++; - } - (void) TclFindCompiledLocal(tail, tail-varName+1, - /*create*/ 1, /*flags*/ 0, envPtr->procPtr); - varTokenPtr = TokenAfter(varTokenPtr); - } - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * * TclCompileWhileCmd -- * * Procedure called to compile the "while" command. @@ -5301,6 +5233,469 @@ TclCompileDivOpCmd( } return TCL_OK; } + + +/* + *---------------------------------------------------------------------- + * + * IndexTailVarIfKnown -- + * + * Procedure used in compiling [global] and [variable] commands. It + * inspects the variable name described by varTokenPtr and, if the tail + * is known at compile time, defines a corresponding local variable. + * + * Results: + * Returns the variable's index in the table of compiled locals if the + * tail is known at compile time, or -1 otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +IndexTailVarIfKnown( + Tcl_Interp *interp, + Tcl_Token *varTokenPtr, /* Token representing the variable name */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Obj *tailPtr; + const char *tailName, *p; + int len, n = varTokenPtr->numComponents; + Tcl_Token *lastTokenPtr; + int full, localIndex; + + /* + * Determine if the tail is (a) known at compile time, and (b) not an + * array element. Should any of these fail, return an error so that + * the non-compiled command will be called at runtime. + * In order for the tail to be known at compile time, the last token + * in the word has to be constant and contain "::" if it is not the + * only one. + */ + + if (envPtr->procPtr == NULL) { + return -1; + } + + TclNewObj(tailPtr); + if (TclWordKnownAtCompileTime(varTokenPtr, tailPtr)) { + full = 1; + lastTokenPtr = varTokenPtr; + } else { + full = 0; + lastTokenPtr = varTokenPtr + n; + if (!TclWordKnownAtCompileTime(lastTokenPtr, tailPtr)) { + Tcl_DecrRefCount(tailPtr); + return -1; + } + } + + tailName = Tcl_GetStringFromObj(tailPtr, &len); + + if (len) { + if (*(tailName+len-1) == ')') { + /* + * Possible array: bail out + */ + + Tcl_DecrRefCount(tailPtr); + return -1; + } + + /* + * Get the tail: immediately after the last '::' + */ + + for(p = tailName + len -1; p > tailName; p--) { + if ((*p == ':') && (*(p-1) == ':')) { + p++; + break; + } + } + if (!full && (p == tailName)) { + /* + * No :: in the last component + */ + Tcl_DecrRefCount(tailPtr); + return -1; + } + len -= p - tailName; + tailName = p; + } + + localIndex = TclFindCompiledLocal(tailName, len, + /*create*/ TCL_CREATE_VAR, + /*flags*/ 0, + envPtr->procPtr); + Tcl_DecrRefCount(tailPtr); + return localIndex; +} + + +/* + *---------------------------------------------------------------------- + * + * TclCompileUpvarCmd -- + * + * Procedure called to compile the "upvar" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "upvar" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileUpvarCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr; + int simpleVarName, isScalar, localIndex, numWords, i; + DefineLineInformation; /* TIP #280 */ + Tcl_Obj *objPtr = Tcl_NewObj(); + + if (envPtr->procPtr == NULL) { + return TCL_ERROR; + } + + numWords = parsePtr->numWords; + if (numWords < 3) { + return TCL_ERROR; + } + + + /* + * Push the frame index if it is known at compile time + */ + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + if(TclWordKnownAtCompileTime(tokenPtr, objPtr)) { + CallFrame *framePtr; + Tcl_ObjType *newTypePtr, *typePtr = objPtr->typePtr; + + /* + * Attempt to convert to a level reference. Note that TclObjGetFrame + * only changes the obj type when a conversion was successful. + */ + + TclObjGetFrame(interp, objPtr, &framePtr); + newTypePtr = objPtr->typePtr; + Tcl_DecrRefCount(objPtr); + + if (newTypePtr != typePtr) { + if(numWords%2) { + return TCL_ERROR; + } + CompileWord(envPtr, tokenPtr, interp, 1); + otherTokenPtr = TokenAfter(tokenPtr); + i = 4; + } else { + if(!(numWords%2)) { + return TCL_ERROR; + } + PushLiteral(envPtr, "1", 1); + otherTokenPtr = tokenPtr; + i = 3; + } + } else { + return TCL_ERROR; + } + + /* + * Loop over the (otherVar, thisVar) pairs. If any of the thisVar is not a + * local variable, return an error so that the non-compiled command will + * be called at runtime. + */ + + for(; i<=numWords; i+=2, otherTokenPtr = TokenAfter(localTokenPtr)) { + localTokenPtr = TokenAfter(otherTokenPtr); + + CompileWord(envPtr, otherTokenPtr, interp, 1); + PushVarName(interp, localTokenPtr, envPtr, TCL_CREATE_VAR, + &localIndex, &simpleVarName, &isScalar, + mapPtr->loc[eclIndex].line[1]); + + if((localIndex < 0) || !isScalar) { + return TCL_ERROR; + } + TclEmitInstInt4(INST_UPVAR, localIndex, envPtr); + } + + /* + * Pop the frame index, and set the result to empty + */ + + TclEmitOpcode(INST_POP, envPtr); + PushLiteral(envPtr, "", 0); + return TCL_OK; +} + + +/* + *---------------------------------------------------------------------- + * + * TclCompileNamespaceCmd -- + * + * Procedure called to compile the "namespace" command; currently, only + * the subcommand "namespace upvar" is compiled to bytecodes. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "namespace upvar" + * command at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileNamespaceCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr; + int simpleVarName, isScalar, localIndex, numWords, i; + DefineLineInformation; /* TIP #280 */ + + if (envPtr->procPtr == NULL) { + return TCL_ERROR; + } + + /* + * Only compile [namespace upvar ...]: needs an odd number of args, >=5 + */ + + numWords = parsePtr->numWords; + if (!(numWords%2) || (numWords < 5)) { + return TCL_ERROR; + } + + + /* + * Check if the second argument is "upvar" + */ + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + if ((tokenPtr->size != 5) /* 5 == strlen("upvar") */ + || strncmp(tokenPtr->start, "upvar", 5)) { + return TCL_ERROR; + } + + /* + * Push the namespace + */ + + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + + /* + * Loop over the (otherVar, thisVar) pairs. If any of the thisVar is not a + * local variable, return an error so that the non-compiled command will + * be called at runtime. + */ + + localTokenPtr = tokenPtr; + for(i=4; i<=numWords; i+=2) { + otherTokenPtr = TokenAfter(localTokenPtr); + localTokenPtr = TokenAfter(otherTokenPtr); + + CompileWord(envPtr, otherTokenPtr, interp, 1); + PushVarName(interp, localTokenPtr, envPtr, TCL_CREATE_VAR, + &localIndex, &simpleVarName, &isScalar, + mapPtr->loc[eclIndex].line[1]); + + if((localIndex < 0) || !isScalar) { + return TCL_ERROR; + } + TclEmitInstInt4(INST_NSUPVAR, localIndex, envPtr); + } + + /* + * Pop the namespace, and set the result to empty + */ + + TclEmitOpcode(INST_POP, envPtr); + PushLiteral(envPtr, "", 0); + return TCL_OK; +} + + +/* + *---------------------------------------------------------------------- + * + * TclCompileGlobalCmd -- + * + * Procedure called to compile the "global" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "global" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileGlobalCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token *varTokenPtr; + int localIndex, numWords, i; + DefineLineInformation; /* TIP #280 */ + + numWords = parsePtr->numWords; + if (numWords < 2) { + return TCL_ERROR; + } + + /* + * 'global' has no effect outside of proc bodies; handle that at runtime + */ + + if (envPtr->procPtr == NULL) { + return TCL_ERROR; + } + + /* + * Push the namespace + */ + + PushLiteral(envPtr, "::", 2); + + /* + * Loop over the variables. + */ + + varTokenPtr = TokenAfter(parsePtr->tokenPtr); + for(i=2; i<=numWords; varTokenPtr = TokenAfter(varTokenPtr),i++) { + localIndex = IndexTailVarIfKnown(interp, varTokenPtr, envPtr); + + if(localIndex < 0) { + return TCL_ERROR; + } + + CompileWord(envPtr, varTokenPtr, interp, 1); + TclEmitInstInt4(INST_NSUPVAR, localIndex, envPtr); + } + + /* + * Pop the namespace, and set the result to empty + */ + + TclEmitOpcode(INST_POP, envPtr); + PushLiteral(envPtr, "", 0); + return TCL_OK; +} + + +/* + *---------------------------------------------------------------------- + * + * TclCompileVariableCmd -- + * + * Procedure called to compile the "variable" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "variable" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileVariableCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Interp *iPtr = (Interp *) interp; + Tcl_Token *varTokenPtr, *valueTokenPtr; + int localIndex, numWords, i; + DefineLineInformation; /* TIP #280 */ + + numWords = parsePtr->numWords; + if (numWords < 2) { + return TCL_ERROR; + } + + /* + * Bail out if not compiling a proc body + */ + + if (envPtr->procPtr == NULL) { + return TCL_ERROR; + } + + /* + * Push the namespace: it is the namespace corresponding to the current + * compilation. + */ + + PushLiteral(envPtr, iPtr->varFramePtr->nsPtr->fullName,-1); + + /* + * Loop over the (var, value) pairs. + */ + + valueTokenPtr = parsePtr->tokenPtr; + for(i=2; i<=numWords; i+=2) { + varTokenPtr = TokenAfter(valueTokenPtr); + valueTokenPtr = TokenAfter(varTokenPtr); + + localIndex = IndexTailVarIfKnown(interp, varTokenPtr, envPtr); + + if(localIndex < 0) { + return TCL_ERROR; + } + + CompileWord(envPtr, varTokenPtr, interp, 1); + TclEmitInstInt4(INST_VARIABLE, localIndex, envPtr); + + if (i != numWords) { + /* + * A value has been given: set the variable, pop the value + */ + + CompileWord(envPtr, valueTokenPtr, interp, 1); + TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr); + TclEmitOpcode(INST_POP, envPtr); + } + } + + /* + * Pop the namespace, and set the result to empty + */ + + TclEmitOpcode(INST_POP, envPtr); + PushLiteral(envPtr, "", 0); + return TCL_OK; +} + /* * Local Variables: diff --git a/generic/tclCompile.c b/generic/tclCompile.c index dbd8db2..419e177 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.111 2007/04/01 00:32:26 dkf Exp $ + * RCS: @(#) $Id: tclCompile.c,v 1.112 2007/04/03 01:34:36 msofer Exp $ */ #include "tclInt.h" @@ -372,6 +372,15 @@ InstructionDesc tclInstructionTable[] = { * Stack: ... value => ... * Note that the jump table contains offsets relative to the PC when * it points to this instruction; the code is relocatable. */ + {"upvar", 5, 0, 1, {OPERAND_LVT4}}, + /* finds level and otherName in stack, links to local variable at + * index op1. Leaves the level on stack. */ + {"nsupvar", 5, 0, 1, {OPERAND_LVT4}}, + /* finds namespace and otherName in stack, links to local variable at + * index op1. Leaves the namespace on stack. */ + {"variable", 5, 0, 1, {OPERAND_LVT4}}, + /* finds namespace and otherName in stack, links to local variable at + * index op1. Leaves the namespace on stack. */ {0} }; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index b5ad0ba..f0a3117 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -8,7 +8,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.69 2007/03/02 10:32:12 dkf Exp $ + * RCS: @(#) $Id: tclCompile.h,v 1.70 2007/04/03 01:34:37 msofer Exp $ */ #ifndef _TCLCOMPILATION @@ -614,8 +614,17 @@ typedef struct ByteCode { #define INST_JUMP_TABLE 121 +/* + * Instructions to support compilation of global, variable, upvar and + * [namespace upvar]. + */ + +#define INST_UPVAR 122 +#define INST_NSUPVAR 123 +#define INST_VARIABLE 124 + /* The last opcode */ -#define LAST_INST_OPCODE 121 +#define LAST_INST_OPCODE 124 /* * Table describing the Tcl bytecode instructions: their name (for displaying @@ -904,8 +913,6 @@ MODULE_SCOPE int TclNoIdentOpCmd(ClientData clientData, MODULE_SCOPE void TclVerifyGlobalLiteralTable(Interp *iPtr); MODULE_SCOPE void TclVerifyLocalLiteralTable(CompileEnv *envPtr); #endif -MODULE_SCOPE int TclCompileVariableCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, CompileEnv *envPtr); MODULE_SCOPE int TclWordKnownAtCompileTime(Tcl_Token *tokenPtr, Tcl_Obj *valuePtr); MODULE_SCOPE int TclWordSimpleExpansion(Tcl_Token *tokenPtr); diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 7e4148e..4a31669 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.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: tclExecute.c,v 1.267 2007/04/02 18:48:03 dgp Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.268 2007/04/03 01:34:37 msofer Exp $ */ #include "tclInt.h" @@ -2650,6 +2650,131 @@ TclExecuteByteCode( * --------------------------------------------------------- */ + case INST_UPVAR: { + int opnd; + Var *varPtr, *otherPtr; + + TRACE_WITH_OBJ(("upvar "), *(tosPtr-1)); + + { + CallFrame *framePtr, *savedFramePtr; + + result = TclObjGetFrame(interp, *(tosPtr-1), &framePtr); + if (result == -1) { + result = TCL_ERROR; + goto checkForCatch; + } else { + result = TCL_OK; + } + + /* + * Locate the other variable + */ + + savedFramePtr = iPtr->varFramePtr; + iPtr->varFramePtr = framePtr; + otherPtr = TclObjLookupVar(interp, *tosPtr, NULL, + (TCL_LEAVE_ERR_MSG), "access", + /*createPart1*/ 1, /*createPart2*/ 1, &varPtr); + iPtr->varFramePtr = savedFramePtr; + if (otherPtr == NULL) { + result = TCL_ERROR; + goto checkForCatch; + } + } + goto doLinkVars; + + case INST_VARIABLE: + case INST_NSUPVAR: + TRACE_WITH_OBJ(("nsupvar "), *(tosPtr-1)); + + { + Tcl_Namespace *nsPtr, *savedNsPtr; + + result = TclGetNamespaceFromObj(interp, *(tosPtr-1), &nsPtr); + if (result != TCL_OK) { + goto checkForCatch; + } + if (nsPtr == NULL) { + /* + * The namespace does not exist, leave an error message. + */ + Tcl_SetObjResult(interp, Tcl_Format(NULL, + "namespace \"%s\" does not exist", 1, + (tosPtr-1))); + result = TCL_ERROR; + goto checkForCatch; + } + + /* + * Locate the other variable + */ + + savedNsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr; + iPtr->varFramePtr->nsPtr = (Namespace *) nsPtr; + otherPtr = TclObjLookupVar(interp, *tosPtr, NULL, + (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access", + /*createPart1*/ 1, /*createPart2*/ 1, &varPtr); + iPtr->varFramePtr->nsPtr = (Namespace *) savedNsPtr; + if (otherPtr == NULL) { + result = TCL_ERROR; + goto checkForCatch; + } + + /* + * Do the [variable] magic if necessary + */ + + if ((*pc == INST_VARIABLE) && !TclIsVarNamespaceVar(otherPtr)) { + TclSetVarNamespaceVar(otherPtr); + otherPtr->refCount++; + } + } + + doLinkVars: + + /* + * If we are here, the local variable has already been created: do the + * little work of TclPtrMakeUpvar that remains to be done right here + * if there are no errors; otherwise, let it handle the case. + */ + + opnd = TclGetInt4AtPtr(pc+1);; + varPtr = &(compiledLocals[opnd]); + if ((varPtr != otherPtr) && (varPtr->tracePtr == NULL) + && (TclIsVarUndefined(varPtr) || TclIsVarLink(varPtr))) { + if (!TclIsVarUndefined(varPtr)) { + /* Then it is a defined link */ + Var *linkPtr = varPtr->value.linkPtr; + if (linkPtr == otherPtr) { + goto doLinkVarsDone; + } + linkPtr->refCount--; + if (TclIsVarUndefined(linkPtr)) { + TclCleanupVar(linkPtr, NULL); + } + } + TclSetVarLink(varPtr); + TclClearVarUndefined(varPtr); + varPtr->value.linkPtr = otherPtr; + otherPtr->refCount++; + } else { + result = TclPtrMakeUpvar(interp, otherPtr, NULL, 0, opnd); + if (result != TCL_OK) { + goto checkForCatch; + } + } + + /* + * Do not pop the namespace or frame index, it may be needed for other + * variables. + */ + + doLinkVarsDone: + NEXT_INST_F(5, 1, 0); + } + + case INST_JUMP1: { int opnd; diff --git a/generic/tclInt.h b/generic/tclInt.h index 564c19e..8450621 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -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: tclInt.h,v 1.302 2007/03/28 19:03:42 dgp Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.303 2007/04/03 01:34:37 msofer Exp $ */ #ifndef _TCLINT @@ -2725,6 +2725,8 @@ MODULE_SCOPE int TclCompileForCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileForeachCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileGlobalCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileIfCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileIncrCmd(Tcl_Interp *interp, @@ -2741,8 +2743,10 @@ MODULE_SCOPE int TclCompileLlengthCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileLsetCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileNoOp(Tcl_Interp *interp, Tcl_Parse *parsePtr, - struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileNamespaceCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileNoOp(Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileRegexpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileReturnCmd(Tcl_Interp *interp, @@ -2753,6 +2757,10 @@ MODULE_SCOPE int TclCompileStringCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileSwitchCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileUpvarCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileVariableCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileWhileCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr); diff --git a/generic/tclVar.c b/generic/tclVar.c index 17b859c..c723e84 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -15,7 +15,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.128 2007/03/12 18:06:14 dgp Exp $ + * RCS: @(#) $Id: tclVar.c,v 1.129 2007/04/03 01:34:39 msofer Exp $ */ #include "tclInt.h" @@ -3243,7 +3243,7 @@ ObjMakeUpvar( */ if (index < 0) { - if (((otherP2 ? arrayPtr->nsPtr : otherPtr->nsPtr) == NULL) + if (((arrayPtr ? arrayPtr->nsPtr : otherPtr->nsPtr) == NULL) && ((myFlags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) || (varFramePtr == NULL) || !HasLocalVars(varFramePtr) @@ -3301,6 +3301,7 @@ TclPtrMakeUpvar( Tcl_Panic("ObjMakeUpvar called with an index outside from a proc"); } varPtr = &(varFramePtr->compiledLocals[index]); + myName = varPtr->name; } else { /* * Do not permit the new variable to look like an array reference, as |