summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog8
-rw-r--r--generic/tclInt.decls6
-rw-r--r--generic/tclInt.h13
-rw-r--r--generic/tclIntDecls.h12
-rw-r--r--generic/tclObj.c57
-rw-r--r--generic/tclStubInit.c3
6 files changed, 77 insertions, 22 deletions
diff --git a/ChangeLog b/ChangeLog
index af0f7cb..6adf911 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,13 @@
2006-09-30 Miguel Sofer <msofer@users.sf.net>
+ * generic/tclInt.decls:
+ * generic/tclInt.h:
+ * generic/tclIntDecls.h:
+ * generic/tclObj.c:
+ * generic/tclStubInit.c: added an internal function
+ TclObjBeingDeleted to provide info as to the reason for the loss
+ of an internal rep. [FR 1512138]
+
* generic/tclCompile.c:
* generic/tclHistory.c:
* generic/tclInt.h:
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index 208ca9e..3d77a83 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -12,7 +12,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: tclInt.decls,v 1.97 2006/06/21 03:10:39 dgp Exp $
+# RCS: @(#) $Id: tclInt.decls,v 1.98 2006/09/30 19:00:12 msofer Exp $
library tcl
@@ -890,6 +890,10 @@ declare 225 generic {
int keyc, Tcl_Obj *CONST keyv[], int flags)
}
+declare 226 generic {
+ int TclObjBeingDeleted(Tcl_Obj *objPtr)
+}
+
##############################################################################
# Define the platform specific internal Tcl interface. These functions are
diff --git a/generic/tclInt.h b/generic/tclInt.h
index a3d6f48..6c45660 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInt.h,v 1.278 2006/09/30 17:56:47 msofer Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.279 2006/09/30 19:00:12 msofer Exp $
*/
#ifndef _TCLINT
@@ -2646,15 +2646,20 @@ MODULE_SCOPE void TclInvalidateNsPath(Namespace *nsPtr);
(objPtr)->length = 0; \
(objPtr)->typePtr = NULL
+/* Invalidate the string rep first so we can use the bytes value \
+ * for our pointer chain, and signal an obj deletion (as opposed \
+ * to shimmering) with 'length == -1' */ \
+
# define TclDecrRefCount(objPtr) \
if (--(objPtr)->refCount <= 0) { \
if ((objPtr)->typePtr && (objPtr)->typePtr->freeIntRepProc) { \
TclFreeObj(objPtr); \
} else { \
- if ((objPtr)->bytes \
- && ((objPtr)->bytes != tclEmptyStringRep)) { \
- ckfree((char *) (objPtr)->bytes); \
+ if ((objPtr)->bytes \
+ && ((objPtr)->bytes != tclEmptyStringRep)) { \
+ ckfree((char *) (objPtr)->bytes); \
} \
+ (objPtr)->length = -1; \
TclFreeObjStorage(objPtr); \
TclIncrObjsFreed(); \
} \
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index 1912451..f9ec7a7 100644
--- a/generic/tclIntDecls.h
+++ b/generic/tclIntDecls.h
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclIntDecls.h,v 1.87 2006/06/21 03:10:39 dgp Exp $
+ * RCS: @(#) $Id: tclIntDecls.h,v 1.88 2006/09/30 19:00:13 msofer Exp $
*/
#ifndef _TCLINTDECLS
@@ -1020,6 +1020,11 @@ EXTERN Tcl_Obj * TclTraceDictPath _ANSI_ARGS_((Tcl_Interp * interp,
Tcl_Obj * rootPtr, int keyc,
Tcl_Obj *CONST keyv[], int flags));
#endif
+#ifndef TclObjBeingDeleted_TCL_DECLARED
+#define TclObjBeingDeleted_TCL_DECLARED
+/* 226 */
+EXTERN int TclObjBeingDeleted _ANSI_ARGS_((Tcl_Obj * objPtr));
+#endif
typedef struct TclIntStubs {
int magic;
@@ -1266,6 +1271,7 @@ typedef struct TclIntStubs {
void *reserved223;
TclPlatformType * (*tclGetPlatform) _ANSI_ARGS_((void)); /* 224 */
Tcl_Obj * (*tclTraceDictPath) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * rootPtr, int keyc, Tcl_Obj *CONST keyv[], int flags)); /* 225 */
+ int (*tclObjBeingDeleted) _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 226 */
} TclIntStubs;
#ifdef __cplusplus
@@ -1955,6 +1961,10 @@ extern TclIntStubs *tclIntStubsPtr;
#define TclTraceDictPath \
(tclIntStubsPtr->tclTraceDictPath) /* 225 */
#endif
+#ifndef TclObjBeingDeleted
+#define TclObjBeingDeleted \
+ (tclIntStubsPtr->tclObjBeingDeleted) /* 226 */
+#endif
#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
diff --git a/generic/tclObj.c b/generic/tclObj.c
index 3c5e3cf..eb77e35 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclObj.c,v 1.112 2006/08/10 12:15:31 dkf Exp $
+ * RCS: @(#) $Id: tclObj.c,v 1.113 2006/09/30 19:00:13 msofer Exp $
*/
#include "tclInt.h"
@@ -111,13 +111,8 @@ typedef struct PendingObjData {
#define ObjDeletePending(contextPtr) ((contextPtr)->deletionCount > 0)
#define ObjOnStack(contextPtr) ((contextPtr)->deletionStack != NULL)
#define PushObjToDelete(contextPtr,objPtr) \
- /* Invalidate the string rep first so we can use the bytes value \
- * for our pointer chain. */ \
- if (((objPtr)->bytes != NULL) \
- && ((objPtr)->bytes != tclEmptyStringRep)) { \
- ckfree((char *) (objPtr)->bytes); \
- } \
- /* Now push onto the head of the stack. */ \
+ /* The string rep is already invalidated so we can use the bytes value \
+ * for our pointer chain: push onto the head of the stack. */ \
(objPtr)->bytes = (char *) ((contextPtr)->deletionStack); \
(contextPtr)->deletionStack = (objPtr)
#define PopObjToDelete(contextPtr,objPtrVar) \
@@ -849,6 +844,13 @@ TclFreeObj(
Tcl_Panic("Reference count for %lx was negative", objPtr);
}
+ /* Invalidate the string rep first so we can use the bytes value
+ * for our pointer chain, and signal an obj deletion (as opposed
+ * to shimmering) with 'length == -1' */
+
+ TclInvalidateStringRep(objPtr);
+ objPtr->length = -1;
+
if (ObjDeletePending(context)) {
PushObjToDelete(context, objPtr);
} else {
@@ -857,7 +859,6 @@ TclFreeObj(
typePtr->freeIntRepProc(objPtr);
ObjDeletionUnlock(context);
}
- TclInvalidateStringRep(objPtr);
Tcl_MutexLock(&tclObjMutex);
ckfree((char *) objPtr);
@@ -888,15 +889,19 @@ void
TclFreeObj(
register Tcl_Obj *objPtr) /* The object to be freed. */
{
+ /* Invalidate the string rep first so we can use the bytes value
+ * for our pointer chain, and signal an obj deletion (as opposed
+ * to shimmering) with 'length == -1' */
+
+ TclInvalidateStringRep(objPtr);
+ objPtr->length = -1;
+
if (!objPtr->typePtr || !objPtr->typePtr->freeIntRepProc) {
/*
* objPtr can be freed safely, as it will not attempt to free any
* other objects: it will not cause recursive calls to this function.
*/
- if (objPtr->bytes && (objPtr->bytes != tclEmptyStringRep)) {
- ckfree((char *) objPtr->bytes);
- }
TclFreeObjStorage(objPtr);
TclIncrObjsFreed();
} else {
@@ -923,9 +928,6 @@ TclFreeObj(
objPtr->typePtr->freeIntRepProc(objPtr);
ObjDeletionUnlock(context);
- if (objPtr->bytes && (objPtr->bytes != tclEmptyStringRep)) {
- ckfree((char *) objPtr->bytes);
- }
TclFreeObjStorage(objPtr);
TclIncrObjsFreed();
ObjDeletionLock(context);
@@ -948,6 +950,31 @@ TclFreeObj(
/*
*----------------------------------------------------------------------
*
+ * TclObjBeingDeleted --
+ *
+ * This function returns 1 when the Tcl_Obj is being deleted. It is
+ * provided for the rare cases where the reason for the loss of an
+ * internal rep might be relevant [FR 1512138]
+ *
+ * Results:
+ * 1 if being deleted, 0 otherwise.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclObjBeingDeleted(Tcl_Obj *objPtr)
+{
+ return (objPtr->length == -1);
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_DuplicateObj --
*
* Create and return a new object that is a duplicate of the argument
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index 4a68100..535566f 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclStubInit.c,v 1.132 2006/09/22 18:13:29 andreas_kupries Exp $
+ * RCS: @(#) $Id: tclStubInit.c,v 1.133 2006/09/30 19:00:13 msofer Exp $
*/
#include "tclInt.h"
@@ -317,6 +317,7 @@ TclIntStubs tclIntStubs = {
NULL, /* 223 */
TclGetPlatform, /* 224 */
TclTraceDictPath, /* 225 */
+ TclObjBeingDeleted, /* 226 */
};
TclIntPlatStubs tclIntPlatStubs = {