Index: generic/tclCompile.c ================================================================== --- generic/tclCompile.c +++ generic/tclCompile.c @@ -1779,13 +1779,21 @@ 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 = LITERAL_CMD_NAME; + + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj); + if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) { + extraLiteralFlags |= LITERAL_UNSHARED; + } + + bytes = Tcl_GetStringFromObj(cmdObj, &numBytes); + cmdLitIdx = TclRegisterLiteral(envPtr, (char *)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. * 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 = LITERAL_CMD_NAME; 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,14 @@ */ objPtr = Tcl_NewObj(); Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr); bytes = Tcl_GetStringFromObj(objPtr, &length); - cmdLit = TclRegisterNewCmdLiteral(envPtr, bytes, length); + if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) { + extraLiteralFlags |= LITERAL_UNSHARED; + } + cmdLit = TclRegisterLiteral(envPtr, (char *)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 @@ -239,10 +239,20 @@ 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; + } + 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); @@ -1151,17 +1161,10 @@ bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length); Tcl_Panic("%s: local literal \"%.*s\" had bad refCount %d", "TclVerifyLocalLiteralTable", (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); - } 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 != NULL && resPtr->cmdPtr == cmdPtr) { + return; + } } cmdPtr->refCount++; resPtr = ckalloc(sizeof(ResolvedCmdName)); resPtr->cmdPtr = cmdPtr; Index: generic/tclTest.c ================================================================== --- generic/tclTest.c +++ generic/tclTest.c @@ -7297,27 +7297,86 @@ { 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); + Namespace *callerNsPtr = varFramePtr->nsPtr; + Tcl_Command resolvedCmdPtr = NULL; + + /* + * 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). + */ - if (procPtr && (procPtr->cmdPtr->nsPtr == iPtr->globalNsPtr - || (ns2NsPtr && procPtr->cmdPtr->nsPtr == ns2NsPtr))) { - const char *callingCmdName = + const char *callingCmdName = Tcl_GetCommandName(interp, (Tcl_Command) procPtr->cmdPtr); - if ((callingCmdName[0] == 'x') && (callingCmdName[1] == '\0') - && (name[0] == 'z') && (name[1] == '\0')) { - Tcl_Command sourceCmdPtr = Tcl_FindCommand(interp, "y", NULL, - TCL_GLOBAL_ONLY); - - if (sourceCmdPtr != NULL) { - *rPtr = sourceCmdPtr; - return TCL_OK; - } + 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). + */ + + CallFrame *parentFramePtr = varFramePtr->callerPtr; + char *context = parentFramePtr != NULL ? parentFramePtr->nsPtr->name : "(NULL)"; + + 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; } Index: tests/resolver.test ================================================================== --- tests/resolver.test +++ tests/resolver.test @@ -194,10 +194,125 @@ # 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: