summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog9
-rw-r--r--generic/tclBasic.c4
-rw-r--r--generic/tclCompCmds.c642
-rw-r--r--generic/tclCompile.c63
-rw-r--r--generic/tclCompile.h23
-rw-r--r--generic/tclDictObj.c55
-rw-r--r--generic/tclExecute.c529
-rw-r--r--generic/tclInt.h32
-rw-r--r--tests/dict.test37
9 files changed, 1281 insertions, 113 deletions
diff --git a/ChangeLog b/ChangeLog
index 452433f..3d045ce 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,12 @@
+2005-07-21 Donal K. Fellows <dkf@users.sf.net>
+
+ * generic/tclCompCmds.c (TclCompileDictCmd): First run at a compiler
+ * generic/tclExecute.c (TclExecuteByteCode): for dictionaries.
+ Also added an instruction to support 'finally'-like clauses, exposed
+ more of the dict guts to the rest of the core, and defined a few
+ tests to exercise more obscure parts of the compiler's operation that
+ were bugs during development.
+
2005-07-21 Kevin B. Kenny <kennykb@acm.org>
* library/ldAout.tcl (***REMOVED***): Removed support for ancient
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 0d9cdec..14228c8 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -13,7 +13,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.162 2005/06/21 18:33:02 dgp Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.163 2005/07/21 21:48:58 dkf Exp $
*/
#include "tclInt.h"
@@ -154,7 +154,7 @@ static CmdInfo builtInCmds[] = {
{"catch", Tcl_CatchObjCmd, TclCompileCatchCmd, 1},
{"concat", Tcl_ConcatObjCmd, (CompileProc *) NULL, 1},
{"continue", Tcl_ContinueObjCmd, TclCompileContinueCmd, 1},
- {"dict", Tcl_DictObjCmd, (CompileProc *) NULL, 1},
+ {"dict", Tcl_DictObjCmd, TclCompileDictCmd, 1},
{"encoding", Tcl_EncodingObjCmd, (CompileProc *) NULL, 0},
{"error", Tcl_ErrorObjCmd, (CompileProc *) NULL, 1},
{"eval", Tcl_EvalObjCmd, (CompileProc *) NULL, 1},
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 8e1b195..4f962ca 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -7,12 +7,12 @@
* Copyright (c) 1997-1998 Sun Microsystems, Inc.
* Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
* Copyright (c) 2002 ActiveState Corporation.
- * Copyright (c) 2004 Donal K. Fellows.
+ * Copyright (c) 2004-2005 by Donal K. Fellows.
*
* 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.76 2005/07/13 20:33:11 dgp Exp $
+ * RCS: @(#) $Id: tclCompCmds.c,v 1.77 2005/07/21 21:49:00 dkf Exp $
*/
#include "tclInt.h"
@@ -79,6 +79,26 @@
((envPtr)->codeNext - (envPtr)->codeStart)
/*
+ * static int DeclareExceptionRange(CompileEnv *envPtr, int type);
+ * static int ExceptionRangeStarts(CompileEnv *envPtr, int index);
+ * static void ExceptionRangeEnds(CompileEnv *envPtr, int index);
+ * static void ExceptionRangeTarget(CompileEnv *envPtr, int index, LABEL);
+ */
+
+#define DeclareExceptionRange(envPtr, type) \
+ (((envPtr)->exceptDepth++), \
+ ((envPtr)->maxExceptDepth = \
+ TclMax((envPtr)->exceptDepth, (envPtr)->maxExceptDepth)), \
+ (TclCreateExceptRange((type), (envPtr))))
+#define ExceptionRangeStarts(envPtr, index) \
+ ((envPtr)->exceptArrayPtr[(index)].codeOffset = CurrentOffset(envPtr))
+#define ExceptionRangeEnds(envPtr, index) \
+ ((envPtr)->exceptArrayPtr[(index)].numCodeBytes = \
+ CurrentOffset(envPtr) - (envPtr)->exceptArrayPtr[(index)].codeOffset)
+#define ExceptionRangeTarget(envPtr, index, targetType) \
+ ((envPtr)->exceptArrayPtr[(index)].targetType = CurrentOffset(envPtr))
+
+/*
* Prototypes for procedures defined later in this file:
*/
@@ -266,7 +286,7 @@ TclCompileCatchCmd(interp, parsePtr, envPtr)
JumpFixup jumpFixup;
Tcl_Token *cmdTokenPtr, *resultNameTokenPtr, *optsNameTokenPtr;
CONST char *name;
- int resultIndex, optsIndex, nameChars, range, startOffset;
+ int resultIndex, optsIndex, nameChars, range;
int savedStackDepth = envPtr->currStackDepth;
/*
@@ -330,10 +350,7 @@ TclCompileCatchCmd(interp, parsePtr, envPtr)
* start of the catch body: the subcommand it controls.
*/
- envPtr->exceptDepth++;
- envPtr->maxExceptDepth =
- TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth);
- range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
+ range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
TclEmitInstInt4(INST_BEGIN_CATCH4, range, envPtr);
/*
@@ -346,17 +363,16 @@ TclCompileCatchCmd(interp, parsePtr, envPtr)
*/
if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
- startOffset = CurrentOffset(envPtr);
+ ExceptionRangeStarts(envPtr, range);
CompileBody(envPtr, cmdTokenPtr, interp);
+ ExceptionRangeEnds(envPtr, range);
} else {
TclCompileTokens(interp, cmdTokenPtr+1,
cmdTokenPtr->numComponents, envPtr);
- startOffset = CurrentOffset(envPtr);
+ ExceptionRangeStarts(envPtr, range);
TclEmitOpcode(INST_EVAL_STK, envPtr);
+ ExceptionRangeEnds(envPtr, range);
}
- envPtr->exceptArrayPtr[range].codeOffset = startOffset;
- envPtr->exceptArrayPtr[range].numCodeBytes =
- CurrentOffset(envPtr) - startOffset;
/*
* The "no errors" epilogue code: store the body's result into the
@@ -401,7 +417,7 @@ TclCompileCatchCmd(interp, parsePtr, envPtr)
*/
envPtr->currStackDepth = savedStackDepth;
- envPtr->exceptArrayPtr[range].catchOffset = CurrentOffset(envPtr);
+ ExceptionRangeTarget(envPtr, range, catchOffset);
if (resultIndex != -1) {
if (optsIndex != -1) {
TclEmitOpcode(INST_PUSH_RETURN_OPTIONS, envPtr);
@@ -484,6 +500,515 @@ TclCompileContinueCmd(interp, parsePtr, envPtr)
/*
*----------------------------------------------------------------------
*
+ * TclCompileDictCmd --
+ *
+ * Procedure called to compile the "dict" command.
+ *
+ * Results:
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "dict" command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileDictCmd(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 *tokenPtr;
+ int numWords, size, i;
+ const char *cmd;
+ Proc *procPtr = envPtr->procPtr;
+
+ /*
+ * There must be at least one argument after the command.
+ */
+
+ if (parsePtr->numWords < 2) {
+ return TCL_ERROR;
+ }
+
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ numWords = parsePtr->numWords-2;
+ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * The following commands are in fairly common use and are possibly worth
+ * bytecoding:
+ * dict append
+ * dict create [*]
+ * dict exists [*]
+ * dict for
+ * dict get [*]
+ * dict incr
+ * dict keys [*]
+ * dict lappend
+ * dict set
+ * dict unset
+ * In practice, those that are pure-value operators (marked with [*]) can
+ * probably be left alone (except perhaps [dict get] which is very very
+ * common) and [dict update] should be considered instead (really big
+ * win!)
+ */
+
+ size = tokenPtr[1].size;
+ cmd = tokenPtr[1].start;
+ if (size==3 && strncmp(cmd, "set", 3)==0) {
+ Tcl_Token *varTokenPtr;
+ int dictVarIndex, nameChars;
+ const char *name;
+
+ if (numWords < 3 || procPtr == NULL) {
+ return TCL_ERROR;
+ }
+ varTokenPtr = TokenAfter(tokenPtr);
+ tokenPtr = TokenAfter(varTokenPtr);
+ if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ return TCL_ERROR;
+ }
+ name = varTokenPtr[1].start;
+ nameChars = varTokenPtr[1].size;
+ if (!TclIsLocalScalar(name, nameChars)) {
+ return TCL_ERROR;
+ }
+ dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, VAR_SCALAR,
+ procPtr);
+ for (i=1 ; i<numWords ; i++) {
+ CompileWord(envPtr, tokenPtr, interp);
+ tokenPtr = TokenAfter(tokenPtr);
+ }
+ TclEmitInstInt4( INST_DICT_SET, numWords-2, envPtr);
+ TclEmitInt4( dictVarIndex, envPtr);
+ return TCL_OK;
+ } else if (size==4 && strncmp(cmd, "incr", 4)==0) {
+ Tcl_Token *varTokenPtr, *keyTokenPtr, *incrTokenPtr = NULL;
+ int dictVarIndex, nameChars, incrAmount = 1;
+ const char *name;
+
+ if (numWords < 2 || numWords > 3 || procPtr == NULL) {
+ return TCL_ERROR;
+ }
+ varTokenPtr = TokenAfter(tokenPtr);
+ keyTokenPtr = TokenAfter(varTokenPtr);
+ if (numWords == 3) {
+ const char *word;
+ int numBytes, code;
+ Tcl_Obj *intObj;
+
+ incrTokenPtr = TokenAfter(keyTokenPtr);
+ if (incrTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ return TCL_ERROR;
+ }
+ word = incrTokenPtr[1].start;
+ numBytes = incrTokenPtr[1].size;
+
+ /*
+ * Note there is a danger that modifying the string could have
+ * undesirable side effects. In this case, TclLooksLikeInt has no
+ * dependencies on shared strings so we should be safe.
+ */
+
+ if (!TclLooksLikeInt(word, numBytes)) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Now try to really parse the number.
+ */
+
+ intObj = Tcl_NewStringObj(word, numBytes);
+ Tcl_IncrRefCount(intObj);
+ code = Tcl_GetIntFromObj(NULL, intObj, &incrAmount);
+ Tcl_DecrRefCount(intObj);
+ if (code != TCL_OK) {
+ return TCL_ERROR;
+ }
+ }
+ if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ return TCL_ERROR;
+ }
+ name = varTokenPtr[1].start;
+ nameChars = varTokenPtr[1].size;
+ if (!TclIsLocalScalar(name, nameChars)) {
+ return TCL_ERROR;
+ }
+ dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, VAR_SCALAR,
+ procPtr);
+ CompileWord(envPtr, keyTokenPtr, interp);
+ TclEmitInstInt4( INST_DICT_INCR_IMM, incrAmount, envPtr);
+ TclEmitInt4( dictVarIndex, envPtr);
+ return TCL_OK;
+ } else if (size==3 && strncmp(cmd, "get", 3)==0) {
+ /*
+ * Only compile this because we need INST_DICT_GET anyway.
+ */
+ if (numWords < 2) {
+ return TCL_ERROR;
+ }
+ for (i=0 ; i<numWords ; i++) {
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp);
+ }
+ TclEmitInstInt4(INST_DICT_GET, numWords-1, envPtr);
+ return TCL_OK;
+ } else if (size==3 && strncmp(cmd, "for", 3)==0) {
+ Tcl_Token *varsTokenPtr, *dictTokenPtr, *bodyTokenPtr;
+ int keyVarIndex, valueVarIndex, nameChars, loopRange, catchRange;
+ int infoIndex, jumpDisplacement, bodyTargetOffset, doneTargetOffset;
+ int endTargetOffset;
+ const char **argv;
+ Tcl_DString buffer;
+ int savedStackDepth = envPtr->currStackDepth;
+
+ if (numWords != 3 || procPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ varsTokenPtr = TokenAfter(tokenPtr);
+ dictTokenPtr = TokenAfter(varsTokenPtr);
+ bodyTokenPtr = TokenAfter(dictTokenPtr);
+ if (varsTokenPtr->type != TCL_TOKEN_SIMPLE_WORD ||
+ bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Check we've got a pair of variables and that they are local
+ * variables. Then extract their indices in the LVT.
+ */
+
+ Tcl_DStringInit(&buffer);
+ Tcl_DStringAppend(&buffer, varsTokenPtr[1].start,
+ varsTokenPtr[1].size);
+ if (Tcl_SplitList(NULL, Tcl_DStringValue(&buffer), &numWords,
+ &argv) != TCL_OK) {
+ Tcl_DStringFree(&buffer);
+ return TCL_ERROR;
+ }
+ Tcl_DStringFree(&buffer);
+ if (numWords != 2) {
+ ckfree((char *) argv);
+ return TCL_ERROR;
+ }
+ nameChars = strlen(argv[0]);
+ if (!TclIsLocalScalar(argv[0], nameChars)) {
+ ckfree((char *) argv);
+ return TCL_ERROR;
+ }
+ keyVarIndex = TclFindCompiledLocal(argv[0], nameChars, 1, VAR_SCALAR,
+ procPtr);
+ nameChars = strlen(argv[1]);
+ if (!TclIsLocalScalar(argv[1], nameChars)) {
+ ckfree((char *) argv);
+ return TCL_ERROR;
+ }
+ valueVarIndex = TclFindCompiledLocal(argv[1], nameChars, 1, VAR_SCALAR,
+ procPtr);
+ ckfree((char *) argv);
+
+ /*
+ * Allocate a temporary variable to store the iterator reference. The
+ * variable will contain a Tcl_DictSearch reference which will be
+ * allocated by INST_DICT_FIRST and disposed when the variable is
+ * unset (at which point it should also have been finished with).
+ */
+
+ infoIndex = TclFindCompiledLocal(NULL, 0, 1, VAR_SCALAR, procPtr);
+
+ /*
+ * Preparation complete; issue instructions. Note that this code
+ * issues fixed-sized jumps. That simplifies things a lot!
+ *
+ * First up, get the dictionary and start the iteration. No catching
+ * of errors at this point.
+ */
+
+ CompileWord(envPtr, dictTokenPtr, interp);
+ TclEmitInstInt4( INST_DICT_FIRST, infoIndex, envPtr);
+ doneTargetOffset = CurrentOffset(envPtr);
+ TclEmitInstInt4( INST_JUMP_TRUE4, 0, envPtr);
+
+ /*
+ * Now we catch errors from here on so that we can finalize the search
+ * started by Tcl_DictObjFirst above.
+ */
+
+ catchRange = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
+ TclEmitInstInt4( INST_BEGIN_CATCH4, catchRange, envPtr);
+ ExceptionRangeStarts(envPtr, catchRange);
+
+ /*
+ * Inside the iteration, write the loop variables.
+ */
+
+ bodyTargetOffset = CurrentOffset(envPtr);
+ TclEmitInstInt4( INST_STORE_SCALAR4, keyVarIndex, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ TclEmitInstInt4( INST_STORE_SCALAR4, valueVarIndex, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+
+ /*
+ * Set up the loop exception targets.
+ */
+
+ loopRange = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE);
+ ExceptionRangeStarts(envPtr, loopRange);
+
+ /*
+ * Compile the loop body itself. It should be stack-neutral.
+ */
+
+ CompileBody(envPtr, bodyTokenPtr, interp);
+ envPtr->currStackDepth = savedStackDepth + 1;
+ TclEmitOpcode( INST_POP, envPtr);
+ envPtr->currStackDepth = savedStackDepth;
+
+ /*
+ * Both exception target ranges (error and loop) end here.
+ */
+
+ ExceptionRangeEnds(envPtr, loopRange);
+ ExceptionRangeEnds(envPtr, catchRange);
+
+ /*
+ * Continue (or just normally process) by getting the next pair of
+ * items from the dictionary and jumping back to the code to write
+ * them into variables if there is another pair.
+ */
+
+ ExceptionRangeTarget(envPtr, loopRange, continueOffset);
+ TclEmitInstInt4( INST_DICT_NEXT, infoIndex, envPtr);
+ jumpDisplacement = bodyTargetOffset - CurrentOffset(envPtr);
+ TclEmitInstInt4( INST_JUMP_FALSE4, jumpDisplacement, envPtr);
+
+ /*
+ * Otherwise we're done (the jump after the DICT_FIRST points here)
+ * and we need to pop the bogus key/value pair (pushed to keep stack
+ * calculations easy!)
+ */
+
+ jumpDisplacement = CurrentOffset(envPtr) - doneTargetOffset;
+ TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDisplacement,
+ envPtr->codeStart + doneTargetOffset);
+ TclEmitOpcode( INST_POP, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+
+ /*
+ * Now do the final cleanup for the no-error case (this is where we
+ * break out of the loop to) by force-terminating the iteration (if
+ * not already terminated), ditching the exception info and jumping to
+ * the last instruction for this command. In theory, this could be
+ * done using the "finally" clause (next generated) but this is
+ * faster.
+ */
+
+ ExceptionRangeTarget(envPtr, loopRange, breakOffset);
+ TclEmitInstInt4( INST_DICT_DONE, infoIndex, envPtr);
+ TclEmitOpcode( INST_END_CATCH, envPtr);
+ endTargetOffset = CurrentOffset(envPtr);
+ TclEmitInstInt4( INST_JUMP4, 0, envPtr);
+
+ /*
+ * Error handler "finally" clause, which force-terminates the
+ * iteration and rethrows the error.
+ */
+
+ ExceptionRangeTarget(envPtr, catchRange, catchOffset);
+ TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr);
+ TclEmitOpcode( INST_PUSH_RESULT, envPtr);
+ TclEmitInstInt4( INST_DICT_DONE, infoIndex, envPtr);
+ TclEmitOpcode( INST_END_CATCH, envPtr);
+ TclEmitOpcode( INST_RETURN_STK, envPtr);
+
+ /*
+ * Final stage of the command (normal case) is that we push an empty
+ * object. This is done last to promote peephole optimization when
+ * it's dropped immediately.
+ */
+
+ jumpDisplacement = CurrentOffset(envPtr) - endTargetOffset;
+ TclUpdateInstInt4AtPc(INST_JUMP4, jumpDisplacement,
+ envPtr->codeStart + endTargetOffset);
+ PushLiteral(envPtr, "", 0);
+ envPtr->exceptDepth -= 2;
+ return TCL_OK;
+ } else if (size==6 && strncmp(cmd, "update", 6)==0) {
+ const char *name;
+ int nameChars, dictIndex, keyTmpIndex, numVars, range;
+ Tcl_Token **keyTokenPtrs, *dictVarTokenPtr, *bodyTokenPtr;
+ Tcl_DString localVarsLiteral;
+
+ /*
+ * Parse the command. Expect the following:
+ * dict update <lit(eral)> <any> <lit> ?<any> <lit> ...? <lit>
+ */
+
+ if (numWords < 4 || numWords & 1 || procPtr == NULL) {
+ return TCL_ERROR;
+ }
+ numVars = numWords/2 - 1;
+ dictVarTokenPtr = TokenAfter(tokenPtr);
+ if (dictVarTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ return TCL_ERROR;
+ }
+ name = dictVarTokenPtr[1].start;
+ nameChars = dictVarTokenPtr[1].size;
+ if (!TclIsLocalScalar(name, nameChars)) {
+ return TCL_ERROR;
+ }
+ dictIndex = TclFindCompiledLocal(name, nameChars, 1, VAR_SCALAR,
+ procPtr);
+
+ Tcl_DStringInit(&localVarsLiteral);
+ 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 *) keyTokenPtrs);
+ return TCL_ERROR;
+ }
+ name = tokenPtr[1].start;
+ nameChars = tokenPtr[1].size;
+ if (!TclIsLocalScalar(name, nameChars)) {
+ Tcl_DStringFree(&localVarsLiteral);
+ 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);
+ }
+ tokenPtr = TokenAfter(tokenPtr);
+ }
+ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ Tcl_DStringFree(&localVarsLiteral);
+ ckfree((char *) keyTokenPtrs);
+ return TCL_ERROR;
+ }
+ bodyTokenPtr = tokenPtr;
+
+ keyTmpIndex = TclFindCompiledLocal(NULL, 0, 1, VAR_SCALAR, procPtr);
+
+ for (i=0 ; i<numVars ; i++) {
+ CompileWord(envPtr, keyTokenPtrs[i], interp);
+ }
+ 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);
+
+ range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
+ TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr);
+
+ ExceptionRangeStarts(envPtr, range);
+ CompileBody(envPtr, bodyTokenPtr, interp);
+ ExceptionRangeEnds(envPtr, range);
+
+ ExceptionRangeTarget(envPtr, range, catchOffset);
+ TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr);
+ TclEmitOpcode( INST_PUSH_RESULT, envPtr);
+ TclEmitOpcode( INST_END_CATCH, envPtr);
+ 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...
+ */
+ TclEmitInstInt4( INST_STORE_SCALAR4, keyTmpIndex, envPtr);
+ TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr);
+
+ TclEmitOpcode( INST_RETURN_STK, envPtr);
+
+ Tcl_DStringFree(&localVarsLiteral);
+ ckfree((char *) keyTokenPtrs);
+ return TCL_OK;
+ } else if (size==6 && strncmp(cmd, "append", 6) == 0) {
+ Tcl_Token *varTokenPtr;
+ int dictVarIndex, nameChars;
+ const char *name;
+
+ /*
+ * Arbirary safe limit; anyone exceeding it should stop worrying about
+ * speed quite so much. ;-)
+ */
+ if (numWords < 3 || numWords > 100 || procPtr == NULL) {
+ return TCL_ERROR;
+ }
+ varTokenPtr = TokenAfter(tokenPtr);
+ tokenPtr = TokenAfter(varTokenPtr);
+ if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ return TCL_ERROR;
+ }
+ name = varTokenPtr[1].start;
+ nameChars = varTokenPtr[1].size;
+ if (!TclIsLocalScalar(name, nameChars)) {
+ return TCL_ERROR;
+ }
+ dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, VAR_SCALAR,
+ procPtr);
+ for (i=1 ; i<numWords ; i++) {
+ CompileWord(envPtr, tokenPtr, interp);
+ tokenPtr = TokenAfter(tokenPtr);
+ }
+ if (numWords > 3) {
+ TclEmitInstInt1( INST_CONCAT1, numWords-2, envPtr);
+ }
+ TclEmitInstInt4( INST_DICT_APPEND, dictVarIndex, envPtr);
+ return TCL_OK;
+ } else if (size==7 && strncmp(cmd, "lappend", 7) == 0) {
+ Tcl_Token *varTokenPtr, *keyTokenPtr, *valueTokenPtr;
+ int dictVarIndex, nameChars;
+ const char *name;
+
+ if (numWords != 3 || procPtr == NULL) {
+ return TCL_ERROR;
+ }
+ varTokenPtr = TokenAfter(tokenPtr);
+ keyTokenPtr = TokenAfter(varTokenPtr);
+ valueTokenPtr = TokenAfter(keyTokenPtr);
+ if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ return TCL_ERROR;
+ }
+ name = varTokenPtr[1].start;
+ nameChars = varTokenPtr[1].size;
+ if (!TclIsLocalScalar(name, nameChars)) {
+ return TCL_ERROR;
+ }
+ dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, VAR_SCALAR,
+ procPtr);
+ CompileWord(envPtr, keyTokenPtr, interp);
+ CompileWord(envPtr, valueTokenPtr, interp);
+ TclEmitInstInt4( INST_DICT_LAPPEND, dictVarIndex, envPtr);
+ return TCL_OK;
+ }
+
+ /*
+ * Something we do not know how to compile.
+ */
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclCompileExprCmd --
*
* Procedure called to compile the "expr" command.
@@ -581,10 +1106,7 @@ TclCompileForCmd(interp, parsePtr, envPtr)
* has a -1 continueOffset).
*/
- envPtr->exceptDepth++;
- envPtr->maxExceptDepth =
- TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth);
- bodyRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
+ bodyRange = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE);
nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
/*
@@ -612,12 +1134,10 @@ TclCompileForCmd(interp, parsePtr, envPtr)
* Compile the loop body.
*/
- bodyCodeOffset = CurrentOffset(envPtr);
-
+ bodyCodeOffset = ExceptionRangeStarts(envPtr, bodyRange);
CompileBody(envPtr, bodyTokenPtr, interp);
+ ExceptionRangeEnds(envPtr, bodyRange);
envPtr->currStackDepth = savedStackDepth + 1;
- envPtr->exceptArrayPtr[bodyRange].numCodeBytes =
- CurrentOffset(envPtr) - bodyCodeOffset;
TclEmitOpcode(INST_POP, envPtr);
@@ -625,13 +1145,11 @@ TclCompileForCmd(interp, parsePtr, envPtr)
* Compile the "next" subcommand.
*/
- nextCodeOffset = CurrentOffset(envPtr);
-
envPtr->currStackDepth = savedStackDepth;
+ nextCodeOffset = ExceptionRangeStarts(envPtr, nextRange);
CompileBody(envPtr, nextTokenPtr, interp);
+ ExceptionRangeEnds(envPtr, nextRange);
envPtr->currStackDepth = savedStackDepth + 1;
- envPtr->exceptArrayPtr[nextRange].numCodeBytes =
- CurrentOffset(envPtr) - nextCodeOffset;
TclEmitOpcode(INST_POP, envPtr);
envPtr->currStackDepth = savedStackDepth;
@@ -661,7 +1179,8 @@ TclCompileForCmd(interp, parsePtr, envPtr)
}
/*
- * Set the loop's offsets and break target.
+ * Fix the starting points of the exception ranges (may have moved due to
+ * jump type modification) and set where the exceptions target.
*/
envPtr->exceptArrayPtr[bodyRange].codeOffset = bodyCodeOffset;
@@ -669,9 +1188,8 @@ TclCompileForCmd(interp, parsePtr, envPtr)
envPtr->exceptArrayPtr[nextRange].codeOffset = nextCodeOffset;
- envPtr->exceptArrayPtr[bodyRange].breakOffset =
- envPtr->exceptArrayPtr[nextRange].breakOffset =
- CurrentOffset(envPtr);
+ ExceptionRangeTarget(envPtr, bodyRange, breakOffset);
+ ExceptionRangeTarget(envPtr, nextRange, breakOffset);
/*
* The for command's result is an empty string.
@@ -777,14 +1295,6 @@ TclCompileForeachCmd(interp, parsePtr, envPtr)
}
/*
- * Set the exception stack depth.
- */
-
- envPtr->exceptDepth++;
- envPtr->maxExceptDepth =
- TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth);
-
- /*
* Break up each var list and set the varcList and varvList arrays. Don't
* compile the foreach inline if any var name needs substitutions or isn't
* a scalar, or if any var list needs substitutions.
@@ -879,10 +1389,14 @@ TclCompileForeachCmd(interp, parsePtr, envPtr)
infoIndex = TclCreateAuxData((ClientData) infoPtr, &tclForeachInfoType, envPtr);
/*
- * Evaluate then store each value list in the associated temporary.
+ * Create an exception record to handle [break] and [continue].
*/
- range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
+ range = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE);
+
+ /*
+ * Evaluate then store each value list in the associated temporary.
+ */
loopIndex = 0;
for (i = 0, tokenPtr = parsePtr->tokenPtr;
@@ -914,7 +1428,7 @@ TclCompileForeachCmd(interp, parsePtr, envPtr)
* to terminate the loop.
*/
- envPtr->exceptArrayPtr[range].continueOffset = CurrentOffset(envPtr);
+ ExceptionRangeTarget(envPtr, range, continueOffset);
TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr);
TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup);
@@ -922,11 +1436,10 @@ TclCompileForeachCmd(interp, parsePtr, envPtr)
* Inline compile the loop body.
*/
- envPtr->exceptArrayPtr[range].codeOffset = CurrentOffset(envPtr);
+ ExceptionRangeStarts(envPtr, range);
CompileBody(envPtr, bodyTokenPtr, interp);
+ ExceptionRangeEnds(envPtr, range);
envPtr->currStackDepth = savedStackDepth + 1;
- envPtr->exceptArrayPtr[range].numCodeBytes =
- CurrentOffset(envPtr) - envPtr->exceptArrayPtr[range].codeOffset;
TclEmitOpcode(INST_POP, envPtr);
/*
@@ -974,7 +1487,7 @@ TclCompileForeachCmd(interp, parsePtr, envPtr)
* Set the loop's break target.
*/
- envPtr->exceptArrayPtr[range].breakOffset = CurrentOffset(envPtr);
+ ExceptionRangeTarget(envPtr, range, breakOffset);
/*
* The foreach command's result is an empty string.
@@ -2309,6 +2822,31 @@ TclCompileReturnCmd(interp, parsePtr, envPtr)
int objc;
Tcl_Obj *staticObjArray[NUM_STATIC_OBJS], **objv;
+ /*
+ * Check for special case which can always be compiled:
+ * return -options <opts> <msg>
+ * Unlike the normal [return] compilation, this version does everything at
+ * runtime so it can handle arbitrary words and not just literals. Note
+ * that if INST_RETURN_STK wasn't already needed for something else
+ * ('finally' clause processing) this piece of code would not be present.
+ */
+
+ if ((numWords == 4) && (wordTokenPtr->type == TCL_TOKEN_SIMPLE_WORD)
+ && (wordTokenPtr[1].size == 8)
+ && (strncmp(wordTokenPtr[1].start, "-options", 8) == 0)) {
+ Tcl_Token *optsTokenPtr = TokenAfter(wordTokenPtr);
+ Tcl_Token *msgTokenPtr = TokenAfter(optsTokenPtr);
+
+ CompileWord(envPtr, optsTokenPtr, interp);
+ CompileWord(envPtr, msgTokenPtr, interp);
+ TclEmitOpcode(INST_RETURN_STK, envPtr);
+ return TCL_OK;
+ }
+
+ /*
+ * Allocate some working space if needed
+ */
+
if (numOptionWords > NUM_STATIC_OBJS) {
objv = (Tcl_Obj **) ckalloc(numOptionWords * sizeof(Tcl_Obj *));
} else {
@@ -2398,11 +2936,11 @@ TclCompileReturnCmd(interp, parsePtr, envPtr)
/*
* Could not use the optimization, so we push the return options dict, and
- * emit the INST_RETURN instruction with code and level as operands.
+ * emit the INST_RETURN_IMM instruction with code and level as operands.
*/
TclEmitPush(TclAddLiteralObj(envPtr, returnOpts, NULL), envPtr);
- TclEmitInstInt4(INST_RETURN, code, envPtr);
+ TclEmitInstInt4(INST_RETURN_IMM, code, envPtr);
TclEmitInt4(level, envPtr);
return TCL_OK;
}
@@ -3318,10 +3856,7 @@ TclCompileWhileCmd(interp, parsePtr, envPtr)
* implement break and continue.
*/
- envPtr->exceptDepth++;
- envPtr->maxExceptDepth =
- TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth);
- range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
+ range = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE);
/*
* Jump to the evaluation of the condition. This code uses the "loop
@@ -3348,11 +3883,10 @@ TclCompileWhileCmd(interp, parsePtr, envPtr)
* Compile the loop body.
*/
- bodyCodeOffset = CurrentOffset(envPtr);
+ bodyCodeOffset = ExceptionRangeStarts(envPtr, range);
CompileBody(envPtr, bodyTokenPtr, interp);
+ ExceptionRangeEnds(envPtr, range);
envPtr->currStackDepth = savedStackDepth + 1;
- envPtr->exceptArrayPtr[range].numCodeBytes =
- CurrentOffset(envPtr) - bodyCodeOffset;
TclEmitOpcode(INST_POP, envPtr);
/*
@@ -3393,7 +3927,7 @@ TclCompileWhileCmd(interp, parsePtr, envPtr)
envPtr->exceptArrayPtr[range].continueOffset = testCodeOffset;
envPtr->exceptArrayPtr[range].codeOffset = bodyCodeOffset;
- envPtr->exceptArrayPtr[range].breakOffset = CurrentOffset(envPtr);
+ ExceptionRangeTarget(envPtr, range, breakOffset);
/*
* The while command's result is an empty string.
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 28edd75..6cc8428 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.89 2005/07/14 13:41:41 dkf Exp $
+ * RCS: @(#) $Id: tclCompile.c,v 1.90 2005/07/21 21:49:02 dkf Exp $
*/
#include "tclInt.h"
@@ -274,10 +274,9 @@ InstructionDesc tclInstructionTable[] = {
* (operand-2) indices; pushes the new value.
*/
- {"return", 9, -1, 2, {OPERAND_INT4, OPERAND_UINT4}},
- /* Compiled [return], code, level are operands; options and result are
- * on the stack. */
-
+ {"returnImm", 9, -1, 2, {OPERAND_INT4, OPERAND_UINT4}},
+ /* Compiled [return], code, level are operands; options and result
+ * are on the stack. */
{"expon", 1, -1, 0, {OPERAND_NONE}},
/* Binary exponentiation operator: push (stknext ** stktop) */
@@ -311,6 +310,58 @@ InstructionDesc tclInstructionTable[] = {
{"pushReturnOpts", 1, +1, 0, {OPERAND_NONE}},
/* Push the interpreter's return option dictionary as an object on the
* stack. */
+ {"returnStk", 1, -2, 0, {OPERAND_NONE}},
+ /* Compiled [return]; options and result are on the stack, code and
+ * level are in the options. */
+
+ {"dictGet", 5, INT_MIN, 1, {OPERAND_UINT4}},
+ /* The top op4 words (min 1) are a key path into the dictionary just
+ * below the keys on the stack, and all those values are replaced by
+ * the value read out of that key-path (like [dict get]).
+ * Stack: ... dict key1 ... keyN => ... value */
+ {"dictSet", 5, INT_MIN, 2, {OPERAND_UINT4, OPERAND_LVT4}},
+ /* Update a dictionary value such that the keys are a path pointing to
+ * the value. op4#1 = numKeys, op4#2 = LVTindex
+ * Stack: ... key1 ... keyN value => ... newDict */
+ {"dictUnset", 5, INT_MIN, 2, {OPERAND_UINT4, OPERAND_LVT4}},
+ /* Update a dictionary value such that the keys are not a path pointing
+ * to any value. op4#1 = numKeys, op4#2 = LVTindex
+ * Stack: ... key1 ... keyN => ... newDict */
+ {"dictIncrImm", 5, 0, 2, {OPERAND_INT4, OPERAND_LVT4}},
+ /* Update a dictionary value such that the value pointed to by key is
+ * incremented by some value (or set to it if the key isn't in the
+ * dictionary at all). op4#1 = incrAmount, op4#2 = LVTindex
+ * Stack: ... key => ... newDict */
+ {"dictAppend", 5, -1, 1, {OPERAND_LVT4}},
+ /* Update a dictionary value such that the value pointed to by key has
+ * some value string-concatenated onto it. op4 = LVTindex
+ * Stack: ... key valueToAppend => ... newDict */
+ {"dictLappend", 5, -1, 1, {OPERAND_LVT4}},
+ /* Update a dictionary value such that the value pointed to by key has
+ * some value list-appended onto it. op4 = LVTindex
+ * Stack: ... key valueToAppend => ... newDict */
+ {"dictFirst", 5, +2, 1, {OPERAND_LVT4}},
+ /* Begin iterating over the dictionary, using the local scalar
+ * indicated by op4 to hold the iterator state. If doneBool is true,
+ * dictDone *must* be called later on.
+ * Stack: ... dict => ... value key doneBool */
+ {"dictNext", 5, +3, 1, {OPERAND_LVT4}},
+ /* Get the next iteration from the iterator in op4's local scalar.
+ * 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. */
{0}
};
@@ -1216,7 +1267,7 @@ TclCompileScript(interp, script, numBytes, envPtr)
* offsets of the source and code for the command.
*/
- finishCommand:
+ finishCommand:
EnterCmdExtentData(envPtr, currCmdIndex, commandLength,
(envPtr->codeNext-envPtr->codeStart) - startCodeOffset);
isFirstCmd = 0;
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 27b05b8..dcb122b 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.58 2005/07/14 12:12:39 dkf Exp $
+ * RCS: @(#) $Id: tclCompile.h,v 1.59 2005/07/21 21:49:04 dkf Exp $
*/
#ifndef _TCLCOMPILATION
@@ -518,7 +518,7 @@ typedef struct ByteCode {
/* TIP#90 - 'return' command. */
-#define INST_RETURN 98
+#define INST_RETURN_IMM 98
/* TIP#123 - exponentiation operator. */
@@ -544,9 +544,26 @@ typedef struct ByteCode {
#define INST_LIST_NOT_IN 107
#define INST_PUSH_RETURN_OPTIONS 108
+#define INST_RETURN_STK 109
+
+/*
+ * Dictionary (TIP#111) related commands.
+ */
+
+#define INST_DICT_GET 110
+#define INST_DICT_SET 111
+#define INST_DICT_UNSET 112
+#define INST_DICT_INCR_IMM 113
+#define INST_DICT_APPEND 114
+#define INST_DICT_LAPPEND 115
+#define INST_DICT_FIRST 116
+#define INST_DICT_NEXT 117
+#define INST_DICT_DONE 118
+#define INST_DICT_UPDATE_START 119
+#define INST_DICT_UPDATE_END 120
/* The last opcode */
-#define LAST_INST_OPCODE 108
+#define LAST_INST_OPCODE 120
/*
* Table describing the Tcl bytecode instructions: their name (for displaying
diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c
index b96ef8b..1e428a1 100644
--- a/generic/tclDictObj.c
+++ b/generic/tclDictObj.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: tclDictObj.c,v 1.32 2005/07/04 21:19:34 dkf Exp $
+ * RCS: @(#) $Id: tclDictObj.c,v 1.33 2005/07/21 21:49:05 dkf Exp $
*/
#include "tclInt.h"
@@ -20,33 +20,6 @@
struct Dict;
/*
- * Flag values for TraceDictPath().
- *
- * DICT_PATH_READ indicates that all entries on the path must exist
- * but no updates will be needed.
- *
- * DICT_PATH_UPDATE indicates that we are going to be doing an update
- * at the tip of the path, so duplication of shared objects should be
- * done along the way.
- *
- * DICT_PATH_EXISTS indicates that we are performing an existance test
- * and a lookup failure should therefore not be an error. If (and
- * only if) this flag is set, TraceDictPath() will return the special
- * value DICT_PATH_NON_EXISTENT if the path is not traceable.
- *
- * DICT_PATH_CREATE (which also requires the DICT_PATH_UPDATE bit to
- * be set) indicates that we are to create non-existant dictionaries
- * on the path.
- */
-
-#define DICT_PATH_READ 0
-#define DICT_PATH_UPDATE 1
-#define DICT_PATH_EXISTS 2
-#define DICT_PATH_CREATE 5
-
-#define DICT_PATH_NON_EXISTENT ((Tcl_Obj *) (void *) 1)
-
-/*
* Prototypes for procedures defined later in this file:
*/
@@ -95,9 +68,6 @@ static void FreeDictInternalRep _ANSI_ARGS_((Tcl_Obj *dictPtr));
static void InvalidateDictChain _ANSI_ARGS_((Tcl_Obj *dictObj));
static int SetDictFromAny _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr));
-static Tcl_Obj * TraceDictPath _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Obj *rootPtr, int keyc, Tcl_Obj *CONST keyv[],
- int flags));
static void UpdateStringOfDict _ANSI_ARGS_((Tcl_Obj *dictPtr));
/*
@@ -588,7 +558,7 @@ SetDictFromAny(interp, objPtr)
/*
*----------------------------------------------------------------------
*
- * TraceDictPath --
+ * TclTraceDictPath --
*
* Trace through a tree of dictionaries using the array of keys
* given. If the flags argument has the DICT_PATH_UPDATE flag is
@@ -619,8 +589,8 @@ SetDictFromAny(interp, objPtr)
*----------------------------------------------------------------------
*/
-static Tcl_Obj *
-TraceDictPath(interp, dictPtr, keyc, keyv, flags)
+Tcl_Obj *
+TclTraceDictPath(interp, dictPtr, keyc, keyv, flags)
Tcl_Interp *interp;
Tcl_Obj *dictPtr, *CONST keyv[];
int keyc, flags;
@@ -697,8 +667,8 @@ TraceDictPath(interp, dictPtr, keyc, keyv, flags)
* InvalidateDictChain --
*
* Go through a dictionary chain (built by an updating invokation
- * of TraceDictPath) and invalidate the string representations of
- * all the dictionaries on the chain.
+ * of TclTraceDictPath) and invalidate the string representations
+ * of all the dictionaries on the chain.
*
* Results:
* None
@@ -1135,7 +1105,7 @@ Tcl_DictObjPutKeyList(interp, dictPtr, keyc, keyv, valuePtr)
Tcl_Panic("Tcl_DictObjPutKeyList called with empty key list");
}
- dictPtr = TraceDictPath(interp, dictPtr, keyc-1, keyv, DICT_PATH_CREATE);
+ dictPtr = TclTraceDictPath(interp, dictPtr, keyc-1,keyv, DICT_PATH_CREATE);
if (dictPtr == NULL) {
return TCL_ERROR;
}
@@ -1191,7 +1161,7 @@ Tcl_DictObjRemoveKeyList(interp, dictPtr, keyc, keyv)
Tcl_Panic("Tcl_DictObjRemoveKeyList called with empty key list");
}
- dictPtr = TraceDictPath(interp, dictPtr, keyc-1, keyv, DICT_PATH_UPDATE);
+ dictPtr = TclTraceDictPath(interp, dictPtr, keyc-1,keyv, DICT_PATH_UPDATE);
if (dictPtr == NULL) {
return TCL_ERROR;
}
@@ -1426,7 +1396,7 @@ DictGetCmd(interp, objc, objv)
* executes at least once.
*/
- dictPtr = TraceDictPath(interp, objv[2], objc-4, objv+3, DICT_PATH_READ);
+ dictPtr = TclTraceDictPath(interp, objv[2], objc-4,objv+3, DICT_PATH_READ);
if (dictPtr == NULL) {
return TCL_ERROR;
}
@@ -1815,7 +1785,8 @@ DictExistsCmd(interp, objc, objv)
return TCL_ERROR;
}
- dictPtr = TraceDictPath(interp, objv[2], objc-4, objv+3, DICT_PATH_EXISTS);
+ dictPtr = TclTraceDictPath(interp, objv[2], objc-4, objv+3,
+ DICT_PATH_EXISTS);
if (dictPtr == NULL) {
return TCL_ERROR;
}
@@ -2879,7 +2850,7 @@ DictWithCmd(interp, objc, objv)
return TCL_ERROR;
}
if (objc > 4) {
- dictPtr = TraceDictPath(interp, dictPtr, objc-4, objv+3,
+ dictPtr = TclTraceDictPath(interp, dictPtr, objc-4, objv+3,
DICT_PATH_READ);
if (dictPtr == NULL) {
return TCL_ERROR;
@@ -2957,7 +2928,7 @@ DictWithCmd(interp, objc, objv)
* on to update; it's just less than perfectly efficient (but
* no memory should be leaked).
*/
- leafPtr = TraceDictPath(interp, dictPtr, objc-4, objv+3,
+ leafPtr = TclTraceDictPath(interp, dictPtr, objc-4, objv+3,
DICT_PATH_EXISTS | DICT_PATH_UPDATE);
if (leafPtr == NULL) {
TclDecrRefCount(keysPtr);
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index b9022bf..9dd242e 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -6,11 +6,13 @@
* Copyright (c) 1996-1997 Sun Microsystems, Inc.
* Copyright (c) 1998-2000 by Scriptics Corporation.
* Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
+ * Copyright (c) 2002-2005 by Miguel Sofer.
+ * Copyright (c) 2005 by Donal K. Fellows.
*
* 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.195 2005/07/11 15:04:11 dkf Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.196 2005/07/21 21:49:05 dkf Exp $
*/
#include "tclInt.h"
@@ -350,6 +352,11 @@ long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 };
}
#endif /* TCL_WIDE_INT_IS_LONG */
+static Tcl_ObjType dictIteratorType = {
+ "dictIterator",
+ NULL, NULL, NULL, NULL
+};
+
/*
* Declarations for local procedures to this file:
*/
@@ -1258,11 +1265,13 @@ TclExecuteByteCode(interp, codePtr)
}
switch (*pc) {
- case INST_RETURN: {
+ case INST_RETURN_IMM: {
int code = TclGetInt4AtPtr(pc+1);
int level = TclGetUInt4AtPtr(pc+5);
- Tcl_Obj *returnOpts = POP_OBJECT();
+ Tcl_Obj *returnOpts;
+ TRACE(("%u %u => ", code, level));
+ returnOpts = POP_OBJECT();
result = TclProcessReturn(interp, code, level, returnOpts);
Tcl_DecrRefCount(returnOpts);
if (result != TCL_OK) {
@@ -1270,9 +1279,25 @@ TclExecuteByteCode(interp, codePtr)
cleanup = 1;
goto processExceptionReturn;
}
+ TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")",
+ O2S(objResultPtr)));
NEXT_INST_F(9, 0, 0);
}
+ case INST_RETURN_STK:
+ TRACE(("=> "));
+ objResultPtr = POP_OBJECT();
+ result = Tcl_SetReturnOptions(interp, POP_OBJECT());
+ if (result != TCL_OK) {
+ Tcl_SetObjResult(interp, objResultPtr);
+ Tcl_DecrRefCount(objResultPtr);
+ cleanup = 0;
+ goto processExceptionReturn;
+ }
+ TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")",
+ O2S(objResultPtr)));
+ NEXT_INST_F(1, 0, -1);
+
case INST_DONE:
if (tosPtr <= eePtr->stackPtr + initStackTop) {
tosPtr--;
@@ -4763,6 +4788,502 @@ TclExecuteByteCode(interp, codePtr)
TRACE_WITH_OBJ(("=> "), objResultPtr);
NEXT_INST_F(1, 0, 1);
+ {
+ int opnd, opnd2, allocateDict;
+ Tcl_Obj *dictPtr, *valPtr;
+ Var *varPtr;
+ char *part1;
+
+ case INST_DICT_GET:
+ opnd = TclGetUInt4AtPtr(pc+1);
+ TRACE(("%u => ", opnd));
+ dictPtr = *(tosPtr - opnd);
+ if (opnd > 1) {
+ dictPtr = TclTraceDictPath(interp, dictPtr, opnd-1,
+ tosPtr - (opnd-1), DICT_PATH_READ);
+ if (dictPtr == NULL) {
+ TRACE_WITH_OBJ((
+ "%u => ERROR tracing dictionary path into \"%s\": ",
+ opnd, O2S(*(tosPtr - opnd))),
+ Tcl_GetObjResult(interp));
+ result = TCL_ERROR;
+ cleanup = opnd + 1;
+ goto checkForCatch;
+ }
+ }
+ result = Tcl_DictObjGet(interp, dictPtr, *tosPtr, &objResultPtr);
+ if (result != TCL_OK) {
+ TRACE_WITH_OBJ((
+ "%u => ERROR reading leaf dictionary key \"%s\": ",
+ opnd, O2S(dictPtr)), Tcl_GetObjResult(interp));
+ cleanup = opnd + 1;
+ goto checkForCatch;
+ }
+ if (objResultPtr == NULL) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "key \"", TclGetString(*tosPtr),
+ "\" not known in dictionary", NULL);
+ TRACE_WITH_OBJ(("%u => ERROR ", opnd), Tcl_GetObjResult(interp));
+ result = TCL_ERROR;
+ cleanup = opnd + 1;
+ goto checkForCatch;
+ }
+ TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+ NEXT_INST_V(5, opnd+1, 1);
+
+ case INST_DICT_SET:
+ case INST_DICT_UNSET:
+ case INST_DICT_INCR_IMM:
+ opnd = TclGetUInt4AtPtr(pc+1);
+ opnd2 = TclGetUInt4AtPtr(pc+5);
+
+ varPtr = &(compiledLocals[opnd2]);
+ part1 = varPtr->name;
+ while (TclIsVarLink(varPtr)) {
+ varPtr = varPtr->value.linkPtr;
+ }
+ TRACE(("%u %u => ", opnd, opnd2));
+ if (TclIsVarDirectReadable(varPtr)) {
+ dictPtr = varPtr->value.objPtr;
+ } else {
+ DECACHE_STACK_INFO();
+ dictPtr = TclPtrGetVar(interp, varPtr, NULL, part1, NULL, 0);
+ CACHE_STACK_INFO();
+ }
+ if (dictPtr == NULL) {
+ TclNewObj(dictPtr);
+ allocateDict = 1;
+ } else {
+ allocateDict = Tcl_IsShared(dictPtr);
+ if (allocateDict) {
+ dictPtr = Tcl_DuplicateObj(dictPtr);
+ }
+ }
+
+ switch (*pc) {
+ case INST_DICT_SET:
+ cleanup = opnd + 1;
+ result = Tcl_DictObjPutKeyList(interp, dictPtr, opnd, tosPtr-opnd,
+ *tosPtr);
+ break;
+ case INST_DICT_INCR_IMM: {
+ long value;
+
+ cleanup = 1;
+ opnd = TclGetInt4AtPtr(pc+1);
+ result = Tcl_DictObjGet(interp, dictPtr, *tosPtr, &valPtr);
+ if (result != TCL_OK) {
+ break;
+ }
+ if (valPtr == NULL) {
+ Tcl_DictObjPut(NULL, dictPtr, *tosPtr, Tcl_NewLongObj(opnd));
+ } else {
+#warning non-long incrementing broken
+ result = Tcl_GetLongFromObj(interp, valPtr, &value);
+ if (result != TCL_OK) {
+ break;
+ }
+ Tcl_DictObjPut(NULL, dictPtr, *tosPtr,
+ Tcl_NewLongObj(value + opnd));
+ }
+ break;
+ }
+ case INST_DICT_UNSET:
+ cleanup = opnd;
+ result = Tcl_DictObjRemoveKeyList(interp, dictPtr, opnd,
+ tosPtr - (opnd-1));
+ break;
+ default:
+ Tcl_Panic("Should not happen!");
+ }
+
+ if (result != TCL_OK) {
+ if (allocateDict) {
+ Tcl_DecrRefCount(dictPtr);
+ }
+ TRACE_WITH_OBJ(("%u %u => ERROR updating dictionary: ",opnd,opnd2),
+ Tcl_GetObjResult(interp));
+ goto checkForCatch;
+ }
+
+ if (TclIsVarDirectWritable(varPtr)) {
+ if (allocateDict) {
+ Tcl_Obj *oldValuePtr = varPtr->value.objPtr;
+
+ Tcl_IncrRefCount(dictPtr);
+ if (oldValuePtr != NULL) {
+ Tcl_DecrRefCount(oldValuePtr);
+ } else {
+ TclSetVarScalar(varPtr);
+ TclClearVarUndefined(varPtr);
+ }
+ varPtr->value.objPtr = dictPtr;
+ }
+ objResultPtr = dictPtr;
+ } else {
+ Tcl_IncrRefCount(dictPtr);
+ DECACHE_STACK_INFO();
+ objResultPtr = TclPtrSetVar(interp, varPtr, NULL, part1, NULL,
+ dictPtr, TCL_LEAVE_ERR_MSG);
+ CACHE_STACK_INFO();
+ Tcl_DecrRefCount(dictPtr);
+ if (objResultPtr == NULL) {
+ TRACE_APPEND(("ERROR: %.30s\n",O2S(Tcl_GetObjResult(interp))));
+ result = TCL_ERROR;
+ goto checkForCatch;
+ }
+ }
+#ifndef TCL_COMPILE_DEBUG
+ if (*(pc+9) == INST_POP) {
+ NEXT_INST_V(10, cleanup, 0);
+ }
+#endif
+ TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+ NEXT_INST_V(9, cleanup, 1);
+
+ case INST_DICT_APPEND:
+ case INST_DICT_LAPPEND:
+ opnd = TclGetUInt4AtPtr(pc+1);
+ cleanup = 2;
+
+ varPtr = &(compiledLocals[opnd]);
+ part1 = varPtr->name;
+ while (TclIsVarLink(varPtr)) {
+ varPtr = varPtr->value.linkPtr;
+ }
+ TRACE(("%u => ", opnd));
+ if (TclIsVarDirectReadable(varPtr)) {
+ dictPtr = varPtr->value.objPtr;
+ } else {
+ DECACHE_STACK_INFO();
+ dictPtr = TclPtrGetVar(interp, varPtr, NULL, part1, NULL, 0);
+ CACHE_STACK_INFO();
+ }
+ if (dictPtr == NULL) {
+ TclNewObj(dictPtr);
+ allocateDict = 1;
+ } else {
+ allocateDict = Tcl_IsShared(dictPtr);
+ if (allocateDict) {
+ dictPtr = Tcl_DuplicateObj(dictPtr);
+ }
+ }
+
+ result = Tcl_DictObjGet(interp, dictPtr, *(tosPtr - 1), &valPtr);
+ if (result != TCL_OK) {
+ if (allocateDict) {
+ Tcl_DecrRefCount(dictPtr);
+ }
+ goto checkForCatch;
+ }
+
+ /*
+ * Note that a non-existent key results in a NULL valPtr, which is a
+ * case handled separately below. What we *can* say at this point is
+ * that the write-back will always succeed.
+ */
+
+ switch (*pc) {
+ case INST_DICT_APPEND:
+ if (valPtr == NULL) {
+ valPtr = *tosPtr;
+ } else {
+ if (Tcl_IsShared(valPtr)) {
+ valPtr = Tcl_DuplicateObj(valPtr);
+ }
+ Tcl_AppendObjToObj(valPtr, *tosPtr);
+ }
+ break;
+ case INST_DICT_LAPPEND:
+ /*
+ * More complex because list-append can fail.
+ */
+ if (valPtr == NULL) {
+ valPtr = Tcl_NewListObj(1, tosPtr);
+ } else if (Tcl_IsShared(valPtr)) {
+ Tcl_Obj *dupPtr = Tcl_DuplicateObj(valPtr);
+
+ result = Tcl_ListObjAppendElement(interp, dupPtr, *tosPtr);
+ if (result != TCL_OK) {
+ Tcl_DecrRefCount(dupPtr);
+ if (allocateDict) {
+ Tcl_DecrRefCount(dictPtr);
+ }
+ goto checkForCatch;
+ }
+ } else {
+ result = Tcl_ListObjAppendElement(interp, valPtr, *tosPtr);
+ if (result != TCL_OK) {
+ if (allocateDict) {
+ Tcl_DecrRefCount(dictPtr);
+ }
+ goto checkForCatch;
+ }
+ }
+ break;
+ default:
+ Tcl_Panic("Should not happen!");
+ }
+
+ Tcl_DictObjPut(NULL, dictPtr, *(tosPtr - 1), valPtr);
+
+ if (TclIsVarDirectWritable(varPtr)) {
+ if (allocateDict) {
+ Tcl_Obj *oldValuePtr = varPtr->value.objPtr;
+
+ Tcl_IncrRefCount(dictPtr);
+ if (oldValuePtr != NULL) {
+ Tcl_DecrRefCount(oldValuePtr);
+ } else {
+ TclSetVarScalar(varPtr);
+ TclClearVarUndefined(varPtr);
+ }
+ varPtr->value.objPtr = dictPtr;
+ }
+ objResultPtr = dictPtr;
+ } else {
+ Tcl_IncrRefCount(dictPtr);
+ DECACHE_STACK_INFO();
+ objResultPtr = TclPtrSetVar(interp, varPtr, NULL, part1, NULL,
+ dictPtr, TCL_LEAVE_ERR_MSG);
+ CACHE_STACK_INFO();
+ Tcl_DecrRefCount(dictPtr);
+ if (objResultPtr == NULL) {
+ TRACE_APPEND(("ERROR: %.30s\n",O2S(Tcl_GetObjResult(interp))));
+ result = TCL_ERROR;
+ goto checkForCatch;
+ }
+ }
+#ifndef TCL_COMPILE_DEBUG
+ if (*(pc+9) == INST_POP) {
+ NEXT_INST_F(6, 2, 0);
+ }
+#endif
+ TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+ NEXT_INST_F(5, 2, 1);
+ }
+
+ {
+ int opnd, done;
+ Tcl_Obj *statePtr, *dictPtr, *keyPtr, *valuePtr, *emptyPtr;
+ Var *varPtr;
+ Tcl_DictSearch *searchPtr;
+
+ case INST_DICT_FIRST:
+ opnd = TclGetUInt4AtPtr(pc+1);
+ TRACE(("%u => ", opnd));
+ dictPtr = POP_OBJECT();
+ searchPtr = (Tcl_DictSearch *) ckalloc(sizeof(Tcl_DictSearch));
+ result = Tcl_DictObjFirst(interp, dictPtr, searchPtr, &keyPtr,
+ &valuePtr, &done);
+ Tcl_DecrRefCount(dictPtr);
+ if (result != TCL_OK) {
+ ckfree((char *) searchPtr);
+ cleanup = 0;
+ goto checkForCatch;
+ }
+ TclNewObj(statePtr);
+ statePtr->typePtr = &dictIteratorType;
+ statePtr->internalRep.otherValuePtr = (void *) searchPtr;
+ varPtr = compiledLocals + opnd;
+ if (varPtr->value.objPtr == NULL) {
+ TclSetVarScalar(compiledLocals + opnd);
+ TclClearVarUndefined(compiledLocals + opnd);
+ } else if (varPtr->value.objPtr->typePtr == &dictIteratorType) {
+ Tcl_Panic("mis-issued dictFirst!");
+ } else {
+ Tcl_DecrRefCount(varPtr->value.objPtr);
+ }
+ varPtr->value.objPtr = statePtr;
+ Tcl_IncrRefCount(statePtr);
+ goto pushDictIteratorResult;
+
+ case INST_DICT_NEXT:
+ opnd = TclGetUInt4AtPtr(pc+1);
+ TRACE(("%u => ", opnd));
+ statePtr = compiledLocals[opnd].value.objPtr;
+ if (statePtr == NULL || statePtr->typePtr != &dictIteratorType) {
+ Tcl_Panic("mis-issued dictNext!");
+ }
+ searchPtr = (Tcl_DictSearch *) statePtr->internalRep.otherValuePtr;
+ Tcl_DictObjNext(searchPtr, &keyPtr, &valuePtr, &done);
+ pushDictIteratorResult:
+ if (done) {
+ TclNewObj(emptyPtr);
+ PUSH_OBJECT(emptyPtr);
+ PUSH_OBJECT(emptyPtr);
+ } else {
+ PUSH_OBJECT(valuePtr);
+ PUSH_OBJECT(keyPtr);
+ }
+ TRACE_APPEND(("\"%.30s\" \"%.30s\" %d",
+ O2S(*(tosPtr-1)), O2S(*tosPtr), done));
+ objResultPtr = Tcl_NewBooleanObj(done);
+ NEXT_INST_F(5, 0, 1);
+
+ case INST_DICT_DONE:
+ opnd = TclGetUInt4AtPtr(pc+1);
+ TRACE(("%u => ", opnd));
+ statePtr = compiledLocals[opnd].value.objPtr;
+ if (statePtr == NULL) {
+ Tcl_Panic("mis-issued dictDone!");
+ }
+ if (statePtr->typePtr == &dictIteratorType) {
+ searchPtr = (Tcl_DictSearch *) statePtr->internalRep.otherValuePtr;
+ Tcl_DictObjDone(searchPtr);
+ ckfree((char *) searchPtr);
+ }
+ /*
+ * Set the internal variable to an empty object to signify
+ * that we don't hold an iterator.
+ */
+ Tcl_DecrRefCount(statePtr);
+ TclNewObj(emptyPtr);
+ compiledLocals[opnd].value.objPtr = emptyPtr;
+ Tcl_IncrRefCount(emptyPtr);
+ NEXT_INST_F(5, 0, 0);
+ }
+
+ {
+ int opnd, i, length, length2, allocdict;
+ Tcl_Obj **keyPtrPtr, **varIdxPtrPtr, *dictPtr;
+ Var *varPtr;
+ char *part1;
+
+ case INST_DICT_UPDATE_START:
+ opnd = TclGetUInt4AtPtr(pc+1);
+ varPtr = &(compiledLocals[opnd]);
+ part1 = varPtr->name;
+ while (TclIsVarLink(varPtr)) {
+ varPtr = varPtr->value.linkPtr;
+ }
+ TRACE(("%u => ", opnd));
+ if (TclIsVarDirectReadable(varPtr)) {
+ dictPtr = varPtr->value.objPtr;
+ } else {
+ DECACHE_STACK_INFO();
+ dictPtr = TclPtrGetVar(interp, varPtr, NULL, part1, NULL,
+ TCL_LEAVE_ERR_MSG);
+ CACHE_STACK_INFO();
+ if (dictPtr == NULL) {
+ goto dictUpdateStartFailed;
+ }
+ }
+ if (Tcl_ListObjGetElements(interp, *(tosPtr - 1), &length,
+ &keyPtrPtr) != TCL_OK ||
+ Tcl_ListObjGetElements(interp, *tosPtr, &length2,
+ &varIdxPtrPtr) != TCL_OK) {
+ goto dictUpdateStartFailed;
+ }
+ if (length != length2) {
+ 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]);
+ part1 = varPtr->name;
+ while (TclIsVarLink(varPtr)) {
+ varPtr = varPtr->value.linkPtr;
+ }
+ DECACHE_STACK_INFO();
+ if (valPtr == NULL) {
+ Tcl_UnsetVar(interp, part1, 0);
+ } else if (TclPtrSetVar(interp, varPtr, NULL, part1, NULL,
+ valPtr, TCL_LEAVE_ERR_MSG) == NULL) {
+ CACHE_STACK_INFO();
+ dictUpdateStartFailed:
+ cleanup = 2;
+ result = TCL_ERROR;
+ goto checkForCatch;
+ }
+ CACHE_STACK_INFO();
+ }
+ NEXT_INST_F(5, 2, 0);
+
+ case INST_DICT_UPDATE_END:
+ opnd = TclGetUInt4AtPtr(pc+1);
+ varPtr = &(compiledLocals[opnd]);
+ part1 = varPtr->name;
+ while (TclIsVarLink(varPtr)) {
+ varPtr = varPtr->value.linkPtr;
+ }
+ TRACE(("%u => ", opnd));
+ if (TclIsVarDirectReadable(varPtr)) {
+ dictPtr = varPtr->value.objPtr;
+ } else {
+ DECACHE_STACK_INFO();
+ dictPtr = TclPtrGetVar(interp, varPtr, NULL, part1, NULL, 0);
+ 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;
+ result = TCL_ERROR;
+ goto checkForCatch;
+ }
+ allocdict = Tcl_IsShared(dictPtr);
+ if (allocdict) {
+ dictPtr = Tcl_DuplicateObj(dictPtr);
+ }
+ for (i=0 ; i<length ; i++) {
+ Tcl_Obj *valPtr;
+ int varIdx;
+ Var *var2Ptr;
+ char *part1a;
+
+ Tcl_GetIntFromObj(NULL, varIdxPtrPtr[i], &varIdx);
+ var2Ptr = &(compiledLocals[varIdx]);
+ part1a = var2Ptr->name;
+ while (TclIsVarLink(var2Ptr)) {
+ var2Ptr = var2Ptr->value.linkPtr;
+ }
+ if (TclIsVarDirectReadable(var2Ptr)) {
+ valPtr = var2Ptr->value.objPtr;
+ } else {
+ DECACHE_STACK_INFO();
+ valPtr = TclPtrGetVar(interp, var2Ptr, NULL, part1a, NULL, 0);
+ CACHE_STACK_INFO();
+ }
+ if (valPtr == NULL) {
+ Tcl_DictObjRemove(interp, dictPtr, keyPtrPtr[i]);
+ } else {
+ Tcl_DictObjPut(interp, dictPtr, keyPtrPtr[i], valPtr);
+ }
+ }
+ if (TclIsVarDirectWritable(varPtr)) {
+ Tcl_IncrRefCount(dictPtr);
+ Tcl_DecrRefCount(varPtr->value.objPtr);
+ varPtr->value.objPtr = dictPtr;
+ } else {
+ DECACHE_STACK_INFO();
+ objResultPtr = TclPtrSetVar(interp, varPtr, NULL, part1, NULL,
+ dictPtr, TCL_LEAVE_ERR_MSG);
+ CACHE_STACK_INFO();
+ if (objResultPtr == NULL) {
+ if (allocdict) {
+ Tcl_DecrRefCount(dictPtr);
+ }
+ cleanup = 2;
+ result = TCL_ERROR;
+ goto checkForCatch;
+ }
+ }
+ NEXT_INST_F(5, 2, 0);
+ }
+
default:
Tcl_Panic("TclExecuteByteCode: unrecognized opCode %u", *pc);
} /* end of switch on opCode */
@@ -4912,7 +5433,7 @@ TclExecuteByteCode(interp, codePtr)
while ((expandNestList != NULL) && ((catchTop == initCatchTop) ||
((ptrdiff_t) eePtr->stackPtr[catchTop] <=
- (ptrdiff_t) expandNestList->internalRep.twoPtrValue.ptr1))) {
+ (ptrdiff_t) expandNestList->internalRep.twoPtrValue.ptr1))) {
Tcl_Obj *objPtr = expandNestList->internalRep.twoPtrValue.ptr2;
TclDecrRefCount(expandNestList);
expandNestList = objPtr;
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 7137443..28538f3 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -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: tclInt.h,v 1.241 2005/07/05 18:15:56 dgp Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.242 2005/07/21 21:49:08 dkf Exp $
*/
#ifndef _TCLINT
@@ -1711,6 +1711,33 @@ typedef struct List {
}
/*
+ * Flag values for TclTraceDictPath().
+ *
+ * DICT_PATH_READ indicates that all entries on the path must exist
+ * but no updates will be needed.
+ *
+ * DICT_PATH_UPDATE indicates that we are going to be doing an update
+ * at the tip of the path, so duplication of shared objects should be
+ * done along the way.
+ *
+ * DICT_PATH_EXISTS indicates that we are performing an existance test
+ * and a lookup failure should therefore not be an error. If (and
+ * only if) this flag is set, TclTraceDictPath() will return the special
+ * value DICT_PATH_NON_EXISTENT if the path is not traceable.
+ *
+ * DICT_PATH_CREATE (which also requires the DICT_PATH_UPDATE bit to
+ * be set) indicates that we are to create non-existant dictionaries
+ * on the path.
+ */
+
+#define DICT_PATH_READ 0
+#define DICT_PATH_UPDATE 1
+#define DICT_PATH_EXISTS 2
+#define DICT_PATH_CREATE 5
+
+#define DICT_PATH_NON_EXISTENT ((Tcl_Obj *) (void *) 1)
+
+/*
*----------------------------------------------------------------
* Data structures related to the filesystem internals
*----------------------------------------------------------------
@@ -1724,6 +1751,7 @@ typedef struct List {
* virtual filesystem interfaces, more efficiency in 'path' manipulation
* and usage, and cleaner filesystem code internally.
*/
+
#define TCL_FILESYSTEM_VERSION_2 ((Tcl_FSVersion) 0x2)
typedef ClientData (TclFSGetCwdProc2) _ANSI_ARGS_((ClientData clientData));
@@ -2441,6 +2469,8 @@ MODULE_SCOPE int TclCompileCatchCmd _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
MODULE_SCOPE int TclCompileContinueCmd _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
+MODULE_SCOPE int TclCompileDictCmd _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
MODULE_SCOPE int TclCompileExprCmd _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
MODULE_SCOPE int TclCompileForCmd _ANSI_ARGS_((Tcl_Interp *interp,
diff --git a/tests/dict.test b/tests/dict.test
index f6c11d7..090142e 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.12 2004/10/19 22:20:05 dkf Exp $
+# RCS: @(#) $Id: dict.test,v 1.13 2005/07/21 21:49:08 dkf Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
@@ -306,6 +306,17 @@ test dict-11.15 {dict incr command: write failure} {
catch {unset dictVar}
set result
} {1 {can't set "dictVar": variable is array}}
+test dict-11.16 {dict incr command: compilation} {
+ proc dicttest {} {
+ set v {a 0 b 0 c 0}
+ dict incr v a
+ dict incr v b 1
+ dict incr v c 2
+ dict incr v d 3
+ list [dict get $v a] [dict get $v b] [dict get $v c] [dict get $v d]
+ }
+ dicttest
+} {1 1 2 3}
test dict-12.1 {dict lappend command} {
set dictv {a a}
@@ -511,6 +522,17 @@ test dict-14.15 {dict for command: keys are unique and iterated over once only}
catch {unset accum}
set result
} {a1 a2 b1 b2 bar foo : a, b, c, d, foo, bar,}
+test dict-14.16 {dict for command in compilation context} {
+ proc dicttest {} {
+ set res {x x x x x x}
+ dict for {k v} {a 0 b 1 c 2 d 3 e 4 f 5} {
+ lset res $v $k
+ continue
+ }
+ return $res
+ }
+ dicttest
+} {a b c d e f}
# There's probably a lot more tests to add here. Really ought to use
# a coverage tool for this job...
@@ -968,6 +990,19 @@ test dict-21.12 {dict update command} {
}
getOrder $a b d f
} {b c d e f g 3}
+test dict-21.13 {dict update command: compilation} {
+ proc dicttest {d} {
+ while 1 {
+ dict update d a alpha b beta {
+ set beta $alpha
+ unset alpha
+ break
+ }
+ }
+ return $d
+ }
+ getOrder [dicttest {a 1 c 2}] b c
+} {b 1 c 2 2}
test dict-22.1 {dict with command} -body {
dict with
generated by cgit v0.12 at 2024-07-22 05:01:25 (GMT)