Added compilation of [dict create] and [dict merge].

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