From 72901fb88ca266a88a78b0a34c4db3b3c386e367 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Fri, 2 Nov 2012 16:50:06 +0000
Subject: Work on compilation of [string is]. Hit some problem edge cases with
 differences in strictness of edge cases that will force a rethink ([string is
 boolean] is significantly more strict than Tcl_GetBooleanFromObj).

---
 generic/tclCmdMZ.c      |   2 +-
 generic/tclCompCmdsSZ.c | 190 ++++++++++++++++++++++++++++++++++++++++++++++++
 generic/tclInt.h        |   3 +
 3 files changed, 194 insertions(+), 1 deletion(-)

diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index de32fce..0526325 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -3306,7 +3306,7 @@ TclInitStringCmd(
 	{"equal",	StringEqualCmd,	TclCompileStringEqualCmd, NULL, NULL, 0},
 	{"first",	StringFirstCmd,	TclCompileStringFirstCmd, NULL, NULL, 0},
 	{"index",	StringIndexCmd,	TclCompileStringIndexCmd, NULL, NULL, 0},
-	{"is",		StringIsCmd,	NULL, NULL, NULL, 0},
+	{"is",		StringIsCmd,	TclCompileStringIsCmd, NULL, NULL, 0},
 	{"last",	StringLastCmd,	NULL, NULL, NULL, 0},
 	{"length",	StringLenCmd,	TclCompileStringLenCmd, NULL, NULL, 0},
 	{"map",		StringMapCmd,	TclCompileStringMapCmd, NULL, NULL, 0},
diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index 57cb992..b9309ec 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -451,6 +451,196 @@ TclCompileStringIndexCmd(
 /*
  *----------------------------------------------------------------------
  *
+ * TclCompileStringIsCmd --
+ *
+ *	Procedure called to compile the simplest and most common form of the
+ *	"string is" 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 is" command at
+ *	runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileStringIsCmd(
+    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 = TokenAfter(parsePtr->tokenPtr);
+    int numWords = parsePtr->numWords;
+    enum IsType {
+	TypeBool, TypeBoolFalse, TypeBoolTrue,
+	TypeFloat,
+	TypeInteger, TypeNarrowInt, TypeWideInt,
+	TypeList /*, TypeDict */
+    };
+    enum IsType t;
+    JumpFixup jumpFixup;
+    int start, range;
+    int allowEmpty = 0;
+
+    if (numWords < 2 || tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+	return TCL_ERROR;
+    }
+#define GotLiteral(tokenPtr,word) \
+    ((tokenPtr)[1].size > 1 && (tokenPtr)[1].start[0] == word[0] &&	\
+	    strncmp((tokenPtr)[1].start, (word), (tokenPtr)[1].size) == 0)
+
+    if (GotLiteral(tokenPtr, "boolean")) {
+	t = TypeBool;
+    } else if (GotLiteral(tokenPtr, "double")) {
+	t = TypeFloat;
+    } else if (GotLiteral(tokenPtr, "entier")) {
+	t = TypeInteger;
+    } else if (GotLiteral(tokenPtr, "false")) {
+	t = TypeBoolFalse;
+    } else if (GotLiteral(tokenPtr, "integer")) {
+	t = TypeNarrowInt;
+	return TCL_ERROR; // Not yet implemented
+    } else if (GotLiteral(tokenPtr, "list")) {
+	t = TypeList;
+    } else if (GotLiteral(tokenPtr, "true")) {
+	t = TypeBoolTrue;
+    } else if (GotLiteral(tokenPtr, "wideinteger")) {
+	t = TypeWideInt;
+	return TCL_ERROR; // Not yet implemented
+    } else {
+	/*
+	 * We don't handle character class checks in bytecode currently.
+	 */
+
+	return TCL_ERROR;
+    }
+    if (numWords != 3 && numWords != 4) {
+	return TCL_ERROR;
+    }
+    tokenPtr = TokenAfter(tokenPtr);
+    if (numWords == 3) {
+	allowEmpty = (t != TypeList);
+    } else {
+	if (!GotLiteral(tokenPtr, "-strict")) {
+	    return TCL_ERROR;
+	}
+	tokenPtr = TokenAfter(tokenPtr);
+    }
+#undef GotLiteral
+
+    /*
+     * Push the word to check.
+     */
+
+    CompileWord(envPtr, tokenPtr, interp, numWords-1);
+
+    /*
+     * Next, do the type check. First, we push a catch range; most of the
+     * type-check operations throw an exception on failure.
+     */
+
+    range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
+    start = 0;
+    TclEmitInstInt4(	INST_BEGIN_CATCH4, range,	envPtr);
+    ExceptionRangeStarts(envPtr, range);
+
+    /*
+     * Issue the type-check itself for the specific type.
+     */
+
+    switch (t) {
+    case TypeBool:
+	TclEmitOpcode(		INST_DUP,			envPtr);
+	TclEmitOpcode(		INST_LNOT,			envPtr);
+	TclEmitOpcode(		INST_POP,			envPtr);
+	break;
+    case TypeBoolFalse:
+	TclEmitOpcode(		INST_DUP,			envPtr);
+	start = CurrentOffset(envPtr);
+	TclEmitInstInt1(	INST_JUMP_TRUE1, 0,		envPtr);
+	break;
+    case TypeBoolTrue:
+	TclEmitOpcode(		INST_DUP,			envPtr);
+	start = CurrentOffset(envPtr);
+	TclEmitInstInt1(	INST_JUMP_FALSE1, 0,		envPtr);
+	break;
+    case TypeFloat:
+	/*
+	 * Careful! Preserve behavior of NaN which is a double (that is, true
+	 * for the purposes of a type check) but most math ops fail on it. The
+	 * key is that it is not == to itself (and is the only value which
+	 * this is true for).
+	 */
+
+	TclEmitOpcode(		INST_DUP,			envPtr);
+	TclEmitOpcode(		INST_DUP,			envPtr);
+	TclEmitOpcode(		INST_NEQ,			envPtr);
+	TclEmitInstInt1(	INST_JUMP_TRUE1, 5,		envPtr);
+
+	/*
+	 * Type check for all other double values.
+	 */
+
+	TclEmitOpcode(		INST_DUP,			envPtr);
+	TclEmitOpcode(		INST_UMINUS,			envPtr);
+	TclEmitOpcode(		INST_POP,			envPtr);
+	break;
+    case TypeInteger:
+	TclEmitOpcode(		INST_DUP,			envPtr);
+	TclEmitOpcode(		INST_BITNOT,			envPtr);
+	TclEmitOpcode(		INST_POP,			envPtr);
+	break;
+    case TypeNarrowInt:
+	Tcl_Panic("not yet implemented");
+    case TypeWideInt:
+	Tcl_Panic("not yet implemented");
+    case TypeList:
+	TclEmitOpcode(		INST_DUP,			envPtr);
+	TclEmitOpcode(		INST_LIST_LENGTH,		envPtr);
+	TclEmitOpcode(		INST_POP,			envPtr);
+	break;
+    }
+
+    /*
+     * Based on whether the exception was thrown (or conditional branch taken,
+     * in the case of true/false checks), push the correct boolean value. This
+     * is also where we deal with what happens with empty values in non-strict
+     * mode.
+     */
+
+    ExceptionRangeEnds(envPtr, range);
+    TclEmitOpcode(		INST_END_CATCH,			envPtr);
+    TclEmitOpcode(		INST_POP,			envPtr);
+    PushLiteral(envPtr, "1", 1);
+    TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);
+    ExceptionRangeTarget(envPtr, range, catchOffset);
+    if (start != 0) {
+	TclStoreInt1AtPtr(CurrentOffset(envPtr) - start,
+		envPtr->codeStart + start + 1);
+    }
+    TclEmitOpcode(		INST_END_CATCH,			envPtr);
+    if (allowEmpty) {
+	PushLiteral(envPtr, "", 0);
+	TclEmitOpcode(		INST_STR_EQ,			envPtr);
+    } else {
+	TclEmitOpcode(		INST_POP,			envPtr);
+	PushLiteral(envPtr, "0", 1);
+    }
+    TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127);
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * TclCompileStringMatchCmd --
  *
  *	Procedure called to compile the simplest and most common form of the
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 1fffa1f..e513a6e 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3647,6 +3647,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	TclCompileStringIsCmd(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);
-- 
cgit v0.12


From c3ba561b42a9a5ebac6660b70f30f37c923e0551 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Thu, 2 Jan 2014 15:30:53 +0000
Subject: redevelop code to have more in common with the interpreted [string
 is] and to remove non-working types

---
 generic/tclCompCmdsSZ.c | 147 +++++++++++++++++++++++++-----------------------
 1 file changed, 78 insertions(+), 69 deletions(-)

diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index 440b5bf..06cca50 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -435,56 +435,59 @@ TclCompileStringIsCmd(
 {
     DefineLineInformation;	/* TIP #280 */
     Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
-    int numWords = parsePtr->numWords;
-    enum IsType {
-	TypeBool, TypeBoolFalse, TypeBoolTrue,
-	TypeFloat,
-	TypeInteger, TypeNarrowInt, TypeWideInt,
-	TypeList /*, TypeDict */
+    static const char *const isClasses[] = {
+	"alnum",	"alpha",	"ascii",	"control",
+	"boolean",	"digit",	"double",	"entier",
+	"false",	"graph",	"integer",	"list",
+	"lower",	"print",	"punct",	"space",
+	"true",		"upper",	"wideinteger",	"wordchar",
+	"xdigit",	NULL
+    };
+    enum isClasses {
+	STR_IS_ALNUM,	STR_IS_ALPHA,	STR_IS_ASCII,	STR_IS_CONTROL,
+	STR_IS_BOOL,	STR_IS_DIGIT,	STR_IS_DOUBLE,	STR_IS_ENTIER,
+	STR_IS_FALSE,	STR_IS_GRAPH,	STR_IS_INT,	STR_IS_LIST,
+	STR_IS_LOWER,	STR_IS_PRINT,	STR_IS_PUNCT,	STR_IS_SPACE,
+	STR_IS_TRUE,	STR_IS_UPPER,	STR_IS_WIDE,	STR_IS_WORD,
+	STR_IS_XDIGIT
     };
-    enum IsType t;
     JumpFixup jumpFixup;
-    int start, range;
-    int allowEmpty = 0;
+    int t, range, allowEmpty = 0;
+    Tcl_Obj *isClass;
 
-    if (numWords < 2 || tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+    if (parsePtr->numWords < 3 || parsePtr->numWords > 6) {
 	return TCL_ERROR;
     }
-#define GotLiteral(tokenPtr,word) \
-    ((tokenPtr)[1].size > 1 && (tokenPtr)[1].start[0] == word[0] &&	\
-	    strncmp((tokenPtr)[1].start, (word), (tokenPtr)[1].size) == 0)
-
-    if (GotLiteral(tokenPtr, "boolean")) {
-	t = TypeBool;
-    } else if (GotLiteral(tokenPtr, "double")) {
-	t = TypeFloat;
-    } else if (GotLiteral(tokenPtr, "entier")) {
-	t = TypeInteger;
-    } else if (GotLiteral(tokenPtr, "false")) {
-	t = TypeBoolFalse;
-    } else if (GotLiteral(tokenPtr, "integer")) {
-	t = TypeNarrowInt;
-	return TCL_ERROR; // Not yet implemented
-    } else if (GotLiteral(tokenPtr, "list")) {
-	t = TypeList;
-    } else if (GotLiteral(tokenPtr, "true")) {
-	t = TypeBoolTrue;
-    } else if (GotLiteral(tokenPtr, "wideinteger")) {
-	t = TypeWideInt;
-	return TCL_ERROR; // Not yet implemented
-    } else {
-	/*
-	 * We don't handle character class checks in bytecode currently.
-	 */
-
+    isClass = Tcl_NewObj();
+    if (!TclWordKnownAtCompileTime(tokenPtr, isClass)) {
+	Tcl_DecrRefCount(isClass);
 	return TCL_ERROR;
+    } else if (Tcl_GetIndexFromObj(interp, isClass, isClasses, "class", 0,
+	    &t) != TCL_OK) {
+	Tcl_DecrRefCount(isClass);
+	TclCompileSyntaxError(interp, envPtr);
+	return TCL_OK;
     }
-    if (numWords != 3 && numWords != 4) {
+    Tcl_DecrRefCount(isClass);
+
+#define GotLiteral(tokenPtr, word) \
+    ((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD &&			\
+     (tokenPtr)[1].size > 1 &&						\
+     (tokenPtr)[1].start[0] == word[0] &&				\
+     strncmp((tokenPtr)[1].start, (word), (tokenPtr)[1].size) == 0)
+
+    /*
+     * Cannot handle the -failindex option at all, and that's the only legal
+     * way to have more than 4 arguments.
+     */
+
+    if (parsePtr->numWords != 3 && parsePtr->numWords != 4) {
 	return TCL_ERROR;
     }
+
     tokenPtr = TokenAfter(tokenPtr);
-    if (numWords == 3) {
-	allowEmpty = (t != TypeList);
+    if (parsePtr->numWords == 3) {
+	allowEmpty = (t != STR_IS_LIST);
     } else {
 	if (!GotLiteral(tokenPtr, "-strict")) {
 	    return TCL_ERROR;
@@ -494,18 +497,47 @@ TclCompileStringIsCmd(
 #undef GotLiteral
 
     /*
+     * Some types are not currently handled. Character classes are a prime
+     * example of this.
+     */
+
+    switch (t) {
+    case STR_IS_ALNUM:
+    case STR_IS_ALPHA:
+    case STR_IS_ASCII:
+    case STR_IS_CONTROL:
+    case STR_IS_DIGIT:
+    case STR_IS_GRAPH:
+    case STR_IS_LOWER:
+    case STR_IS_PRINT:
+    case STR_IS_PUNCT:
+    case STR_IS_SPACE:
+    case STR_IS_UPPER:
+    case STR_IS_WORD:
+    case STR_IS_XDIGIT:
+	return TCL_ERROR;
+
+    case STR_IS_BOOL:
+    case STR_IS_FALSE:
+    case STR_IS_INT:
+    case STR_IS_TRUE:
+    case STR_IS_WIDE:
+	/* Not yet implemented */
+	return TCL_ERROR;
+    }
+
+    /*
      * Push the word to check.
      */
 
-    CompileWord(envPtr, tokenPtr, interp, numWords-1);
+    CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1);
 
     /*
      * Next, do the type check. First, we push a catch range; most of the
      * type-check operations throw an exception on failure.
      */
 
-    range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
-    start = 0;
+    range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
     TclEmitInstInt4(	INST_BEGIN_CATCH4, range,	envPtr);
     ExceptionRangeStarts(envPtr, range);
 
@@ -514,22 +546,7 @@ TclCompileStringIsCmd(
      */
 
     switch (t) {
-    case TypeBool:
-	TclEmitOpcode(		INST_DUP,			envPtr);
-	TclEmitOpcode(		INST_LNOT,			envPtr);
-	TclEmitOpcode(		INST_POP,			envPtr);
-	break;
-    case TypeBoolFalse:
-	TclEmitOpcode(		INST_DUP,			envPtr);
-	start = CurrentOffset(envPtr);
-	TclEmitInstInt1(	INST_JUMP_TRUE1, 0,		envPtr);
-	break;
-    case TypeBoolTrue:
-	TclEmitOpcode(		INST_DUP,			envPtr);
-	start = CurrentOffset(envPtr);
-	TclEmitInstInt1(	INST_JUMP_FALSE1, 0,		envPtr);
-	break;
-    case TypeFloat:
+    case STR_IS_DOUBLE:
 	/*
 	 * Careful! Preserve behavior of NaN which is a double (that is, true
 	 * for the purposes of a type check) but most math ops fail on it. The
@@ -550,16 +567,12 @@ TclCompileStringIsCmd(
 	TclEmitOpcode(		INST_UMINUS,			envPtr);
 	TclEmitOpcode(		INST_POP,			envPtr);
 	break;
-    case TypeInteger:
+    case STR_IS_ENTIER:
 	TclEmitOpcode(		INST_DUP,			envPtr);
 	TclEmitOpcode(		INST_BITNOT,			envPtr);
 	TclEmitOpcode(		INST_POP,			envPtr);
 	break;
-    case TypeNarrowInt:
-	Tcl_Panic("not yet implemented");
-    case TypeWideInt:
-	Tcl_Panic("not yet implemented");
-    case TypeList:
+    case STR_IS_LIST:
 	TclEmitOpcode(		INST_DUP,			envPtr);
 	TclEmitOpcode(		INST_LIST_LENGTH,		envPtr);
 	TclEmitOpcode(		INST_POP,			envPtr);
@@ -579,10 +592,6 @@ TclCompileStringIsCmd(
     PushLiteral(envPtr, "1", 1);
     TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);
     ExceptionRangeTarget(envPtr, range, catchOffset);
-    if (start != 0) {
-	TclStoreInt1AtPtr(CurrentOffset(envPtr) - start,
-		envPtr->codeStart + start + 1);
-    }
     TclEmitOpcode(		INST_END_CATCH,			envPtr);
     if (allowEmpty) {
 	PushLiteral(envPtr, "", 0);
-- 
cgit v0.12


From 46e4bced044a19d781735a5c6f55a3a307dff7dc Mon Sep 17 00:00:00 2001
From: mig <mig>
Date: Sun, 5 Jan 2014 12:01:04 +0000
Subject: reducing TEBCdata: pc and cleanup now passed in the NREcallback

---
 generic/tclExecute.c | 40 ++++++++++++++++------------------------
 1 file changed, 16 insertions(+), 24 deletions(-)

diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 37a7397..3601b22 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -174,28 +174,24 @@ static BuiltinFunc const tclBuiltinFuncTable[] = {
 typedef struct TEBCdata {
     ByteCode *codePtr;		/* Constant until the BC returns */
 				/* -----------------------------------------*/
-    const unsigned char *pc;	/* These fields are used on return TO this */
-    ptrdiff_t *catchTop;	/* this level: they record the state when a */
-    int cleanup;		/* new codePtr was received for NR */
-    Tcl_Obj *auxObjList;	/* execution. */
-    CmdFrame cmdFrame;
+    ptrdiff_t *catchTop;	/* These fields are used on return TO this */
+    Tcl_Obj *auxObjList;	/* this level: they record the state when a */
+    CmdFrame cmdFrame;		/* new codePtr was received for NR */
+                                /* execution. */
     void *stack[1];		/* Start of the actual combined catch and obj
 				 * stacks; the struct will be expanded as
 				 * necessary */
 } TEBCdata;
 
 #define TEBC_YIELD() \
-    do {								\
-	esPtr->tosPtr = tosPtr;						\
-	TD->pc = pc;							\
-	TD->cleanup = cleanup;						\
-	TclNRAddCallback(interp, TEBCresume, TD, INT2PTR(1), NULL, NULL); \
+    do {						\
+	esPtr->tosPtr = tosPtr;				\
+	TclNRAddCallback(interp, TEBCresume,		\
+		TD, pc, INT2PTR(cleanup), NULL);	\
     } while (0)
 
 #define TEBC_DATA_DIG() \
     do {					\
-	pc = TD->pc;				\
-	cleanup = TD->cleanup;			\
 	tosPtr = esPtr->tosPtr;			\
     } while (0)
 
@@ -2032,10 +2028,6 @@ TclNRExecuteByteCode(
 		* sizeof(void *);
     int numWords = (size + sizeof(Tcl_Obj *) - 1) / sizeof(Tcl_Obj *);
 
-    if (iPtr->execEnvPtr->rewind) {
-	return TCL_ERROR;
-    }
-
     codePtr->refCount++;
 
     /*
@@ -2054,9 +2046,7 @@ TclNRExecuteByteCode(
     esPtr->tosPtr = initTosPtr;
 
     TD->codePtr     = codePtr;
-    TD->pc	    = codePtr->codeStart;
     TD->catchTop    = initCatchTop;
-    TD->cleanup     = 0;
     TD->auxObjList  = NULL;
 
     /*
@@ -2086,8 +2076,8 @@ TclNRExecuteByteCode(
      * Push the callback for bytecode execution
      */
 
-    TclNRAddCallback(interp, TEBCresume, TD, /*resume*/ INT2PTR(0),
-	    NULL, NULL);
+    TclNRAddCallback(interp, TEBCresume, TD, /* pc */ NULL,
+	    /* cleanup */ INT2PTR(0), NULL);
     return TCL_OK;
 }
 
@@ -2150,7 +2140,8 @@ TEBCresume(
 
     Tcl_Obj **tosPtr;		/* Cached pointer to top of evaluation
 				 * stack. */
-    const unsigned char *pc;	/* The current program counter. */
+    const unsigned char *pc = data[1];
+                                /* The current program counter. */
     unsigned char inst;         /* The currently running instruction */
     
     /*
@@ -2158,7 +2149,7 @@ TEBCresume(
      * executing an instruction.
      */
 
-    int cleanup = 0;
+    int cleanup = PTR2INT(data[2]);
     Tcl_Obj *objResultPtr;
     int checkInterp;            /* Indicates when a check of interp readyness
 				 * is necessary. Set by CACHE_STACK_INFO() */
@@ -2186,16 +2177,17 @@ TEBCresume(
     TEBC_DATA_DIG();
 
 #ifdef TCL_COMPILE_DEBUG
-    if (!data[1] && (tclTraceExec >= 2)) {
+    if (!pc && (tclTraceExec >= 2)) {
 	PrintByteCodeInfo(codePtr);
 	fprintf(stdout, "  Starting stack top=%d\n", (int) CURR_DEPTH);
 	fflush(stdout);
     }
 #endif
 
-    if (!data[1]) {
+    if (!pc) {
 	/* bytecode is starting from scratch */
 	checkInterp = 0;
+	pc = codePtr->codeStart;
 	goto cleanup0;
     } else {
         /* resume from invocation */
-- 
cgit v0.12


From f63ef2c79888c0b68ff4e0ae7815e11e2075de65 Mon Sep 17 00:00:00 2001
From: mig <mig>
Date: Sun, 5 Jan 2014 14:10:42 +0000
Subject: skip the switch(result) on returning TCL_OK from a proc

---
 generic/tclProc.c | 72 +++++++++++++++++++++++++------------------------------
 1 file changed, 32 insertions(+), 40 deletions(-)

diff --git a/generic/tclProc.c b/generic/tclProc.c
index 1314719..ce1c767 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -1855,9 +1855,39 @@ InterpProcNR2(
     }
 
     /*
-     * Process the result code.
+     * Free the stack-allocated compiled locals and CallFrame. It is important
+     * to pop the call frame without freeing it first: the compiledLocals
+     * cannot be freed before the frame is popped, as the local variables must
+     * be deleted. But the compiledLocals must be freed first, as they were
+     * allocated later on the stack.
      */
 
+    if (result != TCL_OK) {
+	goto process;
+    }
+    
+    done: 
+    if (TCL_DTRACE_PROC_RESULT_ENABLED()) {
+	int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0;
+	Tcl_Obj *r = Tcl_GetObjResult(interp);
+
+	TCL_DTRACE_PROC_RESULT(l < iPtr->varFramePtr->objc ?
+		TclGetString(iPtr->varFramePtr->objv[l]) : NULL, result,
+		TclGetString(r), r);
+    }
+
+    freePtr = iPtr->framePtr;
+    Tcl_PopCallFrame(interp);		/* Pop but do not free. */
+    TclStackFree(interp, freePtr->compiledLocals);
+					/* Free compiledLocals. */
+    TclStackFree(interp, freePtr);	/* Free CallFrame. */
+    return result;
+
+    /*
+     * Process any non-TCL_OK result code.
+     */
+
+    process:
     switch (result) {
     case TCL_RETURN:
 	/*
@@ -1892,46 +1922,8 @@ InterpProcNR2(
 	 */
 
 	errorProc(interp, procNameObj);
-
-    default:
-	/*
-	 * Process other results (OK and non-standard) by doing nothing
-	 * special, skipping directly to the code afterwards that cleans up
-	 * associated memory.
-	 *
-	 * Non-standard results are processed by passing them through quickly.
-	 * This means they all work as exceptions, unwinding the stack quickly
-	 * and neatly. Who knows how well they are handled by third-party code
-	 * though...
-	 */
-
-	(void) 0;		/* do nothing */
-    }
-
-    if (TCL_DTRACE_PROC_RESULT_ENABLED()) {
-	int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0;
-	Tcl_Obj *r = Tcl_GetObjResult(interp);
-
-	TCL_DTRACE_PROC_RESULT(l < iPtr->varFramePtr->objc ?
-		TclGetString(iPtr->varFramePtr->objv[l]) : NULL, result,
-		TclGetString(r), r);
     }
-
-    /*
-     * Free the stack-allocated compiled locals and CallFrame. It is important
-     * to pop the call frame without freeing it first: the compiledLocals
-     * cannot be freed before the frame is popped, as the local variables must
-     * be deleted. But the compiledLocals must be freed first, as they were
-     * allocated later on the stack.
-     */
-
-    freePtr = iPtr->framePtr;
-    Tcl_PopCallFrame(interp);		/* Pop but do not free. */
-    TclStackFree(interp, freePtr->compiledLocals);
-					/* Free compiledLocals. */
-    TclStackFree(interp, freePtr);	/* Free CallFrame. */
-
-    return result;
+    goto done;
 }
 
 /*
-- 
cgit v0.12


From 92f27b7095220ef6e508c9a0216e0fce97b3d2ae Mon Sep 17 00:00:00 2001
From: mig <mig>
Date: Sun, 5 Jan 2014 15:01:52 +0000
Subject: fix arraySet compiler to set -errorcode instead of -errorCode in
 return options

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

diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 323aa87..3d5bfe0 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -278,7 +278,7 @@ TclCompileArraySetCmd(
 
     if (isDataValid && !isDataEven) {
 	PushStringLiteral(envPtr, "list must have an even number of elements");
-	PushStringLiteral(envPtr, "-errorCode {TCL ARGUMENT FORMAT}");
+	PushStringLiteral(envPtr, "-errorcode {TCL ARGUMENT FORMAT}");
 	TclEmitInstInt4(INST_RETURN_IMM, TCL_ERROR,		envPtr);
 	TclEmitInt4(		0,				envPtr);
 	goto done;
@@ -373,7 +373,7 @@ TclCompileArraySetCmd(
 	offsetFwd = CurrentOffset(envPtr);
 	TclEmitInstInt1(INST_JUMP_FALSE1, 0,			envPtr);
 	PushStringLiteral(envPtr, "list must have an even number of elements");
-	PushStringLiteral(envPtr, "-errorCode {TCL ARGUMENT FORMAT}");
+	PushStringLiteral(envPtr, "-errorcode {TCL ARGUMENT FORMAT}");
 	TclEmitInstInt4(INST_RETURN_IMM, TCL_ERROR,		envPtr);
 	TclEmitInt4(		0,				envPtr);
 	TclAdjustStackDepth(-1, envPtr);
-- 
cgit v0.12


From c01192cf149de63a2a22afde7ac9adecd73f051d Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Sun, 5 Jan 2014 17:31:38 +0000
Subject: factor out a common stanza

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

diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index f25b588..612a5cb 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -1996,6 +1996,41 @@ TclIncrObj(
 /*
  *----------------------------------------------------------------------
  *
+ * ArgumentBCEnter --
+ *
+ *	This is a helper for TclNRExecuteByteCode/TEBCresume that encapsulates
+ *	a code sequence that is fairly common in the code but *not* commonly
+ *	called.
+ *
+ * Results:
+ *	None
+ *
+ * Side effects:
+ *	May register information about the bytecode in the command frame.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+ArgumentBCEnter(
+    Tcl_Interp *interp,
+    ByteCode *codePtr,
+    TEBCdata *tdPtr,
+    const unsigned char *pc,
+    int objc,
+    Tcl_Obj **objv)
+{
+    int cmd;
+
+    if (GetSrcInfoForPc(pc, codePtr, NULL, NULL, &cmd)) {
+	TclArgumentBCEnter(interp, objv, objc, codePtr, &tdPtr->cmdFrame, cmd,
+		pc - codePtr->codeStart);
+    }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * TclNRExecuteByteCode --
  *
  *	This procedure executes the instructions of a ByteCode structure. It
@@ -2205,7 +2240,7 @@ TEBCresume(
 	}
 	iPtr->cmdFramePtr = bcFramePtr->nextPtr;
 	if (iPtr->flags & INTERP_DEBUG_FRAME) {
-	    TclArgumentBCRelease((Tcl_Interp *) iPtr, bcFramePtr);
+	    TclArgumentBCRelease(interp, bcFramePtr);
 	}
 	if (codePtr->flags & TCL_BYTECODE_RECOMPILE) {
 	    iPtr->flags |= ERR_ALREADY_LOGGED;
@@ -2487,11 +2522,7 @@ TEBCresume(
 	iPtr->cmdFramePtr = bcFramePtr;
 
 	if (iPtr->flags & INTERP_DEBUG_FRAME) {
-	    int cmd;
-	    if (GetSrcInfoForPc(pc, codePtr, NULL, NULL, &cmd)) {
-		TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc,
-			codePtr, bcFramePtr, cmd, pc - codePtr->codeStart);
-	    }
+	    ArgumentBCEnter(interp, codePtr, TD, pc, objc, objv);
 	}
 
 	pc++;
@@ -2961,11 +2992,7 @@ TEBCresume(
 	iPtr->cmdFramePtr = bcFramePtr;
 
 	if (iPtr->flags & INTERP_DEBUG_FRAME) {
-	    int cmd;
-	    if (GetSrcInfoForPc(pc, codePtr, NULL, NULL, &cmd)) {
-		TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc,
-			codePtr, bcFramePtr, cmd, pc - codePtr->codeStart);
-	    }
+	    ArgumentBCEnter(interp, codePtr, TD, pc, objc, objv);
 	}
 
 	DECACHE_STACK_INFO();
@@ -3110,11 +3137,7 @@ TEBCresume(
 	bcFramePtr->data.tebc.pc = (char *) pc;
 	iPtr->cmdFramePtr = bcFramePtr;
 	if (iPtr->flags & INTERP_DEBUG_FRAME) {
-	    int cmd;
-	    if (GetSrcInfoForPc(pc, codePtr, NULL, NULL, &cmd)) {
-		TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc,
-			codePtr, bcFramePtr, cmd, pc - codePtr->codeStart);
-	    }
+	    ArgumentBCEnter(interp, codePtr, TD, pc, objc, objv);
 	}
 	iPtr->ensembleRewrite.sourceObjs = objv;
 	iPtr->ensembleRewrite.numRemovedObjs = opnd;
@@ -4559,11 +4582,7 @@ TEBCresume(
 	iPtr->cmdFramePtr = bcFramePtr;
 
 	if (iPtr->flags & INTERP_DEBUG_FRAME) {
-	    int cmd;
-	    if (GetSrcInfoForPc(pc, codePtr, NULL, NULL, &cmd)) {
-		TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc,
-			codePtr, bcFramePtr, cmd, pc - codePtr->codeStart);
-	    }
+	    ArgumentBCEnter(interp, codePtr, TD, pc, objc, objv);
 	}
 
 	pcAdjustment = 2;
-- 
cgit v0.12


From 23573493d5f31cddea12c4e9b6f8ae5a5d3f50c9 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Tue, 7 Jan 2014 13:59:30 +0000
Subject: reduce the overhead of NR-enabled TclOO [next]

---
 generic/tclExecute.c | 136 +++++++++++++++++++++++++++++++++++++++++++++++----
 1 file changed, 127 insertions(+), 9 deletions(-)

diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 612a5cb..5b42124 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -800,7 +800,8 @@ static Tcl_Obj **	StackAllocWords(Tcl_Interp *interp, int numWords);
 static Tcl_Obj **	StackReallocWords(Tcl_Interp *interp, int numWords);
 static Tcl_NRPostProc	CopyCallback;
 static Tcl_NRPostProc	ExprObjCallback;
-
+static Tcl_NRPostProc	FinalizeOONext;
+static Tcl_NRPostProc	FinalizeOONextFilter;
 static Tcl_NRPostProc   TEBCresume;
 
 /*
@@ -4535,6 +4536,7 @@ TEBCresume(
      */
 
     {
+	Object *oPtr;
 	CallFrame *framePtr;
 	CallContext *contextPtr;
 
@@ -4578,6 +4580,53 @@ TEBCresume(
 	}
 	contextPtr = framePtr->clientData;
 
+	if (contextPtr->index+1 >= contextPtr->callPtr->numChain) {
+	    /*
+	     * We're at the end of the chain; generate an error message unless
+	     * the interpreter is being torn down, in which case we might be
+	     * getting here because of methods/destructors doing a [next] (or
+	     * equivalent) unexpectedly.
+	     */
+
+	    const char *methodType;
+
+	    if (contextPtr->callPtr->flags & CONSTRUCTOR) {
+		methodType = "constructor";
+	    } else if (contextPtr->callPtr->flags & DESTRUCTOR) {
+		methodType = "destructor";
+	    } else {
+		methodType = "method";
+	    }
+
+	    TRACE_APPEND(("ERROR: no TclOO next impl\n"));
+	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+		    "no next %s implementation", methodType));
+	    DECACHE_STACK_INFO();
+	    Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL);
+	    CACHE_STACK_INFO();
+	    goto gotError;
+	}
+
+#ifdef TCL_COMPILE_DEBUG
+	if (tclTraceExec >= 2) {
+	    int i;
+
+	    if (traceInstructions) {
+		strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
+		TRACE(("next_in_chain "));
+	    } else {
+		fprintf(stdout, "%d: (%u) invoking next_in_chain ",
+			iPtr->numLevels, (unsigned)(pc - codePtr->codeStart));
+	    }
+	    for (i = 0;  i < objc;  i++) {
+		TclPrintObject(stdout, objv[i], 15);
+		fprintf(stdout, " ");
+	    }
+	    fprintf(stdout, "\n");
+	    fflush(stdout);
+	}
+#endif /*TCL_COMPILE_DEBUG*/
+
 	bcFramePtr->data.tebc.pc = (char *) pc;
 	iPtr->cmdFramePtr = bcFramePtr;
 
@@ -4591,14 +4640,31 @@ TEBCresume(
 	iPtr->varFramePtr = framePtr->callerVarPtr;
 	pc += pcAdjustment;
 	TEBC_YIELD();
-	TclNRAddCallback(interp, TclOONextRestoreFrame, framePtr,
-		NULL, NULL, NULL);
-	/* TODO: consider merging another layer of processing */
-	return TclNRObjectContextInvokeNext(interp,
-		(Tcl_ObjectContext) contextPtr, opnd, &OBJ_AT_DEPTH(opnd-1), 1);
-    }
-    {
-	Object *oPtr;
+	oPtr = contextPtr->oPtr;
+	if (oPtr->flags & FILTER_HANDLING) {
+	    TclNRAddCallback(interp, FinalizeOONextFilter,
+		    framePtr, contextPtr, INT2PTR(contextPtr->index),
+		    INT2PTR(contextPtr->skip));
+	} else {
+	    TclNRAddCallback(interp, FinalizeOONext,
+		    framePtr, contextPtr, INT2PTR(contextPtr->index),
+		    INT2PTR(contextPtr->skip));
+	}
+	if (contextPtr->callPtr->chain[++contextPtr->index].isFilter
+		|| contextPtr->callPtr->flags & FILTER_HANDLING) {
+	    oPtr->flags |= FILTER_HANDLING;
+	} else {
+	    oPtr->flags &= ~FILTER_HANDLING;
+	}
+	contextPtr->skip = 1;
+	{
+	    register Method *const mPtr =
+		    contextPtr->callPtr->chain[contextPtr->index].mPtr;
+
+	    return mPtr->typePtr->callProc(mPtr->clientData, interp,
+		    (Tcl_ObjectContext) contextPtr, opnd,
+		    &OBJ_AT_DEPTH(opnd-1));
+	}
 
     case INST_TCLOO_IS_OBJECT:
 	oPtr = (Object *) Tcl_GetObjectFromObj(interp, OBJ_AT_TOS);
@@ -7766,6 +7832,58 @@ TEBCresume(
 #undef auxObjList
 #undef catchTop
 #undef TCONST
+
+static int
+FinalizeOONext(
+    ClientData data[],
+    Tcl_Interp *interp,
+    int result)
+{
+    Interp *iPtr = (Interp *) interp;
+    CallContext *contextPtr = data[1];
+
+    /*
+     * Reset the variable lookup frame.
+     */
+
+    iPtr->varFramePtr = data[0];
+
+    /*
+     * Restore the call chain context index as we've finished the inner invoke
+     * and want to operate in the outer context again.
+     */
+
+    contextPtr->index = PTR2INT(data[2]);
+    contextPtr->skip = PTR2INT(data[3]);
+    contextPtr->oPtr->flags &= ~FILTER_HANDLING;
+    return result;
+}
+
+static int
+FinalizeOONextFilter(
+    ClientData data[],
+    Tcl_Interp *interp,
+    int result)
+{
+    Interp *iPtr = (Interp *) interp;
+    CallContext *contextPtr = data[1];
+
+    /*
+     * Reset the variable lookup frame.
+     */
+
+    iPtr->varFramePtr = data[0];
+
+    /*
+     * Restore the call chain context index as we've finished the inner invoke
+     * and want to operate in the outer context again.
+     */
+
+    contextPtr->index = PTR2INT(data[2]);
+    contextPtr->skip = PTR2INT(data[3]);
+    contextPtr->oPtr->flags |= FILTER_HANDLING;
+    return result;
+}
 
 /*
  *----------------------------------------------------------------------
-- 
cgit v0.12


From 8bb7405765b9aed27270dfd145037e3c5884a34a Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Tue, 7 Jan 2014 14:13:37 +0000
Subject: make function static once more; not needed outside of source file

---
 generic/tclInt.h     |  1 -
 generic/tclOOBasic.c | 21 +++++++++------------
 2 files changed, 9 insertions(+), 13 deletions(-)

diff --git a/generic/tclInt.h b/generic/tclInt.h
index f10beae..3aaa30b 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -2734,7 +2734,6 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldmObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldToObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRInvoke;
-MODULE_SCOPE Tcl_NRPostProc TclOONextRestoreFrame;
 
 MODULE_SCOPE void  TclSetTailcall(Tcl_Interp *interp, Tcl_Obj *tailcallPtr);
 MODULE_SCOPE void  TclPushTailcallPoint(Tcl_Interp *interp);
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index 49c917b..6084cf2 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -17,14 +17,11 @@
 #include "tclOOInt.h"
 
 static inline Tcl_Object *AddConstructionFinalizer(Tcl_Interp *interp);
-static int		AfterNRDestructor(ClientData data[],
-			    Tcl_Interp *interp, int result);
-static int		DecrRefsPostClassConstructor(ClientData data[],
-			    Tcl_Interp *interp, int result);
-static int		FinalizeConstruction(ClientData data[],
-			    Tcl_Interp *interp, int result);
-static int		FinalizeEval(ClientData data[],
-			    Tcl_Interp *interp, int result);
+static Tcl_NRPostProc	AfterNRDestructor;
+static Tcl_NRPostProc	DecrRefsPostClassConstructor;
+static Tcl_NRPostProc	FinalizeConstruction;
+static Tcl_NRPostProc	FinalizeEval;
+static Tcl_NRPostProc	NextRestoreFrame;
 
 /*
  * ----------------------------------------------------------------------
@@ -806,7 +803,7 @@ TclOONextObjCmd(
      * that this is like [uplevel 1] and not [eval].
      */
 
-    TclNRAddCallback(interp, TclOONextRestoreFrame, framePtr, NULL,NULL,NULL);
+    TclNRAddCallback(interp, NextRestoreFrame, framePtr, NULL,NULL,NULL);
     iPtr->varFramePtr = framePtr->callerVarPtr;
     return TclNRObjectContextInvokeNext(interp, context, objc, objv, 1);
 }
@@ -875,7 +872,7 @@ TclOONextToObjCmd(
 	     * context. Note that this is like [uplevel 1] and not [eval].
 	     */
 
-	    TclNRAddCallback(interp, TclOONextRestoreFrame, framePtr,
+	    TclNRAddCallback(interp, NextRestoreFrame, framePtr,
 		    contextPtr, INT2PTR(contextPtr->index), NULL);
 	    contextPtr->index = i-1;
 	    iPtr->varFramePtr = framePtr->callerVarPtr;
@@ -905,8 +902,8 @@ TclOONextToObjCmd(
     return TCL_ERROR;
 }
 
-int
-TclOONextRestoreFrame(
+static int
+NextRestoreFrame(
     ClientData data[],
     Tcl_Interp *interp,
     int result)
-- 
cgit v0.12


From acf1cebeab93607fc83206e77534b5fada8726ef Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Thu, 9 Jan 2014 10:49:04 +0000
Subject: use compact form

---
 generic/tclCompCmdsSZ.c | 51 ++++++++++++++++++++++++-------------------------
 1 file changed, 25 insertions(+), 26 deletions(-)

diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index 06cca50..345dd9f 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -451,8 +451,7 @@ TclCompileStringIsCmd(
 	STR_IS_TRUE,	STR_IS_UPPER,	STR_IS_WIDE,	STR_IS_WORD,
 	STR_IS_XDIGIT
     };
-    JumpFixup jumpFixup;
-    int t, range, allowEmpty = 0;
+    int t, range, allowEmpty = 0, end;
     Tcl_Obj *isClass;
 
     if (parsePtr->numWords < 3 || parsePtr->numWords > 6) {
@@ -538,7 +537,7 @@ TclCompileStringIsCmd(
      */
 
     range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
-    TclEmitInstInt4(	INST_BEGIN_CATCH4, range,	envPtr);
+    OP4(		BEGIN_CATCH4, range);
     ExceptionRangeStarts(envPtr, range);
 
     /*
@@ -554,28 +553,28 @@ TclCompileStringIsCmd(
 	 * this is true for).
 	 */
 
-	TclEmitOpcode(		INST_DUP,			envPtr);
-	TclEmitOpcode(		INST_DUP,			envPtr);
-	TclEmitOpcode(		INST_NEQ,			envPtr);
-	TclEmitInstInt1(	INST_JUMP_TRUE1, 5,		envPtr);
+	OP(		DUP);
+	OP(		DUP);
+	OP(		NEQ);
+	OP1(		JUMP_TRUE1, 5);
 
 	/*
 	 * Type check for all other double values.
 	 */
 
-	TclEmitOpcode(		INST_DUP,			envPtr);
-	TclEmitOpcode(		INST_UMINUS,			envPtr);
-	TclEmitOpcode(		INST_POP,			envPtr);
+	OP(		DUP);
+	OP(		UMINUS);
+	OP(		POP);
 	break;
     case STR_IS_ENTIER:
-	TclEmitOpcode(		INST_DUP,			envPtr);
-	TclEmitOpcode(		INST_BITNOT,			envPtr);
-	TclEmitOpcode(		INST_POP,			envPtr);
+	OP(		DUP);
+	OP(		BITNOT);
+	OP(		POP);
 	break;
     case STR_IS_LIST:
-	TclEmitOpcode(		INST_DUP,			envPtr);
-	TclEmitOpcode(		INST_LIST_LENGTH,		envPtr);
-	TclEmitOpcode(		INST_POP,			envPtr);
+	OP(		DUP);
+	OP(		LIST_LENGTH);
+	OP(		POP);
 	break;
     }
 
@@ -587,20 +586,20 @@ TclCompileStringIsCmd(
      */
 
     ExceptionRangeEnds(envPtr, range);
-    TclEmitOpcode(		INST_END_CATCH,			envPtr);
-    TclEmitOpcode(		INST_POP,			envPtr);
-    PushLiteral(envPtr, "1", 1);
-    TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);
+    OP(			END_CATCH);
+    OP(			POP);
+    PUSH(		"1");
+    JUMP1(		JUMP, end);
     ExceptionRangeTarget(envPtr, range, catchOffset);
-    TclEmitOpcode(		INST_END_CATCH,			envPtr);
+    OP(			END_CATCH);
     if (allowEmpty) {
-	PushLiteral(envPtr, "", 0);
-	TclEmitOpcode(		INST_STR_EQ,			envPtr);
+	PUSH(		"");
+	OP(		STR_EQ);
     } else {
-	TclEmitOpcode(		INST_POP,			envPtr);
-	PushLiteral(envPtr, "0", 1);
+	OP(		POP);
+	PUSH(		"0");
     }
-    TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127);
+    FIXJUMP1(	end);
     return TCL_OK;
 }
 
-- 
cgit v0.12


From c3c6e803684022dcc788ddbfc4a59a6d0dfde102 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Fri, 10 Jan 2014 15:58:41 +0000
Subject: a different approach

---
 generic/tclAssembly.c   |   4 +-
 generic/tclCompCmdsSZ.c | 150 ++++++++++++++++++++++++++----------------------
 generic/tclCompile.c    |   4 ++
 generic/tclCompile.h    |   4 +-
 generic/tclExecute.c    |   8 +++
 5 files changed, 98 insertions(+), 72 deletions(-)

diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 89c286a..70379c6 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -437,6 +437,7 @@ static const TalInstDesc TalInstructionTable[] = {
     {"nop",		ASSEM_1BYTE,	INST_NOP,		0,	0},
     {"not",		ASSEM_1BYTE,	INST_LNOT,		1,	1},
     {"nsupvar",		ASSEM_LVT4,	INST_NSUPVAR,		2,	1},
+    {"numericType",	ASSEM_1BYTE,	INST_NUM_TYPE,		1,	1},
     {"originCmd",	ASSEM_1BYTE,	INST_ORIGIN_COMMAND,	1,	1},
     {"over",		ASSEM_OVER,	INST_OVER,		INT_MIN,-1-1},
     {"pop",		ASSEM_1BYTE,	INST_POP,		1,	0},
@@ -516,7 +517,8 @@ static const unsigned char NonThrowingByteCodes[] = {
     INST_RESOLVE_COMMAND,					/* 154 */
     INST_STR_TRIM, INST_STR_TRIM_LEFT, INST_STR_TRIM_RIGHT,	/* 166-168 */
     INST_CONCAT_STK,						/* 169 */
-    INST_STR_UPPER, INST_STR_LOWER, INST_STR_TITLE		/* 170-172 */
+    INST_STR_UPPER, INST_STR_LOWER, INST_STR_TITLE,		/* 170-172 */
+    INST_NUM_TYPE						/* 180 */
 };
 
 /*
diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index 345dd9f..1436a20 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -500,7 +500,7 @@ TclCompileStringIsCmd(
      * example of this.
      */
 
-    switch (t) {
+    switch ((enum isClasses) t) {
     case STR_IS_ALNUM:
     case STR_IS_ALPHA:
     case STR_IS_ASCII:
@@ -514,93 +514,103 @@ TclCompileStringIsCmd(
     case STR_IS_UPPER:
     case STR_IS_WORD:
     case STR_IS_XDIGIT:
+	/* Not yet implemented */
 	return TCL_ERROR;
 
     case STR_IS_BOOL:
     case STR_IS_FALSE:
-    case STR_IS_INT:
     case STR_IS_TRUE:
-    case STR_IS_WIDE:
 	/* Not yet implemented */
 	return TCL_ERROR;
-    }
-
-    /*
-     * Push the word to check.
-     */
-
-    CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1);
 
-    /*
-     * Next, do the type check. First, we push a catch range; most of the
-     * type-check operations throw an exception on failure.
-     */
-
-    range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
-    OP4(		BEGIN_CATCH4, range);
-    ExceptionRangeStarts(envPtr, range);
-
-    /*
-     * Issue the type-check itself for the specific type.
-     */
+    case STR_IS_DOUBLE: {
+	int satisfied, isEmpty;
 
-    switch (t) {
-    case STR_IS_DOUBLE:
-	/*
-	 * Careful! Preserve behavior of NaN which is a double (that is, true
-	 * for the purposes of a type check) but most math ops fail on it. The
-	 * key is that it is not == to itself (and is the only value which
-	 * this is true for).
-	 */
+	CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1);
+	if (allowEmpty) {
+	    OP(		DUP);
+	    PUSH(	"");
+	    OP(		STR_EQ);
+	    JUMP1(	JUMP_TRUE, isEmpty);
+	    OP(		NUM_TYPE);
+	    JUMP1(	JUMP_TRUE, satisfied);
+	    PUSH(	"0");
+	    JUMP1(	JUMP, end);
+	    FIXJUMP1(	isEmpty);
+	    OP(		POP);
+	    FIXJUMP1(	satisfied);
+	} else {
+	    OP(		NUM_TYPE);
+	    JUMP1(	JUMP_TRUE, satisfied);
+	    PUSH(	"0");
+	    JUMP1(	JUMP, end);
+	    TclAdjustStackDepth(-1, envPtr);
+	    FIXJUMP1(	satisfied);
+	}
+	PUSH(		"1");
+	FIXJUMP1(	end);
+	return TCL_OK;
+    }
 
-	OP(		DUP);
-	OP(		DUP);
-	OP(		NEQ);
-	OP1(		JUMP_TRUE1, 5);
+    case STR_IS_INT:
+    case STR_IS_WIDE:
+    case STR_IS_ENTIER:
+	CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1);
+	if (allowEmpty) {
+	    int testNumType;
+
+	    OP(		DUP);
+	    OP(		NUM_TYPE);
+	    OP(		DUP);
+	    JUMP1(	JUMP_TRUE, testNumType);
+	    OP(		POP);
+	    PUSH(	"");
+	    OP(		STR_EQ);
+	    JUMP1(	JUMP, end);
+	    TclAdjustStackDepth(1, envPtr);
+	    FIXJUMP1(	testNumType);
+	    OP4(	REVERSE, 2);
+	    OP(		POP);
+	} else {
+	    OP(		NUM_TYPE);
+	    OP(		DUP);
+	    JUMP1(	JUMP_FALSE, end);
+	}
 
-	/*
-	 * Type check for all other double values.
-	 */
+	switch (t) {
+	case STR_IS_INT:
+	    PUSH(	"1");
+	    OP(		EQ);
+	    break;
+	case STR_IS_WIDE:
+	    PUSH(	"2");
+	    OP(		LE);
+	    break;
+	case STR_IS_ENTIER:
+	    PUSH(	"3");
+	    OP(		LE);
+	    break;
+	}
+	FIXJUMP1(	end);
+	return TCL_OK;
 
-	OP(		DUP);
-	OP(		UMINUS);
-	OP(		POP);
-	break;
-    case STR_IS_ENTIER:
-	OP(		DUP);
-	OP(		BITNOT);
-	OP(		POP);
-	break;
     case STR_IS_LIST:
+	CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1);
+	range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
+	OP4(		BEGIN_CATCH4, range);
+	ExceptionRangeStarts(envPtr, range);
 	OP(		DUP);
 	OP(		LIST_LENGTH);
 	OP(		POP);
-	break;
-    }
-
-    /*
-     * Based on whether the exception was thrown (or conditional branch taken,
-     * in the case of true/false checks), push the correct boolean value. This
-     * is also where we deal with what happens with empty values in non-strict
-     * mode.
-     */
-
-    ExceptionRangeEnds(envPtr, range);
-    OP(			END_CATCH);
-    OP(			POP);
-    PUSH(		"1");
-    JUMP1(		JUMP, end);
-    ExceptionRangeTarget(envPtr, range, catchOffset);
-    OP(			END_CATCH);
-    if (allowEmpty) {
-	PUSH(		"");
-	OP(		STR_EQ);
-    } else {
+	ExceptionRangeEnds(envPtr, range);
+	ExceptionRangeTarget(envPtr, range, catchOffset);
 	OP(		POP);
-	PUSH(		"0");
+	OP(		PUSH_RETURN_CODE);
+	OP(		END_CATCH);
+	OP(		LNOT);
+	return TCL_OK;
     }
-    FIXJUMP1(	end);
-    return TCL_OK;
+    return TCL_ERROR;
 }
 
 int
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index ee67e24..c01571f 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -621,6 +621,10 @@ InstructionDesc const tclInstructionTable[] = {
 	/* Push the identity of the current TclOO object (i.e., the name of
 	 * its current public access command) on the stack. */
 
+    {"numericType",	 1,	0,	  0,	{OPERAND_NONE}},
+	/* Pushes the numeric type code of the word at the top of the stack.
+	 * Stack:  ... value => ... typeCode */
+
     {NULL, 0, 0, 0, {OPERAND_NONE}}
 };
 
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 6ecadf4..6bf5daf 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -792,8 +792,10 @@ typedef struct ByteCode {
 
 #define INST_TCLOO_NEXT			179
 
+#define INST_NUM_TYPE			180
+
 /* The last opcode */
-#define LAST_INST_OPCODE		179
+#define LAST_INST_OPCODE		180
 
 /*
  * Table describing the Tcl bytecode instructions: their name (for displaying
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 5b42124..2707ec1 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -5776,6 +5776,14 @@ TEBCresume(
 	int type1, type2;
 	long l1, l2, lResult;
 
+    case INST_NUM_TYPE:
+	if (GetNumberFromObj(NULL, OBJ_AT_TOS, &ptr1, &type1) != TCL_OK) {
+	    type1 = 0;
+	}
+	TclNewIntObj(objResultPtr, type1);
+	TRACE(("\"%.20s\" => %d\n", O2S(OBJ_AT_TOS), type1));
+	NEXT_INST_F(1, 1, 1);
+
     case INST_EQ:
     case INST_NEQ:
     case INST_LT:
-- 
cgit v0.12


From aa2c40934df3fdefbb39338f7eef44e79c3c551e Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Mon, 13 Jan 2014 08:06:43 +0000
Subject: extend [string is] to booleans

---
 generic/tclAssembly.c   |  1 +
 generic/tclCompCmdsSZ.c | 51 +++++++++++++++++++++++++++++++++++++++++++++----
 generic/tclCompile.c    |  3 +++
 generic/tclCompile.h    |  3 ++-
 generic/tclExecute.c    | 11 +++++++++++
 5 files changed, 64 insertions(+), 5 deletions(-)

diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 70379c6..f10bca8 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -478,6 +478,7 @@ static const TalInstDesc TalInstructionTable[] = {
     {"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},
+    {"tryCvtToBoolean",	ASSEM_1BYTE,	INST_TRY_CVT_TO_BOOLEAN,1,	2},
     {"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/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index 1436a20..91bb94c 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -514,14 +514,57 @@ TclCompileStringIsCmd(
     case STR_IS_UPPER:
     case STR_IS_WORD:
     case STR_IS_XDIGIT:
-	/* Not yet implemented */
-	return TCL_ERROR;
+	return TclCompileBasicMin0ArgCmd(interp, parsePtr, cmdPtr, envPtr);
 
     case STR_IS_BOOL:
     case STR_IS_FALSE:
     case STR_IS_TRUE:
-	/* Not yet implemented */
-	return TCL_ERROR;
+	CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1);
+	OP(		TRY_CVT_TO_BOOLEAN);
+	switch (t) {
+	    int over, over2;
+
+	case STR_IS_BOOL:
+	    if (allowEmpty) {
+		JUMP1(	JUMP_TRUE, over);
+		PUSH(	"");
+		OP(	STR_EQ);
+		JUMP1(	JUMP, over2);
+		FIXJUMP1(over);
+		OP(	POP);
+		PUSH(	"1");
+		FIXJUMP1(over2);
+	    } else {
+		OP4(	REVERSE, 2);
+		OP(	POP);
+	    }
+	    return TCL_OK;
+	case STR_IS_TRUE:
+	    JUMP1(	JUMP_TRUE, over);
+	    if (allowEmpty) {
+		PUSH(	"");
+		OP(	STR_EQ);
+	    } else {
+		OP(	POP);
+		PUSH(	"0");
+	    }
+	    FIXJUMP1(	over);
+	    OP(		LNOT);
+	    OP(		LNOT);
+	    return TCL_OK;
+	case STR_IS_FALSE:
+	    JUMP1(	JUMP_TRUE, over);
+	    if (allowEmpty) {
+		PUSH(	"");
+		OP(	STR_NEQ);
+	    } else {
+		OP(	POP);
+		PUSH(	"1");
+	    }
+	    FIXJUMP1(	over);
+	    OP(		LNOT);
+	    return TCL_OK;
+	}
 
     case STR_IS_DOUBLE: {
 	int satisfied, isEmpty;
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index c01571f..39fa241 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -624,6 +624,9 @@ InstructionDesc const tclInstructionTable[] = {
     {"numericType",	 1,	0,	  0,	{OPERAND_NONE}},
 	/* Pushes the numeric type code of the word at the top of the stack.
 	 * Stack:  ... value => ... typeCode */
+    {"tryCvtToBoolean",	 1,	+1,	  0,	{OPERAND_NONE}},
+	/* Try converting stktop to boolean if possible. No errors.
+	 * Stack:  ... value => ... value isStrictBool */
 
     {NULL, 0, 0, 0, {OPERAND_NONE}}
 };
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 6bf5daf..a08a93a 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -793,9 +793,10 @@ typedef struct ByteCode {
 #define INST_TCLOO_NEXT			179
 
 #define INST_NUM_TYPE			180
+#define INST_TRY_CVT_TO_BOOLEAN		181
 
 /* The last opcode */
-#define LAST_INST_OPCODE		180
+#define LAST_INST_OPCODE		181
 
 /*
  * Table describing the Tcl bytecode instructions: their name (for displaying
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 2707ec1..989b7b6 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -6461,6 +6461,17 @@ TEBCresume(
      * -----------------------------------------------------------------
      */
 
+    case INST_TRY_CVT_TO_BOOLEAN:
+	valuePtr = OBJ_AT_TOS;
+	if (valuePtr->typePtr == &tclBooleanType) {
+	    objResultPtr = TCONST(1);
+	} else {
+	    int result = (TclSetBooleanFromAny(NULL, valuePtr) == TCL_OK);
+	    objResultPtr = TCONST(result);
+	}
+	TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(valuePtr)), objResultPtr);
+	NEXT_INST_F(1, 0, 1);
+
     case INST_BREAK:
 	/*
 	DECACHE_STACK_INFO();
-- 
cgit v0.12


From ab8fd1e3f28322c8d57229cd2e171fea351097af Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Sun, 19 Jan 2014 18:39:24 +0000
Subject: added compilation for [nextto]

---
 generic/tclAssembly.c   |   1 +
 generic/tclCompCmdsGR.c |  25 +++++++++
 generic/tclCompile.c    |  14 ++++-
 generic/tclCompile.h    |   3 +-
 generic/tclExecute.c    | 132 +++++++++++++++++++++++++++++++++++++++++++-----
 generic/tclInt.h        |   3 ++
 generic/tclOO.c         |   3 +-
 generic/tclOOBasic.c    |  20 ++++++--
 8 files changed, 179 insertions(+), 22 deletions(-)

diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 89c286a..7b775a9 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -26,6 +26,7 @@
  *-   jumpTable testing
  *-   syntax (?)
  *-   returnCodeBranch
+ *-   tclooNext, tclooNextClass
  */
 
 #include "tclInt.h"
diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c
index b8a7e0f..b3e273f 100644
--- a/generic/tclCompCmdsGR.c
+++ b/generic/tclCompCmdsGR.c
@@ -3075,6 +3075,31 @@ TclCompileObjectNextCmd(
 }
 
 int
+TclCompileObjectNextToCmd(
+    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 > 255) {
+	return TCL_ERROR;
+    }
+
+    for (i=0 ; i<parsePtr->numWords ; i++) {
+	CompileWord(envPtr, tokenPtr, interp, i);
+	tokenPtr = TokenAfter(tokenPtr);
+    }
+    TclEmitInstInt1(	INST_TCLOO_NEXT_CLASS, i,	envPtr);
+    return TCL_OK;
+}
+
+int
 TclCompileObjectSelfCmd(
     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 ee67e24..bd97e3e 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -618,8 +618,18 @@ InstructionDesc const tclInstructionTable[] = {
 	 * Stack:  ... cmdName => ... fullOriginalCmdName */
 
     {"tclooNext",	 2,	INT_MIN,  1,	{OPERAND_UINT1}},
-	/* Push the identity of the current TclOO object (i.e., the name of
-	 * its current public access command) on the stack. */
+	/* Call the next item on the TclOO call chain, passing opnd arguments
+	 * (min 1, max 255, *includes* "next").  The result of the invoked
+	 * method implementation will be pushed on the stack in place of the
+	 * arguments (similar to invokeStk).
+	 * Stack:  ... "next" arg2 arg3 -- argN => ... result */
+    {"tclooNextClass",	 2,	INT_MIN,  1,	{OPERAND_UINT1}},
+	/* Call the following item on the TclOO call chain defined by class
+	 * className, passing opnd arguments (min 2, max 255, *includes*
+	 * "nextto" and the class name). The result of the invoked method
+	 * implementation will be pushed on the stack in place of the
+	 * arguments (similar to invokeStk).
+	 * Stack:  ... "nextto" className arg3 arg4 -- argN => ... result */
 
     {NULL, 0, 0, 0, {OPERAND_NONE}}
 };
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 6ecadf4..b047855 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -791,9 +791,10 @@ typedef struct ByteCode {
 #define INST_ORIGIN_COMMAND		178
 
 #define INST_TCLOO_NEXT			179
+#define INST_TCLOO_NEXT_CLASS		180
 
 /* The last opcode */
-#define LAST_INST_OPCODE		179
+#define LAST_INST_OPCODE		180
 
 /*
  * Table describing the Tcl bytecode instructions: their name (for displaying
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 5b42124..ac0ea12 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -4539,6 +4539,7 @@ TEBCresume(
 	Object *oPtr;
 	CallFrame *framePtr;
 	CallContext *contextPtr;
+	int skip, newDepth;
 
     case INST_TCLOO_SELF:
 	framePtr = iPtr->varFramePtr;
@@ -4563,9 +4564,111 @@ TEBCresume(
 	TRACE_WITH_OBJ(("=> "), objResultPtr);
 	NEXT_INST_F(1, 0, 1);
 
+    case INST_TCLOO_NEXT_CLASS:
+	opnd = TclGetUInt1AtPtr(pc+1);
+	framePtr = iPtr->varFramePtr;
+	valuePtr = OBJ_AT_DEPTH(opnd - 2);
+	objv = &OBJ_AT_DEPTH(opnd - 1);
+	skip = 2;
+	TRACE(("%d => ", opnd));
+	if (framePtr == NULL ||
+		!(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
+	    TRACE_APPEND(("ERROR: no TclOO call context\n"));
+	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
+		    "nextto may only be called from inside a method",
+		    -1));
+	    DECACHE_STACK_INFO();
+	    Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
+	    CACHE_STACK_INFO();
+	    goto gotError;
+	}
+	contextPtr = framePtr->clientData;
+
+	oPtr = (Object *) Tcl_GetObjectFromObj(interp, valuePtr);
+	if (oPtr == NULL) {
+	    TRACE_APPEND(("ERROR: \"%.30s\" not object\n", O2S(valuePtr)));
+	    goto gotError;
+	} else {
+	    Class *classPtr = oPtr->classPtr;
+	    struct MInvoke *miPtr;
+	    int i;
+	    const char *methodType;
+
+	    if (classPtr == NULL) {
+		TRACE_APPEND(("ERROR: \"%.30s\" not class\n", O2S(valuePtr)));
+		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+			"\"%s\" is not a class", TclGetString(valuePtr)));
+		DECACHE_STACK_INFO();
+		Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_REQUIRED", NULL);
+		CACHE_STACK_INFO();
+		goto gotError;
+	    }
+
+	    for (i=contextPtr->index+1 ; i<contextPtr->callPtr->numChain ; i++) {
+		miPtr = contextPtr->callPtr->chain + i;
+		if (!miPtr->isFilter &&
+			miPtr->mPtr->declaringClassPtr == classPtr) {
+		    newDepth = i;
+#ifdef TCL_COMPILE_DEBUG
+		    if (tclTraceExec >= 2) {
+			if (traceInstructions) {
+			    strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
+			} else {
+			    fprintf(stdout, "%d: (%u) invoking ",
+				    iPtr->numLevels,
+				    (unsigned)(pc - codePtr->codeStart));
+			}
+			for (i = 0;  i < opnd;  i++) {
+			    TclPrintObject(stdout, objv[i], 15);
+			    fprintf(stdout, " ");
+			}
+			fprintf(stdout, "\n");
+			fflush(stdout);
+		    }
+#endif /*TCL_COMPILE_DEBUG*/
+		    goto doInvokeNext;
+		}
+	    }
+
+	    if (contextPtr->callPtr->flags & CONSTRUCTOR) {
+		methodType = "constructor";
+	    } else if (contextPtr->callPtr->flags & DESTRUCTOR) {
+		methodType = "destructor";
+	    } else {
+		methodType = "method";
+	    }
+
+	    TRACE_APPEND(("ERROR: \"%.30s\" not on reachable chain\n",
+		    O2S(valuePtr)));
+	    for (i=contextPtr->index ; i>=0 ; i--) {
+		miPtr = contextPtr->callPtr->chain + i;
+		if (miPtr->isFilter
+			|| miPtr->mPtr->declaringClassPtr != classPtr) {
+		    continue;
+		}
+		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+			"%s implementation by \"%s\" not reachable from here",
+			methodType, TclGetString(valuePtr)));
+		DECACHE_STACK_INFO();
+		Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_REACHABLE",
+			NULL);
+		CACHE_STACK_INFO();
+		goto gotError;
+	    }
+	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+		    "%s has no non-filter implementation by \"%s\"",
+		    methodType, TclGetString(valuePtr)));
+	    DECACHE_STACK_INFO();
+	    Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_THERE", NULL);
+	    CACHE_STACK_INFO();
+	    goto gotError;
+	}
+
     case INST_TCLOO_NEXT:
 	opnd = TclGetUInt1AtPtr(pc+1);
+	objv = &OBJ_AT_DEPTH(opnd - 1);
 	framePtr = iPtr->varFramePtr;
+	skip = 1;
 	TRACE(("%d => ", opnd));
 	if (framePtr == NULL ||
 		!(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
@@ -4580,7 +4683,8 @@ TEBCresume(
 	}
 	contextPtr = framePtr->clientData;
 
-	if (contextPtr->index+1 >= contextPtr->callPtr->numChain) {
+	newDepth = contextPtr->index + 1;
+	if (newDepth >= contextPtr->callPtr->numChain) {
 	    /*
 	     * We're at the end of the chain; generate an error message unless
 	     * the interpreter is being torn down, in which case we might be
@@ -4605,33 +4709,31 @@ TEBCresume(
 	    Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL);
 	    CACHE_STACK_INFO();
 	    goto gotError;
-	}
-
 #ifdef TCL_COMPILE_DEBUG
-	if (tclTraceExec >= 2) {
+	} else if (tclTraceExec >= 2) {
 	    int i;
 
 	    if (traceInstructions) {
 		strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
-		TRACE(("next_in_chain "));
 	    } else {
-		fprintf(stdout, "%d: (%u) invoking next_in_chain ",
+		fprintf(stdout, "%d: (%u) invoking ",
 			iPtr->numLevels, (unsigned)(pc - codePtr->codeStart));
 	    }
-	    for (i = 0;  i < objc;  i++) {
+	    for (i = 0;  i < opnd;  i++) {
 		TclPrintObject(stdout, objv[i], 15);
 		fprintf(stdout, " ");
 	    }
 	    fprintf(stdout, "\n");
 	    fflush(stdout);
-	}
 #endif /*TCL_COMPILE_DEBUG*/
+	}
 
+    doInvokeNext:
 	bcFramePtr->data.tebc.pc = (char *) pc;
 	iPtr->cmdFramePtr = bcFramePtr;
 
 	if (iPtr->flags & INTERP_DEBUG_FRAME) {
-	    ArgumentBCEnter(interp, codePtr, TD, pc, objc, objv);
+	    ArgumentBCEnter(interp, codePtr, TD, pc, opnd, objv);
 	}
 
 	pcAdjustment = 2;
@@ -4640,6 +4742,7 @@ TEBCresume(
 	iPtr->varFramePtr = framePtr->callerVarPtr;
 	pc += pcAdjustment;
 	TEBC_YIELD();
+
 	oPtr = contextPtr->oPtr;
 	if (oPtr->flags & FILTER_HANDLING) {
 	    TclNRAddCallback(interp, FinalizeOONextFilter,
@@ -4650,20 +4753,21 @@ TEBCresume(
 		    framePtr, contextPtr, INT2PTR(contextPtr->index),
 		    INT2PTR(contextPtr->skip));
 	}
-	if (contextPtr->callPtr->chain[++contextPtr->index].isFilter
+	contextPtr->skip = skip;
+	contextPtr->index = newDepth;
+	if (contextPtr->callPtr->chain[newDepth].isFilter
 		|| contextPtr->callPtr->flags & FILTER_HANDLING) {
 	    oPtr->flags |= FILTER_HANDLING;
 	} else {
 	    oPtr->flags &= ~FILTER_HANDLING;
 	}
-	contextPtr->skip = 1;
+
 	{
 	    register Method *const mPtr =
-		    contextPtr->callPtr->chain[contextPtr->index].mPtr;
+		    contextPtr->callPtr->chain[newDepth].mPtr;
 
 	    return mPtr->typePtr->callProc(mPtr->clientData, interp,
-		    (Tcl_ObjectContext) contextPtr, opnd,
-		    &OBJ_AT_DEPTH(opnd-1));
+		    (Tcl_ObjectContext) contextPtr, opnd, objv);
 	}
 
     case INST_TCLOO_IS_OBJECT:
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 3aaa30b..7932a58 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3592,6 +3592,9 @@ MODULE_SCOPE int	TclCompileNoOp(Tcl_Interp *interp,
 MODULE_SCOPE int	TclCompileObjectNextCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
+MODULE_SCOPE int	TclCompileObjectNextToCmd(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);
diff --git a/generic/tclOO.c b/generic/tclOO.c
index 9a0682d..de00733 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -440,8 +440,9 @@ InitFoundation(
     cmdPtr = (Command *) Tcl_NRCreateCommand(interp, "::oo::Helpers::next",
 	    NULL, TclOONextObjCmd, NULL, NULL);
     cmdPtr->compileProc = TclCompileObjectNextCmd;
-    Tcl_NRCreateCommand(interp, "::oo::Helpers::nextto",
+    cmdPtr = (Command *) Tcl_NRCreateCommand(interp, "::oo::Helpers::nextto",
 	    NULL, TclOONextToObjCmd, NULL, NULL);
+    cmdPtr->compileProc = TclCompileObjectNextToCmd;
     cmdPtr = (Command *) Tcl_CreateObjCommand(interp, "::oo::Helpers::self",
 	    TclOOSelfObjCmd, NULL, NULL);
     cmdPtr->compileProc = TclCompileObjectSelfCmd;
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index 6084cf2..0b0516b 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -821,6 +821,7 @@ TclOONextToObjCmd(
     CallContext *contextPtr;
     int i;
     Tcl_Object object;
+    const char *methodType;
 
     /*
      * Start with sanity checks on the calling context to make sure that we
@@ -886,19 +887,30 @@ TclOONextToObjCmd(
      * is on the chain but unreachable, or not on the chain at all.
      */
 
+    if (contextPtr->callPtr->flags & CONSTRUCTOR) {
+	methodType = "constructor";
+    } else if (contextPtr->callPtr->flags & DESTRUCTOR) {
+	methodType = "destructor";
+    } else {
+	methodType = "method";
+    }
+
     for (i=contextPtr->index ; i>=0 ; i--) {
 	struct MInvoke *miPtr = contextPtr->callPtr->chain + i;
 
 	if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) {
 	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
-		    "method implementation by \"%s\" not reachable from here",
-		    TclGetString(objv[1])));
+		    "%s implementation by \"%s\" not reachable from here",
+		    methodType, TclGetString(objv[1])));
+	    Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_REACHABLE",
+		    NULL);
 	    return TCL_ERROR;
 	}
     }
     Tcl_SetObjResult(interp, Tcl_ObjPrintf(
-	    "method has no non-filter implementation by \"%s\"",
-	    TclGetString(objv[1])));
+	    "%s has no non-filter implementation by \"%s\"",
+	    methodType, TclGetString(objv[1])));
+    Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_THERE", NULL);
     return TCL_ERROR;
 }
 
-- 
cgit v0.12


From 61bfac2613d3cc063099ad9e6de3110491b6f5df Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Tue, 21 Jan 2014 15:07:59 +0000
Subject: implementation of [yieldto] in bytecode

---
 generic/tclBasic.c      |  2 +-
 generic/tclCompCmdsSZ.c | 45 +++++++++++++++++++++++++++++++
 generic/tclCompile.c    |  7 +++++
 generic/tclCompile.h    |  4 ++-
 generic/tclExecute.c    | 71 ++++++++++++++++++++++++++++++++++++++++++-------
 generic/tclInt.h        |  3 +++
 6 files changed, 121 insertions(+), 11 deletions(-)

diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 7c02706..e355229 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -259,7 +259,7 @@ static const CmdInfo builtInCmds[] = {
     {"variable",	Tcl_VariableObjCmd,	TclCompileVariableCmd,	NULL,	CMD_IS_SAFE},
     {"while",		Tcl_WhileObjCmd,	TclCompileWhileCmd,	TclNRWhileObjCmd,	CMD_IS_SAFE},
     {"yield",		NULL,			TclCompileYieldCmd,	TclNRYieldObjCmd,	CMD_IS_SAFE},
-    {"yieldto",		NULL,			NULL,			TclNRYieldToObjCmd,	CMD_IS_SAFE},
+    {"yieldto",		NULL,			TclCompileYieldToCmd,	TclNRYieldToObjCmd,	CMD_IS_SAFE},
 
     /*
      * Commands in the OS-interface. Note that many of these are unsafe.
diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index 0f2790f..5c132b4 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -3447,6 +3447,51 @@ TclCompileYieldCmd(
 /*
  *----------------------------------------------------------------------
  *
+ * TclCompileYieldToCmd --
+ *
+ *	Procedure called to compile the "yieldto" 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 "yieldto" command at
+ *	runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileYieldToCmd(
+    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 = TokenAfter(parsePtr->tokenPtr);
+    int i;
+
+    if (parsePtr->numWords < 2) {
+	return TCL_ERROR;
+    }
+
+    OP(		NS_CURRENT);
+    for (i = 1 ; i < parsePtr->numWords ; i++) {
+	CompileWord(envPtr, tokenPtr, interp, i);
+	tokenPtr = TokenAfter(tokenPtr);
+    }
+    OP4(	LIST, i);
+    OP(		YIELD_TO_INVOKE);
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * CompileUnaryOpCmd --
  *
  *	Utility routine to compile the unary operator commands.
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index bd97e3e..f75ac83 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -631,6 +631,13 @@ InstructionDesc const tclInstructionTable[] = {
 	 * arguments (similar to invokeStk).
 	 * Stack:  ... "nextto" className arg3 arg4 -- argN => ... result */
 
+    {"yieldToInvoke",	 1,	0,	  0,	{OPERAND_NONE}},
+	/* Makes the current coroutine yield the value at the top of the
+	 * stack, invoking the given command/args with resolution in the given
+	 * namespace (all packed into a list), and places the list of values
+	 * that are the response back on top of the stack when it resumes.
+	 * Stack:  ... [list ns cmd arg1 ... argN] => ... resumeList */
+
     {NULL, 0, 0, 0, {OPERAND_NONE}}
 };
 
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index b047855..7994e2c 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -793,8 +793,10 @@ typedef struct ByteCode {
 #define INST_TCLOO_NEXT			179
 #define INST_TCLOO_NEXT_CLASS		180
 
+#define INST_YIELD_TO_INVOKE		181
+
 /* The last opcode */
-#define LAST_INST_OPCODE		180
+#define LAST_INST_OPCODE		181
 
 /*
  * Table describing the Tcl bytecode instructions: their name (for displaying
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index ac0ea12..575f227 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -2494,9 +2494,12 @@ TEBCresume(
 	TRACE_APPEND(("\n"));
 	goto processExceptionReturn;
 
-    case INST_YIELD: {
-	CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
+    {
+	CoroutineData *corPtr;
+	int yieldParameter;
 
+    case INST_YIELD:
+	corPtr = iPtr->execEnvPtr->corPtr;
 	TRACE(("%.30s => ", O2S(OBJ_AT_TOS)));
 	if (!corPtr) {
 	    TRACE_APPEND(("ERROR: yield outside coroutine\n"));
@@ -2510,11 +2513,63 @@ TEBCresume(
 	}
 
 #ifdef TCL_COMPILE_DEBUG
-	TRACE_WITH_OBJ(("yield, result="), iPtr->objResultPtr);
-	if (traceInstructions) {
-	    fprintf(stdout, "\n");
+	if (tclTraceExec >= 2) {
+	    if (traceInstructions) {
+		TRACE_APPEND(("YIELD...\n"));
+	    } else {
+		fprintf(stdout, "%d: (%u) yielding value \"%.30s\"\n",
+			iPtr->numLevels, (unsigned)(pc - codePtr->codeStart),
+			Tcl_GetString(OBJ_AT_TOS));
+	    }
+	    fflush(stdout);
+	}
+#endif
+	yieldParameter = 0;
+	Tcl_SetObjResult(interp, OBJ_AT_TOS);
+	goto doYield;
+
+    case INST_YIELD_TO_INVOKE:
+	corPtr = iPtr->execEnvPtr->corPtr;
+	valuePtr = OBJ_AT_TOS;
+	if (!corPtr) {
+	    TRACE(("[%.30s] => ERROR: yield outside coroutine\n",
+		    O2S(valuePtr)));
+	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
+		    "yieldto can only be called in a coroutine", -1));
+	    DECACHE_STACK_INFO();
+	    Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD",
+		    NULL);
+	    CACHE_STACK_INFO();
+	    goto gotError;
+	}
+
+#ifdef TCL_COMPILE_DEBUG
+	if (tclTraceExec >= 2) {
+	    if (traceInstructions) {
+		TRACE(("[%.30s] => YIELD...\n", O2S(valuePtr)));
+	    } else {
+		/* FIXME: What is the right thing to trace? */
+		fprintf(stdout, "%d: (%u) yielding to [%.30s]\n",
+			iPtr->numLevels, (unsigned)(pc - codePtr->codeStart),
+			Tcl_GetString(valuePtr));
+	    }
+	    fflush(stdout);
 	}
 #endif
+
+	/*
+	 * Install a tailcall record in the caller and continue with the
+	 * yield. The yield is switched into multi-return mode (via the
+	 * 'yieldParameter').
+	 */
+
+	Tcl_IncrRefCount(valuePtr);
+	iPtr->execEnvPtr = corPtr->callerEEPtr;
+	TclSetTailcall(interp, valuePtr);
+	iPtr->execEnvPtr = corPtr->eePtr;
+	yieldParameter = (PTR2INT(NULL)+1);	/*==CORO_ACTIVATE_YIELDM*/
+
+    doYield:
 	/* TIP #280: Record the last piece of info needed by
 	 * 'TclGetSrcInfoForPc', and push the frame.
 	 */
@@ -2529,11 +2584,8 @@ TEBCresume(
 	pc++;
 	cleanup = 1;
 	TEBC_YIELD();
-	
-	Tcl_SetObjResult(interp, OBJ_AT_TOS);
 	TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr,
-		INT2PTR(0), NULL, NULL);
-
+		INT2PTR(yieldParameter), NULL, NULL);
 	return TCL_OK;
     }
 
@@ -2553,6 +2605,7 @@ TEBCresume(
 	}
 
 #ifdef TCL_COMPILE_DEBUG
+	/* FIXME: What is the right thing to trace? */
 	{
 	    register int i;
 
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 7932a58..6ddb015 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3688,6 +3688,9 @@ MODULE_SCOPE int	TclCompileWhileCmd(Tcl_Interp *interp,
 MODULE_SCOPE int	TclCompileYieldCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
+MODULE_SCOPE int	TclCompileYieldToCmd(Tcl_Interp *interp,
+			    Tcl_Parse *parsePtr, Command *cmdPtr,
+			    struct CompileEnv *envPtr);
 MODULE_SCOPE int	TclCompileBasic0ArgCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
-- 
cgit v0.12


From 78a75740ae5c82cc161e49e5e28a306fa9f2a580 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Wed, 22 Jan 2014 09:07:45 +0000
Subject: [a90d9331bc]: must not crash when yieldto called in vanishing
 namespace

---
 generic/tclBasic.c   | 18 ++++------
 generic/tclExecute.c | 11 +++++++
 tests/coroutine.test | 92 +++++++++++++++++++++++++++++++++++++++++++++++++---
 3 files changed, 105 insertions(+), 16 deletions(-)

diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index e355229..cb9428c 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -8431,11 +8431,13 @@ TclNRYieldToObjCmd(
 	return TCL_ERROR;
     }
 
-    /*
-     * Add the tailcall in the caller env, then just yield.
-     *
-     * This is essentially code from TclNRTailcallObjCmd
-     */
+    if (((Namespace *) TclGetCurrentNamespace(interp))->flags & NS_DYING) {
+        Tcl_SetObjResult(interp, Tcl_NewStringObj(
+		"yieldto called in deleted namespace", -1));
+        Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "YIELDTO_IN_DELETED",
+		NULL);
+        return TCL_ERROR;
+    }
 
     /*
      * Add the tailcall in the caller env, then just yield.
@@ -8444,15 +8446,9 @@ TclNRYieldToObjCmd(
      */
 
     listPtr = Tcl_NewListObj(objc, objv);
-
     nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1);
-    if ((TCL_OK != TclGetNamespaceFromObj(interp, nsObjPtr, &ns1Ptr))
-	    || (nsPtr != ns1Ptr)) {
-	Tcl_Panic("yieldto failed to find the proper namespace");
-    }
     TclListObjSetElement(interp, listPtr, 0, nsObjPtr);
 
-
     /*
      * Add the callback in the caller's env, then instruct TEBC to yield.
      */
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 575f227..6749120 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -2542,6 +2542,17 @@ TEBCresume(
 	    CACHE_STACK_INFO();
 	    goto gotError;
 	}
+	if (((Namespace *)TclGetCurrentNamespace(interp))->flags & NS_DYING) {
+	    TRACE(("[%.30s] => ERROR: yield in deleted\n",
+		    O2S(valuePtr)));
+	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
+		    "yieldto called in deleted namespace", -1));
+	    DECACHE_STACK_INFO();
+	    Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "YIELDTO_IN_DELETED",
+		    NULL);
+	    CACHE_STACK_INFO();
+	    goto gotError;
+	}
 
 #ifdef TCL_COMPILE_DEBUG
 	if (tclTraceExec >= 2) {
diff --git a/tests/coroutine.test b/tests/coroutine.test
index a360fd5..05b58c9 100644
--- a/tests/coroutine.test
+++ b/tests/coroutine.test
@@ -1,4 +1,4 @@
-# Commands covered:  coroutine, yield, [info coroutine]
+# Commands covered:  coroutine, yield, yieldto, [info coroutine]
 #
 # This file contains a collection of tests for experimental commands that are
 # found in ::tcl::unsupported. The tests will migrate to normal test files
@@ -612,7 +612,6 @@ test coroutine-7.3 {yielding between coroutines} -body {
 } -cleanup {
     catch {rename juggler ""}
 } -result {{{a b c d e} ::j1 {a b c d} ::j2 {a b c} ::j3 {a b} ::j1 a ::j2} {} {} {}}
-
 test coroutine-7.4 {Bug 8ff0cb9fe1} -setup {
     proc foo {a b} {catch yield; return 1}
 } -cleanup {
@@ -620,7 +619,6 @@ test coroutine-7.4 {Bug 8ff0cb9fe1} -setup {
 } -body {
     coroutine demo lsort -command foo {a b}
 } -result {b a}
-
 test coroutine-7.5 {return codes} {
     set result {}
     foreach code {0 1 2 3 4 5} {
@@ -628,14 +626,12 @@ test coroutine-7.5 {return codes} {
     }
     set result
 } {0 1 2 3 4 5}
-
 test coroutine-7.6 {Early yield crashes} {
     proc foo args {}
     trace add execution foo enter {catch yield}
     coroutine demo foo
     rename foo {}
 } {}
-
 test coroutine-7.7 {Bug 2486550} -setup {
     interp hide {} yield
 } -body {
@@ -644,6 +640,92 @@ test coroutine-7.7 {Bug 2486550} -setup {
     demo
     interp expose {} yield
 } -result ok
+test coroutine-7.8 {yieldto context nuke: Bug a90d9331bc} -setup {
+    namespace eval cotest {}
+    set ::result ""
+} -body {
+    proc cotest::body {} {
+	lappend ::result a
+	yield OUT
+	lappend ::result b
+	yieldto ::return -level 0 123
+	lappend ::result c
+	return
+    }
+    lappend ::result [coroutine cotest cotest::body]
+    namespace delete cotest
+    namespace eval cotest {}
+    lappend ::result [cotest]
+    cotest
+    return $result
+} -returnCodes error -cleanup {
+    catch {namespace delete ::cotest}
+    catch {rename cotest ""}
+} -result {yieldto called in deleted namespace}
+test coroutine-7.9 {yieldto context nuke: Bug a90d9331bc} -setup {
+    namespace eval cotest {}
+    set ::result ""
+} -body {
+    proc cotest::body {} {
+	set y ::yieldto
+	lappend ::result a
+	yield OUT
+	lappend ::result b
+	$y ::return -level 0 123
+	lappend ::result c
+	return
+    }
+    lappend ::result [coroutine cotest cotest::body]
+    namespace delete cotest
+    namespace eval cotest {}
+    lappend ::result [cotest]
+    cotest
+    return $result
+} -returnCodes error -cleanup {
+    catch {namespace delete ::cotest}
+    catch {rename cotest ""}
+} -result {yieldto called in deleted namespace}
+test coroutine-7.10 {yieldto context nuke: Bug a90d9331bc} -setup {
+    namespace eval cotest {}
+    set ::result ""
+} -body {
+    proc cotest::body {} {
+	lappend ::result a
+	yield OUT
+	lappend ::result b
+	yieldto ::return -level 0 -cotest [namespace delete ::cotest] 123
+	lappend ::result c
+	return
+    }
+    lappend ::result [coroutine cotest cotest::body]
+    lappend ::result [cotest]
+    cotest
+    return $result
+} -returnCodes error -cleanup {
+    catch {namespace delete ::cotest}
+    catch {rename cotest ""}
+} -result {yieldto called in deleted namespace}
+test coroutine-7.11 {yieldto context nuke: Bug a90d9331bc} -setup {
+    namespace eval cotest {}
+    set ::result ""
+} -body {
+    proc cotest::body {} {
+	set y ::yieldto
+	lappend ::result a
+	yield OUT
+	lappend ::result b
+	$y ::return -level 0 -cotest [namespace delete ::cotest] 123
+	lappend ::result c
+	return
+    }
+    lappend ::result [coroutine cotest cotest::body]
+    lappend ::result [cotest]
+    cotest
+    return $result
+} -returnCodes error -cleanup {
+    catch {namespace delete ::cotest}
+    catch {rename cotest ""}
+} -result {yieldto called in deleted namespace}
 
 
 # cleanup
-- 
cgit v0.12


From 6e072443704a589149fea001df51f9870b78c323 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Wed, 22 Jan 2014 09:14:57 +0000
Subject: minor tidying up

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

diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index cb9428c..46b532b 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -8416,8 +8416,7 @@ TclNRYieldToObjCmd(
 {
     CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
     Tcl_Obj *listPtr, *nsObjPtr;
-    Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
-    Tcl_Namespace *ns1Ptr;
+    Tcl_Namespace *nsPtr = TclGetCurrentNamespace(interp);
 
     if (objc < 2) {
 	Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?");
@@ -8431,7 +8430,7 @@ TclNRYieldToObjCmd(
 	return TCL_ERROR;
     }
 
-    if (((Namespace *) TclGetCurrentNamespace(interp))->flags & NS_DYING) {
+    if (((Namespace *) nsPtr)->flags & NS_DYING) {
         Tcl_SetObjResult(interp, Tcl_NewStringObj(
 		"yieldto called in deleted namespace", -1));
         Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "YIELDTO_IN_DELETED",
-- 
cgit v0.12


From 60e360f12b1c25a8e89f5893a564ca17d3b99217 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Wed, 29 Jan 2014 13:59:32 +0000
Subject: Compile [string is] with character classes in a non-awful way. Needs
 more work to make resulting bytecode disassemble nicely.

---
 generic/tclCompCmdsSZ.c | 99 ++++++++++++++++++++++++++++++++++++++++++++-----
 generic/tclCompile.c    |  5 +++
 generic/tclCompile.h    | 37 +++++++++++++++++-
 generic/tclExecute.c    | 19 ++++++++++
 4 files changed, 150 insertions(+), 10 deletions(-)

diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index 1a69a89..639b4a5 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -452,6 +452,7 @@ TclCompileStringIsCmd(
 	STR_IS_XDIGIT
     };
     int t, range, allowEmpty = 0, end;
+    InstStringClassType strClassType;
     Tcl_Obj *isClass;
 
     if (parsePtr->numWords < 3 || parsePtr->numWords > 6) {
@@ -486,7 +487,7 @@ TclCompileStringIsCmd(
 
     tokenPtr = TokenAfter(tokenPtr);
     if (parsePtr->numWords == 3) {
-	allowEmpty = (t != STR_IS_LIST);
+	allowEmpty = 1;
     } else {
 	if (!GotLiteral(tokenPtr, "-strict")) {
 	    return TCL_ERROR;
@@ -496,30 +497,77 @@ TclCompileStringIsCmd(
 #undef GotLiteral
 
     /*
-     * Some types are not currently handled. Character classes are a prime
-     * example of this.
+     * Compile the code. There are several main classes of check here.
+     *	1. Character classes
+     *	2. Booleans
+     *	3. Integers
+     *	4. Floats
+     *	5. Lists
      */
 
+    CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1);
+
     switch ((enum isClasses) t) {
     case STR_IS_ALNUM:
+	strClassType = STR_CLASS_ALNUM;
+	goto compileStrClass;
     case STR_IS_ALPHA:
+	strClassType = STR_CLASS_ALPHA;
+	goto compileStrClass;
     case STR_IS_ASCII:
+	strClassType = STR_CLASS_ASCII;
+	goto compileStrClass;
     case STR_IS_CONTROL:
+	strClassType = STR_CLASS_CONTROL;
+	goto compileStrClass;
     case STR_IS_DIGIT:
+	strClassType = STR_CLASS_DIGIT;
+	goto compileStrClass;
     case STR_IS_GRAPH:
+	strClassType = STR_CLASS_GRAPH;
+	goto compileStrClass;
     case STR_IS_LOWER:
+	strClassType = STR_CLASS_LOWER;
+	goto compileStrClass;
     case STR_IS_PRINT:
+	strClassType = STR_CLASS_PRINT;
+	goto compileStrClass;
     case STR_IS_PUNCT:
+	strClassType = STR_CLASS_PUNCT;
+	goto compileStrClass;
     case STR_IS_SPACE:
+	strClassType = STR_CLASS_SPACE;
+	goto compileStrClass;
     case STR_IS_UPPER:
+	strClassType = STR_CLASS_UPPER;
+	goto compileStrClass;
     case STR_IS_WORD:
+	strClassType = STR_CLASS_WORD;
+	goto compileStrClass;
     case STR_IS_XDIGIT:
-	return TclCompileBasicMin0ArgCmd(interp, parsePtr, cmdPtr, envPtr);
+	strClassType = STR_CLASS_XDIGIT;
+    compileStrClass:
+	if (allowEmpty) {
+	    OP1(	STR_CLASS, strClassType);
+	} else {
+	    int over, over2;
+
+	    OP(		DUP);
+	    OP1(	STR_CLASS, strClassType);
+	    JUMP1(	JUMP_TRUE, over);
+	    OP(		POP);
+	    PUSH(	"0");
+	    JUMP1(	JUMP, over2);
+	    FIXJUMP1(over);
+	    PUSH(	"");
+	    OP(		STR_NEQ);
+	    FIXJUMP1(over2);
+	}
+	return TCL_OK;
 
     case STR_IS_BOOL:
     case STR_IS_FALSE:
     case STR_IS_TRUE:
-	CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1);
 	OP(		TRY_CVT_TO_BOOLEAN);
 	switch (t) {
 	    int over, over2;
@@ -569,7 +617,6 @@ TclCompileStringIsCmd(
     case STR_IS_DOUBLE: {
 	int satisfied, isEmpty;
 
-	CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1);
 	if (allowEmpty) {
 	    OP(		DUP);
 	    PUSH(	"");
@@ -598,7 +645,6 @@ TclCompileStringIsCmd(
     case STR_IS_INT:
     case STR_IS_WIDE:
     case STR_IS_ENTIER:
-	CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1);
 	if (allowEmpty) {
 	    int testNumType;
 
@@ -638,7 +684,6 @@ TclCompileStringIsCmd(
 	return TCL_OK;
 
     case STR_IS_LIST:
-	CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1);
 	range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
 	OP4(		BEGIN_CATCH4, range);
 	ExceptionRangeStarts(envPtr, range);
@@ -653,7 +698,8 @@ TclCompileStringIsCmd(
 	OP(		LNOT);
 	return TCL_OK;
     }
-    return TCL_ERROR;
+
+    return TclCompileBasicMin0ArgCmd(interp, parsePtr, cmdPtr, envPtr);
 }
 
 int
@@ -1171,6 +1217,41 @@ TclCompileStringToTitleCmd(
 }
 
 /*
+ * Support definitions for the [string is] compilation.
+ */
+
+static int
+UniCharIsAscii(
+    int character)
+{
+    return (character >= 0) && (character < 0x80);
+}
+
+static int
+UniCharIsHexDigit(
+    int character)
+{
+    return (character >= 0) && (character < 0x80) && isxdigit(character);
+}
+
+StringClassDesc const tclStringClassTable[] = {
+    {"alnum",	Tcl_UniCharIsAlnum},
+    {"alpha",	Tcl_UniCharIsAlpha},
+    {"ascii",	UniCharIsAscii},
+    {"control", Tcl_UniCharIsControl},
+    {"digit",	Tcl_UniCharIsDigit},
+    {"graph",	Tcl_UniCharIsGraph},
+    {"lower",	Tcl_UniCharIsLower},
+    {"print",	Tcl_UniCharIsPrint},
+    {"punct",	Tcl_UniCharIsPunct},
+    {"space",	Tcl_UniCharIsSpace},
+    {"upper",	Tcl_UniCharIsUpper},
+    {"word",	Tcl_UniCharIsWordChar},
+    {"xdigit",	UniCharIsHexDigit},
+    {NULL,	NULL}
+};
+
+/*
  *----------------------------------------------------------------------
  *
  * TclCompileSubstCmd --
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index fdc3e26..08a7a4c 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -644,6 +644,11 @@ InstructionDesc const tclInstructionTable[] = {
     {"tryCvtToBoolean",	 1,	+1,	  0,	{OPERAND_NONE}},
 	/* Try converting stktop to boolean if possible. No errors.
 	 * Stack:  ... value => ... value isStrictBool */
+    {"strclass",	 2,	0,	  1,	{OPERAND_UINT1}},
+	/* See if all the characters of the given string are a member of the
+	 * specified (by opnd) character class. Note that an empty string will
+	 * satisfy the class check (standard definition of "all").
+	 * Stack:  ... stringValue => ... boolean */
 
     {NULL, 0, 0, 0, {OPERAND_NONE}}
 };
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index d6d515d..502a2e6 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -797,9 +797,10 @@ typedef struct ByteCode {
 
 #define INST_NUM_TYPE			182
 #define INST_TRY_CVT_TO_BOOLEAN		183
+#define INST_STR_CLASS			184
 
 /* The last opcode */
-#define LAST_INST_OPCODE		183
+#define LAST_INST_OPCODE		184
 
 /*
  * Table describing the Tcl bytecode instructions: their name (for displaying
@@ -844,6 +845,40 @@ typedef struct InstructionDesc {
 MODULE_SCOPE InstructionDesc const tclInstructionTable[];
 
 /*
+ * Constants used by INST_STRING_CLASS to indicate character classes. These
+ * correspond closely by name with what [string is] can support, but there is
+ * no requirement to keep the values the same.
+ */
+
+typedef enum InstStringClassType {
+    STR_CLASS_ALNUM,		/* Unicode alphabet or digit characters. */
+    STR_CLASS_ALPHA,		/* Unicode alphabet characters. */
+    STR_CLASS_ASCII,		/* Characters in range U+000000..U+00007F. */
+    STR_CLASS_CONTROL,		/* Unicode control characters. */
+    STR_CLASS_DIGIT,		/* Unicode digit characters. */
+    STR_CLASS_GRAPH,		/* Unicode printing characters, excluding
+				 * space. */
+    STR_CLASS_LOWER,		/* Unicode lower-case alphabet characters. */
+    STR_CLASS_PRINT,		/* Unicode printing characters, including
+				 * spaces. */
+    STR_CLASS_PUNCT,		/* Unicode punctuation characters. */
+    STR_CLASS_SPACE,		/* Unicode space characters. */
+    STR_CLASS_UPPER,		/* Unicode upper-case alphabet characters. */
+    STR_CLASS_WORD,		/* Unicode word (alphabetic, digit, connector
+				 * punctuation) characters. */
+    STR_CLASS_XDIGIT		/* Characters that can be used as digits in
+				 * hexadecimal numbers ([0-9A-Fa-f]). */
+} InstStringClassType;
+
+typedef struct StringClassDesc {
+    const char *name;		/* Name of the class. */
+    int (*comparator)(int);	/* Function to test if a single unicode
+				 * character is a member of the class. */
+} StringClassDesc;
+
+MODULE_SCOPE StringClassDesc const tclStringClassTable[];
+
+/*
  * Compilation of some Tcl constructs such as if commands and the logical or
  * (||) and logical and (&&) operators in expressions requires the generation
  * of forward jumps. Since the PC target of these jumps isn't known when the
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 916de17..58d85e1 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -5810,6 +5810,25 @@ TEBCresume(
 
 	TclNewIntObj(objResultPtr, match);
 	NEXT_INST_F(1, 2, 1);
+
+    case INST_STR_CLASS:
+	opnd = TclGetInt1AtPtr(pc+1);
+	valuePtr = OBJ_AT_TOS;
+	TRACE(("%s \"%.30s\" => ", tclStringClassTable[opnd].name,
+		O2S(valuePtr)));
+	ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length);
+	match = 1;
+	if (length > 0) {
+	    end = ustring1 + length;
+	    for (p=ustring1 ; p<end ; p++) {
+		if (!tclStringClassTable[opnd].comparator(*p)) {
+		    match = 0;
+		    break;
+		}
+	    }
+	}
+	TRACE_APPEND(("%d\n", match));
+	JUMP_PEEPHOLE_F(match, 2, 1);
     }
 
     case INST_STR_MATCH:
-- 
cgit v0.12


From 347264f196f57e2f4433f33dbaa6c8e2e4a2c83d Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Sun, 2 Feb 2014 14:42:12 +0000
Subject: improve the disassembly

---
 generic/tclCompile.c | 7 ++++++-
 generic/tclCompile.h | 3 ++-
 2 files changed, 8 insertions(+), 2 deletions(-)

diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 08a7a4c..c5d0107 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -644,7 +644,7 @@ InstructionDesc const tclInstructionTable[] = {
     {"tryCvtToBoolean",	 1,	+1,	  0,	{OPERAND_NONE}},
 	/* Try converting stktop to boolean if possible. No errors.
 	 * Stack:  ... value => ... value isStrictBool */
-    {"strclass",	 2,	0,	  1,	{OPERAND_UINT1}},
+    {"strclass",	 2,	0,	  1,	{OPERAND_SCLS1}},
 	/* See if all the characters of the given string are a member of the
 	 * specified (by opnd) character class. Note that an empty string will
 	 * satisfy the class check (standard definition of "all").
@@ -5097,6 +5097,11 @@ FormatInstruction(
 	    }
 	    Tcl_AppendPrintfToObj(bufferObj, "%%v%u ", (unsigned) opnd);
 	    break;
+	case OPERAND_SCLS1:
+	    opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++;
+	    Tcl_AppendPrintfToObj(bufferObj, "%s ",
+		    tclStringClassTable[opnd].name);
+	    break;
 	case OPERAND_NONE:
 	default:
 	    break;
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 502a2e6..5665ca9 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -825,8 +825,9 @@ typedef enum InstOperandType {
 				 * variable table. */
     OPERAND_LVT4,		/* Four byte unsigned index into the local
 				 * variable table. */
-    OPERAND_AUX4		/* Four byte unsigned index into the aux data
+    OPERAND_AUX4,		/* Four byte unsigned index into the aux data
 				 * table. */
+    OPERAND_SCLS1		/* Index into tclStringClassTable. */
 } InstOperandType;
 
 typedef struct InstructionDesc {
-- 
cgit v0.12