From 90c9c56c211f33d783dfd5e332d3e90bfd6abd84 Mon Sep 17 00:00:00 2001 From: hobbs Date: Thu, 17 May 2001 02:13:02 +0000 Subject: * generic/tclBasic.c: added new CompileProc invocations to basic command initialization. * generic/tclCompCmds.c: added new compile commands for append, lappend, lindex and llength. Refactored set and incr compile commands to use new TclPushVarName function for handling the varname component during compilation (also used by append and lappend). Changed string compile command to compile toplevel code as well (when possible). * generic/tclCompile.c: added new instruction enums * generic/tclCompile.h: added debug info for new instructions * generic/tclExecute.c (TclExecuteByteCode): moved elemPtr to toplevel var (oft-used). Added definitions for new bytecode instructions INST_LIST_INDEX, INST_LIST_LENGTH, INST_APPEND_SCALAR1, INST_APPEND_SCALAR4, INST_APPEND_ARRAY1, INST_APPEND_ARRAY4, INST_APPEND_ARRAY_STK, INST_APPEND_STK, INST_LAPPEND_SCALAR1, INST_LAPPEND_SCALAR4, INST_LAPPEND_ARRAY1, INST_LAPPEND_ARRAY4, INST_LAPPEND_ARRAY_STK, INST_LAPPEND_STK. Refactored repititious code for reuse with INST_LOAD_STK (same as INST_LOAD_SCALAR_STK), INST_STORE_STK (same as INST_STORE_SCALAR_STK). Updated INST_STR_CMP with style of fix of 2001-04-06 Fellows [Bug #219201] as that fix only affected the runtime eval'ed "string" (string compare is normally byte-compiled now). We may want to back these out for speed in the future, noting the problems with \x00 comparisons in the docs. * generic/tclInt.h: declarations for new compile commands. * generic/tclVar.c: change TclGetIndexedScalar, TclGetElementOfIndexedArray, TclSetElementOfIndexedArray and TclSetIndexedScalar to use flags. The Set functions now support TCL_APPEND_ELEMENT and TCL_LIST_ELEMENT as well. * generic/tclInt.decls: * generic/tclIntDecls.h: minor signature changes for above. --- generic/tclBasic.c | 10 +- generic/tclCompCmds.c | 1150 +++++++++++++++++++++++++++++++++---------------- generic/tclCompile.c | 32 +- generic/tclCompile.h | 25 +- generic/tclExecute.c | 778 +++++++++++++++++++++++---------- generic/tclInt.decls | 10 +- generic/tclInt.h | 20 +- generic/tclIntDecls.h | 19 +- generic/tclVar.c | 227 ++++++---- 9 files changed, 1546 insertions(+), 725 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,6 @@ TclCompileIncrCmd(interp, parsePtr, envPtr) } done: - if (gotElemParse) { - Tcl_FreeParse(&elemParse); - } envPtr->maxStackDepth = maxDepth; return code; } @@ -1543,87 +1587,367 @@ TclCompileIncrCmd(interp, parsePtr, envPtr) /* *---------------------------------------------------------------------- * - * TclCompileReturnCmd -- + * TclCompileLappendCmd -- * - * Procedure called to compile the "return" command. + * Procedure called to compile the "lappend" command. * * Results: - * The return value is a standard Tcl result, which is TCL_OK if the - * compilation was successful. If the particular return command is - * too complex for this function (ie, return with any flags like "-code" - * or "-errorinfo"), TCL_OUT_LINE_COMPILE is returned, indicating that - * the command should be compiled "out of line" (eg, not byte compiled). - * If an error occurs then the interpreter's result contains a standard - * error message. + * 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 command. + * elements needed to execute the incr command. * * Side effects: - * Instructions are added to envPtr to execute the "return" command + * Instructions are added to envPtr to execute the "lappend" command * at runtime. * *---------------------------------------------------------------------- */ int -TclCompileReturnCmd(interp, parsePtr, envPtr) +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; - int code; - + 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; } - switch (parsePtr->numWords) { - case 1: { - /* - * Simple case: [return] - * Just push the literal string "". - */ - TclEmitPush(TclRegisterLiteral(envPtr, "", 0, 0), envPtr); - envPtr->maxStackDepth = 1; - break; - } - case 2: { - /* - * More complex cases: - * [return "foo"] - * [return $value] - * [return [otherCmd]] - */ - varTokenPtr = parsePtr->tokenPtr - + (parsePtr->tokenPtr->numComponents + 1); - if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - /* - * [return "foo"] case: the parse token is a simple word, - * so just push it. - */ - TclEmitPush(TclRegisterLiteral(envPtr, varTokenPtr[1].start, - varTokenPtr[1].size, /*onHeap*/ 0), envPtr); - envPtr->maxStackDepth = 1; - } else { - /* - * Parse token is more complex, so compile it; this handles the - * variable reference and nested command cases. If the - * parse token can be byte-compiled, then this instance of - * "return" will be byte-compiled; otherwise it will be - * out line compiled. - */ - code = TclCompileTokens(interp, varTokenPtr+1, - varTokenPtr->numComponents, envPtr); - if (code != TCL_OK) { - return code; - } + 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; +} + +/* + *---------------------------------------------------------------------- + * + * 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. + * + * Results: + * The return value is a standard Tcl result, which is TCL_OK if the + * compilation was successful. If the particular return command is + * too complex for this function (ie, return with any flags like "-code" + * or "-errorinfo"), TCL_OUT_LINE_COMPILE is returned, indicating that + * the command should be compiled "out of line" (eg, not byte compiled). + * 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 command. + * + * Side effects: + * Instructions are added to envPtr to execute the "return" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileReturnCmd(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 we're not in a procedure, don't compile. + */ + + if (envPtr->procPtr == NULL) { + return TCL_OUT_LINE_COMPILE; + } + + switch (parsePtr->numWords) { + case 1: { + /* + * Simple case: [return] + * Just push the literal string "". + */ + TclEmitPush(TclRegisterLiteral(envPtr, "", 0, 0), envPtr); + envPtr->maxStackDepth = 1; + break; + } + case 2: { + /* + * More complex cases: + * [return "foo"] + * [return $value] + * [return [otherCmd]] + */ + varTokenPtr = parsePtr->tokenPtr + + (parsePtr->tokenPtr->numComponents + 1); + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + /* + * [return "foo"] case: the parse token is a simple word, + * so just push it. + */ + TclEmitPush(TclRegisterLiteral(envPtr, varTokenPtr[1].start, + varTokenPtr[1].size, /*onHeap*/ 0), envPtr); + envPtr->maxStackDepth = 1; + } else { + /* + * Parse token is more complex, so compile it; this handles the + * variable reference and nested command cases. If the + * parse token can be byte-compiled, then this instance of + * "return" will be byte-compiled; otherwise it will be + * out line compiled. + */ + code = TclCompileTokens(interp, varTokenPtr+1, + varTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + return code; + } } break; } @@ -1679,202 +2003,42 @@ 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; envPtr->maxStackDepth = 0; numWords = parsePtr->numWords; - if ((numWords != 2) && (numWords != 3)) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "wrong # args: should be \"set varName ?newValue?\"", -1); - return TCL_ERROR; - } - isAssignment = (numWords == 3); - - /* - * 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; - - 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; - } - } - } - } - - 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. - */ + if ((numWords != 2) && (numWords != 3)) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"set varName ?newValue?\"", -1); + return TCL_ERROR; + } + isAssignment = (numWords == 3); - code = TclCompileTokens(interp, varTokenPtr+1, - varTokenPtr->numComponents, envPtr); - if (code != TCL_OK) { - goto done; - } - maxDepth += envPtr->maxStackDepth; + /* + * 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, + (isAssignment ? TCL_CREATE_VAR : 0), + &localIndex, &maxDepth, &simpleVarName, &isScalar); + if (code != TCL_OK) { + goto done; } - + /* * 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; } -- cgit v0.12