Attachment "resolver866-2.patch" to
ticket [d4e7780ca1]
added by
gustafn2
2016-07-25 09:36:31.
Index: generic/tclCompExpr.c
==================================================================
--- generic/tclCompExpr.c
+++ generic/tclCompExpr.c
@@ -2270,11 +2270,11 @@
p = TclGetStringFromObj(*funcObjv, &length);
funcObjv++;
Tcl_DStringAppend(&cmdName, p, length);
TclEmitPush(TclRegisterNewCmdLiteral(envPtr,
Tcl_DStringValue(&cmdName),
- Tcl_DStringLength(&cmdName)), envPtr);
+ Tcl_DStringLength(&cmdName), 0), envPtr);
Tcl_DStringFree(&cmdName);
/*
* Start a count of the number of words in this function
* command invocation. In case there's already a count in
Index: generic/tclCompile.c
==================================================================
--- generic/tclCompile.c
+++ generic/tclCompile.c
@@ -1779,14 +1779,24 @@
Tcl_Interp *interp,
Tcl_Obj *cmdObj,
CompileEnv *envPtr)
{
int numBytes;
- const char *bytes = Tcl_GetStringFromObj(cmdObj, &numBytes);
- int cmdLitIdx = TclRegisterNewCmdLiteral(envPtr, bytes, numBytes);
- Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj);
+ const char *bytes;
+ Command *cmdPtr;
+ int cmdLitIdx, extraLiteralFlags = 0;
+ cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj);
+ if (cmdPtr != NULL) {
+ if ((cmdPtr->flags & CMD_VIA_RESOLVER)) {
+ extraLiteralFlags = LITERAL_UNSHARED;
+ }
+ }
+
+ bytes = Tcl_GetStringFromObj(cmdObj, &numBytes);
+ cmdLitIdx = TclRegisterNewCmdLiteral(envPtr, bytes, numBytes, extraLiteralFlags);
+
if (cmdPtr) {
TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLitIdx), cmdPtr);
}
TclEmitPush(cmdLitIdx, envPtr);
}
Index: generic/tclCompile.h
==================================================================
--- generic/tclCompile.h
+++ generic/tclCompile.h
@@ -1206,10 +1206,11 @@
#define TclFetchAuxData(envPtr, index) \
(envPtr)->auxDataArrayPtr[(index)].clientData
#define LITERAL_ON_HEAP 0x01
#define LITERAL_CMD_NAME 0x02
+#define LITERAL_UNSHARED 0x04
/*
* Form of TclRegisterLiteral with flags == 0. In that case, it is safe to
* cast away constness, and it is cleanest to do that here, all in one place.
*
@@ -1227,12 +1228,12 @@
*
* int TclRegisterNewNSLiteral(CompileEnv *envPtr, const char *bytes,
* int length);
*/
-#define TclRegisterNewCmdLiteral(envPtr, bytes, length) \
- TclRegisterLiteral(envPtr, (char *)(bytes), length, LITERAL_CMD_NAME)
+#define TclRegisterNewCmdLiteral(envPtr, bytes, length, extraLiteralFlags) \
+ TclRegisterLiteral(envPtr, (char *)(bytes), length, ((extraLiteralFlags)|LITERAL_CMD_NAME))
/*
* Macro used to manually adjust the stack requirements; used in cases where
* the stack effect cannot be computed from the opcode and its operands, but
* is still known at compile time.
Index: generic/tclEnsemble.c
==================================================================
--- generic/tclEnsemble.c
+++ generic/tclEnsemble.c
@@ -3304,11 +3304,11 @@
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *tokPtr;
Tcl_Obj *objPtr, **words;
char *bytes;
- int length, i, numWords, cmdLit;
+ int length, i, numWords, cmdLit, extraLiteralFlags = 0;
DefineLineInformation;
/*
* Push the words of the command. Take care; the command words may be
* scripts that have backslashes in them, and [info frame 0] can see the
@@ -3347,11 +3347,16 @@
*/
objPtr = Tcl_NewObj();
Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr);
bytes = Tcl_GetStringFromObj(objPtr, &length);
- cmdLit = TclRegisterNewCmdLiteral(envPtr, bytes, length);
+ if (cmdPtr != NULL) {
+ if ((cmdPtr->flags & CMD_VIA_RESOLVER)) {
+ extraLiteralFlags = LITERAL_UNSHARED;
+ }
+ }
+ cmdLit = TclRegisterNewCmdLiteral(envPtr, bytes, length, extraLiteralFlags);
TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLit), cmdPtr);
TclEmitPush(cmdLit, envPtr);
TclDecrRefCount(objPtr);
/*
Index: generic/tclInt.h
==================================================================
--- generic/tclInt.h
+++ generic/tclInt.h
@@ -1675,15 +1675,17 @@
* TCL_TRACE_DELETE - A delete trace is in progress. Further
* recursive deletes will not be traced.
* (these last two flags are defined in tcl.h)
*/
-#define CMD_IS_DELETED 0x1
-#define CMD_TRACE_ACTIVE 0x2
-#define CMD_HAS_EXEC_TRACES 0x4
-#define CMD_COMPILES_EXPANDED 0x8
+#define CMD_IS_DELETED 0x01
+#define CMD_TRACE_ACTIVE 0x02
+#define CMD_HAS_EXEC_TRACES 0x04
+#define CMD_COMPILES_EXPANDED 0x08
#define CMD_REDEF_IN_PROGRESS 0x10
+#define CMD_VIA_RESOLVER 0x20
+
/*
*----------------------------------------------------------------
* Data structures related to name resolution procedures.
*----------------------------------------------------------------
Index: generic/tclLiteral.c
==================================================================
--- generic/tclLiteral.c
+++ generic/tclLiteral.c
@@ -212,19 +212,20 @@
*newPtr = 0;
}
if (globalPtrPtr) {
*globalPtrPtr = globalPtr;
}
- if (flags & LITERAL_ON_HEAP) {
+ if ((flags & LITERAL_ON_HEAP)) {
ckfree(bytes);
}
globalPtr->refCount++;
return objPtr;
}
}
+
if (!newPtr) {
- if (flags & LITERAL_ON_HEAP) {
+ if ((flags & LITERAL_ON_HEAP)) {
ckfree(bytes);
}
return NULL;
}
@@ -233,16 +234,27 @@
* table.
*/
TclNewObj(objPtr);
Tcl_IncrRefCount(objPtr);
- if (flags & LITERAL_ON_HEAP) {
+ if ((flags & LITERAL_ON_HEAP)) {
objPtr->bytes = bytes;
objPtr->length = length;
} else {
TclInitStringRep(objPtr, bytes, length);
}
+
+ if ((flags & LITERAL_UNSHARED)) {
+ /*
+ * Make clear, that no global value is returned
+ */
+ if (globalPtrPtr != NULL) {
+ *globalPtrPtr = NULL;
+ }
+ /*fprintf(stderr, "UNSHARED LITERAL <%s>\n", bytes);*/
+ return objPtr;
+ }
#ifdef TCL_COMPILE_DEBUG
if (LookupLiteralEntry((Tcl_Interp *) iPtr, objPtr) != NULL) {
Tcl_Panic("%s: literal \"%.*s\" found globally but shouldn't be",
"TclRegisterLiteral", (length>60? 60 : length), bytes);
@@ -415,30 +427,30 @@
* sharing it accross namespaces, and try not to share it with non-cmd
* literals. Note that FQ command names can be shared, so that we register
* the namespace as the interp's global NS.
*/
- if (flags & LITERAL_CMD_NAME) {
+ if ((flags & LITERAL_CMD_NAME)) {
if ((length >= 2) && (bytes[0] == ':') && (bytes[1] == ':')) {
nsPtr = iPtr->globalNsPtr;
} else {
nsPtr = iPtr->varFramePtr->nsPtr;
}
} else {
nsPtr = NULL;
}
-
+
/*
* Is it in the interpreter's global literal table? If not, create it.
*/
-
+ globalPtr = NULL;
objPtr = TclCreateLiteral(iPtr, bytes, length, hash, &new, nsPtr, flags,
&globalPtr);
objIndex = AddLocalLiteralEntry(envPtr, objPtr, localHash);
#ifdef TCL_COMPILE_DEBUG
- if (globalPtr->refCount < 1) {
+ if (globalPtr != NULL && globalPtr->refCount < 1) {
Tcl_Panic("%s: global literal \"%.*s\" had bad refCount %d",
"TclRegisterLiteral", (length>60? 60 : length), bytes,
globalPtr->refCount);
}
TclVerifyLocalLiteralTable(envPtr);
@@ -1153,13 +1165,14 @@
(length>60? 60 : length), bytes, localPtr->refCount);
}
if (LookupLiteralEntry((Tcl_Interp *) envPtr->iPtr,
localPtr->objPtr) == NULL) {
bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length);
- Tcl_Panic("%s: local literal \"%.*s\" is not global",
- "TclVerifyLocalLiteralTable",
- (length>60? 60 : length), bytes);
+ //Tcl_Panic("%s: local literal \"%.*s\" is not global",
+ // "TclVerifyLocalLiteralTable",
+ // (length>60? 60 : length), bytes);
+ /*fprintf(stderr, "local literal \"%s\" is not global\n",bytes);*/
}
if (localPtr->objPtr->bytes == NULL) {
Tcl_Panic("%s: literal has NULL string rep",
"TclVerifyLocalLiteralTable");
}
Index: generic/tclNamesp.c
==================================================================
--- generic/tclNamesp.c
+++ generic/tclNamesp.c
@@ -2564,11 +2564,13 @@
}
resPtr = resPtr->nextPtr;
}
if (result == TCL_OK) {
+ ((Command *)cmd)->flags |= CMD_VIA_RESOLVER;
return cmd;
+
} else if (result != TCL_CONTINUE) {
return NULL;
}
}
@@ -2656,10 +2658,11 @@
}
}
}
if (cmdPtr != NULL) {
+ cmdPtr->flags &= ~CMD_VIA_RESOLVER;
return (Tcl_Command) cmdPtr;
}
if (flags & TCL_LEAVE_ERR_MSG) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
Index: generic/tclObj.c
==================================================================
--- generic/tclObj.c
+++ generic/tclObj.c
@@ -4217,11 +4217,14 @@
register ResolvedCmdName *resPtr;
register Namespace *currNsPtr;
const char *name;
if (objPtr->typePtr == &tclCmdNameType) {
- return;
+ resPtr = objPtr->internalRep.twoPtrValue.ptr1;
+ if (resPtr->cmdPtr == cmdPtr) {
+ return;
+ }
}
cmdPtr->refCount++;
resPtr = ckalloc(sizeof(ResolvedCmdName));
resPtr->cmdPtr = cmdPtr;
@@ -4395,11 +4398,13 @@
if (cmdPtr) {
cmdPtr->refCount++;
resPtr = objPtr->internalRep.twoPtrValue.ptr1;
if ((objPtr->typePtr == &tclCmdNameType)
- && resPtr && (resPtr->refCount == 1)) {
+ && resPtr != NULL
+ && (resPtr->refCount == 1)
+ ) {
/*
* Reuse the old ResolvedCmdName struct instead of freeing it
*/
Command *oldCmdPtr = resPtr->cmdPtr;
Index: generic/tclTest.c
==================================================================
--- generic/tclTest.c
+++ generic/tclTest.c
@@ -7293,33 +7293,92 @@
const char *name,
Tcl_Namespace *context,
int flags,
Tcl_Command *rPtr)
{
- Interp *iPtr = (Interp *) interp;
- CallFrame *varFramePtr = iPtr->varFramePtr;
- Proc *procPtr = (varFramePtr->isProcCallFrame & FRAME_IS_PROC) ?
- varFramePtr->procPtr : NULL;
- Namespace *ns2NsPtr = (Namespace *)
- Tcl_FindNamespace(interp, "::ns2", NULL, 0);
+ Interp *iPtr = (Interp *) interp;
+ CallFrame *varFramePtr = iPtr->varFramePtr;
+ Proc *procPtr = (varFramePtr->isProcCallFrame & FRAME_IS_PROC) ? varFramePtr->procPtr : NULL;
+ Namespace *callerNsPtr = varFramePtr->nsPtr;
+ Tcl_Command resolvedCmdPtr = NULL;
- if (procPtr && (procPtr->cmdPtr->nsPtr == iPtr->globalNsPtr
- || (ns2NsPtr && procPtr->cmdPtr->nsPtr == ns2NsPtr))) {
- const char *callingCmdName =
+ /*
+ * Just do something special on a cmd literal "z" in two cases:
+ * A) when the caller is a proc "x", and the proc is either in "::" or in "::ns2".
+ * B) the caller's namespace is "ctx1" or "ctx2"
+ */
+ if ( (name[0] == 'z') && (name[1] == '\0') ) {
+ Namespace *ns2NsPtr = (Namespace *) Tcl_FindNamespace(interp, "::ns2", NULL, 0);
+
+ if (procPtr != NULL
+ && ((procPtr->cmdPtr->nsPtr == iPtr->globalNsPtr)
+ || (ns2NsPtr != NULL && procPtr->cmdPtr->nsPtr == ns2NsPtr)
+ )
+ ) {
+ /*
+ * Case A)
+ *
+ * - The context, in which this resolver becomes active, is
+ * determined by the name of the caller proc, which has to be
+ * named "x".
+ *
+ * - To determine the name of the caller proc, the proc is taken
+ * from the topmost stack frame.
+ *
+ * - Note that the context is NOT provided during byte-code
+ * compilation (e.g. in TclProcCompileProc)
+ *
+ * When these conditions hold, this function resolves the
+ * passed-in cmd literal into a cmd "y", which is taken from the
+ * the global namespace (for simplicity).
+ */
+
+ const char *callingCmdName =
Tcl_GetCommandName(interp, (Tcl_Command) procPtr->cmdPtr);
+
+ if ( callingCmdName[0] == 'x' && callingCmdName[1] == '\0' ) {
+ resolvedCmdPtr = Tcl_FindCommand(interp, "y", NULL, TCL_GLOBAL_ONLY);
+ }
+ } else if (callerNsPtr != NULL) {
+ /*
+ * Case B)
+ *
+ * - The context, in which this resolver becomes active, is
+ * determined by the name of the parent namespace, which has
+ * to be named "ctx1" or "ctx2".
+ *
+ * - To determine the name of the parent namesace, it is taken
+ * from the 2nd highest stack frame.
+ *
+ * - Note that the context can be provided during byte-code
+ * compilation (e.g. in TclProcCompileProc)
+ *
+ * When these conditions hold, this function resolves the
+ * passed-in cmd literal into a cmd "y" or "Y" depending on the
+ * context. The resolved procs are taken from the the global
+ * namespace (for simplicity).
+ */
- if ((callingCmdName[0] == 'x') && (callingCmdName[1] == '\0')
- && (name[0] == 'z') && (name[1] == '\0')) {
- Tcl_Command sourceCmdPtr = Tcl_FindCommand(interp, "y", NULL,
- TCL_GLOBAL_ONLY);
+ CallFrame *parentFramePtr = varFramePtr->callerPtr;
+ char *context = parentFramePtr != NULL ? parentFramePtr->nsPtr->name : "(NULL)";
- if (sourceCmdPtr != NULL) {
- *rPtr = sourceCmdPtr;
- return TCL_OK;
+ if (strcmp(context, "ctx1") == 0 && (name[0] == 'z') && (name[1] == '\0')) {
+ resolvedCmdPtr = Tcl_FindCommand(interp, "y", NULL, TCL_GLOBAL_ONLY);
+ /* fprintf(stderr, "... y ==> %p\n", resolvedCmdPtr);*/
+
+ } else if (strcmp(context, "ctx2") == 0 && (name[0] == 'z') && (name[1] == '\0')) {
+ resolvedCmdPtr = Tcl_FindCommand(interp, "Y", NULL, TCL_GLOBAL_ONLY);
+ /*fprintf(stderr, "... Y ==> %p\n", resolvedCmdPtr);*/
}
}
+
+ if (resolvedCmdPtr != NULL) {
+ *rPtr = resolvedCmdPtr;
+ return TCL_OK;
+ }
}
+
return TCL_CONTINUE;
}
static int
InterpVarResolver(
@@ -7447,13 +7506,20 @@
"down", "up", NULL
};
int idx;
#define RESOLVER_KEY "testInterpResolver"
- if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "up|down");
+ if (objc < 2 || objc >3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "up|down ?interp?");
return TCL_ERROR;
+ }
+ if (objc == 3) {
+ interp = Tcl_GetSlave(interp, Tcl_GetString(objv[2]));
+ if (interp == NULL) {
+ Tcl_AppendResult(interp, "provided interpreter not found", NULL);
+ return TCL_ERROR;
+ }
}
if (Tcl_GetIndexFromObj(interp, objv[1], table, "operation", TCL_EXACT,
&idx) != TCL_OK) {
return TCL_ERROR;
}
Index: tests/resolver.test
==================================================================
--- tests/resolver.test
+++ tests/resolver.test
@@ -36,14 +36,16 @@
# tclTest.c) maps the cmd token "z" to "::y"; this mapping is saved in the
# resulting CmdName Tcl_Obj with the print string "z". The CmdName Tcl_Obj
# is turned into a command literal shared for a given (here: the global)
# namespace.
set r0 [x]; # --> The result of [x] is "Y"
+
# 2) After having requested cmd resolution above, we can now use the
# globally shared CmdName Tcl_Obj "z", now bound to cmd ::y. This is
# certainly questionable, but defensible
set r1 [z]; # --> The result of [z] is "Y"
+
# 3) We import from the namespace ns1 another z. [namespace import] takes
# care "shadowed" cmd references, however, till now cmd literals have not
# been touched. This is, however, necessary since the BC compiler (used in
# the [namespace eval]) seems to be eager to reuse CmdName Tcl_Objs as cmd
# literals for a given NS scope. We expect, that r2 is "Z", the result of
@@ -57,16 +59,16 @@
testinterpresolver down
rename ::x ""
rename ::y ""
namespace delete ::ns1
} -result {Y Y Z}
+
+
test resolver-1.2 {cmdNameObj sharing vs. cmd resolver: proc creation} -setup {
testinterpresolver up
proc ::y {} { return Y }
- proc ::x {} {
- z
- }
+ proc ::x {} { z }
} -constraints testinterpresolver -body {
set r0 [x]
set r1 [z]
proc ::foo {} {
proc ::z {} { return Z }
@@ -78,10 +80,12 @@
rename ::x ""
rename ::y ""
rename ::foo ""
rename ::z ""
} -result {Y Y Z}
+
+
test resolver-1.3 {cmdNameObj sharing vs. cmd resolver: rename} -setup {
testinterpresolver up
proc ::Z {} { return Z }
proc ::y {} { return Y }
proc ::x {} {
@@ -99,10 +103,12 @@
testinterpresolver down
rename ::x ""
rename ::y ""
rename ::z ""
} -result {Y Y Z}
+
+
test resolver-1.4 {cmdNameObj sharing vs. cmd resolver: interp expose} -setup {
testinterpresolver up
proc ::Z {} { return Z }
interp hide {} Z
proc ::y {} { return Y }
@@ -121,21 +127,21 @@
testinterpresolver down
rename ::x ""
rename ::y ""
rename ::z ""
} -result {Y Y Z}
+
+
test resolver-1.5 {cmdNameObj sharing vs. cmd resolver: other than global NS} -setup {
testinterpresolver up
namespace eval ::ns1 {
proc z {} { return Z }
namespace export z
}
proc ::y {} { return Y }
namespace eval ::ns2 {
- proc x {} {
- z
- }
+ proc x {} { z }
}
namespace eval :: {
variable r2 ""
}
} -constraints testinterpresolver -body {
@@ -149,17 +155,17 @@
} -cleanup {
testinterpresolver down
namespace delete ::ns2
namespace delete ::ns1
} -result {Y Y Z}
+
+
test resolver-1.6 {cmdNameObj sharing vs. cmd resolver: interp alias} -setup {
testinterpresolver up
proc ::Z {} { return Z }
proc ::y {} { return Y }
- proc ::x {} {
- z
- }
+ proc ::x {} { z }
} -constraints testinterpresolver -body {
set r0 [x]
set r1 [z]
namespace eval :: {
interp alias {} ::z {} ::Z
@@ -185,22 +191,137 @@
} -constraints testinterpresolver -body {
# Call "x" the first time, causing a byte code compilation of the body.
# During the compilation the compiled var resolver, the resolve-specific
# var info is allocated, during the execution of the body, the variable is
# fetched and cached.
- x;
+ x
# During later calls, the cached variable is reused.
x
# When the proc is freed, the resolver-specific resolver var info is
# freed. This did not happen before fix #3383616.
rename ::x ""
} -cleanup {
testinterpresolver down
} -result {}
+
+
+#
+# The test resolver-3.1* test bad interactions of resolvers on the "global"
+# (per interp) literal pools. A resolver might resolve a cmd literal depending
+# on a context differently, whereas the cmd literal sharing assumed that the
+# namespace containing the literal solely determines the resolved cmd (and is
+# resolver-agnostic).
+#
+# In order to make the test cases for the per-interpreter cmd literal pool
+# reproducable and to minimize interactions between test cases, we use a slave
+# interpreter per test-case.
+#
+#
+# Testing resolver in namespace-based context "ctx1"
+#
+test resolver-3.1a {
+ interp command resolver,
+ resolve literal "z" in proc "x1" in context "ctx1"
+} -setup {
+
+ interp create i0
+ testinterpresolver up i0
+ i0 eval {
+ proc y {} { return yy }
+ namespace eval ::ns {
+ proc x1 {} { z }
+ }
+ }
+} -constraints testinterpresolver -body {
+
+ set r [i0 eval {namespace eval ::ctx1 {
+ ::ns::x1
+ }}]
+
+ return $r
+} -cleanup {
+ testinterpresolver down i0
+ interp delete i0
+} -result {yy}
+
+#
+# Testing resolver in namespace-based context "ctx2"
+#
+test resolver-3.1b {
+ interp command resolver,
+ resolve literal "z" in proc "x2" in context "ctx2"
+} -setup {
+
+ interp create i0
+ testinterpresolver up i0
+ i0 eval {
+ proc Y {} { return YY }
+ namespace eval ::ns {
+ proc x2 {} { z }
+ }
+ }
+} -constraints testinterpresolver -body {
+
+ set r [i0 eval {namespace eval ::ctx2 {
+ ::ns::x2
+ }}]
+
+ return $r
+} -cleanup {
+ testinterpresolver down i0
+ interp delete i0
+} -result {YY}
+
+#
+# Testing resolver in namespace-based context "ctx1" and "ctx2" in the same
+# interpreter.
+#
+
+test resolver-3.1c {
+ interp command resolver,
+ resolve literal "z" in proc "x1" in context "ctx1",
+ resolve literal "z" in proc "x2" in context "ctx2"
+
+ Test, whether the shared cmd literal created by the first byte-code
+ compilation interacts with the second one.
+} -setup {
+
+ interp create i0
+ testinterpresolver up i0
+
+ i0 eval {
+ proc y {} { return yy }
+ proc Y {} { return YY }
+ namespace eval ::ns {
+ proc x1 {} { z }
+ proc x2 {} { z }
+ }
+ }
+
+} -constraints testinterpresolver -body {
+
+ set r1 [i0 eval {namespace eval ::ctx1 {
+ ::ns::x1
+ }}]
+
+ set r2 [i0 eval {namespace eval ::ctx2 {
+ ::ns::x2
+ }}]
+
+ set r3 [i0 eval {namespace eval ::ctx1 {
+ ::ns::x1
+ }}]
+
+ return [list $r1 $r2 $r3]
+} -cleanup {
+ testinterpresolver down i0
+ interp delete i0
+} -result {yy YY yy}
+
cleanupTests
return
# Local Variables:
# mode: tcl
# fill-column: 78
# End:
