Tcl Source Code

Artifact Content
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Artifact 7f0f6c03e38117499452cb11c9b1bcf3b8ff5785:

Attachment "2823282-2.patch" to ticket [2823282fff] added by dgp 2009-07-30 22:54:30.
Index: doc/NRE.3
===================================================================
RCS file: /cvsroot/tcl/tcl/doc/NRE.3,v
retrieving revision 1.3
diff -u -r1.3 NRE.3
--- doc/NRE.3	19 Dec 2008 18:23:04 -0000	1.3
+++ doc/NRE.3	30 Jul 2009 15:51:47 -0000
@@ -31,6 +31,9 @@
 int
 \fBTcl_NRCmdSwap\fR(\fIinterp, cmd, objc, objv, flags\fR)
 .sp
+int
+\fBTcl_NRExprObj\fR(\fIinterp, objPtr, resultPtr\fR)
+.sp
 void
 \fBTcl_NRAddCallback\fR(\fIinterp, postProcPtr, data0, data1, data2, data3\fR)
 .fi
@@ -59,13 +62,16 @@
 Pointer to an array of Tcl objects. Each object holds the value of a
 single word in the command to execute.
 .AP Tcl_Obj *objPtr in
-Pointer to a Tcl_Obj whose value is a script to execute.
+Pointer to a Tcl_Obj whose value is a script or expression to execute.
 .AP int flags in
 ORed combination of flag bits that specify additional options.
 \fBTCL_EVAL_GLOBAL\fR is the only flag that is currently supported.
 .\" TODO: This is a lie. But kbk didn't grasp TCL_EVAL_INVOKE and
 .\"       TCL_EVAL_NOERR well enough to document them.
 .AP Tcl_Command cmd in
+.AP Tcl_Obj *resultPtr out
+Pointer to an unshared Tcl_Obj where the result of expression
+evaluation is written.
 .AP Tcl_NRPostProc *postProcPtr in
 Pointer to a function that will be invoked when the command currently
 executing in the interpreter designated by \fIinterp\fR completes.
@@ -150,9 +156,18 @@
 evaluated in the global namespace. If it is not set, it is evaluated
 in the current namespace.
 .PP
-All three of the routines return \fBTCL_OK\fR if command invocation
-has been scheduled successfully. If for any reason command invocation
-cannot be scheduled (for example, if the interpreter is unable to find
+\fBTcl_NRExprObj\fR arranges for the expression contained in \fIobjPtr\fR
+to be evaluated in the interpreter designated by \fIinterp\fR after
+the current command (which must be trampoline-enabled) returns. It is
+the method by which a command may evaluate a Tcl expression without consuming
+space on the C stack.  The argument \fIresultPtr\fR is a pointer to an
+unshared Tcl_Obj where the result of expression evaluation is to be written.
+If expression evaluation returns any code other than TCL_OK, the
+\fIresultPtr\fR value is left untouched.
+.PP
+All of the routines return \fBTCL_OK\fR if command or expression invocation
+has been scheduled successfully. If for any reason the scheduling cannot
+be completed (for example, if the interpreter is unable to find
 the requested command), they return \fBTCL_ERROR\fR with an
 appropriate message left in the interpreter's result.
 .PP
@@ -296,7 +311,7 @@
     \fITheCmdDeleteProc\fR);
 .CE
 .SH "SEE ALSO"
-Tcl_CreateCommand(3), Tcl_CreateObjCommand(3), Tcl_EvalObjEx(3), Tcl_GetCommandFromObj(3)
+Tcl_CreateCommand(3), Tcl_CreateObjCommand(3), Tcl_EvalObjEx(3), Tcl_GetCommandFromObj(3), Tcl_ExprObj(3)
 .SH KEYWORDS
 stackless, nonrecursive, execute, command, global, object, result, script
 .SH COPYRIGHT
Index: generic/tcl.decls
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tcl.decls,v
retrieving revision 1.169
diff -u -r1.169 tcl.decls
--- generic/tcl.decls	27 Feb 2009 23:03:42 -0000	1.169
+++ generic/tcl.decls	30 Jul 2009 15:51:47 -0000
@@ -2295,6 +2295,11 @@
     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 ----- #
 
 ##############################################################################
Index: generic/tclBasic.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclBasic.c,v
retrieving revision 1.399
diff -u -r1.399 tclBasic.c
--- generic/tclBasic.c	23 Jul 2009 15:23:43 -0000	1.399
+++ generic/tclBasic.c	30 Jul 2009 15:51:47 -0000
@@ -182,7 +182,7 @@
     {"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},
Index: generic/tclCmdAH.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCmdAH.c,v
retrieving revision 1.118
diff -u -r1.118 tclCmdAH.c
--- generic/tclCmdAH.c	24 Jul 2009 20:45:22 -0000	1.118
+++ generic/tclCmdAH.c	30 Jul 2009 15:51:47 -0000
@@ -58,6 +58,7 @@
 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 @@
     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;
 }
 
Index: generic/tclDecls.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclDecls.h,v
retrieving revision 1.170
diff -u -r1.170 tclDecls.h
--- generic/tclDecls.h	27 Feb 2009 23:03:42 -0000	1.170
+++ generic/tclDecls.h	30 Jul 2009 15:51:47 -0000
@@ -3725,6 +3725,12 @@
 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 @@
     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 @@
 #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) */
 
Index: generic/tclExecute.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclExecute.c,v
retrieving revision 1.443
diff -u -r1.443 tclExecute.c
--- generic/tclExecute.c	24 Jul 2009 20:45:23 -0000	1.443
+++ generic/tclExecute.c	30 Jul 2009 15:51:47 -0000
@@ -693,6 +693,9 @@
 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 @@
  *--------------------------------------------------------------
  */
 
+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 @@
     }
     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;
-}
 
 /*
  *----------------------------------------------------------------------
Index: generic/tclInt.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclInt.h,v
retrieving revision 1.431
diff -u -r1.431 tclInt.h
--- generic/tclInt.h	22 Jul 2009 19:54:49 -0000	1.431
+++ generic/tclInt.h	30 Jul 2009 15:51:47 -0000
@@ -2607,6 +2607,7 @@
 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 @@
 			    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);
Index: generic/tclObj.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclObj.c,v
retrieving revision 1.153
diff -u -r1.153 tclObj.c
--- generic/tclObj.c	18 Jun 2009 09:41:29 -0000	1.153
+++ generic/tclObj.c	30 Jul 2009 15:51:47 -0000
@@ -1133,30 +1133,47 @@
  *----------------------------------------------------------------------
  */
 
+#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);
 }
 
 /*
Index: generic/tclStubInit.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclStubInit.c,v
retrieving revision 1.183
diff -u -r1.183 tclStubInit.c
--- generic/tclStubInit.c	15 Jul 2009 13:17:19 -0000	1.183
+++ generic/tclStubInit.c	30 Jul 2009 15:51:47 -0000
@@ -1109,6 +1109,7 @@
     Tcl_SetStartupScript, /* 622 */
     Tcl_GetStartupScript, /* 623 */
     Tcl_CloseEx, /* 624 */
+    Tcl_NRExprObj, /* 625 */
 };
 
 /* !END!: Do not edit above this line. */
Index: tests/expr.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/expr.test,v
retrieving revision 1.75
diff -u -r1.75 expr.test
--- tests/expr.test	1 Jun 2009 21:34:22 -0000	1.75
+++ tests/expr.test	30 Jul 2009 15:51:48 -0000
@@ -7146,6 +7146,13 @@
     expr {-0x8000000000000001 >> 0x8000000000000000}
 } -1
 
+test expr-49.1 {Bug 2823282} {
+    coroutine foo apply {{} {set expr expr; $expr {[yield]}}}
+    foo 1
+} 1
+
+
+
 # cleanup
 if {[info exists a]} {
     unset a