From 4683dce51c55d4a3d5281e98f60e17b8c09d24fb Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Sun, 4 Mar 2012 16:52:01 +0000
Subject: Compilation of misc info sometimes used in high-performance code.

---
 generic/tclAssembly.c |   9 +-
 generic/tclCmdIL.c    |   4 +-
 generic/tclCompCmds.c | 102 +++++++++++++++++--
 generic/tclCompile.c  |  21 +++-
 generic/tclCompile.h  |   8 +-
 generic/tclExecute.c  |  64 ++++++++++++
 generic/tclInt.h      |   9 ++
 generic/tclNamesp.c   | 275 +++++++++++++++++++++++++-------------------------
 tests/info.test       |   6 ++
 9 files changed, 344 insertions(+), 154 deletions(-)

diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 5b32ab0..7bfaac1 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -369,6 +369,7 @@ TalInstDesc TalInstructionTable[] = {
     {"bitor",		ASSEM_1BYTE,	INST_BITOR,		2,	1},
     {"bitxor",		ASSEM_1BYTE,	INST_BITXOR,		2,	1},
     {"concat",		ASSEM_CONCAT1,	INST_CONCAT1,		INT_MIN,1},
+    {"coroName",	ASSEM_1BYTE,	INST_COROUTINE_NAME,	0,	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},
@@ -406,6 +407,8 @@ TalInstDesc TalInstructionTable[] = {
     {"incrStk",		ASSEM_1BYTE,	INST_INCR_SCALAR_STK,	2,	1},
     {"incrStkImm",	ASSEM_SINT1,	INST_INCR_SCALAR_STK_IMM,
 								1,	1},
+    {"infoLevelArgs",	ASSEM_1BYTE,	INST_INFO_LEVEL_ARGS,	1,	1},
+    {"infoLevelNumber",	ASSEM_1BYTE,	INST_INFO_LEVEL_NUM,	0,	1},
     {"invokeStk",	ASSEM_INVOKE,	(INST_INVOKE_STK1 << 8
 					 | INST_INVOKE_STK4),	INT_MIN,1},
     {"jump",		ASSEM_JUMP,	INST_JUMP1,		0,	0},
@@ -449,6 +452,7 @@ TalInstDesc TalInstructionTable[] = {
     {"neq",		ASSEM_1BYTE,	INST_NEQ,		2,	1},
     {"nop",		ASSEM_1BYTE,	INST_NOP,		0,	0},
     {"not",		ASSEM_1BYTE,	INST_LNOT,		1,	1},
+    {"nscurrent",	ASSEM_1BYTE,	INST_NS_CURRENT,	0,	1},
     {"nsupvar",		ASSEM_LVT4,	INST_NSUPVAR,		2,	1},
     {"over",		ASSEM_OVER,	INST_OVER,		INT_MIN,-1-1},
     {"pop",		ASSEM_1BYTE,	INST_POP,		1,	0},
@@ -499,7 +503,10 @@ static unsigned char NonThrowingByteCodes[] = {
     INST_OVER,							/* 95 */
     INST_PUSH_RETURN_OPTIONS,					/* 108 */
     INST_REVERSE,						/* 126 */
-    INST_NOP							/* 132 */
+    INST_NOP,							/* 132 */
+    INST_NS_CURRENT,						/* 141 */
+    INST_COROUTINE_NAME,					/* 142 */
+    INST_INFO_LEVEL_NUM						/* 143 */
 };
 
 /*
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index b312026..3af577b 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -166,7 +166,7 @@ static const EnsembleImplMap defaultInfoMap[] = {
     {"cmdcount",	   InfoCmdCountCmd,	    NULL, NULL, NULL, 0},
     {"commands",	   InfoCommandsCmd,	    NULL, NULL, NULL, 0},
     {"complete",	   InfoCompleteCmd,	    NULL, NULL, NULL, 0},
-    {"coroutine",	   TclInfoCoroutineCmd,     NULL, NULL, NULL, 0},
+    {"coroutine",	   TclInfoCoroutineCmd,     TclCompileInfoCoroutineCmd, NULL, NULL, 0},
     {"default",		   InfoDefaultCmd,	    NULL, NULL, NULL, 0},
     {"errorstack",	   InfoErrorStackCmd,	    NULL, NULL, NULL, 0},
     {"exists",		   TclInfoExistsCmd,	    TclCompileInfoExistsCmd, NULL, NULL, 0},
@@ -174,7 +174,7 @@ static const EnsembleImplMap defaultInfoMap[] = {
     {"functions",	   InfoFunctionsCmd,	    NULL, NULL, NULL, 0},
     {"globals",		   TclInfoGlobalsCmd,	    NULL, NULL, NULL, 0},
     {"hostname",	   InfoHostnameCmd,	    NULL, NULL, NULL, 0},
-    {"level",		   InfoLevelCmd,	    NULL, NULL, NULL, 0},
+    {"level",		   InfoLevelCmd,	    TclCompileInfoLevelCmd, NULL, NULL, 0},
     {"library",		   InfoLibraryCmd,	    NULL, NULL, NULL, 0},
     {"loaded",		   InfoLoadedCmd,	    NULL, NULL, NULL, 0},
     {"locals",		   TclInfoLocalsCmd,	    NULL, NULL, NULL, 0},
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 5b7e0a5..79d29e9 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -2817,22 +2817,47 @@ TclCompileIncrCmd(
 /*
  *----------------------------------------------------------------------
  *
- * TclCompileInfoExistsCmd --
+ * TclCompileInfo*Cmd --
  *
- *	Procedure called to compile the "info exists" subcommand.
+ *	Procedures called to compile "info" subcommands.
  *
  * Results:
  *	Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
  *	evaluation to runtime.
  *
  * Side effects:
- *	Instructions are added to envPtr to execute the "info exists"
- *	subcommand at runtime.
+ *	Instructions are added to envPtr to execute the "info" subcommand at
+ *	runtime.
  *
  *----------------------------------------------------------------------
  */
 
 int
+TclCompileInfoCoroutineCmd(
+    Tcl_Interp *interp,		/* Used for error reporting. */
+    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. */
+{
+    /*
+     * Only compile [info coroutine] without arguments.
+     */
+
+    if (parsePtr->numWords != 1) {
+	return TCL_ERROR;
+    }
+
+    /*
+     * Not much to do; we compile to a single instruction...
+     */
+
+    TclEmitOpcode(		INST_COROUTINE_NAME,		envPtr);
+    return TCL_OK;
+}
+
+int
 TclCompileInfoExistsCmd(
     Tcl_Interp *interp,		/* Used for error reporting. */
     Tcl_Parse *parsePtr,	/* Points to a parse structure for the command
@@ -2883,6 +2908,42 @@ TclCompileInfoExistsCmd(
 
     return TCL_OK;
 }
+
+int
+TclCompileInfoLevelCmd(
+    Tcl_Interp *interp,		/* Used for error reporting. */
+    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. */
+{
+    /*
+     * Only compile [info level] without arguments or with a single argument.
+     */
+
+    if (parsePtr->numWords == 1) {
+	/*
+	 * Not much to do; we compile to a single instruction...
+	 */
+
+	TclEmitOpcode(		INST_INFO_LEVEL_NUM,		envPtr);
+    } else if (parsePtr->numWords != 2) {
+	return TCL_ERROR;
+    } else {
+	DefineLineInformation;	/* TIP #280 */
+
+	/*
+	 * Compile the argument, then add the instruction to convert it into a
+	 * list of arguments.
+	 */
+
+	SetLineInformation(1);
+	CompileTokens(envPtr, TokenAfter(parsePtr->tokenPtr), interp);
+	TclEmitOpcode(		INST_INFO_LEVEL_ARGS,		envPtr);
+    }
+    return TCL_OK;
+}
 
 /*
  *----------------------------------------------------------------------
@@ -3700,11 +3761,11 @@ TclCompileLsetCmd(
 /*
  *----------------------------------------------------------------------
  *
- * TclCompileNamespaceCmd --
+ * TclCompileNamespace*Cmd --
  *
- *	Procedure called to compile the "namespace" command; currently, only
- *	the subcommand "namespace upvar" is compiled to bytecodes, and then
- *	only inside a procedure(-like) context.
+ *	Procedures called to compile the "namespace" command; currently, only
+ *	the subcommands "namespace current" and "namespace upvar" are compiled
+ *	to bytecodes, and the latter only inside a procedure(-like) context.
  *
  * Results:
  *	Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
@@ -3718,6 +3779,31 @@ TclCompileLsetCmd(
  */
 
 int
+TclCompileNamespaceCurrentCmd(
+    Tcl_Interp *interp,		/* Used for error reporting. */
+    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. */
+{
+    /*
+     * Only compile [namespace current] without arguments.
+     */
+
+    if (parsePtr->numWords != 1) {
+	return TCL_ERROR;
+    }
+
+    /*
+     * Not much to do; we compile to a single instruction...
+     */
+
+    TclEmitOpcode(		INST_NS_CURRENT,		envPtr);
+    return TCL_OK;
+}
+
+int
 TclCompileNamespaceUpvarCmd(
     Tcl_Interp *interp,		/* Used for error reporting. */
     Tcl_Parse *parsePtr,	/* Points to a parse structure for the command
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 1d88e11..6f3f778 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -37,7 +37,7 @@ TCL_DECLARE_MUTEX(tableMutex)
 int tclTraceCompile = 0;
 static int traceInitialized = 0;
 #endif
-
+
 /*
  * A table describing the Tcl bytecode instructions. Entries in this table
  * must correspond to the instruction opcode definitions in tclCompile.h. The
@@ -435,6 +435,20 @@ InstructionDesc const tclInstructionTable[] = {
          * indicated by the LVT index. Part of [dict with].
 	 * Stack:  ... path keyList => ... */
 
+    {"nscurrent",	 1,    +1,	  0,	{OPERAND_NONE}},
+	/* Push the name of the interpreter's current namespace as an object
+	 * on the stack. */
+    {"coroName",         1,    +1,	  0,	{OPERAND_NONE}},
+	/* Push the name of the interpreter's current coroutine as an object
+	 * on the stack. */
+    {"infoLevelNumber",  1,    +1,	  0,	{OPERAND_NONE}},
+	/* Push the stack depth (i.e., [info level]) of the interpreter as an
+	 * object on the stack. */
+    {"infoLevelArgs",	 1,	0,	  0,	{OPERAND_NONE}},
+	/* Push the argument words to a stack depth (i.e., [info level <n>])
+	 * of the interpreter as an object on the stack.
+	 * Stack:  ... depth => ... argList */
+
     {NULL, 0, 0, 0, {OPERAND_NONE}}
 };
 
@@ -1673,10 +1687,10 @@ TclCompileScript(
 			    && !(cmdPtr->nsPtr->flags&NS_SUPPRESS_COMPILATION)
 			    && !(cmdPtr->flags & CMD_HAS_EXEC_TRACES)
 			    && !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) {
-			int savedNumCmds = envPtr->numCommands;
+			int code, savedNumCmds = envPtr->numCommands;
 			unsigned savedCodeNext =
 				envPtr->codeNext - envPtr->codeStart;
-			int update = 0, code;
+			int update = 0;
 
 			/*
 			 * Mark the start of the command; the proper bytecode
@@ -4627,6 +4641,5 @@ RecordByteCodeStats(
  * c-basic-offset: 4
  * fill-column: 78
  * tab-width: 8
- * indent-tabs-mode: nil
  * End:
  */
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 58663fd..e12debf 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -681,8 +681,14 @@ typedef struct ByteCode {
 #define INST_DICT_RECOMBINE_STK		139
 #define INST_DICT_RECOMBINE_IMM		140
 
+/* For compilation of basic information operations */
+#define INST_NS_CURRENT			141
+#define INST_COROUTINE_NAME		142
+#define INST_INFO_LEVEL_NUM		143
+#define INST_INFO_LEVEL_ARGS		144
+
 /* The last opcode */
-#define LAST_INST_OPCODE		140
+#define LAST_INST_OPCODE		144
 
 /*
  * Table describing the Tcl bytecode instructions: their name (for displaying
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index e402634..0c0de20 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -4045,6 +4045,70 @@ TEBCresume(
 
     /*
      * -----------------------------------------------------------------
+     *	   Start of general introspector instructions.
+     */
+
+    case INST_NS_CURRENT: {
+	Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
+
+	if (currNsPtr == (Namespace *) TclGetGlobalNamespace(interp)) {
+	    TclNewLiteralStringObj(objResultPtr, "::");
+	} else {
+	    TclNewStringObj(objResultPtr, currNsPtr->fullName,
+		    strlen(currNsPtr->fullName));
+	}
+	TRACE_WITH_OBJ(("=> "), objResultPtr);
+	NEXT_INST_F(1, 0, 1);
+    }
+    case INST_COROUTINE_NAME: {
+	CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
+
+	TclNewObj(objResultPtr);
+	if (corPtr && !(corPtr->cmdPtr->flags & CMD_IS_DELETED)) {
+	    Tcl_GetCommandFullName(interp, (Tcl_Command) corPtr->cmdPtr,
+		    objResultPtr);
+	}
+	TRACE_WITH_OBJ(("=> "), objResultPtr);
+	NEXT_INST_F(1, 0, 1);
+    }
+    case INST_INFO_LEVEL_NUM:
+	TclNewIntObj(objResultPtr, iPtr->varFramePtr->level);
+	TRACE_WITH_OBJ(("=> "), objResultPtr);
+	NEXT_INST_F(1, 0, 1);
+    case INST_INFO_LEVEL_ARGS: {
+	int level;
+	register CallFrame *framePtr = iPtr->varFramePtr;
+	register CallFrame *rootFramePtr = iPtr->rootFramePtr;
+
+	valuePtr = OBJ_AT_TOS;
+	if (TclGetIntFromObj(interp, valuePtr, &level) != TCL_OK) {
+	    TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)),
+		    Tcl_GetObjResult(interp));
+	    goto gotError;
+	}
+	TRACE(("%d => ", level));
+	if (level <= 0) {
+	    level += framePtr->level;
+	}
+	for (; (framePtr->level!=level) && (framePtr!=rootFramePtr) ;
+		framePtr = framePtr->callerVarPtr) {
+	    /* Empty loop body */
+	}
+	if (framePtr == rootFramePtr) {
+	    Tcl_AppendResult(interp, "bad level \"", TclGetString(valuePtr),
+		    "\"", NULL);
+	    TRACE_APPEND(("ERROR: bad level\n"));
+	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "STACK_LEVEL",
+		    TclGetString(valuePtr), NULL);
+	    goto gotError;
+	}
+	objResultPtr = Tcl_NewListObj(framePtr->objc, framePtr->objv);
+	TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+	NEXT_INST_F(1, 1, 1);
+    }
+
+    /*
+     * -----------------------------------------------------------------
      *	   Start of INST_LIST and related instructions.
      */
 
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 08b3f70..bc7cd9f 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3526,9 +3526,15 @@ MODULE_SCOPE int	TclCompileGlobalCmd(Tcl_Interp *interp,
 MODULE_SCOPE int	TclCompileIfCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
+MODULE_SCOPE int	TclCompileInfoCoroutineCmd(Tcl_Interp *interp,
+			    Tcl_Parse *parsePtr, Command *cmdPtr,
+			    struct CompileEnv *envPtr);
 MODULE_SCOPE int	TclCompileInfoExistsCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
+MODULE_SCOPE int	TclCompileInfoLevelCmd(Tcl_Interp *interp,
+			    Tcl_Parse *parsePtr, Command *cmdPtr,
+			    struct CompileEnv *envPtr);
 MODULE_SCOPE int	TclCompileIncrCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
@@ -3556,6 +3562,9 @@ MODULE_SCOPE int	TclCompileLreplaceCmd(Tcl_Interp *interp,
 MODULE_SCOPE int	TclCompileLsetCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
+MODULE_SCOPE int	TclCompileNamespaceCurrentCmd(Tcl_Interp *interp,
+			    Tcl_Parse *parsePtr, Command *cmdPtr,
+			    struct CompileEnv *envPtr);
 MODULE_SCOPE int	TclCompileNamespaceUpvarCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 73bc644..cdaba3d 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -104,7 +104,7 @@ static int		NamespaceDeleteCmd(ClientData dummy,Tcl_Interp *interp,
 static int		NamespaceEvalCmd(ClientData dummy, Tcl_Interp *interp,
 			    int objc, Tcl_Obj *const objv[]);
 static int		NRNamespaceEvalCmd(ClientData dummy,
-                            Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
+			    Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
 static int		NamespaceExistsCmd(ClientData dummy,Tcl_Interp *interp,
 			    int objc, Tcl_Obj *const objv[]);
 static int		NamespaceExportCmd(ClientData dummy,Tcl_Interp *interp,
@@ -160,25 +160,25 @@ static const Tcl_ObjType nsNameType = {
  */
 
 static const EnsembleImplMap defaultNamespaceMap[] = {
-    {"children",        NamespaceChildrenCmd, NULL, NULL, NULL, 0},
-    {"code",            NamespaceCodeCmd, NULL, NULL, NULL, 0},
-    {"current",         NamespaceCurrentCmd, NULL, NULL, NULL, 0},
-    {"delete",          NamespaceDeleteCmd, NULL, NULL, NULL, 0},
-    {"ensemble",        TclNamespaceEnsembleCmd, NULL, NULL, NULL, 0},
-    {"eval",            NamespaceEvalCmd,       NULL, NRNamespaceEvalCmd, NULL, 0},
-    {"exists",          NamespaceExistsCmd, NULL, NULL, NULL, 0},
-    {"export",          NamespaceExportCmd, NULL, NULL, NULL, 0},
-    {"forget",          NamespaceForgetCmd, NULL, NULL, NULL, 0},
-    {"import",          NamespaceImportCmd, NULL, NULL, NULL, 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},
-    {"qualifiers",      NamespaceQualifiersCmd, NULL, NULL, NULL, 0},
-    {"tail",            NamespaceTailCmd, NULL, NULL, NULL, 0},
-    {"unknown",         NamespaceUnknownCmd, NULL, NULL, NULL, 0},
-    {"upvar",           NamespaceUpvarCmd,      TclCompileNamespaceUpvarCmd, NULL, NULL, 0},
-    {"which",           NamespaceWhichCmd, NULL, NULL, NULL, 0},
+    {"children",	NamespaceChildrenCmd, NULL, NULL, NULL, 0},
+    {"code",		NamespaceCodeCmd, NULL, NULL, NULL, 0},
+    {"current",		NamespaceCurrentCmd,	TclCompileNamespaceCurrentCmd, NULL, NULL, 0},
+    {"delete",		NamespaceDeleteCmd, NULL, NULL, NULL, 0},
+    {"ensemble",	TclNamespaceEnsembleCmd, NULL, NULL, NULL, 0},
+    {"eval",		NamespaceEvalCmd,	NULL, NRNamespaceEvalCmd, NULL, 0},
+    {"exists",		NamespaceExistsCmd, NULL, NULL, NULL, 0},
+    {"export",		NamespaceExportCmd, NULL, NULL, NULL, 0},
+    {"forget",		NamespaceForgetCmd, NULL, NULL, NULL, 0},
+    {"import",		NamespaceImportCmd, NULL, NULL, NULL, 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},
+    {"qualifiers",	NamespaceQualifiersCmd, NULL, NULL, NULL, 0},
+    {"tail",		NamespaceTailCmd, NULL, NULL, NULL, 0},
+    {"unknown",		NamespaceUnknownCmd, NULL, NULL, NULL, 0},
+    {"upvar",		NamespaceUpvarCmd,	TclCompileNamespaceUpvarCmd, NULL, NULL, 0},
+    {"which",		NamespaceWhichCmd, NULL, NULL, NULL, 0},
     {NULL, NULL, NULL, NULL, NULL, 0}
 };
 
@@ -423,7 +423,7 @@ Tcl_PopCallFrame(
     framePtr->nsPtr = NULL;
 
     if (framePtr->tailcallPtr) {
-        TclSpliceTailcall(interp, framePtr->tailcallPtr);
+	TclSpliceTailcall(interp, framePtr->tailcallPtr);
     }
 }
 
@@ -690,8 +690,8 @@ Tcl_CreateNamespace(
 	Tcl_ResetResult(interp);
 	Tcl_AppendResult(interp, "can't create namespace \"\": "
 		"only global namespace can have empty name", NULL);
-        Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE",
-                "CREATEGLOBAL", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE",
+		"CREATEGLOBAL", NULL);
 	return NULL;
     } else {
 	/*
@@ -727,8 +727,8 @@ Tcl_CreateNamespace(
 	) {
 	    Tcl_AppendResult(interp, "can't create namespace \"", name,
 		    "\": already exists", NULL);
-            Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE",
-                    "CREATEEXISTING", NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE",
+		    "CREATEEXISTING", NULL);
 	    return NULL;
 	}
     }
@@ -1339,7 +1339,7 @@ Tcl_Export(
     if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) {
 	Tcl_AppendResult(interp, "invalid export pattern \"", pattern,
 		"\": pattern can't specify a namespace", NULL);
-        Tcl_SetErrorCode(interp, "TCL", "EXPORT", "INVALID", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "EXPORT", "INVALID", NULL);
 	return TCL_ERROR;
     }
 
@@ -1544,7 +1544,7 @@ Tcl_Import(
 
     if (strlen(pattern) == 0) {
 	Tcl_SetObjResult(interp, Tcl_NewStringObj("empty import pattern",-1));
-        Tcl_SetErrorCode(interp, "TCL", "IMPORT", "EMPTY", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "IMPORT", "EMPTY", NULL);
 	return TCL_ERROR;
     }
     TclGetNamespaceForQualName(interp, pattern, nsPtr,
@@ -1562,12 +1562,12 @@ Tcl_Import(
 	    Tcl_AppendResult(interp,
 		    "no namespace specified in import pattern \"", pattern,
 		    "\"", NULL);
-            Tcl_SetErrorCode(interp, "TCL", "IMPORT", "ORIGIN", NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "IMPORT", "ORIGIN", NULL);
 	} else {
 	    Tcl_AppendResult(interp, "import pattern \"", pattern,
 		    "\" tries to import from namespace \"",
 		    importNsPtr->name, "\" into itself", NULL);
-            Tcl_SetErrorCode(interp, "TCL", "IMPORT", "SELF", NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "IMPORT", "SELF", NULL);
 	}
 	return TCL_ERROR;
     }
@@ -1689,7 +1689,7 @@ DoImport(
 			    "\" would create a loop containing command \"",
 			    Tcl_DStringValue(&ds), "\"", NULL);
 		    Tcl_DStringFree(&ds);
-                    Tcl_SetErrorCode(interp, "TCL", "IMPORT", "LOOP", NULL);
+		    Tcl_SetErrorCode(interp, "TCL", "IMPORT", "LOOP", NULL);
 		    return TCL_ERROR;
 		}
 	    }
@@ -1729,7 +1729,7 @@ DoImport(
 	}
 	Tcl_AppendResult(interp, "can't import command \"", cmdName,
 		"\": already exists", NULL);
-        Tcl_SetErrorCode(interp, "TCL", "IMPORT", "OVERWRITE", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "IMPORT", "OVERWRITE", NULL);
 	return TCL_ERROR;
     }
     return TCL_OK;
@@ -3286,12 +3286,12 @@ NRNamespaceEvalCmd(
     }
 
     if (iPtr->ensembleRewrite.sourceObjs == NULL) {
-        framePtr->objc = objc;
-        framePtr->objv = objv;
+	framePtr->objc = objc;
+	framePtr->objv = objv;
     } else {
-        framePtr->objc = objc + iPtr->ensembleRewrite.numRemovedObjs
-                - iPtr->ensembleRewrite.numInsertedObjs;
-        framePtr->objv = iPtr->ensembleRewrite.sourceObjs;
+	framePtr->objc = objc + iPtr->ensembleRewrite.numRemovedObjs
+		- iPtr->ensembleRewrite.numInsertedObjs;
+	framePtr->objv = iPtr->ensembleRewrite.sourceObjs;
     }
 
     if (objc == 3) {
@@ -3749,12 +3749,12 @@ NRNamespaceInscopeCmd(
     }
 
     if (iPtr->ensembleRewrite.sourceObjs == NULL) {
-        framePtr->objc = objc;
-        framePtr->objv = objv;
+	framePtr->objc = objc;
+	framePtr->objv = objv;
     } else {
-        framePtr->objc = objc + iPtr->ensembleRewrite.numRemovedObjs
-                - iPtr->ensembleRewrite.numInsertedObjs;
-        framePtr->objv = iPtr->ensembleRewrite.sourceObjs;
+	framePtr->objc = objc + iPtr->ensembleRewrite.numRemovedObjs
+		- iPtr->ensembleRewrite.numInsertedObjs;
+	framePtr->objv = iPtr->ensembleRewrite.sourceObjs;
     }
 
     /*
@@ -3959,15 +3959,15 @@ NamespacePathCmd(
      */
 
     if (objc == 1) {
-        Tcl_Obj *resultObj = Tcl_NewObj();
+	Tcl_Obj *resultObj = Tcl_NewObj();
 
 	for (i=0 ; i<nsPtr->commandPathLength ; i++) {
 	    if (nsPtr->commandPathArray[i].nsPtr != NULL) {
-                Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj(
-                        nsPtr->commandPathArray[i].nsPtr->fullName, -1));
+		Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj(
+			nsPtr->commandPathArray[i].nsPtr->fullName, -1));
 	    }
 	}
-        Tcl_SetObjResult(interp, resultObj);
+	Tcl_SetObjResult(interp, resultObj);
 	return TCL_OK;
     }
 
@@ -4844,8 +4844,8 @@ TclLogCommandInfo(
     int length,			/* Number of bytes in command (-1 means use
 				 * all bytes up to first null byte). */
     const unsigned char *pc,    /* Current pc of bytecode execution context */
-    Tcl_Obj **tosPtr)           /* Current stack of bytecode execution
-                                 * context */
+    Tcl_Obj **tosPtr)		/* Current stack of bytecode execution
+				 * context */
 {
     register const char *p;
     Interp *iPtr = (Interp *) interp;
@@ -4862,55 +4862,55 @@ TclLogCommandInfo(
     }
 
     if (command != NULL) {
-        /*
-         * Compute the line number where the error occurred.
-         */
-
-        iPtr->errorLine = 1;
-        for (p = script; p != command; p++) {
-            if (*p == '\n') {
-                iPtr->errorLine++;
-            }
-        }
-
-        if (length < 0) {
-            length = strlen(command);
-        }
-        overflow = (length > limit);
-        Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+	/*
+	 * Compute the line number where the error occurred.
+	 */
+
+	iPtr->errorLine = 1;
+	for (p = script; p != command; p++) {
+	    if (*p == '\n') {
+		iPtr->errorLine++;
+	    }
+	}
+
+	if (length < 0) {
+	    length = strlen(command);
+	}
+	overflow = (length > limit);
+	Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
 		"\n    %s\n\"%.*s%s\"", ((iPtr->errorInfo == NULL)
 		? "while executing" : "invoked from within"),
 		(overflow ? limit : length), command,
 		(overflow ? "..." : "")));
 
-        varPtr = TclObjLookupVarEx(interp, iPtr->eiVar, NULL, TCL_GLOBAL_ONLY,
+	varPtr = TclObjLookupVarEx(interp, iPtr->eiVar, NULL, TCL_GLOBAL_ONLY,
 		NULL, 0, 0, &arrayPtr);
-        if ((varPtr == NULL) || !TclIsVarTraced(varPtr)) {
-            /*
-             * Should not happen.
-             */
-
-            return;
-        } else {
-            Tcl_HashEntry *hPtr
+	if ((varPtr == NULL) || !TclIsVarTraced(varPtr)) {
+	    /*
+	     * Should not happen.
+	     */
+
+	    return;
+	} else {
+	    Tcl_HashEntry *hPtr
 		    = Tcl_FindHashEntry(&iPtr->varTraces, (char *) varPtr);
-            VarTrace *tracePtr = Tcl_GetHashValue(hPtr);
+	    VarTrace *tracePtr = Tcl_GetHashValue(hPtr);
 
-            if (tracePtr->traceProc != EstablishErrorInfoTraces) {
-                /*
-                 * The most recent trace set on ::errorInfo is not the one the
-                 * core itself puts on last. This means some other code is
+	    if (tracePtr->traceProc != EstablishErrorInfoTraces) {
+		/*
+		 * The most recent trace set on ::errorInfo is not the one the
+		 * core itself puts on last. This means some other code is
 		 * tracing the variable, and the additional trace(s) might be
 		 * write traces that expect the timing of writes to
 		 * ::errorInfo that existed Tcl releases before 8.5. To
 		 * satisfy that compatibility need, we write the current
 		 * -errorinfo value to the ::errorInfo variable.
-                 */
+		 */
 
-                Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL, iPtr->errorInfo,
+		Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL, iPtr->errorInfo,
 			TCL_GLOBAL_ONLY);
-            }
-        }
+	    }
+	}
     }
 
     /*
@@ -4918,60 +4918,60 @@ TclLogCommandInfo(
      */
 
     if (Tcl_IsShared(iPtr->errorStack)) {
-        Tcl_Obj *newObj;
-            
-        newObj = Tcl_DuplicateObj(iPtr->errorStack);
-        Tcl_DecrRefCount(iPtr->errorStack);
-        Tcl_IncrRefCount(newObj);
-        iPtr->errorStack = newObj;
+	Tcl_Obj *newObj;
+	    
+	newObj = Tcl_DuplicateObj(iPtr->errorStack);
+	Tcl_DecrRefCount(iPtr->errorStack);
+	Tcl_IncrRefCount(newObj);
+	iPtr->errorStack = newObj;
     }
     if (iPtr->resetErrorStack) {
 	int len;
 
-        iPtr->resetErrorStack = 0;
+	iPtr->resetErrorStack = 0;
 	Tcl_ListObjLength(interp, iPtr->errorStack, &len);
 
-        /*
-         * Reset while keeping the list intrep as much as possible.
-         */
-
-        Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, 0, NULL);
-        if (pc != NULL) {
-            Tcl_Obj *innerContext;
-
-            innerContext = TclGetInnerContext(interp, pc, tosPtr);
-            if (innerContext != NULL) {
-                Tcl_ListObjAppendElement(NULL, iPtr->errorStack,
-                        iPtr->innerLiteral);
-                Tcl_ListObjAppendElement(NULL, iPtr->errorStack, innerContext);
-            }
-        } else if (command != NULL) {
-            Tcl_ListObjAppendElement(NULL, iPtr->errorStack,
-                    iPtr->innerLiteral);
-            Tcl_ListObjAppendElement(NULL, iPtr->errorStack,
-                    Tcl_NewStringObj(command, length));
-        }
+	/*
+	 * Reset while keeping the list intrep as much as possible.
+	 */
+
+	Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, 0, NULL);
+	if (pc != NULL) {
+	    Tcl_Obj *innerContext;
+
+	    innerContext = TclGetInnerContext(interp, pc, tosPtr);
+	    if (innerContext != NULL) {
+		Tcl_ListObjAppendElement(NULL, iPtr->errorStack,
+			iPtr->innerLiteral);
+		Tcl_ListObjAppendElement(NULL, iPtr->errorStack, innerContext);
+	    }
+	} else if (command != NULL) {
+	    Tcl_ListObjAppendElement(NULL, iPtr->errorStack,
+		    iPtr->innerLiteral);
+	    Tcl_ListObjAppendElement(NULL, iPtr->errorStack,
+		    Tcl_NewStringObj(command, length));
+	}
     } 
 
     if (!iPtr->framePtr->objc) {
-        /*
-         * Special frame, nothing to report.
-         */
+	/*
+	 * Special frame, nothing to report.
+	 */
     } else if (iPtr->varFramePtr != iPtr->framePtr) {
-        /*
-         * uplevel case, [lappend errorstack UP $relativelevel]
-         */
+	/*
+	 * uplevel case, [lappend errorstack UP $relativelevel]
+	 */
 
-        Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->upLiteral);
-        Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewIntObj(
+	Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->upLiteral);
+	Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewIntObj(
 		iPtr->framePtr->level - iPtr->varFramePtr->level));
     } else if (iPtr->framePtr != iPtr->rootFramePtr) {
-        /*
-         * normal case, [lappend errorstack CALL [info level 0]]
-         */
+	/*
+	 * normal case, [lappend errorstack CALL [info level 0]]
+	 */
 
-        Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->callLiteral);
-        Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewListObj(
+	Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->callLiteral);
+	Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewListObj(
 		iPtr->framePtr->objc, iPtr->framePtr->objv));
     }
 }
@@ -4981,8 +4981,8 @@ TclLogCommandInfo(
  *
  * TclErrorStackResetIf --
  *
- *      The TIP 348 reset/no-bc part of TLCI, for specific use by
- *      TclCompileSyntaxError.
+ *	The TIP 348 reset/no-bc part of TLCI, for specific use by
+ *	TclCompileSyntaxError.
  *
  * Results:
  *	None.
@@ -5003,27 +5003,27 @@ TclErrorStackResetIf(
     Interp *iPtr = (Interp *) interp;
 
     if (Tcl_IsShared(iPtr->errorStack)) {
-        Tcl_Obj *newObj;
-            
-        newObj = Tcl_DuplicateObj(iPtr->errorStack);
-        Tcl_DecrRefCount(iPtr->errorStack);
-        Tcl_IncrRefCount(newObj);
-        iPtr->errorStack = newObj;
+	Tcl_Obj *newObj;
+	    
+	newObj = Tcl_DuplicateObj(iPtr->errorStack);
+	Tcl_DecrRefCount(iPtr->errorStack);
+	Tcl_IncrRefCount(newObj);
+	iPtr->errorStack = newObj;
     }
     if (iPtr->resetErrorStack) {
 	int len;
 
-        iPtr->resetErrorStack = 0;
+	iPtr->resetErrorStack = 0;
 	Tcl_ListObjLength(interp, iPtr->errorStack, &len);
 
-        /*
-         * Reset while keeping the list intrep as much as possible.
-         */
+	/*
+	 * Reset while keeping the list intrep as much as possible.
+	 */
 
-        Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, 0, NULL);
-        Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->innerLiteral);
-        Tcl_ListObjAppendElement(NULL, iPtr->errorStack,
-                Tcl_NewStringObj(msg, length));
+	Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, 0, NULL);
+	Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->innerLiteral);
+	Tcl_ListObjAppendElement(NULL, iPtr->errorStack,
+		Tcl_NewStringObj(msg, length));
     } 
 }
 
@@ -5066,6 +5066,5 @@ Tcl_LogCommandInfo(
  * c-basic-offset: 4
  * fill-column: 78
  * tab-width: 8
- * indent-tabs-mode: nil
  * End:
  */
diff --git a/tests/info.test b/tests/info.test
index 3323281..a9f740e 100644
--- a/tests/info.test
+++ b/tests/info.test
@@ -1955,6 +1955,12 @@ test info-38.2 {location information for uplevel, dl, direct-literal} -match glo
 * {type source line 1951 file info.test cmd etrace level 1}
 * {type source line 1949 file info.test cmd uplevel\\ \\\\ level 1}} -cleanup {interp delete sub}
 
+# This test at the end of this file _only_ to avoid disturbing above line
+# numbers. It _belongs_ after info-9.12
+test info-9.13 {info level option, value in global context} -body {
+    uplevel #0 {info level 2}
+} -returnCodes error -result {bad level "2"}
+
 # -------------------------------------------------------------------------
 unset -nocomplain res
 
-- 
cgit v0.12


From a584e5f052e71147186d2607dfc67e1e8c7e19c3 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Fri, 19 Oct 2012 14:17:18 +0000
Subject: yet another small introspector: [self]

---
 generic/tclAssembly.c |  1 +
 generic/tclCompCmds.c | 34 ++++++++++++++++++++++++++++++++++
 generic/tclCompile.c  |  3 +++
 generic/tclCompile.h  |  3 ++-
 generic/tclExecute.c  | 24 ++++++++++++++++++++++++
 generic/tclInt.h      |  3 +++
 generic/tclOO.c       |  6 ++++--
 7 files changed, 71 insertions(+), 3 deletions(-)

diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index a266350..132ee68 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -476,6 +476,7 @@ static const TalInstDesc TalInstructionTable[] = {
     {"strmatch",	ASSEM_BOOL,	INST_STR_MATCH,		2,	1},
     {"strneq",		ASSEM_1BYTE,	INST_STR_NEQ,		2,	1},
     {"sub",		ASSEM_1BYTE,	INST_SUB,		2,	1},
+    {"tclooSelf",	ASSEM_1BYTE,	INST_TCLOO_SELF,	0,	1},
     {"tryCvtToNumeric",	ASSEM_1BYTE,	INST_TRY_CVT_TO_NUMERIC,1,	1},
     {"uminus",		ASSEM_1BYTE,	INST_UMINUS,		1,	1},
     {"unset",		ASSEM_BOOL_LVT4,INST_UNSET_SCALAR,	0,	0},
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 64417c5..3f916a6 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -4687,6 +4687,40 @@ IndexTailVarIfKnown(
     return localIndex;
 }
 
+int
+TclCompileObjectSelfCmd(
+    Tcl_Interp *interp,		/* Used for error reporting. */
+    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. */
+{
+    /*
+     * We only handle [self] and [self object] (which is the same operation).
+     * These are the only very common operations on [self] for which
+     * bytecoding is at all reasonable.
+     */
+
+    if (parsePtr->numWords > 2) {
+	return TCL_ERROR;
+    } else if (parsePtr->numWords == 2) {
+	Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
+
+	if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size==0 ||
+		strncmp(tokenPtr[1].start, "object", tokenPtr[1].size) != 0) {
+	    return TCL_ERROR;
+	}
+    }
+
+    /*
+     * This delegates the entire problem to a single opcode.
+     */
+
+    TclEmitOpcode(		INST_TCLOO_SELF,		envPtr);
+    return TCL_OK;
+}
+
 /*
  *----------------------------------------------------------------------
  *
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 4c84953..3ee0fdf 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -448,6 +448,9 @@ InstructionDesc const tclInstructionTable[] = {
 	/* Push the argument words to a stack depth (i.e., [info level <n>])
 	 * of the interpreter as an object on the stack.
 	 * Stack:  ... depth => ... argList */
+    {"tclooSelf",	 1,	+1,	  0,	{OPERAND_NONE}},
+	/* Push the identity of the current TclOO object (i.e., the name of
+	 * its current public access command) on the stack. */
 
     {NULL, 0, 0, 0, {OPERAND_NONE}}
 };
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 4e039a2..044bef9 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -686,9 +686,10 @@ typedef struct ByteCode {
 #define INST_COROUTINE_NAME		142
 #define INST_INFO_LEVEL_NUM		143
 #define INST_INFO_LEVEL_ARGS		144
+#define INST_TCLOO_SELF			145
 
 /* The last opcode */
-#define LAST_INST_OPCODE		144
+#define LAST_INST_OPCODE		145
 
 /*
  * Table describing the Tcl bytecode instructions: their name (for displaying
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 1041f65..0ec16e9 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -17,6 +17,7 @@
 
 #include "tclInt.h"
 #include "tclCompile.h"
+#include "tclOOInt.h"
 #include "tommath.h"
 #include <math.h>
 
@@ -4106,6 +4107,29 @@ TEBCresume(
 	TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
 	NEXT_INST_F(1, 1, 1);
     }
+    case INST_TCLOO_SELF: {
+	CallFrame *framePtr = iPtr->varFramePtr;
+	CallContext *contextPtr;
+
+	if (framePtr == NULL ||
+		!(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
+	    TRACE(("=> ERROR: no TclOO call context\n"));
+	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
+		    "self may only be called from inside a method",
+		    -1));
+	    Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
+	    goto gotError;
+	}
+	contextPtr = framePtr->clientData;
+
+	/*
+	 * Call out to get the name; it's expensive to compute but cached.
+	 */
+
+	objResultPtr = TclOOObjectName(interp, contextPtr->oPtr);
+	TRACE_WITH_OBJ(("=> "), objResultPtr);
+	NEXT_INST_F(1, 0, 1);
+    }
 
     /*
      * -----------------------------------------------------------------
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 0b84914..9bf492c 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3598,6 +3598,9 @@ MODULE_SCOPE int	TclCompileNamespaceUpvarCmd(Tcl_Interp *interp,
 MODULE_SCOPE int	TclCompileNoOp(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
+MODULE_SCOPE int	TclCompileObjectSelfCmd(Tcl_Interp *interp,
+			    Tcl_Parse *parsePtr, Command *cmdPtr,
+			    struct CompileEnv *envPtr);
 MODULE_SCOPE int	TclCompileRegexpCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
diff --git a/generic/tclOO.c b/generic/tclOO.c
index 04a2bf7..d6d2d6a 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -314,6 +314,7 @@ InitFoundation(
     Foundation *fPtr = ckalloc(sizeof(Foundation));
     Tcl_Obj *namePtr, *argsPtr, *bodyPtr;
     Tcl_DString buffer;
+    Command *cmdPtr;
     int i;
 
     /*
@@ -440,8 +441,9 @@ InitFoundation(
 	    NULL);
     Tcl_CreateObjCommand(interp, "::oo::Helpers::nextto", TclOONextToObjCmd,
 	    NULL, NULL);
-    Tcl_CreateObjCommand(interp, "::oo::Helpers::self", TclOOSelfObjCmd, NULL,
-	    NULL);
+    cmdPtr = (Command *) Tcl_CreateObjCommand(interp, "::oo::Helpers::self",
+	    TclOOSelfObjCmd, NULL, NULL);
+    cmdPtr->compileProc = TclCompileObjectSelfCmd;
     Tcl_CreateObjCommand(interp, "::oo::define", TclOODefineObjCmd, NULL,
 	    NULL);
     Tcl_CreateObjCommand(interp, "::oo::objdefine", TclOOObjDefObjCmd, NULL,
-- 
cgit v0.12


From 734725f73ece60c4a1c37fa5b5ca038767066dce Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Thu, 25 Oct 2012 09:56:35 +0000
Subject: Added compilation of [namespace code] (except for gnarly edge cases).

---
 generic/tclCompCmds.c | 50 ++++++++++++++++++++++++++++++++++++++++++++++++++
 generic/tclInt.h      |  3 +++
 generic/tclNamesp.c   |  2 +-
 3 files changed, 54 insertions(+), 1 deletion(-)

diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index bba5384..66bc5f0 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -4040,6 +4040,56 @@ TclCompileNamespaceCurrentCmd(
 }
 
 int
+TclCompileNamespaceCodeCmd(
+    Tcl_Interp *interp,		/* Used for error reporting. */
+    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. */
+{
+    Tcl_Token *tokenPtr;
+    DefineLineInformation;	/* TIP #280 */
+
+    if (parsePtr->numWords != 2) {
+	return TCL_ERROR;
+    }
+    tokenPtr = TokenAfter(parsePtr->tokenPtr);
+
+    /*
+     * The specification of [namespace code] is rather shocking, in that it is
+     * supposed to check if the argument is itself the result of [namespace
+     * code] and not apply itself in that case. Which is excessively cautious,
+     * but what the test suite checks for.
+     */
+
+    if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || (tokenPtr[1].size > 20
+	    && strncmp(tokenPtr[1].start, "::namespace inscope ", 20) == 0)) {
+	/*
+	 * Technically, we could just pass a literal '::namespace inscope '
+	 * term through, but that's something which really shouldn't be
+	 * occurring as something that the user writes so we'll just punt it.
+	 */
+
+	return TCL_ERROR;
+    }
+
+    /*
+     * Now we can compile using the same strategy as [namespace code]'s normal
+     * implementation does internally. Note that we can't bind the namespace
+     * name directly here, because TclOO plays complex games with namespaces;
+     * the value needs to be determined at runtime for safety.
+     */
+
+    PushLiteral(envPtr,		"::namespace",		11);
+    PushLiteral(envPtr,		"inscope",		7);
+    TclEmitOpcode(		INST_NS_CURRENT,	envPtr);
+    CompileWord(envPtr,		tokenPtr,		interp, 1);
+    TclEmitInstInt4(		INST_LIST, 4,		envPtr);
+    return TCL_OK;
+}
+
+int
 TclCompileNamespaceUpvarCmd(
     Tcl_Interp *interp,		/* Used for error reporting. */
     Tcl_Parse *parsePtr,	/* Points to a parse structure for the command
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 02c8a35..1bf52d1 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3588,6 +3588,9 @@ MODULE_SCOPE int	TclCompileLreplaceCmd(Tcl_Interp *interp,
 MODULE_SCOPE int	TclCompileLsetCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
+MODULE_SCOPE int	TclCompileNamespaceCodeCmd(Tcl_Interp *interp,
+			    Tcl_Parse *parsePtr, Command *cmdPtr,
+			    struct CompileEnv *envPtr);
 MODULE_SCOPE int	TclCompileNamespaceCurrentCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index d98de97..072eb72 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -161,7 +161,7 @@ static const Tcl_ObjType nsNameType = {
 
 static const EnsembleImplMap defaultNamespaceMap[] = {
     {"children",	NamespaceChildrenCmd, NULL, NULL, NULL, 0},
-    {"code",		NamespaceCodeCmd, NULL, NULL, NULL, 0},
+    {"code",		NamespaceCodeCmd,	TclCompileNamespaceCodeCmd, NULL, NULL, 0},
     {"current",		NamespaceCurrentCmd,	TclCompileNamespaceCurrentCmd, NULL, NULL, 0},
     {"delete",		NamespaceDeleteCmd, NULL, NULL, NULL, 0},
     {"ensemble",	TclNamespaceEnsembleCmd, NULL, NULL, NULL, 0},
-- 
cgit v0.12


From 13ba95be1022fb41168cfe6da51ab798eb9bd82b Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Fri, 26 Oct 2012 07:32:47 +0000
Subject: Compile [namespace which -command]; big performance saving in some
 contexts.

---
 generic/tclAssembly.c |  4 +++-
 generic/tclCompCmds.c | 46 ++++++++++++++++++++++++++++++++++++++++++++++
 generic/tclCompile.c  |  5 +++++
 generic/tclCompile.h  |  5 +++--
 generic/tclExecute.c  | 10 ++++++++++
 generic/tclInt.h      |  3 +++
 generic/tclNamesp.c   |  2 +-
 7 files changed, 71 insertions(+), 4 deletions(-)

diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 132ee68..27720c7 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -461,6 +461,7 @@ static const TalInstDesc TalInstructionTable[] = {
 								0,	1},
     {"pushResult",	ASSEM_1BYTE,	INST_PUSH_RESULT,	0,	1},
     {"regexp",		ASSEM_REGEXP,	INST_REGEXP,		2,	1},
+    {"resolveCmd",	ASSEM_1BYTE,	INST_RESOLVE_COMMAND,	1,	1},
     {"reverse",		ASSEM_REVERSE,	INST_REVERSE,		INT_MIN,-1-0},
     {"rshift",		ASSEM_1BYTE,	INST_RSHIFT,		2,	1},
     {"store",		ASSEM_LVT,	(INST_STORE_SCALAR1<<8
@@ -507,7 +508,8 @@ static const unsigned char NonThrowingByteCodes[] = {
     INST_NOP,							/* 132 */
     INST_NS_CURRENT,						/* 141 */
     INST_COROUTINE_NAME,					/* 142 */
-    INST_INFO_LEVEL_NUM						/* 143 */
+    INST_INFO_LEVEL_NUM,					/* 143 */
+    INST_RESOLVE_COMMAND					/* 145 */
 };
 
 /*
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 66bc5f0..245779e 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -4151,6 +4151,52 @@ TclCompileNamespaceUpvarCmd(
     PushLiteral(envPtr, "", 0);
     return TCL_OK;
 }
+
+int
+TclCompileNamespaceWhichCmd(
+    Tcl_Interp *interp,		/* Used for error reporting. */
+    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, *opt;
+    int idx;
+
+    if (parsePtr->numWords < 2 || parsePtr->numWords > 3) {
+	return TCL_ERROR;
+    }
+    tokenPtr = TokenAfter(parsePtr->tokenPtr);
+    idx = 1;
+
+    /*
+     * If there's an option, check that it's "-command". We don't handle
+     * "-variable" (currently) and anything else is an error.
+     */
+
+    if (parsePtr->numWords == 3) {
+	if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+	    return TCL_ERROR;
+	}
+	opt = tokenPtr + 1;
+	if (opt->size < 2 || opt->size > 8
+		|| strncmp(opt->start, "-command", opt->size) != 0) {
+	    return TCL_ERROR;
+	}
+	tokenPtr = TokenAfter(tokenPtr);
+	idx++;
+    }
+
+    /*
+     * Issue the bytecode.
+     */
+
+    CompileWord(envPtr,		tokenPtr,		interp, idx);
+    TclEmitOpcode(		INST_RESOLVE_COMMAND,	envPtr);
+    return TCL_OK;
+}
 
 /*
  *----------------------------------------------------------------------
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 3ee0fdf..b331551 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -448,6 +448,11 @@ InstructionDesc const tclInstructionTable[] = {
 	/* Push the argument words to a stack depth (i.e., [info level <n>])
 	 * of the interpreter as an object on the stack.
 	 * Stack:  ... depth => ... argList */
+    {"resolveCmd",	 1,	0,	  0,	{OPERAND_NONE}},
+	/* Resolves the command named on the top of the stack to its fully
+	 * qualified version, or produces the empty string if no such command
+	 * exists. Never generates errors.
+	 * Stack:  ... cmdName => ... fullCmdName */
     {"tclooSelf",	 1,	+1,	  0,	{OPERAND_NONE}},
 	/* Push the identity of the current TclOO object (i.e., the name of
 	 * its current public access command) on the stack. */
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 044bef9..86a0f77 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -686,10 +686,11 @@ typedef struct ByteCode {
 #define INST_COROUTINE_NAME		142
 #define INST_INFO_LEVEL_NUM		143
 #define INST_INFO_LEVEL_ARGS		144
-#define INST_TCLOO_SELF			145
+#define INST_RESOLVE_COMMAND		145
+#define INST_TCLOO_SELF			146
 
 /* The last opcode */
-#define LAST_INST_OPCODE		145
+#define LAST_INST_OPCODE		146
 
 /*
  * Table describing the Tcl bytecode instructions: their name (for displaying
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 0ec16e9..a24c806 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -4107,6 +4107,16 @@ TEBCresume(
 	TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
 	NEXT_INST_F(1, 1, 1);
     }
+    case INST_RESOLVE_COMMAND: {
+	Tcl_Command cmd = Tcl_GetCommandFromObj(interp, OBJ_AT_TOS);
+
+	TclNewObj(objResultPtr);
+	if (cmd != NULL) {
+	    Tcl_GetCommandFullName(interp, cmd, objResultPtr);
+	}
+	TRACE_WITH_OBJ(("\"%.20s\" => ", O2S(OBJ_AT_TOS)), objResultPtr);
+	NEXT_INST_F(1, 1, 1);
+    }
     case INST_TCLOO_SELF: {
 	CallFrame *framePtr = iPtr->varFramePtr;
 	CallContext *contextPtr;
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 1bf52d1..448a7cd 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3597,6 +3597,9 @@ MODULE_SCOPE int	TclCompileNamespaceCurrentCmd(Tcl_Interp *interp,
 MODULE_SCOPE int	TclCompileNamespaceUpvarCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
+MODULE_SCOPE int	TclCompileNamespaceWhichCmd(Tcl_Interp *interp,
+			    Tcl_Parse *parsePtr, Command *cmdPtr,
+			    struct CompileEnv *envPtr);
 MODULE_SCOPE int	TclCompileNoOp(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 072eb72..60c40d0 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -178,7 +178,7 @@ static const EnsembleImplMap defaultNamespaceMap[] = {
     {"tail",		NamespaceTailCmd, NULL, NULL, NULL, 0},
     {"unknown",		NamespaceUnknownCmd, NULL, NULL, NULL, 0},
     {"upvar",		NamespaceUpvarCmd,	TclCompileNamespaceUpvarCmd, NULL, NULL, 0},
-    {"which",		NamespaceWhichCmd, NULL, NULL, NULL, 0},
+    {"which",		NamespaceWhichCmd,	TclCompileNamespaceWhichCmd, NULL, NULL, 0},
     {NULL, NULL, NULL, NULL, NULL, 0}
 };
 
-- 
cgit v0.12


From 41128611bfaf31dda3432dbc81222ad68ae6f485 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Fri, 26 Oct 2012 13:13:27 +0000
Subject: Working towards a BCCed [yield]; this doesn't work right now.

---
 generic/tclAssembly.c   |  9 +++++----
 generic/tclBasic.c      | 15 +++++++--------
 generic/tclCompCmdsSZ.c | 43 +++++++++++++++++++++++++++++++++++++++++++
 generic/tclCompile.c    | 12 +++++++++---
 generic/tclCompile.h    | 17 ++++++++++-------
 generic/tclExecute.c    | 26 ++++++++++++++++++++++++++
 generic/tclInt.h        |  4 ++++
 7 files changed, 104 insertions(+), 22 deletions(-)

diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 27720c7..5ff96fd 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -370,6 +370,7 @@ static const TalInstDesc TalInstructionTable[] = {
     {"bitxor",		ASSEM_1BYTE,	INST_BITXOR,		2,	1},
     {"concat",		ASSEM_CONCAT1,	INST_CONCAT1,		INT_MIN,1},
     {"coroName",	ASSEM_1BYTE,	INST_COROUTINE_NAME,	0,	1},
+    {"currentNamespace",ASSEM_1BYTE,	INST_NS_CURRENT,	0,	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},
@@ -452,7 +453,6 @@ static const TalInstDesc TalInstructionTable[] = {
     {"neq",		ASSEM_1BYTE,	INST_NEQ,		2,	1},
     {"nop",		ASSEM_1BYTE,	INST_NOP,		0,	0},
     {"not",		ASSEM_1BYTE,	INST_LNOT,		1,	1},
-    {"nscurrent",	ASSEM_1BYTE,	INST_NS_CURRENT,	0,	1},
     {"nsupvar",		ASSEM_LVT4,	INST_NSUPVAR,		2,	1},
     {"over",		ASSEM_OVER,	INST_OVER,		INT_MIN,-1-1},
     {"pop",		ASSEM_1BYTE,	INST_POP,		1,	0},
@@ -487,6 +487,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},
+    {"yield",		ASSEM_1BYTE,	INST_YIELD,		1,	1},
     {NULL,		0,		0,			0,	0}
 };
 
@@ -506,10 +507,10 @@ static const unsigned char NonThrowingByteCodes[] = {
     INST_PUSH_RETURN_OPTIONS,					/* 108 */
     INST_REVERSE,						/* 126 */
     INST_NOP,							/* 132 */
-    INST_NS_CURRENT,						/* 141 */
     INST_COROUTINE_NAME,					/* 142 */
-    INST_INFO_LEVEL_NUM,					/* 143 */
-    INST_RESOLVE_COMMAND					/* 145 */
+    INST_NS_CURRENT,						/* 143 */
+    INST_INFO_LEVEL_NUM,					/* 144 */
+    INST_RESOLVE_COMMAND					/* 146 */
 };
 
 /*
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 3848d5b..ab087e6 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -131,7 +131,6 @@ static Tcl_Obj *	GetCommandSource(Interp *iPtr, int objc,
 			    Tcl_Obj *const objv[], int lookup);
 static void		MathFuncWrongNumArgs(Tcl_Interp *interp, int expected,
 			    int actual, Tcl_Obj *const *objv);
-static Tcl_NRPostProc	NRCoroutineActivateCallback;
 static Tcl_NRPostProc	NRCoroutineCallerCallback;
 static Tcl_NRPostProc	NRCoroutineExitCallback;
 static int NRCommand(ClientData data[], Tcl_Interp *interp, int result);
@@ -258,7 +257,7 @@ static const CmdInfo builtInCmds[] = {
     {"upvar",		Tcl_UpvarObjCmd,	TclCompileUpvarCmd,	NULL,	1},
     {"variable",	Tcl_VariableObjCmd,	TclCompileVariableCmd,	NULL,	1},
     {"while",		Tcl_WhileObjCmd,	TclCompileWhileCmd,	TclNRWhileObjCmd,	1},
-    {"yield",		NULL,			NULL,			TclNRYieldObjCmd,	1},
+    {"yield",		NULL,			TclCompileYieldCmd,	TclNRYieldObjCmd,	1},
     {"yieldto",		NULL,			NULL,			TclNRYieldToObjCmd,	1},
 
     /*
@@ -8495,7 +8494,7 @@ TclNRYieldObjCmd(
     }
 
     NRE_ASSERT(!COR_IS_SUSPENDED(corPtr));
-    TclNRAddCallback(interp, NRCoroutineActivateCallback, corPtr,
+    TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr,
             clientData, NULL, NULL);
     return TCL_OK;
 }
@@ -8712,7 +8711,7 @@ NRCoroutineExitCallback(
 /*
  *----------------------------------------------------------------------
  *
- * NRCoroutineActivateCallback --
+ * TclNRCoroutineActivateCallback --
  *
  *      This is the workhorse for coroutines: it implements both yield and
  *      resume.
@@ -8726,8 +8725,8 @@ NRCoroutineExitCallback(
  *----------------------------------------------------------------------
  */
 
-static int
-NRCoroutineActivateCallback(
+int
+TclNRCoroutineActivateCallback(
     ClientData data[],
     Tcl_Interp *interp,
     int result)
@@ -8902,7 +8901,7 @@ TclNRInterpCoroutine(
         break;
     }
 
-    TclNRAddCallback(interp, NRCoroutineActivateCallback, corPtr,
+    TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr,
             NULL, NULL, NULL);
     return TCL_OK;
 }
@@ -9059,7 +9058,7 @@ TclNRCoroutineObjCmd(
      * Now just resume the coroutine.
      */
 
-    TclNRAddCallback(interp, NRCoroutineActivateCallback, corPtr,
+    TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr,
             NULL, NULL, NULL);
     return TCL_OK;
 }
diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index 8ed3a95..d7dd58e 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -2752,6 +2752,49 @@ TclCompileWhileCmd(
 /*
  *----------------------------------------------------------------------
  *
+ * TclCompileYieldCmd --
+ *
+ *	Procedure called to compile the "yield" command.
+ *
+ * Results:
+ *	Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ *	evaluation to runtime.
+ *
+ * Side effects:
+ *	Instructions are added to envPtr to execute the "yield" command at
+ *	runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileYieldCmd(
+    Tcl_Interp *interp,		/* Used for error reporting. */
+    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. */
+{
+    if (parsePtr->numWords < 1 || parsePtr->numWords > 2) {
+	return TCL_ERROR;
+    }
+
+    if (parsePtr->numWords == 1) {
+	PushLiteral(envPtr, "", 0);
+    } else {
+	DefineLineInformation;	/* TIP #280 */
+	Tcl_Token *valueTokenPtr = TokenAfter(parsePtr->tokenPtr);
+
+	CompileWord(envPtr, valueTokenPtr, interp, 1);
+    }
+    TclEmitOpcode(INST_YIELD, envPtr);
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * PushVarName --
  *
  *	Procedure used in the compiling where pushing a variable name is
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index b331551..1924334 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -435,12 +435,18 @@ InstructionDesc const tclInstructionTable[] = {
          * indicated by the LVT index. Part of [dict with].
 	 * Stack:  ... path keyList => ... */
 
-    {"nscurrent",	 1,    +1,	  0,	{OPERAND_NONE}},
-	/* Push the name of the interpreter's current namespace as an object
-	 * on the stack. */
+    {"yield",		 1,	0,	  0,	{OPERAND_NONE}},
+	/* Makes the current coroutine yield the value at the top of the
+	 * stack, and places the response back on top of the stack when it
+	 * resumes.
+	 * Stack:  ... valueToYield => ... resumeValue */
     {"coroName",         1,    +1,	  0,	{OPERAND_NONE}},
 	/* Push the name of the interpreter's current coroutine as an object
 	 * on the stack. */
+
+    {"currentNamespace", 1,    +1,	  0,	{OPERAND_NONE}},
+	/* Push the name of the interpreter's current namespace as an object
+	 * on the stack. */
     {"infoLevelNumber",  1,    +1,	  0,	{OPERAND_NONE}},
 	/* Push the stack depth (i.e., [info level]) of the interpreter as an
 	 * object on the stack. */
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 86a0f77..fcff46c 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -681,16 +681,19 @@ typedef struct ByteCode {
 #define INST_DICT_RECOMBINE_STK		139
 #define INST_DICT_RECOMBINE_IMM		140
 
-/* For compilation of basic information operations */
-#define INST_NS_CURRENT			141
+/* For operations to do with coroutines */
+#define INST_YIELD			141
 #define INST_COROUTINE_NAME		142
-#define INST_INFO_LEVEL_NUM		143
-#define INST_INFO_LEVEL_ARGS		144
-#define INST_RESOLVE_COMMAND		145
-#define INST_TCLOO_SELF			146
+
+/* For compilation of basic information operations */
+#define INST_NS_CURRENT			143
+#define INST_INFO_LEVEL_NUM		144
+#define INST_INFO_LEVEL_ARGS		145
+#define INST_RESOLVE_COMMAND		146
+#define INST_TCLOO_SELF			147
 
 /* The last opcode */
-#define LAST_INST_OPCODE		146
+#define LAST_INST_OPCODE		147
 
 /*
  * Table describing the Tcl bytecode instructions: their name (for displaying
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index a24c806..30f8d77 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -2332,6 +2332,32 @@ TEBCresume(
 	cleanup = 1;
 	goto processExceptionReturn;
 
+    case INST_YIELD: {
+	CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
+
+	TRACE(("%.30s => ", O2S(OBJ_AT_TOS)));
+	if (!corPtr) {
+	    TRACE_APPEND(("ERROR: yield outside coroutine\n"));
+	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
+		    "yield can only be called in a coroutine", -1));
+	    Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD",
+		    NULL);
+	    goto gotError;
+	}
+
+	Tcl_SetObjResult(interp, OBJ_AT_TOS);
+	TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr,
+		INT2PTR(0), NULL, NULL);
+
+#ifdef TCL_COMPILE_DEBUG
+	TRACE_WITH_OBJ(("yield, result="), iPtr->objResultPtr);
+	if (traceInstructions) {
+	    fprintf(stdout, "\n");
+	}
+#endif
+	goto checkForCatch;
+    }
+
     case INST_DONE:
 	if (tosPtr > initTosPtr) {
 	    /*
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 448a7cd..865378e 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -2797,6 +2797,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRUplevelObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRWhileObjCmd;
 
 MODULE_SCOPE Tcl_NRPostProc TclNRForIterCallback;
+MODULE_SCOPE Tcl_NRPostProc TclNRCoroutineActivateCallback;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRTailcallObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRCoroutineObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd;
@@ -3654,6 +3655,9 @@ MODULE_SCOPE int	TclCompileVariableCmd(Tcl_Interp *interp,
 MODULE_SCOPE int	TclCompileWhileCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
+MODULE_SCOPE int	TclCompileYieldCmd(Tcl_Interp *interp,
+			    Tcl_Parse *parsePtr, Command *cmdPtr,
+			    struct CompileEnv *envPtr);
 
 MODULE_SCOPE int	TclInvertOpCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
-- 
cgit v0.12


From 8122cb706d823c4c19c4baf564529a0d372fc601 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Sun, 28 Oct 2012 16:01:31 +0000
Subject: Added [self namespace] to bytecoded command set.

---
 generic/tclCompCmds.c | 39 ++++++++++++++++++++++++++++++++++-----
 1 file changed, 34 insertions(+), 5 deletions(-)

diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 245779e..d7ee85e 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -4859,23 +4859,52 @@ TclCompileObjectSelfCmd(
      * bytecoding is at all reasonable.
      */
 
-    if (parsePtr->numWords > 2) {
-	return TCL_ERROR;
+    if (parsePtr->numWords == 1) {
+	goto compileSelfObject;
     } else if (parsePtr->numWords == 2) {
-	Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
+	Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr), *subcmd;
 
-	if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size==0 ||
-		strncmp(tokenPtr[1].start, "object", tokenPtr[1].size) != 0) {
+	if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size==0) {
 	    return TCL_ERROR;
 	}
+
+	subcmd = tokenPtr + 1;
+	if (strncmp(subcmd->start, "object", subcmd->size) == 0) {
+	    goto compileSelfObject;
+	} else if (strncmp(subcmd->start, "namespace", subcmd->size) == 0) {
+	    goto compileSelfNamespace;
+	}
     }
 
     /*
+     * Can't compile; handle with runtime call.
+     */
+
+    return TCL_ERROR;
+
+  compileSelfObject:
+
+    /*
      * This delegates the entire problem to a single opcode.
      */
 
     TclEmitOpcode(		INST_TCLOO_SELF,		envPtr);
     return TCL_OK;
+
+  compileSelfNamespace:
+
+    /*
+     * This is formally only correct with TclOO methods as they are currently
+     * implemented; it assumes that the current namespace is invariably when a
+     * TclOO context is present is the object's namespace, and that's
+     * technically only something that's a matter of current policy. But it
+     * avoids creating another opcode, so that's all good!
+     */
+
+    TclEmitOpcode(		INST_TCLOO_SELF,		envPtr);
+    TclEmitOpcode(		INST_POP,			envPtr);
+    TclEmitOpcode(		INST_NS_CURRENT,		envPtr);
+    return TCL_OK;
 }
 
 /*
-- 
cgit v0.12


From f7bae6ac6002df7f2c3a1636ec63c58c9d2fc61f Mon Sep 17 00:00:00 2001
From: mig <mig>
Date: Sun, 28 Oct 2012 18:58:20 +0000
Subject: fix INST_YIELD so that it works

---
 generic/tclExecute.c | 26 +++++++++++++++++++++-----
 1 file changed, 21 insertions(+), 5 deletions(-)

diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 30f8d77..b42e4ab 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -2345,17 +2345,33 @@ TEBCresume(
 	    goto gotError;
 	}
 
-	Tcl_SetObjResult(interp, OBJ_AT_TOS);
-	TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr,
-		INT2PTR(0), NULL, NULL);
-
 #ifdef TCL_COMPILE_DEBUG
 	TRACE_WITH_OBJ(("yield, result="), iPtr->objResultPtr);
 	if (traceInstructions) {
 	    fprintf(stdout, "\n");
 	}
 #endif
-	goto checkForCatch;
+	/* TIP #280: Record the last piece of info needed by
+	 * 'TclGetSrcInfoForPc', and push the frame.
+	 */
+	
+	bcFramePtr->data.tebc.pc = (char *) pc;
+	iPtr->cmdFramePtr = bcFramePtr;
+
+	if (iPtr->flags & INTERP_DEBUG_FRAME) {
+	    TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc,
+		    codePtr, bcFramePtr, pc - codePtr->codeStart);
+	}
+
+	pc++;
+	cleanup = 1;
+	TEBC_YIELD();
+	
+	Tcl_SetObjResult(interp, OBJ_AT_TOS);
+	TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr,
+		INT2PTR(0), NULL, NULL);
+
+	return TCL_OK;
     }
 
     case INST_DONE:
-- 
cgit v0.12


From 1c889c03527bb5c11d74e13aa68ef2d64d33793d Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Mon, 29 Oct 2012 11:02:45 +0000
Subject: Compilation of [info commands] in the case of a fully-qualified
 literal name.

---
 generic/tclCmdIL.c    |  2 +-
 generic/tclCompCmds.c | 58 +++++++++++++++++++++++++++++++++++++++++++++++++++
 generic/tclInt.h      |  3 +++
 3 files changed, 62 insertions(+), 1 deletion(-)

diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index 14e9f0e..7be017d 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -164,7 +164,7 @@ static const EnsembleImplMap defaultInfoMap[] = {
     {"args",		   InfoArgsCmd,		    NULL, NULL, NULL, 0},
     {"body",		   InfoBodyCmd,		    NULL, NULL, NULL, 0},
     {"cmdcount",	   InfoCmdCountCmd,	    NULL, NULL, NULL, 0},
-    {"commands",	   InfoCommandsCmd,	    NULL, NULL, NULL, 0},
+    {"commands",	   InfoCommandsCmd,	    TclCompileInfoCommandsCmd, NULL, NULL, 0},
     {"complete",	   InfoCompleteCmd,	    NULL, NULL, NULL, 0},
     {"coroutine",	   TclInfoCoroutineCmd,     TclCompileInfoCoroutineCmd, NULL, NULL, 0},
     {"default",		   InfoDefaultCmd,	    NULL, NULL, NULL, 0},
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index d7ee85e..79b2709 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -3038,6 +3038,64 @@ TclCompileIncrCmd(
  */
 
 int
+TclCompileInfoCommandsCmd(
+    Tcl_Interp *interp,		/* Used for error reporting. */
+    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)
+{
+    DefineLineInformation;	/* TIP #280 */
+    Tcl_Token *tokenPtr;
+    Tcl_Obj *objPtr;
+    char *bytes;
+
+    /*
+     * We require one compile-time known argument for the case we can compile.
+     */
+
+    if (parsePtr->numWords != 2) {
+	return TCL_ERROR;
+    }
+    tokenPtr = TokenAfter(parsePtr->tokenPtr);
+    objPtr = Tcl_NewObj();
+    Tcl_IncrRefCount(objPtr);
+    if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) {
+	goto notCompilable;
+    }
+    bytes = Tcl_GetString(objPtr);
+
+    /*
+     * We require that the argument start with "::" and not have any of "*\[?"
+     * in it. (Theoretically, we should look in only the final component, but
+     * the difference is so slight given current naming practices.)
+     */
+
+    if (bytes[0] != ':' || bytes[1] != ':' || !TclMatchIsTrivial(bytes)) {
+	goto notCompilable;
+    }
+    Tcl_DecrRefCount(objPtr);
+
+    /*
+     * Confirmed as a literal that will not frighten the horses. Compile. Note
+     * that the result needs to be list-ified.
+     */
+
+    CompileWord(envPtr, tokenPtr,		interp, 1);
+    TclEmitOpcode(	INST_RESOLVE_COMMAND,	envPtr);
+    TclEmitOpcode(	INST_DUP,		envPtr);
+    TclEmitOpcode(	INST_STR_LEN,		envPtr);
+    TclEmitInstInt1(	INST_JUMP_FALSE1, 7,	envPtr);
+    TclEmitInstInt4(	INST_LIST, 1,		envPtr);
+    return TCL_OK;
+
+  notCompilable:
+    Tcl_DecrRefCount(objPtr);
+    return TCL_ERROR;
+}
+
+int
 TclCompileInfoCoroutineCmd(
     Tcl_Interp *interp,		/* Used for error reporting. */
     Tcl_Parse *parsePtr,	/* Points to a parse structure for the command
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 448a7cd..a26ade3 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3549,6 +3549,9 @@ MODULE_SCOPE int	TclCompileGlobalCmd(Tcl_Interp *interp,
 MODULE_SCOPE int	TclCompileIfCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
+MODULE_SCOPE int	TclCompileInfoCommandsCmd(Tcl_Interp *interp,
+			    Tcl_Parse *parsePtr, Command *cmdPtr,
+			    struct CompileEnv *envPtr);
 MODULE_SCOPE int	TclCompileInfoCoroutineCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
-- 
cgit v0.12


From 0d71be4a7eaa6a8aaff906519c3017df2eafc59b Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Mon, 29 Oct 2012 17:15:00 +0000
Subject: Compiler for some of the simpler cases of [format].

---
 generic/tclBasic.c    |   2 +-
 generic/tclCompCmds.c | 219 ++++++++++++++++++++++++++++++++++++++++++++++++++
 generic/tclInt.h      |   3 +
 3 files changed, 223 insertions(+), 1 deletion(-)

diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index ab087e6..1e07161 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -218,7 +218,7 @@ static const CmdInfo builtInCmds[] = {
     {"expr",		Tcl_ExprObjCmd,		TclCompileExprCmd,	TclNRExprObjCmd,	1},
     {"for",		Tcl_ForObjCmd,		TclCompileForCmd,	TclNRForObjCmd,	1},
     {"foreach",		Tcl_ForeachObjCmd,	TclCompileForeachCmd,	TclNRForeachCmd,	1},
-    {"format",		Tcl_FormatObjCmd,	NULL,			NULL,	1},
+    {"format",		Tcl_FormatObjCmd,	TclCompileFormatCmd,	NULL,	1},
     {"global",		Tcl_GlobalObjCmd,	TclCompileGlobalCmd,	NULL,	1},
     {"if",		Tcl_IfObjCmd,		TclCompileIfCmd,	TclNRIfObjCmd,	1},
     {"incr",		Tcl_IncrObjCmd,		TclCompileIncrCmd,	NULL,	1},
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 79b2709..5c21a2f 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -2514,6 +2514,225 @@ PrintForeachInfo(
  *
  * TclCompileGlobalCmd --
  *
+ *	Procedure called to compile the "format" command.
+ *
+ * Results:
+ *	Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ *	evaluation to runtime.
+ *
+ * Side effects:
+ *	Instructions are added to envPtr to execute the "format" command at
+ *	runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileFormatCmd(
+    Tcl_Interp *interp,		/* Used for error reporting. */
+    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 = parsePtr->tokenPtr;
+    Tcl_Obj **objv, *formatObj, *tmpObj;
+    char *bytes, *start;
+    int i, j, len;
+
+    /*
+     * Don't handle any guaranteed-error cases.
+     */
+
+    if (parsePtr->numWords < 2) {
+	return TCL_ERROR;
+    }
+
+    /*
+     * Check if the argument words are all compile-time-known literals; that's
+     * a case we can handle by compiling to a constant.
+     */
+
+    formatObj = Tcl_NewObj();
+    Tcl_IncrRefCount(formatObj);
+    tokenPtr = TokenAfter(tokenPtr);
+    if (!TclWordKnownAtCompileTime(tokenPtr, formatObj)) {
+	Tcl_DecrRefCount(formatObj);
+	return TCL_ERROR;
+    }
+
+    objv = ckalloc((parsePtr->numWords-2) * sizeof(Tcl_Obj *));
+    for (i=0 ; i+2 < parsePtr->numWords ; i++) {
+	tokenPtr = TokenAfter(tokenPtr);
+	objv[i] = Tcl_NewObj();
+	Tcl_IncrRefCount(objv[i]);
+	if (!TclWordKnownAtCompileTime(tokenPtr, objv[i])) {
+	    goto checkForStringConcatCase;
+	}
+    }
+
+    /*
+     * Everything is a literal, so the result is constant too (or an error if
+     * the format is broken). Do the format now.
+     */
+
+    tmpObj = Tcl_Format(interp, Tcl_GetString(formatObj),
+	    parsePtr->numWords-2, objv);
+    for (; --i>=0 ;) {
+	Tcl_DecrRefCount(objv[i]);
+    }
+    ckfree(objv);
+    Tcl_DecrRefCount(formatObj);
+    if (tmpObj == NULL) {
+	return TCL_ERROR;
+    }
+
+    /*
+     * Not an error, always a constant result, so just push the result as a
+     * literal. Job done.
+     */
+
+    bytes = Tcl_GetStringFromObj(tmpObj, &len);
+    PushLiteral(envPtr, bytes, len);
+    Tcl_DecrRefCount(tmpObj);
+    return TCL_OK;
+
+  checkForStringConcatCase:
+    /*
+     * See if we can generate a sequence of things to concatenate. This
+     * requires that all the % sequences be %s or %%, as everything else is
+     * sufficiently complex that we don't bother.
+     *
+     * First, get the state of the system relatively sensible (cleaning up
+     * after our attempt to spot a literal).
+     */
+
+    for (; --i>=0 ;) {
+	Tcl_DecrRefCount(objv[i]);
+    }
+    ckfree(objv);
+    tokenPtr = TokenAfter(parsePtr->tokenPtr);
+    tokenPtr = TokenAfter(tokenPtr);
+    i = 0;
+
+    /*
+     * Now scan through and check for non-%s and non-%% substitutions.
+     */
+
+    for (bytes = Tcl_GetString(formatObj) ; *bytes ; bytes++) {
+	if (*bytes == '%') {
+	    bytes++;
+	    if (*bytes == 's') {
+		i++;
+		continue;
+	    } else if (*bytes == '%') {
+		continue;
+	    }
+	    Tcl_DecrRefCount(formatObj);
+	    return TCL_ERROR;
+	}
+    }
+
+    /*
+     * Check if the number of things to concatenate will fit in a byte.
+     */
+
+    if (i+2 != parsePtr->numWords || i > 125) {
+	Tcl_DecrRefCount(formatObj);
+	return TCL_ERROR;
+    }
+
+    /*
+     * Generate the pushes of the things to concatenate, a sequence of
+     * literals and compiled tokens (of which at least one is non-literal or
+     * we'd have the case in the first half of this function) which we will
+     * concatenate.
+     */
+
+    i = 0;			/* The count of things to concat. */
+    j = 2;			/* The index into the argument tokens, for
+				 * TIP#280 handling. */
+    start = Tcl_GetString(formatObj);
+				/* The start of the currently-scanned literal
+				 * in the format string. */
+    tmpObj = Tcl_NewObj();	/* The buffer used to accumulate the literal
+				 * being built. */
+    for (bytes = start ; *bytes ; bytes++) {
+	if (*bytes == '%') {
+	    Tcl_AppendToObj(tmpObj, start, bytes - start);
+	    if (*++bytes == '%') {
+		Tcl_AppendToObj(tmpObj, "%", 1);
+	    } else {
+		char *b = Tcl_GetStringFromObj(tmpObj, &len);
+
+		/*
+		 * If there is a non-empty literal from the format string,
+		 * push it and reset.
+		 */
+
+		if (len > 0) {
+		    PushLiteral(envPtr, b, len);
+		    Tcl_DecrRefCount(tmpObj);
+		    tmpObj = Tcl_NewObj();
+		    i++;
+		}
+
+		/*
+		 * Push the code to produce the string that would be
+		 * substituted with %s, except we'll be concatenating
+		 * directly.
+		 */
+
+		CompileWord(envPtr, tokenPtr, interp, j);
+		tokenPtr = TokenAfter(tokenPtr);
+		j++;
+		i++;
+	    }
+	    start = bytes + 1;
+	}
+    }
+
+    /*
+     * Handle the case of a trailing literal.
+     */
+
+    Tcl_AppendToObj(tmpObj, start, bytes - start);
+    bytes = Tcl_GetStringFromObj(tmpObj, &len);
+    if (len > 0) {
+	PushLiteral(envPtr, bytes, len);
+	i++;
+    }
+    Tcl_DecrRefCount(tmpObj);
+    Tcl_DecrRefCount(formatObj);
+
+    if (i > 1) {
+	/*
+	 * Do the concatenation, which produces the result.
+	 */
+
+	TclEmitInstInt1(INST_CONCAT1, i, envPtr);
+    } else {
+	/*
+	 * EVIL HACK! Force there to be a string representation in the case
+	 * where there's just a "%s" in the format; case covered by the test
+	 * format-20.1 (and it is horrible...)
+	 */
+
+	TclEmitOpcode(INST_DUP, envPtr);
+	PushLiteral(envPtr, "", 0);
+	TclEmitOpcode(INST_STR_EQ, envPtr);
+	TclEmitOpcode(INST_POP, envPtr);
+    }
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileGlobalCmd --
+ *
  *	Procedure called to compile the "global" command.
  *
  * Results:
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 7182c05..46c7a13 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3544,6 +3544,9 @@ MODULE_SCOPE int	TclCompileForCmd(Tcl_Interp *interp,
 MODULE_SCOPE int	TclCompileForeachCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
+MODULE_SCOPE int	TclCompileFormatCmd(Tcl_Interp *interp,
+			    Tcl_Parse *parsePtr, Command *cmdPtr,
+			    struct CompileEnv *envPtr);
 MODULE_SCOPE int	TclCompileGlobalCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
-- 
cgit v0.12


From bedb57a468dd806574089fc8b9eee940129c156b Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Mon, 29 Oct 2012 17:16:55 +0000
Subject: Minor: correct a comment

---
 generic/tclCompCmds.c | 5 +++--
 1 file changed, 3 insertions(+), 2 deletions(-)

diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 5c21a2f..777d66b 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -2512,9 +2512,10 @@ PrintForeachInfo(
 /*
  *----------------------------------------------------------------------
  *
- * TclCompileGlobalCmd --
+ * TclCompileFormatCmd --
  *
- *	Procedure called to compile the "format" command.
+ *	Procedure called to compile the "format" command. Handles cases that
+ *	can be done as constants or simple string concatenation only.
  *
  * Results:
  *	Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
-- 
cgit v0.12


From 05d8b591837b723be192e9df1ada8df1701a74b5 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Mon, 29 Oct 2012 21:35:49 +0000
Subject: Added compilation of simplest practical case of [string map].

---
 generic/tclAssembly.c   | 10 +++---
 generic/tclCmdMZ.c      |  2 +-
 generic/tclCompCmdsSZ.c | 82 +++++++++++++++++++++++++++++++++++++++++++++++++
 generic/tclCompile.c    |  5 +++
 generic/tclCompile.h    | 19 +++++++-----
 generic/tclExecute.c    | 52 +++++++++++++++++++++++++++++++
 generic/tclInt.h        |  3 ++
 7 files changed, 160 insertions(+), 13 deletions(-)

diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 5ff96fd..10df71a 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -474,6 +474,7 @@ static const TalInstDesc TalInstructionTable[] = {
     {"streq",		ASSEM_1BYTE,	INST_STR_EQ,		2,	1},
     {"strindex",	ASSEM_1BYTE,	INST_STR_INDEX,		2,	1},
     {"strlen",		ASSEM_1BYTE,	INST_STR_LEN,		1,	1},
+    {"strmap",		ASSEM_1BYTE,	INST_STR_MAP,		3,	1},
     {"strmatch",	ASSEM_BOOL,	INST_STR_MATCH,		2,	1},
     {"strneq",		ASSEM_1BYTE,	INST_STR_NEQ,		2,	1},
     {"sub",		ASSEM_1BYTE,	INST_SUB,		2,	1},
@@ -507,10 +508,11 @@ static const unsigned char NonThrowingByteCodes[] = {
     INST_PUSH_RETURN_OPTIONS,					/* 108 */
     INST_REVERSE,						/* 126 */
     INST_NOP,							/* 132 */
-    INST_COROUTINE_NAME,					/* 142 */
-    INST_NS_CURRENT,						/* 143 */
-    INST_INFO_LEVEL_NUM,					/* 144 */
-    INST_RESOLVE_COMMAND					/* 146 */
+    INST_STR_MAP,						/* 141 */
+    INST_COROUTINE_NAME,					/* 143 */
+    INST_NS_CURRENT,						/* 144 */
+    INST_INFO_LEVEL_NUM,					/* 145 */
+    INST_RESOLVE_COMMAND					/* 147 */
 };
 
 /*
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 9e720ea..1f210dd 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -3309,7 +3309,7 @@ TclInitStringCmd(
 	{"is",		StringIsCmd,	NULL, NULL, NULL, 0},
 	{"last",	StringLastCmd,	NULL, NULL, NULL, 0},
 	{"length",	StringLenCmd,	TclCompileStringLenCmd, NULL, NULL, 0},
-	{"map",		StringMapCmd,	NULL, NULL, NULL, 0},
+	{"map",		StringMapCmd,	TclCompileStringMapCmd, NULL, NULL, 0},
 	{"match",	StringMatchCmd,	TclCompileStringMatchCmd, NULL, NULL, 0},
 	{"range",	StringRangeCmd,	NULL, NULL, NULL, 0},
 	{"repeat",	StringReptCmd,	NULL, NULL, NULL, 0},
diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index d7dd58e..b8dada5 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -557,6 +557,88 @@ TclCompileStringLenCmd(
 /*
  *----------------------------------------------------------------------
  *
+ * TclCompileStringMapCmd --
+ *
+ *	Procedure called to compile the simplest and most common form of the
+ *	"string map" command.
+ *
+ * Results:
+ *	Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ *	evaluation to runtime.
+ *
+ * Side effects:
+ *	Instructions are added to envPtr to execute the "string map" command
+ *	at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileStringMapCmd(
+    Tcl_Interp *interp,		/* Used for error reporting. */
+    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 *mapTokenPtr, *stringTokenPtr;
+    Tcl_Obj *mapObj, **objv;
+    char *bytes;
+    int len;
+
+    /*
+     * We only handle the case:
+     *
+     *    string map {foo bar} $thing
+     *
+     * That is, a literal two-element list (doesn't need to be brace-quoted,
+     * but does need to be compile-time knowable) and any old argument (the
+     * thing to map).
+     */
+
+    if (parsePtr->numWords != 3) {
+	return TCL_ERROR;
+    }
+    mapTokenPtr = TokenAfter(parsePtr->tokenPtr);
+    stringTokenPtr = TokenAfter(mapTokenPtr);
+    mapObj = Tcl_NewObj();
+    Tcl_IncrRefCount(mapObj);
+    if (!TclWordKnownAtCompileTime(mapTokenPtr, mapObj)) {
+	Tcl_DecrRefCount(mapObj);
+	return TCL_ERROR;
+    } else if (Tcl_ListObjGetElements(NULL, mapObj, &len, &objv) != TCL_OK) {
+	Tcl_DecrRefCount(mapObj);
+	return TCL_ERROR;
+    } else if (len != 2) {
+	Tcl_DecrRefCount(mapObj);
+	return TCL_ERROR;
+    }
+
+    /*
+     * Now issue the opcodes. Note that in the case that we know that the
+     * first word is an empty word, we don't issue the map at all. That is the
+     * correct semantics for mapping.
+     */
+
+    bytes = Tcl_GetStringFromObj(objv[0], &len);
+    if (len == 0) {
+	CompileWord(envPtr, stringTokenPtr, interp, 2);
+    } else {
+	PushLiteral(envPtr, bytes, len);
+	bytes = Tcl_GetStringFromObj(objv[1], &len);
+	PushLiteral(envPtr, bytes, len);
+	CompileWord(envPtr, stringTokenPtr, interp, 2);
+	TclEmitOpcode(INST_STR_MAP, envPtr);
+    }
+    Tcl_DecrRefCount(mapObj);
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * TclCompileSubstCmd --
  *
  *	Procedure called to compile the "subst" command.
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 1924334..8b98746 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -435,6 +435,11 @@ InstructionDesc const tclInstructionTable[] = {
          * indicated by the LVT index. Part of [dict with].
 	 * Stack:  ... path keyList => ... */
 
+    {"strmap",		 1,    -2,	  0,	{OPERAND_NONE}},
+	/* Simplified version of [string map] that only applies one change
+	 * string, and only case-sensitively.
+	 * Stack:  ... from to string => changedString */
+
     {"yield",		 1,	0,	  0,	{OPERAND_NONE}},
 	/* Makes the current coroutine yield the value at the top of the
 	 * stack, and places the response back on top of the stack when it
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index fcff46c..ff2f0e3 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -681,19 +681,22 @@ typedef struct ByteCode {
 #define INST_DICT_RECOMBINE_STK		139
 #define INST_DICT_RECOMBINE_IMM		140
 
+/* For [string map] and [regsub] compilation */
+#define INST_STR_MAP			141
+
 /* For operations to do with coroutines */
-#define INST_YIELD			141
-#define INST_COROUTINE_NAME		142
+#define INST_YIELD			142
+#define INST_COROUTINE_NAME		143
 
 /* For compilation of basic information operations */
-#define INST_NS_CURRENT			143
-#define INST_INFO_LEVEL_NUM		144
-#define INST_INFO_LEVEL_ARGS		145
-#define INST_RESOLVE_COMMAND		146
-#define INST_TCLOO_SELF			147
+#define INST_NS_CURRENT			144
+#define INST_INFO_LEVEL_NUM		145
+#define INST_INFO_LEVEL_ARGS		146
+#define INST_RESOLVE_COMMAND		147
+#define INST_TCLOO_SELF			148
 
 /* The last opcode */
-#define LAST_INST_OPCODE		147
+#define LAST_INST_OPCODE		148
 
 /*
  * Table describing the Tcl bytecode instructions: their name (for displaying
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index b42e4ab..10cbf46 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -4732,6 +4732,58 @@ TEBCresume(
 		O2S(objResultPtr)));
 	NEXT_INST_F(1, 2, 1);
 
+    case INST_STR_MAP: {
+	Tcl_UniChar *ustring1, *ustring2, *ustring3, *end, *p;
+	int length3;
+	Tcl_Obj *value3Ptr;
+
+	valuePtr = OBJ_AT_TOS;		/* "Main" string. */
+	value3Ptr = OBJ_UNDER_TOS;	/* "Target" string. */
+	value2Ptr = OBJ_AT_DEPTH(2);	/* "Source" string. */
+	if (value3Ptr == value2Ptr || valuePtr == value2Ptr) {
+	    objResultPtr = valuePtr;
+	    NEXT_INST_V(1, 3, 1);
+	}
+	ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length);
+	if (length == 0) {
+	    objResultPtr = valuePtr;
+	    NEXT_INST_V(1, 3, 1);
+	}
+	ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2);
+	if (length2 > length || length2 == 0) {
+	    objResultPtr = valuePtr;
+	    NEXT_INST_V(1, 3, 1);
+	}
+	ustring3 = Tcl_GetUnicodeFromObj(value3Ptr, &length3);
+
+	objResultPtr = Tcl_NewUnicodeObj(ustring1, 0);
+	p = ustring1;
+	end = ustring1 + length;
+	for (; ustring1 < end; ustring1++) {
+	    if ((*ustring1 == *ustring2) &&
+		    (length2==1 || Tcl_UniCharNcmp(ustring1, ustring2,
+				(unsigned long) length2) == 0)) {
+		if (p != ustring1) {
+		    Tcl_AppendUnicodeToObj(objResultPtr, p, ustring1-p);
+		    p = ustring1 + length2;
+		} else {
+		    p += length2;
+		}
+		ustring1 = p - 1;
+
+		Tcl_AppendUnicodeToObj(objResultPtr, ustring3, length3);
+	    }
+	}
+	if (p != ustring1) {
+	    /*
+	     * Put the rest of the unmapped chars onto result.
+	     */
+
+	    Tcl_AppendUnicodeToObj(objResultPtr, p, ustring1 - p);
+	}
+	NEXT_INST_V(1, 3, 1);
+    }
+
     case INST_STR_MATCH:
 	nocase = TclGetInt1AtPtr(pc+1);
 	valuePtr = OBJ_AT_TOS;		/* String */
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 46c7a13..3aaed4c 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3634,6 +3634,9 @@ MODULE_SCOPE int	TclCompileStringIndexCmd(Tcl_Interp *interp,
 MODULE_SCOPE int	TclCompileStringLenCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
+MODULE_SCOPE int	TclCompileStringMapCmd(Tcl_Interp *interp,
+			    Tcl_Parse *parsePtr, Command *cmdPtr,
+			    struct CompileEnv *envPtr);
 MODULE_SCOPE int	TclCompileStringMatchCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
-- 
cgit v0.12


From 71560be8195a455b260188f4dbffe1575feb0e07 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Tue, 30 Oct 2012 12:39:40 +0000
Subject: Added compilation of [regsub] (in the simplest, most restricted
 case).

---
 generic/tclBasic.c    |   2 +-
 generic/tclCompCmds.c | 174 ++++++++++++++++++++++++++++++++++++++++++++++++++
 generic/tclInt.h      |   3 +
 3 files changed, 178 insertions(+), 1 deletion(-)

diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 1e07161..6e60aee 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -240,7 +240,7 @@ static const CmdInfo builtInCmds[] = {
     {"package",		Tcl_PackageObjCmd,	NULL,			NULL,	1},
     {"proc",		Tcl_ProcObjCmd,		NULL,			NULL,	1},
     {"regexp",		Tcl_RegexpObjCmd,	TclCompileRegexpCmd,	NULL,	1},
-    {"regsub",		Tcl_RegsubObjCmd,	NULL,			NULL,	1},
+    {"regsub",		Tcl_RegsubObjCmd,	TclCompileRegsubCmd,	NULL,	1},
     {"rename",		Tcl_RenameObjCmd,	NULL,			NULL,	1},
     {"return",		Tcl_ReturnObjCmd,	TclCompileReturnCmd,	NULL,	1},
     {"scan",		Tcl_ScanObjCmd,		NULL,			NULL,	1},
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 777d66b..029606e 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -4644,6 +4644,180 @@ TclCompileRegexpCmd(
 /*
  *----------------------------------------------------------------------
  *
+ * TclCompileRegsubCmd --
+ *
+ *	Procedure called to compile the "regsub" command.
+ *
+ * Results:
+ *	Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ *	evaluation to runtime.
+ *
+ * Side effects:
+ *	Instructions are added to envPtr to execute the "regsub" command at
+ *	runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileRegsubCmd(
+    Tcl_Interp *interp,		/* Tcl interpreter for error reporting. */
+    Tcl_Parse *parsePtr,	/* Points to a parse structure for the
+				 * command. */
+    Command *cmdPtr,		/* Points to defintion of command being
+				 * compiled. */
+    CompileEnv *envPtr)		/* Holds the resulting instructions. */
+{
+    /*
+     * We only compile the case with [regsub -all] where the pattern is both
+     * known at compile time and simple (i.e., no RE metacharacters). That is,
+     * the pattern must be translatable into a glob like "*foo*" with no other
+     * glob metacharacters inside it; there must be some "foo" in there too.
+     * The substitution string must also be known at compile time and free of
+     * metacharacters ("\digit" and "&"). Finally, there must not be a
+     * variable mentioned in the [regsub] to write the result back to (because
+     * we can't get the count of substitutions that would be the result in
+     * that case). The key is that these are the conditions under which a
+     * [string map] could be used instead, in particular a [string map] of the
+     * form we can compile to bytecode.
+     *
+     * In short, we look for:
+     *
+     *   regsub -all [--] simpleRE string simpleReplacement
+     *
+     * The only optional part is the "--", and no other options are handled.
+     */
+
+    DefineLineInformation;	/* TIP #280 */
+    Tcl_Token *tokenPtr, *stringTokenPtr;
+    Tcl_Obj *patternObj = NULL, *replacementObj = NULL;
+    Tcl_DString pattern;
+    const char *bytes;
+    int len, exact, result = TCL_ERROR;
+
+    if (parsePtr->numWords < 5 || parsePtr->numWords > 6) {
+	return TCL_ERROR;
+    }
+
+    /*
+     * Parse the "-all", which must be the first argument (other options not
+     * supported, non-"-all" substitution we can't compile).
+     */
+
+    tokenPtr = TokenAfter(parsePtr->tokenPtr);
+    if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size != 4
+	    || strncmp(tokenPtr[1].start, "-all", 4)) {
+	return TCL_ERROR;
+    }
+
+    /*
+     * Get the pattern into patternObj, checking for "--" in the process.
+     */
+
+    Tcl_DStringInit(&pattern);
+    tokenPtr = TokenAfter(tokenPtr);
+    patternObj = Tcl_NewObj();
+    if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) {
+	goto done;
+    }
+    if (Tcl_GetString(patternObj)[0] == '-') {
+	if (strcmp(Tcl_GetString(patternObj), "--") != 0
+		|| parsePtr->numWords == 5) {
+	    goto done;
+	}
+	tokenPtr = TokenAfter(tokenPtr);
+	Tcl_DecrRefCount(patternObj);
+	patternObj = Tcl_NewObj();
+	if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) {
+	    goto done;
+	}
+    } else if (parsePtr->numWords == 6) {
+	goto done;
+    }
+
+    /*
+     * Identify the code which produces the string to apply the substitution
+     * to (stringTokenPtr), and the replacement string (into replacementObj).
+     */
+
+    stringTokenPtr = TokenAfter(tokenPtr);
+    tokenPtr = TokenAfter(stringTokenPtr);
+    replacementObj = Tcl_NewObj();
+    if (!TclWordKnownAtCompileTime(tokenPtr, replacementObj)) {
+	goto done;
+    }
+
+    /*
+     * Next, higher-level checks. Is the RE a very simple glob? Is the
+     * replacement "simple"?
+     */
+
+    bytes = Tcl_GetStringFromObj(patternObj, &len);
+    if (TclReToGlob(NULL, bytes, len, &pattern, &exact) != TCL_OK || exact) {
+	goto done;
+    }
+    bytes = Tcl_DStringValue(&pattern);
+    if (*bytes++ != '*') {
+	goto done;
+    }
+    while (1) {
+	switch (*bytes) {
+	case '*':
+	    if (bytes[1] == '\0') {
+		/*
+		 * OK, we've proved there are no metacharacters except for the
+		 * '*' at each end.
+		 */
+
+		len = Tcl_DStringLength(&pattern) - 2;
+		if (len > 0) {
+		    goto isSimpleGlob;
+		}
+
+		/*
+		 * The pattern is "**"! I believe that should be impossible,
+		 * but we definitely can't handle that at all.
+		 */
+	    }
+	case '\0': case '?': case '[': case '\\':
+	    goto done;
+	}
+	bytes++;
+    }
+  isSimpleGlob:
+    for (bytes = Tcl_GetString(replacementObj); *bytes; bytes++) {
+	switch (*bytes) {
+	case '\\': case '&':
+	    goto done;
+	}
+    }
+
+    /*
+     * Proved the simplicity constraints! Time to issue the code.
+     */
+
+    result = TCL_OK;
+    bytes = Tcl_DStringValue(&pattern) + 1;
+    PushLiteral(envPtr,	bytes, len);
+    bytes = Tcl_GetStringFromObj(replacementObj, &len);
+    PushLiteral(envPtr,	bytes, len);
+    CompileWord(envPtr,	stringTokenPtr, interp, parsePtr->numWords-2);
+    TclEmitOpcode(	INST_STR_MAP,	envPtr);
+
+  done:
+    Tcl_DStringFree(&pattern);
+    if (patternObj) {
+	Tcl_DecrRefCount(patternObj);
+    }
+    if (replacementObj) {
+	Tcl_DecrRefCount(replacementObj);
+    }
+    return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * TclCompileReturnCmd --
  *
  *	Procedure called to compile the "return" command.
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 3aaed4c..27da005 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3616,6 +3616,9 @@ MODULE_SCOPE int	TclCompileObjectSelfCmd(Tcl_Interp *interp,
 MODULE_SCOPE int	TclCompileRegexpCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
+MODULE_SCOPE int	TclCompileRegsubCmd(Tcl_Interp *interp,
+			    Tcl_Parse *parsePtr, Command *cmdPtr,
+			    struct CompileEnv *envPtr);
 MODULE_SCOPE int	TclCompileReturnCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
-- 
cgit v0.12


From ee5f41d14197e71e1598091f7497821a45c91357 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Tue, 30 Oct 2012 18:20:28 +0000
Subject: Compilation of [string first] and [string range] (with constant
 indices).

---
 generic/tclAssembly.c   |  10 +-
 generic/tclCmdMZ.c      |   4 +-
 generic/tclCompCmdsSZ.c | 279 ++++++++++++++++++++++++++++++++++++------------
 generic/tclCompile.c    |   8 +-
 generic/tclCompile.h    |  18 ++--
 generic/tclExecute.c    |  67 +++++++++++-
 generic/tclInt.h        |   6 ++
 7 files changed, 306 insertions(+), 86 deletions(-)

diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 10df71a..9d2854d 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -472,6 +472,7 @@ static const TalInstDesc TalInstructionTable[] = {
     {"storeStk",	ASSEM_1BYTE,	INST_STORE_SCALAR_STK,	2,	1},
     {"strcmp",		ASSEM_1BYTE,	INST_STR_CMP,		2,	1},
     {"streq",		ASSEM_1BYTE,	INST_STR_EQ,		2,	1},
+    {"strfind",		ASSEM_1BYTE,	INST_STR_FIND,		2,	1},
     {"strindex",	ASSEM_1BYTE,	INST_STR_INDEX,		2,	1},
     {"strlen",		ASSEM_1BYTE,	INST_STR_LEN,		1,	1},
     {"strmap",		ASSEM_1BYTE,	INST_STR_MAP,		3,	1},
@@ -509,10 +510,11 @@ static const unsigned char NonThrowingByteCodes[] = {
     INST_REVERSE,						/* 126 */
     INST_NOP,							/* 132 */
     INST_STR_MAP,						/* 141 */
-    INST_COROUTINE_NAME,					/* 143 */
-    INST_NS_CURRENT,						/* 144 */
-    INST_INFO_LEVEL_NUM,					/* 145 */
-    INST_RESOLVE_COMMAND					/* 147 */
+    INST_STR_FIND,						/* 142 */
+    INST_COROUTINE_NAME,					/* 145 */
+    INST_NS_CURRENT,						/* 146 */
+    INST_INFO_LEVEL_NUM,					/* 147 */
+    INST_RESOLVE_COMMAND					/* 149 */
 };
 
 /*
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 1f210dd..de32fce 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -3304,14 +3304,14 @@ TclInitStringCmd(
 	{"bytelength",	StringBytesCmd,	NULL, NULL, NULL, 0},
 	{"compare",	StringCmpCmd,	TclCompileStringCmpCmd, NULL, NULL, 0},
 	{"equal",	StringEqualCmd,	TclCompileStringEqualCmd, NULL, NULL, 0},
-	{"first",	StringFirstCmd,	NULL, NULL, NULL, 0},
+	{"first",	StringFirstCmd,	TclCompileStringFirstCmd, NULL, NULL, 0},
 	{"index",	StringIndexCmd,	TclCompileStringIndexCmd, NULL, NULL, 0},
 	{"is",		StringIsCmd,	NULL, NULL, NULL, 0},
 	{"last",	StringLastCmd,	NULL, NULL, NULL, 0},
 	{"length",	StringLenCmd,	TclCompileStringLenCmd, NULL, NULL, 0},
 	{"map",		StringMapCmd,	TclCompileStringMapCmd, NULL, NULL, 0},
 	{"match",	StringMatchCmd,	TclCompileStringMatchCmd, NULL, NULL, 0},
-	{"range",	StringRangeCmd,	NULL, NULL, NULL, 0},
+	{"range",	StringRangeCmd,	TclCompileStringRangeCmd, NULL, NULL, 0},
 	{"repeat",	StringReptCmd,	NULL, NULL, NULL, 0},
 	{"replace",	StringRplcCmd,	NULL, NULL, NULL, 0},
 	{"reverse",	StringRevCmd,	NULL, NULL, NULL, 0},
diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index b8dada5..12396fe 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -133,6 +133,8 @@ const AuxDataType tclJumptableInfoType = {
 #define OP(name)	TclEmitOpcode(INST_##name, envPtr)
 #define OP1(name,val)	TclEmitInstInt1(INST_##name,(val),envPtr)
 #define OP4(name,val)	TclEmitInstInt4(INST_##name,(val),envPtr)
+#define OP14(name,val1,val2) \
+    TclEmitInstInt1(INST_##name,(val1),envPtr);TclEmitInt4((val2),envPtr)
 #define OP44(name,val1,val2) \
     TclEmitInstInt4(INST_##name,(val1),envPtr);TclEmitInt4((val2),envPtr)
 #define BODY(token,index) \
@@ -351,6 +353,57 @@ TclCompileStringEqualCmd(
 /*
  *----------------------------------------------------------------------
  *
+ * TclCompileStringFirstCmd --
+ *
+ *	Procedure called to compile the simplest and most common form of the
+ *	"string first" command.
+ *
+ * Results:
+ *	Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ *	evaluation to runtime.
+ *
+ * Side effects:
+ *	Instructions are added to envPtr to execute the "string first"
+ *	command at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileStringFirstCmd(
+    Tcl_Interp *interp,		/* Used for error reporting. */
+    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;
+
+    /*
+     * We don't support any flags; the bytecode isn't that sophisticated.
+     */
+
+    if (parsePtr->numWords != 3) {
+	return TCL_ERROR;
+    }
+
+    /*
+     * Push the two operands onto the stack and then the test.
+     */
+
+    tokenPtr = TokenAfter(parsePtr->tokenPtr);
+    CompileWord(envPtr, tokenPtr, interp, 1);
+    tokenPtr = TokenAfter(tokenPtr);
+    CompileWord(envPtr, tokenPtr, interp, 2);
+    OP(STR_FIND);
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * TclCompileStringIndexCmd --
  *
  *	Procedure called to compile the simplest and most common form of the
@@ -630,7 +683,7 @@ TclCompileStringMapCmd(
 	bytes = Tcl_GetStringFromObj(objv[1], &len);
 	PushLiteral(envPtr, bytes, len);
 	CompileWord(envPtr, stringTokenPtr, interp, 2);
-	TclEmitOpcode(INST_STR_MAP, envPtr);
+	OP(STR_MAP);
     }
     Tcl_DecrRefCount(mapObj);
     return TCL_OK;
@@ -639,6 +692,113 @@ TclCompileStringMapCmd(
 /*
  *----------------------------------------------------------------------
  *
+ * TclCompileStringRangeCmd --
+ *
+ *	Procedure called to compile the "string range" command (with constant
+ *	indices).
+ *
+ * Results:
+ *	Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ *	evaluation to runtime.
+ *
+ * Side effects:
+ *	Instructions are added to envPtr to execute the "string compare"
+ *	command at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileStringRangeCmd(
+    Tcl_Interp *interp,		/* Used for error reporting. */
+    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 *stringTokenPtr, *tokenPtr;
+    Tcl_Obj *tmpObj;
+    int idx1, idx2, result;
+
+    /*
+     * We don't support any flags; the bytecode isn't that sophisticated.
+     */
+
+    if (parsePtr->numWords != 4) {
+	return TCL_ERROR;
+    }
+    stringTokenPtr = TokenAfter(parsePtr->tokenPtr);
+
+    /*
+     * Parse the first index. Will only compile if it is constant and not an
+     * _integer_ less than zero (since we reserve negative indices here for
+     * end-relative indexing).
+     */
+
+    tokenPtr = TokenAfter(stringTokenPtr);
+    tmpObj = Tcl_NewObj();
+    if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj)) {
+	Tcl_DecrRefCount(tmpObj);
+	return TCL_ERROR;
+    }
+    result = TclGetIntFromObj(NULL, tmpObj, &idx1);
+    if (result == TCL_OK) {
+	if (idx1 < 0) {
+	    result = TCL_ERROR;
+	}
+    } else {
+	result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx1);
+	if (result == TCL_OK && idx1 > -2) {
+	    result = TCL_ERROR;
+	}
+    }
+    TclDecrRefCount(tmpObj);
+    if (result != TCL_OK) {
+	return TCL_ERROR;
+    }
+
+    /*
+     * Parse the second index. Will only compile if it is constant and not an
+     * _integer_ less than zero (since we reserve negative indices here for
+     * end-relative indexing).
+     */
+
+    tokenPtr = TokenAfter(tokenPtr);
+    tmpObj = Tcl_NewObj();
+    if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj)) {
+	Tcl_DecrRefCount(tmpObj);
+	return TCL_ERROR;
+    }
+    result = TclGetIntFromObj(NULL, tmpObj, &idx2);
+    if (result == TCL_OK) {
+	if (idx2 < 0) {
+	    result = TCL_ERROR;
+	}
+    } else {
+	result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx2);
+	if (result == TCL_OK && idx2 > -2) {
+	    result = TCL_ERROR;
+	}
+    }
+    TclDecrRefCount(tmpObj);
+    if (result != TCL_OK) {
+	return TCL_ERROR;
+    }
+
+    /*
+     * Push the two operands onto the stack and then the test.
+     */
+
+    CompileWord(envPtr, stringTokenPtr, interp, 1);
+    OP44(	STR_RANGE_IMM, idx1, idx2);
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * TclCompileSubstCmd --
  *
  *	Procedure called to compile the "subst" command.
@@ -779,11 +939,11 @@ TclSubstCompile(
 	}
 
 	while (count > 255) {
-	    TclEmitInstInt1(INST_CONCAT1, 255, envPtr);
+	    OP1(		CONCAT1, 255);
 	    count -= 254;
 	}
 	if (count > 1) {
-	    TclEmitInstInt1(INST_CONCAT1, count, envPtr);
+	    OP1(		CONCAT1, count);
 	    count = 1;
 	}
 
@@ -804,7 +964,7 @@ TclSubstCompile(
 
 	envPtr->line = bline;
 	catchRange = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
-	TclEmitInstInt4(INST_BEGIN_CATCH4, catchRange, envPtr);
+	OP4(	BEGIN_CATCH4, catchRange);
 	ExceptionRangeStarts(envPtr, catchRange);
 
 	switch (tokenPtr->type) {
@@ -825,20 +985,20 @@ TclSubstCompile(
 	ExceptionRangeEnds(envPtr, catchRange);
 
 	/* Substitution produced TCL_OK */
-	TclEmitOpcode(INST_END_CATCH, envPtr);
+	OP(	END_CATCH);
 	TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &okFixup);
 
 	/* Exceptional return codes processed here */
 	ExceptionRangeTarget(envPtr, catchRange, catchOffset);
-	TclEmitOpcode(INST_PUSH_RETURN_OPTIONS, envPtr);
-	TclEmitOpcode(INST_PUSH_RESULT, envPtr);
-	TclEmitOpcode(INST_PUSH_RETURN_CODE, envPtr);
-	TclEmitOpcode(INST_END_CATCH, envPtr);
-	TclEmitOpcode(INST_RETURN_CODE_BRANCH, envPtr);
+	OP(	PUSH_RETURN_OPTIONS);
+	OP(	PUSH_RESULT);
+	OP(	PUSH_RETURN_CODE);
+	OP(	END_CATCH);
+	OP(	RETURN_CODE_BRANCH);
 
 	/* ERROR -> reraise it */
-	TclEmitOpcode(INST_RETURN_STK, envPtr);
-	TclEmitOpcode(INST_NOP, envPtr);
+	OP(	RETURN_STK);
+	OP(	NOP);
 
 	/* RETURN */
 	TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &returnFixup);
@@ -857,14 +1017,14 @@ TclSubstCompile(
 	    Tcl_Panic("TclCompileSubstCmd: bad break jump distance %d",
 		    (int) (CurrentOffset(envPtr) - breakFixup.codeOffset));
 	}
-	TclEmitOpcode(INST_POP, envPtr);
-	TclEmitOpcode(INST_POP, envPtr);
+	OP(	POP);
+	OP(	POP);
 
 	breakJump = CurrentOffset(envPtr) - breakOffset;
 	if (breakJump > 127) {
-	    TclEmitInstInt4(INST_JUMP4, -breakJump, envPtr);
+	    OP4(JUMP4, -breakJump);
 	} else {
-	    TclEmitInstInt1(INST_JUMP1, -breakJump, envPtr);
+	    OP1(JUMP1, -breakJump);
 	}
 
 	/* CONTINUE destination */
@@ -872,8 +1032,8 @@ TclSubstCompile(
 	    Tcl_Panic("TclCompileSubstCmd: bad continue jump distance %d",
 		    (int) (CurrentOffset(envPtr) - continueFixup.codeOffset));
 	}
-	TclEmitOpcode(INST_POP, envPtr);
-	TclEmitOpcode(INST_POP, envPtr);
+	OP(	POP);
+	OP(	POP);
 	TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &endFixup);
 
 	/* RETURN + other destination */
@@ -890,8 +1050,8 @@ TclSubstCompile(
 	 * Pull the result to top of stack, discard options dict.
 	 */
 
-	TclEmitInstInt4(INST_REVERSE, 2, envPtr);
-	TclEmitOpcode(INST_POP, envPtr);
+	OP4(	REVERSE, 2);
+	OP(	POP);
 
 	/*
 	 * We've emitted several POP instructions, and the automatic
@@ -910,7 +1070,7 @@ TclSubstCompile(
 		    (int) (CurrentOffset(envPtr) - okFixup.codeOffset));
 	}
 	if (count > 1) {
-	    TclEmitInstInt1(INST_CONCAT1, count, envPtr);
+	    OP1(CONCAT1, count);
 	    count = 1;
 	}
 
@@ -922,13 +1082,12 @@ TclSubstCompile(
 	bline = envPtr->line;
     }
 
-
     while (count > 255) {
-	TclEmitInstInt1(INST_CONCAT1, 255, envPtr);
+	OP1(	CONCAT1, 255);
 	count -= 254;
     }
     if (count > 1) {
-	TclEmitInstInt1(INST_CONCAT1, count, envPtr);
+	OP1(	CONCAT1, count);
     }
 
     Tcl_FreeParse(&parse);
@@ -1359,14 +1518,14 @@ IssueSwitchChainedTests(
 
 	    switch (mode) {
 	    case Switch_Exact:
-		TclEmitOpcode(INST_DUP,				envPtr);
+		OP(	DUP);
 		TclCompileTokens(interp, bodyToken[i], 1,	envPtr);
-		TclEmitOpcode(INST_STR_EQ,			envPtr);
+		OP(	STR_EQ);
 		break;
 	    case Switch_Glob:
 		TclCompileTokens(interp, bodyToken[i], 1,	envPtr);
-		TclEmitInstInt4(INST_OVER, 1,			envPtr);
-		TclEmitInstInt1(INST_STR_MATCH, noCase,		envPtr);
+		OP4(	OVER, 1);
+		OP1(	STR_MATCH, noCase);
 		break;
 	    case Switch_Regexp:
 		simple = exact = 0;
@@ -1405,7 +1564,7 @@ IssueSwitchChainedTests(
 		    TclCompileTokens(interp, bodyToken[i], 1, envPtr);
 		}
 
-		TclEmitInstInt4(INST_OVER, 1,			envPtr);
+		OP4(	OVER, 1);
 		if (!simple) {
 		    /*
 		     * Pass correct RE compile flags. We use only Int1
@@ -1417,11 +1576,11 @@ IssueSwitchChainedTests(
 		    int cflags = TCL_REG_ADVANCED
 			    | (noCase ? TCL_REG_NOCASE : 0);
 
-		    TclEmitInstInt1(INST_REGEXP, cflags,	envPtr);
+		    OP1(REGEXP, cflags);
 		} else if (exact && !noCase) {
-		    TclEmitOpcode(INST_STR_EQ,			envPtr);
+		    OP(	STR_EQ);
 		} else {
-		    TclEmitInstInt1(INST_STR_MATCH, noCase,	envPtr);
+		    OP1(STR_MATCH, noCase);
 		}
 		break;
 	    default:
@@ -1486,7 +1645,7 @@ IssueSwitchChainedTests(
 	 * pattern.
 	 */
 
-	TclEmitOpcode(INST_POP,					envPtr);
+	OP(	POP);
 	envPtr->currStackDepth = savedStackDepth + 1;
 	envPtr->line = bodyLines[i+1];		/* TIP #280 */
 	envPtr->clNext = bodyContLines[i+1];	/* TIP #280 */
@@ -1508,7 +1667,7 @@ IssueSwitchChainedTests(
      */
 
     if (!foundDefault) {
-	TclEmitOpcode(INST_POP,					envPtr);
+	OP(	POP);
 	PushLiteral(envPtr, "", 0);
     }
 
@@ -1619,9 +1778,9 @@ IssueSwitchJumpTable(
      */
 
     jumpLocation = CurrentOffset(envPtr);
-    TclEmitInstInt4(INST_JUMP_TABLE, infoIndex,			envPtr);
+    OP4(	JUMP_TABLE, infoIndex);
     jumpToDefault = CurrentOffset(envPtr);
-    TclEmitInstInt4(INST_JUMP4, 0,				envPtr);
+    OP4(	JUMP4, 0);
 
     for (i=0 ; i<numBodyTokens ; i+=2) {
 	/*
@@ -1712,7 +1871,7 @@ IssueSwitchJumpTable(
 	     * rewriting when we fixed this all up.
 	     */
 
-	    TclEmitInstInt4(INST_JUMP4, 0,			envPtr);
+	    OP4(	JUMP4, 0);
 	}
     }
 
@@ -2629,20 +2788,18 @@ TclCompileUnsetCmd(
 	 */
 
 	if (!simpleVarName) {
-	    TclEmitInstInt1(	INST_UNSET_STK, flags,		envPtr);
+	    OP1(	UNSET_STK, flags);
 	} else if (isScalar) {
 	    if (localIndex < 0) {
-		TclEmitInstInt1(INST_UNSET_STK, flags,		envPtr);
+		OP1(	UNSET_STK, flags);
 	    } else {
-		TclEmitInstInt1(INST_UNSET_SCALAR, flags,	envPtr);
-		TclEmitInt4(			   localIndex,	envPtr);
+		OP14(	UNSET_SCALAR, flags, localIndex);
 	    }
 	} else {
 	    if (localIndex < 0) {
-		TclEmitInstInt1(INST_UNSET_ARRAY_STK, flags,	envPtr);
+		OP1(	UNSET_ARRAY_STK, flags);
 	    } else {
-		TclEmitInstInt1(INST_UNSET_ARRAY, flags,	envPtr);
-		TclEmitInt4(			  localIndex,	envPtr);
+		OP14(	UNSET_ARRAY, flags, localIndex);
 	    }
 	}
 
@@ -2779,7 +2936,7 @@ TclCompileWhileCmd(
     CompileBody(envPtr, bodyTokenPtr, interp);
     ExceptionRangeEnds(envPtr, range);
     envPtr->currStackDepth = savedStackDepth + 1;
-    TclEmitOpcode(INST_POP, envPtr);
+    OP(		POP);
 
     /*
      * Compile the test expression then emit the conditional jump that
@@ -2870,7 +3027,7 @@ TclCompileYieldCmd(
 
 	CompileWord(envPtr, valueTokenPtr, interp, 1);
     }
-    TclEmitOpcode(INST_YIELD, envPtr);
+    OP(		YIELD);
     return TCL_OK;
 }
 
@@ -3199,7 +3356,7 @@ CompileAssociativeBinaryOpCmd(
 	 * calcuations, including roundoff errors.
 	 */
 
-	TclEmitInstInt4(INST_REVERSE, words-1, envPtr);
+	OP4(	REVERSE, words-1);
     }
     while (--words > 1) {
 	TclEmitOpcode(instruction, envPtr);
@@ -3290,31 +3447,19 @@ CompileComparisonOpCmd(
 	CompileWord(envPtr, tokenPtr, interp, 1);
 	tokenPtr = TokenAfter(tokenPtr);
 	CompileWord(envPtr, tokenPtr, interp, 2);
-	if (tmpIndex <= 255) {
-	    TclEmitInstInt1(INST_STORE_SCALAR1, tmpIndex, envPtr);
-	} else {
-	    TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr);
-	}
+	STORE(tmpIndex);
 	TclEmitOpcode(instruction, envPtr);
 	for (words=3 ; words<parsePtr->numWords ;) {
-	    if (tmpIndex <= 255) {
-		TclEmitInstInt1(INST_LOAD_SCALAR1, tmpIndex, envPtr);
-	    } else {
-		TclEmitInstInt4(INST_LOAD_SCALAR4, tmpIndex, envPtr);
-	    }
+	    LOAD(tmpIndex);
 	    tokenPtr = TokenAfter(tokenPtr);
 	    CompileWord(envPtr, tokenPtr, interp, words);
 	    if (++words < parsePtr->numWords) {
-		if (tmpIndex <= 255) {
-		    TclEmitInstInt1(INST_STORE_SCALAR1, tmpIndex, envPtr);
-		} else {
-		    TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr);
-		}
+		STORE(tmpIndex);
 	    }
 	    TclEmitOpcode(instruction, envPtr);
 	}
 	for (; words>3 ; words--) {
-	    TclEmitOpcode(INST_BITAND, envPtr);
+	    OP(	BITAND);
 	}
 
 	/*
@@ -3322,13 +3467,7 @@ CompileComparisonOpCmd(
 	 * might be expensive elsewhere.
 	 */
 
-	PushLiteral(envPtr, "", 0);
-	if (tmpIndex <= 255) {
-	    TclEmitInstInt1(INST_STORE_SCALAR1, tmpIndex, envPtr);
-	} else {
-	    TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr);
-	}
-	TclEmitOpcode(INST_POP, envPtr);
+	OP14(	UNSET_SCALAR, 0, tmpIndex);
     }
     return TCL_OK;
 }
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 8b98746..6e2cfae 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -438,7 +438,13 @@ InstructionDesc const tclInstructionTable[] = {
     {"strmap",		 1,    -2,	  0,	{OPERAND_NONE}},
 	/* Simplified version of [string map] that only applies one change
 	 * string, and only case-sensitively.
-	 * Stack:  ... from to string => changedString */
+	 * Stack:  ... from to string => ... changedString */
+    {"strfind",		 1,    -1,	  0,	{OPERAND_NONE}},
+	/* Find the first index of a needle string in a haystack string,
+	 * producing the index (integer) or -1 if nothing found.
+	 * Stack:  ... needle haystack => ... index */
+    {"strrangeImm",	 9,	0,	  2,	{OPERAND_IDX4, OPERAND_IDX4}},
+	/* String Range: push (string range stktop op4 op4) */
 
     {"yield",		 1,	0,	  0,	{OPERAND_NONE}},
 	/* Makes the current coroutine yield the value at the top of the
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index ff2f0e3..2ea4209 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -683,20 +683,22 @@ typedef struct ByteCode {
 
 /* For [string map] and [regsub] compilation */
 #define INST_STR_MAP			141
+#define INST_STR_FIND			142
+#define INST_STR_RANGE_IMM		143
 
 /* For operations to do with coroutines */
-#define INST_YIELD			142
-#define INST_COROUTINE_NAME		143
+#define INST_YIELD			144
+#define INST_COROUTINE_NAME		145
 
 /* For compilation of basic information operations */
-#define INST_NS_CURRENT			144
-#define INST_INFO_LEVEL_NUM		145
-#define INST_INFO_LEVEL_ARGS		146
-#define INST_RESOLVE_COMMAND		147
-#define INST_TCLOO_SELF			148
+#define INST_NS_CURRENT			146
+#define INST_INFO_LEVEL_NUM		147
+#define INST_INFO_LEVEL_ARGS		148
+#define INST_RESOLVE_COMMAND		149
+#define INST_TCLOO_SELF			150
 
 /* The last opcode */
-#define LAST_INST_OPCODE		148
+#define LAST_INST_OPCODE		150
 
 /*
  * Table describing the Tcl bytecode instructions: their name (for displaying
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 10cbf46..f54155d 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -4732,11 +4732,12 @@ TEBCresume(
 		O2S(objResultPtr)));
 	NEXT_INST_F(1, 2, 1);
 
-    case INST_STR_MAP: {
+    {
 	Tcl_UniChar *ustring1, *ustring2, *ustring3, *end, *p;
 	int length3;
 	Tcl_Obj *value3Ptr;
 
+    case INST_STR_MAP:
 	valuePtr = OBJ_AT_TOS;		/* "Main" string. */
 	value3Ptr = OBJ_UNDER_TOS;	/* "Target" string. */
 	value2Ptr = OBJ_AT_DEPTH(2);	/* "Source" string. */
@@ -4781,7 +4782,71 @@ TEBCresume(
 
 	    Tcl_AppendUnicodeToObj(objResultPtr, p, ustring1 - p);
 	}
+	TRACE_WITH_OBJ(("%.20s %.20s %.20s => ",
+		O2S(value2Ptr), O2S(value3Ptr), O2S(valuePtr)), objResultPtr);
 	NEXT_INST_V(1, 3, 1);
+
+    case INST_STR_FIND:
+	ustring1 = Tcl_GetUnicodeFromObj(OBJ_AT_TOS, &length);	/* Haystack */
+	ustring2 = Tcl_GetUnicodeFromObj(OBJ_UNDER_TOS, &length2);/* Needle */
+
+	match = -1;
+	if (length2 > 0 && length2 <= length) {
+	    end = ustring1 + length - length2 + 1;
+	    for (p=ustring1 ; p<end ; p++) {
+		if ((*p == *ustring2) && TclUniCharNcmp(ustring2, p,
+			(unsigned long) length2) == 0) {
+		    match = p - ustring1;
+		    break;
+		}
+	    }
+	}
+
+	TRACE(("%.20s %.20s => %d\n",
+		O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match));
+
+	TclNewIntObj(objResultPtr, match);
+	NEXT_INST_F(1, 2, 1);
+
+    case INST_STR_RANGE_IMM:
+	valuePtr = OBJ_AT_TOS;
+	fromIdx = TclGetInt4AtPtr(pc+1);
+	toIdx = TclGetInt4AtPtr(pc+5);
+	length = Tcl_GetCharLength(valuePtr);
+	TRACE(("\"%.20s\" %d %d", O2S(valuePtr), fromIdx, toIdx));
+
+	/*
+	 * Adjust indices for end-based indexing.
+	 */
+
+	if (fromIdx < -1) {
+	    fromIdx += 1 + length;
+	    if (fromIdx < 0) {
+		fromIdx = 0;
+	    }
+	} else if (fromIdx >= length) {
+	    fromIdx = length;
+	}
+	if (toIdx < -1) {
+	    toIdx += 1 + length;
+	    if (toIdx < 0) {
+		toIdx = 0;
+	    }
+	} else if (toIdx >= length) {
+	    toIdx = length - 1;
+	}
+
+	/*
+	 * Check if we can do a sane substring.
+	 */
+
+	if (fromIdx <= toIdx) {
+	    objResultPtr = Tcl_GetRange(valuePtr, fromIdx, toIdx);
+	} else {
+	    TclNewObj(objResultPtr);
+	}
+	TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+	NEXT_INST_F(9, 1, 1);
     }
 
     case INST_STR_MATCH:
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 27da005..9e9784b 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3631,6 +3631,9 @@ MODULE_SCOPE int	TclCompileStringCmpCmd(Tcl_Interp *interp,
 MODULE_SCOPE int	TclCompileStringEqualCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
+MODULE_SCOPE int	TclCompileStringFirstCmd(Tcl_Interp *interp,
+			    Tcl_Parse *parsePtr, Command *cmdPtr,
+			    struct CompileEnv *envPtr);
 MODULE_SCOPE int	TclCompileStringIndexCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
@@ -3643,6 +3646,9 @@ MODULE_SCOPE int	TclCompileStringMapCmd(Tcl_Interp *interp,
 MODULE_SCOPE int	TclCompileStringMatchCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
+MODULE_SCOPE int	TclCompileStringRangeCmd(Tcl_Interp *interp,
+			    Tcl_Parse *parsePtr, Command *cmdPtr,
+			    struct CompileEnv *envPtr);
 MODULE_SCOPE int	TclCompileSubstCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
-- 
cgit v0.12


From 040b7a730ee8fad1603b496dc3543a1ed96e4300 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Tue, 30 Oct 2012 20:59:34 +0000
Subject: Some corrections and performance tweaks

---
 generic/tclExecute.c | 102 ++++++++++++++++++++++++++++-----------------------
 1 file changed, 56 insertions(+), 46 deletions(-)

diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index f54155d..663d650 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -4732,6 +4732,46 @@ TEBCresume(
 		O2S(objResultPtr)));
 	NEXT_INST_F(1, 2, 1);
 
+    case INST_STR_RANGE_IMM:
+	valuePtr = OBJ_AT_TOS;
+	fromIdx = TclGetInt4AtPtr(pc+1);
+	toIdx = TclGetInt4AtPtr(pc+5);
+	length = Tcl_GetCharLength(valuePtr);
+	TRACE(("\"%.20s\" %d %d", O2S(valuePtr), fromIdx, toIdx));
+
+	/*
+	 * Adjust indices for end-based indexing.
+	 */
+
+	if (fromIdx < -1) {
+	    fromIdx += 1 + length;
+	    if (fromIdx < 0) {
+		fromIdx = 0;
+	    }
+	} else if (fromIdx >= length) {
+	    fromIdx = length;
+	}
+	if (toIdx < -1) {
+	    toIdx += 1 + length;
+	    if (toIdx < 0) {
+		toIdx = 0;
+	    }
+	} else if (toIdx >= length) {
+	    toIdx = length - 1;
+	}
+
+	/*
+	 * Check if we can do a sane substring.
+	 */
+
+	if (fromIdx <= toIdx) {
+	    objResultPtr = Tcl_GetRange(valuePtr, fromIdx, toIdx);
+	} else {
+	    TclNewObj(objResultPtr);
+	}
+	TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+	NEXT_INST_F(9, 1, 1);
+
     {
 	Tcl_UniChar *ustring1, *ustring2, *ustring3, *end, *p;
 	int length3;
@@ -4741,9 +4781,12 @@ TEBCresume(
 	valuePtr = OBJ_AT_TOS;		/* "Main" string. */
 	value3Ptr = OBJ_UNDER_TOS;	/* "Target" string. */
 	value2Ptr = OBJ_AT_DEPTH(2);	/* "Source" string. */
-	if (value3Ptr == value2Ptr || valuePtr == value2Ptr) {
+	if (value3Ptr == value2Ptr) {
 	    objResultPtr = valuePtr;
 	    NEXT_INST_V(1, 3, 1);
+	} else if (valuePtr == value2Ptr) {
+	    objResultPtr = value3Ptr;
+	    NEXT_INST_V(1, 3, 1);
 	}
 	ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length);
 	if (length == 0) {
@@ -4754,6 +4797,13 @@ TEBCresume(
 	if (length2 > length || length2 == 0) {
 	    objResultPtr = valuePtr;
 	    NEXT_INST_V(1, 3, 1);
+	} else if (length2 == length) {
+	    if (memcmp(ustring1, ustring2, sizeof(Tcl_UniChar) * length)) {
+		objResultPtr = valuePtr;
+	    } else {
+		objResultPtr = value3Ptr;
+	    }
+	    NEXT_INST_V(1, 3, 1);
 	}
 	ustring3 = Tcl_GetUnicodeFromObj(value3Ptr, &length3);
 
@@ -4761,9 +4811,9 @@ TEBCresume(
 	p = ustring1;
 	end = ustring1 + length;
 	for (; ustring1 < end; ustring1++) {
-	    if ((*ustring1 == *ustring2) &&
-		    (length2==1 || Tcl_UniCharNcmp(ustring1, ustring2,
-				(unsigned long) length2) == 0)) {
+	    if ((*ustring1 == *ustring2) && (length2==1 ||
+		    memcmp(ustring1, ustring2, sizeof(Tcl_UniChar) * length2)
+			    == 0)) {
 		if (p != ustring1) {
 		    Tcl_AppendUnicodeToObj(objResultPtr, p, ustring1-p);
 		    p = ustring1 + length2;
@@ -4794,8 +4844,8 @@ TEBCresume(
 	if (length2 > 0 && length2 <= length) {
 	    end = ustring1 + length - length2 + 1;
 	    for (p=ustring1 ; p<end ; p++) {
-		if ((*p == *ustring2) && TclUniCharNcmp(ustring2, p,
-			(unsigned long) length2) == 0) {
+		if ((*p == *ustring2) &&
+			memcmp(ustring2,p,sizeof(Tcl_UniChar)*length2) == 0) {
 		    match = p - ustring1;
 		    break;
 		}
@@ -4807,46 +4857,6 @@ TEBCresume(
 
 	TclNewIntObj(objResultPtr, match);
 	NEXT_INST_F(1, 2, 1);
-
-    case INST_STR_RANGE_IMM:
-	valuePtr = OBJ_AT_TOS;
-	fromIdx = TclGetInt4AtPtr(pc+1);
-	toIdx = TclGetInt4AtPtr(pc+5);
-	length = Tcl_GetCharLength(valuePtr);
-	TRACE(("\"%.20s\" %d %d", O2S(valuePtr), fromIdx, toIdx));
-
-	/*
-	 * Adjust indices for end-based indexing.
-	 */
-
-	if (fromIdx < -1) {
-	    fromIdx += 1 + length;
-	    if (fromIdx < 0) {
-		fromIdx = 0;
-	    }
-	} else if (fromIdx >= length) {
-	    fromIdx = length;
-	}
-	if (toIdx < -1) {
-	    toIdx += 1 + length;
-	    if (toIdx < 0) {
-		toIdx = 0;
-	    }
-	} else if (toIdx >= length) {
-	    toIdx = length - 1;
-	}
-
-	/*
-	 * Check if we can do a sane substring.
-	 */
-
-	if (fromIdx <= toIdx) {
-	    objResultPtr = Tcl_GetRange(valuePtr, fromIdx, toIdx);
-	} else {
-	    TclNewObj(objResultPtr);
-	}
-	TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
-	NEXT_INST_F(9, 1, 1);
     }
 
     case INST_STR_MATCH:
-- 
cgit v0.12


From ecec3a1a0bc39752d2c1e538baa90115355e7d16 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Tue, 30 Oct 2012 22:16:35 +0000
Subject: Added [dict exists] compilation; implementation is 95% shared with
 [dict get].

---
 generic/tclAssembly.c |  1 +
 generic/tclCompCmds.c | 36 ++++++++++++++++++++++++++++++++++++
 generic/tclCompile.c  |  6 ++++++
 generic/tclCompile.h  | 25 +++++++++++++------------
 generic/tclDictObj.c  | 19 ++++++++++++++++++-
 generic/tclExecute.c  | 25 +++++++++++++++++++++++--
 generic/tclInt.h      |  7 +++++--
 7 files changed, 102 insertions(+), 17 deletions(-)

diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 9d2854d..5aa1e14 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -372,6 +372,7 @@ static const TalInstDesc TalInstructionTable[] = {
     {"coroName",	ASSEM_1BYTE,	INST_COROUTINE_NAME,	0,	1},
     {"currentNamespace",ASSEM_1BYTE,	INST_NS_CURRENT,	0,	1},
     {"dictAppend",	ASSEM_LVT4,	INST_DICT_APPEND,	2,	1},
+    {"dictExists",	ASSEM_DICT_GET, INST_DICT_EXISTS,	INT_MIN,1},
     {"dictExpand",	ASSEM_1BYTE,	INST_DICT_EXPAND,	3,	1},
     {"dictGet",		ASSEM_DICT_GET, INST_DICT_GET,		INT_MIN,1},
     {"dictIncrImm",	ASSEM_SINT4_LVT4,
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 029606e..068848f 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -787,6 +787,42 @@ TclCompileDictGetCmd(
 }
 
 int
+TclCompileDictExistsCmd(
+    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. */
+{
+    Tcl_Token *tokenPtr;
+    int numWords, i;
+    DefineLineInformation;	/* TIP #280 */
+
+    /*
+     * There must be at least two arguments after the command (the single-arg
+     * case is legal, but too special and magic for us to deal with here).
+     */
+
+    if (parsePtr->numWords < 3) {
+	return TCL_ERROR;
+    }
+    tokenPtr = TokenAfter(parsePtr->tokenPtr);
+    numWords = parsePtr->numWords-1;
+
+    /*
+     * Now we do the code generation.
+     */
+
+    for (i=0 ; i<numWords ; i++) {
+	CompileWord(envPtr, tokenPtr, interp, i);
+	tokenPtr = TokenAfter(tokenPtr);
+    }
+    TclEmitInstInt4(INST_DICT_EXISTS, numWords-1, envPtr);
+    return TCL_OK;
+}
+
+int
 TclCompileDictUnsetCmd(
     Tcl_Interp *interp,		/* Used for looking up stuff. */
     Tcl_Parse *parsePtr,	/* Points to a parse structure for the command
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 6e2cfae..128273b 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -434,6 +434,12 @@ InstructionDesc const tclInstructionTable[] = {
         /* Map variable contents back into a dictionary in the local variable
          * indicated by the LVT index. Part of [dict with].
 	 * Stack:  ... path keyList => ... */
+    {"dictExists",	 5,	INT_MIN,  1,	{OPERAND_UINT4}},
+	/* The top op4 words (min 1) are a key path into the dictionary just
+	 * below the keys on the stack, and all those values are replaced by a
+	 * boolean indicating whether it is possible to read out a value from
+	 * that key-path (like [dict exists]).
+	 * Stack:  ... dict key1 ... keyN => ... boolean */
 
     {"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 2ea4209..24f9464 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -676,29 +676,30 @@ typedef struct ByteCode {
 #define INST_UNSET_ARRAY_STK		136
 #define INST_UNSET_STK			137
 
-/* For [dict with] compilation */
+/* For [dict with] and [dict exists] compilation */
 #define INST_DICT_EXPAND		138
 #define INST_DICT_RECOMBINE_STK		139
 #define INST_DICT_RECOMBINE_IMM		140
+#define INST_DICT_EXISTS		141
 
 /* For [string map] and [regsub] compilation */
-#define INST_STR_MAP			141
-#define INST_STR_FIND			142
-#define INST_STR_RANGE_IMM		143
+#define INST_STR_MAP			142
+#define INST_STR_FIND			143
+#define INST_STR_RANGE_IMM		144
 
 /* For operations to do with coroutines */
-#define INST_YIELD			144
-#define INST_COROUTINE_NAME		145
+#define INST_YIELD			145
+#define INST_COROUTINE_NAME		146
 
 /* For compilation of basic information operations */
-#define INST_NS_CURRENT			146
-#define INST_INFO_LEVEL_NUM		147
-#define INST_INFO_LEVEL_ARGS		148
-#define INST_RESOLVE_COMMAND		149
-#define INST_TCLOO_SELF			150
+#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
 
 /* The last opcode */
-#define LAST_INST_OPCODE		150
+#define LAST_INST_OPCODE		151
 
 /*
  * Table describing the Tcl bytecode instructions: their name (for displaying
diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c
index ea9411c..2d6d209 100644
--- a/generic/tclDictObj.c
+++ b/generic/tclDictObj.c
@@ -87,16 +87,33 @@ 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 },
-    {"exists",	DictExistsCmd, NULL, NULL, NULL, 0 },
+    {"exists",	DictExistsCmd,	TclCompileDictExistsCmd, NULL, NULL, 0 },
     {"filter",	DictFilterCmd, NULL, NULL, NULL, 0 },
     {"for",	NULL,		TclCompileDictForCmd, DictForNRCmd, NULL, 0 },
     {"get",	DictGetCmd,	TclCompileDictGetCmd, NULL, NULL, 0 },
     {"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 },
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 663d650..c6be2f3 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -5916,13 +5916,22 @@ TEBCresume(
 	DictUpdateInfo *duiPtr;
 
     case INST_DICT_GET:
+    case INST_DICT_EXISTS: {
+	register Tcl_Interp *interp2 = interp;
+
 	opnd = TclGetUInt4AtPtr(pc+1);
 	TRACE(("%u => ", opnd));
 	dictPtr = OBJ_AT_DEPTH(opnd);
+	if (*pc == INST_DICT_EXISTS) {
+	    interp2 = NULL;
+	}
 	if (opnd > 1) {
-	    dictPtr = TclTraceDictPath(interp, dictPtr, opnd-1,
+	    dictPtr = TclTraceDictPath(interp2, dictPtr, opnd-1,
 		    &OBJ_AT_DEPTH(opnd-1), DICT_PATH_READ);
 	    if (dictPtr == NULL) {
+		if (*pc == INST_DICT_EXISTS) {
+		    goto dictNotExists;
+		}
 		TRACE_WITH_OBJ((
 			"%u => ERROR tracing dictionary path into \"%s\": ",
 			opnd, O2S(OBJ_AT_DEPTH(opnd))),
@@ -5930,8 +5939,13 @@ TEBCresume(
 		goto gotError;
 	    }
 	}
-	if (Tcl_DictObjGet(interp, dictPtr, OBJ_AT_TOS,
+	if (Tcl_DictObjGet(interp2, dictPtr, OBJ_AT_TOS,
 		&objResultPtr) == TCL_OK) {
+	    if (*pc == INST_DICT_EXISTS) {
+		objResultPtr = TCONST(objResultPtr ? 1 : 0);
+		TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+		NEXT_INST_V(5, opnd+1, 1);
+	    }
 	    if (objResultPtr) {
 		TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
 		NEXT_INST_V(5, opnd+1, 1);
@@ -5945,11 +5959,18 @@ TEBCresume(
 	    CACHE_STACK_INFO();
 	    TRACE_WITH_OBJ(("%u => ERROR ", opnd), Tcl_GetObjResult(interp));
 	} else {
+	    if (*pc == INST_DICT_EXISTS) {
+	    dictNotExists:
+		objResultPtr = TCONST(0);
+		TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+		NEXT_INST_V(5, opnd+1, 1);
+	    }
 	    TRACE_WITH_OBJ((
 		    "%u => ERROR reading leaf dictionary key \"%s\": ",
 		    opnd, O2S(dictPtr)), Tcl_GetObjResult(interp));
 	}
 	goto gotError;
+    }
 
     case INST_DICT_SET:
     case INST_DICT_UNSET:
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 9e9784b..3e2f548 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3502,10 +3502,10 @@ 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	TclCompileDictForCmd(Tcl_Interp *interp,
+MODULE_SCOPE int	TclCompileDictExistsCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
-MODULE_SCOPE int	TclCompileDictMapCmd(Tcl_Interp *interp,
+MODULE_SCOPE int	TclCompileDictForCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
 MODULE_SCOPE int	TclCompileDictGetCmd(Tcl_Interp *interp,
@@ -3517,6 +3517,9 @@ MODULE_SCOPE int	TclCompileDictIncrCmd(Tcl_Interp *interp,
 MODULE_SCOPE int	TclCompileDictLappendCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
+MODULE_SCOPE int	TclCompileDictMapCmd(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);
-- 
cgit v0.12


From 5c683477476d5667195dc702d5d1632bb2a85844 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Thu, 1 Nov 2012 16:47:41 +0000
Subject: Added compilation of [dict create] and [dict merge].

---
 generic/tclAssembly.c |  13 ++--
 generic/tclCompCmds.c | 207 +++++++++++++++++++++++++++++++++++++++++++++++++-
 generic/tclCompile.c  |   4 +
 generic/tclCompile.h  |  25 +++---
 generic/tclDictObj.c  |  21 +----
 generic/tclExecute.c  |  15 +++-
 generic/tclInt.h      |   6 ++
 tests/dict.test       |  48 ++++++++++++
 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
-- 
cgit v0.12


From d82d84f00427920f30c549a88bb8ad726a93523f Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Thu, 1 Nov 2012 18:06:09 +0000
Subject: Added compilation of [tailcall]. Not a particularly efficient
 compilation though; it does not detect tailcall-of-self as a special case.

---
 generic/tclAssembly.c   |  6 +++---
 generic/tclBasic.c      | 11 +++++------
 generic/tclCompCmdsSZ.c | 44 ++++++++++++++++++++++++++++++++++++++++++++
 generic/tclCompile.c    |  4 ++++
 generic/tclCompile.h    | 15 ++++++++-------
 generic/tclExecute.c    | 49 +++++++++++++++++++++++++++++++++++++++++++++++++
 generic/tclInt.h        |  4 ++++
 7 files changed, 117 insertions(+), 16 deletions(-)

diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index eacaafe..f5f2469 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -514,9 +514,9 @@ static const unsigned char NonThrowingByteCodes[] = {
     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 */
+    INST_NS_CURRENT,						/* 149 */
+    INST_INFO_LEVEL_NUM,					/* 150 */
+    INST_RESOLVE_COMMAND					/* 152 */
 };
 
 /*
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 6e60aee..bce6479 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -136,7 +136,6 @@ static Tcl_NRPostProc	NRCoroutineExitCallback;
 static int NRCommand(ClientData data[], Tcl_Interp *interp, int result);
 
 static Tcl_NRPostProc	NRRunObjProc;
-static Tcl_NRPostProc	NRTailcallEval;
 static Tcl_ObjCmdProc	OldMathFuncProc;
 static void		OldMathFuncDeleteProc(ClientData clientData);
 static void		ProcessUnexpectedResult(Tcl_Interp *interp,
@@ -248,7 +247,7 @@ static const CmdInfo builtInCmds[] = {
     {"split",		Tcl_SplitObjCmd,	NULL,			NULL,	1},
     {"subst",		Tcl_SubstObjCmd,	TclCompileSubstCmd,	TclNRSubstObjCmd,	1},
     {"switch",		Tcl_SwitchObjCmd,	TclCompileSwitchCmd,	TclNRSwitchObjCmd, 1},
-    {"tailcall",	NULL,			NULL,			TclNRTailcallObjCmd,	1},
+    {"tailcall",	NULL,			TclCompileTailcallCmd,	TclNRTailcallObjCmd,	1},
     {"throw",		Tcl_ThrowObjCmd,	TclCompileThrowCmd,	NULL,	1},
     {"trace",		Tcl_TraceObjCmd,	NULL,			NULL,	1},
     {"try",		Tcl_TryObjCmd,		TclCompileTryCmd,	TclNRTryObjCmd,	1},
@@ -8322,7 +8321,7 @@ TclNRTailcallObjCmd(
 	return TCL_ERROR;
     }
 
-    if (!iPtr->varFramePtr->isProcCallFrame) {	/* or is upleveled */
+    if (!(iPtr->varFramePtr->isProcCallFrame & 1)) {	/* or is upleveled */
         Tcl_SetObjResult(interp, Tcl_NewStringObj(
                 "tailcall can only be called from a proc or lambda", -1));
         Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL);
@@ -8362,7 +8361,7 @@ TclNRTailcallObjCmd(
         }
         Tcl_IncrRefCount(nsObjPtr);
 
-        TclNRAddCallback(interp, NRTailcallEval, listPtr, nsObjPtr,
+        TclNRAddCallback(interp, TclNRTailcallEval, listPtr, nsObjPtr,
                 NULL, NULL);
         tailcallPtr = TOP_CB(interp);
         TOP_CB(interp) = tailcallPtr->nextPtr;
@@ -8372,7 +8371,7 @@ TclNRTailcallObjCmd(
 }
 
 int
-NRTailcallEval(
+TclNRTailcallEval(
     ClientData data[],
     Tcl_Interp *interp,
     int result)
@@ -8566,7 +8565,7 @@ YieldToCallback(
      * yieldTo: invoke the command using tailcall tech.
      */
 
-    TclNRAddCallback(interp, NRTailcallEval, listPtr, nsPtr, NULL, NULL);
+    TclNRAddCallback(interp, TclNRTailcallEval, listPtr, nsPtr, NULL, NULL);
     cbPtr = TOP_CB(interp);
     TOP_CB(interp) = cbPtr->nextPtr;
 
diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index 12396fe..57cb992 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -1987,6 +1987,50 @@ PrintJumptableInfo(
 /*
  *----------------------------------------------------------------------
  *
+ * TclCompileTailcallCmd --
+ *
+ *	Procedure called to compile the "tailcall" command.
+ *
+ * Results:
+ *	Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ *	evaluation to runtime.
+ *
+ * Side effects:
+ *	Instructions are added to envPtr to execute the "tailcall" command at
+ *	runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileTailcallCmd(
+    Tcl_Interp *interp,		/* Used for error reporting. */
+    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 = parsePtr->tokenPtr;
+    int i;
+
+    if (parsePtr->numWords < 2 || parsePtr->numWords > 256
+	    || envPtr->procPtr == NULL) {
+	return TCL_ERROR;
+    }
+
+    for (i=1 ; i<parsePtr->numWords ; i++) {
+	tokenPtr = TokenAfter(tokenPtr);
+	CompileWord(envPtr, tokenPtr, interp, i);
+    }
+    TclEmitInstInt1(	INST_TAILCALL, parsePtr->numWords-1,	envPtr);
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * TclCompileThrowCmd --
  *
  *	Procedure called to compile the "throw" command.
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index f979fa3..ee8511c 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -464,6 +464,10 @@ InstructionDesc const tclInstructionTable[] = {
     {"coroName",         1,    +1,	  0,	{OPERAND_NONE}},
 	/* Push the name of the interpreter's current coroutine as an object
 	 * on the stack. */
+    {"tailcall",	 2,    INT_MIN,	  1,	{OPERAND_UINT1}},
+	/* Do a tailcall with the opnd items on the stack as the thing to
+	 * tailcall to; opnd must be greater than 0 for the semantics to work
+	 * right. */
 
     {"currentNamespace", 1,    +1,	  0,	{OPERAND_NONE}},
 	/* Push the name of the interpreter's current namespace as an object
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 85d282f..08d59fd 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -688,19 +688,20 @@ typedef struct ByteCode {
 #define INST_STR_FIND			144
 #define INST_STR_RANGE_IMM		145
 
-/* For operations to do with coroutines */
+/* For operations to do with coroutines and other NRE-manipulators */
 #define INST_YIELD			146
 #define INST_COROUTINE_NAME		147
+#define INST_TAILCALL			148
 
 /* For compilation of basic information operations */
-#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
+#define INST_NS_CURRENT			149
+#define INST_INFO_LEVEL_NUM		150
+#define INST_INFO_LEVEL_ARGS		151
+#define INST_RESOLVE_COMMAND		152
+#define INST_TCLOO_SELF			153
 
 /* The last opcode */
-#define LAST_INST_OPCODE		152
+#define LAST_INST_OPCODE		153
 
 /*
  * Table describing the Tcl bytecode instructions: their name (for displaying
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index bbee81d..1e24cb3 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -2374,6 +2374,55 @@ TEBCresume(
 	return TCL_OK;
     }
 
+    case INST_TAILCALL: {
+	Tcl_Obj *listPtr, *nsObjPtr;
+        NRE_callback *tailcallPtr;
+
+	opnd = TclGetUInt1AtPtr(pc+1);
+
+	if (!(iPtr->varFramePtr->isProcCallFrame & 1)) {
+	    TRACE(("%d => ERROR: tailcall in non-proc context\n", opnd));
+	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
+		    "tailcall can only be called from a proc or lambda", -1));
+	    Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL);
+	    goto gotError;
+	}
+
+#ifdef TCL_COMPILE_DEBUG
+	TRACE(("%d [", opnd));
+	for (i=opnd-1 ; i>=0 ; i++) {
+	    TRACE_APPEND(("\"%.30s\"", O2S(OBJ_AT_DEPTH(i))));
+	    if (i > 0) {
+		TRACE_APPEND((" "));
+	    }
+	}
+	TRACE_APPEND(("] => RETURN..."));
+#endif
+
+	/*
+	 * Push the evaluation of the called command into the NR callback
+	 * stack.
+	 */
+
+	listPtr = Tcl_NewListObj(opnd, &OBJ_AT_DEPTH(opnd-1));
+	nsObjPtr = Tcl_NewStringObj(iPtr->varFramePtr->nsPtr->fullName, -1);
+	Tcl_IncrRefCount(listPtr);
+	Tcl_IncrRefCount(nsObjPtr);
+	TclNRAddCallback(interp, TclNRTailcallEval, listPtr, nsObjPtr,
+		NULL, NULL);
+
+	/*
+	 * Unstitch ourselves and do a [return].
+	 */
+
+	tailcallPtr = TOP_CB(interp);
+	TOP_CB(interp) = tailcallPtr->nextPtr;
+	iPtr->varFramePtr->tailcallPtr = tailcallPtr;
+	result = TCL_RETURN;
+	cleanup = opnd;
+	goto processExceptionReturn;
+    }
+
     case INST_DONE:
 	if (tosPtr > initTosPtr) {
 	    /*
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 49298b3..1fffa1f 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -2799,6 +2799,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRWhileObjCmd;
 MODULE_SCOPE Tcl_NRPostProc TclNRForIterCallback;
 MODULE_SCOPE Tcl_NRPostProc TclNRCoroutineActivateCallback;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRTailcallObjCmd;
+MODULE_SCOPE Tcl_NRPostProc TclNRTailcallEval;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRCoroutineObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldmObjCmd;
@@ -3664,6 +3665,9 @@ MODULE_SCOPE int	TclCompileSubstCmd(Tcl_Interp *interp,
 MODULE_SCOPE int	TclCompileSwitchCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
+MODULE_SCOPE int	TclCompileTailcallCmd(Tcl_Interp *interp,
+			    Tcl_Parse *parsePtr, Command *cmdPtr,
+			    struct CompileEnv *envPtr);
 MODULE_SCOPE int	TclCompileThrowCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
-- 
cgit v0.12


From acd9d784587b6767a3f9635251808a583dc11b09 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Fri, 2 Nov 2012 18:13:20 +0000
Subject: Added more TclOO introspection bytecodes ([info object class], [info
 object namespace]). Also moved TclOO-in-8.6 to using the main Tcl internal
 ensemble builder.

---
 generic/tclAssembly.c |  2 ++
 generic/tclCompCmds.c | 40 ++++++++++++++++++++++++
 generic/tclCompile.c  |  8 +++++
 generic/tclCompile.h  |  4 ++-
 generic/tclExecute.c  | 28 +++++++++++++++++
 generic/tclInt.h      |  6 ++++
 generic/tclOOInfo.c   | 85 +++++++++++++++++++--------------------------------
 7 files changed, 119 insertions(+), 54 deletions(-)

diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index f5f2469..19d6232 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -480,6 +480,8 @@ static const TalInstDesc TalInstructionTable[] = {
     {"strmatch",	ASSEM_BOOL,	INST_STR_MATCH,		2,	1},
     {"strneq",		ASSEM_1BYTE,	INST_STR_NEQ,		2,	1},
     {"sub",		ASSEM_1BYTE,	INST_SUB,		2,	1},
+    {"tclooClass",	ASSEM_1BYTE,	INST_TCLOO_CLASS,	1,	1},
+    {"tclooNamespace",	ASSEM_1BYTE,	INST_TCLOO_NS,		1,	1},
     {"tclooSelf",	ASSEM_1BYTE,	INST_TCLOO_SELF,	0,	1},
     {"tryCvtToNumeric",	ASSEM_1BYTE,	INST_TRY_CVT_TO_NUMERIC,1,	1},
     {"uminus",		ASSEM_1BYTE,	INST_UMINUS,		1,	1},
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 5beb7bd..e476cf0 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -3666,6 +3666,46 @@ TclCompileInfoLevelCmd(
     }
     return TCL_OK;
 }
+
+int
+TclCompileInfoObjectClassCmd(
+    Tcl_Interp *interp,		/* Used for error reporting. */
+    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)
+{
+    DefineLineInformation;	/* TIP #280 */
+    Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
+
+    if (parsePtr->numWords != 2) {
+	return TCL_ERROR;
+    }
+    CompileWord(envPtr,		tokenPtr,		interp, 1);
+    TclEmitOpcode(		INST_TCLOO_CLASS,	envPtr);
+    return TCL_OK;
+}
+
+int
+TclCompileInfoObjectNamespaceCmd(
+    Tcl_Interp *interp,		/* Used for error reporting. */
+    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)
+{
+    DefineLineInformation;	/* TIP #280 */
+    Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
+
+    if (parsePtr->numWords != 2) {
+	return TCL_ERROR;
+    }
+    CompileWord(envPtr,		tokenPtr,		interp, 1);
+    TclEmitOpcode(		INST_TCLOO_NS,		envPtr);
+    return TCL_OK;
+}
 
 /*
  *----------------------------------------------------------------------
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index ee8511c..d47e0f6 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -487,6 +487,14 @@ InstructionDesc const tclInstructionTable[] = {
     {"tclooSelf",	 1,	+1,	  0,	{OPERAND_NONE}},
 	/* Push the identity of the current TclOO object (i.e., the name of
 	 * its current public access command) on the stack. */
+   {"tclooClass",	 1,	0,	  0,	{OPERAND_NONE}},
+	/* Push the class of the TclOO object named at the top of the stack
+	 * onto the stack.
+	 * Stack:  ... object => ... class */
+   {"tclooNamespace",	 1,	0,	  0,	{OPERAND_NONE}},
+	/* Push the namespace of the TclOO object named at the top of the
+	 * stack onto the stack.
+	 * Stack:  ... object => ... namespace */
 
     {NULL, 0, 0, 0, {OPERAND_NONE}}
 };
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 08d59fd..a31a33b 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -699,9 +699,11 @@ typedef struct ByteCode {
 #define INST_INFO_LEVEL_ARGS		151
 #define INST_RESOLVE_COMMAND		152
 #define INST_TCLOO_SELF			153
+#define INST_TCLOO_CLASS		154
+#define INST_TCLOO_NS			155
 
 /* The last opcode */
-#define LAST_INST_OPCODE		153
+#define LAST_INST_OPCODE		155
 
 /*
  * Table describing the Tcl bytecode instructions: their name (for displaying
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 1e24cb3..bf07dd7 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -4231,6 +4231,34 @@ TEBCresume(
 	TRACE_WITH_OBJ(("=> "), objResultPtr);
 	NEXT_INST_F(1, 0, 1);
     }
+    {
+	Object *oPtr;
+
+    case INST_TCLOO_CLASS:
+	oPtr = (Object *) Tcl_GetObjectFromObj(interp, OBJ_AT_TOS);
+	if (oPtr == NULL) {
+	    TRACE(("%.30s => ERROR: not object\n", O2S(OBJ_AT_TOS)));
+	    goto gotError;
+	}
+	objResultPtr = TclOOObjectName(interp, oPtr->selfCls->thisPtr);
+	TRACE_WITH_OBJ(("%.30s => ", O2S(OBJ_AT_TOS)), objResultPtr);
+	NEXT_INST_F(1, 1, 1);
+    case INST_TCLOO_NS:
+	oPtr = (Object *) Tcl_GetObjectFromObj(interp, OBJ_AT_TOS);
+	if (oPtr == NULL) {
+	    TRACE(("%.30s => ERROR: not object\n", O2S(OBJ_AT_TOS)));
+	    goto gotError;
+	}
+
+	/*
+	 * TclOO objects *never* have the global namespace as their NS.
+	 */
+
+	TclNewStringObj(objResultPtr, oPtr->namespacePtr->fullName,
+		strlen(oPtr->namespacePtr->fullName));
+	TRACE_WITH_OBJ(("%.30s => ", O2S(OBJ_AT_TOS)), objResultPtr);
+	NEXT_INST_F(1, 1, 1);
+    }
 
     /*
      * -----------------------------------------------------------------
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 1fffa1f..06bcd95 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3575,6 +3575,12 @@ MODULE_SCOPE int	TclCompileInfoExistsCmd(Tcl_Interp *interp,
 MODULE_SCOPE int	TclCompileInfoLevelCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
+MODULE_SCOPE int	TclCompileInfoObjectClassCmd(Tcl_Interp *interp,
+			    Tcl_Parse *parsePtr, Command *cmdPtr,
+			    struct CompileEnv *envPtr);
+MODULE_SCOPE int	TclCompileInfoObjectNamespaceCmd(Tcl_Interp *interp,
+			    Tcl_Parse *parsePtr, Command *cmdPtr,
+			    struct CompileEnv *envPtr);
 MODULE_SCOPE int	TclCompileIncrCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c
index 1a94e69..ff3e1e5 100644
--- a/generic/tclOOInfo.c
+++ b/generic/tclOOInfo.c
@@ -43,47 +43,45 @@ static Tcl_ObjCmdProc InfoClassSubsCmd;
 static Tcl_ObjCmdProc InfoClassSupersCmd;
 static Tcl_ObjCmdProc InfoClassVariablesCmd;
 
-struct NameProcMap { const char *name; Tcl_ObjCmdProc *proc; };
-
 /*
  * List of commands that are used to implement the [info object] subcommands.
  */
 
-static const struct NameProcMap infoObjectCmds[] = {
-    {"::oo::InfoObject::call",		InfoObjectCallCmd},
-    {"::oo::InfoObject::class",		InfoObjectClassCmd},
-    {"::oo::InfoObject::definition",	InfoObjectDefnCmd},
-    {"::oo::InfoObject::filters",	InfoObjectFiltersCmd},
-    {"::oo::InfoObject::forward",	InfoObjectForwardCmd},
-    {"::oo::InfoObject::isa",		InfoObjectIsACmd},
-    {"::oo::InfoObject::methods",	InfoObjectMethodsCmd},
-    {"::oo::InfoObject::methodtype",	InfoObjectMethodTypeCmd},
-    {"::oo::InfoObject::mixins",	InfoObjectMixinsCmd},
-    {"::oo::InfoObject::namespace",	InfoObjectNsCmd},
-    {"::oo::InfoObject::variables",	InfoObjectVariablesCmd},
-    {"::oo::InfoObject::vars",		InfoObjectVarsCmd},
-    {NULL, NULL}
+static const EnsembleImplMap infoObjectCmds[] = {
+    {"call",	   InfoObjectCallCmd,	    NULL, NULL, NULL, 0},
+    {"class",	   InfoObjectClassCmd,	    TclCompileInfoObjectClassCmd, NULL, NULL, 0},
+    {"definition", InfoObjectDefnCmd,	    NULL, NULL, NULL, 0},
+    {"filters",	   InfoObjectFiltersCmd,    NULL, NULL, NULL, 0},
+    {"forward",	   InfoObjectForwardCmd,    NULL, NULL, NULL, 0},
+    {"isa",	   InfoObjectIsACmd,	    NULL, NULL, NULL, 0},
+    {"methods",	   InfoObjectMethodsCmd,    NULL, NULL, NULL, 0},
+    {"methodtype", InfoObjectMethodTypeCmd, NULL, NULL, NULL, 0},
+    {"mixins",	   InfoObjectMixinsCmd,	    NULL, NULL, NULL, 0},
+    {"namespace",  InfoObjectNsCmd,	    TclCompileInfoObjectNamespaceCmd, NULL, NULL, 0},
+    {"variables",  InfoObjectVariablesCmd,  NULL, NULL, NULL, 0},
+    {"vars",	   InfoObjectVarsCmd,	    NULL, NULL, NULL, 0},
+    {NULL, NULL, NULL, NULL, NULL, 0}
 };
 
 /*
  * List of commands that are used to implement the [info class] subcommands.
  */
 
-static const struct NameProcMap infoClassCmds[] = {
-    {"::oo::InfoClass::call",		InfoClassCallCmd},
-    {"::oo::InfoClass::constructor",	InfoClassConstrCmd},
-    {"::oo::InfoClass::definition",	InfoClassDefnCmd},
-    {"::oo::InfoClass::destructor",	InfoClassDestrCmd},
-    {"::oo::InfoClass::filters",	InfoClassFiltersCmd},
-    {"::oo::InfoClass::forward",	InfoClassForwardCmd},
-    {"::oo::InfoClass::instances",	InfoClassInstancesCmd},
-    {"::oo::InfoClass::methods",	InfoClassMethodsCmd},
-    {"::oo::InfoClass::methodtype",	InfoClassMethodTypeCmd},
-    {"::oo::InfoClass::mixins",		InfoClassMixinsCmd},
-    {"::oo::InfoClass::subclasses",	InfoClassSubsCmd},
-    {"::oo::InfoClass::superclasses",	InfoClassSupersCmd},
-    {"::oo::InfoClass::variables",	InfoClassVariablesCmd},
-    {NULL, NULL}
+static const EnsembleImplMap infoClassCmds[] = {
+    {"call",	     InfoClassCallCmd,		NULL, NULL, NULL, 0},
+    {"constructor",  InfoClassConstrCmd,	NULL, NULL, NULL, 0},
+    {"definition",   InfoClassDefnCmd,		NULL, NULL, NULL, 0},
+    {"destructor",   InfoClassDestrCmd,		NULL, NULL, NULL, 0},
+    {"filters",	     InfoClassFiltersCmd,	NULL, NULL, NULL, 0},
+    {"forward",	     InfoClassForwardCmd,	NULL, NULL, NULL, 0},
+    {"instances",    InfoClassInstancesCmd,	NULL, NULL, NULL, 0},
+    {"methods",	     InfoClassMethodsCmd,	NULL, NULL, NULL, 0},
+    {"methodtype",   InfoClassMethodTypeCmd,	NULL, NULL, NULL, 0},
+    {"mixins",	     InfoClassMixinsCmd,	NULL, NULL, NULL, 0},
+    {"subclasses",   InfoClassSubsCmd,		NULL, NULL, NULL, 0},
+    {"superclasses", InfoClassSupersCmd,	NULL, NULL, NULL, 0},
+    {"variables",    InfoClassVariablesCmd,	NULL, NULL, NULL, 0},
+    {NULL, NULL, NULL, NULL, NULL, 0}
 };
 
 /*
@@ -101,33 +99,14 @@ void
 TclOOInitInfo(
     Tcl_Interp *interp)
 {
-    Tcl_Namespace *nsPtr;
     Tcl_Command infoCmd;
-    int i;
-
-    /*
-     * Build the ensemble used to implement [info object].
-     */
-
-    nsPtr = Tcl_CreateNamespace(interp, "::oo::InfoObject", NULL, NULL);
-    Tcl_CreateEnsemble(interp, nsPtr->fullName, nsPtr, TCL_ENSEMBLE_PREFIX);
-    Tcl_Export(interp, nsPtr, "[a-z]*", 1);
-    for (i=0 ; infoObjectCmds[i].name!=NULL ; i++) {
-	Tcl_CreateObjCommand(interp, infoObjectCmds[i].name,
-		infoObjectCmds[i].proc, NULL, NULL);
-    }
 
     /*
-     * Build the ensemble used to implement [info class].
+     * Build the ensembles used to implement [info object] and [info class].
      */
 
-    nsPtr = Tcl_CreateNamespace(interp, "::oo::InfoClass", NULL, NULL);
-    Tcl_CreateEnsemble(interp, nsPtr->fullName, nsPtr, TCL_ENSEMBLE_PREFIX);
-    Tcl_Export(interp, nsPtr, "[a-z]*", 1);
-    for (i=0 ; infoClassCmds[i].name!=NULL ; i++) {
-	Tcl_CreateObjCommand(interp, infoClassCmds[i].name,
-		infoClassCmds[i].proc, NULL, NULL);
-    }
+    TclMakeEnsemble(interp, "::oo::InfoObject", infoObjectCmds);
+    TclMakeEnsemble(interp, "::oo::InfoClass", infoClassCmds);
 
     /*
      * Install into the master [info] ensemble.
-- 
cgit v0.12


From f17426d59e1252097decdf5715f91dd77c57cda7 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Sat, 3 Nov 2012 12:48:08 +0000
Subject: Added compilation of [info object isa object] (i.e., object
 verification).

---
 generic/tclAssembly.c |  1 +
 generic/tclCompCmds.c | 36 ++++++++++++++++++++++++++++++++++++
 generic/tclCompile.c  | 10 ++++++++--
 generic/tclCompile.h  |  3 ++-
 generic/tclExecute.c  |  5 +++++
 generic/tclInt.h      |  3 +++
 generic/tclOOInfo.c   |  2 +-
 7 files changed, 56 insertions(+), 4 deletions(-)

diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 19d6232..9256556 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -481,6 +481,7 @@ static const TalInstDesc TalInstructionTable[] = {
     {"strneq",		ASSEM_1BYTE,	INST_STR_NEQ,		2,	1},
     {"sub",		ASSEM_1BYTE,	INST_SUB,		2,	1},
     {"tclooClass",	ASSEM_1BYTE,	INST_TCLOO_CLASS,	1,	1},
+    {"tclooIsObject",	ASSEM_1BYTE,	INST_TCLOO_IS_OBJECT,	1,	1},
     {"tclooNamespace",	ASSEM_1BYTE,	INST_TCLOO_NS,		1,	1},
     {"tclooSelf",	ASSEM_1BYTE,	INST_TCLOO_SELF,	0,	1},
     {"tryCvtToNumeric",	ASSEM_1BYTE,	INST_TRY_CVT_TO_NUMERIC,1,	1},
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index e476cf0..0829072 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -3688,6 +3688,42 @@ TclCompileInfoObjectClassCmd(
 }
 
 int
+TclCompileInfoObjectIsACmd(
+    Tcl_Interp *interp,		/* Used for error reporting. */
+    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)
+{
+    DefineLineInformation;	/* TIP #280 */
+    Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
+
+    /*
+     * We only handle [info object isa object <somevalue>]. The first three
+     * words are compressed to a single token by the ensemble compilation
+     * engine.
+     */
+
+    if (parsePtr->numWords != 3) {
+	return TCL_ERROR;
+    }
+    if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size < 1
+	    || strncmp(tokenPtr[1].start, "object", tokenPtr[1].size)) {
+	return TCL_ERROR;
+    }
+    tokenPtr = TokenAfter(tokenPtr);
+
+    /*
+     * Issue the code.
+     */
+
+    CompileWord(envPtr,		tokenPtr,		interp, 2);
+    TclEmitOpcode(		INST_TCLOO_IS_OBJECT,	envPtr);
+    return TCL_OK;
+}
+
+int
 TclCompileInfoObjectNamespaceCmd(
     Tcl_Interp *interp,		/* Used for error reporting. */
     Tcl_Parse *parsePtr,	/* Points to a parse structure for the command
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index d47e0f6..475a85e 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -487,14 +487,20 @@ InstructionDesc const tclInstructionTable[] = {
     {"tclooSelf",	 1,	+1,	  0,	{OPERAND_NONE}},
 	/* Push the identity of the current TclOO object (i.e., the name of
 	 * its current public access command) on the stack. */
-   {"tclooClass",	 1,	0,	  0,	{OPERAND_NONE}},
+    {"tclooClass",	 1,	0,	  0,	{OPERAND_NONE}},
 	/* Push the class of the TclOO object named at the top of the stack
 	 * onto the stack.
 	 * Stack:  ... object => ... class */
-   {"tclooNamespace",	 1,	0,	  0,	{OPERAND_NONE}},
+    {"tclooNamespace",	 1,	0,	  0,	{OPERAND_NONE}},
 	/* Push the namespace of the TclOO object named at the top of the
 	 * stack onto the stack.
 	 * Stack:  ... object => ... namespace */
+    {"tclooIsObject",	 1,	0,	  0,	{OPERAND_NONE}},
+	/* Push whether the value named at the top of the stack is a TclOO
+	 * object (i.e., a boolean). Can corrupt the interpreter result
+	 * despite not throwing, so not safe for use in a post-exception
+	 * context.
+	 * Stack:  ... value => ... boolean */
 
     {NULL, 0, 0, 0, {OPERAND_NONE}}
 };
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index a31a33b..3db3a78 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -701,9 +701,10 @@ typedef struct ByteCode {
 #define INST_TCLOO_SELF			153
 #define INST_TCLOO_CLASS		154
 #define INST_TCLOO_NS			155
+#define INST_TCLOO_IS_OBJECT		156
 
 /* The last opcode */
-#define LAST_INST_OPCODE		155
+#define LAST_INST_OPCODE		156
 
 /*
  * Table describing the Tcl bytecode instructions: their name (for displaying
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index bf07dd7..ad79482 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -4234,6 +4234,11 @@ TEBCresume(
     {
 	Object *oPtr;
 
+    case INST_TCLOO_IS_OBJECT:
+	oPtr = (Object *) Tcl_GetObjectFromObj(interp, OBJ_AT_TOS);
+	objResultPtr = TCONST(oPtr != NULL ? 1 : 0);
+	TRACE_WITH_OBJ(("%.30s => ", O2S(OBJ_AT_TOS)), objResultPtr);
+	NEXT_INST_F(1, 1, 1);
     case INST_TCLOO_CLASS:
 	oPtr = (Object *) Tcl_GetObjectFromObj(interp, OBJ_AT_TOS);
 	if (oPtr == NULL) {
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 06bcd95..48297b9 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3578,6 +3578,9 @@ MODULE_SCOPE int	TclCompileInfoLevelCmd(Tcl_Interp *interp,
 MODULE_SCOPE int	TclCompileInfoObjectClassCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
+MODULE_SCOPE int	TclCompileInfoObjectIsACmd(Tcl_Interp *interp,
+			    Tcl_Parse *parsePtr, Command *cmdPtr,
+			    struct CompileEnv *envPtr);
 MODULE_SCOPE int	TclCompileInfoObjectNamespaceCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c
index ff3e1e5..e09ee4e 100644
--- a/generic/tclOOInfo.c
+++ b/generic/tclOOInfo.c
@@ -53,7 +53,7 @@ static const EnsembleImplMap infoObjectCmds[] = {
     {"definition", InfoObjectDefnCmd,	    NULL, NULL, NULL, 0},
     {"filters",	   InfoObjectFiltersCmd,    NULL, NULL, NULL, 0},
     {"forward",	   InfoObjectForwardCmd,    NULL, NULL, NULL, 0},
-    {"isa",	   InfoObjectIsACmd,	    NULL, NULL, NULL, 0},
+    {"isa",	   InfoObjectIsACmd,	    TclCompileInfoObjectIsACmd, NULL, NULL, 0},
     {"methods",	   InfoObjectMethodsCmd,    NULL, NULL, NULL, 0},
     {"methodtype", InfoObjectMethodTypeCmd, NULL, NULL, NULL, 0},
     {"mixins",	   InfoObjectMixinsCmd,	    NULL, NULL, NULL, 0},
-- 
cgit v0.12


From 9ef6a75daf7373340bbc3e03f5337ac7fbeb6d5b Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Sat, 3 Nov 2012 20:21:13 +0000
Subject: Added compilation of [string last] and improved the compilation of
 [string range]. This in turn enables compilation of [namespace qualifiers]
 and [namespace tail] (also done).

---
 generic/tclAssembly.c   |  10 +-
 generic/tclCmdMZ.c      |   2 +-
 generic/tclCompCmds.c   |  73 ++++++++++++++
 generic/tclCompCmdsSZ.c | 252 +++++++++++++++---------------------------------
 generic/tclCompile.c    |   7 ++
 generic/tclCompile.h    |  28 +++---
 generic/tclExecute.c    |  48 ++++++++-
 generic/tclInt.h        |   9 ++
 generic/tclNamesp.c     |  38 ++++----
 9 files changed, 253 insertions(+), 214 deletions(-)

diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 9256556..3b02ca2 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -479,6 +479,8 @@ static const TalInstDesc TalInstructionTable[] = {
     {"strmap",		ASSEM_1BYTE,	INST_STR_MAP,		3,	1},
     {"strmatch",	ASSEM_BOOL,	INST_STR_MATCH,		2,	1},
     {"strneq",		ASSEM_1BYTE,	INST_STR_NEQ,		2,	1},
+    {"strrange",	ASSEM_1BYTE,	INST_STR_RANGE,		3,	1},
+    {"strrfind",	ASSEM_1BYTE,	INST_STR_FIND_LAST,	2,	1},
     {"sub",		ASSEM_1BYTE,	INST_SUB,		2,	1},
     {"tclooClass",	ASSEM_1BYTE,	INST_TCLOO_CLASS,	1,	1},
     {"tclooIsObject",	ASSEM_1BYTE,	INST_TCLOO_IS_OBJECT,	1,	1},
@@ -516,10 +518,10 @@ static const unsigned char NonThrowingByteCodes[] = {
     INST_NOP,							/* 132 */
     INST_STR_MAP,						/* 143 */
     INST_STR_FIND,						/* 144 */
-    INST_COROUTINE_NAME,					/* 147 */
-    INST_NS_CURRENT,						/* 149 */
-    INST_INFO_LEVEL_NUM,					/* 150 */
-    INST_RESOLVE_COMMAND					/* 152 */
+    INST_COROUTINE_NAME,					/* 149 */
+    INST_NS_CURRENT,						/* 151 */
+    INST_INFO_LEVEL_NUM,					/* 152 */
+    INST_RESOLVE_COMMAND					/* 154 */
 };
 
 /*
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index de32fce..c14f543 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -3307,7 +3307,7 @@ TclInitStringCmd(
 	{"first",	StringFirstCmd,	TclCompileStringFirstCmd, NULL, NULL, 0},
 	{"index",	StringIndexCmd,	TclCompileStringIndexCmd, NULL, NULL, 0},
 	{"is",		StringIsCmd,	NULL, NULL, NULL, 0},
-	{"last",	StringLastCmd,	NULL, NULL, NULL, 0},
+	{"last",	StringLastCmd,	TclCompileStringLastCmd, NULL, NULL, 0},
 	{"length",	StringLenCmd,	TclCompileStringLenCmd, NULL, NULL, 0},
 	{"map",		StringMapCmd,	TclCompileStringMapCmd, NULL, NULL, 0},
 	{"match",	StringMatchCmd,	TclCompileStringMatchCmd, NULL, NULL, 0},
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 0829072..463e82c 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -4683,6 +4683,79 @@ TclCompileNamespaceCodeCmd(
 }
 
 int
+TclCompileNamespaceQualifiersCmd(
+    Tcl_Interp *interp,		/* Used for error reporting. */
+    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. */
+{
+    Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
+    DefineLineInformation;	/* TIP #280 */
+    int off;
+
+    if (parsePtr->numWords != 2) {
+	return TCL_ERROR;
+    }
+
+    CompileWord(envPtr, tokenPtr, interp, 1);
+    PushLiteral(envPtr, "0", 1);
+    PushLiteral(envPtr, "::", 2);
+    TclEmitInstInt4(	INST_OVER, 2,			envPtr);
+    TclEmitOpcode(	INST_STR_FIND_LAST,		envPtr);
+    off = CurrentOffset(envPtr);
+    PushLiteral(envPtr, "1", 1);
+    TclEmitOpcode(	INST_SUB,			envPtr);
+    TclEmitInstInt4(	INST_OVER, 2,			envPtr);
+    TclEmitInstInt4(	INST_OVER, 1,			envPtr);
+    TclEmitOpcode(	INST_STR_INDEX,			envPtr);
+    PushLiteral(envPtr, ":", 1);
+    TclEmitOpcode(	INST_STR_EQ,			envPtr);
+    off = off - CurrentOffset(envPtr);
+    TclEmitInstInt1(	INST_JUMP_TRUE1, off,		envPtr);
+    TclEmitOpcode(	INST_STR_RANGE,			envPtr);
+    return TCL_OK;
+}
+
+int
+TclCompileNamespaceTailCmd(
+    Tcl_Interp *interp,		/* Used for error reporting. */
+    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. */
+{
+    Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
+    DefineLineInformation;	/* TIP #280 */
+    JumpFixup jumpFixup;
+
+    if (parsePtr->numWords != 2) {
+	return TCL_ERROR;
+    }
+
+    /*
+     * Take care; only add 2 to found index if the string was actually found.
+     */
+
+    CompileWord(envPtr, tokenPtr, interp, 1);
+    PushLiteral(envPtr, "::", 2);
+    TclEmitInstInt4(	INST_OVER, 1,			envPtr);
+    TclEmitOpcode(	INST_STR_FIND_LAST,		envPtr);
+    TclEmitOpcode(	INST_DUP,			envPtr);
+    PushLiteral(envPtr, "0", 1);
+    TclEmitOpcode(	INST_GE,			envPtr);
+    TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFixup);
+    PushLiteral(envPtr, "2", 1);
+    TclEmitOpcode(	INST_ADD,			envPtr);
+    TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127);
+    PushLiteral(envPtr, "end", 3);
+    TclEmitOpcode(	INST_STR_RANGE,			envPtr);
+    return TCL_OK;
+}
+
+int
 TclCompileNamespaceUpvarCmd(
     Tcl_Interp *interp,		/* Used for error reporting. */
     Tcl_Parse *parsePtr,	/* Points to a parse structure for the command
diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index 57cb992..090f996 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -251,18 +251,18 @@ TclCompileSetCmd(
 /*
  *----------------------------------------------------------------------
  *
- * TclCompileStringCmpCmd --
+ * TclCompileString*Cmd --
  *
- *	Procedure called to compile the simplest and most common form of the
- *	"string compare" command.
+ *	Procedures called to compile various subcommands of the "string"
+ *	command.
  *
  * Results:
  *	Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
  *	evaluation to runtime.
  *
  * Side effects:
- *	Instructions are added to envPtr to execute the "string compare"
- *	command at runtime.
+ *	Instructions are added to envPtr to execute the "string" command at
+ *	runtime.
  *
  *----------------------------------------------------------------------
  */
@@ -298,25 +298,6 @@ TclCompileStringCmpCmd(
     TclEmitOpcode(INST_STR_CMP, envPtr);
     return TCL_OK;
 }
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileStringEqualCmd --
- *
- *	Procedure called to compile the simplest and most common form of the
- *	"string equal" command.
- *
- * Results:
- *	Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- *	evaluation to runtime.
- *
- * Side effects:
- *	Instructions are added to envPtr to execute the "string equal" command
- *	at runtime.
- *
- *----------------------------------------------------------------------
- */
 
 int
 TclCompileStringEqualCmd(
@@ -349,25 +330,6 @@ TclCompileStringEqualCmd(
     TclEmitOpcode(INST_STR_EQ, envPtr);
     return TCL_OK;
 }
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileStringFirstCmd --
- *
- *	Procedure called to compile the simplest and most common form of the
- *	"string first" command.
- *
- * Results:
- *	Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- *	evaluation to runtime.
- *
- * Side effects:
- *	Instructions are added to envPtr to execute the "string first"
- *	command at runtime.
- *
- *----------------------------------------------------------------------
- */
 
 int
 TclCompileStringFirstCmd(
@@ -400,25 +362,38 @@ TclCompileStringFirstCmd(
     OP(STR_FIND);
     return TCL_OK;
 }
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileStringIndexCmd --
- *
- *	Procedure called to compile the simplest and most common form of the
- *	"string index" command.
- *
- * Results:
- *	Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- *	evaluation to runtime.
- *
- * Side effects:
- *	Instructions are added to envPtr to execute the "string index" command
- *	at runtime.
- *
- *----------------------------------------------------------------------
- */
+
+int
+TclCompileStringLastCmd(
+    Tcl_Interp *interp,		/* Used for error reporting. */
+    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;
+
+    /*
+     * We don't support any flags; the bytecode isn't that sophisticated.
+     */
+
+    if (parsePtr->numWords != 3) {
+	return TCL_ERROR;
+    }
+
+    /*
+     * Push the two operands onto the stack and then the test.
+     */
+
+    tokenPtr = TokenAfter(parsePtr->tokenPtr);
+    CompileWord(envPtr, tokenPtr, interp, 1);
+    tokenPtr = TokenAfter(tokenPtr);
+    CompileWord(envPtr, tokenPtr, interp, 2);
+    OP(STR_FIND_LAST);
+    return TCL_OK;
+}
 
 int
 TclCompileStringIndexCmd(
@@ -447,25 +422,6 @@ TclCompileStringIndexCmd(
     TclEmitOpcode(INST_STR_INDEX, envPtr);
     return TCL_OK;
 }
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileStringMatchCmd --
- *
- *	Procedure called to compile the simplest and most common form of the
- *	"string match" command.
- *
- * Results:
- *	Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- *	evaluation to runtime.
- *
- * Side effects:
- *	Instructions are added to envPtr to execute the "string match" command
- *	at runtime.
- *
- *----------------------------------------------------------------------
- */
 
 int
 TclCompileStringMatchCmd(
@@ -547,25 +503,6 @@ TclCompileStringMatchCmd(
     }
     return TCL_OK;
 }
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileStringLenCmd --
- *
- *	Procedure called to compile the simplest and most common form of the
- *	"string length" command.
- *
- * Results:
- *	Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- *	evaluation to runtime.
- *
- * Side effects:
- *	Instructions are added to envPtr to execute the "string length"
- *	command at runtime.
- *
- *----------------------------------------------------------------------
- */
 
 int
 TclCompileStringLenCmd(
@@ -606,25 +543,6 @@ TclCompileStringLenCmd(
     TclDecrRefCount(objPtr);
     return TCL_OK;
 }
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileStringMapCmd --
- *
- *	Procedure called to compile the simplest and most common form of the
- *	"string map" command.
- *
- * Results:
- *	Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- *	evaluation to runtime.
- *
- * Side effects:
- *	Instructions are added to envPtr to execute the "string map" command
- *	at runtime.
- *
- *----------------------------------------------------------------------
- */
 
 int
 TclCompileStringMapCmd(
@@ -688,25 +606,6 @@ TclCompileStringMapCmd(
     Tcl_DecrRefCount(mapObj);
     return TCL_OK;
 }
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileStringRangeCmd --
- *
- *	Procedure called to compile the "string range" command (with constant
- *	indices).
- *
- * Results:
- *	Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- *	evaluation to runtime.
- *
- * Side effects:
- *	Instructions are added to envPtr to execute the "string compare"
- *	command at runtime.
- *
- *----------------------------------------------------------------------
- */
 
 int
 TclCompileStringRangeCmd(
@@ -718,18 +617,16 @@ TclCompileStringRangeCmd(
     CompileEnv *envPtr)		/* Holds resulting instructions. */
 {
     DefineLineInformation;	/* TIP #280 */
-    Tcl_Token *stringTokenPtr, *tokenPtr;
+    Tcl_Token *stringTokenPtr, *fromTokenPtr, *toTokenPtr;
     Tcl_Obj *tmpObj;
     int idx1, idx2, result;
 
-    /*
-     * We don't support any flags; the bytecode isn't that sophisticated.
-     */
-
     if (parsePtr->numWords != 4) {
 	return TCL_ERROR;
     }
     stringTokenPtr = TokenAfter(parsePtr->tokenPtr);
+    fromTokenPtr = TokenAfter(stringTokenPtr);
+    toTokenPtr = TokenAfter(fromTokenPtr);
 
     /*
      * Parse the first index. Will only compile if it is constant and not an
@@ -737,26 +634,22 @@ TclCompileStringRangeCmd(
      * end-relative indexing).
      */
 
-    tokenPtr = TokenAfter(stringTokenPtr);
     tmpObj = Tcl_NewObj();
-    if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj)) {
-	Tcl_DecrRefCount(tmpObj);
-	return TCL_ERROR;
-    }
-    result = TclGetIntFromObj(NULL, tmpObj, &idx1);
-    if (result == TCL_OK) {
-	if (idx1 < 0) {
-	    result = TCL_ERROR;
-	}
-    } else {
-	result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx1);
-	if (result == TCL_OK && idx1 > -2) {
-	    result = TCL_ERROR;
+    result = TCL_ERROR;
+    if (TclWordKnownAtCompileTime(fromTokenPtr, tmpObj)) {
+	if (TclGetIntFromObj(NULL, tmpObj, &idx1) == TCL_OK) {
+	    if (idx1 >= 0) {
+		result = TCL_OK;
+	    }
+	} else if (TclGetIntForIndexM(NULL, tmpObj, -2, &idx1) == TCL_OK) {
+	    if (idx1 <= -2) {
+		result = TCL_OK;
+	    }
 	}
     }
     TclDecrRefCount(tmpObj);
     if (result != TCL_OK) {
-	return TCL_ERROR;
+	goto nonConstantIndices;
     }
 
     /*
@@ -765,34 +658,41 @@ TclCompileStringRangeCmd(
      * end-relative indexing).
      */
 
-    tokenPtr = TokenAfter(tokenPtr);
     tmpObj = Tcl_NewObj();
-    if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj)) {
-	Tcl_DecrRefCount(tmpObj);
-	return TCL_ERROR;
-    }
-    result = TclGetIntFromObj(NULL, tmpObj, &idx2);
-    if (result == TCL_OK) {
-	if (idx2 < 0) {
-	    result = TCL_ERROR;
-	}
-    } else {
-	result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx2);
-	if (result == TCL_OK && idx2 > -2) {
-	    result = TCL_ERROR;
+    result = TCL_ERROR;
+    if (TclWordKnownAtCompileTime(toTokenPtr, tmpObj)) {
+	if (TclGetIntFromObj(NULL, tmpObj, &idx2) == TCL_OK) {
+	    if (idx2 >= 0) {
+		result = TCL_OK;
+	    }
+	} else if (TclGetIntForIndexM(NULL, tmpObj, -2, &idx2) == TCL_OK) {
+	    if (idx2 <= -2) {
+		result = TCL_OK;
+	    }
 	}
     }
     TclDecrRefCount(tmpObj);
     if (result != TCL_OK) {
-	return TCL_ERROR;
+	goto nonConstantIndices;
     }
 
     /*
-     * Push the two operands onto the stack and then the test.
+     * Push the operand onto the stack and then the substring operation.
      */
 
-    CompileWord(envPtr, stringTokenPtr, interp, 1);
-    OP44(	STR_RANGE_IMM, idx1, idx2);
+    CompileWord(envPtr, stringTokenPtr,			interp, 1);
+    OP44(		STR_RANGE_IMM, idx1, idx2);
+    return TCL_OK;
+
+    /*
+     * Push the operands onto the stack and then the substring operation.
+     */    
+
+  nonConstantIndices:
+    CompileWord(envPtr, stringTokenPtr,			interp, 1);
+    CompileWord(envPtr, fromTokenPtr,			interp, 2);
+    CompileWord(envPtr, toTokenPtr,			interp, 3);
+    OP(			STR_RANGE);
     return TCL_OK;
 }
 
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 475a85e..2c87b34 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -453,8 +453,15 @@ InstructionDesc const tclInstructionTable[] = {
 	/* Find the first index of a needle string in a haystack string,
 	 * producing the index (integer) or -1 if nothing found.
 	 * Stack:  ... needle haystack => ... index */
+    {"strrfind",	 1,    -1,	  0,	{OPERAND_NONE}},
+	/* Find the last index of a needle string in a haystack string,
+	 * producing the index (integer) or -1 if nothing found.
+	 * Stack:  ... needle haystack => ... index */
     {"strrangeImm",	 9,	0,	  2,	{OPERAND_IDX4, OPERAND_IDX4}},
 	/* String Range: push (string range stktop op4 op4) */
+    {"strrange",	 1,    -2,	  0,	{OPERAND_NONE}},
+	/* String Range with non-constant arguments.
+	 * Stack:  ... string idxA idxB => ... substring */
 
     {"yield",		 1,	0,	  0,	{OPERAND_NONE}},
 	/* Makes the current coroutine yield the value at the top of the
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 3db3a78..b080d33 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -686,25 +686,27 @@ typedef struct ByteCode {
 /* For [string map] and [regsub] compilation */
 #define INST_STR_MAP			143
 #define INST_STR_FIND			144
-#define INST_STR_RANGE_IMM		145
+#define INST_STR_FIND_LAST		145
+#define INST_STR_RANGE_IMM		146
+#define INST_STR_RANGE			147
 
 /* For operations to do with coroutines and other NRE-manipulators */
-#define INST_YIELD			146
-#define INST_COROUTINE_NAME		147
-#define INST_TAILCALL			148
+#define INST_YIELD			148
+#define INST_COROUTINE_NAME		149
+#define INST_TAILCALL			150
 
 /* For compilation of basic information operations */
-#define INST_NS_CURRENT			149
-#define INST_INFO_LEVEL_NUM		150
-#define INST_INFO_LEVEL_ARGS		151
-#define INST_RESOLVE_COMMAND		152
-#define INST_TCLOO_SELF			153
-#define INST_TCLOO_CLASS		154
-#define INST_TCLOO_NS			155
-#define INST_TCLOO_IS_OBJECT		156
+#define INST_NS_CURRENT			151
+#define INST_INFO_LEVEL_NUM		152
+#define INST_INFO_LEVEL_ARGS		153
+#define INST_RESOLVE_COMMAND		154
+#define INST_TCLOO_SELF			155
+#define INST_TCLOO_CLASS		156
+#define INST_TCLOO_NS			157
+#define INST_TCLOO_IS_OBJECT		158
 
 /* The last opcode */
-#define LAST_INST_OPCODE		156
+#define LAST_INST_OPCODE		158
 
 /*
  * Table describing the Tcl bytecode instructions: their name (for displaying
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index ad79482..2b29d5c 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -4814,12 +4814,37 @@ TEBCresume(
 		O2S(objResultPtr)));
 	NEXT_INST_F(1, 2, 1);
 
+    case INST_STR_RANGE:
+	TRACE(("\"%.20s\" %s %s =>",
+		O2S(OBJ_AT_DEPTH(2)), O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS)));
+	length = Tcl_GetCharLength(OBJ_AT_DEPTH(2)) - 1;
+	if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, length,
+		    &fromIdx) != TCL_OK
+	    || TclGetIntForIndexM(interp, OBJ_AT_TOS, length,
+		    &toIdx) != TCL_OK) {
+	    goto gotError;
+	}
+
+	if (fromIdx < 0) {
+	    fromIdx = 0;
+	}
+	if (toIdx >= length) {
+	    toIdx = length;
+	}
+	if (toIdx >= fromIdx) {
+	    objResultPtr = Tcl_GetRange(OBJ_AT_DEPTH(2), fromIdx, toIdx);
+	} else {
+	    TclNewObj(objResultPtr);
+	}
+	TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
+	NEXT_INST_V(1, 3, 1);
+
     case INST_STR_RANGE_IMM:
 	valuePtr = OBJ_AT_TOS;
 	fromIdx = TclGetInt4AtPtr(pc+1);
 	toIdx = TclGetInt4AtPtr(pc+5);
 	length = Tcl_GetCharLength(valuePtr);
-	TRACE(("\"%.20s\" %d %d", O2S(valuePtr), fromIdx, toIdx));
+	TRACE(("\"%.20s\" %d %d => ", O2S(valuePtr), fromIdx, toIdx));
 
 	/*
 	 * Adjust indices for end-based indexing.
@@ -4939,6 +4964,27 @@ TEBCresume(
 
 	TclNewIntObj(objResultPtr, match);
 	NEXT_INST_F(1, 2, 1);
+
+    case INST_STR_FIND_LAST:
+	ustring1 = Tcl_GetUnicodeFromObj(OBJ_AT_TOS, &length);	/* Haystack */
+	ustring2 = Tcl_GetUnicodeFromObj(OBJ_UNDER_TOS, &length2);/* Needle */
+
+	match = -1;
+	if (length2 > 0 && length2 <= length) {
+	    for (p=ustring1+length-length2 ; p>=ustring1 ; p--) {
+		if ((*p == *ustring2) &&
+			memcmp(ustring2,p,sizeof(Tcl_UniChar)*length2) == 0) {
+		    match = p - ustring1;
+		    break;
+		}
+	    }
+	}
+
+	TRACE(("%.20s %.20s => %d\n",
+		O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match));
+
+	TclNewIntObj(objResultPtr, match);
+	NEXT_INST_F(1, 2, 1);
     }
 
     case INST_STR_MATCH:
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 48297b9..7dc21c1 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3620,6 +3620,12 @@ MODULE_SCOPE int	TclCompileNamespaceCodeCmd(Tcl_Interp *interp,
 MODULE_SCOPE int	TclCompileNamespaceCurrentCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
+MODULE_SCOPE int	TclCompileNamespaceQualifiersCmd(Tcl_Interp *interp,
+			    Tcl_Parse *parsePtr, Command *cmdPtr,
+			    struct CompileEnv *envPtr);
+MODULE_SCOPE int	TclCompileNamespaceTailCmd(Tcl_Interp *interp,
+			    Tcl_Parse *parsePtr, Command *cmdPtr,
+			    struct CompileEnv *envPtr);
 MODULE_SCOPE int	TclCompileNamespaceUpvarCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
@@ -3656,6 +3662,9 @@ MODULE_SCOPE int	TclCompileStringFirstCmd(Tcl_Interp *interp,
 MODULE_SCOPE int	TclCompileStringIndexCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
+MODULE_SCOPE int	TclCompileStringLastCmd(Tcl_Interp *interp,
+			    Tcl_Parse *parsePtr, Command *cmdPtr,
+			    struct CompileEnv *envPtr);
 MODULE_SCOPE int	TclCompileStringLenCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 60c40d0..02d517f 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -160,25 +160,25 @@ static const Tcl_ObjType nsNameType = {
  */
 
 static const EnsembleImplMap defaultNamespaceMap[] = {
-    {"children",	NamespaceChildrenCmd, NULL, NULL, NULL, 0},
-    {"code",		NamespaceCodeCmd,	TclCompileNamespaceCodeCmd, NULL, NULL, 0},
-    {"current",		NamespaceCurrentCmd,	TclCompileNamespaceCurrentCmd, NULL, NULL, 0},
-    {"delete",		NamespaceDeleteCmd, NULL, NULL, NULL, 0},
-    {"ensemble",	TclNamespaceEnsembleCmd, NULL, NULL, NULL, 0},
-    {"eval",		NamespaceEvalCmd,	NULL, NRNamespaceEvalCmd, NULL, 0},
-    {"exists",		NamespaceExistsCmd, NULL, NULL, NULL, 0},
-    {"export",		NamespaceExportCmd, NULL, NULL, NULL, 0},
-    {"forget",		NamespaceForgetCmd, NULL, NULL, NULL, 0},
-    {"import",		NamespaceImportCmd, NULL, NULL, NULL, 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},
-    {"qualifiers",	NamespaceQualifiersCmd, NULL, NULL, NULL, 0},
-    {"tail",		NamespaceTailCmd, NULL, NULL, NULL, 0},
-    {"unknown",		NamespaceUnknownCmd, NULL, NULL, NULL, 0},
-    {"upvar",		NamespaceUpvarCmd,	TclCompileNamespaceUpvarCmd, NULL, NULL, 0},
-    {"which",		NamespaceWhichCmd,	TclCompileNamespaceWhichCmd, NULL, NULL, 0},
+    {"children",   NamespaceChildrenCmd, NULL, NULL, NULL, 0},
+    {"code",	   NamespaceCodeCmd,	TclCompileNamespaceCodeCmd, NULL, NULL, 0},
+    {"current",	   NamespaceCurrentCmd,	TclCompileNamespaceCurrentCmd, NULL, NULL, 0},
+    {"delete",	   NamespaceDeleteCmd,	NULL, NULL, NULL, 0},
+    {"ensemble",   TclNamespaceEnsembleCmd, NULL, NULL, NULL, 0},
+    {"eval",	   NamespaceEvalCmd,	NULL, NRNamespaceEvalCmd, NULL, 0},
+    {"exists",	   NamespaceExistsCmd,	NULL, NULL, NULL, 0},
+    {"export",	   NamespaceExportCmd,	NULL, NULL, NULL, 0},
+    {"forget",	   NamespaceForgetCmd,	NULL, NULL, NULL, 0},
+    {"import",	   NamespaceImportCmd,	NULL, NULL, NULL, 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},
+    {"qualifiers", NamespaceQualifiersCmd, TclCompileNamespaceQualifiersCmd, NULL, NULL, 0},
+    {"tail",	   NamespaceTailCmd,	TclCompileNamespaceTailCmd, NULL, NULL, 0},
+    {"unknown",	   NamespaceUnknownCmd, NULL, NULL, NULL, 0},
+    {"upvar",	   NamespaceUpvarCmd,	TclCompileNamespaceUpvarCmd, NULL, NULL, 0},
+    {"which",	   NamespaceWhichCmd,	TclCompileNamespaceWhichCmd, NULL, NULL, 0},
     {NULL, NULL, NULL, NULL, NULL, 0}
 };
 
-- 
cgit v0.12


From ac3ebfbd4945bfd6a6ebe8d15016170e9b11b70c Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Mon, 5 Nov 2012 14:34:36 +0000
Subject: Added compilation of [array exists], [array set] and [array unset].
 Fixed a whole bunch of issues with opcode issuing that were causing problems
 with stack depth calculations.

---
 generic/tclAssembly.c   |   4 +
 generic/tclCompCmds.c   | 279 ++++++++++++++++++++++++++++++++++++++++++++----
 generic/tclCompCmdsSZ.c |  19 +++-
 generic/tclCompile.c    |  48 ++++++++-
 generic/tclCompile.h    |   8 +-
 generic/tclExecute.c    | 114 ++++++++++++++++++--
 generic/tclInt.h        |   9 ++
 generic/tclVar.c        |   6 +-
 8 files changed, 451 insertions(+), 36 deletions(-)

diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 3b02ca2..7833105 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -362,6 +362,10 @@ static const TalInstDesc TalInstructionTable[] = {
 					 | INST_APPEND_ARRAY4),	2,	1},
     {"appendArrayStk",	ASSEM_1BYTE,	INST_APPEND_ARRAY_STK,	3,	1},
     {"appendStk",	ASSEM_1BYTE,	INST_APPEND_STK,	2,	1},
+    {"arrayExistsImm",	ASSEM_LVT4,	INST_ARRAY_EXISTS_IMM,	0,	1},
+    {"arrayExistsStk",	ASSEM_1BYTE,	INST_ARRAY_EXISTS_STK,	1,	1},
+    {"arrayMakeImm",	ASSEM_LVT4,	INST_ARRAY_MAKE_IMM,	0,	0},
+    {"arrayMakeStk",	ASSEM_1BYTE,	INST_ARRAY_MAKE_STK,	1,	0},
     {"beginCatch",	ASSEM_BEGIN_CATCH,
 					INST_BEGIN_CATCH4,	0,	0},
     {"bitand",		ASSEM_1BYTE,	INST_BITAND,		2,	1},
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 463e82c..160fa3c 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -15,6 +15,7 @@
 
 #include "tclInt.h"
 #include "tclCompile.h"
+#include <assert.h>
 
 /*
  * Prototypes for procedures defined later in this file:
@@ -225,6 +226,245 @@ TclCompileAppendCmd(
 /*
  *----------------------------------------------------------------------
  *
+ * TclCompileArray*Cmd --
+ *
+ *	Functions called to compile "array" sucommands.
+ *
+ * Results:
+ *	All return TCL_OK for a successful compile, and TCL_ERROR to defer
+ *	evaluation to runtime.
+ *
+ * Side effects:
+ *	Instructions are added to envPtr to execute the "array" subcommand at
+ *	runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileArrayExistsCmd(
+    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 simpleVarName, isScalar, localIndex;
+
+    if (parsePtr->numWords != 2) {
+	return TCL_ERROR;
+    }
+
+    tokenPtr = TokenAfter(parsePtr->tokenPtr);
+    PushVarNameWord(interp, tokenPtr, envPtr, 0,
+	    &localIndex, &simpleVarName, &isScalar, 1);
+    if (!isScalar) {
+	return TCL_ERROR;
+    }
+
+    if (localIndex >= 0) {
+	TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex,	envPtr);
+    } else {
+	TclEmitOpcode(	INST_ARRAY_EXISTS_STK,			envPtr);
+    }
+    return TCL_OK;
+}
+
+int
+TclCompileArraySetCmd(
+    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 simpleVarName, isScalar, localIndex;
+    int dataVar, iterVar, keyVar, valVar, infoIndex;
+    int back, fwd, offsetBack, offsetFwd, savedStackDepth;
+    ForeachInfo *infoPtr;
+
+    if (parsePtr->numWords != 3) {
+	return TCL_ERROR;
+    }
+
+    tokenPtr = TokenAfter(parsePtr->tokenPtr);
+    PushVarNameWord(interp, tokenPtr, envPtr, 0,
+	    &localIndex, &simpleVarName, &isScalar, 1);
+    if (!isScalar) {
+	return TCL_ERROR;
+    }
+    tokenPtr = TokenAfter(tokenPtr);
+
+    /*
+     * Special case: literal empty value argument is just an "ensure array"
+     * operation.
+     */
+
+    if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD && tokenPtr[1].size == 0) {
+	if (localIndex >= 0) {
+	    TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex,	envPtr);
+	    TclEmitInstInt1(INST_JUMP_TRUE1, 7,			envPtr);
+	    TclEmitInstInt4(INST_ARRAY_MAKE_IMM, localIndex,	envPtr);
+	} else {
+	    TclEmitOpcode(  INST_DUP,				envPtr);
+	    TclEmitOpcode(  INST_ARRAY_EXISTS_STK,		envPtr);
+	    TclEmitInstInt1(INST_JUMP_TRUE1, 5,			envPtr);
+	    savedStackDepth = envPtr->currStackDepth;
+	    TclEmitOpcode(  INST_ARRAY_MAKE_STK,		envPtr);
+	    TclEmitInstInt1(INST_JUMP1, 3,			envPtr);
+	    envPtr->currStackDepth = savedStackDepth;
+	    TclEmitOpcode(  INST_POP,				envPtr);
+	}
+	PushLiteral(envPtr, "", 0);
+	return TCL_OK;
+    }
+
+    /*
+     * Prepare for the internal foreach.
+     */
+
+    if (envPtr->procPtr == NULL) {
+	return TCL_ERROR;
+    }
+    dataVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+    iterVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+    keyVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+    valVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+
+    infoPtr = ckalloc(sizeof(ForeachInfo) + sizeof(ForeachVarList *));
+    infoPtr->numLists = 1;
+    infoPtr->firstValueTemp = dataVar;
+    infoPtr->loopCtTemp = iterVar;
+    infoPtr->varLists[0] = ckalloc(sizeof(ForeachVarList) * 2*sizeof(int));
+    infoPtr->varLists[0]->numVars = 2;
+    infoPtr->varLists[0]->varIndexes[0] = keyVar;
+    infoPtr->varLists[0]->varIndexes[1] = valVar;
+    infoIndex = TclCreateAuxData(infoPtr, &tclForeachInfoType, envPtr);
+
+    /*
+     * Start issuing instructions to write to the array.
+     */
+
+    CompileWord(envPtr, tokenPtr, interp, 2);
+    TclEmitOpcode(	INST_DUP,				envPtr);
+    TclEmitOpcode(	INST_LIST_LENGTH,			envPtr);
+    PushLiteral(envPtr, "1", 1);
+    TclEmitOpcode(	INST_BITAND,				envPtr);
+    offsetFwd = CurrentOffset(envPtr);
+    TclEmitInstInt1(	INST_JUMP_FALSE1, 0,			envPtr);
+    savedStackDepth = envPtr->currStackDepth;
+    PushLiteral(envPtr, "list must have an even number of elements",
+	    strlen("list must have an even number of elements"));
+    PushLiteral(envPtr, "-errorCode {TCL ARGUMENT FORMAT}",
+	    strlen("-errorCode {TCL ARGUMENT FORMAT}"));
+    TclEmitInstInt4(	INST_RETURN_IMM, 1,			envPtr);
+    TclEmitInt4(		0,				envPtr);
+    envPtr->currStackDepth = savedStackDepth;
+    fwd = CurrentOffset(envPtr) - offsetFwd;
+    TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1);
+    Emit14Inst(		INST_STORE_SCALAR, dataVar,		envPtr);
+    TclEmitOpcode(	INST_POP,				envPtr);
+
+    if (localIndex >= 0) {
+	TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex,	envPtr);
+	TclEmitInstInt1(INST_JUMP_TRUE1, 7,			envPtr);
+	TclEmitInstInt4(INST_ARRAY_MAKE_IMM, localIndex,	envPtr);
+	TclEmitInstInt4(INST_FOREACH_START4, infoIndex,		envPtr);
+	offsetBack = CurrentOffset(envPtr);
+	TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex,		envPtr);
+	offsetFwd = CurrentOffset(envPtr);
+	TclEmitInstInt1(INST_JUMP_FALSE1, 0,			envPtr);
+	savedStackDepth = envPtr->currStackDepth;
+	Emit14Inst(	INST_LOAD_SCALAR, keyVar,		envPtr);
+	Emit14Inst(	INST_LOAD_SCALAR, valVar,		envPtr);
+	Emit14Inst(	INST_STORE_ARRAY, localIndex,		envPtr);
+	TclEmitOpcode(	INST_POP,				envPtr);
+	back = offsetBack - CurrentOffset(envPtr);
+	TclEmitInstInt1(INST_JUMP1, back,			envPtr);
+	fwd = CurrentOffset(envPtr) - offsetFwd;
+	TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1);
+	envPtr->currStackDepth = savedStackDepth;
+    } else {
+	TclEmitOpcode(	INST_DUP,				envPtr);
+	TclEmitOpcode(	INST_ARRAY_EXISTS_STK,			envPtr);
+	TclEmitInstInt1(INST_JUMP_TRUE1, 4,			envPtr);
+	TclEmitOpcode(	INST_DUP,				envPtr);
+	TclEmitOpcode(	INST_ARRAY_MAKE_STK,			envPtr);
+	TclEmitInstInt4(INST_FOREACH_START4, infoIndex,		envPtr);
+	offsetBack = CurrentOffset(envPtr);
+	TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex,		envPtr);
+	offsetFwd = CurrentOffset(envPtr);
+	TclEmitInstInt1(INST_JUMP_FALSE1, 0,			envPtr);
+	savedStackDepth = envPtr->currStackDepth;
+	TclEmitOpcode(	INST_DUP,				envPtr);
+	Emit14Inst(	INST_LOAD_SCALAR, keyVar,		envPtr);
+	Emit14Inst(	INST_LOAD_SCALAR, valVar,		envPtr);
+	TclEmitOpcode(	INST_STORE_ARRAY_STK,			envPtr);
+	TclEmitOpcode(	INST_POP,				envPtr);
+	back = offsetBack - CurrentOffset(envPtr);
+	TclEmitInstInt1(INST_JUMP1, back,			envPtr);
+	fwd = CurrentOffset(envPtr) - offsetFwd;
+	TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1);
+	envPtr->currStackDepth = savedStackDepth;
+	TclEmitOpcode(	INST_POP,				envPtr);
+    }
+    TclEmitInstInt1(	INST_UNSET_SCALAR, 0,			envPtr);
+    TclEmitInt4(		dataVar,			envPtr);
+    PushLiteral(envPtr,	"", 0);
+    return TCL_OK;
+}
+
+int
+TclCompileArrayUnsetCmd(
+    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 = TokenAfter(parsePtr->tokenPtr);
+    int simpleVarName, isScalar, localIndex, savedStackDepth;
+
+    if (parsePtr->numWords != 2) {
+	return TCL_ERROR;
+    }
+
+    PushVarNameWord(interp, tokenPtr, envPtr, 0,
+	    &localIndex, &simpleVarName, &isScalar, 1);
+    if (!isScalar) {
+	return TCL_ERROR;
+    }
+
+    if (localIndex >= 0) {
+	TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex,	envPtr);
+	TclEmitInstInt1(INST_JUMP_FALSE1, 8,			envPtr);
+	TclEmitInstInt1(INST_UNSET_SCALAR, 1,			envPtr);
+	TclEmitInt4(		localIndex,			envPtr);
+    } else {
+	TclEmitOpcode(	INST_DUP,				envPtr);
+	TclEmitOpcode(	INST_ARRAY_EXISTS_STK,			envPtr);
+	TclEmitInstInt1(INST_JUMP_FALSE1, 6,			envPtr);
+	savedStackDepth = envPtr->currStackDepth;
+	TclEmitInstInt1(INST_UNSET_STK, 1,			envPtr);
+	TclEmitInstInt1(INST_JUMP1, 3,				envPtr);
+	envPtr->currStackDepth = savedStackDepth;
+	TclEmitOpcode(	INST_POP,				envPtr);
+    }
+    PushLiteral(envPtr,	"", 0);
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * TclCompileBreakCmd --
  *
  *	Procedure called to compile the "break" command.
@@ -258,6 +498,7 @@ TclCompileBreakCmd(
      */
 
     TclEmitOpcode(INST_BREAK, envPtr);
+    PushLiteral(envPtr, "", 0);	/* Evil hack! */
     return TCL_OK;
 }
 
@@ -564,6 +805,7 @@ TclCompileContinueCmd(
      */
 
     TclEmitOpcode(INST_CONTINUE, envPtr);
+    PushLiteral(envPtr, "", 0);	/* Evil hack! */
     return TCL_OK;
 }
 
@@ -582,26 +824,6 @@ TclCompileContinueCmd(
  *	Instructions are added to envPtr to execute the "dict" subcommand at
  *	runtime.
  *
- * Notes:
- *	The following commands are in fairly common use and are possibly worth
- *	bytecoding:
- *		dict append
- *		dict create	[*]
- *		dict exists	[*]
- *		dict for
- *		dict get	[*]
- *		dict incr
- *		dict keys	[*]
- *		dict lappend
- *		dict map
- *		dict set
- *		dict unset
- *
- *	In practice, those that are pure-value operators (marked with [*]) can
- *	probably be left alone (except perhaps [dict get] which is very very
- *	common) and [dict update] should be considered instead (really big
- *	win!)
- *
  *----------------------------------------------------------------------
  */
 
@@ -666,6 +888,7 @@ TclCompileDictSetCmd(
 
     TclEmitInstInt4( INST_DICT_SET, numWords-2,		envPtr);
     TclEmitInt4(     dictVarIndex,			envPtr);
+    TclAdjustStackDepth(-1, envPtr);
     return TCL_OK;
 }
 
@@ -783,6 +1006,7 @@ TclCompileDictGetCmd(
 	tokenPtr = TokenAfter(tokenPtr);
     }
     TclEmitInstInt4(INST_DICT_GET, numWords-1, envPtr);
+    TclAdjustStackDepth(-1, envPtr);
     return TCL_OK;
 }
 
@@ -819,6 +1043,7 @@ TclCompileDictExistsCmd(
 	tokenPtr = TokenAfter(tokenPtr);
     }
     TclEmitInstInt4(INST_DICT_EXISTS, numWords-1, envPtr);
+    TclAdjustStackDepth(-1, envPtr);
     return TCL_OK;
 }
 
@@ -879,7 +1104,7 @@ TclCompileDictUnsetCmd(
      */
 
     TclEmitInstInt4( INST_DICT_UNSET, parsePtr->numWords-2,	envPtr);
-    TclEmitInt4(     dictVarIndex,				envPtr);
+    TclEmitInt4(	dictVarIndex,				envPtr);
     return TCL_OK;
 }
 
@@ -967,6 +1192,7 @@ TclCompileDictCreateCmd(
 	tokenPtr = TokenAfter(tokenPtr);
 	TclEmitInstInt4(	INST_DICT_SET, 1,		envPtr);
 	TclEmitInt4(			worker,			envPtr);
+	TclAdjustStackDepth(-1, envPtr);
 	TclEmitOpcode(		INST_POP,			envPtr);
     }
     Emit14Inst(			INST_LOAD_SCALAR, worker,	envPtr);
@@ -1048,6 +1274,7 @@ TclCompileDictMergeCmd(
 	TclEmitInstInt4(	INST_REVERSE, 2,		envPtr);
 	TclEmitInstInt4(	INST_DICT_SET, 1,		envPtr);
 	TclEmitInt4(			workerIndex,		envPtr);
+	TclAdjustStackDepth(-1, envPtr);
 	TclEmitOpcode(		INST_POP,			envPtr);
 	TclEmitInstInt4(	INST_DICT_NEXT, infoIndex,	envPtr);
 	TclEmitInstInt1(	INST_JUMP_FALSE1, -20,		envPtr);
@@ -1275,6 +1502,7 @@ CompileDictEachCmd(
 	TclEmitInstInt4(INST_OVER, 1,				envPtr);
 	TclEmitInstInt4(INST_DICT_SET, 1,			envPtr);
 	TclEmitInt4(		collectVar,			envPtr);
+	TclAdjustStackDepth(-1, envPtr);
 	TclEmitOpcode(	INST_POP,				envPtr);
     }
     TclEmitOpcode(	INST_POP,				envPtr);
@@ -1337,7 +1565,7 @@ CompileDictEachCmd(
      * easy!) Note that we skip the END_CATCH. [Bug 1382528]
      */
 
-    envPtr->currStackDepth = savedStackDepth+2;
+    envPtr->currStackDepth = savedStackDepth + 2;
     jumpDisplacement = CurrentOffset(envPtr) - emptyTargetOffset;
     TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDisplacement,
 	    envPtr->codeStart + emptyTargetOffset);
@@ -1533,6 +1761,7 @@ TclCompileDictUpdateCmd(
 		(int) (CurrentOffset(envPtr) - jumpFixup.codeOffset));
     }
     TclStackFree(interp, keyTokenPtrs);
+    envPtr->currStackDepth = savedStackDepth + 1;
     return TCL_OK;
 }
 
@@ -1781,6 +2010,7 @@ TclCompileDictWithCmd(
 		PushLiteral(envPtr, "", 0);
 	    }
 	}
+	envPtr->currStackDepth = savedStackDepth + 1;
 	return TCL_OK;
     }
 
@@ -1899,6 +2129,7 @@ TclCompileDictWithCmd(
      * Prepare for the start of the next command.
      */
 
+    envPtr->currStackDepth = savedStackDepth + 1;
     if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) {
 	Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d",
 		(int) (CurrentOffset(envPtr) - jumpFixup.codeOffset));
@@ -1998,6 +2229,7 @@ TclCompileErrorCmd(
      * However, we only deal with the case where there is just a message.
      */
     Tcl_Token *messageTokenPtr;
+    int savedStackDepth = envPtr->currStackDepth;
     DefineLineInformation;	/* TIP #280 */
 
     if (parsePtr->numWords != 2) {
@@ -2008,6 +2240,7 @@ TclCompileErrorCmd(
     PushLiteral(envPtr, "-code error -level 0", 20);
     CompileWord(envPtr, messageTokenPtr, interp, 1);
     TclEmitOpcode(INST_RETURN_STK, envPtr);
+    envPtr->currStackDepth = savedStackDepth + 1;
     return TCL_OK;
 }
 
@@ -5238,6 +5471,7 @@ TclCompileReturnCmd(
     int numWords = parsePtr->numWords;
     int explicitResult = (0 == (numWords % 2));
     int numOptionWords = numWords - 1 - explicitResult;
+    int savedStackDepth = envPtr->currStackDepth;
     Tcl_Obj *returnOpts, **objv;
     Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr);
     DefineLineInformation;	/* TIP #280 */
@@ -5260,6 +5494,7 @@ TclCompileReturnCmd(
 	CompileWord(envPtr, optsTokenPtr, interp, 2);
 	CompileWord(envPtr, msgTokenPtr,  interp, 3);
 	TclEmitOpcode(INST_RETURN_STK, envPtr);
+	envPtr->currStackDepth = savedStackDepth + 1;
 	return TCL_OK;
     }
 
diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index 090f996..be63e0e 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -995,6 +995,7 @@ TclSubstCompile(
     if (state != NULL) {
 	Tcl_RestoreInterpState(interp, state);
 	TclCompileSyntaxError(interp, envPtr);
+	TclAdjustStackDepth(-1, envPtr);
     }
 
     /* Final target of the multi-jump from all BREAKs */
@@ -1639,6 +1640,7 @@ IssueSwitchJumpTable(
     int **bodyContLines)	/* Array of continuation line info. */
 {
     JumptableInfo *jtPtr;
+    int savedStackDepth = envPtr->currStackDepth;
     int infoIndex, isNew, *finalFixups, numRealBodies = 0, jumpLocation;
     int mustGenerate, foundDefault, jumpToDefault, i;
     Tcl_DString buffer;
@@ -1751,6 +1753,7 @@ IssueSwitchJumpTable(
 	 * Compile the body of the arm.
 	 */
 
+	envPtr->currStackDepth = savedStackDepth;
 	envPtr->line = bodyLines[i+1];		/* TIP #280 */
 	envPtr->clNext = bodyContLines[i+1];	/* TIP #280 */
 	TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr);
@@ -1782,6 +1785,7 @@ IssueSwitchJumpTable(
      */
 
     if (!foundDefault) {
+	envPtr->currStackDepth = savedStackDepth;
 	TclStoreInt4AtPtr(CurrentOffset(envPtr)-jumpToDefault,
 		envPtr->codeStart+jumpToDefault+1);
 	PushLiteral(envPtr, "", 0);
@@ -1802,6 +1806,7 @@ IssueSwitchJumpTable(
      */
 
     TclStackFree(interp, finalFixups);
+    envPtr->currStackDepth = savedStackDepth + 1;
 }
 
 /*
@@ -1957,6 +1962,7 @@ TclCompileThrowCmd(
 {
     DefineLineInformation;	/* TIP #280 */
     int numWords = parsePtr->numWords;
+    int savedStackDepth = envPtr->currStackDepth;
     Tcl_Token *codeToken, *msgToken;
     Tcl_Obj *objPtr;
 
@@ -1987,6 +1993,7 @@ TclCompileThrowCmd(
 	    CompileWord(envPtr, msgToken, interp, 2);
 	    TclCompileSyntaxError(interp, envPtr);
 	    Tcl_DecrRefCount(objPtr);
+	    envPtr->currStackDepth = savedStackDepth + 1;
 	    return TCL_OK;
 	}
 	if (len == 0) {
@@ -2007,6 +2014,7 @@ TclCompileThrowCmd(
 	PushLiteral(envPtr, string, len);
 	TclDecrRefCount(dictPtr);
 	OP44(				RETURN_IMM, 1, 0);
+	envPtr->currStackDepth = savedStackDepth + 1;
     } else {
 	/*
 	 * When the code token is not known at compilation time, we need to do
@@ -2035,6 +2043,7 @@ TclCompileThrowCmd(
 	PUSH(				"");
 	OP44(				RETURN_IMM, 1, 0);
     }
+    envPtr->currStackDepth = savedStackDepth + 1;
     TclDecrRefCount(objPtr);
     return TCL_OK;
 }
@@ -2302,6 +2311,7 @@ IssueTryInstructions(
 {
     DefineLineInformation;	/* TIP #280 */
     int range, resultVar, optionsVar;
+    int savedStackDepth = envPtr->currStackDepth;
     int i, j, len, forwardsNeedFixing = 0;
     int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource;
     char buf[TCL_INTEGER_SPACE];
@@ -2363,6 +2373,7 @@ IssueTryInstructions(
 	    LOAD(			optionsVar);
 	    PUSH(			"-errorcode");
 	    OP4(			DICT_GET, 1);
+	    TclAdjustStackDepth(-1, envPtr);
 	    OP44(			LIST_RANGE_IMM, 0, len-1);
 	    PUSH(			TclGetString(matchClauses[i]));
 	    OP(				STR_EQ);
@@ -2403,6 +2414,7 @@ IssueTryInstructions(
 		    forwardsToFix[j] = -1;
 		}
 	    }
+	    envPtr->currStackDepth = savedStackDepth;
 	    BODY(			handlerTokens[i], 5+i*4);
 	}
 
@@ -2434,6 +2446,7 @@ IssueTryInstructions(
     }
     TclStackFree(interp, forwardsToFix);
     TclStackFree(interp, addrsToFix);
+    envPtr->currStackDepth = savedStackDepth + 1;
     return TCL_OK;
 }
 
@@ -2470,6 +2483,7 @@ IssueTryFinallyInstructions(
     range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
     OP4(				BEGIN_CATCH4, range);
     ExceptionRangeStarts(envPtr, range);
+    envPtr->currStackDepth = savedStackDepth;
     BODY(				bodyToken, 1);
     ExceptionRangeEnds(envPtr, range);
     PUSH(				"0");
@@ -2514,6 +2528,7 @@ IssueTryFinallyInstructions(
 		LOAD(			optionsVar);
 		PUSH(			"-errorcode");
 		OP4(			DICT_GET, 1);
+		TclAdjustStackDepth(-1, envPtr);
 		OP44(			LIST_RANGE_IMM, 0, len-1);
 		PUSH(			TclGetString(matchClauses[i]));
 		OP(			STR_EQ);
@@ -2586,6 +2601,7 @@ IssueTryFinallyInstructions(
 		}
 		OP4(			BEGIN_CATCH4, range);
 	    }
+	    envPtr->currStackDepth = savedStackDepth;
 	    BODY(			handlerTokens[i], 5+i*4);
 	    ExceptionRangeEnds(envPtr, range);
 	    OP(				PUSH_RETURN_OPTIONS);
@@ -2637,7 +2653,6 @@ IssueTryFinallyInstructions(
      */
 
     OP(					POP);
-    envPtr->currStackDepth = savedStackDepth;
 
     /*
      * Process the finally clause (at last!) Note that we do not wrap this in
@@ -2647,11 +2662,13 @@ IssueTryFinallyInstructions(
      * next command (or some inter-command manipulation).
      */
 
+    envPtr->currStackDepth = savedStackDepth;
     BODY(				finallyToken, 3 + 4*numHandlers);
     OP(					POP);
     LOAD(				optionsVar);
     LOAD(				resultVar);
     OP(					RETURN_STK);
+    envPtr->currStackDepth = savedStackDepth + 1;
 
     return TCL_OK;
 }
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 2c87b34..309682d 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -372,13 +372,13 @@ InstructionDesc const tclInstructionTable[] = {
 	 * Stack:  ... value => ...
 	 * Note that the jump table contains offsets relative to the PC when
 	 * it points to this instruction; the code is relocatable. */
-    {"upvar",            5,     0,        1,   {OPERAND_LVT4}},
+    {"upvar",            5,    -1,        1,   {OPERAND_LVT4}},
 	/* finds level and otherName in stack, links to local variable at
 	 * index op1. Leaves the level on stack. */
-    {"nsupvar",          5,     0,        1,   {OPERAND_LVT4}},
+    {"nsupvar",          5,    -1,        1,   {OPERAND_LVT4}},
 	/* finds namespace and otherName in stack, links to local variable at
 	 * index op1. Leaves the namespace on stack. */
-    {"variable",         5,     0,        1,   {OPERAND_LVT4}},
+    {"variable",         5,    -1,        1,   {OPERAND_LVT4}},
 	/* finds namespace and otherName in stack, links to local variable at
 	 * index op1. Leaves the namespace on stack. */
     {"syntax",		 9,   -1,         2,	{OPERAND_INT4, OPERAND_UINT4}},
@@ -509,6 +509,26 @@ InstructionDesc const tclInstructionTable[] = {
 	 * context.
 	 * Stack:  ... value => ... boolean */
 
+    {"arrayExistsStk",	 1,	0,	  0,	{OPERAND_NONE}},
+	/* Looks up the element on the top of the stack and tests whether it
+	 * is an array. Pushes a boolean describing whether this is the
+	 * case. Also runs the whole-array trace on the named variable, so can
+	 * throw anything.
+	 * Stack:  ... varName => ... boolean */
+    {"arrayExistsImm",	 5,	+1,	  1,	{OPERAND_UINT4}},
+	/* Looks up the variable indexed by opnd and tests whether it is an
+	 * array. Pushes a boolean describing whether this is the case. Also
+	 * runs the whole-array trace on the named variable, so can throw
+	 * anything.
+	 * Stack:  ... => ... boolean */
+    {"arrayMakeStk",	 1,	-1,	  0,	{OPERAND_NONE}},
+	/* Forces the element on the top of the stack to be the name of an
+	 * array.
+	 * Stack:  ... varName => ... */
+    {"arrayMakeImm",	 5,	0,	  1,	{OPERAND_UINT4}},
+	/* Forces the variable indexed by opnd to be an array. Does not touch
+	 * the stack. */
+
     {NULL, 0, 0, 0, {OPERAND_NONE}}
 };
 
@@ -1751,6 +1771,9 @@ TclCompileScript(
 			unsigned savedCodeNext =
 				envPtr->codeNext - envPtr->codeStart;
 			int update = 0;
+#ifdef TCL_COMPILE_DEBUG
+			int startStackDepth = envPtr->currStackDepth;
+#endif
 
 			/*
 			 * Mark the start of the command; the proper bytecode
@@ -1794,6 +1817,25 @@ TclCompileScript(
 				envPtr);
 
 			if (code == TCL_OK) {
+			    /*
+			     * Confirm that the command compiler generated a
+			     * single value on the stack as its result. This
+			     * is only done in debugging mode, as it *should*
+			     * be correct and normal users have no reasonable
+			     * way to fix it anyway.
+			     */
+
+#ifdef TCL_COMPILE_DEBUG
+			    int diff = envPtr->currStackDepth-startStackDepth;
+
+			    if (diff != 1 && (diff != 0 ||
+				   *(envPtr->codeNext-1) != INST_DONE)) {
+				Tcl_Panic("bad stack adjustment when compiling"
+					" %.*s (was %d instead of 1)",
+					parsePtr->tokenPtr->size,
+					parsePtr->tokenPtr->start, diff);
+			    }
+#endif
 			    if (update) {
 				/*
 				 * Fix the bytecode length.
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index b080d33..3302f9b 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -705,8 +705,14 @@ typedef struct ByteCode {
 #define INST_TCLOO_NS			157
 #define INST_TCLOO_IS_OBJECT		158
 
+/* For compilation of [array] subcommands */
+#define INST_ARRAY_EXISTS_STK		159
+#define INST_ARRAY_EXISTS_IMM		160
+#define INST_ARRAY_MAKE_STK		161
+#define INST_ARRAY_MAKE_IMM		162
+
 /* The last opcode */
-#define LAST_INST_OPCODE		158
+#define LAST_INST_OPCODE		162
 
 /*
  * Table describing the Tcl bytecode instructions: their name (for displaying
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 2b29d5c..caf35ba 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -2389,14 +2389,18 @@ TEBCresume(
 	}
 
 #ifdef TCL_COMPILE_DEBUG
-	TRACE(("%d [", opnd));
-	for (i=opnd-1 ; i>=0 ; i++) {
-	    TRACE_APPEND(("\"%.30s\"", O2S(OBJ_AT_DEPTH(i))));
-	    if (i > 0) {
-		TRACE_APPEND((" "));
+	{
+	    register int i;
+
+	    TRACE(("%d [", opnd));
+	    for (i=opnd-1 ; i>=0 ; i++) {
+		TRACE_APPEND(("\"%.30s\"", O2S(OBJ_AT_DEPTH(i))));
+		if (i > 0) {
+		    TRACE_APPEND((" "));
+		}
 	    }
+	    TRACE_APPEND(("] => RETURN..."));
 	}
-	TRACE_APPEND(("] => RETURN..."));
 #endif
 
 	/*
@@ -3877,6 +3881,104 @@ TEBCresume(
     /*
      *	   End of INST_UNSET instructions.
      * -----------------------------------------------------------------
+     *	   Start of INST_ARRAY instructions.
+     */
+
+    case INST_ARRAY_EXISTS_IMM:
+	opnd = TclGetUInt4AtPtr(pc+1);
+	pcAdjustment = 5;
+	cleanup = 0;
+	part1Ptr = NULL;
+	arrayPtr = NULL;
+	TRACE(("%u => ", opnd));
+	varPtr = LOCAL(opnd);
+	while (TclIsVarLink(varPtr)) {
+	    varPtr = varPtr->value.linkPtr;
+	}
+	goto doArrayExists;
+    case INST_ARRAY_EXISTS_STK:
+	opnd = -1;
+	pcAdjustment = 1;
+	cleanup = 1;
+	part1Ptr = OBJ_AT_TOS;
+	TRACE(("\"%.30s\" => ", O2S(part1Ptr)));
+	varPtr = TclObjLookupVarEx(interp, part1Ptr, NULL, 0, NULL,
+		/*createPart1*/0, /*createPart2*/0, &arrayPtr);
+    doArrayExists:
+	if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY)
+		&& (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) {
+	    DECACHE_STACK_INFO();
+	    result = TclObjCallVarTraces(iPtr, arrayPtr, varPtr, part1Ptr,
+		    NULL, (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|
+		    TCL_GLOBAL_ONLY|TCL_TRACE_ARRAY), 1, opnd);
+	    CACHE_STACK_INFO();
+	    if (result == TCL_ERROR) {
+		TRACE_APPEND(("ERROR: %.30s\n",
+			O2S(Tcl_GetObjResult(interp))));
+		goto gotError;
+	    }
+	}
+	if (varPtr && TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) {
+	    objResultPtr = TCONST(1);
+	} else {
+	    objResultPtr = TCONST(0);
+	}
+	TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+	NEXT_INST_V(pcAdjustment, cleanup, 1);
+
+    case INST_ARRAY_MAKE_IMM:
+	opnd = TclGetUInt4AtPtr(pc+1);
+	pcAdjustment = 5;
+	cleanup = 0;
+	part1Ptr = NULL;
+	arrayPtr = NULL;
+	TRACE(("%u => ", opnd));
+	varPtr = LOCAL(opnd);
+	while (TclIsVarLink(varPtr)) {
+	    varPtr = varPtr->value.linkPtr;
+	}
+	goto doArrayMake;
+    case INST_ARRAY_MAKE_STK:
+	opnd = -1;
+	pcAdjustment = 1;
+	cleanup = 1;
+	part1Ptr = OBJ_AT_TOS;
+	TRACE(("\"%.30s\" => ", O2S(part1Ptr)));
+	varPtr = TclObjLookupVarEx(interp, part1Ptr, NULL, TCL_LEAVE_ERR_MSG,
+		"set", /*createPart1*/1, /*createPart2*/0, &arrayPtr);
+	if (varPtr == NULL) {
+	    TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
+	    goto gotError;
+	}
+    doArrayMake:
+	if (varPtr && !TclIsVarArray(varPtr)) {
+	    if (TclIsVarArrayElement(varPtr) || !TclIsVarUndefined(varPtr)) {
+		/*
+		 * Either an array element, or a scalar: lose!
+		 */
+
+		TclObjVarErrMsg(interp, part1Ptr, NULL, "array set",
+			"variable isn't array", opnd);
+		Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL);
+		TRACE_APPEND(("ERROR: bad array ref: %.30s\n",
+			O2S(Tcl_GetObjResult(interp))));
+		goto gotError;
+	    }
+	    TclSetVarArray(varPtr);
+	    varPtr->value.tablePtr = ckalloc(sizeof(TclVarHashTable));
+	    TclInitVarHashTable(varPtr->value.tablePtr,
+		    TclGetVarNsPtr(varPtr));
+#ifdef TCL_COMPILE_DEBUG
+	    TRACE_APPEND(("done\n"));
+	} else {
+	    TRACE_APPEND(("nothing to do\n"));
+#endif
+	}
+	NEXT_INST_V(pcAdjustment, cleanup, 0);
+
+    /*
+     *	   End of INST_ARRAY instructions.
+     * -----------------------------------------------------------------
      *	   Start of variable linking instructions.
      */
 
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 7dc21c1..1d04c82 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3491,6 +3491,15 @@ MODULE_SCOPE int	Tcl_WhileObjCmd(ClientData clientData,
 MODULE_SCOPE int	TclCompileAppendCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
+MODULE_SCOPE int	TclCompileArrayExistsCmd(Tcl_Interp *interp,
+			    Tcl_Parse *parsePtr, Command *cmdPtr,
+			    struct CompileEnv *envPtr);
+MODULE_SCOPE int	TclCompileArraySetCmd(Tcl_Interp *interp,
+			    Tcl_Parse *parsePtr, Command *cmdPtr,
+			    struct CompileEnv *envPtr);
+MODULE_SCOPE int	TclCompileArrayUnsetCmd(Tcl_Interp *interp,
+			    Tcl_Parse *parsePtr, Command *cmdPtr,
+			    struct CompileEnv *envPtr);
 MODULE_SCOPE int	TclCompileBreakCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
diff --git a/generic/tclVar.c b/generic/tclVar.c
index e31e9cf..1c01e41 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -4224,15 +4224,15 @@ TclInitArrayCmd(
     static const EnsembleImplMap arrayImplMap[] = {
 	{"anymore",	ArrayAnyMoreCmd,	NULL, NULL, NULL, 0},
 	{"donesearch",	ArrayDoneSearchCmd,	NULL, NULL, NULL, 0},
-	{"exists",	ArrayExistsCmd,		NULL, NULL, NULL, 0},
+	{"exists",	ArrayExistsCmd,		TclCompileArrayExistsCmd, NULL, NULL, 0},
 	{"get",		ArrayGetCmd,		NULL, NULL, NULL, 0},
 	{"names",	ArrayNamesCmd,		NULL, NULL, NULL, 0},
 	{"nextelement",	ArrayNextElementCmd,	NULL, NULL, NULL, 0},
-	{"set",		ArraySetCmd,		NULL, NULL, NULL, 0},
+	{"set",		ArraySetCmd,		TclCompileArraySetCmd, NULL, NULL, 0},
 	{"size",	ArraySizeCmd,		NULL, NULL, NULL, 0},
 	{"startsearch",	ArrayStartSearchCmd,	NULL, NULL, NULL, 0},
 	{"statistics",	ArrayStatsCmd,		NULL, NULL, NULL, 0},
-	{"unset",	ArrayUnsetCmd,		NULL, NULL, NULL, 0},
+	{"unset",	ArrayUnsetCmd,		TclCompileArrayUnsetCmd, NULL, NULL, 0},
 	{NULL, NULL, NULL, NULL, NULL, 0}
     };
 
-- 
cgit v0.12