TIP #353 IMPLEMENTATION

        * doc/NRE.3:            New public routine Tcl_NRExprObj() permits
        * generic/tcl.decls:    extension commands to evaluate Tcl expressions
        * generic/tclBasic.c:   in NR-enabled command procedures.
        * generic/tclCmdAH.c:
        * generic/tclExecute.c:
        * generic/tclInt.h:
        * generic/tclObj.c:
        * tests/expr.test:

        * generic/tclDecls.h:           make genstubs
        * generic/tclStubInit.c:

8 files changed, 219 insertions, 90 deletions

diff --git a/generic/tcl.decls b/generic/tcl.decls
index 0ce6825..26f3a83 100644
--- a/generic/tcl.decls
+++ b/generic/tcl.decls
@@ -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: tcl.decls,v 1.169 2009/02/27 23:03:42 nijtmans Exp $
+# RCS: @(#) $Id: tcl.decls,v 1.170 2009/08/12 16:06:39 dgp Exp $
 
 library tcl
 
@@ -2295,6 +2295,11 @@ declare 624 generic {
     int Tcl_CloseEx(Tcl_Interp *interp, Tcl_Channel chan, int flags)
 }
 
+# TIP #353 (NR-enabled expressions) dgp
+declare 625 generic {
+    int Tcl_NRExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj *resultPtr)
+}
+
 # ----- BASELINE -- FOR -- 8.6.0 ----- #
 
 ##############################################################################
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 7941c7d..b83afe5 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.400 2009/08/02 13:03:47 dkf Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.401 2009/08/12 16:06:41 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -182,7 +182,7 @@ static const CmdInfo builtInCmds[] = {
     {"coroutine",	NULL,			NULL,			TclNRCoroutineObjCmd,	1},
     {"error",		Tcl_ErrorObjCmd,	NULL,			NULL,	1},
     {"eval",		Tcl_EvalObjCmd,		NULL,			NULL,	1},
-    {"expr",		Tcl_ExprObjCmd,		TclCompileExprCmd,	NULL,	1},
+    {"expr",		Tcl_ExprObjCmd,		TclCompileExprCmd,	TclNRExprObjCmd,	1},
     {"for",		Tcl_ForObjCmd,		TclCompileForCmd,	TclNRForObjCmd,	1},
     {"foreach",		Tcl_ForeachObjCmd,	TclCompileForeachCmd,	TclNRForeachCmd,	1},
     {"format",		Tcl_FormatObjCmd,	NULL,			NULL,	1},
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index b268bfc..85b098a 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -10,7 +10,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclCmdAH.c,v 1.118 2009/07/24 20:45:22 dgp Exp $
+ * RCS: @(#) $Id: tclCmdAH.c,v 1.119 2009/08/12 16:06:43 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -58,6 +58,7 @@ static const char *	GetTypeFromMode(int mode);
 static int		StoreStatData(Tcl_Interp *interp, Tcl_Obj *varName,
 			    Tcl_StatBuf *statPtr);
 static Tcl_NRPostProc	CatchObjCmdCallback;
+static Tcl_NRPostProc	ExprCallback;
 static Tcl_NRPostProc	ForNextCallback;
 static Tcl_NRPostProc	ForeachLoopStep;
 static Tcl_NRPostProc	EvalCmdErrMsg;
@@ -837,29 +838,53 @@ Tcl_ExprObjCmd(
     int objc,			/* Number of arguments. */
     Tcl_Obj *const objv[])	/* Argument objects. */
 {
-    Tcl_Obj *resultPtr;
-    int result;
+    return Tcl_NRCallObjProc(interp, TclNRExprObjCmd, dummy, objc, objv);
+}
+
+int
+TclNRExprObjCmd(
+    ClientData dummy,		/* Not used. */
+    Tcl_Interp *interp,		/* Current interpreter. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *const objv[])	/* Argument objects. */
+{
+    Tcl_Obj *resultPtr, *objPtr;
 
     if (objc < 2) {
 	Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?");
 	return TCL_ERROR;
     }
 
+    TclNewObj(resultPtr);
+    Tcl_IncrRefCount(resultPtr);
     if (objc == 2) {
-	result = Tcl_ExprObj(interp, objv[1], &resultPtr);
+	objPtr = objv[1];
+	TclNRAddCallback(interp, ExprCallback, resultPtr, NULL, NULL, NULL);
     } else {
-	Tcl_Obj *objPtr = Tcl_ConcatObj(objc-1, objv+1);
+	objPtr = Tcl_ConcatObj(objc-1, objv+1);
+	TclNRAddCallback(interp, ExprCallback, resultPtr, objPtr, NULL, NULL);
+    }
+
+    return Tcl_NRExprObj(interp, objPtr, resultPtr);
+}
+
+static int
+ExprCallback(
+    ClientData data[],
+    Tcl_Interp *interp,
+    int result)
+{
+    Tcl_Obj *resultPtr = data[0];
+    Tcl_Obj *objPtr = data[1];
 
-	Tcl_IncrRefCount(objPtr);
-	result = Tcl_ExprObj(interp, objPtr, &resultPtr);
+    if (objPtr != NULL) {
 	Tcl_DecrRefCount(objPtr);
     }
 
     if (result == TCL_OK) {
 	Tcl_SetObjResult(interp, resultPtr);
-	Tcl_DecrRefCount(resultPtr);	/* Done with the result object */
     }
-
+    Tcl_DecrRefCount(resultPtr);
     return result;
 }
 
diff --git a/generic/tclDecls.h b/generic/tclDecls.h
index 6c3869f..032fb75 100644
--- a/generic/tclDecls.h
+++ b/generic/tclDecls.h
@@ -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: tclDecls.h,v 1.170 2009/02/27 23:03:42 nijtmans Exp $
+ * RCS: @(#) $Id: tclDecls.h,v 1.171 2009/08/12 16:06:43 dgp Exp $
  */
 
 #ifndef _TCLDECLS
@@ -3725,6 +3725,12 @@ EXTERN Tcl_Obj *	Tcl_GetStartupScript (const char ** encodingPtr);
 EXTERN int		Tcl_CloseEx (Tcl_Interp * interp, Tcl_Channel chan,
 				int flags);
 #endif
+#ifndef Tcl_NRExprObj_TCL_DECLARED
+#define Tcl_NRExprObj_TCL_DECLARED
+/* 625 */
+EXTERN int		Tcl_NRExprObj (Tcl_Interp * interp, Tcl_Obj * objPtr,
+				Tcl_Obj * resultPtr);
+#endif
 
 typedef struct TclStubHooks {
     const struct TclPlatStubs *tclPlatStubs;
@@ -4385,6 +4391,7 @@ typedef struct TclStubs {
     void (*tcl_SetStartupScript) (Tcl_Obj * path, const char * encoding); /* 622 */
     Tcl_Obj * (*tcl_GetStartupScript) (const char ** encodingPtr); /* 623 */
     int (*tcl_CloseEx) (Tcl_Interp * interp, Tcl_Channel chan, int flags); /* 624 */
+    int (*tcl_NRExprObj) (Tcl_Interp * interp, Tcl_Obj * objPtr, Tcl_Obj * resultPtr); /* 625 */
 } TclStubs;
 
 #if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS)
@@ -6915,6 +6922,10 @@ extern const TclStubs *tclStubsPtr;
 #define Tcl_CloseEx \
 	(tclStubsPtr->tcl_CloseEx) /* 624 */
 #endif
+#ifndef Tcl_NRExprObj
+#define Tcl_NRExprObj \
+	(tclStubsPtr->tcl_NRExprObj) /* 625 */
+#endif
 
 #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
 
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 1a9c9a9..c668539 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -14,7 +14,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclExecute.c,v 1.443 2009/07/24 20:45:23 dgp Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.444 2009/08/12 16:06:43 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -693,6 +693,9 @@ static inline int	OFFSET(void *ptr);
 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;
+
 /*
  * The structure below defines a bytecode Tcl object type to hold the
  * compiled bytecode for Tcl expressions.
@@ -1243,6 +1246,127 @@ TclStackRealloc(
  *--------------------------------------------------------------
  */
 
+int
+Tcl_ExprObj(
+    Tcl_Interp *interp,		/* Context in which to evaluate the
+				 * expression. */
+    register Tcl_Obj *objPtr,	/* Points to Tcl object containing expression
+				 * to evaluate. */
+    Tcl_Obj **resultPtrPtr)	/* Where the Tcl_Obj* that is the expression
+				 * result is stored if no errors occur. */
+{
+    TEOV_callback *rootPtr = TOP_CB(interp);
+    Tcl_Obj *resultPtr;
+
+    TclNewObj(resultPtr);
+    TclNRAddCallback(interp, CopyCallback, resultPtrPtr, resultPtr,
+	    NULL, NULL);
+    Tcl_NRExprObj(interp, objPtr, resultPtr);
+    return TclNRRunCallbacks(interp, TCL_OK, rootPtr, 0);
+}
+
+static int
+CopyCallback(
+    ClientData data[],
+    Tcl_Interp *interp,
+    int result)
+{
+    Tcl_Obj **resultPtrPtr = data[0];
+    Tcl_Obj *resultPtr = data[1];
+
+    if (result == TCL_OK) {
+	*resultPtrPtr = resultPtr;
+	Tcl_IncrRefCount(resultPtr);
+    } else {
+	Tcl_DecrRefCount(resultPtr);
+    }
+    return result;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Tcl_NRExprObj --
+ *
+ *	Request evaluation of the expression in a Tcl_Obj by the NR stack.
+ *
+ * Results:
+ *	Returns TCL_OK.
+ *
+ * Side effects:
+ *	Compiles objPtr as a Tcl expression and places callbacks on the
+ *	NR stack to execute the bytecode and store the result in resultPtr.
+ *	If bytecode execution raises an exception, nothing is written
+ *	to resultPtr, and the exceptional return code flows up the NR
+ *	stack.  If the exception is TCL_ERROR, an error message is left
+ *	in the interp result and the interp's return options dictionary
+ *	holds additional error information too.  Execution of the bytecode
+ *	may have other side effects, depending on the expression.
+ *
+ *--------------------------------------------------------------
+ */
+
+int
+Tcl_NRExprObj(
+    Tcl_Interp *interp,
+    Tcl_Obj *objPtr,
+    Tcl_Obj *resultPtr)
+{
+    ByteCode *codePtr;
+
+    /* TODO: consider saving whole state? */
+    Tcl_Obj *saveObjPtr = Tcl_GetObjResult(interp);
+
+    Tcl_IncrRefCount(saveObjPtr);
+
+    codePtr = CompileExprObj(interp, objPtr);
+
+    /* TODO: Confirm reset not required? */
+    /*Tcl_ResetResult(interp);*/
+    Tcl_NRAddCallback(interp, ExprObjCallback, saveObjPtr, resultPtr,
+	    NULL, NULL);
+    Tcl_NRAddCallback(interp, NRCallTEBC, INT2PTR(TCL_NR_BC_TYPE), codePtr,
+	    NULL, NULL);
+    return TCL_OK;
+}
+
+static int
+ExprObjCallback(
+    ClientData data[],
+    Tcl_Interp *interp,
+    int result)
+{
+    Tcl_Obj *saveObjPtr = data[0];
+    Tcl_Obj *resultPtr = data[1];
+
+    if (result == TCL_OK) {
+	TclSetDuplicateObj(resultPtr, Tcl_GetObjResult(interp));
+	Tcl_IncrRefCount(resultPtr);
+	Tcl_SetObjResult(interp, saveObjPtr);
+    }
+    TclDecrRefCount(saveObjPtr);
+    return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CompileExprObj --
+ *	Compile a Tcl expression value into ByteCode.
+ *
+ * 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 "bytecode" type,
+ *	and the ByteCode is kept in the internal rep (along with context
+ *	data for checking validity) for faster operations the next time
+ *	CompileExprObj is called on the same value.
+ *
+ *----------------------------------------------------------------------
+ */
 
 static ByteCode *
 CompileExprObj(
@@ -1318,62 +1442,6 @@ CompileExprObj(
     }
     return codePtr;
 }
-
-int
-Tcl_ExprObj(
-    Tcl_Interp *interp,		/* Context in which to evaluate the
-				 * expression. */
-    register Tcl_Obj *objPtr,	/* Points to Tcl object containing expression
-				 * to evaluate. */
-    Tcl_Obj **resultPtrPtr)	/* Where the Tcl_Obj* that is the expression
-				 * result is stored if no errors occur. */
-{
-    Interp *iPtr = (Interp *) interp;
-    int result;
-    ByteCode *codePtr;
-
-    /*
-     * Execute the expression after first saving the interpreter's result.
-     */
-
-    Tcl_Obj *saveObjPtr = Tcl_GetObjResult(interp);
-    Tcl_IncrRefCount(saveObjPtr);
-
-    codePtr = CompileExprObj(interp, objPtr);
-
-
-    Tcl_ResetResult(interp);
-
-    /*
-     * Increment the code's ref count while it is being executed. If
-     * afterwards no references to it remain, free the code.
-     */
-
-    codePtr->refCount++;
-    result = TclExecuteByteCode(interp, codePtr);
-    codePtr->refCount--;
-    if (codePtr->refCount <= 0) {
-	TclCleanupByteCode(codePtr);
-    }
-
-    /*
-     * If the expression evaluated successfully, store a pointer to its value
-     * object in resultPtrPtr then restore the old interpreter result. We
-     * increment the object's ref count to reflect the reference that we are
-     * returning to the caller. We also decrement the ref count of the
-     * interpreter's result object after calling Tcl_SetResult since we next
-     * store into that field directly.
-     */
-
-    if (result == TCL_OK) {
-	*resultPtrPtr = iPtr->objResultPtr;
-	Tcl_IncrRefCount(iPtr->objResultPtr);
-
-	Tcl_SetObjResult(interp, saveObjPtr);
-    }
-    TclDecrRefCount(saveObjPtr);
-    return result;
-}
 
 /*
  *----------------------------------------------------------------------
diff --git a/generic/tclInt.h b/generic/tclInt.h
index ac3b3bc..b441bf6b 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.432 2009/08/02 13:03:47 dkf Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.433 2009/08/12 16:06:44 dgp Exp $
  */
 
 #ifndef _TCLINT
@@ -2607,6 +2607,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRNamespaceObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRApplyObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRUplevelObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRCatchObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRExprObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRForObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRForeachCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRIfObjCmd;
@@ -2890,6 +2891,7 @@ MODULE_SCOPE void	TclSetBignumIntRep(Tcl_Obj *objPtr,
 			    mp_int *bignumValue);
 MODULE_SCOPE void	TclSetCmdNameObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
 			    Command *cmdPtr);
+MODULE_SCOPE void	TclSetDuplicateObj(Tcl_Obj *dupPtr, Tcl_Obj *objPtr);
 MODULE_SCOPE void	TclSetProcessGlobalValue(ProcessGlobalValue *pgvPtr,
 			    Tcl_Obj *newValue, Tcl_Encoding encoding);
 MODULE_SCOPE void	TclSignalExitThread(Tcl_ThreadId id, int result);
diff --git a/generic/tclObj.c b/generic/tclObj.c
index 46758fa..8052028 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -13,7 +13,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclObj.c,v 1.154 2009/08/02 13:03:47 dkf Exp $
+ * RCS: @(#) $Id: tclObj.c,v 1.155 2009/08/12 16:06:44 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -1133,30 +1133,47 @@ TclObjBeingDeleted(
  *----------------------------------------------------------------------
  */
 
+#define SetDuplicateObj(dupPtr, objPtr)					\
+    {									\
+	const Tcl_ObjType *typePtr = (objPtr)->typePtr;			\
+	const char *bytes = (objPtr)->bytes;				\
+	if (bytes) {							\
+	    TclInitStringRep((dupPtr), bytes, (objPtr)->length);	\
+	} else {							\
+	    (dupPtr)->bytes = NULL;					\
+	}								\
+	if (typePtr) {							\
+	    if (typePtr->dupIntRepProc) {				\
+		typePtr->dupIntRepProc((objPtr), (dupPtr));		\
+	    } else {							\
+		(dupPtr)->internalRep = (objPtr)->internalRep;		\
+		(dupPtr)->typePtr = typePtr;				\
+	    }								\
+	}								\
+    }
+
 Tcl_Obj *
 Tcl_DuplicateObj(
-    register Tcl_Obj *objPtr)		/* The object to duplicate. */
+    Tcl_Obj *objPtr)		/* The object to duplicate. */
 {
-    register const Tcl_ObjType *typePtr = objPtr->typePtr;
-    register Tcl_Obj *dupPtr;
+    Tcl_Obj *dupPtr;
 
     TclNewObj(dupPtr);
+    SetDuplicateObj(dupPtr, objPtr);
+    return dupPtr;
+}
 
-    if (objPtr->bytes == NULL) {
-	dupPtr->bytes = NULL;
-    } else if (objPtr->bytes != tclEmptyStringRep) {
-	TclInitStringRep(dupPtr, objPtr->bytes, objPtr->length);
-    }
-
-    if (typePtr != NULL) {
-	if (typePtr->dupIntRepProc == NULL) {
-	    dupPtr->internalRep = objPtr->internalRep;
-	    dupPtr->typePtr = typePtr;
-	} else {
-	    typePtr->dupIntRepProc(objPtr, dupPtr);
-	}
+void
+TclSetDuplicateObj(
+    Tcl_Obj *dupPtr,
+    Tcl_Obj *objPtr)
+{
+    if (Tcl_IsShared(dupPtr)) {
+	Tcl_Panic("%s called with shared object", "TclSetDuplicateObj");
     }
-    return dupPtr;
+    TclInvalidateStringRep(dupPtr);
+    TclFreeIntRep(dupPtr);
+    SetDuplicateObj(dupPtr, objPtr);
 }
 
 /*
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index d80c19a..c71b944 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -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: tclStubInit.c,v 1.183 2009/07/15 13:17:19 dkf Exp $
+ * RCS: @(#) $Id: tclStubInit.c,v 1.184 2009/08/12 16:06:44 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -1109,6 +1109,7 @@ static const TclStubs tclStubs = {
     Tcl_SetStartupScript, /* 622 */
     Tcl_GetStartupScript, /* 623 */
     Tcl_CloseEx, /* 624 */
+    Tcl_NRExprObj, /* 625 */
 };
 
 /* !END!: Do not edit above this line. */