diff options
author | jan.nijtmans <nijtmans@users.sourceforge.net> | 2016-09-07 13:34:41 (GMT) |
---|---|---|
committer | jan.nijtmans <nijtmans@users.sourceforge.net> | 2016-09-07 13:34:41 (GMT) |
commit | 126933978f910cb47d9bf73c99e1c9eacb57ed04 (patch) | |
tree | 8eefd8a982aaa8cb93031d34bb939751e833acb4 | |
parent | 5a3911451c1076781c85ddc9c055b12f7a718f37 (diff) | |
parent | ea21bb5de3ca09b64d101656f0613cd10f877aa6 (diff) | |
download | tcl-126933978f910cb47d9bf73c99e1c9eacb57ed04.zip tcl-126933978f910cb47d9bf73c99e1c9eacb57ed04.tar.gz tcl-126933978f910cb47d9bf73c99e1c9eacb57ed04.tar.bz2 |
Fix [d4e7780ca1681cd095dbd81fe264feff75c988f7|d4e7780ca1]: "global" cmd literal sharing vs. per-interp resolvers
-rw-r--r-- | generic/tclAssembly.c | 6 | ||||
-rw-r--r-- | generic/tclCompCmdsGR.c | 2 | ||||
-rw-r--r-- | generic/tclCompCmdsSZ.c | 6 | ||||
-rw-r--r-- | generic/tclCompExpr.c | 18 | ||||
-rw-r--r-- | generic/tclCompile.c | 22 | ||||
-rw-r--r-- | generic/tclCompile.h | 30 | ||||
-rw-r--r-- | generic/tclEnsemble.c | 13 | ||||
-rw-r--r-- | generic/tclExecute.c | 2 | ||||
-rw-r--r-- | generic/tclInt.decls | 2 | ||||
-rw-r--r-- | generic/tclInt.h | 10 | ||||
-rw-r--r-- | generic/tclIntDecls.h | 4 | ||||
-rw-r--r-- | generic/tclLiteral.c | 35 | ||||
-rw-r--r-- | generic/tclNamesp.c | 3 | ||||
-rw-r--r-- | generic/tclObj.c | 7 | ||||
-rw-r--r-- | generic/tclTest.c | 83 | ||||
-rw-r--r-- | tests/exec.test | 3 | ||||
-rw-r--r-- | tests/io.test | 4 | ||||
-rw-r--r-- | tests/resolver.test | 115 |
18 files changed, 269 insertions, 96 deletions
diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 7a5ffcc..06f277f 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -1300,7 +1300,7 @@ AssembleOneLine( goto cleanup; } operand1 = TclGetStringFromObj(operand1Obj, &operand1Len); - litIndex = TclRegisterNewLiteral(envPtr, operand1, operand1Len); + litIndex = TclRegisterLiteral(envPtr, operand1, operand1Len, 0); BBEmitInst1or4(assemEnvPtr, tblIdx, litIndex, 0); break; @@ -1449,7 +1449,7 @@ AssembleOneLine( goto cleanup; } else { operand1 = TclGetStringFromObj(operand1Obj, &operand1Len); - litIndex = TclRegisterNewLiteral(envPtr, operand1, operand1Len); + litIndex = TclRegisterLiteral(envPtr, operand1, operand1Len, 0); /* * Assumes that PUSH is the first slot! @@ -3541,7 +3541,7 @@ StackCheckExit( * Emit a 'push' of the empty literal. */ - litIndex = TclRegisterNewLiteral(envPtr, "", 0); + litIndex = TclRegisterLiteral(envPtr, "", 0, 0); /* * Assumes that 'push' is at slot 0 in TalInstructionTable. diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 593a8af..ff5495c 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -2761,7 +2761,7 @@ TclCompileSyntaxError( const char *bytes = TclGetStringFromObj(msg, &numBytes); TclErrorStackResetIf(interp, bytes, numBytes); - TclEmitPush(TclRegisterNewLiteral(envPtr, bytes, numBytes), envPtr); + TclEmitPush(TclRegisterLiteral(envPtr, bytes, numBytes, 0), envPtr); CompileReturnInternal(envPtr, INST_SYNTAX, TCL_ERROR, 0, TclNoErrorStack(interp, Tcl_GetReturnOptions(interp, TCL_ERROR))); Tcl_ResetResult(interp); diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 2503089..10b3cc8 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -1456,8 +1456,8 @@ TclSubstCompile( switch (tokenPtr->type) { case TCL_TOKEN_TEXT: - literal = TclRegisterNewLiteral(envPtr, - tokenPtr->start, tokenPtr->size); + literal = TclRegisterLiteral(envPtr, + tokenPtr->start, tokenPtr->size, 0); TclEmitPush(literal, envPtr); TclAdvanceLines(&bline, tokenPtr->start, tokenPtr->start + tokenPtr->size); @@ -1466,7 +1466,7 @@ TclSubstCompile( case TCL_TOKEN_BS: length = TclParseBackslash(tokenPtr->start, tokenPtr->size, NULL, buf); - literal = TclRegisterNewLiteral(envPtr, buf, length); + literal = TclRegisterLiteral(envPtr, buf, length, 0); TclEmitPush(literal, envPtr); count++; continue; diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 654666a..83bb883 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -2267,9 +2267,9 @@ CompileExprTree( p = TclGetStringFromObj(*funcObjv, &length); funcObjv++; Tcl_DStringAppend(&cmdName, p, length); - TclEmitPush(TclRegisterNewCmdLiteral(envPtr, + TclEmitPush(TclRegisterLiteral(envPtr, Tcl_DStringValue(&cmdName), - Tcl_DStringLength(&cmdName)), envPtr); + Tcl_DStringLength(&cmdName), LITERAL_CMD_NAME), envPtr); Tcl_DStringFree(&cmdName); /* @@ -2376,8 +2376,8 @@ CompileExprTree( pc1 = CurrentOffset(envPtr); TclEmitInstInt1((nodePtr->lexeme == AND) ? INST_JUMP_FALSE1 : INST_JUMP_TRUE1, 0, envPtr); - TclEmitPush(TclRegisterNewLiteral(envPtr, - (nodePtr->lexeme == AND) ? "1" : "0", 1), envPtr); + TclEmitPush(TclRegisterLiteral(envPtr, + (nodePtr->lexeme == AND) ? "1" : "0", 1, 0), envPtr); pc2 = CurrentOffset(envPtr); TclEmitInstInt1(INST_JUMP1, 0, envPtr); TclAdjustStackDepth(-1, envPtr); @@ -2386,8 +2386,8 @@ CompileExprTree( if (TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump, 127)) { pc2 += 3; } - TclEmitPush(TclRegisterNewLiteral(envPtr, - (nodePtr->lexeme == AND) ? "0" : "1", 1), envPtr); + TclEmitPush(TclRegisterLiteral(envPtr, + (nodePtr->lexeme == AND) ? "0" : "1", 1, 0), envPtr); TclStoreInt1AtPtr(CurrentOffset(envPtr) - pc2, envPtr->codeStart + pc2 + 1); convert = 0; @@ -2421,7 +2421,7 @@ CompileExprTree( if (optimize) { int length; const char *bytes = TclGetStringFromObj(literal, &length); - int index = TclRegisterNewLiteral(envPtr, bytes, length); + int index = TclRegisterLiteral(envPtr, bytes, length, 0); Tcl_Obj *objPtr = TclFetchLiteral(envPtr, index); if ((objPtr->typePtr == NULL) && (literal->typePtr != NULL)) { @@ -2479,8 +2479,8 @@ CompileExprTree( if (objPtr->bytes) { Tcl_Obj *tableValue; - index = TclRegisterNewLiteral(envPtr, objPtr->bytes, - objPtr->length); + index = TclRegisterLiteral(envPtr, objPtr->bytes, + objPtr->length, 0); tableValue = TclFetchLiteral(envPtr, index); if ((tableValue->typePtr == NULL) && (objPtr->typePtr != NULL)) { diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 0024f1e..c588731 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1792,9 +1792,17 @@ CompileCmdLiteral( CompileEnv *envPtr) { int numBytes; - const char *bytes = TclGetStringFromObj(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, bytes, numBytes, extraLiteralFlags); if (cmdPtr) { TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLitIdx), cmdPtr); @@ -1829,8 +1837,8 @@ TclCompileInvocation( continue; } - objIdx = TclRegisterNewLiteral(envPtr, - tokenPtr[1].start, tokenPtr[1].size); + objIdx = TclRegisterLiteral(envPtr, + tokenPtr[1].start, tokenPtr[1].size, 0); if (envPtr->clNext) { TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx), tokenPtr[1].start - envPtr->source, envPtr->clNext); @@ -1879,8 +1887,8 @@ CompileExpanded( continue; } - objIdx = TclRegisterNewLiteral(envPtr, - tokenPtr[1].start, tokenPtr[1].size); + objIdx = TclRegisterLiteral(envPtr, + tokenPtr[1].start, tokenPtr[1].size, 0); if (envPtr->clNext) { TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx), tokenPtr[1].start - envPtr->source, envPtr->clNext); diff --git a/generic/tclCompile.h b/generic/tclCompile.h index f99c07c..89cdc59 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1095,7 +1095,7 @@ MODULE_SCOPE int TclCreateAuxData(ClientData clientData, MODULE_SCOPE int TclCreateExceptRange(ExceptionRangeType type, CompileEnv *envPtr); MODULE_SCOPE ExecEnv * TclCreateExecEnv(Tcl_Interp *interp, int size); -MODULE_SCOPE Tcl_Obj * TclCreateLiteral(Interp *iPtr, char *bytes, +MODULE_SCOPE Tcl_Obj * TclCreateLiteral(Interp *iPtr, const char *bytes, int length, unsigned int hash, int *newPtr, Namespace *nsPtr, int flags, LiteralEntry **globalPtrPtr); @@ -1210,29 +1210,7 @@ MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData, #define LITERAL_ON_HEAP 0x01 #define LITERAL_CMD_NAME 0x02 - -/* - * 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. - * - * int TclRegisterNewLiteral(CompileEnv *envPtr, const char *bytes, - * int length); - */ - -#define TclRegisterNewLiteral(envPtr, bytes, length) \ - TclRegisterLiteral(envPtr, (char *)(bytes), length, /*flags*/ 0) - -/* - * Form of TclRegisterLiteral with flags == LITERAL_CMD_NAME. In that case, it - * is safe to cast away constness, and it is cleanest to do that here, all in - * one place. - * - * int TclRegisterNewNSLiteral(CompileEnv *envPtr, const char *bytes, - * int length); - */ - -#define TclRegisterNewCmdLiteral(envPtr, bytes, length) \ - TclRegisterLiteral(envPtr, (char *)(bytes), length, LITERAL_CMD_NAME) +#define LITERAL_UNSHARED 0x04 /* * Macro used to manually adjust the stack requirements; used in cases where @@ -1549,9 +1527,9 @@ MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData, */ #define PushLiteral(envPtr, string, length) \ - TclEmitPush(TclRegisterNewLiteral((envPtr), (string), (length)), (envPtr)) + TclEmitPush(TclRegisterLiteral(envPtr, string, length, 0), (envPtr)) #define PushStringLiteral(envPtr, string) \ - PushLiteral((envPtr), (string), (int) (sizeof(string "") - 1)) + PushLiteral(envPtr, string, (int) (sizeof(string "") - 1)) /* * Macro to advance to the next token; it is more mnemonic than the address diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 2766769..43813f1 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -3306,7 +3306,7 @@ CompileToInvokedCommand( Tcl_Token *tokPtr; Tcl_Obj *objPtr, **words; char *bytes; - int length, i, numWords, cmdLit; + int length, i, numWords, cmdLit, extraLiteralFlags = LITERAL_CMD_NAME; DefineLineInformation; /* @@ -3326,8 +3326,8 @@ CompileToInvokedCommand( SetLineInformation(i); if (tokPtr->type == TCL_TOKEN_SIMPLE_WORD) { - int literal = TclRegisterNewLiteral(envPtr, - tokPtr[1].start, tokPtr[1].size); + int literal = TclRegisterLiteral(envPtr, + tokPtr[1].start, tokPtr[1].size, 0); if (envPtr->clNext) { TclContinuationsEnterDerived( @@ -3348,8 +3348,11 @@ CompileToInvokedCommand( objPtr = Tcl_NewObj(); Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr); - bytes = TclGetStringFromObj(objPtr, &length); - cmdLit = TclRegisterNewCmdLiteral(envPtr, bytes, length); + bytes = Tcl_GetStringFromObj(objPtr, &length); + if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) { + extraLiteralFlags |= LITERAL_UNSHARED; + } + cmdLit = TclRegisterLiteral(envPtr, bytes, length, extraLiteralFlags); TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLit), cmdPtr); TclEmitPush(cmdLit, envPtr); TclDecrRefCount(objPtr); diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 704e494..df36958 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -1554,7 +1554,7 @@ CompileExprObj( */ if (compEnv.codeNext == compEnv.codeStart) { - TclEmitPush(TclRegisterNewLiteral(&compEnv, "0", 1), + TclEmitPush(TclRegisterLiteral(&compEnv, "0", 1, 0), &compEnv); } diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 4e7e422..c00dff1 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -1009,7 +1009,7 @@ declare 250 { # Allow extensions for optimization declare 251 { int TclRegisterLiteral(void *envPtr, - char *bytes, int length, int flags) + const char *bytes, int length, int flags) } ############################################################################## diff --git a/generic/tclInt.h b/generic/tclInt.h index b39c8ea..da1b5c5 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1690,11 +1690,13 @@ typedef struct Command { * (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 + /* *---------------------------------------------------------------- diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index f95f999..dfa5727 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -615,7 +615,7 @@ EXTERN char * TclDoubleDigits(double dv, int ndigits, int flags, EXTERN void TclSetSlaveCancelFlags(Tcl_Interp *interp, int flags, int force); /* 251 */ -EXTERN int TclRegisterLiteral(void *envPtr, char *bytes, +EXTERN int TclRegisterLiteral(void *envPtr, const char *bytes, int length, int flags); typedef struct TclIntStubs { @@ -873,7 +873,7 @@ typedef struct TclIntStubs { int (*tclCopyChannel) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, Tcl_WideInt toRead, Tcl_Obj *cmdPtr); /* 248 */ char * (*tclDoubleDigits) (double dv, int ndigits, int flags, int *decpt, int *signum, char **endPtr); /* 249 */ void (*tclSetSlaveCancelFlags) (Tcl_Interp *interp, int flags, int force); /* 250 */ - int (*tclRegisterLiteral) (void *envPtr, char *bytes, int length, int flags); /* 251 */ + int (*tclRegisterLiteral) (void *envPtr, const char *bytes, int length, int flags); /* 251 */ } TclIntStubs; extern const TclIntStubs *tclIntStubsPtr; diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c index 9f01144..9922cec 100644 --- a/generic/tclLiteral.c +++ b/generic/tclLiteral.c @@ -174,7 +174,7 @@ TclDeleteLiteralTable( Tcl_Obj * TclCreateLiteral( Interp *iPtr, - char *bytes, /* The start of the string. Note that this is + const char *bytes, /* The start of the string. Note that this is * not a NUL-terminated string. */ int length, /* Number of bytes in the string. */ unsigned hash, /* The string's hash. If -1, it will be @@ -214,7 +214,7 @@ TclCreateLiteral( if (globalPtrPtr) { *globalPtrPtr = globalPtr; } - if (flags & LITERAL_ON_HEAP) { + if ((flags & LITERAL_ON_HEAP)) { ckfree(bytes); } globalPtr->refCount++; @@ -222,7 +222,7 @@ TclCreateLiteral( } } if (!newPtr) { - if (flags & LITERAL_ON_HEAP) { + if ((flags & LITERAL_ON_HEAP)) { ckfree(bytes); } return NULL; @@ -235,13 +235,23 @@ TclCreateLiteral( TclNewObj(objPtr); Tcl_IncrRefCount(objPtr); - if (flags & LITERAL_ON_HEAP) { - objPtr->bytes = bytes; + if ((flags & LITERAL_ON_HEAP)) { + objPtr->bytes = (char *) 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", @@ -360,7 +370,7 @@ int TclRegisterLiteral( void *ePtr, /* Points to the CompileEnv in whose object * array an object is found or created. */ - register char *bytes, /* Points to string for which to find or + register const char *bytes, /* Points to string for which to find or * create an object in CompileEnv's object * array. */ int length, /* Number of bytes in the string. If < 0, the @@ -398,7 +408,7 @@ TclRegisterLiteral( if ((objPtr->length == length) && ((length == 0) || ((objPtr->bytes[0] == bytes[0]) && (memcmp(objPtr->bytes, bytes, (unsigned) length) == 0)))) { - if (flags & LITERAL_ON_HEAP) { + if ((flags & LITERAL_ON_HEAP)) { ckfree(bytes); } objIndex = (localPtr - envPtr->literalArrayPtr); @@ -417,7 +427,7 @@ TclRegisterLiteral( * 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 { @@ -1026,7 +1036,7 @@ TclInvalidateCmdLiteral( * invalidate a cmd literal. */ { Interp *iPtr = (Interp *) interp; - Tcl_Obj *literalObjPtr = TclCreateLiteral(iPtr, (char *) name, + Tcl_Obj *literalObjPtr = TclCreateLiteral(iPtr, name, strlen(name), -1, NULL, nsPtr, 0, NULL); if (literalObjPtr != NULL) { @@ -1153,13 +1163,6 @@ TclVerifyLocalLiteralTable( "TclVerifyLocalLiteralTable", (length>60? 60 : length), bytes, localPtr->refCount); } - if (LookupLiteralEntry((Tcl_Interp *) envPtr->iPtr, - localPtr->objPtr) == NULL) { - bytes = TclGetStringFromObj(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"); diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 1fef919..7f6ecf5 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -2566,7 +2566,9 @@ Tcl_FindCommand( } if (result == TCL_OK) { + ((Command *)cmd)->flags |= CMD_VIA_RESOLVER; return cmd; + } else if (result != TCL_CONTINUE) { return NULL; } @@ -2658,6 +2660,7 @@ Tcl_FindCommand( } if (cmdPtr != NULL) { + cmdPtr->flags &= ~CMD_VIA_RESOLVER; return (Tcl_Command) cmdPtr; } diff --git a/generic/tclObj.c b/generic/tclObj.c index df17f13..d3f59ec 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -4264,8 +4264,13 @@ TclSetCmdNameObj( Command *cmdPtr) /* Points to Command structure that the * CmdName object should refer to. */ { + register ResolvedCmdName *resPtr; + if (objPtr->typePtr == &tclCmdNameType) { - return; + resPtr = objPtr->internalRep.twoPtrValue.ptr1; + if (resPtr != NULL && resPtr->cmdPtr == cmdPtr) { + return; + } } SetCmdNameObj(interp, objPtr, cmdPtr, NULL); diff --git a/generic/tclTest.c b/generic/tclTest.c index e0ed374..47d85e1 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -7326,24 +7326,83 @@ InterpCmdResolver( 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; - 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') - && (name[0] == 'z') && (name[1] == '\0')) { - Tcl_Command sourceCmdPtr = Tcl_FindCommand(interp, "y", NULL, - TCL_GLOBAL_ONLY); + 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 (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; } diff --git a/tests/exec.test b/tests/exec.test index 38927d3..2a4b31e 100644 --- a/tests/exec.test +++ b/tests/exec.test @@ -695,9 +695,6 @@ test exec-20.1 {exec .CMD file} -constraints {win} -body { exec [makeFile "echo %1> $log" exec201.CMD] "Testing exec-20.1" viewFile $log } -result "\"Testing exec-20.1\"" - - - # ---------------------------------------------------------------------- # cleanup diff --git a/tests/io.test b/tests/io.test index 2084991..6e7420d 100644 --- a/tests/io.test +++ b/tests/io.test @@ -8646,11 +8646,11 @@ test io-74.1 {[104f2885bb] improper cache validity check} -setup { interp create slave } -constraints testobj -body { teststringobj set 1 [string range $rfd 0 end] - read [teststringobj get 1] + read [teststringobj get 1] testobj duplicate 1 2 interp transfer {} $rfd slave catch {read [teststringobj get 1]} - read [teststringobj get 2] + read [teststringobj get 2] } -cleanup { interp delete slave testobj freeallvars diff --git a/tests/resolver.test b/tests/resolver.test index aaad02c..9bb4c08 100644 --- a/tests/resolver.test +++ b/tests/resolver.test @@ -196,6 +196,121 @@ test resolver-2.1 {compiled var resolver: Bug #3383616} -setup { } -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 |