From ec332750d28a86537a3fc721decc3bb74d850dc9 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 27 Oct 2016 19:39:49 +0000 Subject: Start bringing all `string cat` operations into one place so it can be coded correctly one time instead of badly multiple times. --- generic/tclCmdMZ.c | 17 ++++++++--------- generic/tclInt.h | 2 ++ generic/tclStringObj.c | 40 ++++++++++++++++++++++++++++++++++++++++ 3 files changed, 50 insertions(+), 9 deletions(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 591e31c..1a08674 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -2855,7 +2855,7 @@ StringCatCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int i; + int code; Tcl_Obj *objResultPtr; if (objc < 2) { @@ -2872,16 +2872,15 @@ StringCatCmd( Tcl_SetObjResult(interp, objv[1]); return TCL_OK; } - objResultPtr = objv[1]; - if (Tcl_IsShared(objResultPtr)) { - objResultPtr = Tcl_DuplicateObj(objResultPtr); - } - for(i = 2;i < objc;i++) { - Tcl_AppendObjToObj(objResultPtr, objv[i]); + + code = TclStringCatObjv(interp, objc-1, objv+1, &objResultPtr); + + if (code == TCL_OK) { + Tcl_SetObjResult(interp, objResultPtr); + return TCL_OK; } - Tcl_SetObjResult(interp, objResultPtr); - return TCL_OK; + return code; } /* diff --git a/generic/tclInt.h b/generic/tclInt.h index da1b5c5..36c1a81 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3135,6 +3135,8 @@ MODULE_SCOPE void TclSpellFix(Tcl_Interp *interp, Tcl_Obj *bad, Tcl_Obj *fix); MODULE_SCOPE void * TclStackRealloc(Tcl_Interp *interp, void *ptr, int numBytes); +MODULE_SCOPE int TclStringCatObjv(Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[], Tcl_Obj **objPtrPtr); MODULE_SCOPE int TclStringMatch(const char *str, int strLen, const char *pattern, int ptnLen, int flags); MODULE_SCOPE int TclStringMatchObj(Tcl_Obj *stringObj, diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 2930fa1..1828d20 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -2598,6 +2598,46 @@ TclGetStringStorage( *sizePtr = stringPtr->allocated; return objPtr->bytes; } + +/* + *--------------------------------------------------------------------------- + * + * TclStringCatObjv -- + * + * Performs the [string cat] function. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Writes to *objPtrPtr the address of Tcl_Obj that is concatenation + * of all objc values in objv. + * + *--------------------------------------------------------------------------- + */ + +int +TclStringCatObjv( + Tcl_Interp *interp, + int objc, + Tcl_Obj * const objv[], + Tcl_Obj **objPtrPtr) +{ + Tcl_Obj *objResultPtr; + + /* assert (objc >= 2) */ + + objResultPtr = *objv++; objc--; + if (Tcl_IsShared(objResultPtr)) { + objResultPtr = Tcl_DuplicateObj(objResultPtr); + } + while (objc--) { + Tcl_AppendObjToObj(objResultPtr, *objv++); + } + *objPtrPtr = objResultPtr; + return TCL_OK; +} + /* *--------------------------------------------------------------------------- * -- cgit v0.12 From 6beda912ab0f8bd8784d7b1a973d3897c89b75c0 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 27 Oct 2016 20:06:36 +0000 Subject: Convert INST_STR_CONCAT1 to the common `string cat` implementation. --- generic/tclExecute.c | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index b19754e..fcf5ba9 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2692,6 +2692,13 @@ TEBCresume( opnd = TclGetUInt1AtPtr(pc+1); +#if 1 + if (TCL_OK != TclStringCatObjv(interp, opnd, &OBJ_AT_DEPTH(opnd-1), + &objResultPtr)) { + TRACE_ERROR(interp); + goto gotError; + } +#else /* * Detect only-bytearray-or-null case. */ @@ -2828,6 +2835,7 @@ TEBCresume( } } } +#endif TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); NEXT_INST_V(2, opnd, 1); -- cgit v0.12 From 4968966c028c3577f5ef3e604cf1e98b7c37d824 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 28 Oct 2016 14:06:15 +0000 Subject: Add obvious optimization to Tcl_GetCharLength(). --- generic/tclStringObj.c | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 2930fa1..e878167 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -409,6 +409,15 @@ Tcl_GetCharLength( int numChars; /* + * Quick, no-shimmer return for short string reps. + */ + + if ((objPtr->bytes) && (objPtr->length < 2)) { + /* 0 bytes -> 0 chars; 1 byte -> 1 char */ + return objPtr->length; + } + + /* * Optimize the case where we're really dealing with a bytearray object * without string representation; we don't need to convert to a string to * perform the get-length operation. -- cgit v0.12 From e0d5715972ba45f8d23f0349033503b2195b1664 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 28 Oct 2016 14:23:25 +0000 Subject: Add warning commentary making important assumptions explicit. --- generic/tclCmdIL.c | 8 ++++++++ generic/tclStringObj.c | 2 ++ 2 files changed, 10 insertions(+) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 02e5812..b303bb6 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -2025,6 +2025,14 @@ Tcl_JoinObjCmd( resObjPtr = Tcl_NewObj(); for (i = 0; i < listLen; i++) { if (i > 0) { + + /* + * NOTE: This code is relying on Tcl_AppendObjToObj() **NOT** + * to shimmer joinObjPtr. If it did, then the case where + * objv[1] and objv[2] are the same value would not be safe. + * Accessing elemPtrs would crash. + */ + Tcl_AppendObjToObj(resObjPtr, joinObjPtr); } Tcl_AppendObjToObj(resObjPtr, elemPtrs[i]); diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 86f0c62..67e86c5 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -1261,6 +1261,8 @@ Tcl_AppendUnicodeToObj( * Side effects: * The string rep of appendObjPtr is appended to the string * representation of objPtr. + * IMPORTANT: This routine does not and MUST NOT shimmer appendObjPtr. + * Callers are counting on that. * *---------------------------------------------------------------------- */ -- cgit v0.12 From 335716b81d99c7476e68979fe48b20b0f2bfeeee Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 28 Oct 2016 14:45:54 +0000 Subject: Add obvious optimizations to [join] implementation. --- generic/tclCmdIL.c | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index bb3c9b7..7f4ca1d 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -2173,6 +2173,16 @@ Tcl_JoinObjCmd( return TCL_ERROR; } + if (listLen == 0) { + /* No elements to join; default empty result is correct. */ + return TCL_OK; + } + if (listLen == 1) { + /* One element; return it */ + Tcl_SetObjResult(interp, elemPtrs[0]); + return TCL_OK; + } + joinObjPtr = (objc == 2) ? Tcl_NewStringObj(" ", 1) : objv[2]; Tcl_IncrRefCount(joinObjPtr); -- cgit v0.12 From dff4ed85a2e6fac50d5e9d7caee4a7f1dffcd835 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 28 Oct 2016 15:46:49 +0000 Subject: Add optimization to [dict append]. --- generic/tclDictObj.c | 25 +++++++++++++++++-------- 1 file changed, 17 insertions(+), 8 deletions(-) diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 428173d..f99f984 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -2305,17 +2305,26 @@ DictAppendCmd( return TCL_ERROR; } - if (valuePtr == NULL) { - TclNewObj(valuePtr); - } else if (Tcl_IsShared(valuePtr)) { - valuePtr = Tcl_DuplicateObj(valuePtr); - } + if ((objc > 3) || (valuePtr == NULL)) { + /* Only go through append activites when something will change. */ + + if (valuePtr == NULL) { + TclNewObj(valuePtr); + } else if (Tcl_IsShared(valuePtr)) { + valuePtr = Tcl_DuplicateObj(valuePtr); + } - for (i=3 ; i Date: Fri, 28 Oct 2016 16:55:44 +0000 Subject: revise [dict append] to make use of common [string cat] engine. --- generic/tclDictObj.c | 30 ++++++++++++++++++++++++------ 1 file changed, 24 insertions(+), 6 deletions(-) diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index f99f984..3be968a 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -2282,7 +2282,7 @@ DictAppendCmd( Tcl_Obj *const *objv) { Tcl_Obj *dictPtr, *valuePtr, *resultPtr; - int i, allocatedDict = 0; + int allocatedDict = 0; if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "dictVarName key ?value ...?"); @@ -2307,15 +2307,33 @@ DictAppendCmd( if ((objc > 3) || (valuePtr == NULL)) { /* Only go through append activites when something will change. */ + Tcl_Obj *appendObjPtr = NULL; - if (valuePtr == NULL) { + if (objc > 3) { + /* Something to append */ + + if (objc == 4) { + appendObjPtr = objv[3]; + } else if (TCL_OK != TclStringCatObjv(interp, objc-3, objv+3, + &appendObjPtr)) { + return TCL_ERROR; + } + } + + if (appendObjPtr == NULL) { + /* => (objc == 3) => (valuePtr == NULL) */ TclNewObj(valuePtr); - } else if (Tcl_IsShared(valuePtr)) { - valuePtr = Tcl_DuplicateObj(valuePtr); + } else if (valuePtr == NULL) { + valuePtr = appendObjPtr; + appendObjPtr = NULL; } - for (i=3 ; i Date: Fri, 28 Oct 2016 20:33:55 +0000 Subject: WIP --- generic/tclCmdIL.c | 5 ++--- generic/tclCmdMZ.c | 3 ++- generic/tclDictObj.c | 4 ++-- generic/tclExecute.c | 4 ++-- generic/tclInt.h | 5 +++-- generic/tclStringObj.c | 58 +++++++++++++++++++++++++++++++++++++++++++++++++- 6 files changed, 68 insertions(+), 11 deletions(-) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 09adc8d..73bd36f 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -2187,9 +2187,8 @@ Tcl_JoinObjCmd( Tcl_IncrRefCount(joinObjPtr); if (Tcl_GetCharLength(joinObjPtr) == 0) { - Tcl_IncrRefCount(elemPtrs[0]); - TclStringCatObjv(interp, listLen, elemPtrs, &resObjPtr); - Tcl_DecrRefCount(elemPtrs[0]); + TclStringCatObjv(interp, /* inPlace */ 0, listLen, elemPtrs, + &resObjPtr); } else { int i; diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 1a08674..10c2ef3 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -2873,7 +2873,8 @@ StringCatCmd( return TCL_OK; } - code = TclStringCatObjv(interp, objc-1, objv+1, &objResultPtr); + code = TclStringCatObjv(interp, /* inPlace */ 1, objc-1, objv+1, + &objResultPtr); if (code == TCL_OK) { Tcl_SetObjResult(interp, objResultPtr); diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 3be968a..9686c6f 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -2314,8 +2314,8 @@ DictAppendCmd( if (objc == 4) { appendObjPtr = objv[3]; - } else if (TCL_OK != TclStringCatObjv(interp, objc-3, objv+3, - &appendObjPtr)) { + } else if (TCL_OK != TclStringCatObjv(interp, /* inPlace */ 1, + objc-3, objv+3, &appendObjPtr)) { return TCL_ERROR; } } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index fcf5ba9..1cf8548 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2693,8 +2693,8 @@ TEBCresume( opnd = TclGetUInt1AtPtr(pc+1); #if 1 - if (TCL_OK != TclStringCatObjv(interp, opnd, &OBJ_AT_DEPTH(opnd-1), - &objResultPtr)) { + if (TCL_OK != TclStringCatObjv(interp, /* inPlace */ 1, + opnd, &OBJ_AT_DEPTH(opnd-1), &objResultPtr)) { TRACE_ERROR(interp); goto gotError; } diff --git a/generic/tclInt.h b/generic/tclInt.h index 36c1a81..8a647f0 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3135,8 +3135,9 @@ MODULE_SCOPE void TclSpellFix(Tcl_Interp *interp, Tcl_Obj *bad, Tcl_Obj *fix); MODULE_SCOPE void * TclStackRealloc(Tcl_Interp *interp, void *ptr, int numBytes); -MODULE_SCOPE int TclStringCatObjv(Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[], Tcl_Obj **objPtrPtr); +MODULE_SCOPE int TclStringCatObjv(Tcl_Interp *interp, int inPlace, + int objc, Tcl_Obj *const objv[], + Tcl_Obj **objPtrPtr); MODULE_SCOPE int TclStringMatch(const char *str, int strLen, const char *pattern, int ptnLen, int flags); MODULE_SCOPE int TclStringMatchObj(Tcl_Obj *stringObj, diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index cc30602..c248749 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -2630,18 +2630,74 @@ TclGetStringStorage( int TclStringCatObjv( Tcl_Interp *interp, + int inPlace, int objc, Tcl_Obj * const objv[], Tcl_Obj **objPtrPtr) { Tcl_Obj *objResultPtr; + int i, length = 0, binary = 1, first = 0; /* assert (objc >= 2) */ + /* + * GOALS: Avoid shimmering & string rep generation. + * Produce pure bytearray when possible. + * Error on overflow. + */ + + for (i = 0; i < objc && binary; i++) { + Tcl_Obj *objPtr = objv[i]; + + if (objPtr->bytes) { + if (objPtr->length == 0) { + continue; + } + binary = 0; + } else if (!TclIsPureByteArray(objPtr)) { + binary = 0; + } + } + + if (binary) { + for (i = 0; i < objc && length >= 0; i++) { + if (objv[i]->bytes == NULL) { + int numBytes; + + Tcl_GetByteArrayFromObj(objv[i], &numBytes); + if (length == 0) { + first = i; + } + length += numBytes; + } + } + if (length < 0) { + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "max size for a Tcl value (%d bytes) exceeded", + INT_MAX)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + return TCL_ERROR; + } + if (length == 0) { + /* Total length of zero means every value has length zero */ + *objPtrPtr = objv[0]; + return TCL_OK; + } + } + + objv += first; objc -= first; objResultPtr = *objv++; objc--; - if (Tcl_IsShared(objResultPtr)) { + if (!inPlace || Tcl_IsShared(objResultPtr)) { objResultPtr = Tcl_DuplicateObj(objResultPtr); } + + if (binary) { + Tcl_SetByteArrayLength(objResultPtr, length); + } + + while (objc--) { Tcl_AppendObjToObj(objResultPtr, *objv++); } -- cgit v0.12 From a913c1c36df3e3fc5c44926e7b267593f4bfdacb Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 29 Oct 2016 21:03:25 +0000 Subject: Added test for bug --- tests/zlib.test | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) diff --git a/tests/zlib.test b/tests/zlib.test index 15dbb34..ae8742b 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -138,6 +138,25 @@ test zlib-7.7 {zlib stream: Bug 25842c161} -constraints zlib -body { } -cleanup { catch {$s close} } -result "" +# Also causes Tk Bug 10f2e7872b +test zlib-7.8 {zlib stream: Bug b26e38a3e4} -constraints zlib -setup { + expr srand(12345) + set randdata {} + for {set i 0} {$i<6001} {incr i} { + append randdata [binary format c [expr {int(256*rand())}]] + } +} -body { + set strm [zlib stream compress] + for {set i 1} {$i<3000} {incr i} { + $strm put $randdata + } + $strm put -finalize $randdata + set data [$strm get] + list [string length $data] [string length [zlib decompress $data]] +} -cleanup { + catch {$strm close} + unset -nocomplain randdata data +} -result {120185 18003000} test zlib-8.1 {zlib transformation} -constraints zlib -setup { set file [makeFile {} test.gz] -- cgit v0.12 From f50fc619a4f614dc4011b6bf50add8f947d6cb35 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 30 Oct 2016 05:02:46 +0000 Subject: Fix the bug. Make use of zlib API in this area more like a Tcl API with wrapper function. --- generic/tclZlib.c | 144 ++++++++++++++++++++++++++++++++---------------------- 1 file changed, 86 insertions(+), 58 deletions(-) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index c9d7b88..53cd14b 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -177,6 +177,8 @@ static Tcl_ObjCmdProc ZlibStreamPutCmd; static void ConvertError(Tcl_Interp *interp, int code, uLong adler); static Tcl_Obj * ConvertErrorToList(int code, uLong adler); +static inline int Deflate(z_streamp strm, void *bufferPtr, + int bufferSize, int flush, int *writtenPtr); static void ExtractHeader(gz_header *headerPtr, Tcl_Obj *dictObj); static int GenerateHeader(Tcl_Interp *interp, Tcl_Obj *dictObj, GzipHeader *headerPtr, int *extraSizePtr); @@ -578,6 +580,10 @@ ExtractHeader( } } +/* + * Disentangle the worst of how the zlib API is used. + */ + static int SetInflateDictionary( z_streamp strm, @@ -605,6 +611,38 @@ SetDeflateDictionary( } return Z_OK; } + +static inline int +Deflate( + z_streamp strm, + void *bufferPtr, + int bufferSize, + int flush, + int *writtenPtr) +{ + int e; + + strm->next_out = (Bytef *) bufferPtr; + strm->avail_out = (unsigned) bufferSize; + e = deflate(strm, flush); + if (writtenPtr != NULL) { + *writtenPtr = bufferSize - strm->avail_out; + } + return e; +} + +static inline void +AppendByteArray( + Tcl_Obj *listObj, + void *buffer, + int size) +{ + if (size > 0) { + Tcl_Obj *baObj = Tcl_NewByteArrayObj((unsigned char *) buffer, size); + + Tcl_ListObjAppendElement(NULL, listObj, baObj); + } +} /* *---------------------------------------------------------------------- @@ -1139,6 +1177,8 @@ Tcl_ZlibStreamSetCompressionDictionary( *---------------------------------------------------------------------- */ +#define BUFFER_SIZE_LIMIT 0xFFFF + int Tcl_ZlibStreamPut( Tcl_ZlibStream zshandle, /* As obtained from Tcl_ZlibStreamInit */ @@ -1148,8 +1188,7 @@ Tcl_ZlibStreamPut( { ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle; char *dataTmp = NULL; - int e, size, outSize; - Tcl_Obj *obj; + int e, size, outSize, toStore; if (zshPtr->streamEnd) { if (zshPtr->interp) { @@ -1175,26 +1214,45 @@ Tcl_ZlibStreamPut( if (HaveDictToSet(zshPtr)) { e = SetDeflateDictionary(&zshPtr->stream, zshPtr->compDictObj); if (e != Z_OK) { - if (zshPtr->interp) { - ConvertError(zshPtr->interp, e, zshPtr->stream.adler); - } + ConvertError(zshPtr->interp, e, zshPtr->stream.adler); return TCL_ERROR; } DictWasSet(zshPtr); } /* - * Deflatebound doesn't seem to take various header sizes into - * account, so we add 100 extra bytes. + * deflateBound() doesn't seem to take various header sizes into + * account, so we add 100 extra bytes. However, we can also loop + * around again so we also set an upper bound on the output buffer + * size. */ - outSize = deflateBound(&zshPtr->stream, zshPtr->stream.avail_in)+100; - zshPtr->stream.avail_out = outSize; - dataTmp = ckalloc(zshPtr->stream.avail_out); - zshPtr->stream.next_out = (Bytef *) dataTmp; + outSize = deflateBound(&zshPtr->stream, size) + 100; + if (outSize > BUFFER_SIZE_LIMIT) { + outSize = BUFFER_SIZE_LIMIT; + } + dataTmp = ckalloc(outSize); + + while (1) { + e = Deflate(&zshPtr->stream, dataTmp, outSize, flush, &toStore); + + /* + * Test if we've filled the buffer up and have to ask deflate() to + * give us some more. Note that the condition for needing to + * repeat a buffer transfer when the result is Z_OK is whether + * there is no more space in the buffer we provided; the zlib + * library does not necessarily return a different code in that + * case. [Bug b26e38a3e4] [Tk Bug 10f2e7872b] + */ + + if ((e != Z_BUF_ERROR) && (e != Z_OK || toStore < outSize)) { + if ((e == Z_OK) || (flush == Z_FINISH && e == Z_STREAM_END)) { + break; + } + ConvertError(zshPtr->interp, e, zshPtr->stream.adler); + return TCL_ERROR; + } - e = deflate(&zshPtr->stream, flush); - while (e == Z_BUF_ERROR || (flush == Z_FINISH && e == Z_OK)) { /* * Output buffer too small to hold the data being generated or we * are doing the end-of-stream flush (which can spit out masses of @@ -1202,45 +1260,21 @@ Tcl_ZlibStreamPut( * saving the old generated data to the outData list. */ - obj = Tcl_NewByteArrayObj((unsigned char *) dataTmp, outSize); - Tcl_ListObjAppendElement(NULL, zshPtr->outData, obj); + AppendByteArray(zshPtr->outData, dataTmp, outSize); - if (outSize < 0xFFFF) { - outSize = 0xFFFF; /* There may be *lots* of data left to - * output... */ + if (outSize < BUFFER_SIZE_LIMIT) { + outSize = BUFFER_SIZE_LIMIT; + /* There may be *lots* of data left to output... */ dataTmp = ckrealloc(dataTmp, outSize); } - zshPtr->stream.avail_out = outSize; - zshPtr->stream.next_out = (Bytef *) dataTmp; - - e = deflate(&zshPtr->stream, flush); - } - - if (e != Z_OK && !(flush==Z_FINISH && e==Z_STREAM_END)) { - if (zshPtr->interp) { - ConvertError(zshPtr->interp, e, zshPtr->stream.adler); - } - return TCL_ERROR; } /* - * And append the final data block. + * And append the final data block to the outData list. */ - if (outSize - zshPtr->stream.avail_out > 0) { - obj = Tcl_NewByteArrayObj((unsigned char *) dataTmp, - outSize - zshPtr->stream.avail_out); - - /* - * Now append the compressed data to the outData list. - */ - - Tcl_ListObjAppendElement(NULL, zshPtr->outData, obj); - } - - if (dataTmp) { - ckfree(dataTmp); - } + AppendByteArray(zshPtr->outData, dataTmp, toStore); + ckfree(dataTmp); } else { /* * This is easy. Just append to the inData list. @@ -1356,9 +1390,7 @@ Tcl_ZlibStreamGet( if (IsRawStream(zshPtr) && HaveDictToSet(zshPtr)) { e = SetInflateDictionary(&zshPtr->stream, zshPtr->compDictObj); if (e != Z_OK) { - if (zshPtr->interp) { - ConvertError(zshPtr->interp, e, zshPtr->stream.adler); - } + ConvertError(zshPtr->interp, e, zshPtr->stream.adler); return TCL_ERROR; } DictWasSet(zshPtr); @@ -2879,10 +2911,8 @@ ZlibTransformClose( if (cd->mode == TCL_ZLIB_STREAM_DEFLATE) { cd->outStream.avail_in = 0; do { - 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; + e = Deflate(&cd->outStream, cd->outBuffer, cd->outAllocated, + Z_FINISH, &written); /* * Can't be sure that deflate() won't declare the buffer to be @@ -3086,17 +3116,15 @@ ZlibTransformOutput( cd->outStream.next_in = (Bytef *) buf; cd->outStream.avail_in = toWrite; do { - cd->outStream.next_out = (Bytef *) cd->outBuffer; - cd->outStream.avail_out = cd->outAllocated; - - e = deflate(&cd->outStream, Z_NO_FLUSH); - produced = cd->outAllocated - cd->outStream.avail_out; + e = Deflate(&cd->outStream, cd->outBuffer, cd->outAllocated, + Z_NO_FLUSH, &produced); 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. + * Z_BUF_ERROR *or* by simply returning Z_OK with no remaining + * space; in either case, we must write the whole buffer out and + * retry to compress what is left. */ if (e == Z_BUF_ERROR) { -- cgit v0.12 From 4ebcee3015caa6c14ae484220d113c943bc1f736 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 30 Oct 2016 05:07:47 +0000 Subject: One more place where the internal API change can be used easily. --- generic/tclZlib.c | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 53cd14b..e5a5946 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -3177,10 +3177,8 @@ ZlibTransformFlush( * Get the bytes to go out of the compression engine. */ - cd->outStream.next_out = (Bytef *) cd->outBuffer; - cd->outStream.avail_out = cd->outAllocated; - - e = deflate(&cd->outStream, flushType); + e = Deflate(&cd->outStream, cd->outBuffer, cd->outAllocated, + flushType, &len); if (e != Z_OK && e != Z_BUF_ERROR) { ConvertError(interp, e, cd->outStream.adler); return TCL_ERROR; @@ -3190,7 +3188,6 @@ ZlibTransformFlush( * Write the bytes we've received to the next layer. */ - len = cd->outStream.next_out - (Bytef *) cd->outBuffer; if (len > 0 && Tcl_WriteRaw(cd->parent, cd->outBuffer, len) < 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "problem flushing channel: %s", -- cgit v0.12 From df54f23b9fdd17bc3eb02a15f3fd9513e6261b7e Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 30 Oct 2016 08:22:13 +0000 Subject: [1ae12987cb] Ensure that deleting the [history] command deletes its storage. --- library/history.tcl | 24 ++++++++++++++++++++++ tests/history.test | 58 +++++++++++++++++++++++++++++++++++++++++++++++++++-- 2 files changed, 80 insertions(+), 2 deletions(-) diff --git a/library/history.tcl b/library/history.tcl index 51d2404..ef9099b 100644 --- a/library/history.tcl +++ b/library/history.tcl @@ -56,6 +56,30 @@ proc ::history {args} { tailcall apply {arglist {tailcall history {*}$arglist} ::tcl} $args } +# (unnamed) -- +# +# Callback when [::history] is destroyed. Destroys the implementation. +# +# Parameters: +# oldName what the command was called. +# newName what the command is now called (an empty string). +# op the operation (= delete). +# +# Results: +# none +# +# Side Effects: +# The implementation of the [::history] command ceases to exist. + +trace add command ::history delete [list apply {{oldName newName op} { + variable history + unset -nocomplain history + foreach c [info procs ::tcl::Hist*] { + rename $c {} + } + rename ::tcl::history {} +} ::tcl}] + # tcl::HistAdd -- # # Add an item to the history, and optionally eval it at the global scope diff --git a/tests/history.test b/tests/history.test index 7549beb..3201ad7 100644 --- a/tests/history.test +++ b/tests/history.test @@ -11,8 +11,8 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2 namespace import -force ::tcltest::* } @@ -245,6 +245,60 @@ test history-9.2 {miscellaneous} history { catch {history gorp} msg set msg } {unknown or ambiguous subcommand "gorp": must be add, change, clear, event, info, keep, nextid, or redo} + +# History retains references; Bug 1ae12987cb +test history-10.1 {references kept by history} -constraints history -setup { + interp create histtest + histtest eval { + # Trigger any autoloading that might be present + catch {history} + proc refcount {x} { + set rep [::tcl::unsupported::representation $x] + regexp {with a refcount of (\d+)} $rep -> rc + # Ignore the references due to calling this procedure + return [expr {$rc - 3}] + } + } +} -body { + histtest eval { + # A fresh object, refcount 1 from the variable we write it to + set obj [expr rand()] + set baseline [refcount $obj] + lappend result [refcount $obj] + history add [list list $obj] + lappend result [refcount $obj] + history clear + lappend result [refcount $obj] + } +} -cleanup { + interp delete histtest +} -result {1 2 1} +test history-10.2 {references kept by history} -constraints history -setup { + interp create histtest + histtest eval { + # Trigger any autoloading that might be present + catch {history} + proc refcount {x} { + set rep [::tcl::unsupported::representation $x] + regexp {with a refcount of (\d+)} $rep -> rc + # Ignore the references due to calling this procedure + return [expr {$rc - 3}] + } + } +} -body { + histtest eval { + # A fresh object, refcount 1 from the variable we write it to + set obj [expr rand()] + set baseline [refcount $obj] + lappend result [refcount $obj] + history add [list list $obj] + lappend result [refcount $obj] + rename history {} + lappend result [refcount $obj] + } +} -cleanup { + interp delete histtest +} -result {1 2 1} # cleanup ::tcltest::cleanupTests -- cgit v0.12 From 5ddd3f071bddef971e50673d7700162700561cf6 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 30 Oct 2016 16:16:29 +0000 Subject: [253ba6e818] Improved description of [variable] behaviour. --- doc/variable.n | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/doc/variable.n b/doc/variable.n index a6e545f..8228859 100644 --- a/doc/variable.n +++ b/doc/variable.n @@ -45,7 +45,8 @@ linked to the corresponding namespace variables (and therefore these variables are listed by \fBinfo vars\fR.) In this way the \fBvariable\fR command resembles the \fBglobal\fR command, although the \fBglobal\fR command -only links to variables in the global namespace. +resolves variable names with respect to the global namespace instead +of the current namespace of the procedure. If any \fIvalue\fRs are given, they are used to modify the values of the associated namespace variables. If a namespace variable does not exist, @@ -98,3 +99,7 @@ namespace eval foo { global(n), namespace(n), upvar(n) .SH KEYWORDS global, namespace, procedure, variable +.\" Local variables: +.\" mode: nroff +.\" fill-column: 78 +.\" End: -- cgit v0.12 From 1cb5e0af9770c565d370fbb5cf713af0d1f561de Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 31 Oct 2016 14:17:31 +0000 Subject: Coverage tests for INST_STR_CONCAT1 byterarray ops. --- tests/binary.test | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/tests/binary.test b/tests/binary.test index 40b1315..7738f69 100644 --- a/tests/binary.test +++ b/tests/binary.test @@ -2837,6 +2837,19 @@ test binary-76.2 {binary string appending growth algorithm} win { # Append to it string length [append str [binary format a* foo]] } 3 + +test binary-77.1 {string cat ops on all bytearrays} { + apply {{a b} { + return [binary format H* $a][binary format H* $b] + }} ab cd +} [binary format H* abcd] +test binary-77.2 {string cat ops on all bytearrays} { + apply {{a b} { + set one [binary format H* $a] + return $one[binary format H* $b] + }} ab cd +} [binary format H* abcd] + # ---------------------------------------------------------------------- # cleanup -- cgit v0.12 From 77c9a433f701214eafd76617a8e3c67316ebf08e Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 31 Oct 2016 16:15:16 +0000 Subject: Complete the "pure binary" implementation of the [string cat] engine. --- generic/tclStringObj.c | 26 ++++++++++++++++++++------ 1 file changed, 20 insertions(+), 6 deletions(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index c248749..c0d85a0 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -2694,12 +2694,26 @@ TclStringCatObjv( } if (binary) { - Tcl_SetByteArrayLength(objResultPtr, length); - } - - - while (objc--) { - Tcl_AppendObjToObj(objResultPtr, *objv++); + /* Efficiently produce a pure binary result */ + unsigned char *dst; + int start; + + Tcl_GetByteArrayFromObj(objResultPtr, &start); + dst = Tcl_SetByteArrayLength(objResultPtr, length) + start; + while (objc--) { + Tcl_Obj *objPtr = *objv++; + + if (objPtr->bytes == NULL) { + int more; + unsigned char *src = Tcl_GetByteArrayFromObj(objPtr, &more); + memcpy(dst, src, (size_t) more); + dst += more; + } + } + } else { + while (objc--) { + Tcl_AppendObjToObj(objResultPtr, *objv++); + } } *objPtrPtr = objResultPtr; return TCL_OK; -- cgit v0.12 From b550e65a968434e0f17d097f85df3fb64347e1ce Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 31 Oct 2016 18:10:21 +0000 Subject: Reduce copies in the pure binary implementation of [string cat]. --- generic/tclStringObj.c | 26 +++++++++++++++++++------- 1 file changed, 19 insertions(+), 7 deletions(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index c0d85a0..1723804 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -2688,18 +2688,21 @@ TclStringCatObjv( } objv += first; objc -= first; - objResultPtr = *objv++; objc--; - if (!inPlace || Tcl_IsShared(objResultPtr)) { - objResultPtr = Tcl_DuplicateObj(objResultPtr); - } if (binary) { /* Efficiently produce a pure binary result */ unsigned char *dst; - int start; - Tcl_GetByteArrayFromObj(objResultPtr, &start); - dst = Tcl_SetByteArrayLength(objResultPtr, length) + start; + if (inPlace && !Tcl_IsShared(*objv)) { + int start; + + objResultPtr = *objv++; objc--; + Tcl_GetByteArrayFromObj(objResultPtr, &start); + dst = Tcl_SetByteArrayLength(objResultPtr, length) + start; + } else { + objResultPtr = Tcl_NewByteArrayObj(NULL, length); + dst = Tcl_SetByteArrayLength(objResultPtr, length); + } while (objc--) { Tcl_Obj *objPtr = *objv++; @@ -2711,6 +2714,15 @@ TclStringCatObjv( } } } else { + + + objResultPtr = *objv++; objc--; + if (!inPlace || Tcl_IsShared(objResultPtr)) { + objResultPtr = Tcl_DuplicateObj(objResultPtr); + } + + + while (objc--) { Tcl_AppendObjToObj(objResultPtr, *objv++); } -- cgit v0.12 From ff2f0e85be431ad093ea78333f98942321ea1779 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 1 Nov 2016 15:07:30 +0000 Subject: Expand all the cases of the [string cat] engine. --- generic/tclStringObj.c | 156 ++++++++++++++++++++++++++++++++++++++++--------- 1 file changed, 129 insertions(+), 27 deletions(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 1723804..05dcba4 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -2637,60 +2637,113 @@ TclStringCatObjv( { Tcl_Obj *objResultPtr; int i, length = 0, binary = 1, first = 0; + int allowUniChar = 1, requestUniChar = 0; /* assert (objc >= 2) */ /* + * Analyze to determine what representation result should be. * GOALS: Avoid shimmering & string rep generation. * Produce pure bytearray when possible. * Error on overflow. */ - for (i = 0; i < objc && binary; i++) { + for (i = 0; i < objc && (binary || allowUniChar); i++) { Tcl_Obj *objPtr = objv[i]; if (objPtr->bytes) { - if (objPtr->length == 0) { - continue; + /* Value has a string rep. */ + if (objPtr->length) { + /* + * Non-empty string rep. Not a pure bytearray, so we + * won't create a pure bytearray + */ + binary = 0; + if ((objPtr->typePtr) && (objPtr->typePtr != &tclStringType)) { + /* Prevent shimmer of non-string types. */ + allowUniChar = 0; + } + } + } else { + /* assert (objPtr->typePtr != NULL) -- stork! */ + if (TclIsPureByteArray(objPtr)) { + allowUniChar = 0; + } else { + binary = 0; + if (objPtr->typePtr == &tclStringType) { + /* Have a pure Unicode value; ask to preserve it */ + requestUniChar = 1; + } else { + /* Have another type; prevent shimmer */ + allowUniChar = 0; + } } - binary = 0; - } else if (!TclIsPureByteArray(objPtr)) { - binary = 0; } } if (binary) { + /* Result will be pure byte array. Pre-size it */ for (i = 0; i < objc && length >= 0; i++) { - if (objv[i]->bytes == NULL) { + Tcl_Obj *objPtr = objv[i]; + + if (objPtr->bytes == NULL) { int numBytes; - Tcl_GetByteArrayFromObj(objv[i], &numBytes); + Tcl_GetByteArrayFromObj(objPtr, &numBytes); if (length == 0) { first = i; } length += numBytes; } } - if (length < 0) { - if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "max size for a Tcl value (%d bytes) exceeded", - INT_MAX)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } else if (allowUniChar && requestUniChar) { + /* Result will be pure Tcl_UniChar array. Pre-size it. */ + for (i = 0; i < objc && length >= 0; i++) { + Tcl_Obj *objPtr = objv[i]; + + if ((objPtr->bytes == NULL) || (objPtr->length)) { + int numChars; + + Tcl_GetUnicodeFromObj(objPtr, &numChars); + if (length == 0) { + first = i; + } + length += numChars; } - return TCL_ERROR; } - if (length == 0) { - /* Total length of zero means every value has length zero */ - *objPtrPtr = objv[0]; - return TCL_OK; + } else { + /* Result will be concat of string reps. Pre-size it. */ + for (i = 0; i < objc && length >= 0; i++) { + Tcl_Obj *objPtr = objv[i]; + int numBytes; + + Tcl_GetStringFromObj(objPtr, &numBytes); + if ((length == 0) && numBytes) { + first = i; + } + length += numBytes; + } + } + + if (length < 0) { + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "max size for a Tcl value (%d bytes) exceeded", INT_MAX)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); } - } + return TCL_ERROR; + } + + if (length == 0) { + /* Total length of zero means every value has length zero */ + *objPtrPtr = objv[0]; + return TCL_OK; + } objv += first; objc -= first; if (binary) { - /* Efficiently produce a pure binary result */ + /* Efficiently produce a pure byte array result */ unsigned char *dst; if (inPlace && !Tcl_IsShared(*objv)) { @@ -2713,18 +2766,67 @@ TclStringCatObjv( dst += more; } } - } else { + } else if (allowUniChar && requestUniChar) { + /* Efficiently produce a pure Tcl_UniChar array result */ + Tcl_UniChar *dst; + if (inPlace && !Tcl_IsShared(*objv)) { + int start; - objResultPtr = *objv++; objc--; - if (!inPlace || Tcl_IsShared(objResultPtr)) { - objResultPtr = Tcl_DuplicateObj(objResultPtr); - } + objResultPtr = *objv++; objc--; + + /* Ugly interface! Force resize of the unicode array. */ + Tcl_GetUnicodeFromObj(objResultPtr, &start); + Tcl_InvalidateStringRep(objResultPtr); + Tcl_SetObjLength(objResultPtr, length); + dst = Tcl_GetUnicode(objResultPtr) + start; + } else { + Tcl_UniChar ch = 0; + + /* Ugly interface! No scheme to init array size. */ + objResultPtr = Tcl_NewUnicodeObj(&ch, 0); + Tcl_SetObjLength(objResultPtr, length); + dst = Tcl_GetUnicode(objResultPtr); + } + while (objc--) { + Tcl_Obj *objPtr = *objv++; + + if ((objPtr->bytes == NULL) || (objPtr->length)) { + int more; + Tcl_UniChar *src = Tcl_GetUnicodeFromObj(objPtr, &more); + memcpy(dst, src, more * sizeof(Tcl_UniChar)); + dst += more; + } + } + } else { + /* Efficiently concatenate string reps */ + char *dst; + if (inPlace && !Tcl_IsShared(*objv)) { + int start; + objResultPtr = *objv++; objc--; + Tcl_GetStringFromObj(objResultPtr, &start); + Tcl_SetObjLength(objResultPtr, length); + dst = Tcl_GetString(objResultPtr) + start; + if (length > start) { + TclFreeIntRep(objResultPtr); + } + } else { + objResultPtr = Tcl_NewObj(); + Tcl_SetObjLength(objResultPtr, length); + dst = Tcl_GetString(objResultPtr); + } while (objc--) { - Tcl_AppendObjToObj(objResultPtr, *objv++); + Tcl_Obj *objPtr = *objv++; + + if ((objPtr->bytes == NULL) || (objPtr->length)) { + int more; + char *src = Tcl_GetStringFromObj(objPtr, &more); + memcpy(dst, src, (size_t) more); + dst += more; + } } } *objPtrPtr = objResultPtr; -- cgit v0.12 From 418ded1bc9df7ae0976ce3793aa0190c93609332 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 1 Nov 2016 15:12:07 +0000 Subject: Trim away obsolete code. --- generic/tclExecute.c | 146 +-------------------------------------------------- 1 file changed, 1 insertion(+), 145 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 1cf8548..83b83f1 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2684,162 +2684,18 @@ TEBCresume( NEXT_INST_F(5, 0, 0); } - case INST_STR_CONCAT1: { - int appendLen = 0; - char *bytes, *p; - Tcl_Obj **currPtr; - int onlyb = 1; + case INST_STR_CONCAT1: opnd = TclGetUInt1AtPtr(pc+1); -#if 1 if (TCL_OK != TclStringCatObjv(interp, /* inPlace */ 1, opnd, &OBJ_AT_DEPTH(opnd-1), &objResultPtr)) { TRACE_ERROR(interp); goto gotError; } -#else - /* - * Detect only-bytearray-or-null case. - */ - - for (currPtr=&OBJ_AT_DEPTH(opnd-1); currPtr<=&OBJ_AT_TOS; currPtr++) { - if (((*currPtr)->typePtr != &tclByteArrayType) - && ((*currPtr)->bytes != tclEmptyStringRep)) { - onlyb = 0; - break; - } else if (((*currPtr)->typePtr == &tclByteArrayType) && - ((*currPtr)->bytes != NULL)) { - onlyb = 0; - break; - } - } - - /* - * Compute the length to be appended. - */ - - if (onlyb) { - for (currPtr = &OBJ_AT_DEPTH(opnd-2); - appendLen >= 0 && currPtr <= &OBJ_AT_TOS; currPtr++) { - if ((*currPtr)->bytes != tclEmptyStringRep) { - Tcl_GetByteArrayFromObj(*currPtr, &length); - appendLen += length; - } - } - } else { - for (currPtr = &OBJ_AT_DEPTH(opnd-2); - appendLen >= 0 && currPtr <= &OBJ_AT_TOS; currPtr++) { - bytes = TclGetStringFromObj(*currPtr, &length); - if (bytes != NULL) { - appendLen += length; - } - } - } - - if (appendLen < 0) { - /* TODO: convert panic to error ? */ - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); - } - - /* - * If nothing is to be appended, just return the first object by - * dropping all the others from the stack; this saves both the - * computation and copy of the string rep of the first object, - * enabling the fast '$x[set x {}]' idiom for 'K $x [set x {}]'. - */ - - if (appendLen == 0) { - TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); - NEXT_INST_V(2, (opnd-1), 0); - } - - /* - * If the first object is shared, we need a new obj for the result; - * otherwise, we can reuse the first object. In any case, make sure it - * has enough room to accomodate all the concatenated bytes. Note that - * if it is unshared its bytes are copied by ckrealloc, so that we set - * the loop parameters to avoid copying them again: p points to the - * end of the already copied bytes, currPtr to the second object. - */ - - objResultPtr = OBJ_AT_DEPTH(opnd-1); - if (!onlyb) { - bytes = TclGetStringFromObj(objResultPtr, &length); - if (length + appendLen < 0) { - /* TODO: convert panic to error ? */ - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", - INT_MAX); - } -#ifndef TCL_COMPILE_DEBUG - if (bytes != tclEmptyStringRep && !Tcl_IsShared(objResultPtr)) { - TclFreeIntRep(objResultPtr); - objResultPtr->bytes = ckrealloc(bytes, length+appendLen+1); - objResultPtr->length = length + appendLen; - p = TclGetString(objResultPtr) + length; - currPtr = &OBJ_AT_DEPTH(opnd - 2); - } else -#endif - { - p = ckalloc(length + appendLen + 1); - TclNewObj(objResultPtr); - objResultPtr->bytes = p; - objResultPtr->length = length + appendLen; - currPtr = &OBJ_AT_DEPTH(opnd - 1); - } - - /* - * Append the remaining characters. - */ - - for (; currPtr <= &OBJ_AT_TOS; currPtr++) { - bytes = TclGetStringFromObj(*currPtr, &length); - if (bytes != NULL) { - memcpy(p, bytes, (size_t) length); - p += length; - } - } - *p = '\0'; - } else { - bytes = (char *) Tcl_GetByteArrayFromObj(objResultPtr, &length); - if (length + appendLen < 0) { - /* TODO: convert panic to error ? */ - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", - INT_MAX); - } -#ifndef TCL_COMPILE_DEBUG - if (!Tcl_IsShared(objResultPtr)) { - bytes = (char *) Tcl_SetByteArrayLength(objResultPtr, - length + appendLen); - p = bytes + length; - currPtr = &OBJ_AT_DEPTH(opnd - 2); - } else -#endif - { - TclNewObj(objResultPtr); - bytes = (char *) Tcl_SetByteArrayLength(objResultPtr, - length + appendLen); - p = bytes; - currPtr = &OBJ_AT_DEPTH(opnd - 1); - } - - /* - * Append the remaining characters. - */ - - for (; currPtr <= &OBJ_AT_TOS; currPtr++) { - if ((*currPtr)->bytes != tclEmptyStringRep) { - bytes = (char *) Tcl_GetByteArrayFromObj(*currPtr,&length); - memcpy(p, bytes, (size_t) length); - p += length; - } - } - } -#endif TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); NEXT_INST_V(2, opnd, 1); - } case INST_CONCAT_STK: /* -- cgit v0.12 From cdc8b6080c2a2f05f3f66adfa3184405f04dc003 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 1 Nov 2016 15:42:50 +0000 Subject: Replace indexing with pointer increments. --- generic/tclStringObj.c | 31 ++++++++++++++++++------------- 1 file changed, 18 insertions(+), 13 deletions(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 05dcba4..7fd7cc1 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -2635,8 +2635,8 @@ TclStringCatObjv( Tcl_Obj * const objv[], Tcl_Obj **objPtrPtr) { - Tcl_Obj *objResultPtr; - int i, length = 0, binary = 1, first = 0; + Tcl_Obj *objPtr, *objResultPtr, * const *ov; + int oc, length = 0, binary = 1, first = 0; int allowUniChar = 1, requestUniChar = 0; /* assert (objc >= 2) */ @@ -2648,8 +2648,9 @@ TclStringCatObjv( * Error on overflow. */ - for (i = 0; i < objc && (binary || allowUniChar); i++) { - Tcl_Obj *objPtr = objv[i]; + ov = objv, oc = objc; + while (oc-- && (binary || allowUniChar)) { + objPtr = *ov++; if (objPtr->bytes) { /* Value has a string rep. */ @@ -2683,43 +2684,47 @@ TclStringCatObjv( if (binary) { /* Result will be pure byte array. Pre-size it */ - for (i = 0; i < objc && length >= 0; i++) { - Tcl_Obj *objPtr = objv[i]; + ov = objv; oc = objc; + while (oc-- && (length >= 0)) { + objPtr = *ov++; if (objPtr->bytes == NULL) { int numBytes; Tcl_GetByteArrayFromObj(objPtr, &numBytes); if (length == 0) { - first = i; + first = objc - oc - 1; } length += numBytes; } } } else if (allowUniChar && requestUniChar) { /* Result will be pure Tcl_UniChar array. Pre-size it. */ - for (i = 0; i < objc && length >= 0; i++) { - Tcl_Obj *objPtr = objv[i]; + ov = objv; oc = objc; + while (oc-- && (length >= 0)) { + objPtr = *ov++; if ((objPtr->bytes == NULL) || (objPtr->length)) { int numChars; Tcl_GetUnicodeFromObj(objPtr, &numChars); if (length == 0) { - first = i; + first = objc - oc - 1; } length += numChars; } } } else { /* Result will be concat of string reps. Pre-size it. */ - for (i = 0; i < objc && length >= 0; i++) { - Tcl_Obj *objPtr = objv[i]; + ov = objv; oc = objc; + while (oc-- && (length >= 0)) { int numBytes; + objPtr = *ov++; + Tcl_GetStringFromObj(objPtr, &numBytes); if ((length == 0) && numBytes) { - first = i; + first = objc - oc - 1; } length += numBytes; } -- cgit v0.12