summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tcl.h6
-rw-r--r--generic/tclAssembly.c3
-rw-r--r--generic/tclCompCmds.c677
-rw-r--r--generic/tclCompExpr.c340
-rw-r--r--generic/tclCompile.c14
-rw-r--r--generic/tclCompile.h7
-rw-r--r--generic/tclDictObj.c244
-rw-r--r--generic/tclExecute.c79
-rw-r--r--generic/tclIORTrans.c2
-rw-r--r--generic/tclInt.h9
-rw-r--r--generic/tclNamesp.c2
-rw-r--r--generic/tclTest.c6
12 files changed, 932 insertions, 457 deletions
diff --git a/generic/tcl.h b/generic/tcl.h
index 7a94956..1bc3a89 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -2276,12 +2276,12 @@ typedef int (Tcl_ArgvGenFuncProc)(ClientData clientData, Tcl_Interp *interp,
#define TCL_ARGV_AUTO_HELP \
{TCL_ARGV_HELP, "-help", NULL, NULL, \
- "Print summary of command-line options and abort"}
+ "Print summary of command-line options and abort", NULL}
#define TCL_ARGV_AUTO_REST \
{TCL_ARGV_REST, "--", NULL, NULL, \
- "Marks the end of the options"}
+ "Marks the end of the options", NULL}
#define TCL_ARGV_TABLE_END \
- {TCL_ARGV_END}
+ {TCL_ARGV_END, NULL, NULL, NULL, NULL, NULL}
/*
*----------------------------------------------------------------------------
diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index cd6dc38..5b32ab0 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -370,10 +370,13 @@ TalInstDesc TalInstructionTable[] = {
{"bitxor", ASSEM_1BYTE, INST_BITXOR, 2, 1},
{"concat", ASSEM_CONCAT1, INST_CONCAT1, INT_MIN,1},
{"dictAppend", ASSEM_LVT4, INST_DICT_APPEND, 2, 1},
+ {"dictExpand", ASSEM_1BYTE, INST_DICT_EXPAND, 3, 1},
{"dictGet", ASSEM_DICT_GET, INST_DICT_GET, INT_MIN,1},
{"dictIncrImm", ASSEM_SINT4_LVT4,
INST_DICT_INCR_IMM, 1, 1},
{"dictLappend", ASSEM_LVT4, INST_DICT_LAPPEND, 2, 1},
+ {"dictRecombineStk",ASSEM_1BYTE, INST_DICT_RECOMBINE_STK,3, 0},
+ {"dictRecombineImm",ASSEM_LVT4, INST_DICT_RECOMBINE_IMM,2, 0},
{"dictSet", ASSEM_DICT_SET, INST_DICT_SET, INT_MIN,1},
{"dictUnset", ASSEM_DICT_UNSET,
INST_DICT_UNSET, INT_MIN,1},
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 66c03ab..69b44ed 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -83,6 +83,18 @@ static int PushVarName(Tcl_Interp *interp,
mapPtr->loc[eclIndex].next[(word)])
/*
+ * Often want to issue one of two versions of an instruction based on whether
+ * the argument will fit in a single byte or not. This makes it much clearer.
+ */
+
+#define Emit14Inst(nm,idx,envPtr) \
+ if (idx <= 255) { \
+ TclEmitInstInt1(nm##1,idx,envPtr); \
+ } else { \
+ TclEmitInstInt4(nm##4,idx,envPtr); \
+ }
+
+/*
* Flags bits used by PushVarName.
*/
@@ -186,18 +198,14 @@ TclCompileAppendCmd(
if (isScalar) {
if (localIndex < 0) {
TclEmitOpcode(INST_APPEND_STK, envPtr);
- } else if (localIndex <= 255) {
- TclEmitInstInt1(INST_APPEND_SCALAR1, localIndex, envPtr);
} else {
- TclEmitInstInt4(INST_APPEND_SCALAR4, localIndex, envPtr);
+ Emit14Inst(INST_APPEND_SCALAR, localIndex, envPtr);
}
} else {
if (localIndex < 0) {
TclEmitOpcode(INST_APPEND_ARRAY_STK, envPtr);
- } else if (localIndex <= 255) {
- TclEmitInstInt1(INST_APPEND_ARRAY1, localIndex, envPtr);
} else {
- TclEmitInstInt4(INST_APPEND_ARRAY4, localIndex, envPtr);
+ Emit14Inst(INST_APPEND_ARRAY, localIndex, envPtr);
}
}
} else {
@@ -366,16 +374,16 @@ TclCompileCatchCmd(
SetLineInformation(1);
if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
savedStackDepth = envPtr->currStackDepth;
- TclEmitInstInt4(INST_BEGIN_CATCH4, range, envPtr);
+ TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr);
ExceptionRangeStarts(envPtr, range);
CompileBody(envPtr, cmdTokenPtr, interp);
} else {
CompileTokens(envPtr, cmdTokenPtr, interp);
savedStackDepth = envPtr->currStackDepth;
- TclEmitInstInt4(INST_BEGIN_CATCH4, range, envPtr);
+ TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr);
ExceptionRangeStarts(envPtr, range);
- TclEmitOpcode(INST_DUP, envPtr);
- TclEmitOpcode(INST_EVAL_STK, envPtr);
+ TclEmitOpcode( INST_DUP, envPtr);
+ TclEmitOpcode( INST_EVAL_STK, envPtr);
}
/* Stack at this point:
* nonsimple: script <mark> result
@@ -399,8 +407,8 @@ TclCompileCatchCmd(
envPtr->currStackDepth = savedStackDepth;
ExceptionRangeTarget(envPtr, range, catchOffset);
/* Stack at this point: ?script? */
- TclEmitOpcode(INST_PUSH_RESULT, envPtr);
- TclEmitOpcode(INST_PUSH_RETURN_CODE, envPtr);
+ TclEmitOpcode( INST_PUSH_RESULT, envPtr);
+ TclEmitOpcode( INST_PUSH_RETURN_CODE, envPtr);
/*
* Update the target of the jump after the "no errors" code.
@@ -415,7 +423,7 @@ TclCompileCatchCmd(
/* Push the return options if the caller wants them */
if (optsIndex != -1) {
- TclEmitOpcode(INST_PUSH_RETURN_OPTIONS, envPtr);
+ TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr);
}
/*
@@ -423,7 +431,7 @@ TclCompileCatchCmd(
*/
ExceptionRangeEnds(envPtr, range);
- TclEmitOpcode(INST_END_CATCH, envPtr);
+ TclEmitOpcode( INST_END_CATCH, envPtr);
/*
* At this point, the top of the stack is inconveniently ordered:
@@ -432,9 +440,9 @@ TclCompileCatchCmd(
*/
if (optsIndex != -1) {
- TclEmitInstInt4(INST_REVERSE, 3, envPtr);
+ TclEmitInstInt4( INST_REVERSE, 3, envPtr);
} else {
- TclEmitInstInt4(INST_REVERSE, 2, envPtr);
+ TclEmitInstInt4( INST_REVERSE, 2, envPtr);
}
/*
@@ -442,13 +450,9 @@ TclCompileCatchCmd(
*/
if (resultIndex != -1) {
- if (resultIndex <= 255) {
- TclEmitInstInt1(INST_STORE_SCALAR1, resultIndex, envPtr);
- } else {
- TclEmitInstInt4(INST_STORE_SCALAR4, resultIndex, envPtr);
- }
+ Emit14Inst( INST_STORE_SCALAR, resultIndex, envPtr);
}
- TclEmitOpcode(INST_POP, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
/*
* Stack is now ?script? ?returnOptions? returnCode.
@@ -458,13 +462,9 @@ TclCompileCatchCmd(
*/
if (optsIndex != -1) {
- TclEmitInstInt4(INST_REVERSE, 2, envPtr);
- if (optsIndex <= 255) {
- TclEmitInstInt1(INST_STORE_SCALAR1, optsIndex, envPtr);
- } else {
- TclEmitInstInt4(INST_STORE_SCALAR4, optsIndex, envPtr);
- }
- TclEmitOpcode(INST_POP, envPtr);
+ TclEmitInstInt4( INST_REVERSE, 2, envPtr);
+ Emit14Inst( INST_STORE_SCALAR, optsIndex, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
}
/*
@@ -473,8 +473,8 @@ TclCompileCatchCmd(
*/
if (cmdTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- TclEmitInstInt4(INST_REVERSE, 2, envPtr);
- TclEmitOpcode(INST_POP, envPtr);
+ TclEmitInstInt4( INST_REVERSE, 2, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
}
/*
@@ -844,9 +844,9 @@ TclCompileDictForCmd(
*/
CompileWord(envPtr, dictTokenPtr, interp, 3);
- TclEmitInstInt4( INST_DICT_FIRST, infoIndex, envPtr);
+ TclEmitInstInt4( INST_DICT_FIRST, infoIndex, envPtr);
emptyTargetOffset = CurrentOffset(envPtr);
- TclEmitInstInt4( INST_JUMP_TRUE4, 0, envPtr);
+ TclEmitInstInt4( INST_JUMP_TRUE4, 0, envPtr);
/*
* Now we catch errors from here on so that we can finalize the search
@@ -854,7 +854,7 @@ TclCompileDictForCmd(
*/
catchRange = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
- TclEmitInstInt4( INST_BEGIN_CATCH4, catchRange, envPtr);
+ TclEmitInstInt4( INST_BEGIN_CATCH4, catchRange, envPtr);
ExceptionRangeStarts(envPtr, catchRange);
/*
@@ -862,10 +862,10 @@ TclCompileDictForCmd(
*/
bodyTargetOffset = CurrentOffset(envPtr);
- TclEmitInstInt4( INST_STORE_SCALAR4, keyVarIndex, envPtr);
- TclEmitOpcode( INST_POP, envPtr);
- TclEmitInstInt4( INST_STORE_SCALAR4, valueVarIndex, envPtr);
- TclEmitOpcode( INST_POP, envPtr);
+ Emit14Inst( INST_STORE_SCALAR, keyVarIndex, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ Emit14Inst( INST_STORE_SCALAR, valueVarIndex, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
/*
* Set up the loop exception targets.
@@ -880,7 +880,7 @@ TclCompileDictForCmd(
SetLineInformation(4);
CompileBody(envPtr, bodyTokenPtr, interp);
- TclEmitOpcode( INST_POP, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
/*
* Both exception target ranges (error and loop) end here.
@@ -896,11 +896,11 @@ TclCompileDictForCmd(
*/
ExceptionRangeTarget(envPtr, loopRange, continueOffset);
- TclEmitInstInt4( INST_DICT_NEXT, infoIndex, envPtr);
+ TclEmitInstInt4( INST_DICT_NEXT, infoIndex, envPtr);
jumpDisplacement = bodyTargetOffset - CurrentOffset(envPtr);
- TclEmitInstInt4( INST_JUMP_FALSE4, jumpDisplacement, envPtr);
- TclEmitOpcode( INST_POP, envPtr);
- TclEmitOpcode( INST_POP, envPtr);
+ TclEmitInstInt4( INST_JUMP_FALSE4, jumpDisplacement, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
/*
* Now do the final cleanup for the no-error case (this is where we break
@@ -911,11 +911,11 @@ TclCompileDictForCmd(
*/
ExceptionRangeTarget(envPtr, loopRange, breakOffset);
- TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
- TclEmitInt4( infoIndex, envPtr);
- TclEmitOpcode( INST_END_CATCH, envPtr);
+ TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
+ TclEmitInt4( infoIndex, envPtr);
+ TclEmitOpcode( INST_END_CATCH, envPtr);
endTargetOffset = CurrentOffset(envPtr);
- TclEmitInstInt4( INST_JUMP4, 0, envPtr);
+ TclEmitInstInt4( INST_JUMP4, 0, envPtr);
/*
* Error handler "finally" clause, which force-terminates the iteration
@@ -923,12 +923,12 @@ TclCompileDictForCmd(
*/
ExceptionRangeTarget(envPtr, catchRange, catchOffset);
- TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr);
- TclEmitOpcode( INST_PUSH_RESULT, envPtr);
- TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
- TclEmitInt4( infoIndex, envPtr);
- TclEmitOpcode( INST_END_CATCH, envPtr);
- TclEmitOpcode( INST_RETURN_STK, envPtr);
+ TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr);
+ TclEmitOpcode( INST_PUSH_RESULT, envPtr);
+ TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
+ TclEmitInt4( infoIndex, envPtr);
+ TclEmitOpcode( INST_END_CATCH, envPtr);
+ TclEmitOpcode( INST_RETURN_STK, envPtr);
/*
* Otherwise we're done (the jump after the DICT_FIRST points here) and we
@@ -940,10 +940,10 @@ TclCompileDictForCmd(
jumpDisplacement = CurrentOffset(envPtr) - emptyTargetOffset;
TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDisplacement,
envPtr->codeStart + emptyTargetOffset);
- TclEmitOpcode( INST_POP, envPtr);
- TclEmitOpcode( INST_POP, envPtr);
- TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
- TclEmitInt4( infoIndex, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
+ TclEmitInt4( infoIndex, envPtr);
/*
* Final stage of the command (normal case) is that we push an empty
@@ -1075,12 +1075,12 @@ TclCompileDictUpdateCmd(
for (i=0 ; i<numVars ; i++) {
CompileWord(envPtr, keyTokenPtrs[i], interp, i);
}
- TclEmitInstInt4( INST_LIST, numVars, envPtr);
- TclEmitInstInt4( INST_DICT_UPDATE_START, dictIndex, envPtr);
- TclEmitInt4( infoIndex, envPtr);
+ TclEmitInstInt4( INST_LIST, numVars, envPtr);
+ TclEmitInstInt4( INST_DICT_UPDATE_START, dictIndex, envPtr);
+ TclEmitInt4( infoIndex, envPtr);
range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
- TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr);
+ TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr);
ExceptionRangeStarts(envPtr, range);
envPtr->currStackDepth++;
@@ -1093,10 +1093,10 @@ TclCompileDictUpdateCmd(
* the body evaluation: swap them and finish the update code.
*/
- TclEmitOpcode( INST_END_CATCH, envPtr);
- TclEmitInstInt4( INST_REVERSE, 2, envPtr);
- TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr);
- TclEmitInt4( infoIndex, envPtr);
+ TclEmitOpcode( INST_END_CATCH, envPtr);
+ TclEmitInstInt4( INST_REVERSE, 2, envPtr);
+ TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr);
+ TclEmitInt4( infoIndex, envPtr);
/*
* Jump around the exceptional termination code.
@@ -1111,14 +1111,14 @@ TclCompileDictUpdateCmd(
*/
ExceptionRangeTarget(envPtr, range, catchOffset);
- TclEmitOpcode( INST_PUSH_RESULT, envPtr);
- TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr);
- TclEmitOpcode( INST_END_CATCH, envPtr);
- TclEmitInstInt4( INST_REVERSE, 3, envPtr);
+ TclEmitOpcode( INST_PUSH_RESULT, envPtr);
+ TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr);
+ TclEmitOpcode( INST_END_CATCH, envPtr);
+ TclEmitInstInt4( INST_REVERSE, 3, envPtr);
- TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr);
- TclEmitInt4( infoIndex, envPtr);
- TclEmitOpcode( INST_RETURN_STK, envPtr);
+ TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr);
+ TclEmitInt4( infoIndex, envPtr);
+ TclEmitOpcode( INST_RETURN_STK, envPtr);
if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) {
Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d",
@@ -1231,7 +1231,270 @@ TclCompileDictLappendCmd(
}
CompileWord(envPtr, keyTokenPtr, interp, 3);
CompileWord(envPtr, valueTokenPtr, interp, 4);
- TclEmitInstInt4( INST_DICT_LAPPEND, dictVarIndex, envPtr);
+ 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, dictVar = -1;
+ int bodyIsEmpty = 1;
+ Tcl_Token *varTokenPtr, *tokenPtr;
+ int savedStackDepth = envPtr->currStackDepth;
+ JumpFixup jumpFixup;
+ const char *ptr, *end;
+
+ /*
+ * There must be at least one argument after the command.
+ */
+
+ if (parsePtr->numWords < 3) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Parse the command (trivially). Expect the following:
+ * dict with <any (varName)> ?<any> ...? <literal>
+ */
+
+ varTokenPtr = TokenAfter(parsePtr->tokenPtr);
+ tokenPtr = TokenAfter(varTokenPtr);
+ for (i=3 ; i<parsePtr->numWords ; i++) {
+ tokenPtr = TokenAfter(tokenPtr);
+ }
+ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Test if the last word is an empty script; if so, we can compile it in
+ * all cases, but if it is non-empty we need local variable table entries
+ * to hold the temporary variables (used to keep stack usage simple).
+ */
+
+ for (ptr=tokenPtr[1].start,end=ptr+tokenPtr[1].size ; ptr!=end ; ptr++) {
+ if (*ptr!=' ' && *ptr!='\t' && *ptr!='\n' && *ptr!='\r') {
+ if (envPtr->procPtr == NULL) {
+ return TCL_ERROR;
+ }
+ bodyIsEmpty = 0;
+ break;
+ }
+ }
+
+ /*
+ * Determine if we're manipulating a dict in a simple local variable.
+ */
+
+ gotPath = (parsePtr->numWords > 3);
+ if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD &&
+ TclIsLocalScalar(varTokenPtr[1].start, varTokenPtr[1].size)) {
+ dictVar = TclFindCompiledLocal(varTokenPtr[1].start,
+ varTokenPtr[1].size, 1, envPtr);
+ }
+
+ /*
+ * Special case: an empty body means we definitely have no need to issue
+ * try-finally style code or to allocate local variable table entries for
+ * storing temporaries. Still need to do both INST_DICT_EXPAND and
+ * INST_DICT_RECOMBINE_* though, because we can't determine if we're free
+ * of traces.
+ */
+
+ if (bodyIsEmpty) {
+ if (dictVar >= 0) {
+ if (gotPath) {
+ /*
+ * Case: Path into dict in LVT with empty body.
+ */
+
+ tokenPtr = TokenAfter(varTokenPtr);
+ for (i=2 ; i<parsePtr->numWords-1 ; i++) {
+ CompileWord(envPtr, tokenPtr, interp, i-1);
+ tokenPtr = TokenAfter(tokenPtr);
+ }
+ TclEmitInstInt4(INST_LIST, parsePtr->numWords-3,envPtr);
+ Emit14Inst( INST_LOAD_SCALAR, dictVar, envPtr);
+ TclEmitInstInt4(INST_OVER, 1, envPtr);
+ TclEmitOpcode( INST_DICT_EXPAND, envPtr);
+ TclEmitInstInt4(INST_DICT_RECOMBINE_IMM, dictVar, envPtr);
+ PushLiteral(envPtr, "", 0);
+ } else {
+ /*
+ * Case: Direct dict in LVT with empty body.
+ */
+
+ PushLiteral(envPtr, "", 0);
+ Emit14Inst( INST_LOAD_SCALAR, dictVar, envPtr);
+ PushLiteral(envPtr, "", 0);
+ TclEmitOpcode( INST_DICT_EXPAND, envPtr);
+ TclEmitInstInt4(INST_DICT_RECOMBINE_IMM, dictVar, envPtr);
+ PushLiteral(envPtr, "", 0);
+ }
+ } else {
+ if (gotPath) {
+ /*
+ * Case: Path into dict in non-simple var with empty body.
+ */
+
+ tokenPtr = varTokenPtr;
+ for (i=1 ; i<parsePtr->numWords-1 ; i++) {
+ CompileWord(envPtr, tokenPtr, interp, i-1);
+ tokenPtr = TokenAfter(tokenPtr);
+ }
+ TclEmitInstInt4(INST_LIST, parsePtr->numWords-3,envPtr);
+ TclEmitInstInt4(INST_OVER, 1, envPtr);
+ TclEmitOpcode( INST_LOAD_STK, envPtr);
+ TclEmitInstInt4(INST_OVER, 1, envPtr);
+ TclEmitOpcode( INST_DICT_EXPAND, envPtr);
+ TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr);
+ PushLiteral(envPtr, "", 0);
+ } else {
+ /*
+ * Case: Direct dict in non-simple var with empty body.
+ */
+
+ CompileWord(envPtr, varTokenPtr, interp, 0);
+ TclEmitOpcode( INST_DUP, envPtr);
+ TclEmitOpcode( INST_LOAD_STK, envPtr);
+ PushLiteral(envPtr, "", 0);
+ TclEmitOpcode( INST_DICT_EXPAND, envPtr);
+ PushLiteral(envPtr, "", 0);
+ TclEmitInstInt4(INST_REVERSE, 2, envPtr);
+ TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr);
+ PushLiteral(envPtr, "", 0);
+ }
+ }
+ return TCL_OK;
+ }
+
+ /*
+ * OK, we have a non-trivial body. This means that the focus is on
+ * generating a try-finally structure where the INST_DICT_RECOMBINE_* goes
+ * in the 'finally' clause.
+ *
+ * Start by allocating local (unnamed, untraced) working variables.
+ */
+
+ if (dictVar == -1) {
+ varNameTmp = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+ } else {
+ varNameTmp = -1;
+ }
+ 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.
+ */
+
+ if (varNameTmp > -1) {
+ CompileWord(envPtr, varTokenPtr, interp, 0);
+ Emit14Inst( INST_STORE_SCALAR, varNameTmp, envPtr);
+ }
+ tokenPtr = TokenAfter(varTokenPtr);
+ 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);
+ Emit14Inst( INST_STORE_SCALAR, pathTmp, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ }
+ if (dictVar == -1) {
+ TclEmitOpcode( INST_LOAD_STK, envPtr);
+ } else {
+ Emit14Inst( INST_LOAD_SCALAR, dictVar, envPtr);
+ }
+ if (gotPath) {
+ Emit14Inst( INST_LOAD_SCALAR, pathTmp, envPtr);
+ } else {
+ PushLiteral(envPtr, "", 0);
+ }
+ TclEmitOpcode( INST_DICT_EXPAND, envPtr);
+ Emit14Inst( INST_STORE_SCALAR, 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 > -1) {
+ Emit14Inst( INST_LOAD_SCALAR, varNameTmp, envPtr);
+ }
+ if (gotPath) {
+ Emit14Inst( INST_LOAD_SCALAR, pathTmp, envPtr);
+ } else {
+ PushLiteral(envPtr, "", 0);
+ }
+ Emit14Inst( INST_LOAD_SCALAR, keysTmp, envPtr);
+ if (dictVar == -1) {
+ TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr);
+ } else {
+ TclEmitInstInt4( INST_DICT_RECOMBINE_IMM, dictVar, 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 > -1) {
+ Emit14Inst( INST_LOAD_SCALAR, varNameTmp, envPtr);
+ }
+ if (parsePtr->numWords > 3) {
+ Emit14Inst( INST_LOAD_SCALAR, pathTmp, envPtr);
+ } else {
+ PushLiteral(envPtr, "", 0);
+ }
+ Emit14Inst( INST_LOAD_SCALAR, keysTmp, envPtr);
+ if (dictVar == -1) {
+ TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr);
+ } else {
+ TclEmitInstInt4( INST_DICT_RECOMBINE_IMM, dictVar, 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;
}
@@ -1770,12 +2033,8 @@ TclCompileForeachCmd(
SetLineInformation(i);
CompileTokens(envPtr, tokenPtr, interp);
tempVar = (firstValueTemp + loopIndex);
- if (tempVar <= 255) {
- TclEmitInstInt1(INST_STORE_SCALAR1, tempVar, envPtr);
- } else {
- TclEmitInstInt4(INST_STORE_SCALAR4, tempVar, envPtr);
- }
- TclEmitOpcode(INST_POP, envPtr);
+ Emit14Inst( INST_STORE_SCALAR, tempVar, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
loopIndex++;
}
}
@@ -1784,7 +2043,7 @@ TclCompileForeachCmd(
* Initialize the temporary var that holds the count of loop iterations.
*/
- TclEmitInstInt4(INST_FOREACH_START4, infoIndex, envPtr);
+ TclEmitInstInt4( INST_FOREACH_START4, infoIndex, envPtr);
/*
* Top of loop code: assign each loop variable and check whether
@@ -1792,7 +2051,7 @@ TclCompileForeachCmd(
*/
ExceptionRangeTarget(envPtr, range, continueOffset);
- TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr);
+ TclEmitInstInt4( INST_FOREACH_STEP4, infoIndex, envPtr);
TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup);
/*
@@ -1804,7 +2063,7 @@ TclCompileForeachCmd(
CompileBody(envPtr, bodyTokenPtr, interp);
ExceptionRangeEnds(envPtr, range);
envPtr->currStackDepth = savedStackDepth + 1;
- TclEmitOpcode(INST_POP, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
/*
* Jump back to the test at the top of the loop. Generate a 4 byte jump if
@@ -2079,14 +2338,14 @@ TclCompileGlobalCmd(
}
CompileWord(envPtr, varTokenPtr, interp, 1);
- TclEmitInstInt4(INST_NSUPVAR, localIndex, envPtr);
+ TclEmitInstInt4( INST_NSUPVAR, localIndex, envPtr);
}
/*
* Pop the namespace, and set the result to empty
*/
- TclEmitOpcode(INST_POP, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
PushLiteral(envPtr, "", 0);
return TCL_OK;
}
@@ -2485,43 +2744,41 @@ TclCompileIncrCmd(
* Emit the instruction to increment the variable.
*/
- if (simpleVarName) {
- if (isScalar) {
- if (localIndex >= 0) {
- if (haveImmValue) {
- TclEmitInstInt1(INST_INCR_SCALAR1_IMM, localIndex, envPtr);
- TclEmitInt1(immValue, envPtr);
- } else {
- TclEmitInstInt1(INST_INCR_SCALAR1, localIndex, envPtr);
- }
+ if (!simpleVarName) {
+ if (haveImmValue) {
+ TclEmitInstInt1( INST_INCR_STK_IMM, immValue, envPtr);
+ } else {
+ TclEmitOpcode( INST_INCR_STK, envPtr);
+ }
+ } else if (isScalar) { /* Simple scalar variable. */
+ if (localIndex >= 0) {
+ if (haveImmValue) {
+ TclEmitInstInt1(INST_INCR_SCALAR1_IMM, localIndex, envPtr);
+ TclEmitInt1(immValue, envPtr);
} else {
- if (haveImmValue) {
- TclEmitInstInt1(INST_INCR_SCALAR_STK_IMM, immValue, envPtr);
- } else {
- TclEmitOpcode(INST_INCR_SCALAR_STK, envPtr);
- }
+ TclEmitInstInt1(INST_INCR_SCALAR1, localIndex, envPtr);
}
} else {
- if (localIndex >= 0) {
- if (haveImmValue) {
- TclEmitInstInt1(INST_INCR_ARRAY1_IMM, localIndex, envPtr);
- TclEmitInt1(immValue, envPtr);
- } else {
- TclEmitInstInt1(INST_INCR_ARRAY1, localIndex, envPtr);
- }
+ if (haveImmValue) {
+ TclEmitInstInt1(INST_INCR_SCALAR_STK_IMM, immValue, envPtr);
} else {
- if (haveImmValue) {
- TclEmitInstInt1(INST_INCR_ARRAY_STK_IMM, immValue, envPtr);
- } else {
- TclEmitOpcode(INST_INCR_ARRAY_STK, envPtr);
- }
+ TclEmitOpcode( INST_INCR_SCALAR_STK, envPtr);
}
}
- } else { /* Non-simple variable name. */
- if (haveImmValue) {
- TclEmitInstInt1(INST_INCR_STK_IMM, immValue, envPtr);
+ } else { /* Simple array variable. */
+ if (localIndex >= 0) {
+ if (haveImmValue) {
+ TclEmitInstInt1(INST_INCR_ARRAY1_IMM, localIndex, envPtr);
+ TclEmitInt1(immValue, envPtr);
+ } else {
+ TclEmitInstInt1(INST_INCR_ARRAY1, localIndex, envPtr);
+ }
} else {
- TclEmitOpcode(INST_INCR_STK, envPtr);
+ if (haveImmValue) {
+ TclEmitInstInt1(INST_INCR_ARRAY_STK_IMM, immValue, envPtr);
+ } else {
+ TclEmitOpcode( INST_INCR_ARRAY_STK, envPtr);
+ }
}
}
@@ -2579,22 +2836,20 @@ TclCompileInfoExistsCmd(
* Emit instruction to check the variable for existence.
*/
- if (simpleVarName) {
- if (isScalar) {
- if (localIndex < 0) {
- TclEmitOpcode(INST_EXIST_STK, envPtr);
- } else {
- TclEmitInstInt4(INST_EXIST_SCALAR, localIndex, envPtr);
- }
+ if (!simpleVarName) {
+ TclEmitOpcode( INST_EXIST_STK, envPtr);
+ } else if (isScalar) {
+ if (localIndex < 0) {
+ TclEmitOpcode( INST_EXIST_STK, envPtr);
} else {
- if (localIndex < 0) {
- TclEmitOpcode(INST_EXIST_ARRAY_STK, envPtr);
- } else {
- TclEmitInstInt4(INST_EXIST_ARRAY, localIndex, envPtr);
- }
+ TclEmitInstInt4( INST_EXIST_SCALAR, localIndex, envPtr);
}
} else {
- TclEmitOpcode(INST_EXIST_STK, envPtr);
+ if (localIndex < 0) {
+ TclEmitOpcode( INST_EXIST_ARRAY_STK, envPtr);
+ } else {
+ TclEmitInstInt4( INST_EXIST_ARRAY, localIndex, envPtr);
+ }
}
return TCL_OK;
@@ -2684,26 +2939,20 @@ TclCompileLappendCmd(
* LOAD/STORE instructions.
*/
- if (simpleVarName) {
- if (isScalar) {
- if (localIndex < 0) {
- TclEmitOpcode(INST_LAPPEND_STK, envPtr);
- } else if (localIndex <= 255) {
- TclEmitInstInt1(INST_LAPPEND_SCALAR1, localIndex, envPtr);
- } else {
- TclEmitInstInt4(INST_LAPPEND_SCALAR4, localIndex, envPtr);
- }
+ if (!simpleVarName) {
+ TclEmitOpcode( INST_LAPPEND_STK, envPtr);
+ } else if (isScalar) {
+ if (localIndex < 0) {
+ TclEmitOpcode( INST_LAPPEND_STK, envPtr);
} else {
- if (localIndex < 0) {
- TclEmitOpcode(INST_LAPPEND_ARRAY_STK, envPtr);
- } else if (localIndex <= 255) {
- TclEmitInstInt1(INST_LAPPEND_ARRAY1, localIndex, envPtr);
- } else {
- TclEmitInstInt4(INST_LAPPEND_ARRAY4, localIndex, envPtr);
- }
+ Emit14Inst( INST_LAPPEND_SCALAR, localIndex, envPtr);
}
} else {
- TclEmitOpcode(INST_LAPPEND_STK, envPtr);
+ if (localIndex < 0) {
+ TclEmitOpcode( INST_LAPPEND_ARRAY_STK, envPtr);
+ } else {
+ Emit14Inst( INST_LAPPEND_ARRAY, localIndex, envPtr);
+ }
}
return TCL_OK;
@@ -2776,50 +3025,44 @@ TclCompileLassignCmd(
* the stack and assign it to the variable.
*/
- if (simpleVarName) {
- if (isScalar) {
- if (localIndex >= 0) {
- TclEmitOpcode(INST_DUP, envPtr);
- TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
- if (localIndex <= 255) {
- TclEmitInstInt1(INST_STORE_SCALAR1,localIndex,envPtr);
- } else {
- TclEmitInstInt4(INST_STORE_SCALAR4,localIndex,envPtr);
- }
- } else {
- TclEmitInstInt4(INST_OVER, 1, envPtr);
- TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
- TclEmitOpcode(INST_STORE_SCALAR_STK, envPtr);
- }
+ if (!simpleVarName) {
+ TclEmitInstInt4( INST_OVER, 1, envPtr);
+ TclEmitInstInt4( INST_LIST_INDEX_IMM, idx, envPtr);
+ TclEmitOpcode( INST_STORE_STK, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ } else if (isScalar) {
+ if (localIndex >= 0) {
+ TclEmitOpcode( INST_DUP, envPtr);
+ TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
+ Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
} else {
- if (localIndex >= 0) {
- TclEmitInstInt4(INST_OVER, 1, envPtr);
- TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
- if (localIndex <= 255) {
- TclEmitInstInt1(INST_STORE_ARRAY1, localIndex, envPtr);
- } else {
- TclEmitInstInt4(INST_STORE_ARRAY4, localIndex, envPtr);
- }
- } else {
- TclEmitInstInt4(INST_OVER, 2, envPtr);
- TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
- TclEmitOpcode(INST_STORE_ARRAY_STK, envPtr);
- }
+ TclEmitInstInt4(INST_OVER, 1, envPtr);
+ TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
+ TclEmitOpcode( INST_STORE_SCALAR_STK, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
}
} else {
- TclEmitInstInt4(INST_OVER, 1, envPtr);
- TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
- TclEmitOpcode(INST_STORE_STK, envPtr);
+ if (localIndex >= 0) {
+ TclEmitInstInt4(INST_OVER, 1, envPtr);
+ TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
+ Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ } else {
+ TclEmitInstInt4(INST_OVER, 2, envPtr);
+ TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
+ TclEmitOpcode( INST_STORE_ARRAY_STK, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ }
}
- TclEmitOpcode(INST_POP, envPtr);
}
/*
* Generate code to leave the rest of the list on the stack.
*/
- TclEmitInstInt4(INST_LIST_RANGE_IMM, idx, envPtr);
- TclEmitInt4(-2, envPtr); /* -2 == "end" */
+ TclEmitInstInt4( INST_LIST_RANGE_IMM, idx, envPtr);
+ TclEmitInt4( -2 /* == "end" */, envPtr);
return TCL_OK;
}
@@ -2887,7 +3130,7 @@ TclCompileLindexCmd(
*/
CompileWord(envPtr, valTokenPtr, interp, 1);
- TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
+ TclEmitInstInt4( INST_LIST_INDEX_IMM, idx, envPtr);
return TCL_OK;
}
@@ -2913,9 +3156,9 @@ TclCompileLindexCmd(
*/
if (numWords == 3) {
- TclEmitOpcode(INST_LIST_INDEX, envPtr);
+ TclEmitOpcode( INST_LIST_INDEX, envPtr);
} else {
- TclEmitInstInt4(INST_LIST_INDEX_MULTI, numWords-1, envPtr);
+ TclEmitInstInt4( INST_LIST_INDEX_MULTI, numWords-1, envPtr);
}
return TCL_OK;
@@ -2949,6 +3192,8 @@ TclCompileListCmd(
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
+ Tcl_Token *valueTokenPtr;
+ int i, numWords;
/*
* If we're not in a procedure, don't compile.
@@ -2969,17 +3214,13 @@ TclCompileListCmd(
* Push the all values onto the stack.
*/
- Tcl_Token *valueTokenPtr;
- int i, numWords;
-
numWords = parsePtr->numWords;
-
valueTokenPtr = TokenAfter(parsePtr->tokenPtr);
for (i = 1; i < numWords; i++) {
CompileWord(envPtr, valueTokenPtr, interp, i);
valueTokenPtr = TokenAfter(valueTokenPtr);
}
- TclEmitInstInt4(INST_LIST, numWords - 1, envPtr);
+ TclEmitInstInt4( INST_LIST, numWords - 1, envPtr);
}
return TCL_OK;
@@ -3021,7 +3262,7 @@ TclCompileLlengthCmd(
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
CompileWord(envPtr, varTokenPtr, interp, 1);
- TclEmitOpcode(INST_LIST_LENGTH, envPtr);
+ TclEmitOpcode( INST_LIST_LENGTH, envPtr);
return TCL_OK;
}
@@ -3127,7 +3368,7 @@ TclCompileLsetCmd(
} else {
tempDepth = parsePtr->numWords - 1;
}
- TclEmitInstInt4(INST_OVER, tempDepth, envPtr);
+ TclEmitInstInt4( INST_OVER, tempDepth, envPtr);
}
/*
@@ -3140,7 +3381,7 @@ TclCompileLsetCmd(
} else {
tempDepth = parsePtr->numWords - 2;
}
- TclEmitInstInt4(INST_OVER, tempDepth, envPtr);
+ TclEmitInstInt4( INST_OVER, tempDepth, envPtr);
}
/*
@@ -3148,22 +3389,18 @@ TclCompileLsetCmd(
*/
if (!simpleVarName) {
- TclEmitOpcode(INST_LOAD_STK, envPtr);
+ TclEmitOpcode( INST_LOAD_STK, envPtr);
} else if (isScalar) {
if (localIndex < 0) {
- TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr);
- } else if (localIndex < 0x100) {
- TclEmitInstInt1(INST_LOAD_SCALAR1, localIndex, envPtr);
+ TclEmitOpcode( INST_LOAD_SCALAR_STK, envPtr);
} else {
- TclEmitInstInt4(INST_LOAD_SCALAR4, localIndex, envPtr);
+ Emit14Inst( INST_LOAD_SCALAR, localIndex, envPtr);
}
} else {
if (localIndex < 0) {
- TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr);
- } else if (localIndex < 0x100) {
- TclEmitInstInt1(INST_LOAD_ARRAY1, localIndex, envPtr);
+ TclEmitOpcode( INST_LOAD_ARRAY_STK, envPtr);
} else {
- TclEmitInstInt4(INST_LOAD_ARRAY4, localIndex, envPtr);
+ Emit14Inst( INST_LOAD_ARRAY, localIndex, envPtr);
}
}
@@ -3172,9 +3409,9 @@ TclCompileLsetCmd(
*/
if (parsePtr->numWords == 4) {
- TclEmitOpcode(INST_LSET_LIST, envPtr);
+ TclEmitOpcode( INST_LSET_LIST, envPtr);
} else {
- TclEmitInstInt4(INST_LSET_FLAT, parsePtr->numWords-1, envPtr);
+ TclEmitInstInt4( INST_LSET_FLAT, parsePtr->numWords-1, envPtr);
}
/*
@@ -3182,22 +3419,18 @@ TclCompileLsetCmd(
*/
if (!simpleVarName) {
- TclEmitOpcode(INST_STORE_STK, envPtr);
+ TclEmitOpcode( INST_STORE_STK, envPtr);
} else if (isScalar) {
if (localIndex < 0) {
- TclEmitOpcode(INST_STORE_SCALAR_STK, envPtr);
- } else if (localIndex < 0x100) {
- TclEmitInstInt1(INST_STORE_SCALAR1, localIndex, envPtr);
+ TclEmitOpcode( INST_STORE_SCALAR_STK, envPtr);
} else {
- TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr);
+ Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr);
}
} else {
if (localIndex < 0) {
- TclEmitOpcode(INST_STORE_ARRAY_STK, envPtr);
- } else if (localIndex < 0x100) {
- TclEmitInstInt1(INST_STORE_ARRAY1, localIndex, envPtr);
+ TclEmitOpcode( INST_STORE_ARRAY_STK, envPtr);
} else {
- TclEmitInstInt4(INST_STORE_ARRAY4, localIndex, envPtr);
+ Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr);
}
}
@@ -3275,14 +3508,14 @@ TclCompileNamespaceUpvarCmd(
if ((localIndex < 0) || !isScalar) {
return TCL_ERROR;
}
- TclEmitInstInt4(INST_NSUPVAR, localIndex, envPtr);
+ TclEmitInstInt4( INST_NSUPVAR, localIndex, envPtr);
}
/*
* Pop the namespace, and set the result to empty
*/
- TclEmitOpcode(INST_POP, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
PushLiteral(envPtr, "", 0);
return TCL_OK;
}
@@ -3433,9 +3666,9 @@ TclCompileRegexpCmd(
if (simple) {
if (exact && !nocase) {
- TclEmitOpcode(INST_STR_EQ, envPtr);
+ TclEmitOpcode( INST_STR_EQ, envPtr);
} else {
- TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr);
+ TclEmitInstInt1( INST_STR_MATCH, nocase, envPtr);
}
} else {
/*
@@ -3446,7 +3679,7 @@ TclCompileRegexpCmd(
int cflags = TCL_REG_ADVANCED | (nocase ? TCL_REG_NOCASE : 0);
- TclEmitInstInt1(INST_REGEXP, cflags, envPtr);
+ TclEmitInstInt1( INST_REGEXP, cflags, envPtr);
}
return TCL_OK;
@@ -3644,7 +3877,7 @@ TclCompileSyntaxError(
TclErrorStackResetIf(interp, bytes, numBytes);
TclEmitPush(TclRegisterNewLiteral(envPtr, bytes, numBytes), envPtr);
CompileReturnInternal(envPtr, INST_SYNTAX, TCL_ERROR, 0,
- TclNoErrorStack(interp, Tcl_GetReturnOptions(interp, TCL_ERROR)));
+ TclNoErrorStack(interp, Tcl_GetReturnOptions(interp, TCL_ERROR)));
}
/*
@@ -3744,14 +3977,14 @@ TclCompileUpvarCmd(
if ((localIndex < 0) || !isScalar) {
return TCL_ERROR;
}
- TclEmitInstInt4(INST_UPVAR, localIndex, envPtr);
+ TclEmitInstInt4( INST_UPVAR, localIndex, envPtr);
}
/*
* Pop the frame index, and set the result to empty
*/
- TclEmitOpcode(INST_POP, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
PushLiteral(envPtr, "", 0);
return TCL_OK;
}
@@ -3816,7 +4049,7 @@ TclCompileVariableCmd(
}
CompileWord(envPtr, varTokenPtr, interp, 1);
- TclEmitInstInt4(INST_VARIABLE, localIndex, envPtr);
+ TclEmitInstInt4( INST_VARIABLE, localIndex, envPtr);
if (i != numWords) {
/*
@@ -3824,12 +4057,8 @@ TclCompileVariableCmd(
*/
CompileWord(envPtr, valueTokenPtr, interp, 1);
- if (localIndex < 0x100) {
- TclEmitInstInt1(INST_STORE_SCALAR1, localIndex, envPtr);
- } else {
- TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr);
- }
- TclEmitOpcode(INST_POP, envPtr);
+ Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
}
}
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..97e2a8a 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -421,6 +421,20 @@ 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 */
+ {"dictRecombineStk", 1, -3, 0, {OPERAND_NONE}},
+ /* Map variable contents back into a dictionary in a variable. Part of
+ * [dict with].
+ * Stack: ... dictVarName path keyList => ... */
+ {"dictRecombineImm", 1, -2, 1, {OPERAND_LVT4}},
+ /* Map variable contents back into a dictionary in the local variable
+ * indicated by the LVT index. Part of [dict with].
+ * Stack: ... path keyList => ... */
+
{NULL, 0, 0, 0, {OPERAND_NONE}}
};
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 45d50ea..e80a710 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -676,8 +676,13 @@ typedef struct ByteCode {
#define INST_UNSET_ARRAY_STK 136
#define INST_UNSET_STK 137
+/* For [dict with] compilation */
+#define INST_DICT_EXPAND 138
+#define INST_DICT_RECOMBINE_STK 139
+#define INST_DICT_RECOMBINE_IMM 140
+
/* The last opcode */
-#define LAST_INST_OPCODE 137
+#define LAST_INST_OPCODE 140
/*
* Table describing the Tcl bytecode instructions: their name (for displaying
diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c
index 83fc3a6..d50c0a2 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,55 +3155,200 @@ 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];
Tcl_Obj *pathPtr = data[2];
+ Var *varPtr, *arrayPtr;
if (result == TCL_ERROR) {
Tcl_AddErrorInfo(interp, "\n (body of \"dict with\")");
}
/*
+ * 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.
+ */
+
+ varPtr = TclObjLookupVarEx(interp, varName, NULL, TCL_LEAVE_ERR_MSG, "set",
+ /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
+ if (varPtr == NULL) {
+ result = TCL_ERROR;
+ } else {
+ result = TclDictWithFinish(interp, varPtr, arrayPtr, varName, NULL, -1,
+ 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, /* Command interpreter in which variable
+ * exists. Used for state management, traces
+ * and error reporting. */
+ Var *varPtr, /* Reference to the variable holding the
+ * dictionary. */
+ Var *arrayPtr, /* Reference to the array containing the
+ * variable, or NULL if the variable is a
+ * scalar. */
+ Tcl_Obj *part1Ptr, /* Name of an array (if part2 is non-NULL) or
+ * the name of a variable. NULL if the 'index'
+ * parameter is >= 0 */
+ Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element
+ * in the array part1. */
+ int index, /* Index into the local variable table of the
+ * variable, or -1. Only used when part1Ptr is
+ * NULL. */
+ int pathc, /* The number of elements in the path into the
+ * dictionary. */
+ Tcl_Obj *const pathv[], /* The elements of the path to the subdict. */
+ Tcl_Obj *keysPtr) /* List of keys to be synchronized. This is
+ * the result value from TclDictWithInit. */
+{
+ 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);
+ dictPtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
+ TCL_LEAVE_ERR_MSG, index);
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 +3358,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 +3396,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);
}
@@ -3301,13 +3410,14 @@ FinalizeDictWith(
* Write back the outermost dictionary to the variable.
*/
- if (Tcl_ObjSetVar2(interp, varName, NULL, dictPtr,
- TCL_LEAVE_ERR_MSG) == NULL) {
- Tcl_DiscardInterpState(state);
+ if (TclPtrSetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, dictPtr,
+ TCL_LEAVE_ERR_MSG, index) == NULL) {
+ 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..953c63e 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,78 @@ 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_STK:
+ keysPtr = POP_OBJECT();
+ varNamePtr = OBJ_UNDER_TOS;
+ listPtr = OBJ_AT_TOS;
+ TRACE(("\"%.30s\" \"%.30s\" \"%.30s\" => ",
+ O2S(varNamePtr), O2S(valuePtr), O2S(keysPtr)));
+ if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) {
+ TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
+ TclDecrRefCount(keysPtr);
+ goto gotError;
+ }
+ varPtr = TclObjLookupVarEx(interp, varNamePtr, NULL,
+ TCL_LEAVE_ERR_MSG, "set", 1, 1, &arrayPtr);
+ if (varPtr == NULL) {
+ TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
+ TclDecrRefCount(keysPtr);
+ goto gotError;
+ }
+ DECACHE_STACK_INFO();
+ result = TclDictWithFinish(interp, varPtr,arrayPtr,varNamePtr,NULL,-1,
+ objc, objv, keysPtr);
+ CACHE_STACK_INFO();
+ TclDecrRefCount(keysPtr);
+ if (result != TCL_OK) {
+ TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
+ goto gotError;
+ }
+ TRACE_APPEND(("OK\n"));
+ NEXT_INST_F(1, 2, 0);
+
+ case INST_DICT_RECOMBINE_IMM:
+ opnd = TclGetUInt4AtPtr(pc+1);
+ listPtr = OBJ_UNDER_TOS;
+ keysPtr = OBJ_AT_TOS;
+ varPtr = LOCAL(opnd);
+ TRACE(("%u <- \"%.30s\" \"%.30s\" => ", opnd, O2S(valuePtr),
+ O2S(keysPtr)));
+ if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) {
+ TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
+ goto gotError;
+ }
+ while (TclIsVarLink(varPtr)) {
+ varPtr = varPtr->value.linkPtr;
+ }
+ DECACHE_STACK_INFO();
+ result = TclDictWithFinish(interp, varPtr, NULL, NULL, NULL, opnd,
+ objc, objv, keysPtr);
+ CACHE_STACK_INFO();
+ if (result != TCL_OK) {
+ TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
+ goto gotError;
+ }
+ TRACE_APPEND(("OK\n"));
+ NEXT_INST_F(5, 2, 0);
}
/*
diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c
index b095dcf..6c9a41b 100644
--- a/generic/tclIORTrans.c
+++ b/generic/tclIORTrans.c
@@ -885,7 +885,7 @@ ReflectClose(
{
ReflectedTransform *rtPtr = clientData;
int errorCode, errorCodeSet = 0;
- int result; /* Result code for 'close' */
+ int result = TCL_OK; /* Result code for 'close' */
Tcl_Obj *resObj; /* Result data for 'close' */
ReflectedTransformMap *rtmPtr;
/* Map of reflected transforms with handlers
diff --git a/generic/tclInt.h b/generic/tclInt.h
index f30e83e..b375bb9 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3231,6 +3231,12 @@ 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, Var *varPtr,
+ Var *arrayPtr, Tcl_Obj *part1Ptr,
+ Tcl_Obj *part2Ptr, int index, 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 +3501,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);
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 9a2152a..73bc644 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -170,7 +170,7 @@ static const EnsembleImplMap defaultNamespaceMap[] = {
{"export", NamespaceExportCmd, NULL, NULL, NULL, 0},
{"forget", NamespaceForgetCmd, NULL, NULL, NULL, 0},
{"import", NamespaceImportCmd, NULL, NULL, NULL, 0},
- {"inscope", NamespaceInscopeCmd, NULL, NULL, NRNamespaceInscopeCmd, 0},
+ {"inscope", NamespaceInscopeCmd, NULL, NRNamespaceInscopeCmd, NULL, 0},
{"origin", NamespaceOriginCmd, NULL, NULL, NULL, 0},
{"parent", NamespaceParentCmd, NULL, NULL, NULL, 0},
{"path", NamespacePathCmd, NULL, NULL, NULL, 0},
diff --git a/generic/tclTest.c b/generic/tclTest.c
index 30c95c8..cbebacd 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -75,7 +75,7 @@ typedef struct TestAsyncHandler {
/* Next is list of handlers. */
} TestAsyncHandler;
-TCL_DECLARE_MUTEX(asyncTestMutex);
+TCL_DECLARE_MUTEX(asyncTestMutex)
static TestAsyncHandler *firstHandler = NULL;
@@ -7109,13 +7109,15 @@ TestparseargsCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Arguments. */
{
- int count = objc, foo = 0;
+ static int foo = 0;
+ int count = objc;
Tcl_Obj **remObjv, *result[3];
Tcl_ArgvInfo argTable[] = {
{TCL_ARGV_CONSTANT, "-bool", INT2PTR(1), &foo, "booltest", NULL},
TCL_ARGV_AUTO_REST, TCL_ARGV_AUTO_HELP, TCL_ARGV_TABLE_END
};
+ foo = 0;
if (Tcl_ParseArgsObjv(interp, argTable, &count, objv, &remObjv)!=TCL_OK) {
return TCL_ERROR;
}
generated by cgit v0.12 at 2024-12-26 05:28:43 (GMT)