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
