diff options
| -rw-r--r-- | ChangeLog | 7 | ||||
| -rw-r--r-- | generic/tclCompCmds.c | 179 | ||||
| -rw-r--r-- | generic/tclCompExpr.c | 340 | ||||
| -rw-r--r-- | generic/tclCompile.c | 10 | ||||
| -rw-r--r-- | generic/tclCompile.h | 5 | ||||
| -rw-r--r-- | generic/tclDictObj.c | 213 | ||||
| -rw-r--r-- | generic/tclExecute.c | 45 | ||||
| -rw-r--r-- | generic/tclInt.h | 8 |
8 files changed, 584 insertions, 223 deletions
@@ -1,3 +1,10 @@ +2011-10-02 Donal K. Fellows <dkf@users.sf.net> + + * generic/tclDictObj.c (TclDictWithInit, TclDictWithFinish): + * generic/tclCompCmds.c (TclCompileDictWithCmd): Experimental + compilation for the [dict with] subcommand, using parts factored out + from the interpreted version of the command. + 2011-09-29 Donal K. Fellows <dkf@users.sf.net> * tools/tcltk-man2html.tcl, tools/tcltk-man2html-utils.tcl: More diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 66c03ab..172a58d 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -1234,6 +1234,185 @@ TclCompileDictLappendCmd( TclEmitInstInt4( INST_DICT_LAPPEND, dictVarIndex, envPtr); return TCL_OK; } + +int +TclCompileDictWithCmd( + Tcl_Interp *interp, /* Used for looking up stuff. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + int i, range, varNameTmp, pathTmp, keysTmp, gotPath; + Tcl_Token *dictVarTokenPtr, *tokenPtr; + int savedStackDepth = envPtr->currStackDepth; + JumpFixup jumpFixup; + + /* + * There must be at least one argument after the command and we must be in + * a procedure so we can have local temporaries. + */ + + if (envPtr->procPtr == NULL) { + return TCL_ERROR; + } + if (parsePtr->numWords < 3) { + return TCL_ERROR; + } + + /* + * Parse the command (trivially). Expect the following: + * dict with <any (varName)> ?<any> ...? <literal> + */ + + dictVarTokenPtr = TokenAfter(parsePtr->tokenPtr); + tokenPtr = TokenAfter(dictVarTokenPtr); + for (i=3 ; i<parsePtr->numWords ; i++) { + tokenPtr = TokenAfter(tokenPtr); + } + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_ERROR; + } + + /* + * Allocate local (unnamed, untraced) working variables. + */ + + gotPath = (parsePtr->numWords > 3); + varNameTmp = TclFindCompiledLocal(NULL, 0, 1, envPtr); + if (gotPath) { + pathTmp = TclFindCompiledLocal(NULL, 0, 1, envPtr); + } else { + pathTmp = -1; + } + keysTmp = TclFindCompiledLocal(NULL, 0, 1, envPtr); + + /* + * Issue instructions. First, the part to expand the dictionary. + */ + + tokenPtr = dictVarTokenPtr; + CompileWord(envPtr, tokenPtr, interp, 0); + if (varNameTmp <= 255) { + TclEmitInstInt1( INST_STORE_SCALAR1, varNameTmp, envPtr); + } else { + TclEmitInstInt4( INST_STORE_SCALAR4, varNameTmp, envPtr); + } + tokenPtr = TokenAfter(tokenPtr); + if (gotPath) { + for (i=2 ; i<parsePtr->numWords-1 ; i++) { + CompileWord(envPtr, tokenPtr, interp, i-1); + tokenPtr = TokenAfter(tokenPtr); + } + TclEmitInstInt4( INST_LIST, parsePtr->numWords-3,envPtr); + if (pathTmp <= 255) { + TclEmitInstInt1( INST_STORE_SCALAR1, pathTmp, envPtr); + } else { + TclEmitInstInt4( INST_STORE_SCALAR4, pathTmp, envPtr); + } + TclEmitOpcode( INST_POP, envPtr); + } + TclEmitOpcode( INST_LOAD_STK, envPtr); + if (gotPath) { + if (pathTmp <= 255) { + TclEmitInstInt1( INST_LOAD_SCALAR1, pathTmp, envPtr); + } else { + TclEmitInstInt4( INST_LOAD_SCALAR4, pathTmp, envPtr); + } + } else { + PushLiteral(envPtr, "", 0); + } + TclEmitOpcode( INST_DICT_EXPAND, envPtr); + if (keysTmp <= 255) { + TclEmitInstInt1( INST_STORE_SCALAR1, keysTmp, envPtr); + } else { + TclEmitInstInt4( INST_STORE_SCALAR4, keysTmp, envPtr); + } + TclEmitOpcode( INST_POP, envPtr); + + /* + * Now the body of the [dict with]. + */ + + range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); + TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); + + ExceptionRangeStarts(envPtr, range); + envPtr->currStackDepth++; + SetLineInformation(parsePtr->numWords-1); + CompileBody(envPtr, tokenPtr, interp); + envPtr->currStackDepth = savedStackDepth; + ExceptionRangeEnds(envPtr, range); + + /* + * Now fold the results back into the dictionary in the OK case. + */ + + TclEmitOpcode( INST_END_CATCH, envPtr); + if (varNameTmp <= 255) { + TclEmitInstInt1( INST_LOAD_SCALAR1, varNameTmp, envPtr); + } else { + TclEmitInstInt4( INST_LOAD_SCALAR4, varNameTmp, envPtr); + } + if (gotPath) { + if (pathTmp <= 255) { + TclEmitInstInt1( INST_LOAD_SCALAR1, pathTmp, envPtr); + } else { + TclEmitInstInt4( INST_LOAD_SCALAR4, pathTmp, envPtr); + } + } else { + PushLiteral(envPtr, "", 0); + } + if (keysTmp <= 255) { + TclEmitInstInt1( INST_LOAD_SCALAR1, keysTmp, envPtr); + } else { + TclEmitInstInt4( INST_LOAD_SCALAR4, keysTmp, envPtr); + } + TclEmitOpcode( INST_DICT_RECOMBINE, envPtr); + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); + + /* + * Now fold the results back into the dictionary in the exception case. + */ + + ExceptionRangeTarget(envPtr, range, catchOffset); + TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); + TclEmitOpcode( INST_PUSH_RESULT, envPtr); + TclEmitOpcode( INST_END_CATCH, envPtr); + if (varNameTmp <= 255) { + TclEmitInstInt1( INST_LOAD_SCALAR1, varNameTmp, envPtr); + } else { + TclEmitInstInt4( INST_LOAD_SCALAR4, varNameTmp, envPtr); + } + if (parsePtr->numWords > 3) { + if (pathTmp <= 255) { + TclEmitInstInt1( INST_LOAD_SCALAR1, pathTmp, envPtr); + } else { + TclEmitInstInt4( INST_LOAD_SCALAR4, pathTmp, envPtr); + } + } else { + PushLiteral(envPtr, "", 0); + } + if (keysTmp <= 255) { + TclEmitInstInt1( INST_LOAD_SCALAR1, keysTmp, envPtr); + } else { + TclEmitInstInt4( INST_LOAD_SCALAR4, keysTmp, envPtr); + } + TclEmitOpcode( INST_DICT_RECOMBINE, envPtr); + TclEmitOpcode( INST_RETURN_STK, envPtr); + + /* + * Prepare for the start of the next command. + */ + + if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { + Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d", + (int) (CurrentOffset(envPtr) - jumpFixup.codeOffset)); + } + return TCL_OK; +} /* *---------------------------------------------------------------------- diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index d96670c..b043fed 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -167,135 +167,135 @@ enum Marks { /* Leaf lexemes */ -#define NUMBER ( LEAF | 1) /* For literal numbers */ -#define SCRIPT ( LEAF | 2) /* Script substitution; [foo] */ -#define BOOLEAN ( LEAF | BAREWORD) /* For literal booleans */ -#define BRACED ( LEAF | 4) /* Braced string; {foo bar} */ -#define VARIABLE ( LEAF | 5) /* Variable substitution; $x */ -#define QUOTED ( LEAF | 6) /* Quoted string; "foo $bar [soom]" */ -#define EMPTY ( LEAF | 7) /* Used only for an empty argument - * list to a function. Represents the - * empty string within parens in the - * expression: rand() */ +#define NUMBER (LEAF | 1) + /* For literal numbers */ +#define SCRIPT (LEAF | 2) + /* Script substitution; [foo] */ +#define BOOLEAN (LEAF | BAREWORD) + /* For literal booleans */ +#define BRACED (LEAF | 4) + /* Braced string; {foo bar} */ +#define VARIABLE (LEAF | 5) + /* Variable substitution; $x */ +#define QUOTED (LEAF | 6) + /* Quoted string; "foo $bar [soom]" */ +#define EMPTY (LEAF | 7) + /* Used only for an empty argument list to a + * function. Represents the empty string + * within parens in the expression: rand() */ /* Unary operator lexemes */ -#define UNARY_PLUS ( UNARY | PLUS) -#define UNARY_MINUS ( UNARY | MINUS) -#define FUNCTION ( UNARY | BAREWORD) /* This is a bit of "creative - * interpretation" on the part of the - * parser. A function call is parsed - * into the parse tree according to - * the perspective that the function - * name is a unary operator and its - * argument list, enclosed in parens, - * is its operand. The additional - * requirements not implied generally - * by treatment as a unary operator -- - * for example, the requirement that - * the operand be enclosed in parens - * -- are hard coded in the relevant - * portions of ParseExpr(). We trade - * off the need to include such - * exceptional handling in the code - * against the need we would otherwise - * have for more lexeme categories. */ -#define START ( UNARY | 4) /* This lexeme isn't parsed from the - * expression text at all. It - * represents the start of the - * expression and sits at the root of - * the parse tree where it serves as - * the start/end point of - * traversals. */ -#define OPEN_PAREN ( UNARY | 5) /* Another bit of creative - * interpretation, where we treat "(" - * as a unary operator with the - * sub-expression between it and its - * matching ")" as its operand. See - * CLOSE_PAREN below. */ -#define NOT ( UNARY | 6) -#define BIT_NOT ( UNARY | 7) +#define UNARY_PLUS (UNARY | PLUS) +#define UNARY_MINUS (UNARY | MINUS) +#define FUNCTION (UNARY | BAREWORD) + /* This is a bit of "creative interpretation" + * on the part of the parser. A function call + * is parsed into the parse tree according to + * the perspective that the function name is a + * unary operator and its argument list, + * enclosed in parens, is its operand. The + * additional requirements not implied + * generally by treatment as a unary operator + * -- for example, the requirement that the + * operand be enclosed in parens -- are hard + * coded in the relevant portions of + * ParseExpr(). We trade off the need to + * include such exceptional handling in the + * code against the need we would otherwise + * have for more lexeme categories. */ +#define START (UNARY | 4) + /* This lexeme isn't parsed from the + * expression text at all. It represents the + * start of the expression and sits at the + * root of the parse tree where it serves as + * the start/end point of traversals. */ +#define OPEN_PAREN (UNARY | 5) + /* Another bit of creative interpretation, + * where we treat "(" as a unary operator with + * the sub-expression between it and its + * matching ")" as its operand. See + * CLOSE_PAREN below. */ +#define NOT (UNARY | 6) +#define BIT_NOT (UNARY | 7) /* Binary operator lexemes */ -#define BINARY_PLUS ( BINARY | PLUS) -#define BINARY_MINUS ( BINARY | MINUS) -#define COMMA ( BINARY | 3) /* The "," operator is a low - * precedence binary operator that - * separates the arguments in a - * function call. The additional - * constraint that this operator can - * only legally appear at the right - * places within a function call - * argument list are hard coded within - * ParseExpr(). */ -#define MULT ( BINARY | 4) -#define DIVIDE ( BINARY | 5) -#define MOD ( BINARY | 6) -#define LESS ( BINARY | 7) -#define GREATER ( BINARY | 8) -#define BIT_AND ( BINARY | 9) -#define BIT_XOR ( BINARY | 10) -#define BIT_OR ( BINARY | 11) -#define QUESTION ( BINARY | 12) /* These two lexemes make up the */ -#define COLON ( BINARY | 13) /* ternary conditional operator, - * $x ? $y : $z . We treat them as two - * binary operators to avoid another - * lexeme category, and code the - * additional constraints directly in - * ParseExpr(). For instance, the - * right operand of a "?" operator - * must be a ":" operator. */ -#define LEFT_SHIFT ( BINARY | 14) -#define RIGHT_SHIFT ( BINARY | 15) -#define LEQ ( BINARY | 16) -#define GEQ ( BINARY | 17) -#define EQUAL ( BINARY | 18) -#define NEQ ( BINARY | 19) -#define AND ( BINARY | 20) -#define OR ( BINARY | 21) -#define STREQ ( BINARY | 22) -#define STRNEQ ( BINARY | 23) -#define EXPON ( BINARY | 24) /* Unlike the other binary operators, - * EXPON is right associative and this - * distinction is coded directly in - * ParseExpr(). */ -#define IN_LIST ( BINARY | 25) -#define NOT_IN_LIST ( BINARY | 26) -#define CLOSE_PAREN ( BINARY | 27) /* By categorizing the CLOSE_PAREN - * lexeme as a BINARY operator, the - * normal parsing rules for binary - * operators assure that a close paren - * will not directly follow another - * operator, and the machinery already - * in place to connect operands to - * operators according to precedence - * performs most of the work of - * matching open and close parens for - * us. In the end though, a close - * paren is not really a binary - * operator, and some special coding - * in ParseExpr() make sure we never - * put an actual CLOSE_PAREN node in - * the parse tree. The sub-expression - * between parens becomes the single - * argument of the matching OPEN_PAREN - * unary operator. */ -#define END ( BINARY | 28) /* This lexeme represents the end of - * the string being parsed. Treating - * it as a binary operator follows the - * same logic as the CLOSE_PAREN - * lexeme and END pairs with START, in - * the same way that CLOSE_PAREN pairs - * with OPEN_PAREN. */ +#define BINARY_PLUS (BINARY | PLUS) +#define BINARY_MINUS (BINARY | MINUS) +#define COMMA (BINARY | 3) + /* The "," operator is a low precedence binary + * operator that separates the arguments in a + * function call. The additional constraint + * that this operator can only legally appear + * at the right places within a function call + * argument list are hard coded within + * ParseExpr(). */ +#define MULT (BINARY | 4) +#define DIVIDE (BINARY | 5) +#define MOD (BINARY | 6) +#define LESS (BINARY | 7) +#define GREATER (BINARY | 8) +#define BIT_AND (BINARY | 9) +#define BIT_XOR (BINARY | 10) +#define BIT_OR (BINARY | 11) +#define QUESTION (BINARY | 12) + /* These two lexemes make up the */ +#define COLON (BINARY | 13) + /* ternary conditional operator, $x ? $y : $z. + * We treat them as two binary operators to + * avoid another lexeme category, and code the + * additional constraints directly in + * ParseExpr(). For instance, the right + * operand of a "?" operator must be a ":" + * operator. */ +#define LEFT_SHIFT (BINARY | 14) +#define RIGHT_SHIFT (BINARY | 15) +#define LEQ (BINARY | 16) +#define GEQ (BINARY | 17) +#define EQUAL (BINARY | 18) +#define NEQ (BINARY | 19) +#define AND (BINARY | 20) +#define OR (BINARY | 21) +#define STREQ (BINARY | 22) +#define STRNEQ (BINARY | 23) +#define EXPON (BINARY | 24) + /* Unlike the other binary operators, EXPON is + * right associative and this distinction is + * coded directly in ParseExpr(). */ +#define IN_LIST (BINARY | 25) +#define NOT_IN_LIST (BINARY | 26) +#define CLOSE_PAREN (BINARY | 27) + /* By categorizing the CLOSE_PAREN lexeme as a + * BINARY operator, the normal parsing rules + * for binary operators assure that a close + * paren will not directly follow another + * operator, and the machinery already in + * place to connect operands to operators + * according to precedence performs most of + * the work of matching open and close parens + * for us. In the end though, a close paren is + * not really a binary operator, and some + * special coding in ParseExpr() make sure we + * never put an actual CLOSE_PAREN node in the + * parse tree. The sub-expression between + * parens becomes the single argument of the + * matching OPEN_PAREN unary operator. */ +#define END (BINARY | 28) + /* This lexeme represents the end of the + * string being parsed. Treating it as a + * binary operator follows the same logic as + * the CLOSE_PAREN lexeme and END pairs with + * START, in the same way that CLOSE_PAREN + * pairs with OPEN_PAREN. */ + /* * When ParseExpr() builds the parse tree it must choose which operands to * connect to which operators. This is done according to operator precedence. - * The greater an operator's precedence the greater claim it has to link to - * an available operand. The Precedence enumeration lists the precedence - * values used by Tcl expression operators, from lowest to highest claim. - * Each precedence level is commented with the operators that hold that - * precedence. + * The greater an operator's precedence the greater claim it has to link to an + * available operand. The Precedence enumeration lists the precedence values + * used by Tcl expression operators, from lowest to highest claim. Each + * precedence level is commented with the operators that hold that precedence. */ enum Precedence { @@ -320,9 +320,9 @@ enum Precedence { }; /* - * Here the same information contained in the comments above is stored - * in inverted form, so that given a lexeme, one can quickly look up - * its precedence value. + * Here the same information contained in the comments above is stored in + * inverted form, so that given a lexeme, one can quickly look up its + * precedence value. */ static const unsigned char prec[] = { @@ -599,7 +599,10 @@ ParseExpr( * actual leaf at the time the complete tree * is needed. */ - /* These variables control generation of the error message. */ + /* + * These variables control generation of the error message. + */ + Tcl_Obj *msg = NULL; /* The error message. */ Tcl_Obj *post = NULL; /* In a few cases, an additional postscript * for the error message, supplying more @@ -801,17 +804,19 @@ ParseExpr( } } /* Uncategorized lexemes */ - /* Handle lexeme based on its category. */ - switch (NODE_TYPE & lexeme) { - /* - * Each LEAF results in either a literal getting appended to the - * litList, or a sequence of Tcl_Tokens representing a Tcl word - * getting appended to the parsePtr->tokens. No OpNode is filled for - * this lexeme. + * Handle lexeme based on its category. */ + switch (NODE_TYPE & lexeme) { case LEAF: { + /* + * Each LEAF results in either a literal getting appended to the + * litList, or a sequence of Tcl_Tokens representing a Tcl word + * getting appended to the parsePtr->tokens. No OpNode is filled + * for this lexeme. + */ + Tcl_Token *tokenPtr; const char *end = start; int wordIndex; @@ -828,7 +833,10 @@ ParseExpr( scanned = 0; insertMark = 1; - /* Free any literal to avoid a memleak. */ + /* + * Free any literal to avoid a memleak. + */ + if ((lexeme == NUMBER) || (lexeme == BOOLEAN)) { Tcl_DecrRefCount(literal); } @@ -1027,7 +1035,10 @@ ParseExpr( goto error; } - /* Create an OpNode for the unary operator */ + /* + * Create an OpNode for the unary operator. + */ + nodePtr->lexeme = lexeme; nodePtr->precedence = prec[lexeme]; nodePtr->mark = MARK_RIGHT; @@ -1498,7 +1509,10 @@ ConvertTreeToTokens( case OT_LITERAL: - /* Skip any white space that comes before the literal */ + /* + * Skip any white space that comes before the literal. + */ + scanned = TclParseAllWhiteSpace(start, numBytes); start += scanned; numBytes -= scanned; @@ -1581,7 +1595,10 @@ ConvertTreeToTokens( default: - /* Advance to the child node, which is an operator. */ + /* + * Advance to the child node, which is an operator. + */ + nodePtr = nodes + next; /* @@ -1662,7 +1679,10 @@ ConvertTreeToTokens( case MARK_RIGHT: next = nodePtr->right; - /* Skip any white space that comes before the operator */ + /* + * Skip any white space that comes before the operator. + */ + scanned = TclParseAllWhiteSpace(start, numBytes); start += scanned; numBytes -= scanned; @@ -1679,7 +1699,10 @@ ConvertTreeToTokens( case COMMA: case COLON: - /* No tokens for these lexemes -> nothing to do. */ + /* + * No tokens for these lexemes -> nothing to do. + */ + break; default: @@ -1714,7 +1737,10 @@ ConvertTreeToTokens( case OPEN_PAREN: - /* Skip past matching close paren. */ + /* + * Skip past matching close paren. + */ + scanned = TclParseAllWhiteSpace(start, numBytes); start += scanned; numBytes -= scanned; @@ -1723,7 +1749,7 @@ ConvertTreeToTokens( numBytes -= scanned; break; - default: { + default: /* * Before we leave this node/operator/subexpression for the @@ -1757,7 +1783,6 @@ ConvertTreeToTokens( subExprTokenIdx = parentIdx; break; } - } /* * Since we're returning to parent, skip child handling code. @@ -2009,6 +2034,7 @@ ParseLexeme( */ if (literal->typePtr == &tclDoubleType) { const char *p = start; + while (p < end) { if (!isalnum(UCHAR(*p++))) { /* @@ -2028,6 +2054,7 @@ ParseLexeme( */ goto number; } + /* * Otherwise, fall through and parse the whole as a bareword. */ @@ -2290,22 +2317,22 @@ CompileExprTree( break; } case QUESTION: - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &(jumpPtr->jump)); + TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpPtr->jump); break; case COLON: CLANG_ASSERT(jumpPtr); TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, - &(jumpPtr->next->jump)); + &jumpPtr->next->jump); envPtr->currStackDepth = jumpPtr->depth; jumpPtr->offset = (envPtr->codeNext - envPtr->codeStart); jumpPtr->convert = convert; convert = 1; break; case AND: - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &(jumpPtr->jump)); + TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpPtr->jump); break; case OR: - TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &(jumpPtr->jump)); + TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &jumpPtr->jump); break; } } else { @@ -2348,12 +2375,12 @@ CompileExprTree( break; case COLON: CLANG_ASSERT(jumpPtr); - if (TclFixupForwardJump(envPtr, &(jumpPtr->next->jump), + if (TclFixupForwardJump(envPtr, &jumpPtr->next->jump, (envPtr->codeNext - envPtr->codeStart) - jumpPtr->next->jump.codeOffset, 127)) { jumpPtr->offset += 3; } - TclFixupForwardJump(envPtr, &(jumpPtr->jump), + TclFixupForwardJump(envPtr, &jumpPtr->jump, jumpPtr->offset - jumpPtr->jump.codeOffset, 127); convert |= jumpPtr->convert; envPtr->currStackDepth = jumpPtr->depth + 1; @@ -2369,18 +2396,18 @@ CompileExprTree( CLANG_ASSERT(jumpPtr); TclEmitForwardJump(envPtr, (nodePtr->lexeme == AND) ? TCL_FALSE_JUMP : TCL_TRUE_JUMP, - &(jumpPtr->next->jump)); + &jumpPtr->next->jump); TclEmitPush(TclRegisterNewLiteral(envPtr, (nodePtr->lexeme == AND) ? "1" : "0", 1), envPtr); TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, - &(jumpPtr->next->next->jump)); - TclFixupForwardJumpToHere(envPtr, &(jumpPtr->next->jump), 127); - if (TclFixupForwardJumpToHere(envPtr, &(jumpPtr->jump), 127)) { + &jumpPtr->next->next->jump); + TclFixupForwardJumpToHere(envPtr, &jumpPtr->next->jump, 127); + if (TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump, 127)) { jumpPtr->next->next->jump.codeOffset += 3; } TclEmitPush(TclRegisterNewLiteral(envPtr, (nodePtr->lexeme == AND) ? "0" : "1", 1), envPtr); - TclFixupForwardJumpToHere(envPtr, &(jumpPtr->next->next->jump), + TclFixupForwardJumpToHere(envPtr, &jumpPtr->next->next->jump, 127); convert = 0; envPtr->currStackDepth = jumpPtr->depth + 1; @@ -2400,8 +2427,8 @@ CompileExprTree( break; } if (nodePtr == rootPtr) { - /* We're done */ + return; } nodePtr = nodes + nodePtr->p.parent; @@ -2478,6 +2505,7 @@ CompileExprTree( * Don't generate a string rep, but if we have one * already, then use it to share via the literal table. */ + if (objPtr->bytes) { Tcl_Obj *tableValue; @@ -2486,7 +2514,10 @@ CompileExprTree( tableValue = envPtr->literalArrayPtr[index].objPtr; if ((tableValue->typePtr == NULL) && (objPtr->typePtr != NULL)) { - /* Same intrep surgery as for OT_LITERAL */ + /* + * Same intrep surgery as for OT_LITERAL. + */ + tableValue->typePtr = objPtr->typePtr; tableValue->internalRep = objPtr->internalRep; objPtr->typePtr = NULL; @@ -2511,6 +2542,7 @@ CompileExprTree( *---------------------------------------------------------------------- * * TclSingleOpCmd -- + * * Implements the commands: ~, !, <<, >>, %, !=, ne, in, ni * in the ::tcl::mathop namespace. These commands have no * extension to arbitrary arguments; they accept only exactly one @@ -2537,7 +2569,7 @@ TclSingleOpCmd( OpNode nodes[2]; Tcl_Obj *const *litObjv = objv + 1; - if (objc != 1+occdPtr->i.numArgs) { + if (objc != 1 + occdPtr->i.numArgs) { Tcl_WrongNumArgs(interp, 1, objv, occdPtr->expected); return TCL_ERROR; } diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 026503b..4b5d2bb 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -421,6 +421,16 @@ InstructionDesc const tclInstructionTable[] = { /* Make general variable cease to exist; unparsed variable name is * stktop; op1 is 1 for errors on problems, 0 otherwise */ + {"dictExpand", 1, -1, 0, {OPERAND_NONE}}, + /* Probe into a dict and extract it (or a subdict of it) into + * variables with matched names. Produces list of keys bound as + * result. Part of [dict with]. + * Stack: ... dict path => ... keyList */ + {"dictRecombine", 1, -3, 0, {OPERAND_NONE}}, + /* Map variable contents back into a dictionary in a variable. Part of + * [dict with]. + * Stack: ... dictVarName path keyList => ... */ + {NULL, 0, 0, 0, {OPERAND_NONE}} }; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 45d50ea..0cd667c 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -676,8 +676,11 @@ typedef struct ByteCode { #define INST_UNSET_ARRAY_STK 136 #define INST_UNSET_STK 137 +#define INST_DICT_EXPAND 138 +#define INST_DICT_RECOMBINE 139 + /* The last opcode */ -#define LAST_INST_OPCODE 137 +#define LAST_INST_OPCODE 139 /* * Table describing the Tcl bytecode instructions: their name (for displaying diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 83fc3a6..5b7ca9b 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -103,7 +103,7 @@ static const EnsembleImplMap implementationMap[] = { {"unset", DictUnsetCmd, NULL, NULL, NULL, 0 }, {"update", DictUpdateCmd, TclCompileDictUpdateCmd, NULL, NULL, 0 }, {"values", DictValuesCmd, NULL, NULL, NULL, 0 }, - {"with", DictWithCmd, NULL, NULL, NULL, 0 }, + {"with", DictWithCmd, TclCompileDictWithCmd, NULL, NULL, 0 }, {NULL, NULL, NULL, NULL, NULL, 0} }; @@ -3110,9 +3110,7 @@ DictWithCmd( Tcl_Obj *const *objv) { Interp *iPtr = (Interp *) interp; - Tcl_Obj *dictPtr, *keysPtr, *keyPtr = NULL, *valPtr = NULL, *pathPtr; - Tcl_DictSearch s; - int done; + Tcl_Obj *dictPtr, *keysPtr, *pathPtr; if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "dictVar ?key ...? script"); @@ -3127,39 +3125,13 @@ DictWithCmd( if (dictPtr == NULL) { return TCL_ERROR; } - if (objc > 3) { - dictPtr = TclTraceDictPath(interp, dictPtr, objc-3, objv+2, - DICT_PATH_READ); - if (dictPtr == NULL) { - return TCL_ERROR; - } - } - /* - * Go over the list of keys and write each corresponding value to a - * variable in the current context with the same name. Also keep a copy of - * the keys so we can write back properly later on even if the dictionary - * has been structurally modified. - */ - - if (Tcl_DictObjFirst(interp, dictPtr, &s, &keyPtr, &valPtr, - &done) != TCL_OK) { + keysPtr = TclDictWithInit(interp, dictPtr, objc-3, objv+2); + if (keysPtr == NULL) { return TCL_ERROR; } - - TclNewObj(keysPtr); Tcl_IncrRefCount(keysPtr); - for (; !done ; Tcl_DictObjNext(&s, &keyPtr, &valPtr, &done)) { - Tcl_ListObjAppendElement(NULL, keysPtr, keyPtr); - if (Tcl_ObjSetVar2(interp, keyPtr, NULL, valPtr, - TCL_LEAVE_ERR_MSG) == NULL) { - TclDecrRefCount(keysPtr); - Tcl_DictObjDone(&s); - return TCL_ERROR; - } - } - /* * Execute the body, while making the invoking context available to the * loop body (TIP#280) and postponing the cleanup until later (NRE). @@ -3183,8 +3155,8 @@ FinalizeDictWith( Tcl_Interp *interp, int result) { - Tcl_Obj **keyv, *leafPtr, *dictPtr, *valPtr; - int keyc, i, allocdict = 0; + Tcl_Obj **pathv; + int pathc; Tcl_InterpState state; Tcl_Obj *varName = data[0]; Tcl_Obj *keysPtr = data[1]; @@ -3195,43 +3167,163 @@ FinalizeDictWith( } /* + * Save the result state; TDWF doesn't guarantee to not modify that on + * TCL_OK result. + */ + + state = Tcl_SaveInterpState(interp, result); + if (pathPtr != NULL) { + Tcl_ListObjGetElements(NULL, pathPtr, &pathc, &pathv); + } else { + pathc = 0; + pathv = NULL; + } + + /* + * Pack from local variables back into the dictionary. + */ + + result = TclDictWithFinish(interp, varName, pathc, pathv, keysPtr); + + /* + * Tidy up and return the real result (unless we had an error). + */ + + TclDecrRefCount(varName); + TclDecrRefCount(keysPtr); + if (pathPtr != NULL) { + TclDecrRefCount(pathPtr); + } + if (result != TCL_OK) { + Tcl_DiscardInterpState(state); + return TCL_ERROR; + } + return Tcl_RestoreInterpState(interp, state); +} + +/* + *---------------------------------------------------------------------- + * + * TclDictWithInit -- + * + * Part of the core of [dict with]. Pokes into a dictionary and converts + * the mappings there into assignments to (presumably) local variables. + * Returns a list of all the names that were mapped so that removal of + * either the variable or the dictionary entry won't surprise us when we + * come to stuffing everything back. + * + * Result: + * List of mapped names, or NULL if there was an error. + * + * Side effects: + * Assigns to variables, so potentially legion due to traces. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclDictWithInit( + Tcl_Interp *interp, + Tcl_Obj *dictPtr, + int pathc, + Tcl_Obj *const pathv[]) +{ + Tcl_DictSearch s; + Tcl_Obj *keyPtr, *valPtr, *keysPtr; + int done; + + if (pathc > 0) { + dictPtr = TclTraceDictPath(interp, dictPtr, pathc, pathv, + DICT_PATH_READ); + if (dictPtr == NULL) { + return NULL; + } + } + + /* + * Go over the list of keys and write each corresponding value to a + * variable in the current context with the same name. Also keep a copy of + * the keys so we can write back properly later on even if the dictionary + * has been structurally modified. + */ + + if (Tcl_DictObjFirst(interp, dictPtr, &s, &keyPtr, &valPtr, + &done) != TCL_OK) { + return NULL; + } + + TclNewObj(keysPtr); + + for (; !done ; Tcl_DictObjNext(&s, &keyPtr, &valPtr, &done)) { + Tcl_ListObjAppendElement(NULL, keysPtr, keyPtr); + if (Tcl_ObjSetVar2(interp, keyPtr, NULL, valPtr, + TCL_LEAVE_ERR_MSG) == NULL) { + TclDecrRefCount(keysPtr); + Tcl_DictObjDone(&s); + return NULL; + } + } + + return keysPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclDictWithFinish -- + * + * Part of the core of [dict with]. Reassembles the piece of the dict (in + * varName, location given by pathc/pathv) from the variables named in + * the keysPtr argument. NB, does not try to preserve errors or manage + * argument lifetimes. + * + * Result: + * TCL_OK if we succeeded, or TCL_ERROR if we failed. + * + * Side effects: + * Assigns to a variable, so potentially legion due to traces. Updates + * the dictionary in the named variable. + * + *---------------------------------------------------------------------- + */ + +int +TclDictWithFinish( + Tcl_Interp *interp, + Tcl_Obj *varName, + int pathc, + Tcl_Obj *const pathv[], + Tcl_Obj *keysPtr) +{ + Tcl_Obj *dictPtr, *leafPtr, *valPtr; + int i, allocdict, keyc; + Tcl_Obj **keyv; + + /* * If the dictionary variable doesn't exist, drop everything silently. */ dictPtr = Tcl_ObjGetVar2(interp, varName, NULL, 0); if (dictPtr == NULL) { - TclDecrRefCount(varName); - TclDecrRefCount(keysPtr); - if (pathPtr) { - TclDecrRefCount(pathPtr); - } - return result; + return TCL_OK; } /* * Double-check that it is still a dictionary. */ - state = Tcl_SaveInterpState(interp, result); if (Tcl_DictObjSize(interp, dictPtr, &i) != TCL_OK) { - TclDecrRefCount(varName); - TclDecrRefCount(keysPtr); - if (pathPtr) { - TclDecrRefCount(pathPtr); - } - Tcl_DiscardInterpState(state); return TCL_ERROR; } if (Tcl_IsShared(dictPtr)) { dictPtr = Tcl_DuplicateObj(dictPtr); allocdict = 1; + } else { + allocdict = 0; } - if (pathPtr != NULL) { - Tcl_Obj **pathv; - int pathc; - + if (pathc > 0) { /* * Want to get to the dictionary which we will update; need to do * prepare-for-update de-sharing along the path *but* avoid generating @@ -3241,26 +3333,19 @@ FinalizeDictWith( * perfectly efficient (but no memory should be leaked). */ - Tcl_ListObjGetElements(NULL, pathPtr, &pathc, &pathv); leafPtr = TclTraceDictPath(interp, dictPtr, pathc, pathv, DICT_PATH_EXISTS | DICT_PATH_UPDATE); - TclDecrRefCount(pathPtr); if (leafPtr == NULL) { - TclDecrRefCount(varName); - TclDecrRefCount(keysPtr); if (allocdict) { TclDecrRefCount(dictPtr); } - Tcl_DiscardInterpState(state); return TCL_ERROR; } if (leafPtr == DICT_PATH_NON_EXISTENT) { - TclDecrRefCount(varName); - TclDecrRefCount(keysPtr); if (allocdict) { TclDecrRefCount(dictPtr); } - return Tcl_RestoreInterpState(interp, state); + return TCL_OK; } } else { leafPtr = dictPtr; @@ -3286,14 +3371,13 @@ FinalizeDictWith( Tcl_DictObjPut(NULL, leafPtr, keyv[i], valPtr); } } - TclDecrRefCount(keysPtr); /* * Ensure that none of the dictionaries in the chain still have a string * rep. */ - if (pathPtr != NULL) { + if (pathc > 0) { InvalidateDictChain(leafPtr); } @@ -3303,11 +3387,12 @@ FinalizeDictWith( if (Tcl_ObjSetVar2(interp, varName, NULL, dictPtr, TCL_LEAVE_ERR_MSG) == NULL) { - Tcl_DiscardInterpState(state); + if (allocdict) { + TclDecrRefCount(dictPtr); + } return TCL_ERROR; } - TclDecrRefCount(varName); - return Tcl_RestoreInterpState(interp, state); + return TCL_OK; } /* diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 691c8d7..e3db83e 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -1992,9 +1992,8 @@ TclNRExecuteByteCode( * Push the callback for bytecode execution */ - TclNRAddCallback(interp, TEBCresume, TD, - /*resume*/ INT2PTR(0), NULL, NULL); - + TclNRAddCallback(interp, TEBCresume, TD, /*resume*/ INT2PTR(0), + NULL, NULL); return TCL_OK; } @@ -5625,7 +5624,7 @@ TEBCresume( { int opnd2, allocateDict, done, i, allocdict; - Tcl_Obj *dictPtr, *statePtr, *keyPtr; + Tcl_Obj *dictPtr, *statePtr, *keyPtr, *listPtr, *varNamePtr, *keysPtr; Tcl_Obj *emptyPtr, **keyPtrPtr; Tcl_DictSearch *searchPtr; DictUpdateInfo *duiPtr; @@ -6105,6 +6104,44 @@ TEBCresume( } } NEXT_INST_F(9, 1, 0); + + case INST_DICT_EXPAND: + dictPtr = OBJ_UNDER_TOS; + listPtr = OBJ_AT_TOS; + if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { + TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ", + O2S(dictPtr), O2S(listPtr)), Tcl_GetObjResult(interp)); + goto gotError; + } + objResultPtr = TclDictWithInit(interp, dictPtr, objc, objv); + if (objResultPtr == NULL) { + TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ", + O2S(dictPtr), O2S(listPtr)), Tcl_GetObjResult(interp)); + goto gotError; + } + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + + case INST_DICT_RECOMBINE: + varNamePtr = OBJ_AT_DEPTH(2); + listPtr = OBJ_UNDER_TOS; + keysPtr = OBJ_AT_TOS; + if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { + TRACE_WITH_OBJ(("%.30s %.30s %.30s => ERROR: ", + O2S(varNamePtr), O2S(listPtr), O2S(keysPtr)), + Tcl_GetObjResult(interp)); + goto gotError; + } + if (TclDictWithFinish(interp, varNamePtr, objc, objv, + keysPtr) != TCL_OK) { + TRACE_WITH_OBJ(("%.30s %.30s %.30s => ERROR: ", + O2S(varNamePtr), O2S(listPtr), O2S(keysPtr)), + Tcl_GetObjResult(interp)); + goto gotError; + } + TclDecrRefCount(keysPtr); + POP_OBJECT(); + NEXT_INST_F(1, 2, 0); } /* diff --git a/generic/tclInt.h b/generic/tclInt.h index f30e83e..e7a84ce 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3231,6 +3231,11 @@ MODULE_SCOPE int TclDefaultBgErrorHandlerObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_Command TclInitDictCmd(Tcl_Interp *interp); +MODULE_SCOPE int TclDictWithFinish(Tcl_Interp *interp, + Tcl_Obj *varName, int pathc, + Tcl_Obj *const pathv[], Tcl_Obj *keysPtr); +MODULE_SCOPE Tcl_Obj * TclDictWithInit(Tcl_Interp *interp, Tcl_Obj *dictPtr, + int pathc, Tcl_Obj *const pathv[]); MODULE_SCOPE int Tcl_DisassembleObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -3495,6 +3500,9 @@ MODULE_SCOPE int TclCompileDictSetCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileDictUpdateCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileDictWithCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileEnsemble(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); |