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