summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tclAssembly.c6
-rw-r--r--generic/tclCompCmdsGR.c2
-rw-r--r--generic/tclCompCmdsSZ.c6
-rw-r--r--generic/tclCompExpr.c18
-rw-r--r--generic/tclCompile.c22
-rw-r--r--generic/tclCompile.h31
-rw-r--r--generic/tclEnsemble.c13
-rw-r--r--generic/tclExecute.c2
-rw-r--r--generic/tclInt.decls2
-rw-r--r--generic/tclInt.h10
-rw-r--r--generic/tclIntDecls.h4
-rw-r--r--generic/tclLiteral.c46
-rw-r--r--generic/tclNamesp.c23
-rw-r--r--generic/tclObj.c7
-rw-r--r--generic/tclTest.c83
-rw-r--r--generic/tclVar.c73
-rw-r--r--generic/tclZlib.c48
17 files changed, 250 insertions, 146 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;
generated by cgit v0.12 at 2024-11-17 15:17:33 (GMT)