Attachment "mutability851rc0.patch" to
ticket [1881766fff]
added by
ferrieux
2008-01-30 07:22:15.
diff -aburN tcl8.5.1rc0-orig/generic/tclBasic.c tcl8.5.1rc0/generic/tclBasic.c
--- tcl8.5.1rc0-orig/generic/tclBasic.c Fri Jan 25 16:43:50 2008
+++ tcl8.5.1rc0/generic/tclBasic.c Wed Jan 30 00:12:25 2008
@@ -697,6 +697,28 @@
Tcl_CreateObjCommand(interp, "::tcl::unsupported::disassemble",
Tcl_DisassembleObjCmd, NULL, NULL);
+ /*
+ * Create an unsupported command for debugging objects.
+ */
+
+ Tcl_CreateObjCommand(interp, "debugobj",
+ Tcl_DebugObjObjCmd, NULL, NULL);
+
+ /*
+ * Create a few unsupported commands for 1st-class mutables
+ */
+
+ Tcl_CreateObjCommand(interp, "mutable",
+ Tcl_MutableObjCmd, NULL, NULL);
+
+ Tcl_CreateObjCommand(interp, "mutant",
+ Tcl_MutantObjCmd, NULL, NULL);
+
+ if (Tcl_LinkVar(interp, "tcl_traceMutable", (char *) &tclTraceMutable,
+ TCL_LINK_INT) != TCL_OK) {
+ Tcl_Panic("Can't create link for tcl_traceMutable variable");
+ }
+
#ifdef USE_DTRACE
/*
* Register the tcl::dtrace command.
diff -aburN tcl8.5.1rc0-orig/generic/tclCmdAH.c tcl8.5.1rc0/generic/tclCmdAH.c
--- tcl8.5.1rc0-orig/generic/tclCmdAH.c Mon Nov 12 19:18:14 2007
+++ tcl8.5.1rc0/generic/tclCmdAH.c Wed Jan 30 00:12:25 2008
@@ -368,7 +368,12 @@
Tcl_Obj *CONST objv[]) /* Argument objects. */
{
if (objc >= 2) {
+ int wasMut;
+
+ wasMut=Tcl_IsListAndMutable(objv[1]);
+ if (wasMut) ListRepPtr(objv[1])->mutableFlag |= MUTABLE_MUTANT;
Tcl_SetObjResult(interp, Tcl_ConcatObj(objc-1, objv+1));
+ if (wasMut) ListRepPtr(objv[1])->mutableFlag &= ~MUTABLE_MUTANT;
}
return TCL_OK;
}
diff -aburN tcl8.5.1rc0-orig/generic/tclCmdIL.c tcl8.5.1rc0/generic/tclCmdIL.c
--- tcl8.5.1rc0-orig/generic/tclCmdIL.c Wed Jan 23 16:42:18 2008
+++ tcl8.5.1rc0/generic/tclCmdIL.c Wed Jan 30 00:12:25 2008
@@ -2196,7 +2196,7 @@
*/
listPtr = objv[1];
- if (Tcl_IsShared(listPtr)) {
+ if (Tcl_IsSharedAndNotMutableList(listPtr)) {
listPtr = TclListObjCopy(NULL, listPtr);
}
@@ -2552,7 +2552,7 @@
*/
listPtr = objv[1];
- if (Tcl_IsShared(listPtr)) {
+ if (Tcl_IsSharedAndNotMutableList(listPtr)) {
listPtr = TclListObjCopy(NULL, listPtr);
}
@@ -2623,6 +2623,8 @@
List *listPtr;
makeNewReversedList:
+ if (Tcl_IsListAndMutable(objv[1]))
+ goto inPlace;
resultObj = Tcl_NewListObj(elemc, NULL);
listPtr = (List *) resultObj->internalRep.twoPtrValue.ptr1;
listPtr->elemCount = elemc;
@@ -2645,6 +2647,7 @@
goto makeNewReversedList;
}
+ inPlace:
/*
* Not shared, so swap "in place". This relies on Tcl_LOGE above
* returning a pointer to the live array of Tcl_Obj values.
diff -aburN tcl8.5.1rc0-orig/generic/tclInt.h tcl8.5.1rc0/generic/tclInt.h
--- tcl8.5.1rc0-orig/generic/tclInt.h Fri Jan 25 16:43:54 2008
+++ tcl8.5.1rc0/generic/tclInt.h Wed Jan 30 00:12:25 2008
@@ -1,5 +1,5 @@
/*
- * tclInt.h --
+ * Tclint.h --
*
* Declarations of things used internally by the Tcl interpreter.
*
@@ -1877,6 +1877,9 @@
* TclpCheckStackSpace in the platform's
* directory. */
+ int mutant; /* Counter for [mutant] command prefix.
+ * Allows nesting. */
+
#ifdef TCL_COMPILE_STATS
/*
@@ -1887,8 +1890,27 @@
ByteCodeStats stats; /* Holds compilation and execution statistics
* for this interpreter. */
#endif /* TCL_COMPILE_STATS */
+
+
} Interp;
+
+extern int tclTraceMutable;
+#define Mutant(interp) ((interp) && ((Interp *)(interp))->mutant)
+/*
+ * Flag to remember the fact that we are on the purge list
+ */
+#define MUTABLE_TOINVAL 0x80000000
+#define MUTABLE_MUTANT 0x40000000
+/*
+ * Mass Invalidator for mutable values
+ */
+extern void TclMutableMassInvalidator();
+/*
+ * Debug routine returning 1 to advertise successful mutability tests
+ */
+extern int MutSpy(Tcl_Obj *obj);
+
/*
* Macros that use the TSD-ekeko.
*/
@@ -2121,8 +2143,13 @@
* derived from the list representation. May
* be ignored if there is no string rep at
* all.*/
+ int mutableFlag; /* a List may be a mutable container */
+
+ /* This one must be the last field !!! */
Tcl_Obj *elements; /* First list element; the struct is grown to
* accomodate all elements. */
+
+
} List;
/*
@@ -2149,6 +2176,23 @@
? ((ListObjLength((listPtr), *(lenPtr))), TCL_OK)\
: Tcl_ListObjLength((interp), (listPtr), (lenPtr)))
+#define Tcl_ListIsMutable(objPtr) \
+ (Mutant(interp) && ListRepPtr(objPtr)->mutableFlag && MutSpy(objPtr))
+
+#define Tcl_ListIsMutableNoInterp(objPtr) \
+ ((ListRepPtr(objPtr)->mutableFlag&MUTABLE_MUTANT) && MutSpy(objPtr))
+
+#define Tcl_IsListAndMutable(objPtr) \
+ (((objPtr)->typePtr==&tclListType)&&Tcl_ListIsMutable(objPtr))
+
+#define Tcl_IsListAndMutableNoInterp(objPtr) \
+ (((objPtr)->typePtr==&tclListType)&&Tcl_ListIsMutableNoInterp(objPtr))
+
+#define Tcl_IsSharedAndNotMutableList(objPtr) \
+ (Tcl_IsShared(objPtr)&&(!Tcl_IsListAndMutable(objPtr)))
+
+MODULE_SCOPE Tcl_Obj *Tcl_MakeListMutable(Tcl_Interp *interp,Tcl_Obj *listPtr);
+
/*
* Macros providing a faster path to integers: Tcl_GetLongFromObj everywhere,
* Tcl_GetIntFromObj and TclGetIntForIndex on platforms where longs are ints.
@@ -2683,6 +2727,9 @@
#endif
MODULE_SCOPE Tcl_Obj * TclDisassembleByteCodeObj(Tcl_Obj *objPtr);
+MODULE_SCOPE void TclAddToMutableInvalList(Tcl_Obj *objPtr);
+MODULE_SCOPE void TclRemoveFromMutableInvalList(Tcl_Obj *objPtr);
+
/*
*----------------------------------------------------------------
* Command procedures in the generic core:
@@ -2746,6 +2793,22 @@
MODULE_SCOPE int Tcl_DisassembleObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
+
+MODULE_SCOPE int Tcl_DebugObjObjCmd(ClientData dummy,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *CONST objv[]);
+
+MODULE_SCOPE int Tcl_MutableObjCmd(ClientData dummy,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *CONST objv[]);
+
+MODULE_SCOPE int Tcl_MutantObjCmd(ClientData dummy,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *CONST objv[]);
+
MODULE_SCOPE int Tcl_EncodingObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
diff -aburN tcl8.5.1rc0-orig/generic/tclListObj.c tcl8.5.1rc0/generic/tclListObj.c
--- tcl8.5.1rc0-orig/generic/tclListObj.c Mon Nov 12 19:18:20 2007
+++ tcl8.5.1rc0/generic/tclListObj.c Wed Jan 30 00:12:25 2008
@@ -100,6 +100,7 @@
listRepPtr->canonicalFlag = 0;
listRepPtr->refCount = 0;
listRepPtr->maxElemCount = objc;
+ listRepPtr->mutableFlag = 0;
if (objv) {
Tcl_Obj **elemPtrs;
@@ -291,12 +292,12 @@
* None.
*
* Side effects:
- * The object is made a list object and is initialized from the object
- * pointers in objv. If objc is less than or equal to zero, an empty
- * object is returned. The new object's string representation is left
- * NULL. The ref counts of the elements in objv are incremented since the
- * list now refers to them. The object's old string and internal
- * representations are freed and its type is set NULL.
+ * The object is made a(n immutable) list object and is initialized from
+ * the object pointers in objv. If objc is less than or equal to zero, an
+ * empty object is returned. The new object's string representation is
+ * left NULL. The ref counts of the elements in objv are incremented
+ * since the list now refers to them. The object's old string and
+ * internal representations are freed and its type is set NULL.
*
*----------------------------------------------------------------------
*/
@@ -325,10 +326,13 @@
* Set the object's type to "list" and initialize the internal rep.
* However, if there are no elements to put in the list, just give the
* object an empty string rep and a NULL type.
+ *
+ * In case of mutable, always create a list to be able to store
+ * the mutableFlag
*/
if (objc > 0) {
- listRepPtr = NewListIntRep(objc, objv);
+ listRepPtr = NewListIntRep((objc==0)?1:objc,(objc==0)?NULL:objv);
if (!listRepPtr) {
Tcl_Panic("Cannot allocate enough memory for Tcl_SetListObj");
}
@@ -336,6 +340,7 @@
objPtr->internalRep.twoPtrValue.ptr2 = NULL;
objPtr->typePtr = &tclListType;
listRepPtr->refCount++;
+ listRepPtr->mutableFlag=0;
} else {
objPtr->bytes = tclEmptyStringRep;
objPtr->length = 0;
@@ -481,7 +486,7 @@
int listLen, objc, result;
Tcl_Obj **objv;
- if (Tcl_IsShared(listPtr)) {
+ if (Tcl_IsSharedAndNotMutableList(listPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendList");
}
@@ -540,7 +545,7 @@
register Tcl_Obj **elemPtrs;
int numElems, numRequired, newMax, newSize, i;
- if (Tcl_IsShared(listPtr)) {
+ if (Tcl_IsSharedAndNotMutableList(listPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendElement");
}
if (listPtr->typePtr != &tclListType) {
@@ -615,7 +620,11 @@
* representation has changed.
*/
+ if (Tcl_ListIsMutable(listPtr))
+ TclMutableMassInvalidator();
+ else
Tcl_InvalidateStringRep(listPtr);
+
return TCL_OK;
}
@@ -781,7 +790,7 @@
register Tcl_Obj **elemPtrs;
int numElems, numRequired, numAfterLast, start, i, j, isShared;
- if (Tcl_IsShared(listPtr)) {
+ if (Tcl_IsSharedAndNotMutableList(listPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_ListObjReplace");
}
if (listPtr->typePtr != &tclListType) {
@@ -906,6 +915,8 @@
* The old struct will be removed; use its inherited refCounts.
*/
+ listRepPtr->mutableFlag=oldListRepPtr->mutableFlag;
+
if (first > 0) {
memcpy(elemPtrs, oldPtrs, (size_t) first * sizeof(Tcl_Obj *));
}
@@ -958,6 +969,9 @@
* reflects the list's internal representation.
*/
+ if (Tcl_ListIsMutable(listPtr))
+ TclMutableMassInvalidator();
+ else
Tcl_InvalidateStringRep(listPtr);
return TCL_OK;
}
@@ -1286,7 +1300,7 @@
* leave the string rep of listPtr and all elements to be unchanged.
*/
- subListPtr = Tcl_IsShared(listPtr) ? Tcl_DuplicateObj(listPtr) : listPtr;
+ subListPtr = Tcl_IsSharedAndNotMutableList(listPtr) ? Tcl_DuplicateObj(listPtr) : listPtr;
/*
* Anchor the linked list of Tcl_Obj's whose string reps must be
@@ -1344,7 +1358,7 @@
if (--indexCount) {
parentList = subListPtr;
subListPtr = elemPtrs[index];
- if (Tcl_IsShared(subListPtr)) {
+ if (Tcl_IsSharedAndNotMutableList(subListPtr)) {
subListPtr = Tcl_DuplicateObj(subListPtr);
}
@@ -1358,7 +1372,7 @@
*/
TclListObjSetElement(NULL, parentList, index, subListPtr);
- if (Tcl_IsShared(subListPtr)) {
+ if (Tcl_IsSharedAndNotMutableList(subListPtr)) {
subListPtr = Tcl_DuplicateObj(subListPtr);
TclListObjSetElement(NULL, parentList, index, subListPtr);
}
@@ -1420,6 +1434,9 @@
/* Store valuePtr in proper sublist and return */
TclListObjSetElement(NULL, subListPtr, index, valuePtr);
+ if (Tcl_ListIsMutable(subListPtr))
+ TclMutableMassInvalidator();
+ else
Tcl_InvalidateStringRep(subListPtr);
Tcl_IncrRefCount(retValuePtr);
return retValuePtr;
@@ -1473,7 +1490,7 @@
* Ensure that the listPtr parameter designates an unshared list.
*/
- if (Tcl_IsShared(listPtr)) {
+ if (Tcl_IsSharedAndNotMutableList(listPtr)) {
Tcl_Panic("%s called with shared object", "TclListObjSetElement");
}
if (listPtr->typePtr != &tclListType) {
@@ -1582,6 +1599,9 @@
int numElems = listRepPtr->elemCount;
int i;
+ if (listRepPtr->mutableFlag&&(listRepPtr->mutableFlag&MUTABLE_TOINVAL))
+ TclRemoveFromMutableInvalList(listPtr);
+
if (--listRepPtr->refCount <= 0) {
for (i = 0; i < numElems; i++) {
objPtr = elemPtrs[i];
@@ -1740,8 +1760,9 @@
* Free the old internalRep before setting the new one. We do this as late
* as possible to allow the conversion code, in particular
* Tcl_GetStringFromObj, to use that old internalRep.
+ * It also allows us to inherit the mutableFlag.
*/
-
+ listRepPtr->mutableFlag=Tcl_IsListAndMutable(objPtr);
listRepPtr->refCount++;
TclFreeIntRep(objPtr);
objPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr;
@@ -1844,6 +1865,59 @@
*/
listRepPtr->canonicalFlag = 1;
+
+ if (listRepPtr->mutableFlag)
+ {
+ listRepPtr->mutableFlag |= MUTABLE_TOINVAL;
+ TclAddToMutableInvalList(listPtr);
+ }
+}
+
+Tcl_Obj *Tcl_MakeListMutable(Tcl_Interp *interp,Tcl_Obj *listPtr)
+{
+ List *listRepPtr;
+
+ if (listPtr->typePtr!=&tclListType)
+ {
+ if (SetListFromAny(interp,listPtr)!=TCL_OK)
+ return NULL;
+ }
+ if (Tcl_ListIsMutable(listPtr)) return listPtr;
+ if (Tcl_IsShared(listPtr))
+ {
+ Tcl_Obj *copyPtr;
+
+ TclNewObj(copyPtr);
+ TclInvalidateStringRep(copyPtr);
+ DupListInternalRep(listPtr, copyPtr);
+ listPtr=copyPtr;
+ }
+ listRepPtr=ListRepPtr(listPtr);
+ if (listRepPtr->refCount>1)
+ {
+ Tcl_Obj **elemPtrs;
+ int elemCount=listRepPtr->elemCount;
+ List *oldListRepPtr = listRepPtr;
+ Tcl_Obj **oldElemPtrs = &listRepPtr->elements;
+ int i;
+
+ listRepPtr = NewListIntRep(listRepPtr->maxElemCount, NULL);
+ if (listRepPtr == NULL) {
+ Tcl_Panic("Not enough memory to allocate list");
+ }
+ listRepPtr->canonicalFlag = oldListRepPtr->canonicalFlag;
+ elemPtrs = &listRepPtr->elements;
+ for (i=0; i < elemCount; i++) {
+ elemPtrs[i] = oldElemPtrs[i];
+ Tcl_IncrRefCount(elemPtrs[i]);
+ }
+ listRepPtr->refCount++;
+ listRepPtr->elemCount = elemCount;
+ listPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr;
+ oldListRepPtr->refCount--;
+ }
+ listRepPtr->mutableFlag=1;
+ return listPtr;
}
/*
diff -aburN tcl8.5.1rc0-orig/generic/tclMutable.c tcl8.5.1rc0/generic/tclMutable.c
--- tcl8.5.1rc0-orig/generic/tclMutable.c Thu Jan 1 00:00:00 1970
+++ tcl8.5.1rc0/generic/tclMutable.c Wed Jan 30 00:12:25 2008
@@ -0,0 +1,189 @@
+#include "tclInt.h"
+
+int tclTraceMutable;
+
+#ifdef TCL_THREADS
+static Tcl_Mutex mutableInvalMutex;
+#define MutLock() Tcl_MutexLock(&mutableInvalMutex)
+#define MutUnlock() Tcl_MutexUnlock(&mutableInvalMutex)
+#else
+#define MutLock()
+#define MutUnlock()
+#endif
+
+/*
+ * List of mutable containers having a string rep at any given time.
+ * Uses Tcl_Obj's as chained cells (twoPtrValue == car,cdr)
+ * Process-global !
+ */
+static Tcl_Obj *mutableInvalList=NULL;
+
+static void DebugObj(Tcl_Obj *ob)
+{
+ printf("Obj:0x%X(%d) ",
+ (int)ob,
+ ob->refCount);
+ if (!ob->typePtr)
+ printf("(null) ");
+ else if (ob->typePtr==&tclListType)
+ printf("(List):0x%X(%d) (%d elts%s%s) ",
+ (int)ListRepPtr(ob),
+ (int)ListRepPtr(ob)->refCount,
+ (int)ListRepPtr(ob)->elemCount,
+ ListRepPtr(ob)->mutableFlag?", Mutable":"",
+ (ListRepPtr(ob)->mutableFlag&MUTABLE_TOINVAL)?", ToInval":"");
+ else
+ printf("(%s):0x%X-0x%X ",
+ ob->typePtr->name,
+ (int)ob->internalRep.twoPtrValue.ptr1,
+ (int)ob->internalRep.twoPtrValue.ptr2);
+ printf("<<<%s>>>\n",(ob->bytes?ob->bytes:"?"));
+ fflush(stdout);
+}
+
+int
+Tcl_DebugObjObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *CONST objv[]) /* Argument objects. */
+{
+ Tcl_Obj *ob;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "object");
+ return TCL_ERROR;
+ }
+ ob=objv[1];
+ DebugObj(ob);
+ Tcl_SetObjResult(interp, ob);
+ return TCL_OK;
+}
+
+int MutSpy(Tcl_Obj *ob)
+{
+ if (tclTraceMutable)
+ {
+ printf("*** Mutating: ");
+ DebugObj(ob);
+ }
+ return 1;
+}
+
+int
+Tcl_MutableObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *CONST objv[]) /* Argument objects. */
+{
+ Tcl_Obj *obj;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "<list>");
+ return TCL_ERROR;
+ }
+ obj=objv[1];
+ obj=Tcl_MakeListMutable(interp,obj);
+ if (!obj) return TCL_ERROR;
+ Tcl_SetObjResult(interp,obj);
+ return TCL_OK;
+}
+
+int
+Tcl_MutantObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *CONST objv[]) /* Argument objects. */
+{
+ int ret;
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "<command> [<args>...]");
+ return TCL_ERROR;
+ }
+ ((Interp *)interp)->mutant++;
+ ret=Tcl_EvalObjv(interp, objc-1, objv+1, 0);
+ ((Interp *)interp)->mutant--;
+
+ return ret;
+}
+
+#define TclCar(obj) ((Tcl_Obj *)(obj)->internalRep.twoPtrValue.ptr1)
+#define TclCdr(obj) ((Tcl_Obj *)(obj)->internalRep.twoPtrValue.ptr2)
+#define TclSetCar(cons,obj)
+
+void TclAddToMutableInvalList(Tcl_Obj *obj)
+{
+ Tcl_Obj *cons;
+
+ cons=Tcl_NewObj();
+ Tcl_IncrRefCount(cons);
+ cons->internalRep.twoPtrValue.ptr1=obj;
+ MutLock();
+ cons->internalRep.twoPtrValue.ptr2=mutableInvalList;
+ mutableInvalList=cons;
+ MutUnlock();
+ if (tclTraceMutable) printf(" + 0x%X <<<%s>>>\n",(int)obj,obj->bytes);
+}
+
+void TclRemoveFromMutableInvalList(Tcl_Obj *obj)
+{
+ Tcl_Obj **x,*y;
+
+ MutLock();
+ for(x=&mutableInvalList;(y=*x);x=(Tcl_Obj **)&y->internalRep.twoPtrValue.ptr2)
+ {
+ if (TclCar(y)==obj)
+ {
+ *x=TclCdr(y);
+ MutUnlock();
+ Tcl_DecrRefCount(y);
+ if (tclTraceMutable)
+ printf(" -- 0x%X\n",(int)obj);
+ return;
+ }
+ }
+ MutUnlock();
+ if (tclTraceMutable)
+ fprintf(stderr,"*** Internal error: object not found in MutableInvalList: 0x%X <<<%s>>>\n",(int)obj,obj->bytes);
+}
+
+static void TclMaskMutableFlag(Tcl_Obj *obj)
+{
+ if (obj->typePtr==&tclListType)
+ {
+ ListRepPtr(obj)->mutableFlag &= (~MUTABLE_TOINVAL);
+ }
+ else
+ {
+ printf("*** Internal error: masking object of immutable type:\n");
+ DebugObj(obj);
+ }
+}
+
+void TclMutableMassInvalidator(void)
+{
+ Tcl_Obj *cons,*nxt;
+
+ if (tclTraceMutable)
+ printf("\n*** Mass Invalidator ***\n");
+ MutLock();
+ for(cons=mutableInvalList;cons;cons=nxt)
+ {
+ Tcl_Obj *obj;
+
+ nxt=TclCdr(cons);
+ obj=TclCar(cons);
+ if (tclTraceMutable)
+ printf(" - 0x%X <<<%s>>>\n",(int)obj,obj->bytes);
+ Tcl_InvalidateStringRep(obj);
+ TclMaskMutableFlag(obj);
+ Tcl_DecrRefCount(cons);
+ }
+ mutableInvalList=NULL;
+ MutUnlock();
+ if (tclTraceMutable)
+ printf("*** Done ***\n\n");
+}
diff -aburN tcl8.5.1rc0-orig/generic/tclUtil.c tcl8.5.1rc0/generic/tclUtil.c
--- tcl8.5.1rc0-orig/generic/tclUtil.c Tue Dec 11 16:19:56 2007
+++ tcl8.5.1rc0/generic/tclUtil.c Wed Jan 30 00:12:25 2008
@@ -1197,7 +1197,7 @@
if (resPtr) {
Tcl_ListObjReplace(NULL, resPtr, INT_MAX, 0, listc, listv);
} else {
- if (Tcl_IsShared(objPtr)) {
+ if (Tcl_IsShared(objPtr) && !Tcl_IsListAndMutableNoInterp(objPtr)) {
resPtr = TclListObjCopy(NULL, objPtr);
} else {
resPtr = objPtr;
diff -aburN tcl8.5.1rc0-orig/generic/tclVar.c tcl8.5.1rc0/generic/tclVar.c
--- tcl8.5.1rc0-orig/generic/tclVar.c Sun Nov 25 06:45:44 2007
+++ tcl8.5.1rc0/generic/tclVar.c Wed Jan 30 00:12:25 2008
@@ -1844,7 +1844,7 @@
TclNewObj(oldValuePtr);
varPtr->value.objPtr = oldValuePtr;
Tcl_IncrRefCount(oldValuePtr); /* Since var is referenced. */
- } else if (Tcl_IsShared(oldValuePtr)) {
+ } else if (Tcl_IsShared(oldValuePtr) && !Tcl_IsListAndMutable(oldValuePtr)) {
varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr);
TclDecrRefCount(oldValuePtr);
oldValuePtr = varPtr->value.objPtr;
@@ -1864,7 +1864,7 @@
varPtr->value.objPtr = newValuePtr;
Tcl_IncrRefCount(newValuePtr);
} else {
- if (Tcl_IsShared(oldValuePtr)) { /* Append to copy. */
+ if (Tcl_IsShared(oldValuePtr) /* Mutability lost if any */ ) { /* Append to copy. */
varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr);
TclDecrRefCount(oldValuePtr);
oldValuePtr = varPtr->value.objPtr;
@@ -2650,7 +2650,7 @@
TclNewObj(varValuePtr);
createdNewObj = 1;
- } else if (Tcl_IsShared(varValuePtr)) {
+ } else if (Tcl_IsShared(varValuePtr) && !Tcl_IsListAndMutable(varValuePtr)) {
varValuePtr = Tcl_DuplicateObj(varValuePtr);
createdNewObj = 1;
}
diff -aburN tcl8.5.1rc0-orig/tests/mutability.test tcl8.5.1rc0/tests/mutability.test
--- tcl8.5.1rc0-orig/tests/mutability.test Thu Jan 1 00:00:00 1970
+++ tcl8.5.1rc0/tests/mutability.test Wed Jan 30 00:12:25 2008
@@ -0,0 +1,62 @@
+# Commands covered: mutable mutant
+#
+# This file contains a collection of tests for one or more of the Tcl
+# built-in commands. Sourcing this file into Tcl runs the tests and
+# generates output for errors. No output means no errors were found.
+#
+# Copyright (c) 1991-1993 The Regents of the University of California.
+# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: llength.test,v 1.6 2004/05/19 12:23:58 dkf Exp $
+
+if {[lsearch [namespace children] ::tcltest] == -1} {
+ package require tcltest
+ namespace import -force ::tcltest::*
+}
+
+test mutability-1.1 {mutable list} {
+ mutable [list a b c d]
+} {a b c d}
+test mutability-1.2 {effective mutability} {
+ set m [mutable [list 1 2 3]]
+ set n $m
+ mutant lappend m 4
+ list $m $n
+} {{1 2 3 4} {1 2 3 4}}
+test mutability-1.3 {ineffective mutability} {
+ set m [mutable [list 1 2 3]]
+ set n $m
+ lappend m 4
+ list $m $n
+} {{1 2 3 4} {1 2 3}}
+test mutability-1.4 {loss of mutability} {
+ set m [mutable [list 1 2 3]]
+ lappend m 4
+ set n $m
+ lappend m 5
+ list $m $n
+} {{1 2 3 4 5} {1 2 3 4}}
+test mutability-1.5 {immutable snapshot} {
+ set m [mutable [list 1 2 3]]
+ set n [lrange $m 0 end]
+ mutant lappend m 4
+ list $m $n
+} {{1 2 3 4} {1 2 3}}
+
+test mutability-2.1 {error conditions} {
+ list [catch {mutable} msg] $msg
+} {1 {wrong # args: should be "mutable <list>"}}
+test mutability-2.2 {error conditions} {
+ list [catch {mutable a b} msg] $msg
+} {1 {wrong # args: should be "mutable <list>"}}
+test mutability-2.3 {error conditions} {
+ list [catch {mutable "a b c \{"} msg] $msg
+} {1 {unmatched open brace in list}}
+
+# cleanup
+::tcltest::cleanupTests
+return
diff -aburN tcl8.5.1rc0-orig/tests/safe.test tcl8.5.1rc0/tests/safe.test
--- tcl8.5.1rc0-orig/tests/safe.test Tue Dec 5 18:45:52 2006
+++ tcl8.5.1rc0/tests/safe.test Wed Jan 30 00:12:25 2008
@@ -169,7 +169,7 @@
test safe-6.1 {test safe interpreters knowledge of the world} {
lsort [SafeEval {info globals}]
-} {tcl_interactive tcl_patchLevel tcl_platform tcl_version}
+} {tcl_interactive tcl_patchLevel tcl_platform tcl_traceMutable tcl_version}
test safe-6.2 {test safe interpreters knowledge of the world} {
SafeEval {info script}
} {}
diff -aburN tcl8.5.1rc0-orig/win/Makefile.in tcl8.5.1rc0/win/Makefile.in
--- tcl8.5.1rc0-orig/win/Makefile.in Fri Jan 25 21:45:00 2008
+++ tcl8.5.1rc0/win/Makefile.in Wed Jan 30 00:12:25 2008
@@ -248,6 +248,7 @@
tclListObj.$(OBJEXT) \
tclLoad.$(OBJEXT) \
tclMain.$(OBJEXT) \
+ tclMutable.$(OBJEXT) \
tclNamesp.$(OBJEXT) \
tclNotify.$(OBJEXT) \
tclObj.$(OBJEXT) \
