diff options
| -rw-r--r-- | ChangeLog | 10 | ||||
| -rw-r--r-- | generic/tclBasic.c | 4 | ||||
| -rw-r--r-- | generic/tclCmdMZ.c | 22 | ||||
| -rw-r--r-- | generic/tclCompCmds.c | 37 | ||||
| -rw-r--r-- | generic/tclCompile.c | 156 | ||||
| -rw-r--r-- | generic/tclInt.h | 8 | ||||
| -rw-r--r-- | tests/coroutine.test | 4 | ||||
| -rw-r--r-- | tests/parse.test | 4 |
8 files changed, 215 insertions, 30 deletions
@@ -1,3 +1,13 @@ +2009-09-11 Don Porter <dgp@users.sourceforge.net> + + * generic/tclBasic.c: Completed the NR-enabling of [subst]. + * generic/tclCmdMZ.c: [Bug 2314561]. + * generic/tclCompCmds.c: + * generic/tclCompile.c: + * generic/tclInt.h: + * tests/coroutine.test: + * tests/parse.test: + 2009-09-11 Donal K. Fellows <dkf@users.sf.net> * tests/http.test: Added in cleaning up of http tokens for each test diff --git a/generic/tclBasic.c b/generic/tclBasic.c index b5abbc2..7064b86 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.403 2009/09/04 17:33:11 dgp Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.404 2009/09/11 20:13:27 dgp Exp $ */ #include "tclInt.h" @@ -213,7 +213,7 @@ static const CmdInfo builtInCmds[] = { {"scan", Tcl_ScanObjCmd, NULL, NULL, 1}, {"set", Tcl_SetObjCmd, TclCompileSetCmd, NULL, 1}, {"split", Tcl_SplitObjCmd, NULL, NULL, 1}, - {"subst", Tcl_SubstObjCmd, TclCompileSubstCmd, NULL, 1}, + {"subst", Tcl_SubstObjCmd, TclCompileSubstCmd, TclNRSubstObjCmd, 1}, {"switch", Tcl_SwitchObjCmd, TclCompileSwitchCmd, TclNRSwitchObjCmd, 1}, {"throw", Tcl_ThrowObjCmd, NULL, NULL, 1}, {"trace", Tcl_TraceObjCmd, NULL, NULL, 1}, diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index a5a2f1b..72b46af 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -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: tclCmdMZ.c,v 1.192 2009/09/04 17:33:11 dgp Exp $ + * RCS: @(#) $Id: tclCmdMZ.c,v 1.193 2009/09/11 20:13:27 dgp Exp $ */ #include "tclInt.h" @@ -3419,7 +3419,16 @@ Tcl_SubstObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_Obj *resultPtr; + return Tcl_NRCallObjProc(interp, TclNRSubstObjCmd, dummy, objc, objv); +} + +int +TclNRSubstObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ int flags; if (objc < 2) { @@ -3431,14 +3440,7 @@ Tcl_SubstObjCmd( if (TclSubstOptions(interp, objc-2, objv+1, &flags) != TCL_OK) { return TCL_ERROR; } - - resultPtr = Tcl_SubstObj(interp, objv[objc-1], flags); - - if (resultPtr == NULL) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, resultPtr); - return TCL_OK; + return TclNRSubstObj(interp, objv[objc-1], flags); } /* diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 9b33b41..6ec2265 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -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: tclCompCmds.c,v 1.156 2009/09/04 23:14:32 dgp Exp $ + * RCS: @(#) $Id: tclCompCmds.c,v 1.157 2009/09/11 20:13:27 dgp Exp $ */ #include "tclInt.h" @@ -3874,14 +3874,9 @@ TclCompileSubstCmd( int numOpts = numArgs - 1; int objc, flags = TCL_SUBST_ALL; Tcl_Obj **objv/*, *toSubst = NULL*/; - Tcl_Parse parse; - Tcl_InterpState state = NULL; Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr); - int breakOffset = 0, count = 0, code = TCL_ERROR; - Tcl_Token *endTokenPtr, *tokenPtr; + int code = TCL_ERROR; DefineLineInformation; /* TIP #280 */ - int bline = mapPtr->loc[eclIndex].line[numArgs]; - SetLineInformation(numArgs); if (numArgs == 0) { return TCL_ERROR; @@ -3925,8 +3920,29 @@ TclCompileSubstCmd( return TCL_ERROR; } - TclSubstParse(interp, /*toSubst,*/ wordTokenPtr[1].start, - wordTokenPtr[1].size, flags, &parse, &state); + SetLineInformation(numArgs); + TclSubstCompile(interp, wordTokenPtr[1].start, wordTokenPtr[1].size, flags, + mapPtr->loc[eclIndex].line[numArgs], envPtr); + +/* TclDecrRefCount(toSubst);*/ + return TCL_OK; +} + +void +TclSubstCompile( + Tcl_Interp *interp, + const char *bytes, + int numBytes, + int flags, + int line, + CompileEnv *envPtr) +{ + Tcl_Token *endTokenPtr, *tokenPtr; + int breakOffset = 0, count = 0, bline = line; + Tcl_Parse parse; + Tcl_InterpState state = NULL; + + TclSubstParse(interp, bytes, numBytes, flags, &parse, &state); for (tokenPtr = parse.tokenPtr, endTokenPtr = tokenPtr + parse.numTokens; tokenPtr < endTokenPtr; tokenPtr = TokenAfter(tokenPtr)) { @@ -4101,7 +4117,6 @@ TclCompileSubstCmd( } Tcl_FreeParse(&parse); -/* TclDecrRefCount(toSubst);*/ if (state != NULL) { Tcl_RestoreInterpState(interp, state); @@ -4113,8 +4128,6 @@ TclCompileSubstCmd( TclUpdateInstInt4AtPc(INST_JUMP4, CurrentOffset(envPtr) - breakOffset, envPtr->codeStart + breakOffset); } - - return TCL_OK; } /* diff --git a/generic/tclCompile.c b/generic/tclCompile.c index b6b270b..3fa57db 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompile.c,v 1.173 2009/09/04 17:33:11 dgp Exp $ + * RCS: @(#) $Id: tclCompile.c,v 1.174 2009/09/11 20:13:27 dgp Exp $ */ #include "tclInt.h" @@ -413,6 +413,8 @@ InstructionDesc const tclInstructionTable[] = { * Prototypes for procedures defined later in this file: */ +static ByteCode * CompileSubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr, + int flags); static void DupByteCodeInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); static unsigned char * EncodeCmdLocMap(CompileEnv *envPtr, @@ -422,6 +424,7 @@ static void EnterCmdExtentData(CompileEnv *envPtr, static void EnterCmdStartData(CompileEnv *envPtr, int cmdNumber, int srcOffset, int codeOffset); static void FreeByteCodeInternalRep(Tcl_Obj *objPtr); +static void FreeSubstCodeInternalRep(Tcl_Obj *objPtr); static int GetCmdLocEncodingSize(CompileEnv *envPtr); #ifdef TCL_COMPILE_STATS static void RecordByteCodeStats(ByteCode *codePtr); @@ -453,6 +456,19 @@ const Tcl_ObjType tclByteCodeType = { NULL, /* updateStringProc */ SetByteCodeFromAny /* setFromAnyProc */ }; + +/* + * The structure below defines a bytecode Tcl object type to hold the + * compiled bytecode for the [subst]itution of Tcl values. + */ + +static const Tcl_ObjType substCodeType = { + "substcode", /* name */ + FreeSubstCodeInternalRep, /* freeIntRepProc */ + DupByteCodeInternalRep, /* dupIntRepProc - shared with bytecode */ + NULL, /* updateStringProc */ + NULL, /* setFromAnyProc */ +}; /* *---------------------------------------------------------------------- @@ -859,6 +875,144 @@ TclCleanupByteCode( /* *---------------------------------------------------------------------- * + * TclNRSubstObj -- + * + * Request substitution of a Tcl value by the NR stack. + * + * Results: + * Returns TCL_OK. + * + * Side effects: + * Compiles objPtr into bytecode that performs the substitutions as + * governed by flags and places callbacks on the NR stack to execute + * the bytecode and store the result in the interp. + * + *---------------------------------------------------------------------- + */ + +int +TclNRSubstObj( + Tcl_Interp *interp, + Tcl_Obj *objPtr, + int flags) +{ + ByteCode *codePtr = CompileSubstObj(interp, objPtr, flags); + + /* TODO: Confirm we do not need this. */ + /* Tcl_ResetResult(interp); */ + Tcl_NRAddCallback(interp, NRCallTEBC, INT2PTR(TCL_NR_BC_TYPE), codePtr, + NULL, NULL); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * CompileSubstObj -- + * + * Compile a Tcl value into ByteCode implementing its substitution, + * as governed by flags. + * + * 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 "substcode" type, + * and the ByteCode and governing flags value are kept in the internal + * rep for faster operations the next time CompileSubstObj is called + * on the same value. + * + *---------------------------------------------------------------------- + */ + +static ByteCode * +CompileSubstObj( + Tcl_Interp *interp, + Tcl_Obj *objPtr, + int flags) +{ + Interp *iPtr = (Interp *) interp; + ByteCode *codePtr = NULL; + + if (objPtr->typePtr == &substCodeType) { + Namespace *nsPtr = iPtr->varFramePtr->nsPtr; + + codePtr = (ByteCode *) objPtr->internalRep.ptrAndLongRep.ptr; + if (flags != objPtr->internalRep.ptrAndLongRep.value + || ((Interp *) *codePtr->interpHandle != iPtr) + || (codePtr->compileEpoch != iPtr->compileEpoch) + || (codePtr->nsPtr != nsPtr) + || (codePtr->nsEpoch != nsPtr->resolverEpoch) + || (codePtr->localCachePtr != + iPtr->varFramePtr->localCachePtr)) { + FreeSubstCodeInternalRep(objPtr); + } + } + if (objPtr->typePtr != &substCodeType) { + CompileEnv compEnv; + int numBytes; + const char *bytes = Tcl_GetStringFromObj(objPtr, &numBytes); + + /* TODO: Check for more TIP 280 */ + TclInitCompileEnv(interp, &compEnv, bytes, numBytes, NULL, 0); + + TclSubstCompile(interp, bytes, numBytes, flags, 1, &compEnv); + + TclEmitOpcode(INST_DONE, &compEnv); + TclInitByteCodeObj(objPtr, &compEnv); + objPtr->typePtr = &substCodeType; + TclFreeCompileEnv(&compEnv); + codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; + objPtr->internalRep.ptrAndLongRep.ptr = codePtr; + objPtr->internalRep.ptrAndLongRep.value = flags; + if (iPtr->varFramePtr->localCachePtr) { + codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; + codePtr->localCachePtr->refCount++; + } + /* TODO: Debug printing? */ + } + return codePtr; +} + +/* + *---------------------------------------------------------------------- + * + * FreeSubstCodeInternalRep -- + * + * Part of the substcode Tcl object type implementation. Frees the storage + * associated with a substcode object's internal representation unless its + * code is actively being executed. + * + * Results: + * None. + * + * Side effects: + * The substcode object's internal rep is marked invalid and its code gets + * freed unless the code is actively being executed. In that case the + * cleanup is delayed until the last execution of the code completes. + * + *---------------------------------------------------------------------- + */ + +static void +FreeSubstCodeInternalRep( + register Tcl_Obj *objPtr) /* Object whose internal rep to free. */ +{ + register ByteCode *codePtr = objPtr->internalRep.ptrAndLongRep.ptr; + + codePtr->refCount--; + if (codePtr->refCount <= 0) { + TclCleanupByteCode(codePtr); + } + objPtr->typePtr = NULL; + objPtr->internalRep.otherValuePtr = NULL; +} + +/* + *---------------------------------------------------------------------- + * * TclInitCompileEnv -- * * Initializes a CompileEnv compilation environment structure for the diff --git a/generic/tclInt.h b/generic/tclInt.h index a27b0f4..6f7972f 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.441 2009/09/07 06:20:47 das Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.442 2009/09/11 20:13:27 dgp Exp $ */ #ifndef _TCLINT @@ -2651,6 +2651,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRForObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRForeachCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRIfObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRSourceObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclNRSubstObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRSwitchObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRTryObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRWhileObjCmd; @@ -2846,6 +2847,8 @@ MODULE_SCOPE int TclMarkList(Tcl_Interp *interp, const char *list, MODULE_SCOPE int TclMergeReturnOptions(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], Tcl_Obj **optionsPtrPtr, int *codePtr, int *levelPtr); +MODULE_SCOPE int TclNRSubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr, + int flags); MODULE_SCOPE int TclNokia770Doubles(); MODULE_SCOPE void TclObjVarErrMsg(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const char *operation, @@ -2950,6 +2953,9 @@ MODULE_SCOPE int TclStringMatch(const char *str, int strLen, MODULE_SCOPE int TclStringMatchObj(Tcl_Obj *stringObj, Tcl_Obj *patternObj, int flags); MODULE_SCOPE Tcl_Obj * TclStringObjReverse(Tcl_Obj *objPtr); +MODULE_SCOPE void TclSubstCompile(Tcl_Interp *interp, const char *bytes, + int numBytes, int flags, int line, + struct CompileEnv *envPtr); MODULE_SCOPE int TclSubstOptions(Tcl_Interp *interp, int numOpts, Tcl_Obj *const opts[], int *flagPtr); MODULE_SCOPE void TclSubstParse(Tcl_Interp *interp, const char *bytes, diff --git a/tests/coroutine.test b/tests/coroutine.test index b3ae02a..776dda5 100644 --- a/tests/coroutine.test +++ b/tests/coroutine.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: coroutine.test,v 1.5 2009/09/07 14:47:16 dkf Exp $ +# RCS: @(#) $Id: coroutine.test,v 1.6 2009/09/11 20:13:27 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -280,7 +280,7 @@ test coroutine-1.12 {proc as coroutine} -setup { test coroutine-1.13 {subst as coroutine: literal} { list [coroutine foo eval {subst {>>[yield a],[yield b]<<}}] [foo x] [foo y] } {a b >>x,y<<} -test coroutine-1.14 {subst as coroutine: in variable} knownBug { +test coroutine-1.14 {subst as coroutine: in variable} { set pattern {>>[yield c],[yield d]<<} list [coroutine foo eval {subst $pattern}] [foo p] [foo q] } {c d >>p,q<<} diff --git a/tests/parse.test b/tests/parse.test index b745a97..482c3b8 100644 --- a/tests/parse.test +++ b/tests/parse.test @@ -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: parse.test,v 1.37 2009/09/04 17:33:12 dgp Exp $ +# RCS: @(#) $Id: parse.test,v 1.38 2009/09/11 20:13:27 dgp Exp $ if {[catch {package require tcltest 2.0.2}]} { puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required." @@ -1048,7 +1048,7 @@ test parse-19.3 {Bug 1115904: recursion limit in Tcl_EvalEx} -setup { interp delete i } -test parse-19.4 {Bug 1115904: recursion limit in Tcl_EvalEx} -setup { +test parse-19.4 {Bug 1115904: recursion limit in Tcl_EvalEx} -constraints knownBug -setup { interp create i i eval {proc {} args {}} interp recursionlimit i 2 |