From cd1f27f0cf22ec6b5b83f2fd48c1ba93e5c27be2 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 5 Nov 2012 14:34:36 +0000 Subject: Added compilation of [array exists], [array set] and [array unset]. Fixed a whole bunch of issues with opcode issuing that were causing problems with stack depth calculations. --- generic/tclAssembly.c | 4 + generic/tclCompCmds.c | 279 ++++++++++++++++++++++++++++++++++++++++++++---- generic/tclCompCmdsSZ.c | 19 +++- generic/tclCompile.c | 48 ++++++++- generic/tclCompile.h | 8 +- generic/tclExecute.c | 114 ++++++++++++++++++-- generic/tclInt.h | 9 ++ generic/tclVar.c | 6 +- 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 /* * 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} }; -- cgit v0.12