summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2009-09-11 20:13:27 (GMT)
committerdgp <dgp@users.sourceforge.net>2009-09-11 20:13:27 (GMT)
commitc30ce8dcf495febef9d5111ae53ac2a614e593c1 (patch)
tree3752be5dcbdff1a044daf4602cb5e78552c4d52d
parent8bfbb0cd8dbc0d85beef1db77403d7c60a39df65 (diff)
downloadtcl-c30ce8dcf495febef9d5111ae53ac2a614e593c1.zip
tcl-c30ce8dcf495febef9d5111ae53ac2a614e593c1.tar.gz
tcl-c30ce8dcf495febef9d5111ae53ac2a614e593c1.tar.bz2
* 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:
-rw-r--r--ChangeLog10
-rw-r--r--generic/tclBasic.c4
-rw-r--r--generic/tclCmdMZ.c22
-rw-r--r--generic/tclCompCmds.c37
-rw-r--r--generic/tclCompile.c156
-rw-r--r--generic/tclInt.h8
-rw-r--r--tests/coroutine.test4
-rw-r--r--tests/parse.test4
8 files changed, 215 insertions, 30 deletions
diff --git a/ChangeLog b/ChangeLog
index a597ccc..b0efb5e 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -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