From 4ad7747c62ec01498c6452f516702b1fe7e5f775 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 23 Feb 2018 15:44:10 +0000 Subject: Cease registration of the "end-offset" Tcl_ObjType. Give it file scope. Remove the updateStringProc that can never be called. --- generic/tclObj.c | 1 - generic/tclUtil.c | 53 +++++++++-------------------------------------------- 2 files changed, 9 insertions(+), 45 deletions(-) diff --git a/generic/tclObj.c b/generic/tclObj.c index 6d365a2..7b9488e 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -400,7 +400,6 @@ TclInitObjSubsystem(void) Tcl_RegisterObjType(&tclByteArrayType); Tcl_RegisterObjType(&tclDoubleType); - Tcl_RegisterObjType(&tclEndOffsetType); Tcl_RegisterObjType(&tclStringType); Tcl_RegisterObjType(&tclListType); Tcl_RegisterObjType(&tclDictType); diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 9557aac..a5a129d 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -110,7 +110,6 @@ static void FreeThreadHash(ClientData clientData); static Tcl_HashTable * GetThreadHash(Tcl_ThreadDataKey *keyPtr); static int SetEndOffsetFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); -static void UpdateStringOfEndOffset(Tcl_Obj *objPtr); static int FindElement(Tcl_Interp *interp, const char *string, int stringLength, const char *typeStr, const char *typeCode, const char **elementPtr, @@ -119,15 +118,18 @@ static int FindElement(Tcl_Interp *interp, const char *string, /* * The following is the Tcl object type definition for an object that * represents a list index in the form, "end-offset". It is used as a - * performance optimization in TclGetIntForIndex. The internal rep is an - * integer, so no memory management is required for it. + * performance optimization in TclGetIntForIndex. The internal rep is + * stored directly in the wideValue, so no memory management is required + * for it. This is a caching intrep, keeping the result of a parse + * around. This type is only created from a pre-existing string, so an + * updateStringProc will never be called and need not exist. */ -const Tcl_ObjType tclEndOffsetType = { +static const Tcl_ObjType endOffsetType = { "end-offset", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ - UpdateStringOfEndOffset, /* updateStringProc */ + NULL, /* updateStringProc */ SetEndOffsetFromAny }; @@ -3652,43 +3654,6 @@ TclGetIntForIndex( /* *---------------------------------------------------------------------- * - * UpdateStringOfEndOffset -- - * - * Update the string rep of a Tcl object holding an "end-offset" - * expression. - * - * Results: - * None. - * - * Side effects: - * Stores a valid string in the object's string rep. - * - * This function does NOT free any earlier string rep. If it is called on an - * object that already has a valid string rep, it will leak memory. - * - *---------------------------------------------------------------------- - */ - -static void -UpdateStringOfEndOffset( - register Tcl_Obj *objPtr) -{ - char buffer[TCL_INTEGER_SPACE + 5]; - register int len = 3; - - memcpy(buffer, "end", 4); - if (objPtr->internalRep.wideValue != 0) { - buffer[len++] = '-'; - len += TclFormatInt(buffer+len, -(objPtr->internalRep.wideValue)); - } - objPtr->bytes = ckalloc((unsigned) len+1); - memcpy(objPtr->bytes, buffer, (unsigned) len+1); - objPtr->length = len; -} - -/* - *---------------------------------------------------------------------- - * * SetEndOffsetFromAny -- * * Look for a string of the form "end[+-]offset" and convert it to an @@ -3717,7 +3682,7 @@ SetEndOffsetFromAny( * If it's already the right type, we're fine. */ - if (objPtr->typePtr == &tclEndOffsetType) { + if (objPtr->typePtr == &endOffsetType) { return TCL_OK; } @@ -3783,7 +3748,7 @@ SetEndOffsetFromAny( TclFreeIntRep(objPtr); objPtr->internalRep.wideValue = offset; - objPtr->typePtr = &tclEndOffsetType; + objPtr->typePtr = &endOffsetType; return TCL_OK; } -- cgit v0.12 From 85233a46935b192d7baf5fa81c9ad21bfebeca77 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 23 Feb 2018 16:55:49 +0000 Subject: [8e6a9ac221] Stop false matching with bytearrays. (string-11.55) --- generic/tclUtil.c | 3 ++- tests/string.test | 3 +++ 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 34d4be2..d782ea1 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -2340,7 +2340,8 @@ TclStringMatchObj( udata = Tcl_GetUnicodeFromObj(strObj, &length); uptn = Tcl_GetUnicodeFromObj(ptnObj, &plen); match = TclUniCharMatch(udata, length, uptn, plen, flags); - } else if (TclIsPureByteArray(strObj) && !flags) { + } else if (TclIsPureByteArray(strObj) && TclIsPureByteArray(ptnObj) + && !flags) { unsigned char *data, *ptn; data = Tcl_GetByteArrayFromObj(strObj, &length); diff --git a/tests/string.test b/tests/string.test index 7a7a749..39abd86 100644 --- a/tests/string.test +++ b/tests/string.test @@ -1111,6 +1111,9 @@ test string-11.54 {string match, failure} { [string match *a*l*\u0000*cba* $longString] \ [string match *===* $longString] } {0 1 1 1 0 0} +test string-11.55 {string match, invalid binary optimization} { + [format string] match \u0141 [binary format c 65] +} 0 test string-12.1 {string range} { list [catch {string range} msg] $msg -- cgit v0.12 From 9090aca429d0d8ba6abfa8a1f8fc9f91338052cd Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 23 Feb 2018 17:17:47 +0000 Subject: Remove tests of "end-offset" Tcl_ObjType, taken private. --- tests/obj.test | 47 ----------------------------------------------- 1 file changed, 47 deletions(-) diff --git a/tests/obj.test b/tests/obj.test index 833c906..cb62d3f 100644 --- a/tests/obj.test +++ b/tests/obj.test @@ -30,7 +30,6 @@ test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} tes bytecode cmdName dict - end-offset regexp string } { @@ -52,15 +51,6 @@ test obj-2.2 {Tcl_GetObjType and Tcl_ConvertToType} testobj { lappend result [testobj refcount 1] } {{} 12 12 bytearray 3} -test obj-3.1 {Tcl_ConvertToType error} testobj { - list [testdoubleobj set 1 12.34] \ - [catch {testobj convert 1 end-offset} msg] \ - $msg -} {12.34 1 {bad index "12.34": must be end?[+-]integer?}} -test obj-3.2 {Tcl_ConvertToType error, "empty string" object} testobj { - list [testobj newobj 1] [catch {testobj convert 1 end-offset} msg] $msg -} {{} 1 {bad index "": must be end?[+-]integer?}} - test obj-4.1 {Tcl_NewObj and AllocateFreeObjects} testobj { set result "" lappend result [testobj freeallvars] @@ -551,43 +541,6 @@ test obj-30.1 {Ref counting and object deletion, simple types} testobj { } {{} 1024 1024 int 4 4 0 int 3 2} -test obj-31.1 {regenerate string rep of "end"} testobj { - testobj freeallvars - teststringobj set 1 end - testobj convert 1 end-offset - testobj invalidateStringRep 1 -} end -test obj-31.2 {regenerate string rep of "end-1"} testobj { - testobj freeallvars - teststringobj set 1 end-0x1 - testobj convert 1 end-offset - testobj invalidateStringRep 1 -} end-1 -test obj-31.3 {regenerate string rep of "end--1"} testobj { - testobj freeallvars - teststringobj set 1 end--0x1 - testobj convert 1 end-offset - testobj invalidateStringRep 1 -} end--1 -test obj-31.4 {regenerate string rep of "end-bigInteger"} testobj { - testobj freeallvars - teststringobj set 1 end-0x7fffffff - testobj convert 1 end-offset - testobj invalidateStringRep 1 -} end-2147483647 -test obj-31.5 {regenerate string rep of "end--bigInteger"} testobj { - testobj freeallvars - teststringobj set 1 end--0x7fffffff - testobj convert 1 end-offset - testobj invalidateStringRep 1 -} end--2147483647 -test obj-31.6 {regenerate string rep of "end--bigInteger"} {testobj longIs32bit} { - testobj freeallvars - teststringobj set 1 end--0x80000000 - testobj convert 1 end-offset - testobj invalidateStringRep 1 -} end--2147483648 - test obj-32.1 {freeing very large object trees} { set x {} for {set i 0} {$i<100000} {incr i} { -- cgit v0.12 From 6faf2feff2aa8ca778eccc29cb8c43c14ea6199d Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 23 Feb 2018 17:49:23 +0000 Subject: Don't let presence of a string rep prevent optimizations on "pure" bytearrays. --- generic/tclStringObj.c | 32 ++++++++++++++------------------ 1 file changed, 14 insertions(+), 18 deletions(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index f527426..26a3a28 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -481,8 +481,7 @@ Tcl_GetUniChar( /* * 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 indexing operation. + * we don't need to convert to a string to perform the indexing operation. */ if (TclIsPureByteArray(objPtr)) { @@ -615,8 +614,7 @@ Tcl_GetRange( /* * 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 substring operation. + * we don't need to convert to a string to perform the substring operation. */ if (TclIsPureByteArray(objPtr)) { @@ -1224,9 +1222,9 @@ Tcl_AppendObjToObj( /* * Handle append of one bytearray object to another as a special case. - * Note that we only do this when the objects don't have string reps; if - * it did, then appending the byte arrays together could well lose - * information; this is a special-case optimization only. + * Note that we only do this when the objects are pure so that the + * bytearray faithfully represent the true value; Otherwise + * appending the byte arrays together could lose information; */ if ((TclIsPureByteArray(objPtr) || objPtr->bytes == &tclEmptyString) @@ -2915,7 +2913,9 @@ TclStringCat( do { Tcl_Obj *objPtr = *ov++; - if (objPtr->bytes) { + if (TclIsPureByteArray(objPtr)) { + allowUniChar = 0; + } else if (objPtr->bytes) { /* Value has a string rep. */ if (objPtr->length) { /* @@ -2930,17 +2930,13 @@ TclStringCat( } } else { /* assert (objPtr->typePtr != NULL) -- stork! */ - if (TclIsPureByteArray(objPtr)) { - allowUniChar = 0; + binary = 0; + if (objPtr->typePtr == &tclStringType) { + /* Have a pure Unicode value; ask to preserve it */ + requestUniChar = 1; } 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; - } + /* Have another type; prevent shimmer */ + allowUniChar = 0; } } } while (--oc && (binary || allowUniChar)); -- cgit v0.12 From 0bceead396460bd96a148e6a6c9e55acc1ed7311 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 27 Feb 2018 20:30:00 +0000 Subject: No need to set/restore tcl_precision in this test-case --- tests/basic.test | 10 +++------- 1 file changed, 3 insertions(+), 7 deletions(-) diff --git a/tests/basic.test b/tests/basic.test index d47613a..0e4ddea 100644 --- a/tests/basic.test +++ b/tests/basic.test @@ -893,21 +893,17 @@ test basic-48.16.$noComp {expansion: testing for leaks} -setup { rename stress {} } -result 0 -test basic-48.17.$noComp {expansion: object safety} -setup { - set old_precision $::tcl_precision - set ::tcl_precision 4 - } -constraints $constraints -body { +test basic-48.17.$noComp {expansion: object safety} -constraints $constraints -body { set third [expr {1.0/3.0}] set l [list $third $third] set x [run {list $third {*}$l $third}] - set res [list] + set res [list] foreach t $x { lappend res [expr {$t * 3.0}] } set res } -cleanup { - set ::tcl_precision $old_precision - unset old_precision res t l x third + unset res t l x third } -result {1.0 1.0 1.0 1.0} test basic-48.18.$noComp {expansion: list semantics} -constraints $constraints -body { -- cgit v0.12 From 9a809e614ae7603730d8cc5f60b454b66dffa972 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 27 Feb 2018 20:48:00 +0000 Subject: Use mp_isneg() in stead of mp_cmp_d() when the output of this function is simply compared with MP_LT. --- generic/tclBasic.c | 2 +- generic/tclExecute.c | 18 +++++++++--------- generic/tclScan.c | 2 +- generic/tclStrToD.c | 4 ++-- 4 files changed, 13 insertions(+), 13 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index a182139..3d16b70 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -7527,7 +7527,7 @@ ExprAbsFunc( } if (type == TCL_NUMBER_BIG) { - if (mp_cmp_d((const mp_int *) ptr, 0) == MP_LT) { + if (mp_isneg((const mp_int *) ptr)) { Tcl_GetBignumFromObj(NULL, objv[1], &big); tooLarge: mp_neg(&big, &big); diff --git a/generic/tclExecute.c b/generic/tclExecute.c index a83023c..1c69474 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -8092,7 +8092,7 @@ ExecuteExtendedBinaryMathOp( break; case TCL_NUMBER_BIG: Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - invalid = (mp_cmp_d(&big2, 0) == MP_LT); + invalid = mp_isneg(&big2); mp_clear(&big2); break; default: @@ -8171,7 +8171,7 @@ ExecuteExtendedBinaryMathOp( break; case TCL_NUMBER_BIG: Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); - zero = (mp_cmp_d(&big1, 0) == MP_GT); + zero = (!mp_isneg(&big1)); mp_clear(&big1); break; default: @@ -8209,7 +8209,7 @@ ExecuteExtendedBinaryMathOp( } else { mp_init(&bigRemainder); mp_div_2d(&big1, shift, &bigResult, &bigRemainder); - if (mp_cmp_d(&bigRemainder, 0) == MP_LT) { + if (mp_isneg(&bigRemainder)) { /* * Convert to Tcl's integer division rules. */ @@ -8236,14 +8236,14 @@ ExecuteExtendedBinaryMathOp( * arguments is negative, store it in 'Second'. */ - if (mp_cmp_d(&big1, 0) != MP_LT) { - numPos = 1 + (mp_cmp_d(&big2, 0) != MP_LT); + if (!mp_isneg(&big1)) { + numPos = 1 + !mp_isneg(&big2); First = &big1; Second = &big2; } else { First = &big2; Second = &big1; - numPos = (mp_cmp_d(First, 0) != MP_LT); + numPos = (!mp_isneg(First)); } mp_init(&bigResult); @@ -8445,7 +8445,7 @@ ExecuteExtendedBinaryMathOp( break; case TCL_NUMBER_BIG: Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - negativeExponent = (mp_cmp_d(&big2, 0) == MP_LT); + negativeExponent = mp_isneg(&big2); mp_mod_2d(&big2, 1, &big2); oddExponent = !mp_iszero(&big2); mp_clear(&big2); @@ -8995,7 +8995,7 @@ TclCompareTwoNumbers( goto wideCompare; case TCL_NUMBER_BIG: Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - if (mp_cmp_d(&big2, 0) == MP_LT) { + if (mp_isneg(&big2)) { compare = MP_GT; } else { compare = MP_LT; @@ -9032,7 +9032,7 @@ TclCompareTwoNumbers( } Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); if ((d1 < (double)LONG_MAX) && (d1 > (double)LONG_MIN)) { - if (mp_cmp_d(&big2, 0) == MP_LT) { + if (mp_isneg(&big2)) { compare = MP_GT; } else { compare = MP_LT; diff --git a/generic/tclScan.c b/generic/tclScan.c index 25c6c2b..d55d29b 100644 --- a/generic/tclScan.c +++ b/generic/tclScan.c @@ -942,7 +942,7 @@ Tcl_ScanObjCmd( if (flags & SCAN_UNSIGNED) { mp_int big; if ((Tcl_GetBignumFromObj(interp, objPtr, &big) != TCL_OK) - || (mp_cmp_d(&big, 0) == MP_LT)) { + || mp_isneg(&big)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "unsigned bignum scans are invalid", -1)); Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADUNSIGNED",NULL); diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index ac2ca68..0434919 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -4697,7 +4697,7 @@ TclCeil( mp_int b; mp_init(&b); - if (mp_cmp_d(a, 0) == MP_LT) { + if (mp_isneg(a)) { mp_neg(a, &b); r = -TclFloor(&b); } else { @@ -4754,7 +4754,7 @@ TclFloor( mp_int b; mp_init(&b); - if (mp_cmp_d(a, 0) == MP_LT) { + if (mp_isneg(a)) { mp_neg(a, &b); r = -TclCeil(&b); } else { -- cgit v0.12