summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2009-08-12 16:06:35 (GMT)
committerdgp <dgp@users.sourceforge.net>2009-08-12 16:06:35 (GMT)
commit0c4df9767cafc8b3a0d1c1e472b87610bfa7a84f (patch)
tree304bf5c58de4d0e47cff5c024e4f94cfe16357bc
parentf92b24a616e3a96bef3765e9bda4b66f3c7e5010 (diff)
downloadtcl-0c4df9767cafc8b3a0d1c1e472b87610bfa7a84f.zip
tcl-0c4df9767cafc8b3a0d1c1e472b87610bfa7a84f.tar.gz
tcl-0c4df9767cafc8b3a0d1c1e472b87610bfa7a84f.tar.bz2
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:
-rw-r--r--ChangeLog16
-rw-r--r--doc/NRE.327
-rw-r--r--generic/tcl.decls7
-rw-r--r--generic/tclBasic.c4
-rw-r--r--generic/tclCmdAH.c43
-rw-r--r--generic/tclDecls.h13
-rw-r--r--generic/tclExecute.c182
-rw-r--r--generic/tclInt.h4
-rw-r--r--generic/tclObj.c53
-rw-r--r--generic/tclStubInit.c3
-rw-r--r--tests/expr.test9
11 files changed, 264 insertions, 97 deletions
diff --git a/ChangeLog b/ChangeLog
index 6df7583..92ddd99 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,19 @@
+2009-08-12 Don Porter <dgp@users.sourceforge.net>
+
+ 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:
+
2009-08-06 Andreas Kupries <andreask@activestate.com>
* doc/refchan.n [Bug 2827000]: Extended the implementation of
diff --git a/doc/NRE.3 b/doc/NRE.3
index 331e406..4103e3d 100644
--- a/doc/NRE.3
+++ b/doc/NRE.3
@@ -5,7 +5,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" RCS: @(#) $Id: NRE.3,v 1.3 2008/12/19 18:23:04 dgp Exp $
+'\" RCS: @(#) $Id: NRE.3,v 1.4 2009/08/12 16:06:38 dgp Exp $
'\"
.so man.macros
.TH NRE 3 8.6 Tcl "Tcl Library Procedures"
@@ -31,6 +31,9 @@ int
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 @@ Count of parameters provided to the implementation of a command.
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 @@ If the \fBTCL_EVAL_GLOBAL\fR flag is set, the script or command is
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 @@ and the second is for use when there is already a trampoline in place.
\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
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. */
diff --git a/tests/expr.test b/tests/expr.test
index 5662169..f1612b6 100644
--- a/tests/expr.test
+++ b/tests/expr.test
@@ -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: expr.test,v 1.75 2009/06/01 21:34:22 dgp Exp $
+# RCS: @(#) $Id: expr.test,v 1.76 2009/08/12 16:06:44 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2.1
@@ -7146,6 +7146,13 @@ test expr-48.1 {Bug 1770224} {
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