* generic/tclBasic.c: Completed the NR-enabling of [subst].

        * generic/tclCmdMZ.c:   [Bug 2314561].
        * generic/tclCompCmds.c:
        * generic/tclCompile.c:
        * generic/tclInt.h:
        * tests/coroutine.test:
        * tests/parse.test:

8 files changed, 215 insertions, 30 deletions

diff --git a/ChangeLog b/ChangeLog
index a597ccc..b0efb5e 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,13 @@
+2009-09-11  Don Porter  <dgp@users.sourceforge.net>
+
+	* generic/tclBasic.c:	Completed the NR-enabling of [subst].
+	* generic/tclCmdMZ.c:	[Bug 2314561].
+	* generic/tclCompCmds.c:
+	* generic/tclCompile.c:
+	* generic/tclInt.h:
+	* tests/coroutine.test:
+	* tests/parse.test:
+
 2009-09-11  Donal K. Fellows  <dkf@users.sf.net>
 
 	* tests/http.test: Added in cleaning up of http tokens for each test
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index b5abbc2..7064b86 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -16,7 +16,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclBasic.c,v 1.403 2009/09/04 17:33:11 dgp Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.404 2009/09/11 20:13:27 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -213,7 +213,7 @@ static const CmdInfo builtInCmds[] = {
     {"scan",		Tcl_ScanObjCmd,		NULL,			NULL,	1},
     {"set",		Tcl_SetObjCmd,		TclCompileSetCmd,	NULL,	1},
     {"split",		Tcl_SplitObjCmd,	NULL,			NULL,	1},
-    {"subst",		Tcl_SubstObjCmd,	TclCompileSubstCmd,	NULL,	1},
+    {"subst",		Tcl_SubstObjCmd,	TclCompileSubstCmd,	TclNRSubstObjCmd,	1},
     {"switch",		Tcl_SwitchObjCmd,	TclCompileSwitchCmd,	TclNRSwitchObjCmd, 1},
     {"throw",		Tcl_ThrowObjCmd,	NULL,			NULL,	1},
     {"trace",		Tcl_TraceObjCmd,	NULL,			NULL,	1},
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index a5a2f1b..72b46af 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -15,7 +15,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclCmdMZ.c,v 1.192 2009/09/04 17:33:11 dgp Exp $
+ * RCS: @(#) $Id: tclCmdMZ.c,v 1.193 2009/09/11 20:13:27 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -3419,7 +3419,16 @@ Tcl_SubstObjCmd(
     int objc,			/* Number of arguments. */
     Tcl_Obj *const objv[])	/* Argument objects. */
 {
-    Tcl_Obj *resultPtr;
+    return Tcl_NRCallObjProc(interp, TclNRSubstObjCmd, dummy, objc, objv);
+}
+
+int
+TclNRSubstObjCmd(
+    ClientData dummy,		/* Not used. */
+    Tcl_Interp *interp,		/* Current interpreter. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *const objv[])	/* Argument objects. */
+{
     int flags;
 
     if (objc < 2) {
@@ -3431,14 +3440,7 @@ Tcl_SubstObjCmd(
     if (TclSubstOptions(interp, objc-2, objv+1, &flags) != TCL_OK) {
 	return TCL_ERROR;
     }
-
-    resultPtr = Tcl_SubstObj(interp, objv[objc-1], flags);
-
-    if (resultPtr == NULL) {
-	return TCL_ERROR;
-    }
-    Tcl_SetObjResult(interp, resultPtr);
-    return TCL_OK;
+    return TclNRSubstObj(interp, objv[objc-1], flags);
 }
 
 /*
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 9b33b41..6ec2265 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -12,7 +12,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclCompCmds.c,v 1.156 2009/09/04 23:14:32 dgp Exp $
+ * RCS: @(#) $Id: tclCompCmds.c,v 1.157 2009/09/11 20:13:27 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -3874,14 +3874,9 @@ TclCompileSubstCmd(
     int numOpts = numArgs - 1;
     int objc, flags = TCL_SUBST_ALL;
     Tcl_Obj **objv/*, *toSubst = NULL*/;
-    Tcl_Parse parse;
-    Tcl_InterpState state = NULL;
     Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr);
-    int breakOffset = 0, count = 0, code = TCL_ERROR;
-    Tcl_Token *endTokenPtr, *tokenPtr;
+    int code = TCL_ERROR;
     DefineLineInformation;	/* TIP #280 */
-    int bline = mapPtr->loc[eclIndex].line[numArgs];
-    SetLineInformation(numArgs);
 
     if (numArgs == 0) {
 	return TCL_ERROR;
@@ -3925,8 +3920,29 @@ TclCompileSubstCmd(
 	return TCL_ERROR;
     }
 
-    TclSubstParse(interp, /*toSubst,*/ wordTokenPtr[1].start,
-	    wordTokenPtr[1].size, flags, &parse, &state);
+    SetLineInformation(numArgs);
+    TclSubstCompile(interp, wordTokenPtr[1].start, wordTokenPtr[1].size, flags,
+	    mapPtr->loc[eclIndex].line[numArgs], envPtr);
+
+/*    TclDecrRefCount(toSubst);*/
+    return TCL_OK;
+}
+
+void
+TclSubstCompile(
+    Tcl_Interp *interp,
+    const char *bytes,
+    int numBytes,
+    int flags,
+    int line,
+    CompileEnv *envPtr)
+{
+    Tcl_Token *endTokenPtr, *tokenPtr;
+    int breakOffset = 0, count = 0, bline = line;
+    Tcl_Parse parse;
+    Tcl_InterpState state = NULL;
+
+    TclSubstParse(interp, bytes, numBytes, flags, &parse, &state);
 
     for (tokenPtr = parse.tokenPtr, endTokenPtr = tokenPtr + parse.numTokens;
 	    tokenPtr < endTokenPtr; tokenPtr = TokenAfter(tokenPtr)) {
@@ -4101,7 +4117,6 @@ TclCompileSubstCmd(
     }
 
     Tcl_FreeParse(&parse);
-/*    TclDecrRefCount(toSubst);*/
 
     if (state != NULL) {
 	Tcl_RestoreInterpState(interp, state);
@@ -4113,8 +4128,6 @@ TclCompileSubstCmd(
 	TclUpdateInstInt4AtPc(INST_JUMP4, CurrentOffset(envPtr) - breakOffset,
 		envPtr->codeStart + breakOffset);
     }
-
-    return TCL_OK;
 }
 
 /*
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index b6b270b..3fa57db 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -11,7 +11,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclCompile.c,v 1.173 2009/09/04 17:33:11 dgp Exp $
+ * RCS: @(#) $Id: tclCompile.c,v 1.174 2009/09/11 20:13:27 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -413,6 +413,8 @@ InstructionDesc const tclInstructionTable[] = {
  * Prototypes for procedures defined later in this file:
  */
 
+static ByteCode *	CompileSubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
+			    int flags);
 static void		DupByteCodeInternalRep(Tcl_Obj *srcPtr,
 			    Tcl_Obj *copyPtr);
 static unsigned char *	EncodeCmdLocMap(CompileEnv *envPtr,
@@ -422,6 +424,7 @@ static void		EnterCmdExtentData(CompileEnv *envPtr,
 static void		EnterCmdStartData(CompileEnv *envPtr,
 			    int cmdNumber, int srcOffset, int codeOffset);
 static void		FreeByteCodeInternalRep(Tcl_Obj *objPtr);
+static void		FreeSubstCodeInternalRep(Tcl_Obj *objPtr);
 static int		GetCmdLocEncodingSize(CompileEnv *envPtr);
 #ifdef TCL_COMPILE_STATS
 static void		RecordByteCodeStats(ByteCode *codePtr);
@@ -453,6 +456,19 @@ const Tcl_ObjType tclByteCodeType = {
     NULL,			/* updateStringProc */
     SetByteCodeFromAny		/* setFromAnyProc */
 };
+
+/*
+ * The structure below defines a bytecode Tcl object type to hold the
+ * compiled bytecode for the [subst]itution of Tcl values.
+ */
+
+static const Tcl_ObjType substCodeType = {
+    "substcode",		/* name */
+    FreeSubstCodeInternalRep,	/* freeIntRepProc */
+    DupByteCodeInternalRep,	/* dupIntRepProc - shared with bytecode */
+    NULL,			/* updateStringProc */
+    NULL,			/* setFromAnyProc */
+};
 
 /*
  *----------------------------------------------------------------------
@@ -859,6 +875,144 @@ TclCleanupByteCode(
 /*
  *----------------------------------------------------------------------
  *
+ * TclNRSubstObj --
+ *
+ *	Request substitution of a Tcl value by the NR stack.
+ *
+ * Results:
+ *	Returns TCL_OK.
+ *
+ * Side effects:
+ *	Compiles objPtr into bytecode that performs the substitutions as
+ *	governed by flags and places callbacks on the NR stack to execute
+ *	the bytecode and store the result in the interp.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclNRSubstObj(
+    Tcl_Interp *interp,
+    Tcl_Obj *objPtr,
+    int flags)
+{
+    ByteCode *codePtr = CompileSubstObj(interp, objPtr, flags);
+
+    /* TODO: Confirm we do not need this. */
+    /* Tcl_ResetResult(interp); */
+    Tcl_NRAddCallback(interp, NRCallTEBC, INT2PTR(TCL_NR_BC_TYPE), codePtr,
+	    NULL, NULL);
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CompileSubstObj --
+ *
+ *	Compile a Tcl value into ByteCode implementing its substitution,
+ *	as governed by flags.
+ *
+ * Results:
+ *	A (ByteCode *) is returned pointing to the resulting ByteCode.
+ *	The caller must manage its refCount and arrange for a call to
+ *	TclCleanupByteCode() when the last reference disappears.
+ *
+ * Side effects:
+ *	The Tcl_ObjType of objPtr is changed to the "substcode" type,
+ *	and the ByteCode and governing flags value are kept in the internal
+ *	rep for faster operations the next time CompileSubstObj is called
+ *	on the same value.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static ByteCode *
+CompileSubstObj(
+    Tcl_Interp *interp,
+    Tcl_Obj *objPtr,
+    int flags)
+{
+    Interp *iPtr = (Interp *) interp;
+    ByteCode *codePtr = NULL;
+
+    if (objPtr->typePtr == &substCodeType) {
+	Namespace *nsPtr = iPtr->varFramePtr->nsPtr;
+
+	codePtr = (ByteCode *) objPtr->internalRep.ptrAndLongRep.ptr;
+	if (flags != objPtr->internalRep.ptrAndLongRep.value
+		|| ((Interp *) *codePtr->interpHandle != iPtr)
+		|| (codePtr->compileEpoch != iPtr->compileEpoch)
+		|| (codePtr->nsPtr != nsPtr)
+		|| (codePtr->nsEpoch != nsPtr->resolverEpoch)
+		|| (codePtr->localCachePtr !=
+		iPtr->varFramePtr->localCachePtr)) {
+	    FreeSubstCodeInternalRep(objPtr);
+	}
+    }
+    if (objPtr->typePtr != &substCodeType) {
+	CompileEnv compEnv;
+	int numBytes;
+	const char *bytes = Tcl_GetStringFromObj(objPtr, &numBytes);
+
+	/* TODO: Check for more TIP 280 */
+	TclInitCompileEnv(interp, &compEnv, bytes, numBytes, NULL, 0);
+
+	TclSubstCompile(interp, bytes, numBytes, flags, 1, &compEnv);
+
+	TclEmitOpcode(INST_DONE, &compEnv);
+	TclInitByteCodeObj(objPtr, &compEnv);
+	objPtr->typePtr = &substCodeType;
+	TclFreeCompileEnv(&compEnv);
+	codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
+	objPtr->internalRep.ptrAndLongRep.ptr = codePtr;
+	objPtr->internalRep.ptrAndLongRep.value = flags;
+	if (iPtr->varFramePtr->localCachePtr) {
+	    codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr;
+	    codePtr->localCachePtr->refCount++;
+	}
+	/* TODO: Debug printing? */
+    }
+    return codePtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FreeSubstCodeInternalRep --
+ *
+ *	Part of the substcode Tcl object type implementation. Frees the storage
+ *	associated with a substcode object's internal representation unless its
+ *	code is actively being executed.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	The substcode object's internal rep is marked invalid and its code gets
+ *	freed unless the code is actively being executed. In that case the
+ *	cleanup is delayed until the last execution of the code completes.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+FreeSubstCodeInternalRep(
+    register Tcl_Obj *objPtr)	/* Object whose internal rep to free. */
+{
+    register ByteCode *codePtr = objPtr->internalRep.ptrAndLongRep.ptr;
+
+    codePtr->refCount--;
+    if (codePtr->refCount <= 0) {
+	TclCleanupByteCode(codePtr);
+    }
+    objPtr->typePtr = NULL;
+    objPtr->internalRep.otherValuePtr = NULL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * TclInitCompileEnv --
  *
  *	Initializes a CompileEnv compilation environment structure for the
diff --git a/generic/tclInt.h b/generic/tclInt.h
index a27b0f4..6f7972f 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -15,7 +15,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclInt.h,v 1.441 2009/09/07 06:20:47 das Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.442 2009/09/11 20:13:27 dgp Exp $
  */
 
 #ifndef _TCLINT
@@ -2651,6 +2651,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRForObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRForeachCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRIfObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRSourceObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRSubstObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRSwitchObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRTryObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRWhileObjCmd;
@@ -2846,6 +2847,8 @@ MODULE_SCOPE int	TclMarkList(Tcl_Interp *interp, const char *list,
 MODULE_SCOPE int	TclMergeReturnOptions(Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const objv[], Tcl_Obj **optionsPtrPtr,
 			    int *codePtr, int *levelPtr);
+MODULE_SCOPE int	TclNRSubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
+			    int flags);
 MODULE_SCOPE int	TclNokia770Doubles();
 MODULE_SCOPE void	TclObjVarErrMsg(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
 			    Tcl_Obj *part2Ptr, const char *operation,
@@ -2950,6 +2953,9 @@ MODULE_SCOPE int	TclStringMatch(const char *str, int strLen,
 MODULE_SCOPE int	TclStringMatchObj(Tcl_Obj *stringObj,
 			    Tcl_Obj *patternObj, int flags);
 MODULE_SCOPE Tcl_Obj *	TclStringObjReverse(Tcl_Obj *objPtr);
+MODULE_SCOPE void	TclSubstCompile(Tcl_Interp *interp, const char *bytes,
+			    int numBytes, int flags, int line,
+			    struct CompileEnv *envPtr);
 MODULE_SCOPE int	TclSubstOptions(Tcl_Interp *interp, int numOpts,
 			    Tcl_Obj *const opts[], int *flagPtr);
 MODULE_SCOPE void	TclSubstParse(Tcl_Interp *interp, const char *bytes,
diff --git a/tests/coroutine.test b/tests/coroutine.test
index b3ae02a..776dda5 100644
--- a/tests/coroutine.test
+++ b/tests/coroutine.test
@@ -9,7 +9,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: coroutine.test,v 1.5 2009/09/07 14:47:16 dkf Exp $
+# RCS: @(#) $Id: coroutine.test,v 1.6 2009/09/11 20:13:27 dgp Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -280,7 +280,7 @@ test coroutine-1.12 {proc as coroutine} -setup {
 test coroutine-1.13 {subst as coroutine: literal} {
     list [coroutine foo eval {subst {>>[yield a],[yield b]<<}}] [foo x] [foo y]
 } {a b >>x,y<<}
-test coroutine-1.14 {subst as coroutine: in variable} knownBug {
+test coroutine-1.14 {subst as coroutine: in variable} {
     set pattern {>>[yield c],[yield d]<<}
     list [coroutine foo eval {subst $pattern}] [foo p] [foo q]
 } {c d >>p,q<<}
diff --git a/tests/parse.test b/tests/parse.test
index b745a97..482c3b8 100644
--- a/tests/parse.test
+++ b/tests/parse.test
@@ -8,7 +8,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: parse.test,v 1.37 2009/09/04 17:33:12 dgp Exp $
+# RCS: @(#) $Id: parse.test,v 1.38 2009/09/11 20:13:27 dgp Exp $
 
 if {[catch {package require tcltest 2.0.2}]} {
     puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required."
@@ -1048,7 +1048,7 @@ test parse-19.3 {Bug 1115904: recursion limit in Tcl_EvalEx} -setup {
     interp delete i
 }
 
-test parse-19.4 {Bug 1115904: recursion limit in Tcl_EvalEx} -setup {
+test parse-19.4 {Bug 1115904: recursion limit in Tcl_EvalEx} -constraints knownBug -setup {
     interp create i
     i eval {proc {} args {}}
     interp recursionlimit i 2