diff options
Diffstat (limited to 'generic')
| -rw-r--r-- | generic/tcl.decls | 7 | ||||
| -rw-r--r-- | generic/tclBasic.c | 4 | ||||
| -rw-r--r-- | generic/tclCmdAH.c | 43 | ||||
| -rw-r--r-- | generic/tclDecls.h | 13 | ||||
| -rw-r--r-- | generic/tclExecute.c | 182 | ||||
| -rw-r--r-- | generic/tclInt.h | 4 | ||||
| -rw-r--r-- | generic/tclObj.c | 53 | ||||
| -rw-r--r-- | generic/tclStubInit.c | 3 |
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. */ |