summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog17
-rw-r--r--generic/tclCompCmds.c214
-rw-r--r--generic/tclCompile.c44
-rw-r--r--generic/tclCompile.h35
-rw-r--r--generic/tclExecute.c49
-rw-r--r--tests/dict.test18
6 files changed, 304 insertions, 73 deletions
diff --git a/ChangeLog b/ChangeLog
index a1ff2e7..20836aa 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,18 @@
+2007-03-02 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
+
+ * generic/tclCompile.c (TclPrintInstruction): Added a scheme to allow
+ * generic/tclCompile.h (AuxDataPrintProc): aux-data to be printed
+ * generic/tclCompCmds.c (Print*Info): out for debugging. For
+ this to work, immediate operands referring to aux-data must be
+ identified as such in the instruction descriptor table using
+ OPERAND_AUX4 (all are always 4 bytes).
+
+ * generic/tclExecute.c (TclExecuteByteCode): Rewrote the compiled
+ * generic/tclCompCmds.c (TclCompileDictCmd): [dict update] so that it
+ * generic/tclCompile.h (DictUpdateInfo): stores critical
+ * tests/dict.test (dict-21.{14,15}): non-varying data in an
+ aux-data value instead of a (shimmerable) literal.
+
2007-03-01 Don Porter <dgp@users.sourceforge.net>
* generic/tclCmdIL.c (Tcl_LinsertObjCmd): Code simplifications
@@ -15,7 +30,7 @@
* generic/tclCmdIL.c (Tcl_LassignObjCmd): Rewrite to make an
efficient private copy of the list argument, so we can operate on the
- list elements directly with no fear of shimmering effects. Replaces
+ list elements directly with no fear of shimmering effects. Replaces
defensive coding schemes that are otherwise required.
* generic/tclCmdAH.c (Tcl_ForeachObjCmd): Rewrite to make
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index c0721fa..8ceb0b9 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.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: tclCompCmds.c,v 1.101 2007/03/01 10:07:12 dkf Exp $
+ * RCS: @(#) $Id: tclCompCmds.c,v 1.102 2007/03/02 10:32:11 dkf Exp $
*/
#include "tclInt.h"
@@ -128,10 +128,18 @@
* Prototypes for procedures defined later in this file:
*/
+static ClientData DupDictUpdateInfo(ClientData clientData);
+static void FreeDictUpdateInfo(ClientData clientData);
+static void PrintDictUpdateInfo(ClientData clientData,
+ ByteCode *codePtr, unsigned int pcOffset);
static ClientData DupForeachInfo(ClientData clientData);
static void FreeForeachInfo(ClientData clientData);
+static void PrintForeachInfo(ClientData clientData,
+ ByteCode *codePtr, unsigned int pcOffset);
static ClientData DupJumptableInfo(ClientData clientData);
static void FreeJumptableInfo(ClientData clientData);
+static void PrintJumptableInfo(ClientData clientData,
+ ByteCode *codePtr, unsigned int pcOffset);
static int PushVarName(Tcl_Interp *interp,
Tcl_Token *varTokenPtr, CompileEnv *envPtr,
int flags, int *localIndexPtr,
@@ -163,13 +171,22 @@ static int CompileUnaryOpCmd(Tcl_Interp *interp,
AuxDataType tclForeachInfoType = {
"ForeachInfo", /* name */
DupForeachInfo, /* dupProc */
- FreeForeachInfo /* freeProc */
+ FreeForeachInfo, /* freeProc */
+ PrintForeachInfo /* printProc */
};
AuxDataType tclJumptableInfoType = {
"JumptableInfo", /* name */
DupJumptableInfo, /* dupProc */
- FreeJumptableInfo /* freeProc */
+ FreeJumptableInfo, /* freeProc */
+ PrintJumptableInfo /* printProc */
+};
+
+AuxDataType tclDictUpdateInfoType = {
+ "DictUpdateInfo", /* name */
+ DupDictUpdateInfo, /* dupProc */
+ FreeDictUpdateInfo, /* freeProc */
+ PrintDictUpdateInfo /* printProc */
};
/*
@@ -890,9 +907,9 @@ TclCompileDictCmd(
return TCL_OK;
} else if (size==6 && strncmp(cmd, "update", 6)==0) {
const char *name;
- int nameChars, dictIndex, keyTmpIndex, numVars, range;
+ int nameChars, dictIndex, keyTmpIndex, numVars, range, infoIndex;
Tcl_Token **keyTokenPtrs, *dictVarTokenPtr, *bodyTokenPtr;
- Tcl_DString localVarsLiteral;
+ DictUpdateInfo *duiPtr;
/*
* Parse the command. Expect the following:
@@ -915,35 +932,32 @@ TclCompileDictCmd(
dictIndex = TclFindCompiledLocal(name, nameChars, 1, VAR_SCALAR,
procPtr);
- Tcl_DStringInit(&localVarsLiteral);
+ duiPtr = (DictUpdateInfo *)
+ ckalloc(sizeof(DictUpdateInfo) + sizeof(int) * (numVars - 1));
+ duiPtr->length = numVars;
keyTokenPtrs = (Tcl_Token **) ckalloc(sizeof(Tcl_Token *) * numVars);
tokenPtr = TokenAfter(dictVarTokenPtr);
for (i=0 ; i<numVars ; i++) {
keyTokenPtrs[i] = tokenPtr;
tokenPtr = TokenAfter(tokenPtr);
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- Tcl_DStringFree(&localVarsLiteral);
+ ckfree((char *) duiPtr);
ckfree((char *) keyTokenPtrs);
return TCL_ERROR;
}
name = tokenPtr[1].start;
nameChars = tokenPtr[1].size;
if (!TclIsLocalScalar(name, nameChars)) {
- Tcl_DStringFree(&localVarsLiteral);
+ ckfree((char *) duiPtr);
ckfree((char *) keyTokenPtrs);
return TCL_ERROR;
- } else {
- int localVar = TclFindCompiledLocal(name, nameChars, 1,
- VAR_SCALAR, procPtr);
- char buf[12];
-
- sprintf(buf, "%d", localVar);
- Tcl_DStringAppendElement(&localVarsLiteral, buf);
}
+ duiPtr->varIndices[i] = TclFindCompiledLocal(name, nameChars, 1,
+ VAR_SCALAR, procPtr);
tokenPtr = TokenAfter(tokenPtr);
}
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- Tcl_DStringFree(&localVarsLiteral);
+ ckfree((char *) duiPtr);
ckfree((char *) keyTokenPtrs);
return TCL_ERROR;
}
@@ -951,14 +965,21 @@ TclCompileDictCmd(
keyTmpIndex = TclFindCompiledLocal(NULL, 0, 1, VAR_SCALAR, procPtr);
+ /*
+ * The list of variables to bind is stored in auxiliary data so that
+ * it can't be snagged by literal sharing and forced to shimmer
+ * dangerously.
+ */
+
+ infoIndex = TclCreateAuxData(duiPtr, &tclDictUpdateInfoType, envPtr);
+
for (i=0 ; i<numVars ; i++) {
CompileWord(envPtr, keyTokenPtrs[i], interp, i);
}
TclEmitInstInt4( INST_LIST, numVars, envPtr);
TclEmitInstInt4( INST_STORE_SCALAR4, keyTmpIndex, envPtr);
- PushLiteral(envPtr, Tcl_DStringValue(&localVarsLiteral),
- Tcl_DStringLength(&localVarsLiteral));
TclEmitInstInt4( INST_DICT_UPDATE_START, dictIndex, envPtr);
+ TclEmitInt4( infoIndex, envPtr);
range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr);
@@ -974,19 +995,21 @@ TclCompileDictCmd(
envPtr->exceptDepth--;
TclEmitInstInt4( INST_LOAD_SCALAR4, keyTmpIndex, envPtr);
- PushLiteral(envPtr, Tcl_DStringValue(&localVarsLiteral),
- Tcl_DStringLength(&localVarsLiteral));
/*
- * Any literal would do, but this one is handy...
+ * Now remove the contents of the temporary key variable so that the
+ * reference counts of the keys end up correct. Unsetting the variable
+ * would be better, but there's no opcode for that.
*/
+ PushLiteral(envPtr, "", 0);
TclEmitInstInt4( INST_STORE_SCALAR4, keyTmpIndex, envPtr);
- TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr);
+ TclEmitInt4( infoIndex, envPtr);
TclEmitOpcode( INST_RETURN_STK, envPtr);
- Tcl_DStringFree(&localVarsLiteral);
ckfree((char *) keyTokenPtrs);
return TCL_OK;
} else if (size==6 && strncmp(cmd, "append", 6) == 0) {
@@ -1060,6 +1083,65 @@ TclCompileDictCmd(
/*
*----------------------------------------------------------------------
*
+ * DupDictUpdateInfo, FreeDictUpdateInfo --
+ *
+ * Functions to duplicate, release and print the aux data created for use
+ * with the INST_DICT_UPDATE_START and INST_DICT_UPDATE_END instructions.
+ *
+ * Results:
+ * DupDictUpdateInfo: a copy of the auxiliary data
+ * FreeDictUpdateInfo: none
+ * PrintDictUpdateInfo: none
+ *
+ * Side effects:
+ * DupDictUpdateInfo: allocates memory
+ * FreeDictUpdateInfo: releases memory
+ * PrintDictUpdateInfo: none
+ *
+ *----------------------------------------------------------------------
+ */
+
+static ClientData
+DupDictUpdateInfo(
+ ClientData clientData)
+{
+ DictUpdateInfo *dui1Ptr, *dui2Ptr;
+ unsigned len;
+
+ dui1Ptr = clientData;
+ len = sizeof(DictUpdateInfo) + sizeof(int) * (dui1Ptr->length - 1);
+ dui2Ptr = (DictUpdateInfo *) ckalloc(len);
+ memcpy(dui2Ptr, dui1Ptr, len);
+ return dui2Ptr;
+}
+
+static void
+FreeDictUpdateInfo(
+ ClientData clientData)
+{
+ ckfree(clientData);
+}
+
+static void
+PrintDictUpdateInfo(
+ ClientData clientData,
+ ByteCode *codePtr,
+ unsigned int pcOffset)
+{
+ DictUpdateInfo *duiPtr = clientData;
+ int i;
+
+ for (i=0 ; i<duiPtr->length ; i++) {
+ if (i) {
+ fprintf(stdout, ", ");
+ }
+ fprintf(stdout, "%%v%u", duiPtr->varIndices[i]);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclCompileExprCmd --
*
* Procedure called to compile the "expr" command.
@@ -1683,6 +1765,59 @@ FreeForeachInfo(
/*
*----------------------------------------------------------------------
*
+ * PrintForeachInfo --
+ *
+ * Function to write a human-readable representation of a ForeachInfo
+ * structure to stdout for debugging.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+PrintForeachInfo(
+ ClientData clientData,
+ ByteCode *codePtr,
+ unsigned int pcOffset)
+{
+ register ForeachInfo *infoPtr = clientData;
+ register ForeachVarList *varsPtr;
+ int i, j;
+
+ fprintf(stdout, "data=[");
+
+ for (i=0 ; i<infoPtr->numLists ; i++) {
+ if (i) {
+ fprintf(stdout, ", ");
+ }
+ fprintf(stdout, "%%v%u", (unsigned) (infoPtr->firstValueTemp + i));
+ }
+ fprintf(stdout, "], loop=%%v%u", (unsigned) infoPtr->loopCtTemp);
+ for (i=0 ; i<infoPtr->numLists ; i++) {
+ if (i) {
+ fprintf(stdout, ",");
+ }
+ fprintf(stdout, "\n\t\t it%%v%u\t[",
+ (unsigned) (infoPtr->firstValueTemp + i));
+ varsPtr = infoPtr->varLists[i];
+ for (j=0 ; j<varsPtr->numVars ; j++) {
+ if (j) {
+ fprintf(stdout, ", ");
+ }
+ fprintf(stdout, "%%v%u", (unsigned) varsPtr->varIndexes[j]);
+ }
+ fprintf(stdout, "]");
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclCompileIfCmd --
*
* Procedure called to compile the "if" command.
@@ -4097,16 +4232,18 @@ TclCompileSwitchCmd(
*
* DupJumptableInfo, FreeJumptableInfo --
*
- * Functions to duplicate and release a jump-table created for use with
- * the INST_JUMP_TABLE instruction.
+ * Functions to duplicate, release and print a jump-table created for use
+ * with the INST_JUMP_TABLE instruction.
*
* Results:
* DupJumptableInfo: a copy of the jump-table
* FreeJumptableInfo: none
+ * PrintJumptableInfo: none
*
* Side effects:
* DupJumptableInfo: allocates memory
* FreeJumptableInfo: releases memory
+ * PrintJumptableInfo: none
*
*----------------------------------------------------------------------
*/
@@ -4141,6 +4278,33 @@ FreeJumptableInfo(
Tcl_DeleteHashTable(&jtPtr->hashTable);
ckfree((char *) jtPtr);
}
+
+static void
+PrintJumptableInfo(
+ ClientData clientData,
+ ByteCode *codePtr,
+ unsigned int pcOffset)
+{
+ register JumptableInfo *jtPtr = clientData;
+ Tcl_HashEntry *hPtr;
+ Tcl_HashSearch search;
+ const char *keyPtr;
+ int offset, i = 0;
+
+ hPtr = Tcl_FirstHashEntry(&jtPtr->hashTable, &search);
+ for (; hPtr ; hPtr = Tcl_NextHashEntry(&search)) {
+ keyPtr = Tcl_GetHashKey(&jtPtr->hashTable, hPtr);
+ offset = (int) Tcl_GetHashValue(hPtr);
+
+ if (i++) {
+ fprintf(stdout, ", ");
+ if (i%4==0) {
+ fprintf(stdout, "\n\t\t");
+ }
+ }
+ fprintf(stdout, "\"%s\"->pc %d", keyPtr, pcOffset + offset);
+ }
+}
/*
*----------------------------------------------------------------------
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 8509b60..02e23c7 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -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: tclCompile.c,v 1.107 2007/02/20 23:24:02 nijtmans Exp $
+ * RCS: @(#) $Id: tclCompile.c,v 1.108 2007/03/02 10:32:12 dkf Exp $
*/
#include "tclInt.h"
@@ -196,10 +196,10 @@ InstructionDesc tclInstructionTable[] = {
/* Skip to next iteration of closest enclosing loop; if none, return
* TCL_CONTINUE code. */
- {"foreach_start4", 5, 0, 1, {OPERAND_UINT4}},
+ {"foreach_start4", 5, 0, 1, {OPERAND_AUX4}},
/* Initialize execution of a foreach loop. Operand is aux data index
* of the ForeachInfo structure for the foreach command. */
- {"foreach_step4", 5, +1, 1, {OPERAND_UINT4}},
+ {"foreach_step4", 5, +1, 1, {OPERAND_AUX4}},
/* "Step" or begin next iteration of foreach loop. Push 0 if to
* terminate loop, else push 1. */
@@ -350,19 +350,21 @@ InstructionDesc tclInstructionTable[] = {
* Stack: ... => ... value key doneBool */
{"dictDone", 5, 0, 1, {OPERAND_LVT4}},
/* Terminate the iterator in op4's local scalar. */
- {"dictUpdateStart", 5, -2, 1, {OPERAND_LVT4}},
- /* Create the variables to mirror the state of the dictionary in the
- * variable referred to by the immediate argument.
- * Stack: ... keyList LVTindexList => ...
- * Note that the list of LVT indices is assumed to be the same length
- * as the keyList, and the indices should be only ever generated by the
- * compiler. */
- {"dictUpdateEnd", 5, -2, 1, {OPERAND_LVT4}},
- /* Reflect the state of local variables back to the state of the
- * dictionary in the variable referred to by the immediate argument.
- * Stack: ... keyList LVTindexList => ...
- * Same notes as in "dictUpdateStart" apply here. */
- {"jumpTable", 5, -1, 1, {OPERAND_UINT4}},
+ {"dictUpdateStart", 5, -1, 2, {OPERAND_LVT4, OPERAND_AUX4}},
+ /* Create the variables (described in the aux data referred to by the
+ * second immediate argument) to mirror the state of the dictionary in
+ * the variable referred to by the first immediate argument. The list
+ * of keys (popped from the stack) must be the same length as the list
+ * of variables.
+ * Stack: ... keyList => ... */
+ {"dictUpdateEnd", 5, -1, 1, {OPERAND_LVT4, OPERAND_AUX4}},
+ /* Reflect the state of local variables (described in the aux data
+ * referred to by the second immediate argument) back to the state of
+ * the dictionary in the variable referred to by the first immediate
+ * argument. The list of keys (popped from the stack) must be the same
+ * length as the list of variables.
+ * Stack: ... keyList => ... */
+ {"jumpTable", 5, -1, 1, {OPERAND_AUX4}},
/* Jump according to the jump-table (in AuxData as indicated by the
* operand) and the argument popped from the list. Always executes the
* next instruction if no match against the table's entries was found.
@@ -3641,6 +3643,7 @@ TclPrintInstruction(
* and immediates. */
char *suffixSrc = NULL;
Tcl_Obj *suffixObj = NULL;
+ AuxData *auxPtr = NULL;
suffixBuffer[0] = '\0';
fprintf(stdout, "(%u) %s ", pcOffset, instDesc->name);
@@ -3669,6 +3672,7 @@ TclPrintInstruction(
}
fprintf(stdout, "%u ", (unsigned int) opnd);
break;
+ case OPERAND_AUX4:
case OPERAND_UINT4:
opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4;
if (opCode == INST_PUSH4) {
@@ -3677,6 +3681,9 @@ TclPrintInstruction(
sprintf(suffixBuffer, "next cmd at pc %u", pcOffset+opnd);
}
fprintf(stdout, "%u ", (unsigned int) opnd);
+ if (instDesc->opTypes[i] == OPERAND_AUX4) {
+ auxPtr = &codePtr->auxDataArrayPtr[opnd];
+ }
break;
case OPERAND_IDX4:
opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4;
@@ -3728,6 +3735,11 @@ TclPrintInstruction(
}
}
fprintf(stdout, "\n");
+ if (auxPtr && auxPtr->type->printProc) {
+ fprintf(stdout, "\t\t[");
+ auxPtr->type->printProc(auxPtr->clientData, codePtr, pcOffset);
+ fprintf(stdout, "]\n");
+ }
return numBytes;
}
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index cba0888..b5ad0ba 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -8,7 +8,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.68 2007/01/19 14:06:10 dkf Exp $
+ * RCS: @(#) $Id: tclCompile.h,v 1.69 2007/03/02 10:32:12 dkf Exp $
*/
#ifndef _TCLCOMPILATION
@@ -16,6 +16,8 @@
#include "tclInt.h"
+struct ByteCode; /* Forward declaration. */
+
/*
*------------------------------------------------------------------------
* Variables related to compilation. These are used in tclCompile.c,
@@ -157,6 +159,8 @@ typedef struct ExtCmdLoc {
typedef ClientData (AuxDataDupProc) (ClientData clientData);
typedef void (AuxDataFreeProc) (ClientData clientData);
+typedef void (AuxDataPrintProc)(ClientData clientData,
+ struct ByteCode *codePtr, unsigned int pcOffset);
/*
* We define a separate AuxDataType struct to hold type-related information
@@ -177,6 +181,9 @@ typedef struct AuxDataType {
AuxDataFreeProc *freeProc; /* Callback procedure to invoke when the aux
* data is freed. NULL means no proc need be
* called. */
+ AuxDataPrintProc *printProc;/* Callback function to invoke when printing
+ * the aux data as part of debugging. NULL
+ * means that the data can't be printed. */
} AuxDataType;
/*
@@ -281,8 +288,8 @@ typedef struct CompileEnv {
AuxData staticAuxDataArraySpace[COMPILEENV_INIT_AUX_DATA_SIZE];
/* Initial storage for aux data array. */
/* TIP #280 */
- ExtCmdLoc *extCmdMapPtr; /* Extended command location information
- * for 'info frame'. */
+ ExtCmdLoc *extCmdMapPtr; /* Extended command location information for
+ * 'info frame'. */
int line; /* First line of the script, based on the
* invoking context, then the line of the
* command currently compiled. */
@@ -631,8 +638,10 @@ typedef enum InstOperandType {
* integer, but displayed differently.) */
OPERAND_LVT1, /* One byte unsigned index into the local
* variable table. */
- OPERAND_LVT4 /* Four byte unsigned index into the local
+ OPERAND_LVT4, /* Four byte unsigned index into the local
* variable table. */
+ OPERAND_AUX4, /* Four byte unsigned index into the aux data
+ * table. */
} InstOperandType;
typedef struct InstructionDesc {
@@ -754,6 +763,24 @@ typedef struct JumptableInfo {
MODULE_SCOPE AuxDataType tclJumptableInfoType;
/*
+ * Structure used to hold information about a [dict update] command that is
+ * needed during program execution. These structures are stored in CompileEnv
+ * and ByteCode structures as auxiliary data.
+ */
+
+typedef struct {
+ int length; /* Size of array */
+ int varIndices[1]; /* Array of variable indices to manage when
+ * processing the start and end of a [dict
+ * update]. There is really more than one
+ * entry, and the structure is allocated to
+ * take account of this. MUST BE LAST FIELD IN
+ * STRUCTURE. */
+} DictUpdateInfo;
+
+MODULE_SCOPE AuxDataType tclDictUpdateInfoType;
+
+/*
* ClientData type used by the math operator commands.
*/
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 94207b3..c64f171 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.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: tclExecute.c,v 1.259 2007/02/20 23:24:03 nijtmans Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.260 2007/03/02 10:32:12 dkf Exp $
*/
#include "tclInt.h"
@@ -5786,14 +5786,17 @@ TclExecuteByteCode(
}
{
- int opnd, i, length, length2, allocdict;
- Tcl_Obj **keyPtrPtr, **varIdxPtrPtr, *dictPtr;
+ int opnd, opnd2, i, length, allocdict;
+ Tcl_Obj **keyPtrPtr, *dictPtr;
+ DictUpdateInfo *duiPtr;
Var *varPtr;
char *part1;
case INST_DICT_UPDATE_START:
opnd = TclGetUInt4AtPtr(pc+1);
+ opnd2 = TclGetUInt4AtPtr(pc+5);
varPtr = &(compiledLocals[opnd]);
+ duiPtr = codePtr->auxDataArrayPtr[opnd2].clientData;
part1 = varPtr->name;
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
@@ -5810,25 +5813,21 @@ TclExecuteByteCode(
goto dictUpdateStartFailed;
}
}
- if (Tcl_ListObjGetElements(interp, *(tosPtr - 1), &length,
- &keyPtrPtr) != TCL_OK ||
- Tcl_ListObjGetElements(interp, *tosPtr, &length2,
- &varIdxPtrPtr) != TCL_OK) {
+ if (Tcl_ListObjGetElements(interp, *tosPtr, &length,
+ &keyPtrPtr) != TCL_OK) {
goto dictUpdateStartFailed;
}
- if (length != length2) {
+ if (length != duiPtr->length) {
Tcl_Panic("dictUpdateStart argument length mismatch");
}
for (i=0 ; i<length ; i++) {
Tcl_Obj *valPtr;
- int varIdx;
if (Tcl_DictObjGet(interp, dictPtr, keyPtrPtr[i],
&valPtr) != TCL_OK) {
goto dictUpdateStartFailed;
}
- Tcl_GetIntFromObj(NULL, varIdxPtrPtr[i], &varIdx);
- varPtr = &(compiledLocals[varIdx]);
+ varPtr = &(compiledLocals[duiPtr->varIndices[i]]);
part1 = varPtr->name;
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
@@ -5840,17 +5839,19 @@ TclExecuteByteCode(
valPtr, TCL_LEAVE_ERR_MSG) == NULL) {
CACHE_STACK_INFO();
dictUpdateStartFailed:
- cleanup = 2;
+ cleanup = 1;
result = TCL_ERROR;
goto checkForCatch;
}
CACHE_STACK_INFO();
}
- NEXT_INST_F(5, 2, 0);
+ NEXT_INST_F(9, 1, 0);
case INST_DICT_UPDATE_END:
opnd = TclGetUInt4AtPtr(pc+1);
+ opnd2 = TclGetUInt4AtPtr(pc+5);
varPtr = &(compiledLocals[opnd]);
+ duiPtr = codePtr->auxDataArrayPtr[opnd2].clientData;
part1 = varPtr->name;
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
@@ -5864,14 +5865,12 @@ TclExecuteByteCode(
CACHE_STACK_INFO();
}
if (dictPtr == NULL) {
- NEXT_INST_F(5, 2, 0);
- }
- if (Tcl_DictObjSize(interp, dictPtr, &length) != TCL_OK ||
- Tcl_ListObjGetElements(interp, *(tosPtr - 1), &length,
- &keyPtrPtr) != TCL_OK ||
- Tcl_ListObjGetElements(interp, *tosPtr, &length2,
- &varIdxPtrPtr) != TCL_OK) {
- cleanup = 2;
+ NEXT_INST_F(9, 1, 0);
+ }
+ if (Tcl_DictObjSize(interp, dictPtr, &length) != TCL_OK
+ || Tcl_ListObjGetElements(interp, *tosPtr, &length,
+ &keyPtrPtr) != TCL_OK) {
+ cleanup = 1;
result = TCL_ERROR;
goto checkForCatch;
}
@@ -5881,12 +5880,10 @@ TclExecuteByteCode(
}
for (i=0 ; i<length ; i++) {
Tcl_Obj *valPtr;
- int varIdx;
Var *var2Ptr;
char *part1a;
- Tcl_GetIntFromObj(NULL, varIdxPtrPtr[i], &varIdx);
- var2Ptr = &(compiledLocals[varIdx]);
+ var2Ptr = &(compiledLocals[duiPtr->varIndices[i]]);
part1a = var2Ptr->name;
while (TclIsVarLink(var2Ptr)) {
var2Ptr = var2Ptr->value.linkPtr;
@@ -5922,7 +5919,7 @@ TclExecuteByteCode(
goto checkForCatch;
}
}
- NEXT_INST_F(5, 2, 0);
+ NEXT_INST_F(9, 1, 0);
}
default:
@@ -6302,7 +6299,7 @@ ValidatePcAndStackTop(
if (checkStack &&
((stackTop < stackLowerBound) || (stackTop > stackUpperBound))) {
int numChars;
- char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars);
+ const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars);
fprintf(stderr, "\nBad stack top %d at pc %u in TclExecuteByteCode (min %i, max %i)",
stackTop, relativePc, stackLowerBound, stackUpperBound);
diff --git a/tests/dict.test b/tests/dict.test
index cf9fc1f..c6e8987 100644
--- a/tests/dict.test
+++ b/tests/dict.test
@@ -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: dict.test,v 1.19 2006/08/09 13:51:02 dkf Exp $
+# RCS: @(#) $Id: dict.test,v 1.20 2007/03/02 10:32:13 dkf Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
@@ -1042,6 +1042,22 @@ test dict-21.13 {dict update command: compilation} {
}
getOrder [dicttest {a 1 c 2}] b c
} {b 1 c 2 2}
+test dict-21.14 {dict update command: compilation} {
+ proc dicttest x {
+ set indices {2 3}
+ trace add variable aa write "string length \$indices ;#"
+ dict update x k aa l bb {}
+ }
+ dicttest {k 1 l 2}
+} {}
+test dict-21.15 {dict update command: compilation} {
+ proc dicttest x {
+ set indices {2 3}
+ trace add variable aa read "string length \$indices ;#"
+ dict update x k aa l bb {}
+ }
+ dicttest {k 1 l 2}
+} {}
test dict-22.1 {dict with command} -body {
dict with