summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--generic/tclAssembly.c4
-rw-r--r--generic/tclCompCmds.c279
-rw-r--r--generic/tclCompCmdsSZ.c19
-rw-r--r--generic/tclCompile.c48
-rw-r--r--generic/tclCompile.h8
-rw-r--r--generic/tclExecute.c114
-rw-r--r--generic/tclInt.h9
-rw-r--r--generic/tclVar.c6
8 files changed, 451 insertions, 36 deletions
diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 3b02ca2..7833105 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -362,6 +362,10 @@ static const TalInstDesc TalInstructionTable[] = {
| INST_APPEND_ARRAY4), 2, 1},
{"appendArrayStk", ASSEM_1BYTE, INST_APPEND_ARRAY_STK, 3, 1},
{"appendStk", ASSEM_1BYTE, INST_APPEND_STK, 2, 1},
+ {"arrayExistsImm", ASSEM_LVT4, INST_ARRAY_EXISTS_IMM, 0, 1},
+ {"arrayExistsStk", ASSEM_1BYTE, INST_ARRAY_EXISTS_STK, 1, 1},
+ {"arrayMakeImm", ASSEM_LVT4, INST_ARRAY_MAKE_IMM, 0, 0},
+ {"arrayMakeStk", ASSEM_1BYTE, INST_ARRAY_MAKE_STK, 1, 0},
{"beginCatch", ASSEM_BEGIN_CATCH,
INST_BEGIN_CATCH4, 0, 0},
{"bitand", ASSEM_1BYTE, INST_BITAND, 2, 1},
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 463e82c..160fa3c 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -15,6 +15,7 @@
#include "tclInt.h"
#include "tclCompile.h"
+#include <assert.h>
/*
* Prototypes for procedures defined later in this file:
@@ -225,6 +226,245 @@ TclCompileAppendCmd(
/*
*----------------------------------------------------------------------
*
+ * TclCompileArray*Cmd --
+ *
+ * Functions called to compile "array" sucommands.
+ *
+ * Results:
+ * All return TCL_OK for a successful compile, and TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "array" subcommand at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileArrayExistsCmd(
+ Tcl_Interp *interp, /* Used for looking up stuff. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Token *tokenPtr;
+ int simpleVarName, isScalar, localIndex;
+
+ if (parsePtr->numWords != 2) {
+ return TCL_ERROR;
+ }
+
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ PushVarNameWord(interp, tokenPtr, envPtr, 0,
+ &localIndex, &simpleVarName, &isScalar, 1);
+ if (!isScalar) {
+ return TCL_ERROR;
+ }
+
+ if (localIndex >= 0) {
+ TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr);
+ } else {
+ TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr);
+ }
+ return TCL_OK;
+}
+
+int
+TclCompileArraySetCmd(
+ Tcl_Interp *interp, /* Used for looking up stuff. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Token *tokenPtr;
+ int simpleVarName, isScalar, localIndex;
+ int dataVar, iterVar, keyVar, valVar, infoIndex;
+ int back, fwd, offsetBack, offsetFwd, savedStackDepth;
+ ForeachInfo *infoPtr;
+
+ if (parsePtr->numWords != 3) {
+ return TCL_ERROR;
+ }
+
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ PushVarNameWord(interp, tokenPtr, envPtr, 0,
+ &localIndex, &simpleVarName, &isScalar, 1);
+ if (!isScalar) {
+ return TCL_ERROR;
+ }
+ tokenPtr = TokenAfter(tokenPtr);
+
+ /*
+ * Special case: literal empty value argument is just an "ensure array"
+ * operation.
+ */
+
+ if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD && tokenPtr[1].size == 0) {
+ if (localIndex >= 0) {
+ TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr);
+ TclEmitInstInt1(INST_JUMP_TRUE1, 7, envPtr);
+ TclEmitInstInt4(INST_ARRAY_MAKE_IMM, localIndex, envPtr);
+ } else {
+ TclEmitOpcode( INST_DUP, envPtr);
+ TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr);
+ TclEmitInstInt1(INST_JUMP_TRUE1, 5, envPtr);
+ savedStackDepth = envPtr->currStackDepth;
+ TclEmitOpcode( INST_ARRAY_MAKE_STK, envPtr);
+ TclEmitInstInt1(INST_JUMP1, 3, envPtr);
+ envPtr->currStackDepth = savedStackDepth;
+ TclEmitOpcode( INST_POP, envPtr);
+ }
+ PushLiteral(envPtr, "", 0);
+ return TCL_OK;
+ }
+
+ /*
+ * Prepare for the internal foreach.
+ */
+
+ if (envPtr->procPtr == NULL) {
+ return TCL_ERROR;
+ }
+ dataVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+ iterVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+ keyVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+ valVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+
+ infoPtr = ckalloc(sizeof(ForeachInfo) + sizeof(ForeachVarList *));
+ infoPtr->numLists = 1;
+ infoPtr->firstValueTemp = dataVar;
+ infoPtr->loopCtTemp = iterVar;
+ infoPtr->varLists[0] = ckalloc(sizeof(ForeachVarList) * 2*sizeof(int));
+ infoPtr->varLists[0]->numVars = 2;
+ infoPtr->varLists[0]->varIndexes[0] = keyVar;
+ infoPtr->varLists[0]->varIndexes[1] = valVar;
+ infoIndex = TclCreateAuxData(infoPtr, &tclForeachInfoType, envPtr);
+
+ /*
+ * Start issuing instructions to write to the array.
+ */
+
+ CompileWord(envPtr, tokenPtr, interp, 2);
+ TclEmitOpcode( INST_DUP, envPtr);
+ TclEmitOpcode( INST_LIST_LENGTH, envPtr);
+ PushLiteral(envPtr, "1", 1);
+ TclEmitOpcode( INST_BITAND, envPtr);
+ offsetFwd = CurrentOffset(envPtr);
+ TclEmitInstInt1( INST_JUMP_FALSE1, 0, envPtr);
+ savedStackDepth = envPtr->currStackDepth;
+ PushLiteral(envPtr, "list must have an even number of elements",
+ strlen("list must have an even number of elements"));
+ PushLiteral(envPtr, "-errorCode {TCL ARGUMENT FORMAT}",
+ strlen("-errorCode {TCL ARGUMENT FORMAT}"));
+ TclEmitInstInt4( INST_RETURN_IMM, 1, envPtr);
+ TclEmitInt4( 0, envPtr);
+ envPtr->currStackDepth = savedStackDepth;
+ fwd = CurrentOffset(envPtr) - offsetFwd;
+ TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1);
+ Emit14Inst( INST_STORE_SCALAR, dataVar, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+
+ if (localIndex >= 0) {
+ TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr);
+ TclEmitInstInt1(INST_JUMP_TRUE1, 7, envPtr);
+ TclEmitInstInt4(INST_ARRAY_MAKE_IMM, localIndex, envPtr);
+ TclEmitInstInt4(INST_FOREACH_START4, infoIndex, envPtr);
+ offsetBack = CurrentOffset(envPtr);
+ TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr);
+ offsetFwd = CurrentOffset(envPtr);
+ TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr);
+ savedStackDepth = envPtr->currStackDepth;
+ Emit14Inst( INST_LOAD_SCALAR, keyVar, envPtr);
+ Emit14Inst( INST_LOAD_SCALAR, valVar, envPtr);
+ Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ back = offsetBack - CurrentOffset(envPtr);
+ TclEmitInstInt1(INST_JUMP1, back, envPtr);
+ fwd = CurrentOffset(envPtr) - offsetFwd;
+ TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1);
+ envPtr->currStackDepth = savedStackDepth;
+ } else {
+ TclEmitOpcode( INST_DUP, envPtr);
+ TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr);
+ TclEmitInstInt1(INST_JUMP_TRUE1, 4, envPtr);
+ TclEmitOpcode( INST_DUP, envPtr);
+ TclEmitOpcode( INST_ARRAY_MAKE_STK, envPtr);
+ TclEmitInstInt4(INST_FOREACH_START4, infoIndex, envPtr);
+ offsetBack = CurrentOffset(envPtr);
+ TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr);
+ offsetFwd = CurrentOffset(envPtr);
+ TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr);
+ savedStackDepth = envPtr->currStackDepth;
+ TclEmitOpcode( INST_DUP, envPtr);
+ Emit14Inst( INST_LOAD_SCALAR, keyVar, envPtr);
+ Emit14Inst( INST_LOAD_SCALAR, valVar, envPtr);
+ TclEmitOpcode( INST_STORE_ARRAY_STK, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ back = offsetBack - CurrentOffset(envPtr);
+ TclEmitInstInt1(INST_JUMP1, back, envPtr);
+ fwd = CurrentOffset(envPtr) - offsetFwd;
+ TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1);
+ envPtr->currStackDepth = savedStackDepth;
+ TclEmitOpcode( INST_POP, envPtr);
+ }
+ TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
+ TclEmitInt4( dataVar, envPtr);
+ PushLiteral(envPtr, "", 0);
+ return TCL_OK;
+}
+
+int
+TclCompileArrayUnsetCmd(
+ Tcl_Interp *interp, /* Used for looking up stuff. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ int simpleVarName, isScalar, localIndex, savedStackDepth;
+
+ if (parsePtr->numWords != 2) {
+ return TCL_ERROR;
+ }
+
+ PushVarNameWord(interp, tokenPtr, envPtr, 0,
+ &localIndex, &simpleVarName, &isScalar, 1);
+ if (!isScalar) {
+ return TCL_ERROR;
+ }
+
+ if (localIndex >= 0) {
+ TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr);
+ TclEmitInstInt1(INST_JUMP_FALSE1, 8, envPtr);
+ TclEmitInstInt1(INST_UNSET_SCALAR, 1, envPtr);
+ TclEmitInt4( localIndex, envPtr);
+ } else {
+ TclEmitOpcode( INST_DUP, envPtr);
+ TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr);
+ TclEmitInstInt1(INST_JUMP_FALSE1, 6, envPtr);
+ savedStackDepth = envPtr->currStackDepth;
+ TclEmitInstInt1(INST_UNSET_STK, 1, envPtr);
+ TclEmitInstInt1(INST_JUMP1, 3, envPtr);
+ envPtr->currStackDepth = savedStackDepth;
+ TclEmitOpcode( INST_POP, envPtr);
+ }
+ PushLiteral(envPtr, "", 0);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclCompileBreakCmd --
*
* Procedure called to compile the "break" command.
@@ -258,6 +498,7 @@ TclCompileBreakCmd(
*/
TclEmitOpcode(INST_BREAK, envPtr);
+ PushLiteral(envPtr, "", 0); /* Evil hack! */
return TCL_OK;
}
@@ -564,6 +805,7 @@ TclCompileContinueCmd(
*/
TclEmitOpcode(INST_CONTINUE, envPtr);
+ PushLiteral(envPtr, "", 0); /* Evil hack! */
return TCL_OK;
}
@@ -582,26 +824,6 @@ TclCompileContinueCmd(
* Instructions are added to envPtr to execute the "dict" subcommand at
* runtime.
*
- * Notes:
- * The following commands are in fairly common use and are possibly worth
- * bytecoding:
- * dict append
- * dict create [*]
- * dict exists [*]
- * dict for
- * dict get [*]
- * dict incr
- * dict keys [*]
- * dict lappend
- * dict map
- * dict set
- * dict unset
- *
- * In practice, those that are pure-value operators (marked with [*]) can
- * probably be left alone (except perhaps [dict get] which is very very
- * common) and [dict update] should be considered instead (really big
- * win!)
- *
*----------------------------------------------------------------------
*/
@@ -666,6 +888,7 @@ TclCompileDictSetCmd(
TclEmitInstInt4( INST_DICT_SET, numWords-2, envPtr);
TclEmitInt4( dictVarIndex, envPtr);
+ TclAdjustStackDepth(-1, envPtr);
return TCL_OK;
}
@@ -783,6 +1006,7 @@ TclCompileDictGetCmd(
tokenPtr = TokenAfter(tokenPtr);
}
TclEmitInstInt4(INST_DICT_GET, numWords-1, envPtr);
+ TclAdjustStackDepth(-1, envPtr);
return TCL_OK;
}
@@ -819,6 +1043,7 @@ TclCompileDictExistsCmd(
tokenPtr = TokenAfter(tokenPtr);
}
TclEmitInstInt4(INST_DICT_EXISTS, numWords-1, envPtr);
+ TclAdjustStackDepth(-1, envPtr);
return TCL_OK;
}
@@ -879,7 +1104,7 @@ TclCompileDictUnsetCmd(
*/
TclEmitInstInt4( INST_DICT_UNSET, parsePtr->numWords-2, envPtr);
- TclEmitInt4( dictVarIndex, envPtr);
+ TclEmitInt4( dictVarIndex, envPtr);
return TCL_OK;
}
@@ -967,6 +1192,7 @@ TclCompileDictCreateCmd(
tokenPtr = TokenAfter(tokenPtr);
TclEmitInstInt4( INST_DICT_SET, 1, envPtr);
TclEmitInt4( worker, envPtr);
+ TclAdjustStackDepth(-1, envPtr);
TclEmitOpcode( INST_POP, envPtr);
}
Emit14Inst( INST_LOAD_SCALAR, worker, envPtr);
@@ -1048,6 +1274,7 @@ TclCompileDictMergeCmd(
TclEmitInstInt4( INST_REVERSE, 2, envPtr);
TclEmitInstInt4( INST_DICT_SET, 1, envPtr);
TclEmitInt4( workerIndex, envPtr);
+ TclAdjustStackDepth(-1, envPtr);
TclEmitOpcode( INST_POP, envPtr);
TclEmitInstInt4( INST_DICT_NEXT, infoIndex, envPtr);
TclEmitInstInt1( INST_JUMP_FALSE1, -20, envPtr);
@@ -1275,6 +1502,7 @@ CompileDictEachCmd(
TclEmitInstInt4(INST_OVER, 1, envPtr);
TclEmitInstInt4(INST_DICT_SET, 1, envPtr);
TclEmitInt4( collectVar, envPtr);
+ TclAdjustStackDepth(-1, envPtr);
TclEmitOpcode( INST_POP, envPtr);
}
TclEmitOpcode( INST_POP, envPtr);
@@ -1337,7 +1565,7 @@ CompileDictEachCmd(
* easy!) Note that we skip the END_CATCH. [Bug 1382528]
*/
- envPtr->currStackDepth = savedStackDepth+2;
+ envPtr->currStackDepth = savedStackDepth + 2;
jumpDisplacement = CurrentOffset(envPtr) - emptyTargetOffset;
TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDisplacement,
envPtr->codeStart + emptyTargetOffset);
@@ -1533,6 +1761,7 @@ TclCompileDictUpdateCmd(
(int) (CurrentOffset(envPtr) - jumpFixup.codeOffset));
}
TclStackFree(interp, keyTokenPtrs);
+ envPtr->currStackDepth = savedStackDepth + 1;
return TCL_OK;
}
@@ -1781,6 +2010,7 @@ TclCompileDictWithCmd(
PushLiteral(envPtr, "", 0);
}
}
+ envPtr->currStackDepth = savedStackDepth + 1;
return TCL_OK;
}
@@ -1899,6 +2129,7 @@ TclCompileDictWithCmd(
* Prepare for the start of the next command.
*/
+ envPtr->currStackDepth = savedStackDepth + 1;
if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) {
Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d",
(int) (CurrentOffset(envPtr) - jumpFixup.codeOffset));
@@ -1998,6 +2229,7 @@ TclCompileErrorCmd(
* However, we only deal with the case where there is just a message.
*/
Tcl_Token *messageTokenPtr;
+ int savedStackDepth = envPtr->currStackDepth;
DefineLineInformation; /* TIP #280 */
if (parsePtr->numWords != 2) {
@@ -2008,6 +2240,7 @@ TclCompileErrorCmd(
PushLiteral(envPtr, "-code error -level 0", 20);
CompileWord(envPtr, messageTokenPtr, interp, 1);
TclEmitOpcode(INST_RETURN_STK, envPtr);
+ envPtr->currStackDepth = savedStackDepth + 1;
return TCL_OK;
}
@@ -5238,6 +5471,7 @@ TclCompileReturnCmd(
int numWords = parsePtr->numWords;
int explicitResult = (0 == (numWords % 2));
int numOptionWords = numWords - 1 - explicitResult;
+ int savedStackDepth = envPtr->currStackDepth;
Tcl_Obj *returnOpts, **objv;
Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr);
DefineLineInformation; /* TIP #280 */
@@ -5260,6 +5494,7 @@ TclCompileReturnCmd(
CompileWord(envPtr, optsTokenPtr, interp, 2);
CompileWord(envPtr, msgTokenPtr, interp, 3);
TclEmitOpcode(INST_RETURN_STK, envPtr);
+ envPtr->currStackDepth = savedStackDepth + 1;
return TCL_OK;
}
diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index 090f996..be63e0e 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -995,6 +995,7 @@ TclSubstCompile(
if (state != NULL) {
Tcl_RestoreInterpState(interp, state);
TclCompileSyntaxError(interp, envPtr);
+ TclAdjustStackDepth(-1, envPtr);
}
/* Final target of the multi-jump from all BREAKs */
@@ -1639,6 +1640,7 @@ IssueSwitchJumpTable(
int **bodyContLines) /* Array of continuation line info. */
{
JumptableInfo *jtPtr;
+ int savedStackDepth = envPtr->currStackDepth;
int infoIndex, isNew, *finalFixups, numRealBodies = 0, jumpLocation;
int mustGenerate, foundDefault, jumpToDefault, i;
Tcl_DString buffer;
@@ -1751,6 +1753,7 @@ IssueSwitchJumpTable(
* Compile the body of the arm.
*/
+ envPtr->currStackDepth = savedStackDepth;
envPtr->line = bodyLines[i+1]; /* TIP #280 */
envPtr->clNext = bodyContLines[i+1]; /* TIP #280 */
TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr);
@@ -1782,6 +1785,7 @@ IssueSwitchJumpTable(
*/
if (!foundDefault) {
+ envPtr->currStackDepth = savedStackDepth;
TclStoreInt4AtPtr(CurrentOffset(envPtr)-jumpToDefault,
envPtr->codeStart+jumpToDefault+1);
PushLiteral(envPtr, "", 0);
@@ -1802,6 +1806,7 @@ IssueSwitchJumpTable(
*/
TclStackFree(interp, finalFixups);
+ envPtr->currStackDepth = savedStackDepth + 1;
}
/*
@@ -1957,6 +1962,7 @@ TclCompileThrowCmd(
{
DefineLineInformation; /* TIP #280 */
int numWords = parsePtr->numWords;
+ int savedStackDepth = envPtr->currStackDepth;
Tcl_Token *codeToken, *msgToken;
Tcl_Obj *objPtr;
@@ -1987,6 +1993,7 @@ TclCompileThrowCmd(
CompileWord(envPtr, msgToken, interp, 2);
TclCompileSyntaxError(interp, envPtr);
Tcl_DecrRefCount(objPtr);
+ envPtr->currStackDepth = savedStackDepth + 1;
return TCL_OK;
}
if (len == 0) {
@@ -2007,6 +2014,7 @@ TclCompileThrowCmd(
PushLiteral(envPtr, string, len);
TclDecrRefCount(dictPtr);
OP44( RETURN_IMM, 1, 0);
+ envPtr->currStackDepth = savedStackDepth + 1;
} else {
/*
* When the code token is not known at compilation time, we need to do
@@ -2035,6 +2043,7 @@ TclCompileThrowCmd(
PUSH( "");
OP44( RETURN_IMM, 1, 0);
}
+ envPtr->currStackDepth = savedStackDepth + 1;
TclDecrRefCount(objPtr);
return TCL_OK;
}
@@ -2302,6 +2311,7 @@ IssueTryInstructions(
{
DefineLineInformation; /* TIP #280 */
int range, resultVar, optionsVar;
+ int savedStackDepth = envPtr->currStackDepth;
int i, j, len, forwardsNeedFixing = 0;
int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource;
char buf[TCL_INTEGER_SPACE];
@@ -2363,6 +2373,7 @@ IssueTryInstructions(
LOAD( optionsVar);
PUSH( "-errorcode");
OP4( DICT_GET, 1);
+ TclAdjustStackDepth(-1, envPtr);
OP44( LIST_RANGE_IMM, 0, len-1);
PUSH( TclGetString(matchClauses[i]));
OP( STR_EQ);
@@ -2403,6 +2414,7 @@ IssueTryInstructions(
forwardsToFix[j] = -1;
}
}
+ envPtr->currStackDepth = savedStackDepth;
BODY( handlerTokens[i], 5+i*4);
}
@@ -2434,6 +2446,7 @@ IssueTryInstructions(
}
TclStackFree(interp, forwardsToFix);
TclStackFree(interp, addrsToFix);
+ envPtr->currStackDepth = savedStackDepth + 1;
return TCL_OK;
}
@@ -2470,6 +2483,7 @@ IssueTryFinallyInstructions(
range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
OP4( BEGIN_CATCH4, range);
ExceptionRangeStarts(envPtr, range);
+ envPtr->currStackDepth = savedStackDepth;
BODY( bodyToken, 1);
ExceptionRangeEnds(envPtr, range);
PUSH( "0");
@@ -2514,6 +2528,7 @@ IssueTryFinallyInstructions(
LOAD( optionsVar);
PUSH( "-errorcode");
OP4( DICT_GET, 1);
+ TclAdjustStackDepth(-1, envPtr);
OP44( LIST_RANGE_IMM, 0, len-1);
PUSH( TclGetString(matchClauses[i]));
OP( STR_EQ);
@@ -2586,6 +2601,7 @@ IssueTryFinallyInstructions(
}
OP4( BEGIN_CATCH4, range);
}
+ envPtr->currStackDepth = savedStackDepth;
BODY( handlerTokens[i], 5+i*4);
ExceptionRangeEnds(envPtr, range);
OP( PUSH_RETURN_OPTIONS);
@@ -2637,7 +2653,6 @@ IssueTryFinallyInstructions(
*/
OP( POP);
- envPtr->currStackDepth = savedStackDepth;
/*
* Process the finally clause (at last!) Note that we do not wrap this in
@@ -2647,11 +2662,13 @@ IssueTryFinallyInstructions(
* next command (or some inter-command manipulation).
*/
+ envPtr->currStackDepth = savedStackDepth;
BODY( finallyToken, 3 + 4*numHandlers);
OP( POP);
LOAD( optionsVar);
LOAD( resultVar);
OP( RETURN_STK);
+ envPtr->currStackDepth = savedStackDepth + 1;
return TCL_OK;
}
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 2c87b34..309682d 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -372,13 +372,13 @@ InstructionDesc const 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}},
+ {"upvar", 5, -1, 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}},
+ {"nsupvar", 5, -1, 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}},
+ {"variable", 5, -1, 1, {OPERAND_LVT4}},
/* finds namespace and otherName in stack, links to local variable at
* index op1. Leaves the namespace on stack. */
{"syntax", 9, -1, 2, {OPERAND_INT4, OPERAND_UINT4}},
@@ -509,6 +509,26 @@ InstructionDesc const tclInstructionTable[] = {
* context.
* Stack: ... value => ... boolean */
+ {"arrayExistsStk", 1, 0, 0, {OPERAND_NONE}},
+ /* Looks up the element on the top of the stack and tests whether it
+ * is an array. Pushes a boolean describing whether this is the
+ * case. Also runs the whole-array trace on the named variable, so can
+ * throw anything.
+ * Stack: ... varName => ... boolean */
+ {"arrayExistsImm", 5, +1, 1, {OPERAND_UINT4}},
+ /* Looks up the variable indexed by opnd and tests whether it is an
+ * array. Pushes a boolean describing whether this is the case. Also
+ * runs the whole-array trace on the named variable, so can throw
+ * anything.
+ * Stack: ... => ... boolean */
+ {"arrayMakeStk", 1, -1, 0, {OPERAND_NONE}},
+ /* Forces the element on the top of the stack to be the name of an
+ * array.
+ * Stack: ... varName => ... */
+ {"arrayMakeImm", 5, 0, 1, {OPERAND_UINT4}},
+ /* Forces the variable indexed by opnd to be an array. Does not touch
+ * the stack. */
+
{NULL, 0, 0, 0, {OPERAND_NONE}}
};
@@ -1751,6 +1771,9 @@ TclCompileScript(
unsigned savedCodeNext =
envPtr->codeNext - envPtr->codeStart;
int update = 0;
+#ifdef TCL_COMPILE_DEBUG
+ int startStackDepth = envPtr->currStackDepth;
+#endif
/*
* Mark the start of the command; the proper bytecode
@@ -1794,6 +1817,25 @@ TclCompileScript(
envPtr);
if (code == TCL_OK) {
+ /*
+ * Confirm that the command compiler generated a
+ * single value on the stack as its result. This
+ * is only done in debugging mode, as it *should*
+ * be correct and normal users have no reasonable
+ * way to fix it anyway.
+ */
+
+#ifdef TCL_COMPILE_DEBUG
+ int diff = envPtr->currStackDepth-startStackDepth;
+
+ if (diff != 1 && (diff != 0 ||
+ *(envPtr->codeNext-1) != INST_DONE)) {
+ Tcl_Panic("bad stack adjustment when compiling"
+ " %.*s (was %d instead of 1)",
+ parsePtr->tokenPtr->size,
+ parsePtr->tokenPtr->start, diff);
+ }
+#endif
if (update) {
/*
* Fix the bytecode length.
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index b080d33..3302f9b 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -705,8 +705,14 @@ typedef struct ByteCode {
#define INST_TCLOO_NS 157
#define INST_TCLOO_IS_OBJECT 158
+/* For compilation of [array] subcommands */
+#define INST_ARRAY_EXISTS_STK 159
+#define INST_ARRAY_EXISTS_IMM 160
+#define INST_ARRAY_MAKE_STK 161
+#define INST_ARRAY_MAKE_IMM 162
+
/* The last opcode */
-#define LAST_INST_OPCODE 158
+#define LAST_INST_OPCODE 162
/*
* Table describing the Tcl bytecode instructions: their name (for displaying
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 2b29d5c..caf35ba 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -2389,14 +2389,18 @@ TEBCresume(
}
#ifdef TCL_COMPILE_DEBUG
- TRACE(("%d [", opnd));
- for (i=opnd-1 ; i>=0 ; i++) {
- TRACE_APPEND(("\"%.30s\"", O2S(OBJ_AT_DEPTH(i))));
- if (i > 0) {
- TRACE_APPEND((" "));
+ {
+ register int i;
+
+ TRACE(("%d [", opnd));
+ for (i=opnd-1 ; i>=0 ; i++) {
+ TRACE_APPEND(("\"%.30s\"", O2S(OBJ_AT_DEPTH(i))));
+ if (i > 0) {
+ TRACE_APPEND((" "));
+ }
}
+ TRACE_APPEND(("] => RETURN..."));
}
- TRACE_APPEND(("] => RETURN..."));
#endif
/*
@@ -3877,6 +3881,104 @@ TEBCresume(
/*
* End of INST_UNSET instructions.
* -----------------------------------------------------------------
+ * Start of INST_ARRAY instructions.
+ */
+
+ case INST_ARRAY_EXISTS_IMM:
+ opnd = TclGetUInt4AtPtr(pc+1);
+ pcAdjustment = 5;
+ cleanup = 0;
+ part1Ptr = NULL;
+ arrayPtr = NULL;
+ TRACE(("%u => ", opnd));
+ varPtr = LOCAL(opnd);
+ while (TclIsVarLink(varPtr)) {
+ varPtr = varPtr->value.linkPtr;
+ }
+ goto doArrayExists;
+ case INST_ARRAY_EXISTS_STK:
+ opnd = -1;
+ pcAdjustment = 1;
+ cleanup = 1;
+ part1Ptr = OBJ_AT_TOS;
+ TRACE(("\"%.30s\" => ", O2S(part1Ptr)));
+ varPtr = TclObjLookupVarEx(interp, part1Ptr, NULL, 0, NULL,
+ /*createPart1*/0, /*createPart2*/0, &arrayPtr);
+ doArrayExists:
+ if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY)
+ && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) {
+ DECACHE_STACK_INFO();
+ result = TclObjCallVarTraces(iPtr, arrayPtr, varPtr, part1Ptr,
+ NULL, (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|
+ TCL_GLOBAL_ONLY|TCL_TRACE_ARRAY), 1, opnd);
+ CACHE_STACK_INFO();
+ if (result == TCL_ERROR) {
+ TRACE_APPEND(("ERROR: %.30s\n",
+ O2S(Tcl_GetObjResult(interp))));
+ goto gotError;
+ }
+ }
+ if (varPtr && TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) {
+ objResultPtr = TCONST(1);
+ } else {
+ objResultPtr = TCONST(0);
+ }
+ TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+ NEXT_INST_V(pcAdjustment, cleanup, 1);
+
+ case INST_ARRAY_MAKE_IMM:
+ opnd = TclGetUInt4AtPtr(pc+1);
+ pcAdjustment = 5;
+ cleanup = 0;
+ part1Ptr = NULL;
+ arrayPtr = NULL;
+ TRACE(("%u => ", opnd));
+ varPtr = LOCAL(opnd);
+ while (TclIsVarLink(varPtr)) {
+ varPtr = varPtr->value.linkPtr;
+ }
+ goto doArrayMake;
+ case INST_ARRAY_MAKE_STK:
+ opnd = -1;
+ pcAdjustment = 1;
+ cleanup = 1;
+ part1Ptr = OBJ_AT_TOS;
+ TRACE(("\"%.30s\" => ", O2S(part1Ptr)));
+ varPtr = TclObjLookupVarEx(interp, part1Ptr, NULL, TCL_LEAVE_ERR_MSG,
+ "set", /*createPart1*/1, /*createPart2*/0, &arrayPtr);
+ if (varPtr == NULL) {
+ TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
+ goto gotError;
+ }
+ doArrayMake:
+ if (varPtr && !TclIsVarArray(varPtr)) {
+ if (TclIsVarArrayElement(varPtr) || !TclIsVarUndefined(varPtr)) {
+ /*
+ * Either an array element, or a scalar: lose!
+ */
+
+ TclObjVarErrMsg(interp, part1Ptr, NULL, "array set",
+ "variable isn't array", opnd);
+ Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL);
+ TRACE_APPEND(("ERROR: bad array ref: %.30s\n",
+ O2S(Tcl_GetObjResult(interp))));
+ goto gotError;
+ }
+ TclSetVarArray(varPtr);
+ varPtr->value.tablePtr = ckalloc(sizeof(TclVarHashTable));
+ TclInitVarHashTable(varPtr->value.tablePtr,
+ TclGetVarNsPtr(varPtr));
+#ifdef TCL_COMPILE_DEBUG
+ TRACE_APPEND(("done\n"));
+ } else {
+ TRACE_APPEND(("nothing to do\n"));
+#endif
+ }
+ NEXT_INST_V(pcAdjustment, cleanup, 0);
+
+ /*
+ * End of INST_ARRAY instructions.
+ * -----------------------------------------------------------------
* Start of variable linking instructions.
*/
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 7dc21c1..1d04c82 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3491,6 +3491,15 @@ MODULE_SCOPE int Tcl_WhileObjCmd(ClientData clientData,
MODULE_SCOPE int TclCompileAppendCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileArrayExistsCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileArraySetCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileArrayUnsetCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
MODULE_SCOPE int TclCompileBreakCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
diff --git a/generic/tclVar.c b/generic/tclVar.c
index e31e9cf..1c01e41 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -4224,15 +4224,15 @@ TclInitArrayCmd(
static const EnsembleImplMap arrayImplMap[] = {
{"anymore", ArrayAnyMoreCmd, NULL, NULL, NULL, 0},
{"donesearch", ArrayDoneSearchCmd, NULL, NULL, NULL, 0},
- {"exists", ArrayExistsCmd, NULL, NULL, NULL, 0},
+ {"exists", ArrayExistsCmd, TclCompileArrayExistsCmd, NULL, NULL, 0},
{"get", ArrayGetCmd, NULL, NULL, NULL, 0},
{"names", ArrayNamesCmd, NULL, NULL, NULL, 0},
{"nextelement", ArrayNextElementCmd, NULL, NULL, NULL, 0},
- {"set", ArraySetCmd, NULL, NULL, NULL, 0},
+ {"set", ArraySetCmd, TclCompileArraySetCmd, NULL, NULL, 0},
{"size", ArraySizeCmd, NULL, NULL, NULL, 0},
{"startsearch", ArrayStartSearchCmd, NULL, NULL, NULL, 0},
{"statistics", ArrayStatsCmd, NULL, NULL, NULL, 0},
- {"unset", ArrayUnsetCmd, NULL, NULL, NULL, 0},
+ {"unset", ArrayUnsetCmd, TclCompileArrayUnsetCmd, NULL, NULL, 0},
{NULL, NULL, NULL, NULL, NULL, 0}
};
generated by cgit v0.12 at 2024-11-04 19:52:16 (GMT)