summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--generic/tclAssembly.c13
-rw-r--r--generic/tclCompCmds.c207
-rw-r--r--generic/tclCompile.c4
-rw-r--r--generic/tclCompile.h25
-rw-r--r--generic/tclDictObj.c21
-rw-r--r--generic/tclExecute.c15
-rw-r--r--generic/tclInt.h6
-rw-r--r--tests/dict.test48
8 files changed, 298 insertions, 41 deletions
diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 5aa1e14..eacaafe 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -490,6 +490,7 @@ static const TalInstDesc TalInstructionTable[] = {
{"uplus", ASSEM_1BYTE, INST_UPLUS, 1, 1},
{"upvar", ASSEM_LVT4, INST_UPVAR, 2, 1},
{"variable", ASSEM_LVT4, INST_VARIABLE, 1, 0},
+ {"verifyDict", ASSEM_1BYTE, INST_DICT_VERIFY, 1, 0},
{"yield", ASSEM_1BYTE, INST_YIELD, 1, 1},
{NULL, 0, 0, 0, 0}
};
@@ -510,12 +511,12 @@ static const unsigned char NonThrowingByteCodes[] = {
INST_PUSH_RETURN_OPTIONS, /* 108 */
INST_REVERSE, /* 126 */
INST_NOP, /* 132 */
- INST_STR_MAP, /* 141 */
- INST_STR_FIND, /* 142 */
- INST_COROUTINE_NAME, /* 145 */
- INST_NS_CURRENT, /* 146 */
- INST_INFO_LEVEL_NUM, /* 147 */
- INST_RESOLVE_COMMAND /* 149 */
+ INST_STR_MAP, /* 143 */
+ INST_STR_FIND, /* 144 */
+ INST_COROUTINE_NAME, /* 147 */
+ INST_NS_CURRENT, /* 148 */
+ INST_INFO_LEVEL_NUM, /* 149 */
+ INST_RESOLVE_COMMAND /* 151 */
};
/*
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 068848f..5beb7bd 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -884,6 +884,209 @@ TclCompileDictUnsetCmd(
}
int
+TclCompileDictCreateCmd(
+ 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 worker; /* Temp var for building the value in. */
+ Tcl_Token *tokenPtr;
+ Tcl_Obj *keyObj, *valueObj, *dictObj;
+ const char *bytes;
+ int i, len;
+
+ if ((parsePtr->numWords & 1) == 0) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * See if we can build the value at compile time...
+ */
+
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ dictObj = Tcl_NewObj();
+ Tcl_IncrRefCount(dictObj);
+ for (i=1 ; i<parsePtr->numWords ; i+=2) {
+ keyObj = Tcl_NewObj();
+ Tcl_IncrRefCount(keyObj);
+ if (!TclWordKnownAtCompileTime(tokenPtr, keyObj)) {
+ Tcl_DecrRefCount(keyObj);
+ Tcl_DecrRefCount(dictObj);
+ goto nonConstant;
+ }
+ tokenPtr = TokenAfter(tokenPtr);
+ valueObj = Tcl_NewObj();
+ Tcl_IncrRefCount(valueObj);
+ if (!TclWordKnownAtCompileTime(tokenPtr, valueObj)) {
+ Tcl_DecrRefCount(keyObj);
+ Tcl_DecrRefCount(valueObj);
+ Tcl_DecrRefCount(dictObj);
+ goto nonConstant;
+ }
+ tokenPtr = TokenAfter(tokenPtr);
+ Tcl_DictObjPut(NULL, dictObj, keyObj, valueObj);
+ Tcl_DecrRefCount(keyObj);
+ Tcl_DecrRefCount(valueObj);
+ }
+
+ /*
+ * We did! Excellent. The "verifyDict" is to do type forcing.
+ */
+
+ bytes = Tcl_GetStringFromObj(dictObj, &len);
+ PushLiteral(envPtr, bytes, len);
+ TclEmitOpcode( INST_DUP, envPtr);
+ TclEmitOpcode( INST_DICT_VERIFY, envPtr);
+ Tcl_DecrRefCount(dictObj);
+ return TCL_OK;
+
+ /*
+ * Otherwise, we've got to issue runtime code to do the building, which we
+ * do by [dict set]ting into an unnamed local variable. This requires that
+ * we are in a context with an LVT.
+ */
+
+ nonConstant:
+ worker = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+ if (worker < 0) {
+ return TCL_ERROR;
+ }
+
+ PushLiteral(envPtr, "", 0);
+ Emit14Inst( INST_STORE_SCALAR, worker, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ for (i=1 ; i<parsePtr->numWords ; i+=2) {
+ CompileWord(envPtr, tokenPtr, interp, i);
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, i+1);
+ tokenPtr = TokenAfter(tokenPtr);
+ TclEmitInstInt4( INST_DICT_SET, 1, envPtr);
+ TclEmitInt4( worker, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ }
+ Emit14Inst( INST_LOAD_SCALAR, worker, envPtr);
+ TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
+ TclEmitInt4( worker, envPtr);
+ return TCL_OK;
+}
+
+int
+TclCompileDictMergeCmd(
+ 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 */
+ Tcl_Token *tokenPtr;
+ int i, workerIndex, infoIndex, outLoop;
+
+ /*
+ * Deal with some special edge cases. Note that in the case with one
+ * argument, the only thing to do is to verify the dict-ness.
+ */
+
+ if (parsePtr->numWords < 2) {
+ PushLiteral(envPtr, "", 0);
+ return TCL_OK;
+ } else if (parsePtr->numWords == 2) {
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ TclEmitOpcode( INST_DUP, envPtr);
+ TclEmitOpcode( INST_DICT_VERIFY, envPtr);
+ return TCL_OK;
+ }
+
+ /*
+ * There's real merging work to do.
+ *
+ * Allocate some working space. This means we'll only ever compile this
+ * command when there's an LVT present.
+ */
+
+ workerIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+ if (workerIndex < 0) {
+ return TCL_ERROR;
+ }
+ infoIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+
+ /*
+ * Get the first dictionary and verify that it is so.
+ */
+
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ TclEmitOpcode( INST_DUP, envPtr);
+ TclEmitOpcode( INST_DICT_VERIFY, envPtr);
+ Emit14Inst( INST_STORE_SCALAR, workerIndex, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+
+ /*
+ * For each of the remaining dictionaries...
+ */
+
+ outLoop = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
+ TclEmitInstInt4( INST_BEGIN_CATCH4, outLoop, envPtr);
+ ExceptionRangeStarts(envPtr, outLoop);
+ for (i=2 ; i<parsePtr->numWords ; i++) {
+ /*
+ * Get the dictionary, and merge its pairs into the first dict (using
+ * a small loop).
+ */
+
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, i);
+ TclEmitInstInt4( INST_DICT_FIRST, infoIndex, envPtr);
+ TclEmitInstInt1( INST_JUMP_TRUE1, 24, envPtr);
+ TclEmitInstInt4( INST_REVERSE, 2, envPtr);
+ TclEmitInstInt4( INST_DICT_SET, 1, envPtr);
+ TclEmitInt4( workerIndex, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ TclEmitInstInt4( INST_DICT_NEXT, infoIndex, envPtr);
+ TclEmitInstInt1( INST_JUMP_FALSE1, -20, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
+ TclEmitInt4( infoIndex, envPtr);
+ }
+ ExceptionRangeEnds(envPtr, outLoop);
+ TclEmitOpcode( INST_END_CATCH, envPtr);
+
+ /*
+ * Clean up any state left over.
+ */
+
+ Emit14Inst( INST_LOAD_SCALAR, workerIndex, envPtr);
+ TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
+ TclEmitInt4( workerIndex, envPtr);
+ TclEmitInstInt1( INST_JUMP1, 18, envPtr);
+
+ /*
+ * If an exception happens when starting to iterate over the second (and
+ * subsequent) dicts. This is strictly not necessary, but it is nice.
+ */
+
+ ExceptionRangeTarget(envPtr, outLoop, catchOffset);
+ TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr);
+ TclEmitOpcode( INST_PUSH_RESULT, envPtr);
+ TclEmitOpcode( INST_END_CATCH, envPtr);
+ TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
+ TclEmitInt4( workerIndex, envPtr);
+ TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
+ TclEmitInt4( infoIndex, envPtr);
+ TclEmitOpcode( INST_RETURN_STK, envPtr);
+
+ return TCL_OK;
+}
+
+int
TclCompileDictForCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
@@ -1106,7 +1309,7 @@ CompileDictEachCmd(
ExceptionRangeTarget(envPtr, loopRange, breakOffset);
TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
- TclEmitInt4( infoIndex, envPtr);
+ TclEmitInt4( infoIndex, envPtr);
TclEmitOpcode( INST_END_CATCH, envPtr);
endTargetOffset = CurrentOffset(envPtr);
TclEmitInstInt4( INST_JUMP4, 0, envPtr);
@@ -1120,7 +1323,7 @@ CompileDictEachCmd(
TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr);
TclEmitOpcode( INST_PUSH_RESULT, envPtr);
TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
- TclEmitInt4( infoIndex, envPtr);
+ TclEmitInt4( infoIndex, envPtr);
TclEmitOpcode( INST_END_CATCH, envPtr);
if (collect == TCL_EACH_COLLECT) {
TclEmitInstInt1(INST_UNSET_SCALAR, 0, envPtr);
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 128273b..f979fa3 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -440,6 +440,10 @@ InstructionDesc const tclInstructionTable[] = {
* boolean indicating whether it is possible to read out a value from
* that key-path (like [dict exists]).
* Stack: ... dict key1 ... keyN => ... boolean */
+ {"verifyDict", 1, -1, 0, {OPERAND_NONE}},
+ /* Verifies that the word on the top of the stack is a dictionary,
+ * popping it if it is and throwing an error if it is not.
+ * Stack: ... value => ... */
{"strmap", 1, -2, 0, {OPERAND_NONE}},
/* Simplified version of [string map] that only applies one change
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 24f9464..85d282f 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -676,30 +676,31 @@ typedef struct ByteCode {
#define INST_UNSET_ARRAY_STK 136
#define INST_UNSET_STK 137
-/* For [dict with] and [dict exists] compilation */
+/* For [dict with], [dict exists], [dict create] and [dict merge] */
#define INST_DICT_EXPAND 138
#define INST_DICT_RECOMBINE_STK 139
#define INST_DICT_RECOMBINE_IMM 140
#define INST_DICT_EXISTS 141
+#define INST_DICT_VERIFY 142
/* For [string map] and [regsub] compilation */
-#define INST_STR_MAP 142
-#define INST_STR_FIND 143
-#define INST_STR_RANGE_IMM 144
+#define INST_STR_MAP 143
+#define INST_STR_FIND 144
+#define INST_STR_RANGE_IMM 145
/* For operations to do with coroutines */
-#define INST_YIELD 145
-#define INST_COROUTINE_NAME 146
+#define INST_YIELD 146
+#define INST_COROUTINE_NAME 147
/* For compilation of basic information operations */
-#define INST_NS_CURRENT 147
-#define INST_INFO_LEVEL_NUM 148
-#define INST_INFO_LEVEL_ARGS 149
-#define INST_RESOLVE_COMMAND 150
-#define INST_TCLOO_SELF 151
+#define INST_NS_CURRENT 148
+#define INST_INFO_LEVEL_NUM 149
+#define INST_INFO_LEVEL_ARGS 150
+#define INST_RESOLVE_COMMAND 151
+#define INST_TCLOO_SELF 152
/* The last opcode */
-#define LAST_INST_OPCODE 151
+#define LAST_INST_OPCODE 152
/*
* Table describing the Tcl bytecode instructions: their name (for displaying
diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c
index 2d6d209..eb3625e 100644
--- a/generic/tclDictObj.c
+++ b/generic/tclDictObj.c
@@ -87,25 +87,9 @@ static int DictMapLoopCallback(ClientData data[],
* Table of dict subcommand names and implementations.
*/
-#define NORMAL(name, term) \
- {name, Dict##term##Cmd, NULL, NULL, NULL, 0}
-#define COMPILED(name, term) \
- {name, Dict##term##Cmd, TclCompileDict##term##Cmd, NULL, NULL, 0}
-#define NR(name, term) \
- {name, NULL, TclCompileDict##term##Cmd, Dict##term##NRCmd, NULL, 0}
static const EnsembleImplMap implementationMap[] = {
- COMPILED( "append", Append),
- NORMAL( "create", Create),
- COMPILED( "exists", Exists),
- NORMAL( "filter", Filter),
- NR( "for", For),
- COMPILED( "get", Get),
- COMPILED( "incr", Incr),
- NORMAL( "info", Info),
- NORMAL( "keys", Keys),
- /*
{"append", DictAppendCmd, TclCompileDictAppendCmd, NULL, NULL, 0 },
- {"create", DictCreateCmd, NULL, NULL, NULL, 0 },
+ {"create", DictCreateCmd, TclCompileDictCreateCmd, NULL, NULL, 0 },
{"exists", DictExistsCmd, TclCompileDictExistsCmd, NULL, NULL, 0 },
{"filter", DictFilterCmd, NULL, NULL, NULL, 0 },
{"for", NULL, TclCompileDictForCmd, DictForNRCmd, NULL, 0 },
@@ -113,10 +97,9 @@ static const EnsembleImplMap implementationMap[] = {
{"incr", DictIncrCmd, TclCompileDictIncrCmd, NULL, NULL, 0 },
{"info", DictInfoCmd, NULL, NULL, NULL, 0 },
{"keys", DictKeysCmd, NULL, NULL, NULL, 0 },
- */
{"lappend", DictLappendCmd, TclCompileDictLappendCmd, NULL, NULL, 0 },
{"map", NULL, TclCompileDictMapCmd, DictMapNRCmd, NULL, 0 },
- {"merge", DictMergeCmd, NULL, NULL, NULL, 0 },
+ {"merge", DictMergeCmd, TclCompileDictMergeCmd, NULL, NULL, 0 },
{"remove", DictRemoveCmd, NULL, NULL, NULL, 0 },
{"replace", DictReplaceCmd, NULL, NULL, NULL, 0 },
{"set", DictSetCmd, TclCompileDictSetCmd, NULL, NULL, 0 },
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index c6be2f3..bbee81d 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -5915,6 +5915,17 @@ TEBCresume(
Tcl_DictSearch *searchPtr;
DictUpdateInfo *duiPtr;
+ case INST_DICT_VERIFY:
+ dictPtr = OBJ_AT_TOS;
+ TRACE(("=> "));
+ if (Tcl_DictObjSize(interp, dictPtr, &done) != TCL_OK) {
+ TRACE_APPEND(("ERROR verifying dictionary nature of \"%s\": %s\n",
+ O2S(OBJ_AT_DEPTH(opnd)), O2S(Tcl_GetObjResult(interp))));
+ goto gotError;
+ }
+ TRACE_APPEND(("OK\n"));
+ NEXT_INST_F(1, 1, 0);
+
case INST_DICT_GET:
case INST_DICT_EXISTS: {
register Tcl_Interp *interp2 = interp;
@@ -5933,8 +5944,8 @@ TEBCresume(
goto dictNotExists;
}
TRACE_WITH_OBJ((
- "%u => ERROR tracing dictionary path into \"%s\": ",
- opnd, O2S(OBJ_AT_DEPTH(opnd))),
+ "ERROR tracing dictionary path into \"%s\": ",
+ O2S(OBJ_AT_DEPTH(opnd))),
Tcl_GetObjResult(interp));
goto gotError;
}
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 3e2f548..49298b3 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3502,6 +3502,9 @@ MODULE_SCOPE int TclCompileContinueCmd(Tcl_Interp *interp,
MODULE_SCOPE int TclCompileDictAppendCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileDictCreateCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
MODULE_SCOPE int TclCompileDictExistsCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
@@ -3520,6 +3523,9 @@ MODULE_SCOPE int TclCompileDictLappendCmd(Tcl_Interp *interp,
MODULE_SCOPE int TclCompileDictMapCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileDictMergeCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
MODULE_SCOPE int TclCompileDictSetCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
diff --git a/tests/dict.test b/tests/dict.test
index 72f239e..22d652b 100644
--- a/tests/dict.test
+++ b/tests/dict.test
@@ -78,6 +78,24 @@ test dict-2.7 {dict create command - #-quoting in string rep} {
test dict-2.8 {dict create command - #-quoting in string rep} -body {
dict create #a x #b x
} -match glob -result {{#?} x #? x}
+test dict-2.9 {dict create command: compilation} {
+ apply {{} {dict create [format a] b}}
+} {a b}
+test dict-2.10 {dict create command: compilation} {
+ apply {{} {dict create [format a] b c d}}
+} {a b c d}
+test dict-2.11 {dict create command: compilation} {
+ apply {{} {dict create [format a] b c d a x}}
+} {a x c d}
+test dict-2.12 {dict create command: non-compilation} {
+ dict create [format a] b
+} {a b}
+test dict-2.13 {dict create command: non-compilation} {
+ dict create [format a] b c d
+} {a b c d}
+test dict-2.14 {dict create command: non-compilation} {
+ dict create [format a] b c d a x
+} {a x c d}
test dict-3.1 {dict get command} {dict get {a b} a} b
test dict-3.2 {dict get command} {dict get {a b c d} a} b
@@ -1160,6 +1178,36 @@ test dict-20.9 {dict merge command} {
test dict-20.10 {dict merge command} {
dict merge {a b c d e f} {a x 1 2 3 4} {a - 1 -}
} {a - c d e f 1 - 3 4}
+test dict-20.11 {dict merge command} {
+ apply {{} {dict merge}}
+} {}
+test dict-20.12 {dict merge command} {
+ apply {{} {dict merge {a b c d e f}}}
+} {a b c d e f}
+test dict-20.13 {dict merge command} -body {
+ apply {{} {dict merge {a b c d e}}}
+} -result {missing value to go with key} -returnCodes error
+test dict-20.14 {dict merge command} {
+ apply {{} {dict merge {a b c d} {e f g h}}}
+} {a b c d e f g h}
+test dict-20.15 {dict merge command} -body {
+ apply {{} {dict merge {a b c d e} {e f g h}}}
+} -result {missing value to go with key} -returnCodes error
+test dict-20.16 {dict merge command} -body {
+ apply {{} {dict merge {a b c d} {e f g h i}}}
+} -result {missing value to go with key} -returnCodes error
+test dict-20.17 {dict merge command} {
+ apply {{} {dict merge {a b c d e f} {e x g h}}}
+} {a b c d e x g h}
+test dict-20.18 {dict merge command} {
+ apply {{} {dict merge {a b c d} {a x c y}}}
+} {a x c y}
+test dict-20.19 {dict merge command} {
+ apply {{} {dict merge {a b c d} {c y a x}}}
+} {a x c y}
+test dict-20.20 {dict merge command} {
+ apply {{} {dict merge {a b c d e f} {a x 1 2 3 4} {a - 1 -}}}
+} {a - c d e f 1 - 3 4}
test dict-21.1 {dict update command} -returnCodes 1 -body {
dict update
generated by cgit v0.12 at 2024-11-15 11:34:55 (GMT)