diff options
-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 | 31 | ||||
-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 | 46 | ||||
-rw-r--r-- | generic/tclNamesp.c | 23 | ||||
-rw-r--r-- | generic/tclObj.c | 7 | ||||
-rw-r--r-- | generic/tclTest.c | 83 | ||||
-rw-r--r-- | generic/tclVar.c | 73 | ||||
-rw-r--r-- | generic/tclZlib.c | 48 | ||||
-rw-r--r-- | tests/exec.test | 3 | ||||
-rw-r--r-- | tests/io.test | 4 | ||||
-rw-r--r-- | tests/resolver.test | 115 | ||||
-rw-r--r-- | tests/trace.test | 23 | ||||
-rw-r--r-- | tests/var.test | 16 | ||||
-rw-r--r-- | tests/zlib.test | 23 |
23 files changed, 428 insertions, 152 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 fd24cfd..1ae333f 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1791,9 +1791,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); @@ -1828,8 +1836,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); @@ -1878,8 +1886,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 e271d9e..1b82b3d 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1095,7 +1095,8 @@ 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, int length); +MODULE_SCOPE Tcl_Obj * TclCreateLiteral(Interp *iPtr, const char *bytes, + int length); MODULE_SCOPE void TclDeleteExecEnv(ExecEnv *eePtr); MODULE_SCOPE void TclDeleteLiteralTable(Tcl_Interp *interp, LiteralTable *tablePtr); @@ -1207,29 +1208,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 @@ -1546,9 +1525,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 5dd413a..9db0735 100644 --- a/generic/tclLiteral.c +++ b/generic/tclLiteral.c @@ -28,9 +28,9 @@ * Function prototypes for static functions in this file: */ -static Tcl_Obj * CreateLiteral(Interp *iPtr, char *bytes, int length, - int *newPtr, Namespace *nsPtr, int flags, - LiteralEntry **globalPtrPtr); +static Tcl_Obj * CreateLiteral(Interp *iPtr, const char *bytes, + int length, int *newPtr, Namespace *nsPtr, + int flags, LiteralEntry **globalPtrPtr); static void ExpandLocalLiteralArray(CompileEnv *envPtr); static unsigned HashString(const char *string, int length); #ifdef TCL_COMPILE_DEBUG @@ -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. */ { @@ -185,7 +185,7 @@ TclCreateLiteral( static Tcl_Obj * CreateLiteral( 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. */ int *newPtr, @@ -220,7 +220,7 @@ CreateLiteral( if (newPtr) { *newPtr = 0; } - if (flags & LITERAL_ON_HEAP) { + if ((flags & LITERAL_ON_HEAP)) { ckfree(bytes); } if (globalPtrPtr) { @@ -239,7 +239,7 @@ CreateLiteral( } } if (newPtr == NULL) { - if (flags & LITERAL_ON_HEAP) { + if ((flags & LITERAL_ON_HEAP)) { ckfree(bytes); } return NULL; @@ -252,13 +252,23 @@ CreateLiteral( 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", @@ -377,7 +387,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 @@ -404,7 +414,7 @@ TclRegisterLiteral( * 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 { @@ -419,7 +429,7 @@ TclRegisterLiteral( if (new) { objIndex = TclAddLiteralObj(envPtr, objPtr, NULL); Tcl_SetHashValue(hePtr, INT2PTR(objIndex)); - if (!globalNew) { + if (!globalNew && globalPtr) { globalPtr->refCount++; } } else { @@ -891,9 +901,8 @@ TclInvalidateCmdLiteral( * invalidate a cmd literal. */ { Interp *iPtr = (Interp *) interp; - LiteralEntry *globalPtr; - Tcl_Obj *literalObjPtr = CreateLiteral(iPtr, (char *) name, -1, - NULL, nsPtr, 0, &globalPtr); + Tcl_Obj *literalObjPtr = CreateLiteral(iPtr, name, strlen(name), + NULL, nsPtr, 0, NULL); if (literalObjPtr != NULL) { if (literalObjPtr->typePtr == &tclCmdNameType) { @@ -1013,13 +1022,6 @@ TclVerifyLocalLiteralTable( Tcl_Panic("%s: literal has NULL string rep", "TclVerifyLocalLiteralTable"); } - if (LookupLiteralEntry((Tcl_Interp *) envPtr->iPtr, objPtr) == NULL) { - int length; - const char *bytes = TclGetStringFromObj(objPtr, &length); - Tcl_Panic("%s: local literal \"%.*s\" is not global", - "TclVerifyLocalLiteralTable", - (length>60? 60 : length), bytes); - } hePtr = Tcl_NextHashEntry(&search); } } diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 1fef919..74dfaf8 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -382,19 +382,6 @@ Tcl_PopCallFrame( register CallFrame *framePtr = iPtr->framePtr; Namespace *nsPtr; - /* - * It's important to remove the call frame from the interpreter's stack of - * call frames before deleting local variables, so that traces invoked by - * the variable deletion don't see the partially-deleted frame. - */ - - if (framePtr->callerPtr) { - iPtr->framePtr = framePtr->callerPtr; - iPtr->varFramePtr = framePtr->callerVarPtr; - } else { - /* Tcl_PopCallFrame: trying to pop rootCallFrame! */ - } - if (framePtr->varTablePtr != NULL) { TclDeleteVars(iPtr, framePtr->varTablePtr); ckfree(framePtr->varTablePtr); @@ -422,6 +409,13 @@ Tcl_PopCallFrame( } framePtr->nsPtr = NULL; + if (framePtr->callerPtr) { + iPtr->framePtr = framePtr->callerPtr; + iPtr->varFramePtr = framePtr->callerVarPtr; + } else { + /* Tcl_PopCallFrame: trying to pop rootCallFrame! */ + } + if (framePtr->tailcallPtr) { TclSetTailcall(interp, framePtr->tailcallPtr); } @@ -2566,7 +2560,9 @@ Tcl_FindCommand( } if (result == TCL_OK) { + ((Command *)cmd)->flags |= CMD_VIA_RESOLVER; return cmd; + } else if (result != TCL_CONTINUE) { return NULL; } @@ -2658,6 +2654,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/generic/tclVar.c b/generic/tclVar.c index 20bc208..0b371ee 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -4956,13 +4956,16 @@ TclDeleteNamespaceVars( VarHashRefCount(varPtr)++; /* Make sure we get to remove from * hash. */ Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, objPtr); - UnsetVarStruct(varPtr, NULL, iPtr, /* part1 */ objPtr, NULL, flags, - -1); - Tcl_DecrRefCount(objPtr); /* Free no longer needed obj */ + UnsetVarStruct(varPtr, NULL, iPtr, /* part1 */ objPtr, + NULL, flags, -1); /* - * Remove the variable from the table and force it undefined in case - * an unset trace brought it back from the dead. + * We just unset the variable. However, an unset trace might + * have re-set it, or might have re-established traces on it. + * This namespace and its vartable are going away unconditionally, + * so we cannot let such things linger. That would be a leak. + * + * First we destroy all traces. ... */ if (TclIsVarTraced(varPtr)) { @@ -4986,6 +4989,17 @@ TclDeleteNamespaceVars( } } } + + /* + * ...and then, if the variable still holds a value, we unset it + * again. This time with no traces left, we're sure it goes away. + */ + + if (!TclIsVarUndefined(varPtr)) { + UnsetVarStruct(varPtr, NULL, iPtr, /* part1 */ objPtr, + NULL, flags, -1); + } + Tcl_DecrRefCount(objPtr); /* free no longer needed obj */ VarHashRefCount(varPtr)--; VarHashDeleteEntry(varPtr); } @@ -5018,27 +5032,44 @@ TclDeleteVars( TclVarHashTable *tablePtr) /* Hash table containing variables to * delete. */ { - Tcl_Interp *interp = (Tcl_Interp *) iPtr; Tcl_HashSearch search; register Var *varPtr; - int flags; - Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp); - - /* - * Determine what flags to pass to the trace callback functions. - */ - - flags = TCL_TRACE_UNSETS; - if (tablePtr == &iPtr->globalNsPtr->varTable) { - flags |= TCL_GLOBAL_ONLY; - } else if (tablePtr == &currNsPtr->varTable) { - flags |= TCL_NAMESPACE_ONLY; - } for (varPtr = VarHashFirstVar(tablePtr, &search); varPtr != NULL; varPtr = VarHashFirstVar(tablePtr, &search)) { - UnsetVarStruct(varPtr, NULL, iPtr, VarHashGetKey(varPtr), NULL, flags, - -1); + VarHashRefCount(varPtr)++; + + UnsetVarStruct(varPtr, NULL, iPtr, VarHashGetKey(varPtr), + NULL, TCL_TRACE_UNSETS, -1); + + if (TclIsVarTraced(varPtr)) { + Tcl_HashEntry *tPtr = Tcl_FindHashEntry(&iPtr->varTraces, varPtr); + VarTrace *tracePtr = Tcl_GetHashValue(tPtr); + ActiveVarTrace *activePtr; + + while (tracePtr) { + VarTrace *prevPtr = tracePtr; + + tracePtr = tracePtr->nextPtr; + prevPtr->nextPtr = NULL; + Tcl_EventuallyFree(prevPtr, TCL_DYNAMIC); + } + Tcl_DeleteHashEntry(tPtr); + varPtr->flags &= ~VAR_ALL_TRACES; + for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL; + activePtr = activePtr->nextPtr) { + if (activePtr->varPtr == varPtr) { + activePtr->nextTracePtr = NULL; + } + } + } + + if (!TclIsVarUndefined(varPtr)) { + UnsetVarStruct(varPtr, NULL, iPtr, VarHashGetKey(varPtr), + NULL, TCL_TRACE_UNSETS, -1); + } + + VarHashRefCount(varPtr)--; VarHashDeleteEntry(varPtr); } VarHashDeleteTable(tablePtr); diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 10fa4f7..a7e8a8a 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -2864,7 +2864,7 @@ ZlibTransformClose( Tcl_Interp *interp) { ZlibChannelData *cd = instanceData; - int e, result = TCL_OK; + int e, written, result = TCL_OK; /* * Delete the support timer. @@ -2882,6 +2882,17 @@ ZlibTransformClose( cd->outStream.next_out = (Bytef *) cd->outBuffer; cd->outStream.avail_out = (unsigned) cd->outAllocated; e = deflate(&cd->outStream, Z_FINISH); + written = cd->outAllocated - cd->outStream.avail_out; + + /* + * Can't be sure that deflate() won't declare the buffer to be + * full (with Z_BUF_ERROR) so handle that case. + */ + + if (e == Z_BUF_ERROR) { + e = Z_OK; + written = cd->outAllocated; + } if (e != Z_OK && e != Z_STREAM_END) { /* TODO: is this the right way to do errors on close? */ if (!TclInThreadExit()) { @@ -2890,20 +2901,17 @@ ZlibTransformClose( result = TCL_ERROR; break; } - if (cd->outStream.avail_out != (unsigned) cd->outAllocated) { - if (Tcl_WriteRaw(cd->parent, cd->outBuffer, - cd->outAllocated - cd->outStream.avail_out) < 0) { - /* TODO: is this the right way to do errors on close? - * Note: when close is called from FinalizeIOSubsystem - * then interp may be NULL */ - if (!TclInThreadExit() && interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "error while finalizing file: %s", - Tcl_PosixError(interp))); - } - result = TCL_ERROR; - break; + if (written && Tcl_WriteRaw(cd->parent, cd->outBuffer, written) < 0) { + /* TODO: is this the right way to do errors on close? + * Note: when close is called from FinalizeIOSubsystem then + * interp may be NULL */ + if (!TclInThreadExit() && interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error while finalizing file: %s", + Tcl_PosixError(interp))); } + result = TCL_ERROR; + break; } } while (e != Z_STREAM_END); (void) deflateEnd(&cd->outStream); @@ -3084,7 +3092,17 @@ ZlibTransformOutput( e = deflate(&cd->outStream, Z_NO_FLUSH); produced = cd->outAllocated - cd->outStream.avail_out; - if (e == Z_OK && produced > 0) { + if ((e == Z_OK && produced > 0) || e == Z_BUF_ERROR) { + /* + * deflate() indicates that it is out of space by returning + * Z_BUF_ERROR; in that case, we must write the whole buffer out + * and retry to compress what is left. + */ + + if (e == Z_BUF_ERROR) { + produced = cd->outAllocated; + e = Z_OK; + } if (Tcl_WriteRaw(cd->parent, cd->outBuffer, produced) < 0) { *errorCodePtr = Tcl_GetErrno(); return -1; 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 diff --git a/tests/trace.test b/tests/trace.test index 1099f48..3b69d38 100644 --- a/tests/trace.test +++ b/tests/trace.test @@ -1227,7 +1227,7 @@ test trace-17.3 {traced variables must survive procedure exits} { test trace-18.1 {unset traces on procedure returns} { proc p1 {x y} {set a 44; p2 14} - proc p2 {z} {trace add variable z unset {traceCheck {lsort [uplevel 1 {info vars}]}}} + proc p2 {z} {trace add variable z unset {traceCheck {lsort [uplevel 2 {info vars}]}}} set info {} p1 foo bar set info @@ -1263,6 +1263,27 @@ test trace-18.4 {namespace delete / trace vdelete combo, Bug \#1338280} { rename doTrace {} set info } 1110 +test trace-18.5 {Bug 7f02ff1efa} -setup { + proc constant {name value} { + upvar 1 $name c + set c $value + trace variable c wu [list reset $value] + } + proc reset {v a i o} { + uplevel 1 [list constant $a $v] + } + proc demo {} { + constant pi 3.14 + } +} -body { + unset -nocomplain pi + demo + info exists pi +} -cleanup { + rename demo {} + rename reset {} + rename constant {} +} -result 0 # Delete arrays when done, so they can be re-used as scalars # elsewhere. diff --git a/tests/var.test b/tests/var.test index 44e671a..9816d98 100644 --- a/tests/var.test +++ b/tests/var.test @@ -594,6 +594,22 @@ test var-8.2 {TclDeleteNamespaceVars, "unset" traces on ns delete are called wit list [namespace delete test_ns_var] $::info } -result {{} {::test_ns_var::v {} u}} +test var-8.3 {TclDeleteNamespaceVars, mem leak} -constraints memory -setup { + proc ::t {a i o} { + set $a 321 + } +} -body { + leaktest { + namespace eval n { + variable v 123 + trace variable v u ::t + } + namespace delete n + } +} -cleanup { + rename ::t {} +} -result 0 + test var-9.1 {behaviour of TclGet/SetVar simple get/set} -setup { catch {unset u} catch {unset v} diff --git a/tests/zlib.test b/tests/zlib.test index 8a040d8..15dbb34 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -917,6 +917,29 @@ test zlib-12.1 {Tk Bug 9eb55debc5} -constraints zlib -setup { } -cleanup { $stream close } -result {12026 18000} +test zlib-12.2 {Patrick Dunnigan's issue} -constraints zlib -setup { + set filesrc [makeFile {} test.input] + set filedst [makeFile {} test.output] + set f [open $filesrc "wb"] + for {set i 0} {$i < 10000} {incr i} { + puts -nonewline $f "x" + } + close $f +} -body { + set fin [open $filesrc "rb"] + set fout [open $filedst "wb"] + set header [dict create filename "test.input" time 0] + try { + fcopy $fin [zlib push gzip $fout -header $header] + } finally { + close $fin + close $fout + } + file size $filedst +} -cleanup { + removeFile $filesrc + removeFile $filedst +} -result 4152 ::tcltest::cleanupTests return |