summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
authorMiguel Sofer <miguel.sofer@gmail.com>2007-04-03 01:34:35 (GMT)
committerMiguel Sofer <miguel.sofer@gmail.com>2007-04-03 01:34:35 (GMT)
commit8cfd70638999b67e37edba6967467a2ece7a91fe (patch)
tree9800be2d600ba1c88b6e67f0e8a1b46a08f32b64 /generic
parentfa49c9af9b48554cf441f2554c9cd58d3ca1f267 (diff)
downloadtcl-8cfd70638999b67e37edba6967467a2ece7a91fe.zip
tcl-8cfd70638999b67e37edba6967467a2ece7a91fe.tar.gz
tcl-8cfd70638999b67e37edba6967467a2ece7a91fe.tar.bz2
* 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:
Diffstat (limited to 'generic')
-rw-r--r--generic/tclBasic.c10
-rw-r--r--generic/tclCompCmds.c533
-rw-r--r--generic/tclCompile.c11
-rw-r--r--generic/tclCompile.h15
-rw-r--r--generic/tclExecute.c127
-rw-r--r--generic/tclInt.h14
-rw-r--r--generic/tclVar.c5
7 files changed, 630 insertions, 85 deletions
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