More tweaks, finetuning

generic/tcl.decls

@@ -40,22 +40,22 @@ declare 2 {
     TCL_NORETURN void Tcl_Panic(const char *format, ...)
 }
 declare 3 {
-    void *Tcl_Alloc(TCL_HASH_TYPE size)
+    void *Tcl_Alloc_(TCL_HASH_TYPE size)
 }
 declare 4 {
     void Tcl_Free(void *ptr)
 }
 declare 5 {
-    void *Tcl_Realloc(void *ptr, TCL_HASH_TYPE size)
+    void *Tcl_Realloc_(void *ptr, TCL_HASH_TYPE size)
 }
 declare 6 {
-    void *Tcl_DbCkalloc(TCL_HASH_TYPE size, const char *file, int line)
+    void *Tcl_DbCkalloc_(TCL_HASH_TYPE size, const char *file, int line)
 }
 declare 7 {
     void Tcl_DbCkfree(void *ptr, const char *file, int line)
 }
 declare 8 {
-    void *Tcl_DbCkrealloc(void *ptr, TCL_HASH_TYPE size,
+    void *Tcl_DbCkrealloc_(void *ptr, TCL_HASH_TYPE size,
 	    const char *file, int line)
 }
 
@@ -255,7 +255,7 @@ declare 62 {
 #    void Tcl_SetLongObj(Tcl_Obj *objPtr, long longValue)
 #}
 declare 64 {
-    void Tcl_SetObjLength(Tcl_Obj *objPtr, Tcl_Size length)
+    char *Tcl_SetObjLength_(Tcl_Obj *objPtr, Tcl_Size length)
 }
 declare 65 {
     void Tcl_SetStringObj(Tcl_Obj *objPtr, const char *bytes, Tcl_Size length)
@@ -1394,7 +1394,7 @@ declare 378 {
     Tcl_Obj *Tcl_NewUnicodeObj(const Tcl_UniChar *unicode, Tcl_Size numChars)
 }
 declare 379 {
-    void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode,
+    Tcl_UniChar * Tcl_SetUnicodeObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode,
 	    Tcl_Size numChars)
 }
 declare 380 {
@@ -1411,7 +1411,7 @@ declare 383 {
     Tcl_Obj *TclGetRange(Tcl_Obj *objPtr, Tcl_Size first, Tcl_Size last)
 }
 declare 384 {
-    void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode,
+    Tcl_UniChar *Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode,
 	    Tcl_Size length)
 }
 declare 385 {
@@ -1578,20 +1578,20 @@ declare 427 {
 	    int flags, Tcl_CommandTraceProc *proc, void *clientData)
 }
 declare 428 {
-    void *Tcl_AttemptAlloc(TCL_HASH_TYPE size)
+    void *Tcl_Alloc(TCL_HASH_TYPE size)
 }
 declare 429 {
-    void *Tcl_AttemptDbCkalloc(TCL_HASH_TYPE size, const char *file, int line)
+    void *Tcl_DbCkalloc(TCL_HASH_TYPE size, const char *file, int line)
 }
 declare 430 {
-    void *Tcl_AttemptRealloc(void *ptr, TCL_HASH_TYPE size)
+    void *Tcl_Realloc(void *ptr, TCL_HASH_TYPE size)
 }
 declare 431 {
-    void *Tcl_AttemptDbCkrealloc(void *ptr, TCL_HASH_TYPE size,
+    void *Tcl_DbCkrealloc(void *ptr, TCL_HASH_TYPE size,
 	    const char *file, int line)
 }
 declare 432 {
-    int Tcl_AttemptSetObjLength(Tcl_Obj *objPtr, Tcl_Size length)
+    char *Tcl_SetObjLength(Tcl_Obj *objPtr, Tcl_Size length)
 }
 
 # TIP#10 (thread-aware channels) akupries

generic/tclCkalloc.c

@@ -23,8 +23,6 @@
 #undef Tcl_Alloc
 #undef Tcl_Free
 #undef Tcl_Realloc
-#undef Tcl_AttemptAlloc
-#undef Tcl_AttemptRealloc
 
 #ifdef TCL_MEM_DEBUG
 
@@ -392,96 +390,6 @@ Tcl_DbCkalloc(
 	Tcl_ValidateAllMemory(file, line);
     }
 
-    /* Don't let size argument to TclpAlloc overflow */
-    if (size <= (size_t)-2 - offsetof(struct mem_header, body) - HIGH_GUARD_SIZE) {
-	result = (struct mem_header *) TclpAlloc(size +
-		offsetof(struct mem_header, body) + 1U + HIGH_GUARD_SIZE);
-    }
-    if (result == NULL) {
-	fflush(stdout);
-	TclDumpMemoryInfo(stderr, 0);
-	Tcl_Panic("unable to alloc %" TCL_Z_MODIFIER "u bytes, %s line %d", size, file, line);
-    }
-
-    /*
-     * Fill in guard zones and size. Also initialize the contents of the block
-     * with bogus bytes to detect uses of initialized data. Link into
-     * allocated list.
-     */
-
-    if (init_malloced_bodies) {
-	memset(result, GUARD_VALUE,
-		offsetof(struct mem_header, body) + 1U + HIGH_GUARD_SIZE + size);
-    } else {
-	memset(result->low_guard, GUARD_VALUE, LOW_GUARD_SIZE);
-	memset(result->body + size, GUARD_VALUE, HIGH_GUARD_SIZE);
-    }
-    if (!ckallocInit) {
-	TclInitDbCkalloc();
-    }
-    Tcl_MutexLock(ckallocMutexPtr);
-    result->length = size;
-    result->tagPtr = curTagPtr;
-    if (curTagPtr != NULL) {
-	curTagPtr->refCount++;
-    }
-    result->file = file;
-    result->line = line;
-    result->flink = allocHead;
-    result->blink = NULL;
-
-    if (allocHead != NULL) {
-	allocHead->blink = result;
-    }
-    allocHead = result;
-
-    total_mallocs++;
-    if (trace_on_at_malloc && (total_mallocs >= trace_on_at_malloc)) {
-	(void) fflush(stdout);
-	fprintf(stderr, "reached malloc trace enable point (%" TCL_Z_MODIFIER "u)\n",
-		total_mallocs);
-	fflush(stderr);
-	alloc_tracing = TRUE;
-	trace_on_at_malloc = 0;
-    }
-
-    if (alloc_tracing) {
-	fprintf(stderr,"Tcl_Alloc %p %" TCL_Z_MODIFIER "u %s %d\n",
-		result->body, size, file, line);
-    }
-
-    if (break_on_malloc && (total_mallocs >= break_on_malloc)) {
-	break_on_malloc = 0;
-	(void) fflush(stdout);
-	Tcl_Panic("reached malloc break limit (%" TCL_Z_MODIFIER "u)", total_mallocs);
-    }
-
-    current_malloc_packets++;
-    if (current_malloc_packets > maximum_malloc_packets) {
-	maximum_malloc_packets = current_malloc_packets;
-    }
-    current_bytes_malloced += size;
-    if (current_bytes_malloced > maximum_bytes_malloced) {
-	maximum_bytes_malloced = current_bytes_malloced;
-    }
-
-    Tcl_MutexUnlock(ckallocMutexPtr);
-
-    return result->body;
-}
-
-void *
-Tcl_AttemptDbCkalloc(
-    size_t size,
-    const char *file,
-    int line)
-{
-    struct mem_header *result = NULL;
-
-    if (validate_memory) {
-	Tcl_ValidateAllMemory(file, line);
-    }
-
     /* Don't let size argument to TclpAlloc overflow */
     if (size <= (size_t)-2 - offsetof(struct mem_header, body) - HIGH_GUARD_SIZE) {
 	result = (struct mem_header *) TclpAlloc(size +
@@ -680,37 +588,6 @@ Tcl_DbCkrealloc(
 	copySize = memp->length;
     }
     newPtr = (char *)Tcl_DbCkalloc(size, file, line);
-    memcpy(newPtr, ptr, copySize);
-    Tcl_DbCkfree(ptr, file, line);
-    return newPtr;
-}
-
-void *
-Tcl_AttemptDbCkrealloc(
-    void *ptr,
-    size_t size,
-    const char *file,
-    int line)
-{
-    char *newPtr;
-    size_t copySize;
-    struct mem_header *memp;
-
-    if (ptr == NULL) {
-	return Tcl_AttemptDbCkalloc(size, file, line);
-    }
-
-    /*
-     * See comment from Tcl_DbCkfree before you change the following line.
-     */
-
-    memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET);
-
-    copySize = size;
-    if (copySize > memp->length) {
-	copySize = memp->length;
-    }
-    newPtr = (char *)Tcl_AttemptDbCkalloc(size, file, line);
     if (newPtr == NULL) {
 	return NULL;
     }
@@ -744,13 +621,6 @@ Tcl_Alloc(
     return Tcl_DbCkalloc(size, "unknown", 0);
 }
 
-void *
-Tcl_AttemptAlloc(
-    size_t size)
-{
-    return Tcl_AttemptDbCkalloc(size, "unknown", 0);
-}
-
 void
 Tcl_Free(
     void *ptr)
@@ -765,13 +635,6 @@ Tcl_Realloc(
 {
     return Tcl_DbCkrealloc(ptr, size, "unknown", 0);
 }
-void *
-Tcl_AttemptRealloc(
-    void *ptr,
-    size_t size)
-{
-    return Tcl_AttemptDbCkrealloc(ptr, size, "unknown", 0);
-}
 
 /*
  *----------------------------------------------------------------------
@@ -1024,8 +887,8 @@ Tcl_InitMemory(
  *
  * Tcl_Alloc --
  *
- *	Interface to TclpAlloc when TCL_MEM_DEBUG is disabled. It does check
- *	that memory was actually allocated.
+ *	Interface to TclpAlloc when TCL_MEM_DEBUG is disabled. It does not
+ *	check that memory was actually allocated.
  *
  *----------------------------------------------------------------------
  */
@@ -1033,61 +896,12 @@ Tcl_InitMemory(
 void *
 Tcl_Alloc(
     size_t size)
-{
-    void *result = TclpAlloc(size);
-
-    /*
-     * Most systems will not alloc(0), instead bumping it to one so that NULL
-     * isn't returned. Some systems (AIX, Tru64) will alloc(0) by returning
-     * NULL, so we have to check that the NULL we get is not in response to
-     * alloc(0).
-     *
-     * The ANSI spec actually says that systems either return NULL *or* a
-     * special pointer on failure, but we only check for NULL
-     */
-
-    if ((result == NULL) && size) {
-	Tcl_Panic("unable to alloc %" TCL_Z_MODIFIER "u bytes", size);
-    }
-    return result;
-}
-
-void *
-Tcl_DbCkalloc(
-    size_t size,
-    const char *file,
-    int line)
-{
-    void *result = TclpAlloc(size);
-
-    if ((result == NULL) && size) {
-	fflush(stdout);
-	Tcl_Panic("unable to alloc %" TCL_Z_MODIFIER "u bytes, %s line %d",
-		size, file, line);
-    }
-    return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_AttemptAlloc --
- *
- *	Interface to TclpAlloc when TCL_MEM_DEBUG is disabled. It does not
- *	check that memory was actually allocated.
- *
- *----------------------------------------------------------------------
- */
-
-void *
-Tcl_AttemptAlloc(
-    size_t size)
 {
     return (char *)TclpAlloc(size);
 }
 
 void *
-Tcl_AttemptDbCkalloc(
+Tcl_DbCkalloc(
     size_t size,
     TCL_UNUSED(const char *) /*file*/,
     TCL_UNUSED(int) /*line*/)
@@ -1100,8 +914,8 @@ Tcl_AttemptDbCkalloc(
  *
  * Tcl_Realloc --
  *
- *	Interface to TclpRealloc when TCL_MEM_DEBUG is disabled. It does check
- *	that memory was actually allocated.
+ *	Interface to TclpRealloc when TCL_MEM_DEBUG is disabled. It does not
+ *	check that memory was actually allocated.
  *
  *----------------------------------------------------------------------
  */
@@ -1110,53 +924,12 @@ void *
 Tcl_Realloc(
     void *ptr,
     size_t size)
-{
-    void *result = TclpRealloc(ptr, size);
-
-    if ((result == NULL) && size) {
-	Tcl_Panic("unable to realloc %" TCL_Z_MODIFIER "u bytes", size);
-    }
-    return result;
-}
-
-void *
-Tcl_DbCkrealloc(
-    void *ptr,
-    size_t size,
-    const char *file,
-    int line)
-{
-    void *result = TclpRealloc(ptr, size);
-
-    if ((result == NULL) && size) {
-	fflush(stdout);
-	Tcl_Panic("unable to realloc %" TCL_Z_MODIFIER "u bytes, %s line %d",
-		size, file, line);
-    }
-    return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_AttemptRealloc --
- *
- *	Interface to TclpRealloc when TCL_MEM_DEBUG is disabled. It does not
- *	check that memory was actually allocated.
- *
- *----------------------------------------------------------------------
- */
-
-void *
-Tcl_AttemptRealloc(
-    void *ptr,
-    size_t size)
 {
     return (char *)TclpRealloc(ptr, size);
 }
 
 void *
-Tcl_AttemptDbCkrealloc(
+Tcl_DbCkrealloc(
     void *ptr,
     size_t size,
     TCL_UNUSED(const char *) /*file*/,

generic/tclDecls.h

@@ -61,18 +61,18 @@ EXTERN const char *	Tcl_PkgRequireEx(Tcl_Interp *interp,
 /* 2 */
 EXTERN TCL_NORETURN void Tcl_Panic(const char *format, ...) TCL_FORMAT_PRINTF(1, 2);
 /* 3 */
-EXTERN void *		Tcl_Alloc(TCL_HASH_TYPE size);
+EXTERN void *		Tcl_Alloc_(TCL_HASH_TYPE size);
 /* 4 */
 EXTERN void		Tcl_Free(void *ptr);
 /* 5 */
-EXTERN void *		Tcl_Realloc(void *ptr, TCL_HASH_TYPE size);
+EXTERN void *		Tcl_Realloc_(void *ptr, TCL_HASH_TYPE size);
 /* 6 */
-EXTERN void *		Tcl_DbCkalloc(TCL_HASH_TYPE size, const char *file,
+EXTERN void *		Tcl_DbCkalloc_(TCL_HASH_TYPE size, const char *file,
 				int line);
 /* 7 */
 EXTERN void		Tcl_DbCkfree(void *ptr, const char *file, int line);
 /* 8 */
-EXTERN void *		Tcl_DbCkrealloc(void *ptr, TCL_HASH_TYPE size,
+EXTERN void *		Tcl_DbCkrealloc_(void *ptr, TCL_HASH_TYPE size,
 				const char *file, int line);
 /* 9 */
 EXTERN void		Tcl_CreateFileHandler(int fd, int mask,
@@ -211,7 +211,7 @@ EXTERN void		Tcl_SetListObj(Tcl_Obj *objPtr, Tcl_Size objc,
 				Tcl_Obj *const objv[]);
 /* Slot 63 is reserved */
 /* 64 */
-EXTERN void		Tcl_SetObjLength(Tcl_Obj *objPtr, Tcl_Size length);
+EXTERN char *		Tcl_SetObjLength_(Tcl_Obj *objPtr, Tcl_Size length);
 /* 65 */
 EXTERN void		Tcl_SetStringObj(Tcl_Obj *objPtr, const char *bytes,
 				Tcl_Size length);
@@ -999,7 +999,7 @@ EXTERN void		Tcl_RegExpGetInfo(Tcl_RegExp regexp,
 EXTERN Tcl_Obj *	Tcl_NewUnicodeObj(const Tcl_UniChar *unicode,
 				Tcl_Size numChars);
 /* 379 */
-EXTERN void		Tcl_SetUnicodeObj(Tcl_Obj *objPtr,
+EXTERN Tcl_UniChar *	Tcl_SetUnicodeObj(Tcl_Obj *objPtr,
 				const Tcl_UniChar *unicode,
 				Tcl_Size numChars);
 /* 380 */
@@ -1011,7 +1011,7 @@ EXTERN int		TclGetUniChar(Tcl_Obj *objPtr, Tcl_Size index);
 EXTERN Tcl_Obj *	TclGetRange(Tcl_Obj *objPtr, Tcl_Size first,
 				Tcl_Size last);
 /* 384 */
-EXTERN void		Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr,
+EXTERN Tcl_UniChar *	Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr,
 				const Tcl_UniChar *unicode, Tcl_Size length);
 /* 385 */
 EXTERN int		Tcl_RegExpMatchObj(Tcl_Interp *interp,
@@ -1122,18 +1122,17 @@ EXTERN void		Tcl_UntraceCommand(Tcl_Interp *interp,
 				const char *varName, int flags,
 				Tcl_CommandTraceProc *proc, void *clientData);
 /* 428 */
-EXTERN void *		Tcl_AttemptAlloc(TCL_HASH_TYPE size);
+EXTERN void *		Tcl_Alloc(TCL_HASH_TYPE size);
 /* 429 */
-EXTERN void *		Tcl_AttemptDbCkalloc(TCL_HASH_TYPE size,
-				const char *file, int line);
+EXTERN void *		Tcl_DbCkalloc(TCL_HASH_TYPE size, const char *file,
+				int line);
 /* 430 */
-EXTERN void *		Tcl_AttemptRealloc(void *ptr, TCL_HASH_TYPE size);
+EXTERN void *		Tcl_Realloc(void *ptr, TCL_HASH_TYPE size);
 /* 431 */
-EXTERN void *		Tcl_AttemptDbCkrealloc(void *ptr, TCL_HASH_TYPE size,
+EXTERN void *		Tcl_DbCkrealloc(void *ptr, TCL_HASH_TYPE size,
 				const char *file, int line);
 /* 432 */
-EXTERN int		Tcl_AttemptSetObjLength(Tcl_Obj *objPtr,
-				Tcl_Size length);
+EXTERN char *		Tcl_SetObjLength(Tcl_Obj *objPtr, Tcl_Size length);
 /* 433 */
 EXTERN Tcl_ThreadId	Tcl_GetChannelThread(Tcl_Channel channel);
 /* 434 */
@@ -1882,12 +1881,12 @@ typedef struct TclStubs {
     int (*tcl_PkgProvideEx) (Tcl_Interp *interp, const char *name, const char *version, const void *clientData); /* 0 */
     const char * (*tcl_PkgRequireEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 1 */
     TCL_NORETURN1 void (*tcl_Panic) (const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 2 */
-    void * (*tcl_Alloc) (TCL_HASH_TYPE size); /* 3 */
+    void * (*tcl_Alloc_) (TCL_HASH_TYPE size); /* 3 */
     void (*tcl_Free) (void *ptr); /* 4 */
-    void * (*tcl_Realloc) (void *ptr, TCL_HASH_TYPE size); /* 5 */
-    void * (*tcl_DbCkalloc) (TCL_HASH_TYPE size, const char *file, int line); /* 6 */
+    void * (*tcl_Realloc_) (void *ptr, TCL_HASH_TYPE size); /* 5 */
+    void * (*tcl_DbCkalloc_) (TCL_HASH_TYPE size, const char *file, int line); /* 6 */
     void (*tcl_DbCkfree) (void *ptr, const char *file, int line); /* 7 */
-    void * (*tcl_DbCkrealloc) (void *ptr, TCL_HASH_TYPE size, const char *file, int line); /* 8 */
+    void * (*tcl_DbCkrealloc_) (void *ptr, TCL_HASH_TYPE size, const char *file, int line); /* 8 */
     void (*tcl_CreateFileHandler) (int fd, int mask, Tcl_FileProc *proc, void *clientData); /* 9 */
     void (*tcl_DeleteFileHandler) (int fd); /* 10 */
     void (*tcl_SetTimer) (const Tcl_Time *timePtr); /* 11 */
@@ -1943,7 +1942,7 @@ typedef struct TclStubs {
     void (*reserved61)(void);
     void (*tcl_SetListObj) (Tcl_Obj *objPtr, Tcl_Size objc, Tcl_Obj *const objv[]); /* 62 */
     void (*reserved63)(void);
-    void (*tcl_SetObjLength) (Tcl_Obj *objPtr, Tcl_Size length); /* 64 */
+    char * (*tcl_SetObjLength_) (Tcl_Obj *objPtr, Tcl_Size length); /* 64 */
     void (*tcl_SetStringObj) (Tcl_Obj *objPtr, const char *bytes, Tcl_Size length); /* 65 */
     void (*reserved66)(void);
     void (*reserved67)(void);
@@ -2258,12 +2257,12 @@ typedef struct TclStubs {
     int (*tcl_RegExpExecObj) (Tcl_Interp *interp, Tcl_RegExp regexp, Tcl_Obj *textObj, Tcl_Size offset, Tcl_Size nmatches, int flags); /* 376 */
     void (*tcl_RegExpGetInfo) (Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr); /* 377 */
     Tcl_Obj * (*tcl_NewUnicodeObj) (const Tcl_UniChar *unicode, Tcl_Size numChars); /* 378 */
-    void (*tcl_SetUnicodeObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, Tcl_Size numChars); /* 379 */
+    Tcl_UniChar * (*tcl_SetUnicodeObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, Tcl_Size numChars); /* 379 */
     Tcl_Size (*tclGetCharLength) (Tcl_Obj *objPtr); /* 380 */
     int (*tclGetUniChar) (Tcl_Obj *objPtr, Tcl_Size index); /* 381 */
     void (*reserved382)(void);
     Tcl_Obj * (*tclGetRange) (Tcl_Obj *objPtr, Tcl_Size first, Tcl_Size last); /* 383 */
-    void (*tcl_AppendUnicodeToObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, Tcl_Size length); /* 384 */
+    Tcl_UniChar * (*tcl_AppendUnicodeToObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, Tcl_Size length); /* 384 */
     int (*tcl_RegExpMatchObj) (Tcl_Interp *interp, Tcl_Obj *textObj, Tcl_Obj *patternObj); /* 385 */
     void (*tcl_SetNotifier) (const Tcl_NotifierProcs *notifierProcPtr); /* 386 */
     Tcl_Mutex * (*tcl_GetAllocMutex) (void); /* 387 */
@@ -2307,11 +2306,11 @@ typedef struct TclStubs {
     void * (*tcl_CommandTraceInfo) (Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *procPtr, void *prevClientData); /* 425 */
     int (*tcl_TraceCommand) (Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *proc, void *clientData); /* 426 */
     void (*tcl_UntraceCommand) (Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *proc, void *clientData); /* 427 */
-    void * (*tcl_AttemptAlloc) (TCL_HASH_TYPE size); /* 428 */
-    void * (*tcl_AttemptDbCkalloc) (TCL_HASH_TYPE size, const char *file, int line); /* 429 */
-    void * (*tcl_AttemptRealloc) (void *ptr, TCL_HASH_TYPE size); /* 430 */
-    void * (*tcl_AttemptDbCkrealloc) (void *ptr, TCL_HASH_TYPE size, const char *file, int line); /* 431 */
-    int (*tcl_AttemptSetObjLength) (Tcl_Obj *objPtr, Tcl_Size length); /* 432 */
+    void * (*tcl_Alloc) (TCL_HASH_TYPE size); /* 428 */
+    void * (*tcl_DbCkalloc) (TCL_HASH_TYPE size, const char *file, int line); /* 429 */
+    void * (*tcl_Realloc) (void *ptr, TCL_HASH_TYPE size); /* 430 */
+    void * (*tcl_DbCkrealloc) (void *ptr, TCL_HASH_TYPE size, const char *file, int line); /* 431 */
+    char * (*tcl_SetObjLength) (Tcl_Obj *objPtr, Tcl_Size length); /* 432 */
     Tcl_ThreadId (*tcl_GetChannelThread) (Tcl_Channel channel); /* 433 */
     Tcl_UniChar * (*tclGetUnicodeFromObj) (Tcl_Obj *objPtr, void *lengthPtr); /* 434 */
     void (*reserved435)(void);
@@ -2588,18 +2587,18 @@ extern const TclStubs *tclStubsPtr;
 	(tclStubsPtr->tcl_PkgRequireEx) /* 1 */
 #define Tcl_Panic \
 	(tclStubsPtr->tcl_Panic) /* 2 */
-#define Tcl_Alloc \
-	(tclStubsPtr->tcl_Alloc) /* 3 */
+#define Tcl_Alloc_ \
+	(tclStubsPtr->tcl_Alloc_) /* 3 */
 #define Tcl_Free \
 	(tclStubsPtr->tcl_Free) /* 4 */
-#define Tcl_Realloc \
-	(tclStubsPtr->tcl_Realloc) /* 5 */
-#define Tcl_DbCkalloc \
-	(tclStubsPtr->tcl_DbCkalloc) /* 6 */
+#define Tcl_Realloc_ \
+	(tclStubsPtr->tcl_Realloc_) /* 5 */
+#define Tcl_DbCkalloc_ \
+	(tclStubsPtr->tcl_DbCkalloc_) /* 6 */
 #define Tcl_DbCkfree \
 	(tclStubsPtr->tcl_DbCkfree) /* 7 */
-#define Tcl_DbCkrealloc \
-	(tclStubsPtr->tcl_DbCkrealloc) /* 8 */
+#define Tcl_DbCkrealloc_ \
+	(tclStubsPtr->tcl_DbCkrealloc_) /* 8 */
 #define Tcl_CreateFileHandler \
 	(tclStubsPtr->tcl_CreateFileHandler) /* 9 */
 #define Tcl_DeleteFileHandler \
@@ -2701,8 +2700,8 @@ extern const TclStubs *tclStubsPtr;
 #define Tcl_SetListObj \
 	(tclStubsPtr->tcl_SetListObj) /* 62 */
 /* Slot 63 is reserved */
-#define Tcl_SetObjLength \
-	(tclStubsPtr->tcl_SetObjLength) /* 64 */
+#define Tcl_SetObjLength_ \
+	(tclStubsPtr->tcl_SetObjLength_) /* 64 */
 #define Tcl_SetStringObj \
 	(tclStubsPtr->tcl_SetStringObj) /* 65 */
 /* Slot 66 is reserved */
@@ -3379,16 +3378,16 @@ extern const TclStubs *tclStubsPtr;
 	(tclStubsPtr->tcl_TraceCommand) /* 426 */
 #define Tcl_UntraceCommand \
 	(tclStubsPtr->tcl_UntraceCommand) /* 427 */
-#define Tcl_AttemptAlloc \
-	(tclStubsPtr->tcl_AttemptAlloc) /* 428 */
-#define Tcl_AttemptDbCkalloc \
-	(tclStubsPtr->tcl_AttemptDbCkalloc) /* 429 */
-#define Tcl_AttemptRealloc \
-	(tclStubsPtr->tcl_AttemptRealloc) /* 430 */
-#define Tcl_AttemptDbCkrealloc \
-	(tclStubsPtr->tcl_AttemptDbCkrealloc) /* 431 */
-#define Tcl_AttemptSetObjLength \
-	(tclStubsPtr->tcl_AttemptSetObjLength) /* 432 */
+#define Tcl_Alloc \
+	(tclStubsPtr->tcl_Alloc) /* 428 */
+#define Tcl_DbCkalloc \
+	(tclStubsPtr->tcl_DbCkalloc) /* 429 */
+#define Tcl_Realloc \
+	(tclStubsPtr->tcl_Realloc) /* 430 */
+#define Tcl_DbCkrealloc \
+	(tclStubsPtr->tcl_DbCkrealloc) /* 431 */
+#define Tcl_SetObjLength \
+	(tclStubsPtr->tcl_SetObjLength) /* 432 */
 #define Tcl_GetChannelThread \
 	(tclStubsPtr->tcl_GetChannelThread) /* 433 */
 #define TclGetUnicodeFromObj \
@@ -4100,6 +4099,10 @@ extern const TclStubs *tclStubsPtr;
 		(Tcl_GetUnicodeFromObj)(objPtr, (Tcl_Size *)(void *)(sizePtr)))
 #endif
 
+#define Tcl_AttemptAlloc Tcl_Alloc
+#define Tcl_AttemptRealloc Tcl_Realloc
+#define Tcl_AttemptSetObjLength Tcl_SetObjLength
+
 #ifdef TCL_MEM_DEBUG
 #   undef Tcl_Alloc
 #   define Tcl_Alloc(x) \
@@ -4110,12 +4113,6 @@ extern const TclStubs *tclStubsPtr;
 #   undef Tcl_Realloc
 #   define Tcl_Realloc(x,y) \
     (Tcl_DbCkrealloc((x), (y), __FILE__, __LINE__))
-#   undef Tcl_AttemptAlloc
-#   define Tcl_AttemptAlloc(x) \
-    (Tcl_AttemptDbCkalloc((x), __FILE__, __LINE__))
-#   undef Tcl_AttemptRealloc
-#   define Tcl_AttemptRealloc(x,y) \
-    (Tcl_AttemptDbCkrealloc((x), (y), __FILE__, __LINE__))
 #endif /* !TCL_MEM_DEBUG */
 
 #define Tcl_NewLongObj(value) Tcl_NewWideIntObj((long)(value))

generic/tclInt.h

@@ -5180,8 +5180,8 @@ typedef struct NRE_callback {
 #include "tclIntPlatDecls.h"
 
 #if !defined(USE_TCL_STUBS) && !defined(TCL_MEM_DEBUG)
-#define Tcl_AttemptAlloc        TclpAlloc
-#define Tcl_AttemptRealloc      TclpRealloc
+#define Tcl_Alloc               TclpAlloc
+#define Tcl_Realloc             TclpRealloc
 #define Tcl_Free                TclpFree
 #endif
 

generic/tclStringObj.c

@@ -62,7 +62,7 @@ static void		FreeStringInternalRep(Tcl_Obj *objPtr);
 static void		GrowStringBuffer(Tcl_Obj *objPtr, size_t needed, int flag);
 static void		GrowUnicodeBuffer(Tcl_Obj *objPtr, size_t needed);
 static int		SetStringFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
-static void		SetUnicodeObj(Tcl_Obj *objPtr,
+static Tcl_UniChar *SetUnicodeObj(Tcl_Obj *objPtr,
 			    const Tcl_UniChar *unicode, Tcl_Size numChars);
 static Tcl_Size		UnicodeLength(const Tcl_UniChar *unicode);
 static void		UpdateStringOfString(Tcl_Obj *objPtr);
@@ -376,7 +376,10 @@ Tcl_NewUnicodeObj(
     Tcl_Obj *objPtr;
 
     TclNewObj(objPtr);
-    SetUnicodeObj(objPtr, unicode, numChars);
+    if (!SetUnicodeObj(objPtr, unicode, numChars)) {
+	Tcl_DecrRefCount(objPtr);
+	return NULL;
+    }
     return objPtr;
 }
 
@@ -950,105 +953,11 @@ Tcl_SetStringObj(
  *
  * Tcl_SetObjLength --
  *
- *	Changes the length of the string representation of objPtr.
- *
- * Results:
- *	None.
- *
- * Side effects:
- *	If the size of objPtr's string representation is greater than length, a
- *	new terminating null byte is stored in objPtr->bytes at length, and
- *	bytes at positions past length have no meaning.  If the length of the
- *	string representation is greater than length, the storage space is
- *	reallocated to length+1.
- *
- *	The object's internal representation is changed to &tclStringType.
- *
- *----------------------------------------------------------------------
- */
-
-void
-Tcl_SetObjLength(
-    Tcl_Obj *objPtr,		/* Pointer to object. This object must not
-				 * currently be shared. */
-    Tcl_Size length)		/* Number of bytes desired for string
-				 * representation of object, not including
-				 * terminating null byte. */
-{
-    String *stringPtr;
-
-    if (length < 0) {
-	Tcl_Panic("Tcl_SetObjLength: length requested is negative: "
-		"%" TCL_SIZE_MODIFIER "d (integer overflow?)", length);
-    }
-    if (Tcl_IsShared(objPtr)) {
-	Tcl_Panic("%s called with shared object", "Tcl_SetObjLength");
-    }
-
-    if (objPtr->bytes && objPtr->length == length) {
-	return;
-    }
-
-    SetStringFromAny(NULL, objPtr);
-    stringPtr = GET_STRING(objPtr);
-
-    if (objPtr->bytes != NULL) {
-	/*
-	 * Change length of an existing string rep.
-	 */
-	if (length > stringPtr->allocated) {
-	    /*
-	     * Need to enlarge the buffer.
-	     */
-	    if (objPtr->bytes == &tclEmptyString) {
-		objPtr->bytes = (char *)Tcl_Alloc(length + 1);
-	    } else {
-		objPtr->bytes = (char *)Tcl_Realloc(objPtr->bytes, length + 1);
-	    }
-	    stringPtr->allocated = length;
-	}
-
-	objPtr->length = length;
-	objPtr->bytes[length] = 0;
-
-	/*
-	 * Invalidate the Unicode data.
-	 */
-
-	stringPtr->numChars = TCL_INDEX_NONE;
-	stringPtr->hasUnicode = 0;
-    } else {
-	if (length > stringPtr->maxChars) {
-	    stringPtr = stringRealloc(stringPtr, length);
-	    SET_STRING(objPtr, stringPtr);
-	    stringPtr->maxChars = length;
-	}
-
-	/*
-	 * Mark the new end of the Unicode string
-	 */
-
-	stringPtr->numChars = length;
-	stringPtr->unicode[length] = 0;
-	stringPtr->hasUnicode = 1;
-
-	/*
-	 * Can only get here when objPtr->bytes == NULL. No need to invalidate
-	 * the string rep.
-	 */
-    }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_AttemptSetObjLength --
- *
  *	This function changes the length of the string representation of an
- *	object. It uses the attempt* (non-panic'ing) memory allocators.
+ *	object.
  *
  * Results:
- *	1 if the requested memory was allocated, 0 otherwise.
+ *	!= NULL if the requested memory was allocated, NULL otherwise.
  *
  * Side effects:
  *	If the size of objPtr's string representation is greater than length,
@@ -1062,8 +971,8 @@ Tcl_SetObjLength(
  *----------------------------------------------------------------------
  */
 
-int
-Tcl_AttemptSetObjLength(
+char *
+Tcl_SetObjLength(
     Tcl_Obj *objPtr,		/* Pointer to object. This object must not
 				 * currently be shared. */
     Tcl_Size length)		/* Number of bytes desired for string
@@ -1074,14 +983,14 @@ Tcl_AttemptSetObjLength(
 
     if (length < 0) {
 	/* Negative lengths => most likely integer overflow */
-	return 0;
+	return NULL;
     }
 
     if (Tcl_IsShared(objPtr)) {
 	Tcl_Panic("%s called with shared object", "Tcl_AttemptSetObjLength");
     }
     if (objPtr->bytes && objPtr->length == length) {
-	return 1;
+	return objPtr->bytes;
     }
 
     SetStringFromAny(NULL, objPtr);
@@ -1104,7 +1013,7 @@ Tcl_AttemptSetObjLength(
 		newBytes = (char *)Tcl_AttemptRealloc(objPtr->bytes, length + 1);
 	    }
 	    if (newBytes == NULL) {
-		return 0;
+		return NULL;
 	    }
 	    objPtr->bytes = newBytes;
 	    stringPtr->allocated = length;
@@ -1146,7 +1055,7 @@ Tcl_AttemptSetObjLength(
 	 * the string rep.
 	 */
     }
-    return 1;
+    return (char *)INT2PTR(-1);
 }
 
 /*
@@ -1165,7 +1074,7 @@ Tcl_AttemptSetObjLength(
  *---------------------------------------------------------------------------
  */
 
-void
+Tcl_UniChar *
 Tcl_SetUnicodeObj(
     Tcl_Obj *objPtr,		/* The object to set the string of. */
     const Tcl_UniChar *unicode,	/* The Unicode string used to initialize the
@@ -1177,7 +1086,7 @@ Tcl_SetUnicodeObj(
 	Tcl_Panic("%s called with shared object", "Tcl_SetUnicodeObj");
     }
     TclFreeInternalRep(objPtr);
-    SetUnicodeObj(objPtr, unicode, numChars);
+    return SetUnicodeObj(objPtr, unicode, numChars);
 }
 
 static Tcl_Size
@@ -1195,7 +1104,7 @@ UnicodeLength(
     return numChars;
 }
 
-static void
+static Tcl_UniChar *
 SetUnicodeObj(
     Tcl_Obj *objPtr,		/* The object to set the string of. */
     const Tcl_UniChar *unicode,	/* The Unicode string used to initialize the
@@ -1214,6 +1123,9 @@ SetUnicodeObj(
      */
 
     stringPtr = stringAlloc(numChars);
+    if (!stringPtr) {
+	return NULL;
+    }
     SET_STRING(objPtr, stringPtr);
     objPtr->typePtr = &tclStringType;
 
@@ -1225,6 +1137,7 @@ SetUnicodeObj(
 
     TclInvalidateStringRep(objPtr);
     stringPtr->allocated = 0;
+    return stringPtr->unicode;
 }
 
 /*
@@ -1370,7 +1283,7 @@ Tcl_AppendToObj(
  *----------------------------------------------------------------------
  */
 
-void
+Tcl_UniChar *
 Tcl_AppendUnicodeToObj(
     Tcl_Obj *objPtr,		/* Points to the object to append to. */
     const Tcl_UniChar *unicode,	/* The Unicode string to append to the
@@ -1385,7 +1298,7 @@ Tcl_AppendUnicodeToObj(
     }
 
     if (length == 0) {
-	return;
+	return NULL;
     }
 
     SetStringFromAny(NULL, objPtr);
@@ -1399,8 +1312,10 @@ Tcl_AppendUnicodeToObj(
 
     if (stringPtr->hasUnicode) {
 	AppendUnicodeToUnicodeRep(objPtr, unicode, length);
+	return stringPtr->unicode;
     } else {
 	AppendUnicodeToUtfRep(objPtr, unicode, length);
+	return (Tcl_UniChar *)INT2PTR(-1);
     }
 }
 
@@ -4370,7 +4285,8 @@ DupStringInternalRep(
  *	Create an internal representation of type "String" for an object.
  *
  * Results:
- *	This operation always succeeds and returns TCL_OK.
+ *	This operation always succeeds and returns TCL_OK, except when
+ *	not enough memory can be allocated.
  *
  * Side effects:
  *	Any old internal representation for objPtr is freed and the internal
@@ -4381,17 +4297,23 @@ DupStringInternalRep(
 
 static int
 SetStringFromAny(
-    TCL_UNUSED(Tcl_Interp *),
+    Tcl_Interp *interp,
     Tcl_Obj *objPtr)		/* The object to convert. */
 {
     if (!TclHasInternalRep(objPtr, &tclStringType)) {
-	String *stringPtr = stringAlloc(0);
 
 	/*
 	 * Convert whatever we have into an untyped value. Just A String.
 	 */
 
-	(void) TclGetString(objPtr);
+	if (TclGetString(objPtr) == NULL) {
+	    if (interp != NULL) {
+		Tcl_AppendResult( interp,
+		    "Cannot allocate string", -1);
+		Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
+	    }
+	    return TCL_ERROR;
+	}
 	TclFreeInternalRep(objPtr);
 
 	/*
@@ -4399,6 +4321,7 @@ SetStringFromAny(
 	 * already in place at objPtr->bytes.
 	 */
 
+	String *stringPtr = stringAlloc(0);
 	stringPtr->numChars = -1;
 	stringPtr->allocated = objPtr->length;
 	stringPtr->maxChars = 0;

generic/tclStubInit.c

@@ -105,7 +105,7 @@ static void uniCodePanic() {
 #   define Tcl_GetUnicodeFromObj (Tcl_UniChar *(*)(Tcl_Obj *, Tcl_Size *))(void *)uniCodePanic
 #   define TclGetUnicodeFromObj (Tcl_UniChar *(*)(Tcl_Obj *, int *))(void *)uniCodePanic
 #   define Tcl_NewUnicodeObj (Tcl_Obj *(*)(const Tcl_UniChar *, Tcl_Size))(void *)uniCodePanic
-#   define Tcl_SetUnicodeObj (void(*)(Tcl_Obj *, const Tcl_UniChar *, Tcl_Size))(void *)uniCodePanic
+#   define Tcl_SetUnicodeObj (Tcl_UniChar *(*)(Tcl_Obj *, const Tcl_UniChar *, Tcl_Size))(void *)uniCodePanic
 #   define Tcl_AppendUnicodeToObj (void(*)(Tcl_Obj *, const Tcl_UniChar *, Tcl_Size))(void *)uniCodePanic
 #endif
 
@@ -113,6 +113,19 @@ static void uniCodePanic() {
 #define TclUtfNext Tcl_UtfNext
 #define TclUtfPrev Tcl_UtfPrev
 
+/* Those entries can be removed before Tcl 9.0 final.
+ * It's not done now, because _ALL_ extensions then
+ * need to be re-compiled, they will break otherwise.
+ * Suggestions: remove those just after the 9.0b1
+ * official release, many people will re-compile
+ * their extensions then anyway.
+ */
+#define Tcl_Alloc_ Tcl_Alloc
+#define Tcl_Realloc_ Tcl_Realloc
+#define Tcl_DbCkalloc_ Tcl_DbCkalloc
+#define Tcl_DbCkrealloc_ Tcl_DbCkrealloc
+#define Tcl_SetObjLength_ Tcl_SetObjLength
+
 #if defined(TCL_NO_DEPRECATED)
 # define TclListObjGetElements 0
 # define TclListObjLength 0
@@ -829,12 +842,12 @@ const TclStubs tclStubs = {
     Tcl_PkgProvideEx, /* 0 */
     Tcl_PkgRequireEx, /* 1 */
     Tcl_Panic, /* 2 */
-    Tcl_Alloc, /* 3 */
+    Tcl_Alloc_, /* 3 */
     Tcl_Free, /* 4 */
-    Tcl_Realloc, /* 5 */
-    Tcl_DbCkalloc, /* 6 */
+    Tcl_Realloc_, /* 5 */
+    Tcl_DbCkalloc_, /* 6 */
     Tcl_DbCkfree, /* 7 */
-    Tcl_DbCkrealloc, /* 8 */
+    Tcl_DbCkrealloc_, /* 8 */
     Tcl_CreateFileHandler, /* 9 */
     Tcl_DeleteFileHandler, /* 10 */
     Tcl_SetTimer, /* 11 */
@@ -890,7 +903,7 @@ const TclStubs tclStubs = {
     0, /* 61 */
     Tcl_SetListObj, /* 62 */
     0, /* 63 */
-    Tcl_SetObjLength, /* 64 */
+    Tcl_SetObjLength_, /* 64 */
     Tcl_SetStringObj, /* 65 */
     0, /* 66 */
     0, /* 67 */
@@ -1254,11 +1267,11 @@ const TclStubs tclStubs = {
     Tcl_CommandTraceInfo, /* 425 */
     Tcl_TraceCommand, /* 426 */
     Tcl_UntraceCommand, /* 427 */
-    Tcl_AttemptAlloc, /* 428 */
-    Tcl_AttemptDbCkalloc, /* 429 */
-    Tcl_AttemptRealloc, /* 430 */
-    Tcl_AttemptDbCkrealloc, /* 431 */
-    Tcl_AttemptSetObjLength, /* 432 */
+    Tcl_Alloc, /* 428 */
+    Tcl_DbCkalloc, /* 429 */
+    Tcl_Realloc, /* 430 */
+    Tcl_DbCkrealloc, /* 431 */
+    Tcl_SetObjLength, /* 432 */
     Tcl_GetChannelThread, /* 433 */
     TclGetUnicodeFromObj, /* 434 */
     0, /* 435 */