diff options
Diffstat (limited to 'generic')
| -rw-r--r-- | generic/tclBasic.c | 10 | ||||
| -rw-r--r-- | generic/tclCompCmds.c | 1000 | ||||
| -rw-r--r-- | generic/tclCompile.c | 32 | ||||
| -rw-r--r-- | generic/tclCompile.h | 25 | ||||
| -rw-r--r-- | generic/tclExecute.c | 778 | ||||
| -rw-r--r-- | generic/tclInt.decls | 10 | ||||
| -rw-r--r-- | generic/tclInt.h | 20 | ||||
| -rw-r--r-- | generic/tclIntDecls.h | 19 | ||||
| -rw-r--r-- | generic/tclVar.c | 227 |
9 files changed, 1471 insertions, 650 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 12d6802..960b856 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.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: tclBasic.c,v 1.31 2001/04/25 09:44:49 dkf Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.32 2001/05/17 02:13:02 hobbs Exp $ */ #include "tclInt.h" @@ -65,7 +65,7 @@ static CmdInfo builtInCmds[] = { */ {"append", (Tcl_CmdProc *) NULL, Tcl_AppendObjCmd, - (CompileProc *) NULL, 1}, + TclCompileAppendCmd, 1}, {"array", (Tcl_CmdProc *) NULL, Tcl_ArrayObjCmd, (CompileProc *) NULL, 1}, {"binary", (Tcl_CmdProc *) NULL, Tcl_BinaryObjCmd, @@ -113,15 +113,15 @@ static CmdInfo builtInCmds[] = { {"join", (Tcl_CmdProc *) NULL, Tcl_JoinObjCmd, (CompileProc *) NULL, 1}, {"lappend", (Tcl_CmdProc *) NULL, Tcl_LappendObjCmd, - (CompileProc *) NULL, 1}, + TclCompileLappendCmd, 1}, {"lindex", (Tcl_CmdProc *) NULL, Tcl_LindexObjCmd, - (CompileProc *) NULL, 1}, + TclCompileLindexCmd, 1}, {"linsert", (Tcl_CmdProc *) NULL, Tcl_LinsertObjCmd, (CompileProc *) NULL, 1}, {"list", (Tcl_CmdProc *) NULL, Tcl_ListObjCmd, (CompileProc *) NULL, 1}, {"llength", (Tcl_CmdProc *) NULL, Tcl_LlengthObjCmd, - (CompileProc *) NULL, 1}, + TclCompileLlengthCmd, 1}, {"load", (Tcl_CmdProc *) NULL, Tcl_LoadObjCmd, (CompileProc *) NULL, 0}, {"lrange", (Tcl_CmdProc *) NULL, Tcl_LrangeObjCmd, diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 6d9b273..cbe4070 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompCmds.c,v 1.7 2000/05/26 08:53:40 hobbs Exp $ + * RCS: @(#) $Id: tclCompCmds.c,v 1.8 2001/05/17 02:13:02 hobbs Exp $ */ #include "tclInt.h" @@ -20,8 +20,18 @@ */ static ClientData DupForeachInfo _ANSI_ARGS_((ClientData clientData)); -static void FreeForeachInfo _ANSI_ARGS_(( - ClientData clientData)); +static void FreeForeachInfo _ANSI_ARGS_((ClientData clientData)); +static int TclPushVarName _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Token *varTokenPtr, CompileEnv *envPtr, int flags, + int *localIndexPtr, int *maxDepthPtr, int *simpleVarNamePtr, + int *isScalarPtr)); + +/* + * Flags bits used by TclPushVarName. + */ + +#define TCL_CREATE_VAR 1 /* Create a compiled local if none is found */ +#define TCL_NO_LARGE_INDEX 2 /* Do not return localIndex value > 255 */ /* * The structures below define the AuxData types defined in this file. @@ -36,6 +46,139 @@ AuxDataType tclForeachInfoType = { /* *---------------------------------------------------------------------- * + * TclCompileAppendCmd -- + * + * Procedure called to compile the "append" command. + * + * Results: + * The return value is a standard Tcl result, which is normally TCL_OK + * unless there was an error while parsing string. If an error occurs + * then the interpreter's result contains a standard error message. If + * complation fails because the command requires a second level of + * substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the + * command should be compiled "out of line" by emitting code to + * invoke its command procedure (Tcl_AppendObjCmd) at runtime. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the incr command. + * + * Side effects: + * Instructions are added to envPtr to execute the "append" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileAppendCmd(interp, parsePtr, envPtr) + 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, *valueTokenPtr; + int simpleVarName, isScalar, localIndex, numWords; + int maxDepth = 0; + int code = TCL_OK; + + envPtr->maxStackDepth = 0; + numWords = parsePtr->numWords; + if (numWords == 1) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"append varName ?value value ...?\"", + -1); + return TCL_ERROR; + } else if (numWords == 2) { + /* + * append varName === set varName + */ + return TclCompileSetCmd(interp, parsePtr, envPtr); + } else if (numWords > 3) { + /* + * APPEND instructions currently only handle one value + */ + return TCL_OUT_LINE_COMPILE; + } + + /* + * Decide if we can use a frame slot for the var/array name or if we + * need to emit code to compute and push the name at runtime. We use a + * frame slot (entry in the array of local vars) if we are compiling a + * procedure body and if the name is simple text that does not include + * namespace qualifiers. + */ + + varTokenPtr = parsePtr->tokenPtr + + (parsePtr->tokenPtr->numComponents + 1); + + code = TclPushVarName(interp, varTokenPtr, envPtr, + ((numWords > 2) ? TCL_CREATE_VAR : 0), + &localIndex, &maxDepth, &simpleVarName, &isScalar); + if (code != TCL_OK) { + goto done; + } + + /* + * We are doing an assignment, otherwise TclCompileSetCmd was called, + * so push the new value. This will need to be extended to push a + * value for each argument. + */ + + if (numWords > 2) { + valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); + if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + TclEmitPush(TclRegisterLiteral(envPtr, valueTokenPtr[1].start, + valueTokenPtr[1].size, /*onHeap*/ 0), envPtr); + maxDepth += 1; + } else { + code = TclCompileTokens(interp, valueTokenPtr+1, + valueTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + goto done; + } + maxDepth += envPtr->maxStackDepth; + } + } + + /* + * Emit instructions to set/get the variable. + */ + + if (simpleVarName) { + if (isScalar) { + if (localIndex >= 0) { + if (localIndex <= 255) { + TclEmitInstInt1(INST_APPEND_SCALAR1, localIndex, envPtr); + } else { + TclEmitInstInt4(INST_APPEND_SCALAR4, localIndex, envPtr); + } + } else { + TclEmitOpcode(INST_APPEND_STK, envPtr); + } + } else { + if (localIndex >= 0) { + if (localIndex <= 255) { + TclEmitInstInt1(INST_APPEND_ARRAY1, localIndex, envPtr); + } else { + TclEmitInstInt4(INST_APPEND_ARRAY4, localIndex, envPtr); + } + } else { + TclEmitOpcode(INST_APPEND_ARRAY_STK, envPtr); + } + } + } else { + TclEmitOpcode(INST_APPEND_STK, envPtr); + } + + done: + envPtr->maxStackDepth = maxDepth; + return code; +} + +/* + *---------------------------------------------------------------------- + * * TclCompileBreakCmd -- * * Procedure called to compile the "break" command. @@ -1272,7 +1415,7 @@ TclCompileIfCmd(interp, parsePtr, envPtr) } } } - + /* * Free the jumpFixupArray array if malloc'ed storage was used. */ @@ -1318,12 +1461,9 @@ TclCompileIncrCmd(interp, parsePtr, envPtr) CompileEnv *envPtr; /* Holds resulting instructions. */ { Tcl_Token *varTokenPtr, *incrTokenPtr; - Tcl_Parse elemParse; - int gotElemParse = 0; - char *name, *elName, *p; - int nameChars, elNameChars, haveImmValue, immValue, localIndex, i, code; + int simpleVarName, isScalar, localIndex, haveImmValue, immValue; int maxDepth = 0; - char buffer[160]; + int code = TCL_OK; envPtr->maxStackDepth = 0; if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) { @@ -1332,105 +1472,16 @@ TclCompileIncrCmd(interp, parsePtr, envPtr) "wrong # args: should be \"incr varName ?increment?\"", -1); return TCL_ERROR; } - - name = NULL; - elName = NULL; - elNameChars = 0; - localIndex = -1; - code = TCL_OK; varTokenPtr = parsePtr->tokenPtr + (parsePtr->tokenPtr->numComponents + 1); - /* - * Check not only that the type is TCL_TOKEN_SIMPLE_WORD, but whether - * curly braces surround the variable name. - * This really matters for array elements to handle things like - * set {x($foo)} 5 - * which raises an undefined var error if we are not careful here. - * This goes with the hack in TclCompileSetCmd. - */ - if ((varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) && - (varTokenPtr->start[0] != '{')) { - /* - * A simple variable name. Divide it up into "name" and "elName" - * strings. If it is not a local variable, look it up at runtime. - */ - - name = varTokenPtr[1].start; - nameChars = varTokenPtr[1].size; - for (i = 0, p = name; i < nameChars; i++, p++) { - if (*p == '(') { - char *openParen = p; - p = (name + nameChars-1); - if (*p == ')') { /* last char is ')' => array reference */ - nameChars = (openParen - name); - elName = openParen+1; - elNameChars = (p - elName); - } - break; - } - } - if (envPtr->procPtr != NULL) { - localIndex = TclFindCompiledLocal(name, nameChars, - /*create*/ 0, /*flags*/ 0, envPtr->procPtr); - if (localIndex > 255) { /* we'll push the name */ - localIndex = -1; - } - } - if (localIndex < 0) { - TclEmitPush(TclRegisterLiteral(envPtr, name, nameChars, - /*onHeap*/ 0), envPtr); - maxDepth = 1; - } - /* - * Compile the element script, if any. - */ - - if (elName != NULL) { - /* - * Temporarily replace the '(' and ')' by '"'s. - */ - - *(elName-1) = '"'; - *(elName+elNameChars) = '"'; - code = Tcl_ParseCommand(interp, elName-1, elNameChars+2, - /*nested*/ 0, &elemParse); - *(elName-1) = '('; - *(elName+elNameChars) = ')'; - gotElemParse = 1; - if ((code != TCL_OK) || (elemParse.numWords > 1)) { - sprintf(buffer, "\n (parsing index for array \"%.*s\")", - TclMin(nameChars, 100), name); - Tcl_AddObjErrorInfo(interp, buffer, -1); - code = TCL_ERROR; - goto done; - } else if (elemParse.numWords == 1) { - code = TclCompileTokens(interp, elemParse.tokenPtr+1, - elemParse.tokenPtr->numComponents, envPtr); - if (code != TCL_OK) { - goto done; - } - maxDepth += envPtr->maxStackDepth; - } else { - TclEmitPush(TclRegisterLiteral(envPtr, "", 0, - /*alreadyAlloced*/ 0), envPtr); - maxDepth += 1; - } - } - } else { - /* - * Not a simple variable name. Look it up at runtime. - */ - - code = TclCompileTokens(interp, varTokenPtr+1, - varTokenPtr->numComponents, envPtr); - if (code != TCL_OK) { - goto done; - } - maxDepth = envPtr->maxStackDepth; + code = TclPushVarName(interp, varTokenPtr, envPtr, TCL_NO_LARGE_INDEX, + &localIndex, &maxDepth, &simpleVarName, &isScalar); + if (code != TCL_OK) { + goto done; } - + /* * If an increment is given, push it, but see first if it's a small * integer. @@ -1488,20 +1539,18 @@ TclCompileIncrCmd(interp, parsePtr, envPtr) * Emit the instruction to increment the variable. */ - if (name != NULL) { - if (elName == NULL) { + if (simpleVarName) { + if (isScalar) { if (localIndex >= 0) { if (haveImmValue) { - TclEmitInstInt1(INST_INCR_SCALAR1_IMM, localIndex, - envPtr); + TclEmitInstInt1(INST_INCR_SCALAR1_IMM, localIndex, envPtr); TclEmitInt1(immValue, envPtr); } else { TclEmitInstInt1(INST_INCR_SCALAR1, localIndex, envPtr); } } else { if (haveImmValue) { - TclEmitInstInt1(INST_INCR_SCALAR_STK_IMM, immValue, - envPtr); + TclEmitInstInt1(INST_INCR_SCALAR_STK_IMM, immValue, envPtr); } else { TclEmitOpcode(INST_INCR_SCALAR_STK, envPtr); } @@ -1509,16 +1558,14 @@ TclCompileIncrCmd(interp, parsePtr, envPtr) } else { if (localIndex >= 0) { if (haveImmValue) { - TclEmitInstInt1(INST_INCR_ARRAY1_IMM, localIndex, - envPtr); + TclEmitInstInt1(INST_INCR_ARRAY1_IMM, localIndex, envPtr); TclEmitInt1(immValue, envPtr); } else { TclEmitInstInt1(INST_INCR_ARRAY1, localIndex, envPtr); } } else { if (haveImmValue) { - TclEmitInstInt1(INST_INCR_ARRAY_STK_IMM, immValue, - envPtr); + TclEmitInstInt1(INST_INCR_ARRAY_STK_IMM, immValue, envPtr); } else { TclEmitOpcode(INST_INCR_ARRAY_STK, envPtr); } @@ -1533,9 +1580,155 @@ TclCompileIncrCmd(interp, parsePtr, envPtr) } done: - if (gotElemParse) { - Tcl_FreeParse(&elemParse); + envPtr->maxStackDepth = maxDepth; + return code; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileLappendCmd -- + * + * Procedure called to compile the "lappend" command. + * + * Results: + * The return value is a standard Tcl result, which is normally TCL_OK + * unless there was an error while parsing string. If an error occurs + * then the interpreter's result contains a standard error message. If + * complation fails because the command requires a second level of + * substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the + * command should be compiled "out of line" by emitting code to + * invoke its command procedure (Tcl_LappendObjCmd) at runtime. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the incr command. + * + * Side effects: + * Instructions are added to envPtr to execute the "lappend" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileLappendCmd(interp, parsePtr, envPtr) + 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, *valueTokenPtr; + int numValues, simpleVarName, isScalar, localIndex, numWords; + int maxDepth = 0; + int code = TCL_OK; + + /* + * If we're not in a procedure, don't compile. + */ + if (envPtr->procPtr == NULL) { + return TCL_OUT_LINE_COMPILE; + } + + envPtr->maxStackDepth = 0; + numWords = parsePtr->numWords; + if (numWords == 1) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"lappend varName ?value value ...?\"", -1); + return TCL_ERROR; } + if (numWords != 3) { + /* + * LAPPEND instructions currently only handle one value appends + */ + return TCL_OUT_LINE_COMPILE; + } + numValues = (numWords - 2); + + /* + * Decide if we can use a frame slot for the var/array name or if we + * need to emit code to compute and push the name at runtime. We use a + * frame slot (entry in the array of local vars) if we are compiling a + * procedure body and if the name is simple text that does not include + * namespace qualifiers. + */ + + varTokenPtr = parsePtr->tokenPtr + + (parsePtr->tokenPtr->numComponents + 1); + + code = TclPushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR, + &localIndex, &maxDepth, &simpleVarName, &isScalar); + if (code != TCL_OK) { + goto done; + } + + /* + * If we are doing an assignment, push the new value. + * In the no values case, create an empty object. + */ + + if (numWords > 2) { + valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); + if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + TclEmitPush(TclRegisterLiteral(envPtr, valueTokenPtr[1].start, + valueTokenPtr[1].size, /*onHeap*/ 0), envPtr); + maxDepth += 1; + } else { + code = TclCompileTokens(interp, valueTokenPtr+1, + valueTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + goto done; + } + maxDepth += envPtr->maxStackDepth; + } +#if 0 + } else { + /* + * We need to carefully handle the two arg case, as lappend + * always creates the variable. + */ + + TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), envPtr); + maxDepth += 1; + numValues = 1; +#endif + } + + /* + * Emit instructions to set/get the variable. + */ + + /* + * The *_STK opcodes should be refactored to make better use of existing + * LOAD/STORE instructions. + */ + if (simpleVarName) { + if (isScalar) { + if (localIndex >= 0) { + if (localIndex <= 255) { + TclEmitInstInt1(INST_LAPPEND_SCALAR1, localIndex, envPtr); + } else { + TclEmitInstInt4(INST_LAPPEND_SCALAR4, localIndex, envPtr); + } + } else { + TclEmitOpcode(INST_LAPPEND_STK, envPtr); + } + } else { + if (localIndex >= 0) { + if (localIndex <= 255) { + TclEmitInstInt1(INST_LAPPEND_ARRAY1, localIndex, envPtr); + } else { + TclEmitInstInt4(INST_LAPPEND_ARRAY4, localIndex, envPtr); + } + } else { + TclEmitOpcode(INST_LAPPEND_ARRAY_STK, envPtr); + } + } + } else { + TclEmitOpcode(INST_LAPPEND_STK, envPtr); + } + + done: envPtr->maxStackDepth = maxDepth; return code; } @@ -1543,6 +1736,137 @@ TclCompileIncrCmd(interp, parsePtr, envPtr) /* *---------------------------------------------------------------------- * + * TclCompileLindexCmd -- + * + * Procedure called to compile the "lindex" command. + * + * Results: + * The return value is a standard Tcl result, which is TCL_OK if the + * compilation was successful. If the command cannot be byte-compiled, + * TCL_OUT_LINE_COMPILE is returned. If an error occurs then the + * interpreter's result contains an error message, and TCL_ERROR is + * returned. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the command. + * + * Side effects: + * Instructions are added to envPtr to execute the "lindex" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileLindexCmd(interp, parsePtr, envPtr) + 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 code, depth, i; + + if (parsePtr->numWords != 3) { + Tcl_SetResult(interp, "wrong # args: should be \"lindex list index\"", + TCL_STATIC); + return TCL_ERROR; + } + varTokenPtr = parsePtr->tokenPtr + + (parsePtr->tokenPtr->numComponents + 1); + + depth = 0; + + /* + * Push the two operands onto the stack. + */ + + for (i = 0; i < 2; i++) { + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + TclEmitPush(TclRegisterLiteral(envPtr, + varTokenPtr[1].start, varTokenPtr[1].size, + 0), envPtr); + depth++; + } else { + code = TclCompileTokens(interp, varTokenPtr+1, + varTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + return code; + } + depth += envPtr->maxStackDepth; + } + varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); + } + + envPtr->maxStackDepth = depth; + TclEmitOpcode(INST_LIST_INDEX, envPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileLlengthCmd -- + * + * Procedure called to compile the "llength" command. + * + * Results: + * The return value is a standard Tcl result, which is TCL_OK if the + * compilation was successful. If the command cannot be byte-compiled, + * TCL_OUT_LINE_COMPILE is returned. If an error occurs then the + * interpreter's result contains an error message, and TCL_ERROR is + * returned. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the command. + * + * Side effects: + * Instructions are added to envPtr to execute the "llength" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileLlengthCmd(interp, parsePtr, envPtr) + 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 code; + + if (parsePtr->numWords != 2) { + Tcl_SetResult(interp, "wrong # args: should be \"llength list\"", + TCL_STATIC); + return TCL_ERROR; + } + varTokenPtr = parsePtr->tokenPtr + + (parsePtr->tokenPtr->numComponents + 1); + + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + /* + * We could simply count the number of elements here and push + * that value, but that is too rare a case to waste the code space. + */ + TclEmitPush(TclRegisterLiteral(envPtr, varTokenPtr[1].start, + varTokenPtr[1].size, 0), envPtr); + envPtr->maxStackDepth = 1; + } else { + code = TclCompileTokens(interp, varTokenPtr+1, + varTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + return code; + } + } + TclEmitOpcode(INST_LIST_LENGTH, envPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TclCompileReturnCmd -- * * Procedure called to compile the "return" command. @@ -1575,7 +1899,7 @@ TclCompileReturnCmd(interp, parsePtr, envPtr) { Tcl_Token *varTokenPtr; int code; - + /* * If we're not in a procedure, don't compile. */ @@ -1679,13 +2003,7 @@ TclCompileSetCmd(interp, parsePtr, envPtr) CompileEnv *envPtr; /* Holds resulting instructions. */ { Tcl_Token *varTokenPtr, *valueTokenPtr; - Tcl_Parse elemParse; - int gotElemParse = 0; - register char *p; - char *name, *elName; - int nameChars, elNameChars; - register int i, n; - int isAssignment, simpleVarName, localIndex, numWords; + int isAssignment, isScalar, simpleVarName, localIndex, numWords; int maxDepth = 0; int code = TCL_OK; @@ -1707,174 +2025,20 @@ TclCompileSetCmd(interp, parsePtr, envPtr) * namespace qualifiers. */ - simpleVarName = 0; - name = elName = NULL; - nameChars = elNameChars = 0; - localIndex = -1; - varTokenPtr = parsePtr->tokenPtr + (parsePtr->tokenPtr->numComponents + 1); - /* - * Check not only that the type is TCL_TOKEN_SIMPLE_WORD, but whether - * curly braces surround the variable name. - * This really matters for array elements to handle things like - * set {x($foo)} 5 - * which raises an undefined var error if we are not careful here. - * This goes with the hack in TclCompileIncrCmd. - */ - if ((varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) && - (varTokenPtr->start[0] != '{')) { - simpleVarName = 1; - name = varTokenPtr[1].start; - nameChars = varTokenPtr[1].size; - /* last char is ')' => potential array reference */ - if ( *(name + nameChars - 1) == ')') { - for (i = 0, p = name; i < nameChars; i++, p++) { - if (*p == '(') { - elName = p + 1; - elNameChars = nameChars - i - 2; - nameChars = i ; - break; - } - } - } - - /* - * If elName contains any double quotes ("), we can't inline - * compile the element script using the replace '()' by '"' - * technique below. - */ - - for (i = 0, p = elName; i < elNameChars; i++, p++) { - if (*p == '"') { - simpleVarName = 0; - break; - } - } - } else if (((n = varTokenPtr->numComponents) > 1) - && (varTokenPtr[1].type == TCL_TOKEN_TEXT) - && (varTokenPtr[n].type == TCL_TOKEN_TEXT) - && (varTokenPtr[n].start[varTokenPtr[n].size - 1] == ')')) { - simpleVarName = 0; - - /* - * Check for parentheses inside first token - */ - for (i = 0, p = varTokenPtr[1].start; - i < varTokenPtr[1].size; i++, p++) { - if (*p == '(') { - simpleVarName = 1; - break; - } - } - if (simpleVarName) { - name = varTokenPtr[1].start; - nameChars = p - varTokenPtr[1].start; - elName = p + 1; - elNameChars = (varTokenPtr[n].start - p) + varTokenPtr[n].size - 2; - - /* - * If elName contains any double quotes ("), we can't inline - * compile the element script using the replace '()' by '"' - * technique below. - */ - - for (i = 0, p = elName; i < elNameChars; i++, p++) { - if (*p == '"') { - simpleVarName = 0; - break; - } - } - } + code = TclPushVarName(interp, varTokenPtr, envPtr, + (isAssignment ? TCL_CREATE_VAR : 0), + &localIndex, &maxDepth, &simpleVarName, &isScalar); + if (code != TCL_OK) { + goto done; } - if (simpleVarName) { - /* - * See whether name has any namespace separators (::'s). - */ - - int hasNsQualifiers = 0; - for (i = 0, p = name; i < nameChars; i++, p++) { - if ((*p == ':') && ((i+1) < nameChars) && (*(p+1) == ':')) { - hasNsQualifiers = 1; - break; - } - } - - /* - * Look up the var name's index in the array of local vars in the - * proc frame. If retrieving the var's value and it doesn't already - * exist, push its name and look it up at runtime. - */ - - if ((envPtr->procPtr != NULL) && !hasNsQualifiers) { - localIndex = TclFindCompiledLocal(name, nameChars, - /*create*/ isAssignment, - /*flags*/ ((elName==NULL)? VAR_SCALAR : VAR_ARRAY), - envPtr->procPtr); - } - if (localIndex >= 0) { - maxDepth = 0; - } else { - TclEmitPush(TclRegisterLiteral(envPtr, name, nameChars, - /*onHeap*/ 0), envPtr); - maxDepth = 1; - } - - /* - * Compile the element script, if any. - */ - - if (elName != NULL) { - /* - * Temporarily replace the '(' and ')' by '"'s. - */ - - *(elName-1) = '"'; - *(elName+elNameChars) = '"'; - code = Tcl_ParseCommand(interp, elName-1, elNameChars+2, - /*nested*/ 0, &elemParse); - *(elName-1) = '('; - *(elName+elNameChars) = ')'; - gotElemParse = 1; - if ((code != TCL_OK) || (elemParse.numWords > 1)) { - char buffer[160]; - sprintf(buffer, "\n (parsing index for array \"%.*s\")", - TclMin(nameChars, 100), name); - Tcl_AddObjErrorInfo(interp, buffer, -1); - code = TCL_ERROR; - goto done; - } else if (elemParse.numWords == 1) { - code = TclCompileTokens(interp, elemParse.tokenPtr+1, - elemParse.tokenPtr->numComponents, envPtr); - if (code != TCL_OK) { - goto done; - } - maxDepth += envPtr->maxStackDepth; - } else { - TclEmitPush(TclRegisterLiteral(envPtr, "", 0, - /*alreadyAlloced*/ 0), envPtr); - maxDepth += 1; - } - } - } else { - /* - * The var name isn't simple: compile and push it. - */ - - code = TclCompileTokens(interp, varTokenPtr+1, - varTokenPtr->numComponents, envPtr); - if (code != TCL_OK) { - goto done; - } - maxDepth += envPtr->maxStackDepth; - } - /* * If we are doing an assignment, push the new value. */ - + if (isAssignment) { valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { @@ -1890,13 +2054,13 @@ TclCompileSetCmd(interp, parsePtr, envPtr) maxDepth += envPtr->maxStackDepth; } } - + /* * Emit instructions to set/get the variable. */ if (simpleVarName) { - if (elName == NULL) { + if (isScalar) { if (localIndex >= 0) { if (localIndex <= 255) { TclEmitInstInt1((isAssignment? @@ -1909,8 +2073,7 @@ TclCompileSetCmd(interp, parsePtr, envPtr) } } else { TclEmitOpcode((isAssignment? - INST_STORE_SCALAR_STK : INST_LOAD_SCALAR_STK), - envPtr); + INST_STORE_SCALAR_STK : INST_LOAD_SCALAR_STK), envPtr); } } else { if (localIndex >= 0) { @@ -1925,19 +2088,14 @@ TclCompileSetCmd(interp, parsePtr, envPtr) } } else { TclEmitOpcode((isAssignment? - INST_STORE_ARRAY_STK : INST_LOAD_ARRAY_STK), - envPtr); + INST_STORE_ARRAY_STK : INST_LOAD_ARRAY_STK), envPtr); } } } else { - TclEmitOpcode((isAssignment? INST_STORE_STK : INST_LOAD_STK), - envPtr); + TclEmitOpcode((isAssignment? INST_STORE_STK : INST_LOAD_STK), envPtr); } done: - if (gotElemParse) { - Tcl_FreeParse(&elemParse); - } envPtr->maxStackDepth = maxDepth; return code; } @@ -1995,27 +2153,20 @@ TclCompileStringCmd(interp, parsePtr, envPtr) STR_WORDEND, STR_WORDSTART }; - /* - * If we're not in a procedure, don't compile. - */ - if (envPtr->procPtr == NULL) { - return TCL_OUT_LINE_COMPILE; - } - if (parsePtr->numWords < 2) { Tcl_SetResult(interp, "wrong # args: should be \"string option " - "arg ?arg?\"", TCL_STATIC); + "arg ?arg ...?\"", TCL_STATIC); return TCL_ERROR; } opTokenPtr = parsePtr->tokenPtr + (parsePtr->tokenPtr->numComponents + 1); opObj = Tcl_NewStringObj(opTokenPtr->start, opTokenPtr->size); - if (Tcl_GetIndexFromObj(interp, opObj, options, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } + Tcl_DecrRefCount(opObj); varTokenPtr = opTokenPtr + (opTokenPtr->numComponents + 1); @@ -2125,9 +2276,16 @@ TclCompileStringCmd(interp, parsePtr, envPtr) } if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - TclEmitPush(TclRegisterLiteral(envPtr, varTokenPtr[1].start, - varTokenPtr[1].size, 0), envPtr); - envPtr->maxStackDepth = 1; + /* + * Here someone is asking for the length of a static string. + * Just push the actual character (not byte) length. + */ + char buf[TCL_INTEGER_SPACE]; + int len = Tcl_NumUtfChars(varTokenPtr[1].start, + varTokenPtr[1].size); + len = sprintf(buf, "%d", len); + TclEmitPush(TclRegisterLiteral(envPtr, buf, len, 0), envPtr); + return TCL_OK; } else { code = TclCompileTokens(interp, varTokenPtr+1, varTokenPtr->numComponents, envPtr); @@ -2380,6 +2538,236 @@ TclCompileWhileCmd(interp, parsePtr, envPtr) envPtr->exceptDepth--; return code; } + +/* + *---------------------------------------------------------------------- + * + * TclPushVarName -- + * + * Procedure used in the compiling where pushing a variable name + * is necessary (append, lappend, set). + * + * Results: + * The return value is a standard Tcl result, which is normally TCL_OK + * unless there was an error while parsing string. If an error occurs + * then the interpreter's result contains a standard error message. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the incr command. + * + * Side effects: + * Instructions are added to envPtr to execute the "set" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclPushVarName(interp, varTokenPtr, envPtr, flags, localIndexPtr, + maxDepthPtr, simpleVarNamePtr, isScalarPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Token *varTokenPtr; /* Points to a variable token. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ + int flags; /* takes TCL_CREATE_VAR or + * TCL_LARGE_INDEX_OK */ + int *localIndexPtr; /* must not be NULL */ + int *maxDepthPtr; /* must not be NULL, should already have a + * value set in the parent. */ + int *simpleVarNamePtr; /* must not be NULL */ + int *isScalarPtr; /* must not be NULL */ +{ + Tcl_Parse elemParse; + int gotElemParse = 0; + register char *p; + char *name, *elName; + register int i, n; + int nameChars, elNameChars, simpleVarName, localIndex; + int maxDepth = 0; + int code = TCL_OK; + + /* + * Decide if we can use a frame slot for the var/array name or if we + * need to emit code to compute and push the name at runtime. We use a + * frame slot (entry in the array of local vars) if we are compiling a + * procedure body and if the name is simple text that does not include + * namespace qualifiers. + */ + simpleVarName = 0; + name = elName = NULL; + nameChars = elNameChars = 0; + localIndex = -1; + /* + * Check not only that the type is TCL_TOKEN_SIMPLE_WORD, but whether + * curly braces surround the variable name. + * This really matters for array elements to handle things like + * set {x($foo)} 5 + * which raises an undefined var error if we are not careful here. + */ + + if ((varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) && + (varTokenPtr->start[0] != '{')) { + /* + * A simple variable name. Divide it up into "name" and "elName" + * strings. If it is not a local variable, look it up at runtime. + */ + simpleVarName = 1; + name = varTokenPtr[1].start; + nameChars = varTokenPtr[1].size; + /* last char is ')' => potential array reference */ + if ( *(name + nameChars - 1) == ')') { + for (i = 0, p = name; i < nameChars; i++, p++) { + if (*p == '(') { + elName = p + 1; + elNameChars = nameChars - i - 2; + nameChars = i ; + break; + } + } + } + + /* + * If elName contains any double quotes ("), we can't inline + * compile the element script using the replace '()' by '"' + * technique below. + */ + + for (i = 0, p = elName; i < elNameChars; i++, p++) { + if (*p == '"') { + simpleVarName = 0; + break; + } + } + } else if (((n = varTokenPtr->numComponents) > 1) + && (varTokenPtr[1].type == TCL_TOKEN_TEXT) + && (varTokenPtr[n].type == TCL_TOKEN_TEXT) + && (varTokenPtr[n].start[varTokenPtr[n].size - 1] == ')')) { + simpleVarName = 0; + + /* + * Check for parentheses inside first token + */ + for (i = 0, p = varTokenPtr[1].start; + i < varTokenPtr[1].size; i++, p++) { + if (*p == '(') { + simpleVarName = 1; + break; + } + } + if (simpleVarName) { + name = varTokenPtr[1].start; + nameChars = p - varTokenPtr[1].start; + elName = p + 1; + elNameChars = (varTokenPtr[n].start - p) + varTokenPtr[n].size - 2; + + /* + * If elName contains any double quotes ("), we can't inline + * compile the element script using the replace '()' by '"' + * technique below. + */ + + for (i = 0, p = elName; i < elNameChars; i++, p++) { + if (*p == '"') { + simpleVarName = 0; + break; + } + } + } + } + + if (simpleVarName) { + /* + * See whether name has any namespace separators (::'s). + */ + + int hasNsQualifiers = 0; + for (i = 0, p = name; i < nameChars; i++, p++) { + if ((*p == ':') && ((i+1) < nameChars) && (*(p+1) == ':')) { + hasNsQualifiers = 1; + break; + } + } + + /* + * Look up the var name's index in the array of local vars in the + * proc frame. If retrieving the var's value and it doesn't already + * exist, push its name and look it up at runtime. + */ + + if ((envPtr->procPtr != NULL) && !hasNsQualifiers) { + localIndex = TclFindCompiledLocal(name, nameChars, + /*create*/ (flags & TCL_CREATE_VAR), + /*flags*/ ((elName==NULL)? VAR_SCALAR : VAR_ARRAY), + envPtr->procPtr); + if ((flags & TCL_NO_LARGE_INDEX) && (localIndex > 255)) { + /* we'll push the name */ + localIndex = -1; + } + } + if (localIndex < 0) { + TclEmitPush(TclRegisterLiteral(envPtr, name, nameChars, + /*onHeap*/ 0), envPtr); + maxDepth = 1; + } + + /* + * Compile the element script, if any. + */ + + if (elName != NULL) { + /* + * Temporarily replace the '(' and ')' by '"'s. + */ + + *(elName-1) = '"'; + *(elName+elNameChars) = '"'; + code = Tcl_ParseCommand(interp, elName-1, elNameChars+2, + /*nested*/ 0, &elemParse); + *(elName-1) = '('; + *(elName+elNameChars) = ')'; + gotElemParse = 1; + if ((code != TCL_OK) || (elemParse.numWords > 1)) { + char buffer[160]; + sprintf(buffer, "\n (parsing index for array \"%.*s\")", + TclMin(nameChars, 100), name); + Tcl_AddObjErrorInfo(interp, buffer, -1); + code = TCL_ERROR; + goto done; + } else if (elemParse.numWords == 1) { + code = TclCompileTokens(interp, elemParse.tokenPtr+1, + elemParse.tokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + goto done; + } + maxDepth += envPtr->maxStackDepth; + } else { + TclEmitPush(TclRegisterLiteral(envPtr, "", 0, + /*alreadyAlloced*/ 0), envPtr); + maxDepth += 1; + } + } + } else { + /* + * The var name isn't simple: compile and push it. + */ + + code = TclCompileTokens(interp, varTokenPtr+1, + varTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + goto done; + } + maxDepth += envPtr->maxStackDepth; + } + + done: + if (gotElemParse) { + Tcl_FreeParse(&elemParse); + } + *localIndexPtr = localIndex; + *maxDepthPtr += maxDepth; + *simpleVarNamePtr = simpleVarName; + *isScalarPtr = (elName == NULL); + return code; +} diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 6a108ab..f39ae24 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -10,7 +10,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.21 2000/05/26 08:53:41 hobbs Exp $ + * RCS: @(#) $Id: tclCompile.c,v 1.22 2001/05/17 02:13:02 hobbs Exp $ */ #include "tclInt.h" @@ -222,6 +222,36 @@ InstructionDesc instructionTable[] = { /* Str Index: push (strindex stknext stktop) */ {"strmatch", 1, 0, {OPERAND_NONE}}, /* Str Match: push (strmatch stkforenext stknext stktop) */ + {"list", 1, 0, {OPERAND_NONE}}, + /* List: push (stk1 stk2 ... stktop) */ + {"listindex", 1, 0, {OPERAND_NONE}}, + /* List Index: push (listindex stknext stktop) */ + {"listlength", 1, 0, {OPERAND_NONE}}, + /* List Len: push (listlength stktop) */ + {"appendScalar1", 2, 1, {OPERAND_UINT1}}, + /* Append scalar variable at op1<=255 in frame; value is stktop */ + {"appendScalar4", 5, 1, {OPERAND_UINT4}}, + /* Append scalar variable at op1 > 255 in frame; value is stktop */ + {"appendArray1", 2, 1, {OPERAND_UINT1}}, + /* Append array element; array at op1<=255, value is top then elem */ + {"appendArray4", 5, 1, {OPERAND_UINT4}}, + /* Append array element; array at op1>=256, value is top then elem */ + {"appendArrayStk", 1, 0, {OPERAND_NONE}}, + /* Append array element; value is stktop, then elem, array names */ + {"appendStk", 1, 0, {OPERAND_NONE}}, + /* Append general variable; value is stktop, then unparsed name */ + {"lappendScalar1", 2, 1, {OPERAND_UINT1}}, + /* Lappend scalar variable at op1<=255 in frame; value is stktop */ + {"lappendScalar4", 5, 1, {OPERAND_UINT4}}, + /* Lappend scalar variable at op1 > 255 in frame; value is stktop */ + {"lappendArray1", 2, 1, {OPERAND_UINT1}}, + /* Lappend array element; array at op1<=255, value is top then elem */ + {"lappendArray4", 5, 1, {OPERAND_UINT4}}, + /* Lappend array element; array at op1>=256, value is top then elem */ + {"lappendArrayStk", 1, 0, {OPERAND_NONE}}, + /* Lappend array element; value is stktop, then elem, array names */ + {"lappendStk", 1, 0, {OPERAND_NONE}}, + /* Lappend general variable; value is stktop, then unparsed name */ {0} }; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 935f5a7..ec8f120 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -7,7 +7,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.14 2000/05/26 08:53:42 hobbs Exp $ + * RCS: @(#) $Id: tclCompile.h,v 1.15 2001/05/17 02:13:02 hobbs Exp $ */ #ifndef _TCLCOMPILATION @@ -494,7 +494,7 @@ typedef struct ByteCode { #define INST_PUSH_RESULT 71 #define INST_PUSH_RETURN_CODE 72 -/* Opcodes 73 to 74 */ +/* Opcodes 73 to 78 */ #define INST_STR_EQ 73 #define INST_STR_NEQ 74 #define INST_STR_CMP 75 @@ -502,8 +502,27 @@ typedef struct ByteCode { #define INST_STR_INDEX 77 #define INST_STR_MATCH 78 +/* Opcodes 78 to 81 */ +#define INST_LIST 79 +#define INST_LIST_INDEX 80 +#define INST_LIST_LENGTH 81 + +#define INST_APPEND_SCALAR1 82 +#define INST_APPEND_SCALAR4 83 +#define INST_APPEND_ARRAY1 84 +#define INST_APPEND_ARRAY4 85 +#define INST_APPEND_ARRAY_STK 86 +#define INST_APPEND_STK 87 + +#define INST_LAPPEND_SCALAR1 88 +#define INST_LAPPEND_SCALAR4 89 +#define INST_LAPPEND_ARRAY1 90 +#define INST_LAPPEND_ARRAY4 91 +#define INST_LAPPEND_ARRAY_STK 92 +#define INST_LAPPEND_STK 93 + /* The last opcode */ -#define LAST_INST_OPCODE 78 +#define LAST_INST_OPCODE 93 /* * Table describing the Tcl bytecode instructions: their name (for diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 1e9f1e6..facb099 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -10,7 +10,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.22 2001/05/07 22:15:29 msofer Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.23 2001/05/17 02:13:02 hobbs Exp $ */ #include "tclInt.h" @@ -102,7 +102,7 @@ static char *operatorStrings[] = { "BUILTIN FUNCTION", "FUNCTION", "", "", "", "", "", "", "", "", "eq", "ne", }; - + /* * Mapping from Tcl result codes to strings; used for error and debugging * messages. @@ -203,11 +203,11 @@ long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 }; (unsigned int)(pc - codePtr->codeStart), \ GetOpcodeName(pc)); \ printf a; \ - TclPrintObject(stdout, (objPtr), 30); \ + TclPrintObject(stdout, objPtr, 30); \ fprintf(stdout, "\n"); \ } #define O2S(objPtr) \ - Tcl_GetString(objPtr) + (objPtr ? Tcl_GetString(objPtr) : "") #else #define TRACE(a) #define TRACE_WITH_OBJ(a, objPtr) @@ -556,7 +556,7 @@ TclExecuteByteCode(interp, codePtr) * process break, continue, and errors. */ int result = TCL_OK; /* Return code returned after execution. */ int traceInstructions = (tclTraceExec == 3); - Tcl_Obj *valuePtr, *value2Ptr, *objPtr; + Tcl_Obj *valuePtr, *value2Ptr, *objPtr, *elemPtr; char *bytes; int length; long i; @@ -653,7 +653,7 @@ TclExecuteByteCode(interp, codePtr) } #endif goto done; - + case INST_PUSH1: #ifdef TCL_COMPILE_DEBUG valuePtr = codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]; @@ -663,13 +663,13 @@ TclExecuteByteCode(interp, codePtr) PUSH_OBJECT(codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]); #endif /* TCL_COMPILE_DEBUG */ ADJUST_PC(2); - + case INST_PUSH4: valuePtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc+1)]; PUSH_OBJECT(valuePtr); TRACE_WITH_OBJ(("%u => ", TclGetUInt4AtPtr(pc+1)), valuePtr); ADJUST_PC(5); - + case INST_POP: valuePtr = POP_OBJECT(); TRACE_WITH_OBJ(("=> discarding "), valuePtr); @@ -1097,8 +1097,7 @@ TclExecuteByteCode(interp, codePtr) #ifdef TCL_COMPILE_DEBUG opnd = TclGetUInt1AtPtr(pc+1); DECACHE_STACK_INFO(); - valuePtr = TclGetIndexedScalar(interp, opnd, - /*leaveErrorMsg*/ 1); + valuePtr = TclGetIndexedScalar(interp, opnd, TCL_LEAVE_ERR_MSG); CACHE_STACK_INFO(); if (valuePtr == NULL) { TRACE_WITH_OBJ(("%u => ERROR: ", opnd), @@ -1111,7 +1110,7 @@ TclExecuteByteCode(interp, codePtr) #else /* TCL_COMPILE_DEBUG */ DECACHE_STACK_INFO(); opnd = TclGetUInt1AtPtr(pc+1); - valuePtr = TclGetIndexedScalar(interp, opnd, /*leaveErrorMsg*/ 1); + valuePtr = TclGetIndexedScalar(interp, opnd, TCL_LEAVE_ERR_MSG); CACHE_STACK_INFO(); if (valuePtr == NULL) { result = TCL_ERROR; @@ -1124,8 +1123,7 @@ TclExecuteByteCode(interp, codePtr) case INST_LOAD_SCALAR4: opnd = TclGetUInt4AtPtr(pc+1); DECACHE_STACK_INFO(); - valuePtr = TclGetIndexedScalar(interp, opnd, - /*leaveErrorMsg*/ 1); + valuePtr = TclGetIndexedScalar(interp, opnd, TCL_LEAVE_ERR_MSG); CACHE_STACK_INFO(); if (valuePtr == NULL) { TRACE_WITH_OBJ(("%u => ERROR: ", opnd), @@ -1137,8 +1135,9 @@ TclExecuteByteCode(interp, codePtr) TRACE_WITH_OBJ(("%u => ", opnd), valuePtr); ADJUST_PC(5); + case INST_LOAD_STK: case INST_LOAD_SCALAR_STK: - objPtr = POP_OBJECT(); /* scalar name */ + objPtr = POP_OBJECT(); /* scalar / variable name */ DECACHE_STACK_INFO(); valuePtr = Tcl_ObjGetVar2(interp, objPtr, NULL, TCL_LEAVE_ERR_MSG); CACHE_STACK_INFO(); @@ -1164,70 +1163,48 @@ TclExecuteByteCode(interp, codePtr) pcAdjustment = 2; doLoadArray: - { - Tcl_Obj *elemPtr = POP_OBJECT(); - - DECACHE_STACK_INFO(); - valuePtr = TclGetElementOfIndexedArray(interp, opnd, - elemPtr, /*leaveErrorMsg*/ 1); - CACHE_STACK_INFO(); - if (valuePtr == NULL) { - TRACE_WITH_OBJ(("%u \"%.30s\" => ERROR: ", - opnd, O2S(elemPtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(elemPtr); - result = TCL_ERROR; - goto checkForCatch; - } - PUSH_OBJECT(valuePtr); - TRACE_WITH_OBJ(("%u \"%.30s\" => ", - opnd, O2S(elemPtr)),valuePtr); - TclDecrRefCount(elemPtr); + elemPtr = POP_OBJECT(); + + DECACHE_STACK_INFO(); + valuePtr = TclGetElementOfIndexedArray(interp, opnd, + elemPtr, TCL_LEAVE_ERR_MSG); + CACHE_STACK_INFO(); + if (valuePtr == NULL) { + TRACE_WITH_OBJ(("%u \"%.30s\" => ERROR: ", + opnd, O2S(elemPtr)), Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(elemPtr); + result = TCL_ERROR; + goto checkForCatch; } + PUSH_OBJECT(valuePtr); + TRACE_WITH_OBJ(("%u \"%.30s\" => ", + opnd, O2S(elemPtr)),valuePtr); + TclDecrRefCount(elemPtr); ADJUST_PC(pcAdjustment); case INST_LOAD_ARRAY_STK: - { - Tcl_Obj *elemPtr = POP_OBJECT(); - - objPtr = POP_OBJECT(); /* array name */ - DECACHE_STACK_INFO(); - valuePtr = Tcl_ObjGetVar2(interp, objPtr, elemPtr, - TCL_LEAVE_ERR_MSG); - CACHE_STACK_INFO(); - if (valuePtr == NULL) { - TRACE_WITH_OBJ(("\"%.30s(%.30s)\" => ERROR: ", - O2S(objPtr), O2S(elemPtr)), - Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(objPtr); - Tcl_DecrRefCount(elemPtr); - result = TCL_ERROR; - goto checkForCatch; - } - PUSH_OBJECT(valuePtr); - TRACE_WITH_OBJ(("\"%.30s(%.30s)\" => ", - O2S(objPtr), O2S(elemPtr)), valuePtr); - TclDecrRefCount(objPtr); - TclDecrRefCount(elemPtr); - } - ADJUST_PC(1); - - case INST_LOAD_STK: - objPtr = POP_OBJECT(); /* variable name */ + elemPtr = POP_OBJECT(); + objPtr = POP_OBJECT(); /* array name */ DECACHE_STACK_INFO(); - valuePtr = Tcl_ObjGetVar2(interp, objPtr, NULL, TCL_LEAVE_ERR_MSG); + valuePtr = Tcl_ObjGetVar2(interp, objPtr, elemPtr, + TCL_LEAVE_ERR_MSG); CACHE_STACK_INFO(); if (valuePtr == NULL) { - TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", - O2S(objPtr)), Tcl_GetObjResult(interp)); + TRACE_WITH_OBJ(("\"%.30s(%.30s)\" => ERROR: ", + O2S(objPtr), O2S(elemPtr)), + Tcl_GetObjResult(interp)); Tcl_DecrRefCount(objPtr); + Tcl_DecrRefCount(elemPtr); result = TCL_ERROR; goto checkForCatch; } PUSH_OBJECT(valuePtr); - TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr); + TRACE_WITH_OBJ(("\"%.30s(%.30s)\" => ", + O2S(objPtr), O2S(elemPtr)), valuePtr); TclDecrRefCount(objPtr); + TclDecrRefCount(elemPtr); ADJUST_PC(1); - + case INST_STORE_SCALAR4: opnd = TclGetUInt4AtPtr(pc+1); pcAdjustment = 5; @@ -1236,12 +1213,12 @@ TclExecuteByteCode(interp, codePtr) case INST_STORE_SCALAR1: opnd = TclGetUInt1AtPtr(pc+1); pcAdjustment = 2; - + doStoreScalar: valuePtr = POP_OBJECT(); DECACHE_STACK_INFO(); value2Ptr = TclSetIndexedScalar(interp, opnd, valuePtr, - /*leaveErrorMsg*/ 1); + TCL_LEAVE_ERR_MSG); CACHE_STACK_INFO(); if (value2Ptr == NULL) { TRACE_WITH_OBJ(("%u <- \"%.30s\" => ERROR: ", @@ -1256,9 +1233,10 @@ TclExecuteByteCode(interp, codePtr) TclDecrRefCount(valuePtr); ADJUST_PC(pcAdjustment); + case INST_STORE_STK: case INST_STORE_SCALAR_STK: valuePtr = POP_OBJECT(); - objPtr = POP_OBJECT(); /* scalar name */ + objPtr = POP_OBJECT(); /* scalar / variable name */ DECACHE_STACK_INFO(); value2Ptr = Tcl_ObjSetVar2(interp, objPtr, NULL, valuePtr, TCL_LEAVE_ERR_MSG); @@ -1289,85 +1267,321 @@ TclExecuteByteCode(interp, codePtr) pcAdjustment = 2; doStoreArray: - { - Tcl_Obj *elemPtr; + valuePtr = POP_OBJECT(); + elemPtr = POP_OBJECT(); + DECACHE_STACK_INFO(); + value2Ptr = TclSetElementOfIndexedArray(interp, opnd, + elemPtr, valuePtr, TCL_LEAVE_ERR_MSG); + CACHE_STACK_INFO(); + if (value2Ptr == NULL) { + TRACE_WITH_OBJ(("%u \"%.30s\" <- \"%.30s\" => ERROR: ", + opnd, O2S(elemPtr), O2S(valuePtr)), + Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(elemPtr); + Tcl_DecrRefCount(valuePtr); + result = TCL_ERROR; + goto checkForCatch; + } + PUSH_OBJECT(value2Ptr); + TRACE_WITH_OBJ(("%u \"%.30s\" <- \"%.30s\" => ", + opnd, O2S(elemPtr), O2S(valuePtr)), value2Ptr); + TclDecrRefCount(elemPtr); + TclDecrRefCount(valuePtr); + ADJUST_PC(pcAdjustment); - valuePtr = POP_OBJECT(); + case INST_STORE_ARRAY_STK: + valuePtr = POP_OBJECT(); + elemPtr = POP_OBJECT(); + objPtr = POP_OBJECT(); /* array name */ + DECACHE_STACK_INFO(); + value2Ptr = Tcl_ObjSetVar2(interp, objPtr, elemPtr, valuePtr, + TCL_LEAVE_ERR_MSG); + CACHE_STACK_INFO(); + if (value2Ptr == NULL) { + TRACE_WITH_OBJ(("\"%.30s(%.30s)\" <- \"%.30s\" => ERROR: ", + O2S(objPtr), O2S(elemPtr), O2S(valuePtr)), + Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(objPtr); + Tcl_DecrRefCount(elemPtr); + Tcl_DecrRefCount(valuePtr); + result = TCL_ERROR; + goto checkForCatch; + } + PUSH_OBJECT(value2Ptr); + TRACE_WITH_OBJ(("\"%.30s(%.30s)\" <- \"%.30s\" => ", + O2S(objPtr), O2S(elemPtr), O2S(valuePtr)), + value2Ptr); + TclDecrRefCount(objPtr); + TclDecrRefCount(elemPtr); + TclDecrRefCount(valuePtr); + ADJUST_PC(1); + + /* + * START APPEND INSTRUCTIONS + */ + + case INST_APPEND_SCALAR4: + opnd = TclGetUInt4AtPtr(pc+1); + pcAdjustment = 5; + goto doAppendScalar; + + case INST_APPEND_SCALAR1: + opnd = TclGetUInt1AtPtr(pc+1); + pcAdjustment = 2; + + doAppendScalar: + valuePtr = POP_OBJECT(); + DECACHE_STACK_INFO(); + value2Ptr = TclSetIndexedScalar(interp, opnd, valuePtr, + TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); + CACHE_STACK_INFO(); + if (value2Ptr == NULL) { + TRACE_WITH_OBJ(("%u <- \"%.30s\" => ERROR: ", + opnd, O2S(valuePtr)), Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(valuePtr); + result = TCL_ERROR; + goto checkForCatch; + } + PUSH_OBJECT(value2Ptr); + TRACE_WITH_OBJ(("%u <- \"%.30s\" => ", + opnd, O2S(valuePtr)), value2Ptr); + TclDecrRefCount(valuePtr); + ADJUST_PC(pcAdjustment); + + case INST_APPEND_STK: + case INST_APPEND_ARRAY_STK: + valuePtr = POP_OBJECT(); /* value to append */ + if (*pc == INST_APPEND_ARRAY_STK) { elemPtr = POP_OBJECT(); - DECACHE_STACK_INFO(); - value2Ptr = TclSetElementOfIndexedArray(interp, opnd, - elemPtr, valuePtr, TCL_LEAVE_ERR_MSG); - CACHE_STACK_INFO(); - if (value2Ptr == NULL) { - TRACE_WITH_OBJ(("%u \"%.30s\" <- \"%.30s\" => ERROR: ", - opnd, O2S(elemPtr), O2S(valuePtr)), + } else { + elemPtr = NULL; + } + objPtr = POP_OBJECT(); /* scalar name */ + + DECACHE_STACK_INFO(); + value2Ptr = Tcl_ObjSetVar2(interp, objPtr, elemPtr, valuePtr, + TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); + CACHE_STACK_INFO(); + if (value2Ptr == NULL) { + if (elemPtr) { + TRACE_WITH_OBJ(("\"%.30s(%.30s)\" <-+ \"%.30s\" => ERROR: ", + O2S(objPtr), O2S(elemPtr), O2S(valuePtr)), + Tcl_GetObjResult(interp)); + TclDecrRefCount(elemPtr); + } else { + TRACE_WITH_OBJ(("\"%.30s\" <-+ \"%.30s\" => ERROR: ", + O2S(objPtr), O2S(valuePtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(elemPtr); - Tcl_DecrRefCount(valuePtr); - result = TCL_ERROR; - goto checkForCatch; } - PUSH_OBJECT(value2Ptr); - TRACE_WITH_OBJ(("%u \"%.30s\" <- \"%.30s\" => ", - opnd, O2S(elemPtr), O2S(valuePtr)), value2Ptr); + Tcl_DecrRefCount(objPtr); + Tcl_DecrRefCount(valuePtr); + result = TCL_ERROR; + goto checkForCatch; + } + PUSH_OBJECT(value2Ptr); + if (elemPtr) { + TRACE_WITH_OBJ(("\"%.30s(%.30s)\" <-+ \"%.30s\" => ", + O2S(objPtr), O2S(elemPtr), O2S(valuePtr)), + value2Ptr); TclDecrRefCount(elemPtr); - TclDecrRefCount(valuePtr); + } else { + TRACE_WITH_OBJ(("\"%.30s\" <-+ \"%.30s\" => ", + O2S(objPtr), O2S(valuePtr)), value2Ptr); } + TclDecrRefCount(objPtr); + TclDecrRefCount(valuePtr); + ADJUST_PC(1); + + case INST_APPEND_ARRAY4: + opnd = TclGetUInt4AtPtr(pc+1); + pcAdjustment = 5; + goto doAppendArray; + + case INST_APPEND_ARRAY1: + opnd = TclGetUInt1AtPtr(pc+1); + pcAdjustment = 2; + + doAppendArray: + valuePtr = POP_OBJECT(); + elemPtr = POP_OBJECT(); + DECACHE_STACK_INFO(); + value2Ptr = TclSetElementOfIndexedArray(interp, opnd, + elemPtr, valuePtr, TCL_LEAVE_ERR_MSG|TCL_APPEND_VALUE); + CACHE_STACK_INFO(); + if (value2Ptr == NULL) { + TRACE_WITH_OBJ(("%u \"%.30s\" <-+ \"%.30s\" => ERROR: ", + opnd, O2S(elemPtr), O2S(valuePtr)), + Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(elemPtr); + Tcl_DecrRefCount(valuePtr); + result = TCL_ERROR; + goto checkForCatch; + } + PUSH_OBJECT(value2Ptr); + TRACE_WITH_OBJ(("%u \"%.30s\" <-+ \"%.30s\" => ", + opnd, O2S(elemPtr), O2S(valuePtr)), value2Ptr); + TclDecrRefCount(elemPtr); + TclDecrRefCount(valuePtr); ADJUST_PC(pcAdjustment); - case INST_STORE_ARRAY_STK: - { - Tcl_Obj *elemPtr; + /* + * END APPEND INSTRUCTIONS + */ + /* + * START LAPPEND INSTRUCTIONS + */ - valuePtr = POP_OBJECT(); + case INST_LAPPEND_SCALAR4: + opnd = TclGetUInt4AtPtr(pc+1); + pcAdjustment = 5; + goto doLappendScalar; + + case INST_LAPPEND_SCALAR1: + opnd = TclGetUInt1AtPtr(pc+1); + pcAdjustment = 2; + + doLappendScalar: + valuePtr = POP_OBJECT(); + DECACHE_STACK_INFO(); + value2Ptr = TclSetIndexedScalar(interp, opnd, valuePtr, + TCL_LEAVE_ERR_MSG|TCL_APPEND_VALUE|TCL_LIST_ELEMENT); + CACHE_STACK_INFO(); + if (value2Ptr == NULL) { + TRACE_WITH_OBJ(("%u <- \"%.30s\" => ERROR: ", + opnd, O2S(valuePtr)), Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(valuePtr); + result = TCL_ERROR; + goto checkForCatch; + } + PUSH_OBJECT(value2Ptr); + TRACE_WITH_OBJ(("%u <- \"%.30s\" => ", + opnd, O2S(valuePtr)), value2Ptr); + TclDecrRefCount(valuePtr); + ADJUST_PC(pcAdjustment); + + case INST_LAPPEND_STK: + case INST_LAPPEND_ARRAY_STK: + { + /* + * This compile function for this should be refactored + * to make better use of existing LOAD/STORE instructions. + */ + Tcl_Obj *newValuePtr; + int createdNewObj = 0; + + value2Ptr = POP_OBJECT(); /* value to append */ + if (*pc == INST_LAPPEND_ARRAY_STK) { elemPtr = POP_OBJECT(); - objPtr = POP_OBJECT(); /* array name */ - DECACHE_STACK_INFO(); - value2Ptr = Tcl_ObjSetVar2(interp, objPtr, elemPtr, valuePtr, - TCL_LEAVE_ERR_MSG); - CACHE_STACK_INFO(); - if (value2Ptr == NULL) { + } else { + elemPtr = NULL; + } + objPtr = POP_OBJECT(); /* scalar name */ + + DECACHE_STACK_INFO(); + /* Currently value of the list */ + valuePtr = Tcl_ObjGetVar2(interp, objPtr, elemPtr, 0); + CACHE_STACK_INFO(); + if (valuePtr == NULL) { + valuePtr = Tcl_NewObj(); + createdNewObj = 1; + } else if (Tcl_IsShared(valuePtr)) { + valuePtr = Tcl_DuplicateObj(valuePtr); + createdNewObj = 1; + } + + DECACHE_STACK_INFO(); + result = Tcl_ListObjAppendElement(interp, valuePtr, value2Ptr); + CACHE_STACK_INFO(); + if (result != TCL_OK) { + if (elemPtr) { TRACE_WITH_OBJ(("\"%.30s(%.30s)\" <- \"%.30s\" => ERROR: ", - O2S(objPtr), O2S(elemPtr), O2S(valuePtr)), + O2S(objPtr), O2S(elemPtr), O2S(valuePtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(objPtr); Tcl_DecrRefCount(elemPtr); - Tcl_DecrRefCount(valuePtr); - result = TCL_ERROR; - goto checkForCatch; + } else { + TRACE_WITH_OBJ(("\"%.30s\" <-+ \"%.30s\" => ERROR: ", + O2S(objPtr), O2S(value2Ptr)), + Tcl_GetObjResult(interp)); + } + Tcl_DecrRefCount(objPtr); + Tcl_DecrRefCount(value2Ptr); + if (createdNewObj) Tcl_DecrRefCount(valuePtr); + result = TCL_ERROR; + goto checkForCatch; + } + + DECACHE_STACK_INFO(); + newValuePtr = Tcl_ObjSetVar2(interp, objPtr, elemPtr, valuePtr, + TCL_LEAVE_ERR_MSG); + CACHE_STACK_INFO(); + if (newValuePtr == NULL) { + if (elemPtr) { + TRACE_WITH_OBJ(("\"%.30s(%.30s)\" <- \"%.30s\" => ERROR: ", + O2S(objPtr), O2S(elemPtr), O2S(valuePtr)), + Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(elemPtr); + } else { + TRACE_WITH_OBJ(("\"%.30s\" <-+ \"%.30s\" => ERROR: ", + O2S(objPtr), O2S(value2Ptr)), + Tcl_GetObjResult(interp)); } - PUSH_OBJECT(value2Ptr); + Tcl_DecrRefCount(objPtr); + Tcl_DecrRefCount(value2Ptr); + if (createdNewObj) Tcl_DecrRefCount(valuePtr); + result = TCL_ERROR; + goto checkForCatch; + } + PUSH_OBJECT(newValuePtr); + if (elemPtr) { TRACE_WITH_OBJ(("\"%.30s(%.30s)\" <- \"%.30s\" => ", - O2S(objPtr), O2S(elemPtr), O2S(valuePtr)), + O2S(objPtr), O2S(elemPtr), O2S(valuePtr)), value2Ptr); - TclDecrRefCount(objPtr); TclDecrRefCount(elemPtr); - TclDecrRefCount(valuePtr); + } else { + TRACE_WITH_OBJ(("\"%.30s\" <-+ \"%.30s\" => ", + O2S(objPtr), O2S(valuePtr)), value2Ptr); } + TclDecrRefCount(objPtr); + TclDecrRefCount(value2Ptr); ADJUST_PC(1); + } - case INST_STORE_STK: + case INST_LAPPEND_ARRAY4: + opnd = TclGetUInt4AtPtr(pc+1); + pcAdjustment = 5; + goto doLappendArray; + + case INST_LAPPEND_ARRAY1: + opnd = TclGetUInt1AtPtr(pc+1); + pcAdjustment = 2; + + doLappendArray: valuePtr = POP_OBJECT(); - objPtr = POP_OBJECT(); /* variable name */ + elemPtr = POP_OBJECT(); DECACHE_STACK_INFO(); - value2Ptr = Tcl_ObjSetVar2(interp, objPtr, NULL, valuePtr, - TCL_LEAVE_ERR_MSG); + value2Ptr = TclSetElementOfIndexedArray(interp, opnd, + elemPtr, valuePtr, + TCL_LEAVE_ERR_MSG|TCL_APPEND_VALUE|TCL_LIST_ELEMENT); CACHE_STACK_INFO(); if (value2Ptr == NULL) { - TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ERROR: ", - O2S(objPtr), O2S(valuePtr)), + TRACE_WITH_OBJ(("%u \"%.30s\" <-+ \"%.30s\" => ERROR: ", + opnd, O2S(elemPtr), O2S(valuePtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(objPtr); + Tcl_DecrRefCount(elemPtr); Tcl_DecrRefCount(valuePtr); result = TCL_ERROR; goto checkForCatch; } PUSH_OBJECT(value2Ptr); - TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ", - O2S(objPtr), O2S(valuePtr)), value2Ptr); - TclDecrRefCount(objPtr); + TRACE_WITH_OBJ(("%u \"%.30s\" <-+ \"%.30s\" => ", + opnd, O2S(elemPtr), O2S(valuePtr)), value2Ptr); + TclDecrRefCount(elemPtr); TclDecrRefCount(valuePtr); - ADJUST_PC(1); + ADJUST_PC(pcAdjustment); + + /* + * END (L)APPEND INSTRUCTIONS + */ case INST_INCR_SCALAR1: opnd = TclGetUInt1AtPtr(pc+1); @@ -1433,86 +1647,78 @@ TclExecuteByteCode(interp, codePtr) ADJUST_PC(1); case INST_INCR_ARRAY1: - { - Tcl_Obj *elemPtr; - - opnd = TclGetUInt1AtPtr(pc+1); - valuePtr = POP_OBJECT(); - elemPtr = POP_OBJECT(); - if (valuePtr->typePtr != &tclIntType) { - result = tclIntType.setFromAnyProc(interp, valuePtr); - if (result != TCL_OK) { - TRACE_WITH_OBJ(("%u \"%.30s\" (by %s) => ERROR converting increment amount to int: ", - opnd, O2S(elemPtr), O2S(valuePtr)), - Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(elemPtr); - Tcl_DecrRefCount(valuePtr); - goto checkForCatch; - } - } - i = valuePtr->internalRep.longValue; - DECACHE_STACK_INFO(); - value2Ptr = TclIncrElementOfIndexedArray(interp, opnd, - elemPtr, i); - CACHE_STACK_INFO(); - if (value2Ptr == NULL) { - TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ERROR: ", - opnd, O2S(elemPtr), i), + opnd = TclGetUInt1AtPtr(pc+1); + valuePtr = POP_OBJECT(); + elemPtr = POP_OBJECT(); + if (valuePtr->typePtr != &tclIntType) { + result = tclIntType.setFromAnyProc(interp, valuePtr); + if (result != TCL_OK) { + TRACE_WITH_OBJ(("%u \"%.30s\" (by %s) => ERROR converting increment amount to int: ", + opnd, O2S(elemPtr), O2S(valuePtr)), Tcl_GetObjResult(interp)); Tcl_DecrRefCount(elemPtr); Tcl_DecrRefCount(valuePtr); - result = TCL_ERROR; goto checkForCatch; } - PUSH_OBJECT(value2Ptr); - TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ", - opnd, O2S(elemPtr), i), value2Ptr); + } + i = valuePtr->internalRep.longValue; + DECACHE_STACK_INFO(); + value2Ptr = TclIncrElementOfIndexedArray(interp, opnd, + elemPtr, i); + CACHE_STACK_INFO(); + if (value2Ptr == NULL) { + TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ERROR: ", + opnd, O2S(elemPtr), i), + Tcl_GetObjResult(interp)); Tcl_DecrRefCount(elemPtr); Tcl_DecrRefCount(valuePtr); + result = TCL_ERROR; + goto checkForCatch; } + PUSH_OBJECT(value2Ptr); + TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ", + opnd, O2S(elemPtr), i), value2Ptr); + Tcl_DecrRefCount(elemPtr); + Tcl_DecrRefCount(valuePtr); ADJUST_PC(2); case INST_INCR_ARRAY_STK: - { - Tcl_Obj *elemPtr; - - valuePtr = POP_OBJECT(); - elemPtr = POP_OBJECT(); - objPtr = POP_OBJECT(); /* array name */ - if (valuePtr->typePtr != &tclIntType) { - result = tclIntType.setFromAnyProc(interp, valuePtr); - if (result != TCL_OK) { - TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %s) => ERROR converting increment amount to int: ", - O2S(objPtr), O2S(elemPtr), O2S(valuePtr)), - Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(objPtr); - Tcl_DecrRefCount(elemPtr); - Tcl_DecrRefCount(valuePtr); - goto checkForCatch; - } - } - i = valuePtr->internalRep.longValue; - DECACHE_STACK_INFO(); - value2Ptr = TclIncrVar2(interp, objPtr, elemPtr, i, - TCL_LEAVE_ERR_MSG); - CACHE_STACK_INFO(); - if (value2Ptr == NULL) { - TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ERROR: ", - O2S(objPtr), O2S(elemPtr), i), + valuePtr = POP_OBJECT(); + elemPtr = POP_OBJECT(); + objPtr = POP_OBJECT(); /* array name */ + if (valuePtr->typePtr != &tclIntType) { + result = tclIntType.setFromAnyProc(interp, valuePtr); + if (result != TCL_OK) { + TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %s) => ERROR converting increment amount to int: ", + O2S(objPtr), O2S(elemPtr), O2S(valuePtr)), Tcl_GetObjResult(interp)); Tcl_DecrRefCount(objPtr); Tcl_DecrRefCount(elemPtr); Tcl_DecrRefCount(valuePtr); - result = TCL_ERROR; goto checkForCatch; } - PUSH_OBJECT(value2Ptr); - TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ", - O2S(objPtr), O2S(elemPtr), i), value2Ptr); + } + i = valuePtr->internalRep.longValue; + DECACHE_STACK_INFO(); + value2Ptr = TclIncrVar2(interp, objPtr, elemPtr, i, + TCL_LEAVE_ERR_MSG); + CACHE_STACK_INFO(); + if (value2Ptr == NULL) { + TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ERROR: ", + O2S(objPtr), O2S(elemPtr), i), + Tcl_GetObjResult(interp)); Tcl_DecrRefCount(objPtr); Tcl_DecrRefCount(elemPtr); Tcl_DecrRefCount(valuePtr); + result = TCL_ERROR; + goto checkForCatch; } + PUSH_OBJECT(value2Ptr); + TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ", + O2S(objPtr), O2S(elemPtr), i), value2Ptr); + Tcl_DecrRefCount(objPtr); + Tcl_DecrRefCount(elemPtr); + Tcl_DecrRefCount(valuePtr); ADJUST_PC(1); case INST_INCR_SCALAR1_IMM: @@ -1553,57 +1759,49 @@ TclExecuteByteCode(interp, codePtr) ADJUST_PC(2); case INST_INCR_ARRAY1_IMM: - { - Tcl_Obj *elemPtr; - - opnd = TclGetUInt1AtPtr(pc+1); - i = TclGetInt1AtPtr(pc+2); - elemPtr = POP_OBJECT(); - DECACHE_STACK_INFO(); - value2Ptr = TclIncrElementOfIndexedArray(interp, opnd, - elemPtr, i); - CACHE_STACK_INFO(); - if (value2Ptr == NULL) { - TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ERROR: ", - opnd, O2S(elemPtr), i), - Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(elemPtr); - result = TCL_ERROR; - goto checkForCatch; - } - PUSH_OBJECT(value2Ptr); - TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ", - opnd, O2S(elemPtr), i), value2Ptr); + opnd = TclGetUInt1AtPtr(pc+1); + i = TclGetInt1AtPtr(pc+2); + elemPtr = POP_OBJECT(); + DECACHE_STACK_INFO(); + value2Ptr = TclIncrElementOfIndexedArray(interp, opnd, + elemPtr, i); + CACHE_STACK_INFO(); + if (value2Ptr == NULL) { + TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ERROR: ", + opnd, O2S(elemPtr), i), + Tcl_GetObjResult(interp)); Tcl_DecrRefCount(elemPtr); + result = TCL_ERROR; + goto checkForCatch; } + PUSH_OBJECT(value2Ptr); + TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ", + opnd, O2S(elemPtr), i), value2Ptr); + Tcl_DecrRefCount(elemPtr); ADJUST_PC(3); case INST_INCR_ARRAY_STK_IMM: - { - Tcl_Obj *elemPtr; - - i = TclGetInt1AtPtr(pc+1); - elemPtr = POP_OBJECT(); - objPtr = POP_OBJECT(); /* array name */ - DECACHE_STACK_INFO(); - value2Ptr = TclIncrVar2(interp, objPtr, elemPtr, i, - TCL_LEAVE_ERR_MSG); - CACHE_STACK_INFO(); - if (value2Ptr == NULL) { - TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ERROR: ", - O2S(objPtr), O2S(elemPtr), i), - Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(objPtr); - Tcl_DecrRefCount(elemPtr); - result = TCL_ERROR; - goto checkForCatch; - } - PUSH_OBJECT(value2Ptr); - TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ", - O2S(objPtr), O2S(elemPtr), i), value2Ptr); + i = TclGetInt1AtPtr(pc+1); + elemPtr = POP_OBJECT(); + objPtr = POP_OBJECT(); /* array name */ + DECACHE_STACK_INFO(); + value2Ptr = TclIncrVar2(interp, objPtr, elemPtr, i, + TCL_LEAVE_ERR_MSG); + CACHE_STACK_INFO(); + if (value2Ptr == NULL) { + TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ERROR: ", + O2S(objPtr), O2S(elemPtr), i), + Tcl_GetObjResult(interp)); Tcl_DecrRefCount(objPtr); Tcl_DecrRefCount(elemPtr); + result = TCL_ERROR; + goto checkForCatch; } + PUSH_OBJECT(value2Ptr); + TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ", + O2S(objPtr), O2S(elemPtr), i), value2Ptr); + Tcl_DecrRefCount(objPtr); + Tcl_DecrRefCount(elemPtr); ADJUST_PC(2); case INST_JUMP1: @@ -1715,12 +1913,12 @@ TclExecuteByteCode(interp, codePtr) int iResult; char *s; Tcl_ObjType *t1Ptr, *t2Ptr; - + value2Ptr = POP_OBJECT(); valuePtr = POP_OBJECT(); t1Ptr = valuePtr->typePtr; t2Ptr = value2Ptr->typePtr; - + if ((t1Ptr == &tclIntType) || (t1Ptr == &tclBooleanType)) { i1 = (valuePtr->internalRep.longValue != 0); } else if (t1Ptr == &tclDoubleType) { @@ -1771,7 +1969,7 @@ TclExecuteByteCode(interp, codePtr) goto checkForCatch; } } - + /* * Reuse the valuePtr object already on stack if possible. */ @@ -1796,14 +1994,87 @@ TclExecuteByteCode(interp, codePtr) } ADJUST_PC(1); + case INST_LIST_LENGTH: + valuePtr = POP_OBJECT(); + + result = Tcl_ListObjLength(interp, valuePtr, &length); + if (result != TCL_OK) { + TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)), + Tcl_GetObjResult(interp)); + TclDecrRefCount(valuePtr); + goto checkForCatch; + } + PUSH_OBJECT(Tcl_NewIntObj(length)); + TRACE(("%.20s => %d\n", O2S(valuePtr), length)); + TclDecrRefCount(valuePtr); + ADJUST_PC(1); + + case INST_LIST_INDEX: + { + Tcl_Obj **elemPtrs; + int index; + + value2Ptr = POP_OBJECT(); + valuePtr = POP_OBJECT(); + + result = Tcl_ListObjGetElements(interp, valuePtr, + &length, &elemPtrs); + if (result != TCL_OK) { + TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)), + Tcl_GetObjResult(interp)); + TclDecrRefCount(value2Ptr); + TclDecrRefCount(valuePtr); + goto checkForCatch; + } + + result = TclGetIntForIndex(interp, value2Ptr, length - 1, + &index); + if (result != TCL_OK) { + TRACE_WITH_OBJ(("%.20s => ERROR: ", O2S(value2Ptr)), + Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(value2Ptr); + Tcl_DecrRefCount(valuePtr); + goto checkForCatch; + } + + if ((index < 0) || (index >= length)) { + objPtr = Tcl_NewObj(); + } else { + /* + * Make sure listPtr still refers to a list object. It + * might have been converted to an int above if the + * argument objects were shared. + */ + + if (valuePtr->typePtr != &tclListType) { + result = Tcl_ListObjGetElements(interp, valuePtr, + &length, &elemPtrs); + if (result != TCL_OK) { + TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)), + Tcl_GetObjResult(interp)); + TclDecrRefCount(value2Ptr); + TclDecrRefCount(valuePtr); + goto checkForCatch; + } + } + objPtr = elemPtrs[index]; + } + + PUSH_OBJECT(objPtr); + TRACE(("%.20s %.20s => %s\n", + O2S(valuePtr), O2S(value2Ptr), O2S(objPtr))); + TclDecrRefCount(valuePtr); + TclDecrRefCount(value2Ptr); + } + ADJUST_PC(1); + case INST_STR_EQ: case INST_STR_NEQ: { /* * String (in)equality check */ - char *s1, *s2; - int s1len, s2len, iResult; + int iResult; value2Ptr = POP_OBJECT(); valuePtr = POP_OBJECT(); @@ -1815,6 +2086,9 @@ TclExecuteByteCode(interp, codePtr) */ iResult = (*pc == INST_STR_EQ); } else { + char *s1, *s2; + int s1len, s2len; + s1 = Tcl_GetStringFromObj(valuePtr, &s1len); s2 = Tcl_GetStringFromObj(value2Ptr, &s2len); if (s1len == s2len) { @@ -1852,18 +2126,53 @@ TclExecuteByteCode(interp, codePtr) value2Ptr = POP_OBJECT(); valuePtr = POP_OBJECT(); - s1 = Tcl_GetStringFromObj(valuePtr, &s1len); - s2 = Tcl_GetStringFromObj(value2Ptr, &s2len); /* - * Compare up to the minimum byte length + * The comparison function should compare up to the + * minimum byte length only. + */ + if ((valuePtr->typePtr == &tclByteArrayType) && + (value2Ptr->typePtr == &tclByteArrayType)) { + s1 = Tcl_GetByteArrayFromObj(valuePtr, &s1len); + s2 = Tcl_GetByteArrayFromObj(value2Ptr, &s2len); + iResult = memcmp(s1, s2, + (size_t) ((s1len < s2len) ? s1len : s2len)); + } else { +#if 0 + /* + * This solution is less mem intensive, but it is + * computationally expensive as the string grows. The + * reason that we can't use a memcmp is that UTF-8 strings + * that contain a \u0000 can't be compared with memcmp. If + * we knew that the string was ascii-7 or had no null byte, + * we could just do memcmp and save all the hassle. + */ + s1 = Tcl_GetStringFromObj(valuePtr, &s1len); + s2 = Tcl_GetStringFromObj(value2Ptr, &s2len); + iResult = Tcl_UtfNcmp(s1, s2, + (size_t) ((s1len < s2len) ? s1len : s2len)); +#else + /* + * The alternative is to break this into more code + * that does type sensitive comparison, as done in + * Tcl_StringObjCmd. + */ + Tcl_UniChar *uni1, *uni2; + uni1 = Tcl_GetUnicodeFromObj(valuePtr, &s1len); + uni2 = Tcl_GetUnicodeFromObj(value2Ptr, &s2len); + iResult = Tcl_UniCharNcmp(uni1, uni2, + (unsigned) ((s1len < s2len) ? s1len : s2len)); +#endif + } + + /* + * Make sure only -1,0,1 is returned */ - iResult = memcmp(s1, s2, - (size_t) ((s1len < s2len) ? s1len : s2len)); if (iResult == 0) { iResult = s1len - s2len; - } else if (iResult < 0) { + } + if (iResult < 0) { iResult = -1; - } else { + } else if (iResult > 0) { iResult = 1; } @@ -1935,7 +2244,13 @@ TclExecuteByteCode(interp, codePtr) char buf[TCL_UTF_MAX]; Tcl_UniChar ch; - ch = Tcl_GetUniChar(valuePtr, index); + ch = Tcl_GetUniChar(valuePtr, index); + /* + * This could be: + * Tcl_NewUnicodeObj((CONST Tcl_UniChar *)&ch, 1) + * but creating the object as a string seems to be + * faster in practical use. + */ length = Tcl_UniCharToUtf(ch, buf); objPtr = Tcl_NewStringObj(buf, length); } @@ -2042,6 +2357,7 @@ TclExecuteByteCode(interp, codePtr) || ((t2Ptr != &tclIntType) && (t2Ptr != &tclDoubleType))) { /* * One operand is not numeric. Compare as strings. + * NOTE: strcmp is not correct for \x00 < \x01. */ int cmpValue; s1 = Tcl_GetString(valuePtr); @@ -3004,7 +3320,7 @@ TclExecuteByteCode(interp, codePtr) varIndex = varListPtr->varIndexes[j]; DECACHE_STACK_INFO(); value2Ptr = TclSetIndexedScalar(interp, - varIndex, valuePtr, /*leaveErrorMsg*/ 1); + varIndex, valuePtr, TCL_LEAVE_ERR_MSG); CACHE_STACK_INFO(); if (value2Ptr == NULL) { TRACE_WITH_OBJ(("%u => ERROR init. index temp %d: ", diff --git a/generic/tclInt.decls b/generic/tclInt.decls index dce2e0e..241390d 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -10,7 +10,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.decls,v 1.25 2001/04/27 22:11:51 kennykb Exp $ +# RCS: @(#) $Id: tclInt.decls,v 1.26 2001/05/17 02:13:03 hobbs Exp $ library tcl @@ -128,7 +128,7 @@ declare 28 generic { } declare 29 generic { Tcl_Obj * TclGetElementOfIndexedArray(Tcl_Interp *interp, \ - int localIndex, Tcl_Obj *elemPtr, int leaveErrorMsg) + int localIndex, Tcl_Obj *elemPtr, int flags) } # Replaced by char * TclGetEnv(CONST char *name, Tcl_DString *valuePtr) in 8.1: # declare 30 generic { @@ -149,7 +149,7 @@ declare 34 generic { } declare 35 generic { Tcl_Obj * TclGetIndexedScalar(Tcl_Interp *interp, int localIndex, \ - int leaveErrorMsg) + int flags) } declare 36 generic { int TclGetLong(Tcl_Interp *interp, char *str, long *longPtr) @@ -374,11 +374,11 @@ declare 98 generic { } declare 99 generic { Tcl_Obj * TclSetElementOfIndexedArray(Tcl_Interp *interp, \ - int localIndex, Tcl_Obj *elemPtr, Tcl_Obj *objPtr, int leaveErrorMsg) + int localIndex, Tcl_Obj *elemPtr, Tcl_Obj *objPtr, int flags) } declare 100 generic { Tcl_Obj * TclSetIndexedScalar(Tcl_Interp *interp, int localIndex, \ - Tcl_Obj *objPtr, int leaveErrorMsg) + Tcl_Obj *objPtr, int flags) } declare 101 {unix win} { char * TclSetPreInitScript(char *string) diff --git a/generic/tclInt.h b/generic/tclInt.h index 752395f..cb7646b 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -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: tclInt.h,v 1.53 2001/05/15 14:19:13 msofer Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.54 2001/05/17 02:13:03 hobbs Exp $ */ #ifndef _TCLINT @@ -1702,7 +1702,7 @@ EXTERN int TclGetDate _ANSI_ARGS_((char *p, unsigned long *timePtr)); EXTERN Tcl_Obj * TclGetElementOfIndexedArray _ANSI_ARGS_(( Tcl_Interp *interp, int localIndex, - Tcl_Obj *elemPtr, int leaveErrorMsg)); + Tcl_Obj *elemPtr, int flags)); EXTERN char * TclGetExtension _ANSI_ARGS_((char *name)); EXTERN int TclGetFrame _ANSI_ARGS_((Tcl_Interp *interp, char *string, CallFrame **framePtrPtr)); @@ -1710,7 +1710,7 @@ EXTERN TclCmdProcType TclGetInterpProc _ANSI_ARGS_((void)); EXTERN int TclGetIntForIndex _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr, int endValue, int *indexPtr)); EXTERN Tcl_Obj * TclGetIndexedScalar _ANSI_ARGS_((Tcl_Interp *interp, - int localIndex, int leaveErrorMsg)); + int localIndex, int flags)); EXTERN int TclGetLong _ANSI_ARGS_((Tcl_Interp *interp, char *string, long *longPtr)); EXTERN int TclGetLoadedPackages _ANSI_ARGS_(( @@ -1878,11 +1878,9 @@ EXTERN void TclResetShadowedCmdRefs _ANSI_ARGS_(( EXTERN int TclServiceIdle _ANSI_ARGS_((void)); EXTERN Tcl_Obj * TclSetElementOfIndexedArray _ANSI_ARGS_(( Tcl_Interp *interp, int localIndex, - Tcl_Obj *elemPtr, Tcl_Obj *objPtr, - int leaveErrorMsg)); + Tcl_Obj *elemPtr, Tcl_Obj *objPtr, int flags)); EXTERN Tcl_Obj * TclSetIndexedScalar _ANSI_ARGS_((Tcl_Interp *interp, - int localIndex, Tcl_Obj *objPtr, - int leaveErrorMsg)); + int localIndex, Tcl_Obj *objPtr, int flags)); EXTERN char * TclSetPreInitScript _ANSI_ARGS_((char *string)); EXTERN void TclSetupEnv _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN VOID TclSignalExitThread _ANSI_ARGS_((Tcl_ThreadId id, @@ -2084,6 +2082,8 @@ EXTERN int Tcl_ResourceObjCmd _ANSI_ARGS_((ClientData clientData, *---------------------------------------------------------------- */ +EXTERN int TclCompileAppendCmd _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); EXTERN int TclCompileBreakCmd _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); EXTERN int TclCompileCatchCmd _ANSI_ARGS_((Tcl_Interp *interp, @@ -2100,6 +2100,12 @@ EXTERN int TclCompileIfCmd _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); EXTERN int TclCompileIncrCmd _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); +EXTERN int TclCompileLappendCmd _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); +EXTERN int TclCompileLindexCmd _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); +EXTERN int TclCompileLlengthCmd _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); EXTERN int TclCompileReturnCmd _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); EXTERN int TclCompileSetCmd _ANSI_ARGS_((Tcl_Interp *interp, diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 6e20425..32b6ede 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -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: tclIntDecls.h,v 1.23 2001/04/27 22:11:51 kennykb Exp $ + * RCS: @(#) $Id: tclIntDecls.h,v 1.24 2001/05/17 02:13:03 hobbs Exp $ */ #ifndef _TCLINTDECLS @@ -133,7 +133,7 @@ EXTERN Tcl_Channel TclpGetDefaultStdChannel _ANSI_ARGS_((int type)); /* 29 */ EXTERN Tcl_Obj * TclGetElementOfIndexedArray _ANSI_ARGS_(( Tcl_Interp * interp, int localIndex, - Tcl_Obj * elemPtr, int leaveErrorMsg)); + Tcl_Obj * elemPtr, int flags)); /* Slot 30 is reserved */ /* 31 */ EXTERN char * TclGetExtension _ANSI_ARGS_((char * name)); @@ -148,7 +148,7 @@ EXTERN int TclGetIntForIndex _ANSI_ARGS_((Tcl_Interp * interp, int * indexPtr)); /* 35 */ EXTERN Tcl_Obj * TclGetIndexedScalar _ANSI_ARGS_((Tcl_Interp * interp, - int localIndex, int leaveErrorMsg)); + int localIndex, int flags)); /* 36 */ EXTERN int TclGetLong _ANSI_ARGS_((Tcl_Interp * interp, char * str, long * longPtr)); @@ -327,11 +327,10 @@ EXTERN int TclServiceIdle _ANSI_ARGS_((void)); EXTERN Tcl_Obj * TclSetElementOfIndexedArray _ANSI_ARGS_(( Tcl_Interp * interp, int localIndex, Tcl_Obj * elemPtr, Tcl_Obj * objPtr, - int leaveErrorMsg)); + int flags)); /* 100 */ EXTERN Tcl_Obj * TclSetIndexedScalar _ANSI_ARGS_((Tcl_Interp * interp, - int localIndex, Tcl_Obj * objPtr, - int leaveErrorMsg)); + int localIndex, Tcl_Obj * objPtr, int flags)); #if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ /* 101 */ EXTERN char * TclSetPreInitScript _ANSI_ARGS_((char * string)); @@ -580,13 +579,13 @@ typedef struct TclIntStubs { void *reserved26; int (*tclGetDate) _ANSI_ARGS_((char * p, unsigned long now, long zone, unsigned long * timePtr)); /* 27 */ Tcl_Channel (*tclpGetDefaultStdChannel) _ANSI_ARGS_((int type)); /* 28 */ - Tcl_Obj * (*tclGetElementOfIndexedArray) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, Tcl_Obj * elemPtr, int leaveErrorMsg)); /* 29 */ + Tcl_Obj * (*tclGetElementOfIndexedArray) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, Tcl_Obj * elemPtr, int flags)); /* 29 */ void *reserved30; char * (*tclGetExtension) _ANSI_ARGS_((char * name)); /* 31 */ int (*tclGetFrame) _ANSI_ARGS_((Tcl_Interp * interp, char * str, CallFrame ** framePtrPtr)); /* 32 */ TclCmdProcType (*tclGetInterpProc) _ANSI_ARGS_((void)); /* 33 */ int (*tclGetIntForIndex) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int endValue, int * indexPtr)); /* 34 */ - Tcl_Obj * (*tclGetIndexedScalar) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, int leaveErrorMsg)); /* 35 */ + Tcl_Obj * (*tclGetIndexedScalar) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, int flags)); /* 35 */ int (*tclGetLong) _ANSI_ARGS_((Tcl_Interp * interp, char * str, long * longPtr)); /* 36 */ int (*tclGetLoadedPackages) _ANSI_ARGS_((Tcl_Interp * interp, char * targetName)); /* 37 */ int (*tclGetNamespaceForQualName) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * qualName, Namespace * cxtNsPtr, int flags, Namespace ** nsPtrPtr, Namespace ** altNsPtrPtr, Namespace ** actualCxtPtrPtr, CONST char ** simpleNamePtr)); /* 38 */ @@ -650,8 +649,8 @@ typedef struct TclIntStubs { int (*tclRenameCommand) _ANSI_ARGS_((Tcl_Interp * interp, char * oldName, char * newName)); /* 96 */ void (*tclResetShadowedCmdRefs) _ANSI_ARGS_((Tcl_Interp * interp, Command * newCmdPtr)); /* 97 */ int (*tclServiceIdle) _ANSI_ARGS_((void)); /* 98 */ - Tcl_Obj * (*tclSetElementOfIndexedArray) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, Tcl_Obj * elemPtr, Tcl_Obj * objPtr, int leaveErrorMsg)); /* 99 */ - Tcl_Obj * (*tclSetIndexedScalar) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, Tcl_Obj * objPtr, int leaveErrorMsg)); /* 100 */ + Tcl_Obj * (*tclSetElementOfIndexedArray) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, Tcl_Obj * elemPtr, Tcl_Obj * objPtr, int flags)); /* 99 */ + Tcl_Obj * (*tclSetIndexedScalar) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, Tcl_Obj * objPtr, int flags)); /* 100 */ #if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ char * (*tclSetPreInitScript) _ANSI_ARGS_((char * string)); /* 101 */ #endif /* UNIX */ diff --git a/generic/tclVar.c b/generic/tclVar.c index dcaf2c8..4f31613 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -14,7 +14,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclVar.c,v 1.31 2001/04/27 22:11:51 kennykb Exp $ + * RCS: @(#) $Id: tclVar.c,v 1.32 2001/05/17 02:13:03 hobbs Exp $ */ #include "tclInt.h" @@ -665,7 +665,7 @@ Tcl_GetVar2Ex(interp, part1, part2, flags) * given by localIndex. If the specified variable doesn't exist, or * there is a clash in array usage, or an error occurs while executing * variable traces, then NULL is returned and a message will be left in - * the interpreter's result if leaveErrorMsg is 1. + * the interpreter's result if TCL_LEAVE_ERR_MSG is set in flags. * * Side effects: * The ref count for the returned object is _not_ incremented to @@ -676,13 +676,13 @@ Tcl_GetVar2Ex(interp, part1, part2, flags) */ Tcl_Obj * -TclGetIndexedScalar(interp, localIndex, leaveErrorMsg) +TclGetIndexedScalar(interp, localIndex, flags) Tcl_Interp *interp; /* Command interpreter in which variable is * to be looked up. */ register int localIndex; /* Index of variable in procedure's array * of local variables. */ - int leaveErrorMsg; /* 1 if to leave an error message in - * interpreter's result on an error. + int flags; /* TCL_LEAVE_ERR_MSG if to leave an error + * message in interpreter's result on an error. * Otherwise no error message is left. */ { Interp *iPtr = (Interp *) interp; @@ -736,7 +736,7 @@ TclGetIndexedScalar(interp, localIndex, leaveErrorMsg) msg = CallTraces(iPtr, /*arrayPtr*/ NULL, varPtr, varName, NULL, TCL_TRACE_READS); if (msg != NULL) { - if (leaveErrorMsg) { + if (flags & TCL_LEAVE_ERR_MSG) { VarErrMsg(interp, varName, NULL, "read", msg); } return NULL; @@ -749,7 +749,7 @@ TclGetIndexedScalar(interp, localIndex, leaveErrorMsg) */ if (!TclIsVarScalar(varPtr) || TclIsVarUndefined(varPtr)) { - if (leaveErrorMsg) { + if (flags & TCL_LEAVE_ERR_MSG) { if (TclIsVarArray(varPtr)) { msg = isArray; } else { @@ -778,7 +778,7 @@ TclGetIndexedScalar(interp, localIndex, leaveErrorMsg) * element. If the specified array or element doesn't exist, or there * is a clash in array usage, or an error occurs while executing * variable traces, then NULL is returned and a message will be left in - * the interpreter's result if leaveErrorMsg is 1. + * the interpreter's result if TCL_LEAVE_ERR_MSG is set in flags. * * Side effects: * The ref count for the returned object is _not_ incremented to @@ -789,15 +789,15 @@ TclGetIndexedScalar(interp, localIndex, leaveErrorMsg) */ Tcl_Obj * -TclGetElementOfIndexedArray(interp, localIndex, elemPtr, leaveErrorMsg) +TclGetElementOfIndexedArray(interp, localIndex, elemPtr, flags) Tcl_Interp *interp; /* Command interpreter in which variable is * to be looked up. */ int localIndex; /* Index of array variable in procedure's * array of local variables. */ Tcl_Obj *elemPtr; /* Points to an object holding the name of * an element to get in the array. */ - int leaveErrorMsg; /* 1 if to leave an error message in - * the interpreter's result on an error. + int flags; /* TCL_LEAVE_ERR_MSG if to leave an error + * message in interpreter's result on an error. * Otherwise no error message is left. */ { Interp *iPtr = (Interp *) interp; @@ -856,7 +856,7 @@ TclGetElementOfIndexedArray(interp, localIndex, elemPtr, leaveErrorMsg) */ if (!TclIsVarArray(arrayPtr) || TclIsVarUndefined(arrayPtr)) { - if (leaveErrorMsg) { + if (flags & TCL_LEAVE_ERR_MSG) { VarErrMsg(interp, arrayName, elem, "read", noSuchVar); } goto errorReturn; @@ -894,7 +894,7 @@ TclGetElementOfIndexedArray(interp, localIndex, elemPtr, leaveErrorMsg) msg = CallTraces(iPtr, arrayPtr, varPtr, arrayName, elem, TCL_TRACE_READS); if (msg != NULL) { - if (leaveErrorMsg) { + if (flags & TCL_LEAVE_ERR_MSG) { VarErrMsg(interp, arrayName, elem, "read", msg); } goto errorReturn; @@ -909,7 +909,7 @@ TclGetElementOfIndexedArray(interp, localIndex, elemPtr, leaveErrorMsg) return varPtr->value.objPtr; } - if (leaveErrorMsg) { + if (flags & TCL_LEAVE_ERR_MSG) { if (TclIsVarArray(varPtr)) { msg = isArray; } else { @@ -1190,8 +1190,7 @@ Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags) Var *arrayPtr; Tcl_Obj *oldValuePtr; Tcl_Obj *resultPtr = NULL; - char *bytes; - int length, result; + int result; varPtr = TclLookupVar(interp, part1, part2, flags, "set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); @@ -1272,10 +1271,9 @@ Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags) * We append newValuePtr's bytes but don't change its ref count. */ - bytes = Tcl_GetStringFromObj(newValuePtr, &length); if (oldValuePtr == NULL) { - varPtr->value.objPtr = Tcl_NewStringObj(bytes, length); - Tcl_IncrRefCount(varPtr->value.objPtr); + varPtr->value.objPtr = newValuePtr; + Tcl_IncrRefCount(newValuePtr); } else { if (Tcl_IsShared(oldValuePtr)) { /* append to copy */ varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr); @@ -1286,34 +1284,16 @@ Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags) Tcl_AppendObjToObj(oldValuePtr, newValuePtr); } } - } else { - if (flags & TCL_LIST_ELEMENT) { /* set var to list element */ - int neededBytes, listFlags; - - /* - * We set the variable to the result of converting newValuePtr's - * string rep to a list element. We do not change newValuePtr's - * ref count. - */ + } else if (newValuePtr != oldValuePtr) { + /* + * In this case we are replacing the value, so we don't need to + * do more than swap the objects. + */ - if (oldValuePtr != NULL) { - Tcl_DecrRefCount(oldValuePtr); /* discard old value */ - } - bytes = Tcl_GetStringFromObj(newValuePtr, &length); - neededBytes = Tcl_ScanElement(bytes, &listFlags); - oldValuePtr = Tcl_NewObj(); - oldValuePtr->bytes = (char *) - ckalloc((unsigned) (neededBytes + 1)); - oldValuePtr->length = Tcl_ConvertElement(bytes, - oldValuePtr->bytes, listFlags); - varPtr->value.objPtr = oldValuePtr; - Tcl_IncrRefCount(varPtr->value.objPtr); - } else if (newValuePtr != oldValuePtr) { - varPtr->value.objPtr = newValuePtr; - Tcl_IncrRefCount(newValuePtr); /* var is another ref */ - if (oldValuePtr != NULL) { - TclDecrRefCount(oldValuePtr); /* discard old value */ - } + varPtr->value.objPtr = newValuePtr; + Tcl_IncrRefCount(newValuePtr); /* var is another ref */ + if (oldValuePtr != NULL) { + TclDecrRefCount(oldValuePtr); /* discard old value */ } } TclSetVarScalar(varPtr); @@ -1381,8 +1361,8 @@ Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags) * variable given by localIndex. If the specified variable doesn't * exist, or there is a clash in array usage, or an error occurs while * executing variable traces, then NULL is returned and a message will - * be left in the interpreter's result if leaveErrorMsg is 1. Note - * that the returned object may not be the same one referenced by + * be left in the interpreter's result if flags has TCL_LEAVE_ERR_MSG. + * Note that the returned object may not be the same one referenced by * newValuePtr; this is because variable traces may modify the * variable's value. * @@ -1401,15 +1381,15 @@ Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags) */ Tcl_Obj * -TclSetIndexedScalar(interp, localIndex, newValuePtr, leaveErrorMsg) +TclSetIndexedScalar(interp, localIndex, newValuePtr, flags) Tcl_Interp *interp; /* Command interpreter in which variable is * to be found. */ int localIndex; /* Index of variable in procedure's array * of local variables. */ Tcl_Obj *newValuePtr; /* New value for variable. */ - int leaveErrorMsg; /* 1 if to leave an error message in - * the interpreter's result on an error. - * Otherwise no error message is left. */ + int flags; /* Various flags that tell how to set value: + * any of TCL_APPEND_VALUE, + * TCL_LIST_ELEMENT or TCL_LEAVE_ERR_MSG. */ { Interp *iPtr = (Interp *) interp; CallFrame *varFramePtr = iPtr->varFramePtr; @@ -1465,7 +1445,7 @@ TclSetIndexedScalar(interp, localIndex, newValuePtr, leaveErrorMsg) */ if ((varPtr->flags & VAR_IN_HASHTABLE) && (varPtr->hPtr == NULL)) { - if (leaveErrorMsg) { + if (flags & TCL_LEAVE_ERR_MSG) { if (TclIsVarArrayElement(varPtr)) { VarErrMsg(interp, varName, NULL, "set", danglingElement); } else { @@ -1480,19 +1460,62 @@ TclSetIndexedScalar(interp, localIndex, newValuePtr, leaveErrorMsg) */ if (TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) { - if (leaveErrorMsg) { + if (flags & TCL_LEAVE_ERR_MSG) { VarErrMsg(interp, varName, NULL, "set", isArray); } return NULL; } /* - * Set the variable's new value and discard its old value. We don't - * append with this "set" procedure so the old value isn't needed. + * Set the variable's new value and discard its old value. */ oldValuePtr = varPtr->value.objPtr; - if (newValuePtr != oldValuePtr) { /* set new value */ + if (flags & TCL_APPEND_VALUE) { + if (TclIsVarUndefined(varPtr) && (oldValuePtr != NULL)) { + Tcl_DecrRefCount(oldValuePtr); /* discard old value */ + varPtr->value.objPtr = NULL; + oldValuePtr = NULL; + } + if (flags & TCL_LIST_ELEMENT) { /* append list element */ + if (oldValuePtr == NULL) { + TclNewObj(oldValuePtr); + varPtr->value.objPtr = oldValuePtr; + Tcl_IncrRefCount(oldValuePtr); /* since var is referenced */ + } else if (Tcl_IsShared(oldValuePtr)) { + varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr); + Tcl_DecrRefCount(oldValuePtr); + oldValuePtr = varPtr->value.objPtr; + Tcl_IncrRefCount(oldValuePtr); /* since var is referenced */ + } + if (Tcl_ListObjAppendElement(interp, oldValuePtr, + newValuePtr) != TCL_OK) { + return NULL; + } + } else { /* append string */ + /* + * We append newValuePtr's bytes but don't change its ref count. + */ + + if (oldValuePtr == NULL) { + varPtr->value.objPtr = newValuePtr; + Tcl_IncrRefCount(newValuePtr); + } else { + if (Tcl_IsShared(oldValuePtr)) { /* append to copy */ + varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr); + TclDecrRefCount(oldValuePtr); + oldValuePtr = varPtr->value.objPtr; + Tcl_IncrRefCount(oldValuePtr); /* since var is ref */ + } + Tcl_AppendObjToObj(oldValuePtr, newValuePtr); + } + } + } else if (newValuePtr != oldValuePtr) { /* set new value */ + /* + * In this case we are replacing the value, so we don't need to + * do more than swap the objects. + */ + varPtr->value.objPtr = newValuePtr; Tcl_IncrRefCount(newValuePtr); /* var is another ref to obj */ if (oldValuePtr != NULL) { @@ -1510,7 +1533,7 @@ TclSetIndexedScalar(interp, localIndex, newValuePtr, leaveErrorMsg) char *msg = CallTraces(iPtr, /*arrayPtr*/ NULL, varPtr, varName, (char *) NULL, TCL_TRACE_WRITES); if (msg != NULL) { - if (leaveErrorMsg) { + if (flags & TCL_LEAVE_ERR_MSG) { VarErrMsg(interp, varName, NULL, "set", msg); } goto cleanup; @@ -1557,7 +1580,7 @@ TclSetIndexedScalar(interp, localIndex, newValuePtr, leaveErrorMsg) * element. If the specified array or element doesn't exist, or there * is a clash in array usage, or an error occurs while executing * variable traces, then NULL is returned and a message will be left in - * the interpreter's result if leaveErrorMsg is 1. Note that the + * the interpreter's result if flags has TCL_LEAVE_ERR_MSG. Note that the * returned object may not be the same one referenced by newValuePtr; * this is because variable traces may modify the variable's value. * @@ -1578,8 +1601,7 @@ TclSetIndexedScalar(interp, localIndex, newValuePtr, leaveErrorMsg) */ Tcl_Obj * -TclSetElementOfIndexedArray(interp, localIndex, elemPtr, newValuePtr, - leaveErrorMsg) +TclSetElementOfIndexedArray(interp, localIndex, elemPtr, newValuePtr, flags) Tcl_Interp *interp; /* Command interpreter in which the array is * to be found. */ int localIndex; /* Index of array variable in procedure's @@ -1587,9 +1609,9 @@ TclSetElementOfIndexedArray(interp, localIndex, elemPtr, newValuePtr, Tcl_Obj *elemPtr; /* Points to an object holding the name of * an element to set in the array. */ Tcl_Obj *newValuePtr; /* New value for variable. */ - int leaveErrorMsg; /* 1 if to leave an error message in - * the interpreter's result on an error. - * Otherwise no error message is left. */ + int flags; /* Various flags that tell how to set value: + * any of TCL_APPEND_VALUE, + * TCL_LIST_ELEMENT or TCL_LEAVE_ERR_MSG. */ { Interp *iPtr = (Interp *) interp; CallFrame *varFramePtr = iPtr->varFramePtr; @@ -1620,7 +1642,7 @@ TclSetElementOfIndexedArray(interp, localIndex, elemPtr, newValuePtr, (unsigned int) varFramePtr); } if ((localIndex < 0) || (localIndex >= localCt)) { - fprintf(stderr, "\nTclSetIndexedScalar: can't set elememt of local %i in frame 0x%x with %i locals\n", + fprintf(stderr, "\nTclSetIndexedScalar: can't set element of local %i in frame 0x%x with %i locals\n", localIndex, (unsigned int) varFramePtr, localCt); panic("TclSetElementOfIndexedArray: bad local index %i in frame 0x%x", localIndex, (unsigned int) varFramePtr); @@ -1637,7 +1659,7 @@ TclSetElementOfIndexedArray(interp, localIndex, elemPtr, newValuePtr, * reference to a variable in an enclosing namespace. Traverse through * any links until we find the referenced variable. */ - + while (TclIsVarLink(arrayPtr)) { arrayPtr = arrayPtr->value.linkPtr; } @@ -1651,7 +1673,7 @@ TclSetElementOfIndexedArray(interp, localIndex, elemPtr, newValuePtr, */ if ((arrayPtr->flags & VAR_IN_HASHTABLE) && (arrayPtr->hPtr == NULL)) { - if (leaveErrorMsg) { + if (flags & TCL_LEAVE_ERR_MSG) { if (TclIsVarArrayElement(arrayPtr)) { VarErrMsg(interp, arrayName, elem, "set", danglingElement); } else { @@ -1672,11 +1694,11 @@ TclSetElementOfIndexedArray(interp, localIndex, elemPtr, newValuePtr, Tcl_InitHashTable(arrayPtr->value.tablePtr, TCL_STRING_KEYS); TclClearVarUndefined(arrayPtr); } else if (!TclIsVarArray(arrayPtr)) { - if (leaveErrorMsg) { + if (flags & TCL_LEAVE_ERR_MSG) { VarErrMsg(interp, arrayName, elem, "set", needArray); } goto errorReturn; - } + } /* * Look up the element. @@ -1700,23 +1722,66 @@ TclSetElementOfIndexedArray(interp, localIndex, elemPtr, newValuePtr, */ if (TclIsVarArray(varPtr)) { - if (leaveErrorMsg) { + if (flags & TCL_LEAVE_ERR_MSG) { VarErrMsg(interp, arrayName, elem, "set", isArray); } goto errorReturn; } /* - * Set the variable's new value and discard the old one. We don't - * append with this "set" procedure so the old value isn't needed. + * Set the variable's new value and discard the old one. */ oldValuePtr = varPtr->value.objPtr; - if (newValuePtr != oldValuePtr) { /* set new value */ + if (flags & TCL_APPEND_VALUE) { + if (TclIsVarUndefined(varPtr) && (oldValuePtr != NULL)) { + Tcl_DecrRefCount(oldValuePtr); /* discard old value */ + varPtr->value.objPtr = NULL; + oldValuePtr = NULL; + } + if (flags & TCL_LIST_ELEMENT) { /* append list element */ + if (oldValuePtr == NULL) { + TclNewObj(oldValuePtr); + varPtr->value.objPtr = oldValuePtr; + Tcl_IncrRefCount(oldValuePtr); /* since var is referenced */ + } else if (Tcl_IsShared(oldValuePtr)) { + varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr); + Tcl_DecrRefCount(oldValuePtr); + oldValuePtr = varPtr->value.objPtr; + Tcl_IncrRefCount(oldValuePtr); /* since var is referenced */ + } + if (Tcl_ListObjAppendElement(interp, oldValuePtr, + newValuePtr) != TCL_OK) { + return NULL; + } + } else { /* append string */ + /* + * We append newValuePtr's bytes but don't change its ref count. + */ + + if (oldValuePtr == NULL) { + varPtr->value.objPtr = newValuePtr; + Tcl_IncrRefCount(newValuePtr); + } else { + if (Tcl_IsShared(oldValuePtr)) { /* append to copy */ + varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr); + TclDecrRefCount(oldValuePtr); + oldValuePtr = varPtr->value.objPtr; + Tcl_IncrRefCount(oldValuePtr); /* since var is ref */ + } + Tcl_AppendObjToObj(oldValuePtr, newValuePtr); + } + } + } else if (newValuePtr != oldValuePtr) { /* set new value */ + /* + * In this case we are replacing the value, so we don't need to + * do more than swap the objects. + */ + varPtr->value.objPtr = newValuePtr; - Tcl_IncrRefCount(newValuePtr); /* var is another ref to obj */ + Tcl_IncrRefCount(newValuePtr); /* var is another ref to obj */ if (oldValuePtr != NULL) { - TclDecrRefCount(oldValuePtr); /* discard old value */ + TclDecrRefCount(oldValuePtr); /* discard old value */ } } TclSetVarScalar(varPtr); @@ -1731,7 +1796,7 @@ TclSetElementOfIndexedArray(interp, localIndex, elemPtr, newValuePtr, char *msg = CallTraces(iPtr, arrayPtr, varPtr, arrayName, elem, TCL_TRACE_WRITES); if (msg != NULL) { - if (leaveErrorMsg) { + if (flags & TCL_LEAVE_ERR_MSG) { VarErrMsg(interp, arrayName, elem, "set", msg); } goto errorReturn; @@ -1894,8 +1959,7 @@ TclIncrIndexedScalar(interp, localIndex, incrAmount) long i; int result; - varValuePtr = TclGetIndexedScalar(interp, localIndex, - /*leaveErrorMsg*/ 1); + varValuePtr = TclGetIndexedScalar(interp, localIndex, TCL_LEAVE_ERR_MSG); if (varValuePtr == NULL) { Tcl_AddObjErrorInfo(interp, "\n (reading value of variable to increment)", -1); @@ -1929,7 +1993,7 @@ TclIncrIndexedScalar(interp, localIndex, incrAmount) */ resultPtr = TclSetIndexedScalar(interp, localIndex, varValuePtr, - /*leaveErrorMsg*/ 1); + TCL_LEAVE_ERR_MSG); if (resultPtr == NULL) { return NULL; } @@ -1982,7 +2046,7 @@ TclIncrElementOfIndexedArray(interp, localIndex, elemPtr, incrAmount) int result; varValuePtr = TclGetElementOfIndexedArray(interp, localIndex, elemPtr, - /*leaveErrorMsg*/ 1); + TCL_LEAVE_ERR_MSG); if (varValuePtr == NULL) { Tcl_AddObjErrorInfo(interp, "\n (reading value of variable to increment)", -1); @@ -2016,8 +2080,7 @@ TclIncrElementOfIndexedArray(interp, localIndex, elemPtr, incrAmount) */ resultPtr = TclSetElementOfIndexedArray(interp, localIndex, elemPtr, - varValuePtr, - /*leaveErrorMsg*/ 1); + varValuePtr, TCL_LEAVE_ERR_MSG); if (resultPtr == NULL) { return NULL; } |