From 6a77d40d48491f6d5c3dabe5a735ac475c14c493 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 21 Jul 2005 21:48:37 +0000 Subject: Compiler for [dict] and related changes. --- ChangeLog | 9 + generic/tclBasic.c | 4 +- generic/tclCompCmds.c | 642 +++++++++++++++++++++++++++++++++++++++++++++----- generic/tclCompile.c | 63 ++++- generic/tclCompile.h | 23 +- generic/tclDictObj.c | 55 +---- generic/tclExecute.c | 529 ++++++++++++++++++++++++++++++++++++++++- generic/tclInt.h | 32 ++- tests/dict.test | 37 ++- 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 + + * 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 * 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 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 ; icurrStackDepth; + + 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 ? ...? + */ + + 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 ; itype != 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 ; iexceptDepth--; + + 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 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 + * 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 ; iname; + 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 ; iname; + 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 -- cgit v0.12