summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2014-07-22 20:27:59 (GMT)
committerdgp <dgp@users.sourceforge.net>2014-07-22 20:27:59 (GMT)
commit421cb095720c641b6cef201242354a338207d3c3 (patch)
tree376b30b6fcfff8ed2d90f77837b5018081403808 /generic
parent18b04fd803de5db258180ee7d4d4d128a77fb03d (diff)
parent91e311e52d7fd08f0eb70ddd211e5aa51a5e2d22 (diff)
downloadtcl-421cb095720c641b6cef201242354a338207d3c3.zip
tcl-421cb095720c641b6cef201242354a338207d3c3.tar.gz
tcl-421cb095720c641b6cef201242354a338207d3c3.tar.bz2
merge trunk
Diffstat (limited to 'generic')
-rw-r--r--generic/regc_nfa.c2
-rw-r--r--generic/tclAssembly.c4
-rw-r--r--generic/tclCmdIL.c12
-rw-r--r--generic/tclCompCmdsGR.c60
-rw-r--r--generic/tclCompile.c13
-rw-r--r--generic/tclCompile.h7
-rw-r--r--generic/tclDictObj.c4
-rw-r--r--generic/tclExecute.c185
-rw-r--r--generic/tclIO.c2
-rw-r--r--generic/tclIORChan.c63
-rw-r--r--generic/tclOO.c7
-rw-r--r--generic/tclPathObj.c18
-rw-r--r--generic/tclTest.c55
-rw-r--r--generic/tclVar.c3
-rw-r--r--generic/tclZlib.c9
15 files changed, 346 insertions, 98 deletions
diff --git a/generic/regc_nfa.c b/generic/regc_nfa.c
index 42489dd..1f0583e 100644
--- a/generic/regc_nfa.c
+++ b/generic/regc_nfa.c
@@ -1345,7 +1345,7 @@ fixempties(
for (s = nfa->states; s != NULL && !NISERR(); s = nexts) {
nexts = s->next;
/* Ensure tmp fields are clear for next step */
- assert(s->tmp = NULL);
+ assert(s->tmp == NULL);
if (s->flag || s->nins != 1) {
continue;
}
diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index d1866c8..6d5676b 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -410,6 +410,10 @@ static const TalInstDesc TalInstructionTable[] = {
{"lappendArray", ASSEM_LVT, (INST_LAPPEND_ARRAY1<<8
| INST_LAPPEND_ARRAY4),2, 1},
{"lappendArrayStk", ASSEM_1BYTE, INST_LAPPEND_ARRAY_STK, 3, 1},
+ {"lappendList", ASSEM_LVT4, INST_LAPPEND_LIST, 1, 1},
+ {"lappendListArray",ASSEM_LVT4, INST_LAPPEND_LIST_ARRAY,2, 1},
+ {"lappendListArrayStk", ASSEM_1BYTE,INST_LAPPEND_LIST_ARRAY_STK, 3, 1},
+ {"lappendListStk", ASSEM_1BYTE, INST_LAPPEND_LIST_STK, 2, 1},
{"lappendStk", ASSEM_1BYTE, INST_LAPPEND_STK, 2, 1},
{"le", ASSEM_1BYTE, INST_LE, 2, 1},
{"lindexMulti", ASSEM_LINDEX_MULTI,
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index db216e5..d723e4b 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -1287,6 +1287,7 @@ TclInfoFrame(
"eval", "eval", "eval", "precompiled", "source", "proc"
};
Proc *procPtr = framePtr->framePtr ? framePtr->framePtr->procPtr : NULL;
+ int needsFree = -1;
/*
* Pull the information and construct the dictionary to return, as list.
@@ -1360,6 +1361,9 @@ TclInfoFrame(
}
ADD_PAIR("cmd", TclGetSourceFromFrame(fPtr, 0, NULL));
+ if (fPtr->cmdObj && framePtr->cmdObj == NULL) {
+ needsFree = lc - 1;
+ }
TclStackFree(interp, fPtr);
break;
}
@@ -1447,7 +1451,11 @@ TclInfoFrame(
}
}
- return Tcl_NewListObj(lc, lv);
+ tmpObj = Tcl_NewListObj(lc, lv);
+ if (needsFree >= 0) {
+ Tcl_DecrRefCount(lv[needsFree]);
+ }
+ return tmpObj;
}
/*
@@ -2655,7 +2663,7 @@ Tcl_LrepeatObjCmd(
* number of times.
*/
- CLANG_ASSERT(dataArray);
+ CLANG_ASSERT(dataArray || totalElems == 0 );
if (objc == 1) {
register Tcl_Obj *tmpPtr = objv[0];
diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c
index b3e273f..166fea0 100644
--- a/generic/tclCompCmdsGR.c
+++ b/generic/tclCompCmdsGR.c
@@ -868,28 +868,16 @@ TclCompileLappendCmd(
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *varTokenPtr, *valueTokenPtr;
- int isScalar, localIndex, numWords, i, fwd, offsetFwd;
+ int isScalar, localIndex, numWords, i;
DefineLineInformation; /* TIP #280 */
- /*
- * If we're not in a procedure, don't compile.
- */
-
- if (envPtr->procPtr == NULL) {
- return TCL_ERROR;
- }
-
/* TODO: Consider support for compiling expanded args. */
numWords = parsePtr->numWords;
if (numWords == 1) {
return TCL_ERROR;
}
- if (numWords != 3) {
- /*
- * LAPPEND instructions currently only handle one value, but we can
- * handle some multi-value cases by stringing them together.
- */
+ if (numWords != 3 || envPtr->procPtr == NULL) {
goto lappendMultiple;
}
@@ -943,42 +931,28 @@ TclCompileLappendCmd(
return TCL_OK;
lappendMultiple:
- /*
- * Can only handle the case where we are appending to a local scalar when
- * there are multiple values to append. Fortunately, this is common.
- */
-
- if (envPtr->procPtr == NULL) {
- return TCL_ERROR;
- }
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
- PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_ELEMENT,
+ PushVarNameWord(interp, varTokenPtr, envPtr, 0,
&localIndex, &isScalar, 1);
- if (!isScalar || localIndex < 0) {
- return TCL_ERROR;
- }
-
- /*
- * Definitely appending to a local scalar; generate the words and append
- * them.
- */
-
valueTokenPtr = TokenAfter(varTokenPtr);
for (i = 2 ; i < numWords ; i++) {
CompileWord(envPtr, valueTokenPtr, interp, i);
valueTokenPtr = TokenAfter(valueTokenPtr);
}
- TclEmitInstInt4( INST_LIST, numWords-2, envPtr);
- TclEmitInstInt4( INST_EXIST_SCALAR, localIndex, envPtr);
- offsetFwd = CurrentOffset(envPtr);
- TclEmitInstInt1( INST_JUMP_FALSE1, 0, envPtr);
- Emit14Inst( INST_LOAD_SCALAR, localIndex, envPtr);
- TclEmitInstInt4( INST_REVERSE, 2, envPtr);
- TclEmitOpcode( INST_LIST_CONCAT, envPtr);
- fwd = CurrentOffset(envPtr) - offsetFwd;
- TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1);
- Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr);
-
+ TclEmitInstInt4( INST_LIST, numWords-2, envPtr);
+ if (isScalar) {
+ if (localIndex < 0) {
+ TclEmitOpcode( INST_LAPPEND_LIST_STK, envPtr);
+ } else {
+ TclEmitInstInt4(INST_LAPPEND_LIST, localIndex, envPtr);
+ }
+ } else {
+ if (localIndex < 0) {
+ TclEmitOpcode( INST_LAPPEND_LIST_ARRAY_STK, envPtr);
+ } else {
+ TclEmitInstInt4(INST_LAPPEND_LIST_ARRAY, localIndex,envPtr);
+ }
+ }
return TCL_OK;
}
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 347e3f0..838b195 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -650,6 +650,19 @@ InstructionDesc const tclInstructionTable[] = {
* satisfy the class check (standard definition of "all").
* Stack: ... stringValue => ... boolean */
+ {"lappendList", 5, 0, 1, {OPERAND_LVT4}},
+ /* Lappend list to scalar variable at op4 in frame.
+ * Stack: ... list => ... listVarContents */
+ {"lappendListArray", 5, -1, 1, {OPERAND_LVT4}},
+ /* Lappend list to array element; array at op4.
+ * Stack: ... elem list => ... listVarContents */
+ {"lappendListArrayStk", 1, -2, 0, {OPERAND_NONE}},
+ /* Lappend list to array element.
+ * Stack: ... arrayName elem list => ... listVarContents */
+ {"lappendListStk", 1, -1, 0, {OPERAND_NONE}},
+ /* Lappend list to general variable.
+ * Stack: ... varName list => ... listVarContents */
+
{NULL, 0, 0, 0, {OPERAND_NONE}}
};
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 5665ca9..fa4a360 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -799,8 +799,13 @@ typedef struct ByteCode {
#define INST_TRY_CVT_TO_BOOLEAN 183
#define INST_STR_CLASS 184
+#define INST_LAPPEND_LIST 185
+#define INST_LAPPEND_LIST_ARRAY 186
+#define INST_LAPPEND_LIST_ARRAY_STK 187
+#define INST_LAPPEND_LIST_STK 188
+
/* The last opcode */
-#define LAST_INST_OPCODE 184
+#define LAST_INST_OPCODE 188
/*
* Table describing the Tcl bytecode instructions: their name (for displaying
diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c
index 3c0ddd8..15fbe1e 100644
--- a/generic/tclDictObj.c
+++ b/generic/tclDictObj.c
@@ -405,6 +405,7 @@ DupDictInternalRep(
*/
DICT(copyPtr) = newDict;
+ copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
copyPtr->typePtr = &tclDictType;
}
@@ -720,6 +721,7 @@ SetDictFromAny(
dict->chain = NULL;
dict->refcount = 1;
DICT(objPtr) = dict;
+ objPtr->internalRep.twoPtrValue.ptr2 = NULL;
objPtr->typePtr = &tclDictType;
return TCL_OK;
@@ -1390,6 +1392,7 @@ Tcl_NewDictObj(void)
dict->chain = NULL;
dict->refcount = 1;
DICT(dictPtr) = dict;
+ dictPtr->internalRep.twoPtrValue.ptr2 = NULL;
dictPtr->typePtr = &tclDictType;
return dictPtr;
#endif
@@ -1439,6 +1442,7 @@ Tcl_DbNewDictObj(
dict->chain = NULL;
dict->refcount = 1;
DICT(dictPtr) = dict;
+ dictPtr->internalRep.twoPtrValue.ptr2 = NULL;
dictPtr->typePtr = &tclDictType;
return dictPtr;
#else /* !TCL_MEM_DEBUG */
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index d8c5935..2098e50 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -2204,10 +2204,6 @@ TEBCresume(
} else {
/* resume from invocation */
CACHE_STACK_INFO();
- if (iPtr->execEnvPtr->rewind) {
- result = TCL_ERROR;
- goto abnormalReturn;
- }
NRE_ASSERT(iPtr->cmdFramePtr == bcFramePtr);
if (bcFramePtr->cmdObj) {
@@ -2219,6 +2215,10 @@ TEBCresume(
if (iPtr->flags & INTERP_DEBUG_FRAME) {
TclArgumentBCRelease(interp, bcFramePtr);
}
+ if (iPtr->execEnvPtr->rewind) {
+ result = TCL_ERROR;
+ goto abnormalReturn;
+ }
if (codePtr->flags & TCL_BYTECODE_RECOMPILE) {
iPtr->flags |= ERR_ALREADY_LOGGED;
codePtr->flags &= ~TCL_BYTECODE_RECOMPILE;
@@ -3347,7 +3347,7 @@ TEBCresume(
*/
{
- int storeFlags;
+ int storeFlags, len;
case INST_STORE_ARRAY4:
opnd = TclGetUInt4AtPtr(pc+1);
@@ -3587,6 +3587,171 @@ TEBCresume(
#endif
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_V(pcAdjustment, cleanup, 1);
+
+ case INST_LAPPEND_LIST:
+ opnd = TclGetUInt4AtPtr(pc+1);
+ valuePtr = OBJ_AT_TOS;
+ varPtr = LOCAL(opnd);
+ cleanup = 1;
+ pcAdjustment = 5;
+ while (TclIsVarLink(varPtr)) {
+ varPtr = varPtr->value.linkPtr;
+ }
+ TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr)));
+ if (TclListObjGetElements(interp, valuePtr, &objc, &objv)
+ != TCL_OK) {
+ TRACE_ERROR(interp);
+ goto gotError;
+ }
+ if (TclIsVarDirectReadable(varPtr)
+ && TclIsVarDirectWritable(varPtr)) {
+ goto lappendListDirect;
+ }
+ arrayPtr = NULL;
+ part1Ptr = part2Ptr = NULL;
+ goto lappendListPtr;
+
+ case INST_LAPPEND_LIST_ARRAY:
+ opnd = TclGetUInt4AtPtr(pc+1);
+ valuePtr = OBJ_AT_TOS;
+ part1Ptr = NULL;
+ part2Ptr = OBJ_UNDER_TOS;
+ arrayPtr = LOCAL(opnd);
+ cleanup = 2;
+ pcAdjustment = 5;
+ while (TclIsVarLink(arrayPtr)) {
+ arrayPtr = arrayPtr->value.linkPtr;
+ }
+ TRACE(("%u \"%.30s\" \"%.30s\" => ",
+ opnd, O2S(part2Ptr), O2S(valuePtr)));
+ if (TclListObjGetElements(interp, valuePtr, &objc, &objv)
+ != TCL_OK) {
+ TRACE_ERROR(interp);
+ goto gotError;
+ }
+ if (TclIsVarArray(arrayPtr) && !ReadTraced(arrayPtr)
+ && !WriteTraced(arrayPtr)) {
+ varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr);
+ if (varPtr && TclIsVarDirectReadable(varPtr)
+ && TclIsVarDirectWritable(varPtr)) {
+ goto lappendListDirect;
+ }
+ }
+ varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr,
+ TCL_LEAVE_ERR_MSG, "set", 1, 1, arrayPtr, opnd);
+ if (varPtr == NULL) {
+ TRACE_ERROR(interp);
+ goto gotError;
+ }
+ goto lappendListPtr;
+
+ case INST_LAPPEND_LIST_ARRAY_STK:
+ pcAdjustment = 1;
+ cleanup = 3;
+ valuePtr = OBJ_AT_TOS;
+ part2Ptr = OBJ_UNDER_TOS; /* element name */
+ part1Ptr = OBJ_AT_DEPTH(2); /* array name */
+ TRACE(("\"%.30s(%.30s)\" \"%.30s\" => ",
+ O2S(part1Ptr), O2S(part2Ptr), O2S(valuePtr)));
+ goto lappendList;
+
+ case INST_LAPPEND_LIST_STK:
+ pcAdjustment = 1;
+ cleanup = 2;
+ valuePtr = OBJ_AT_TOS;
+ part2Ptr = NULL;
+ part1Ptr = OBJ_UNDER_TOS; /* variable name */
+ TRACE(("\"%.30s\" \"%.30s\" => ", O2S(part1Ptr), O2S(valuePtr)));
+ goto lappendList;
+
+ lappendListDirect:
+ objResultPtr = varPtr->value.objPtr;
+ if (TclListObjLength(interp, objResultPtr, &len) != TCL_OK) {
+ TRACE_ERROR(interp);
+ goto gotError;
+ }
+ if (Tcl_IsShared(objResultPtr)) {
+ Tcl_Obj *newValue = Tcl_DuplicateObj(objResultPtr);
+
+ TclDecrRefCount(objResultPtr);
+ varPtr->value.objPtr = objResultPtr = newValue;
+ Tcl_IncrRefCount(newValue);
+ }
+ if (Tcl_ListObjReplace(interp, objResultPtr, len, 0, objc, objv)
+ != TCL_OK) {
+ TRACE_ERROR(interp);
+ goto gotError;
+ }
+ TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+ NEXT_INST_V(pcAdjustment, cleanup, 1);
+
+ lappendList:
+ opnd = -1;
+ if (TclListObjGetElements(interp, valuePtr, &objc, &objv)
+ != TCL_OK) {
+ TRACE_ERROR(interp);
+ goto gotError;
+ }
+ DECACHE_STACK_INFO();
+ varPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr,
+ TCL_LEAVE_ERR_MSG, "set", 1, 1, &arrayPtr);
+ CACHE_STACK_INFO();
+ if (!varPtr) {
+ TRACE_ERROR(interp);
+ goto gotError;
+ }
+
+ lappendListPtr:
+ if (TclIsVarInHash(varPtr)) {
+ VarHashRefCount(varPtr)++;
+ }
+ if (arrayPtr && TclIsVarInHash(arrayPtr)) {
+ VarHashRefCount(arrayPtr)++;
+ }
+ DECACHE_STACK_INFO();
+ objResultPtr = TclPtrGetVar(interp, varPtr, arrayPtr,
+ part1Ptr, part2Ptr, TCL_LEAVE_ERR_MSG, opnd);
+ CACHE_STACK_INFO();
+ if (TclIsVarInHash(varPtr)) {
+ VarHashRefCount(varPtr)--;
+ }
+ if (arrayPtr && TclIsVarInHash(arrayPtr)) {
+ VarHashRefCount(arrayPtr)--;
+ }
+
+ {
+ int createdNewObj = 0;
+
+ if (!objResultPtr) {
+ objResultPtr = valuePtr;
+ } else if (TclListObjLength(interp, objResultPtr, &len)!=TCL_OK) {
+ TRACE_ERROR(interp);
+ goto gotError;
+ } else {
+ if (Tcl_IsShared(objResultPtr)) {
+ objResultPtr = Tcl_DuplicateObj(objResultPtr);
+ createdNewObj = 1;
+ }
+ if (Tcl_ListObjReplace(interp, objResultPtr, len,0, objc,objv)
+ != TCL_OK) {
+ goto errorInLappendListPtr;
+ }
+ }
+ DECACHE_STACK_INFO();
+ objResultPtr = TclPtrSetVar(interp, varPtr, arrayPtr, part1Ptr,
+ part2Ptr, objResultPtr, TCL_LEAVE_ERR_MSG, opnd);
+ CACHE_STACK_INFO();
+ if (!objResultPtr) {
+ errorInLappendListPtr:
+ if (createdNewObj) {
+ TclDecrRefCount(objResultPtr);
+ }
+ TRACE_ERROR(interp);
+ goto gotError;
+ }
+ }
+ TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+ NEXT_INST_V(pcAdjustment, cleanup, 1);
}
/*
@@ -5601,6 +5766,7 @@ TEBCresume(
((int *) objResultPtr->internalRep.otherValuePtr)[1] = 0;
}
Tcl_InvalidateStringRep(objResultPtr);
+ TclDecrRefCount(value3Ptr);
TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
NEXT_INST_F(1, 1, 1);
} else {
@@ -5627,6 +5793,7 @@ TEBCresume(
((int *) objResultPtr->internalRep.otherValuePtr)[1] = 0;
}
Tcl_InvalidateStringRep(valuePtr);
+ TclDecrRefCount(value3Ptr);
TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr)));
NEXT_INST_F(1, 0, 0);
}
@@ -7474,6 +7641,14 @@ TEBCresume(
searchPtr = ckalloc(sizeof(Tcl_DictSearch));
if (Tcl_DictObjFirst(interp, dictPtr, searchPtr, &keyPtr,
&valuePtr, &done) != TCL_OK) {
+
+ /*
+ * dictPtr is no longer on the stack, and we're not
+ * moving it into the intrep of an iterator. We need
+ * to drop the refcount [Tcl Bug 9b352768e6].
+ */
+
+ Tcl_DecrRefCount(dictPtr);
ckfree(searchPtr);
TRACE_ERROR(interp);
goto gotError;
diff --git a/generic/tclIO.c b/generic/tclIO.c
index 1938173..256b411 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -5446,7 +5446,7 @@ Tcl_ReadRaw(
if (bytesToRead > 0) {
- int nread = ChanRead(chanPtr, readBuf+copied, bytesToRead);
+ int nread = ChanRead(chanPtr, readBuf, bytesToRead);
if (nread > 0) {
/* Successful read (short is OK) - add to bytes copied */
diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c
index ff602c6..3506a44 100644
--- a/generic/tclIORChan.c
+++ b/generic/tclIORChan.c
@@ -436,6 +436,7 @@ static ReflectedChannelMap * GetReflectedChannelMap(Tcl_Interp *interp);
static void DeleteReflectedChannelMap(ClientData clientData,
Tcl_Interp *interp);
static int ErrnoReturn(ReflectedChannel *rcPtr, Tcl_Obj *resObj);
+static void MarkDead(ReflectedChannel *rcPtr);
/*
* Global constant strings (messages). ==================
@@ -1146,7 +1147,6 @@ ReflectClose(
if (result != TCL_OK) {
FreeReceivedError(&p);
}
- return EOK;
}
#endif
@@ -1217,17 +1217,14 @@ ReflectClose(
if (hPtr) {
Tcl_DeleteHashEntry(hPtr);
}
+ }
#endif
-
- tctPtr = ((Channel *)rcPtr->chan)->typePtr;
- if (tctPtr && tctPtr != &tclRChannelType) {
+ tctPtr = ((Channel *)rcPtr->chan)->typePtr;
+ if (tctPtr && tctPtr != &tclRChannelType) {
ckfree((char *)tctPtr);
((Channel *)rcPtr->chan)->typePtr = NULL;
- }
- Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel);
-#ifdef TCL_THREADS
}
-#endif
+ Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel);
return (result == TCL_OK) ? EOK : EINVAL;
}
@@ -2192,9 +2189,15 @@ FreeReflectedChannel(
Channel *chanPtr = (Channel *) rcPtr->chan;
Tcl_Release(chanPtr);
- Tcl_DecrRefCount(rcPtr->name);
- Tcl_DecrRefCount(rcPtr->methods);
- Tcl_DecrRefCount(rcPtr->cmd);
+ if (rcPtr->name) {
+ Tcl_DecrRefCount(rcPtr->name);
+ }
+ if (rcPtr->methods) {
+ Tcl_DecrRefCount(rcPtr->methods);
+ }
+ if (rcPtr->cmd) {
+ Tcl_DecrRefCount(rcPtr->cmd);
+ }
ckfree(rcPtr);
}
@@ -2460,6 +2463,28 @@ GetReflectedChannelMap(
*/
static void
+MarkDead(
+ ReflectedChannel *rcPtr)
+{
+ if (rcPtr->dead) {
+ return;
+ }
+ if (rcPtr->name) {
+ Tcl_DecrRefCount(rcPtr->name);
+ rcPtr->name = NULL;
+ }
+ if (rcPtr->methods) {
+ Tcl_DecrRefCount(rcPtr->methods);
+ rcPtr->methods = NULL;
+ }
+ if (rcPtr->cmd) {
+ Tcl_DecrRefCount(rcPtr->cmd);
+ rcPtr->cmd = NULL;
+ }
+ rcPtr->dead = 1;
+}
+
+static void
DeleteReflectedChannelMap(
ClientData clientData, /* The per-interpreter data structure. */
Tcl_Interp *interp) /* The interpreter being deleted. */
@@ -2494,7 +2519,7 @@ DeleteReflectedChannelMap(
chan = Tcl_GetHashValue(hPtr);
rcPtr = Tcl_GetChannelInstanceData(chan);
- rcPtr->dead = 1;
+ MarkDead(rcPtr);
Tcl_DeleteHashEntry(hPtr);
}
Tcl_DeleteHashTable(&rcmPtr->map);
@@ -2577,7 +2602,7 @@ DeleteReflectedChannelMap(
continue;
}
- rcPtr->dead = 1;
+ MarkDead(rcPtr);
Tcl_DeleteHashEntry(hPtr);
}
#endif
@@ -2724,7 +2749,7 @@ DeleteThreadReflectedChannelMap(
Tcl_Channel chan = Tcl_GetHashValue(hPtr);
ReflectedChannel *rcPtr = Tcl_GetChannelInstanceData(chan);
- rcPtr->dead = 1;
+ MarkDead(rcPtr);
Tcl_DeleteHashEntry(hPtr);
}
ckfree(rcmPtr);
@@ -2907,8 +2932,6 @@ ForwardProc(
* No parameters/results.
*/
- const Tcl_ChannelType *tctPtr;
-
if (InvokeTclMethod(rcPtr, METH_FINAL, NULL, NULL, &resObj)!=TCL_OK) {
ForwardSetObjError(paramPtr, resObj);
}
@@ -2932,13 +2955,7 @@ ForwardProc(
hPtr = Tcl_FindHashEntry(&rcmPtr->map,
Tcl_GetChannelName(rcPtr->chan));
Tcl_DeleteHashEntry(hPtr);
-
- tctPtr = ((Channel *)rcPtr->chan)->typePtr;
- if (tctPtr && tctPtr != &tclRChannelType) {
- ckfree((char *)tctPtr);
- ((Channel *)rcPtr->chan)->typePtr = NULL;
- }
- Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel);
+ MarkDead(rcPtr);
break;
}
diff --git a/generic/tclOO.c b/generic/tclOO.c
index de00733..02e00c9 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -1008,6 +1008,12 @@ ReleaseClassContents(
}
if (!Deleted(instancePtr)) {
Tcl_DeleteCommandFromToken(interp, instancePtr->command);
+ /*
+ * Tcl_DeleteCommandFromToken() may have done to whole
+ * job for us. Roll back and check again.
+ */
+ i--;
+ continue;
}
DelRef(instancePtr);
}
@@ -1280,6 +1286,7 @@ TclOORemoveFromInstances(
removeInstance:
if (Deleted(clsPtr->thisPtr)) {
+ DelRef(clsPtr->instances.list[i]);
clsPtr->instances.list[i] = NULL;
} else {
clsPtr->instances.num--;
diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c
index fe6063f..99d576d 100644
--- a/generic/tclPathObj.c
+++ b/generic/tclPathObj.c
@@ -2437,19 +2437,13 @@ SetFsPathFromAny(
}
TclDecrRefCount(parts);
} else {
- /*
- * Simple case. "rest" is relative path. Just join it. The
- * "rest" object will be freed when Tcl_FSJoinToPath returns
- * (unless something else claims a refCount on it).
- */
-
- Tcl_Obj *joined;
- Tcl_Obj *rest = Tcl_NewStringObj(name+split+1, -1);
+ Tcl_Obj *pair[2];
- Tcl_IncrRefCount(transPtr);
- joined = Tcl_FSJoinToPath(transPtr, 1, &rest);
- TclDecrRefCount(transPtr);
- transPtr = joined;
+ pair[0] = transPtr;
+ pair[1] = Tcl_NewStringObj(name+split+1, -1);
+ transPtr = TclJoinPath(2, pair);
+ Tcl_DecrRefCount(pair[0]);
+ Tcl_DecrRefCount(pair[1]);
}
}
} else {
diff --git a/generic/tclTest.c b/generic/tclTest.c
index a27c95a..0f4b6d4 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -201,8 +201,9 @@ static int EncodingFromUtfProc(ClientData clientData,
int *dstCharsPtr);
static void ExitProcEven(ClientData clientData);
static void ExitProcOdd(ClientData clientData);
-static int GetTimesCmd(ClientData clientData,
- Tcl_Interp *interp, int argc, const char **argv);
+static int GetTimesObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
static void MainLoop(void);
static int NoopCmd(ClientData clientData,
Tcl_Interp *interp, int argc, const char **argv);
@@ -219,6 +220,9 @@ static void SpecialFree(char *blockPtr);
static int StaticInitProc(Tcl_Interp *interp);
static int TestasyncCmd(ClientData dummy,
Tcl_Interp *interp, int argc, const char **argv);
+static int TestbytestringObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
static int TestcmdinfoCmd(ClientData dummy,
Tcl_Interp *interp, int argc, const char **argv);
static int TestcmdtokenCmd(ClientData dummy,
@@ -556,9 +560,10 @@ Tcltest_Init(
* Create additional commands and math functions for testing Tcl.
*/
- Tcl_CreateCommand(interp, "gettimes", GetTimesCmd, NULL, NULL);
+ Tcl_CreateObjCommand(interp, "gettimes", GetTimesObjCmd, NULL, NULL);
Tcl_CreateCommand(interp, "noop", NoopCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "noop", NoopObjCmd, NULL, NULL);
+ Tcl_CreateObjCommand(interp, "testbytestring", TestbytestringObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testwrongnumargs", TestWrongNumArgsObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testfilesystem", TestFilesystemObjCmd,
@@ -4717,7 +4722,7 @@ TestgetvarfullnameCmd(
/*
*----------------------------------------------------------------------
*
- * GetTimesCmd --
+ * GetTimesObjCmd --
*
* This procedure implements the "gettimes" command. It is used for
* computing the time needed for various basic operations such as reading
@@ -4733,11 +4738,11 @@ TestgetvarfullnameCmd(
*/
static int
-GetTimesCmd(
+GetTimesObjCmd(
ClientData unused, /* Unused. */
Tcl_Interp *interp, /* The current interpreter. */
- int argc, /* The number of arguments. */
- const char **argv) /* The argument strings. */
+ int notused1, /* Number of arguments. */
+ Tcl_Obj *const notused2[]) /* The argument objects. */
{
Interp *iPtr = (Interp *) interp;
int i, n;
@@ -4951,6 +4956,42 @@ NoopObjCmd(
/*
*----------------------------------------------------------------------
*
+ * TestbytestringObjCmd --
+ *
+ * This object-based procedure constructs a string which can
+ * possibly contain invalid UTF-8 bytes.
+ *
+ * Results:
+ * Returns the TCL_OK result code.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestbytestringObjCmd(
+ ClientData unused, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* The argument objects. */
+{
+ int n;
+ const char *p;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "bytearray");
+ return TCL_ERROR;
+ }
+ p = (const char *)Tcl_GetByteArrayFromObj(objv[1], &n);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(p, n));
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TestsetCmd --
*
* Implements the "testset{err,noerr}" cmds that are used when testing
diff --git a/generic/tclVar.c b/generic/tclVar.c
index 4694cd8..5e3157e 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -1958,6 +1958,9 @@ TclPtrSetVar(
Tcl_IncrRefCount(oldValuePtr); /* Since var is ref */
}
Tcl_AppendObjToObj(oldValuePtr, newValuePtr);
+ if (newValuePtr->refCount == 0) {
+ Tcl_DecrRefCount(newValuePtr);
+ }
}
}
} else if (newValuePtr != oldValuePtr) {
diff --git a/generic/tclZlib.c b/generic/tclZlib.c
index 2e27303..06e18fe 100644
--- a/generic/tclZlib.c
+++ b/generic/tclZlib.c
@@ -643,7 +643,6 @@ Tcl_ZlibStreamInit(
int e;
ZlibStreamHandle *zshPtr = NULL;
Tcl_DString cmdname;
- Tcl_CmdInfo cmdinfo;
GzipHeader *gzHeaderPtr = NULL;
switch (mode) {
@@ -769,8 +768,8 @@ Tcl_ZlibStreamInit(
Tcl_DStringInit(&cmdname);
TclDStringAppendLiteral(&cmdname, "::tcl::zlib::streamcmd_");
TclDStringAppendObj(&cmdname, Tcl_GetObjResult(interp));
- if (Tcl_GetCommandInfo(interp, Tcl_DStringValue(&cmdname),
- &cmdinfo) == 1) {
+ if (Tcl_FindCommand(interp, Tcl_DStringValue(&cmdname),
+ NULL, 0) != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"BUG: Stream command name already exists", -1));
Tcl_SetErrorCode(interp, "TCL", "BUG", "EXISTING_CMD", NULL);
@@ -2911,6 +2910,10 @@ ZlibTransformClose(
* Release all memory.
*/
+ if (cd->compDictObj) {
+ Tcl_DecrRefCount(cd->compDictObj);
+ cd->compDictObj = NULL;
+ }
Tcl_DStringFree(&cd->decompressed);
if (cd->inBuffer) {