From 3a8a841386b2df65eca6c7018106438bc7c6d07d Mon Sep 17 00:00:00 2001 From: sebres Date: Mon, 8 Apr 2019 15:03:13 +0000 Subject: closes [45b9faf103f2] (tclVar cached lookup): fixes segfaulting if variable released before set; partially revert [4100488a3ca38abf] --- generic/tclCmdMZ.c | 6 ------ generic/tclVar.c | 11 +++++++++-- 2 files changed, 9 insertions(+), 8 deletions(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 5eb854b..2671d49 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -4812,24 +4812,18 @@ TryPostBody( Tcl_Obj *varName; Tcl_ListObjIndex(NULL, info[3], 0, &varName); - Tcl_IncrRefCount(varName); if (Tcl_ObjSetVar2(interp, varName, NULL, resultObj, TCL_LEAVE_ERR_MSG) == NULL) { - Tcl_DecrRefCount(varName); Tcl_DecrRefCount(resultObj); goto handlerFailed; } - Tcl_DecrRefCount(varName); Tcl_DecrRefCount(resultObj); if (dummy > 1) { Tcl_ListObjIndex(NULL, info[3], 1, &varName); - Tcl_IncrRefCount(varName); if (Tcl_ObjSetVar2(interp, varName, NULL, options, TCL_LEAVE_ERR_MSG) == NULL) { - Tcl_DecrRefCount(varName); goto handlerFailed; } - Tcl_DecrRefCount(varName); } } else { /* diff --git a/generic/tclVar.c b/generic/tclVar.c index 3271935..affc848 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -722,7 +722,7 @@ TclObjLookupVarEx( Tcl_Obj *cachedNamePtr = localName(varFramePtr, index); if (part1Ptr == cachedNamePtr) { - cachedNamePtr = NULL; + LocalSetIntRep(part1Ptr, index, NULL); } else { /* * [80304238ac] Trickiness here. We will store and incr the @@ -735,6 +735,14 @@ TclObjLookupVarEx( * cachedNamePtr and leave it as string only. This is * radical and destructive, so a better idea would be welcome. */ + + /* + * Firstly set cached local var reference (avoid free before set, + * see [45b9faf103f2]) + */ + LocalSetIntRep(part1Ptr, index, cachedNamePtr); + + /* Then wipe it */ TclFreeIntRep(cachedNamePtr); /* @@ -744,7 +752,6 @@ TclObjLookupVarEx( */ LocalSetIntRep(cachedNamePtr, index, NULL); } - LocalSetIntRep(part1Ptr, index, cachedNamePtr); } else { /* * At least mark part1Ptr as already parsed. -- cgit v0.12 From 1749b4cc870fc9ff5bdb398dca162d97eed9f28c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 8 Apr 2019 19:31:10 +0000 Subject: Add test-cases for win32/win64 --disable-shared, and put standard --enable-threads --- .travis.yml | 35 +++++++++++++++++++++++++++++++++-- 1 file changed, 33 insertions(+), 2 deletions(-) diff --git a/.travis.yml b/.travis.yml index 8a7484f..b46bc26 100644 --- a/.travis.yml +++ b/.travis.yml @@ -108,7 +108,23 @@ matrix: - wine env: - BUILD_DIR=win - - CFGOPT=--host=i686-w64-mingw32 + - CFGOPT="--host=i686-w64-mingw32 --enable-threads" + - NO_DIRECT_TEST=1 + - os: linux + dist: xenial + compiler: i686-w64-mingw32-gcc + addons: + apt: + packages: + - gcc-mingw-w64-base + - binutils-mingw-w64-i686 + - gcc-mingw-w64-i686 + - gcc-mingw-w64 + - gcc-multilib + - wine + env: + - BUILD_DIR=win + - CFGOPT="--host=i686-w64-mingw32 --disable-shared --enable-threads" - NO_DIRECT_TEST=1 # Test with mingw-w64 (64 bit) - os: linux @@ -124,7 +140,22 @@ matrix: - wine env: - BUILD_DIR=win - - CFGOPT="--host=x86_64-w64-mingw32 --enable-64bit" + - CFGOPT="--host=x86_64-w64-mingw32 --enable-64bit --enable-threads" + - NO_DIRECT_TEST=1 + - os: linux + dist: xenial + compiler: x86_64-w64-mingw32-gcc + addons: + apt: + packages: + - gcc-mingw-w64-base + - binutils-mingw-w64-x86-64 + - gcc-mingw-w64-x86-64 + - gcc-mingw-w64 + - wine + env: + - BUILD_DIR=win + - CFGOPT="--host=x86_64-w64-mingw32 --enable-64bit --enable-threads --disable-shared" - NO_DIRECT_TEST=1 before_install: -- cgit v0.12 From 6ed025f0c6dbc01511a05bd87be92dc7d3dbb77d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 8 Apr 2019 21:25:33 +0000 Subject: Fix clang compiler warning in tclZlib.c. Clear execute bit in two encodings --- generic/tclZlib.c | 2 +- tools/encoding/ebcdic.txt | 0 tools/encoding/tis-620.txt | 0 3 files changed, 1 insertion(+), 1 deletion(-) mode change 100755 => 100644 tools/encoding/ebcdic.txt mode change 100755 => 100644 tools/encoding/tis-620.txt diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 5a7abec..8dbe807 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -422,7 +422,7 @@ GenerateHeader( { Tcl_Obj *value; int len, result = TCL_ERROR; - Tcl_WideInt wideValue; + Tcl_WideInt wideValue = 0; const char *valueStr; Tcl_Encoding latin1enc; static const char *const types[] = { diff --git a/tools/encoding/ebcdic.txt b/tools/encoding/ebcdic.txt old mode 100755 new mode 100644 diff --git a/tools/encoding/tis-620.txt b/tools/encoding/tis-620.txt old mode 100755 new mode 100644 -- cgit v0.12 From 9b1a75a1ccbda9eaf0bb030215b7e6181d51f487 Mon Sep 17 00:00:00 2001 From: andy Date: Tue, 9 Apr 2019 03:11:14 +0000 Subject: Correct minor documentation typo --- doc/interp.n | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/interp.n b/doc/interp.n index 92113a6..1c9618a 100644 --- a/doc/interp.n +++ b/doc/interp.n @@ -201,7 +201,7 @@ slave interpreter identified by \fIpath\fR. If no arguments are given, option and current setting are returned. If \fB\-frame\fR is given, the debug setting is set to the given boolean if provided and the current setting is returned. -This only effects the output of \fBinfo frame\fR, in that exact +This only affects the output of \fBinfo frame\fR, in that exact frame-level information for command invocation at the bytecode level is only captured with this setting on. .RS -- cgit v0.12 From d96dda52c403f620a9fd1ae77fe07e1505d0efe2 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 9 Apr 2019 09:11:31 +0000 Subject: Added missing test case --- tests/oo.test | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) diff --git a/tests/oo.test b/tests/oo.test index db5c14f..b0704da 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -1480,6 +1480,30 @@ test oo-10.3 {OO: invoke and modify} -setup { oo::define B deletemethod b c lappend result [C a] [C b] [C c] } -result {A.a,B.a A.b,B.b A.c,B.c - A.a,B.a A.b A.c,B.c - A.a A.b,B.a A.c,B.c - A.a A.b A.c} +test oo-10.4 {OO: invoke and modify} -setup { + oo::class create A { + method a {} {return A.a} + method b {} {return A.b} + method c {} {return A.c} + } + A create B + oo::objdefine B { + method a {} {return [next],B.a} + method b {} {return [next],B.b} + method c {} {return [next],B.c} + } + set result {} +} -cleanup { + A destroy +} -body { + lappend result [B a] [B b] [B c] - + oo::objdefine B deletemethod b + lappend result [B a] [B b] [B c] - + oo::objdefine B renamemethod a b + lappend result [B a] [B b] [B c] - + oo::objdefine B deletemethod b c + lappend result [B a] [B b] [B c] +} -result {A.a,B.a A.b,B.b A.c,B.c - A.a,B.a A.b A.c,B.c - A.a A.b,B.a A.c,B.c - A.a A.b A.c} test oo-11.1 {OO: cleanup} { oo::object create foo -- cgit v0.12 From 747b6686767cb90fc12954020dd16855dbb3a885 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 9 Apr 2019 09:18:59 +0000 Subject: Clarified some documentation --- doc/define.n | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/doc/define.n b/doc/define.n index e619728..ad991e1 100644 --- a/doc/define.n +++ b/doc/define.n @@ -55,7 +55,8 @@ string, the constructor will be deleted. This deletes each of the methods called \fIname\fR from a class. The methods must have previously existed in that class. Does not affect the superclasses of the class, nor does it affect the subclasses or instances of the class -(except when they have a call chain through the class being modified). +(except when they have a call chain through the class being modified) or the +class object itself. .TP \fBdestructor\fI bodyScript\fR . @@ -135,7 +136,8 @@ This renames the method called \fIfromName\fR in a class to \fItoName\fR. The method must have previously existed in the class, and \fItoName\fR must not previously refer to a method in that class. Does not affect the superclasses of the class, nor does it affect the subclasses or instances of the class -(except when they have a call chain through the class being modified). Does +(except when they have a call chain through the class being modified), or the +class object itself. Does not change the export status of the method; if it was exported before, it will be afterwards. .TP @@ -203,8 +205,10 @@ well be in an inconsistent state unless additional configuration work is done. \fBdeletemethod\fI name\fR ?\fIname ...\fR . This deletes each of the methods called \fIname\fR from an object. The methods -must have previously existed in that object. Does not affect the classes that -the object is an instance of. +must have previously existed in that object (e.g., because it was created +through \fBoo::objdefine method\fR). Does not affect the classes that the +object is an instance of, or remove the exposure of those class-provided +methods in the instance of that class. .TP \fBexport\fI name \fR?\fIname ...\fR? . @@ -262,8 +266,10 @@ By default, this slot works by replacement. This renames the method called \fIfromName\fR in an object to \fItoName\fR. The method must have previously existed in the object, and \fItoName\fR must not previously refer to a method in that object. Does not affect the classes -that the object is an instance of. Does not change the export status of the -method; if it was exported before, it will be afterwards. +that the object is an instance of and cannot rename in an instance object the +methods provided by those classes (though a \fBoo::objdefine forward\fRed +method may provide an equivalent capability). Does not change the export +status of the method; if it was exported before, it will be afterwards. .TP \fBunexport\fI name \fR?\fIname ...\fR? . -- cgit v0.12 From f2c8c6c408d10fd1049ebab13794e83731d7bd90 Mon Sep 17 00:00:00 2001 From: sebres Date: Tue, 9 Apr 2019 10:31:36 +0000 Subject: closes [1e5e25cf2b] - tests/cmdMZ.test: fixed NRT-related sleeps (and time-related corner cases and test expectations); todo: rewrite several tests if monotonic clock is provided resp. command "after" gets microsecond accuracy (RFE [fdfbd5e10] gets merged) --- tests/cmdMZ.test | 30 +++++++++++++++++++----------- 1 file changed, 19 insertions(+), 11 deletions(-) diff --git a/tests/cmdMZ.test b/tests/cmdMZ.test index d1f0a44..2ac74cd 100644 --- a/tests/cmdMZ.test +++ b/tests/cmdMZ.test @@ -321,6 +321,14 @@ test cmdMZ-4.13 {Tcl_SplitObjCmd: basic split commands} { # The tests for Tcl_SubstObjCmd are in subst.test # The tests for Tcl_SwitchObjCmd are in switch.test +# todo: rewrite this if monotonic clock is provided resp. command "after" +# gets microsecond accuracy (RFE [fdfbd5e10] gets merged): +proc _nrt_sleep {msec} { + set usec [expr {$msec * 1000}] + set stime [clock microseconds] + while {abs([clock microseconds] - $stime) < $usec} {after 0} +} + test cmdMZ-5.1 {Tcl_TimeObjCmd: basic format of command} { list [catch {time} msg] $msg } {1 {wrong # args: should be "time command ?count?"}} @@ -337,7 +345,7 @@ test cmdMZ-5.5 {Tcl_TimeObjCmd: result format} { regexp {^\d+ microseconds per iteration} [time {format 1}] } 1 test cmdMZ-5.6 {Tcl_TimeObjCmd: slower commands take longer} { - expr {[lindex [time {after 2}] 0] < [lindex [time {after 1000}] 0]} + expr {[lindex [time {_nrt_sleep 1}] 0] < [lindex [time {_nrt_sleep 20}] 0]} } 1 test cmdMZ-5.7 {Tcl_TimeObjCmd: errors generate right trace} { list [catch {time {error foo}} msg] $msg $::errorInfo @@ -372,18 +380,18 @@ test cmdMZ-6.5b {Tcl_TimeRateObjCmd: result format without iterations} { regexp {^0 \ws/# 0 # 0 #/sec 0 nett-ms$} [timerate {} 0 0] } 1 test cmdMZ-6.6 {Tcl_TimeRateObjCmd: slower commands take longer, but it remains almost the same time of measument} { - set m1 [timerate {after 0} 20] - set m2 [timerate {after 1} 20] + set m1 [timerate {_nrt_sleep 0} 20] + set m2 [timerate {_nrt_sleep 0.2} 20] list \ [expr {[lindex $m1 0] < [lindex $m2 0]}] \ [expr {[lindex $m1 0] < 100}] \ - [expr {[lindex $m2 0] >= 500}] \ + [expr {[lindex $m2 0] > 100}] \ [expr {[lindex $m1 2] > 1000}] \ - [expr {[lindex $m2 2] <= 50}] \ - [expr {[lindex $m1 4] > 10000}] \ - [expr {[lindex $m2 4] < 10000}] \ - [expr {[lindex $m1 6] > 10 && [lindex $m1 6] < 50}] \ - [expr {[lindex $m2 6] > 10 && [lindex $m2 6] < 50}] + [expr {[lindex $m2 2] < 1000}] \ + [expr {[lindex $m1 4] > 50000}] \ + [expr {[lindex $m2 4] < 50000}] \ + [expr {[lindex $m1 6] > 10 && [lindex $m1 6] < 100}] \ + [expr {[lindex $m2 6] > 10 && [lindex $m2 6] < 100}] } [lrepeat 9 1] test cmdMZ-6.7 {Tcl_TimeRateObjCmd: errors generate right trace} { list [catch {timerate {error foo} 1} msg] $msg $::errorInfo @@ -402,11 +410,11 @@ test cmdMZ-6.8 {Tcl_TimeRateObjCmd: allow (conditional) break from timerate} { } {1 1 1 1} test cmdMZ-6.9 {Tcl_TimeRateObjCmd: max count of iterations} { set m1 [timerate {} 1000 5]; # max-count wins - set m2 [timerate {after 20} 1 5]; # max-time wins + set m2 [timerate {_nrt_sleep 20} 1 5]; # max-time wins list [lindex $m1 2] [lindex $m2 2] } {5 1} test cmdMZ-6.10 {Tcl_TimeRateObjCmd: huge overhead cause 0us result} { - set m1 [timerate -overhead 1e6 {after 10} 100 1] + set m1 [timerate -overhead 1e6 {_nrt_sleep 10} 100 1] list \ [expr {[lindex $m1 0] == 0.0}] \ [expr {[lindex $m1 2] == 1}] \ -- cgit v0.12 From 6fb4854406b2c9cf6a6496ffaa026fcf0e3e065a Mon Sep 17 00:00:00 2001 From: sebres Date: Tue, 9 Apr 2019 19:37:55 +0000 Subject: closes [940ce8f958] - tests/cmdMZ.test: avoid import timerate to global NS in tests (e. g. using tcltest -singleproc 1 -file 'cmdMZ* namespace*') --- tests/cmdMZ.test | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/tests/cmdMZ.test b/tests/cmdMZ.test index 2ac74cd..4c4f532 100644 --- a/tests/cmdMZ.test +++ b/tests/cmdMZ.test @@ -24,6 +24,10 @@ namespace eval ::tcl::test::cmdMZ { namespace import ::tcltest::temporaryDirectory namespace import ::tcltest::test + if {[namespace which -command ::tcl::unsupported::timerate] ne ""} { + namespace import ::tcl::unsupported::timerate + } + # Tcl_PwdObjCmd test cmdMZ-1.1 {Tcl_PwdObjCmd} { -- cgit v0.12 From 7df97e929223d6b0ff18cbfaad9809c18e11c3ff Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 11 Apr 2019 20:09:27 +0000 Subject: Only use special mp_sqrt() code when double format/tommath format are exactly what's expected. Otherwise, use original always-working tommath code. Simplify overflow check in bignum expononent code, not using bignums where it's not necessary. Don't overallocate bignums when using wideint's only. --- generic/tclExecute.c | 20 ++++++++------------ generic/tclTomMathInterface.c | 6 ++---- libtommath/bn_mp_set_double.c | 4 ++-- libtommath/bn_mp_sqrt.c | 22 +++++++++++++++------- 4 files changed, 27 insertions(+), 25 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 4c36123..a4a4646 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -6032,7 +6032,7 @@ TEBCresume( /* [string is integer] is -UINT_MAX to UINT_MAX range */ int i; - if (Tcl_GetIntFromObj(NULL, OBJ_AT_TOS, &i) != TCL_OK) { + if (TclGetIntFromObj(NULL, OBJ_AT_TOS, &i) != TCL_OK) { type1 = TCL_NUMBER_WIDE; } #ifndef TCL_WIDE_INT_IS_LONG @@ -6040,7 +6040,7 @@ TEBCresume( /* value is between WIDE_MIN and WIDE_MAX */ /* [string is wideinteger] is -UWIDE_MAX to UWIDE_MAX range */ int i; - if (Tcl_GetIntFromObj(NULL, OBJ_AT_TOS, &i) == TCL_OK) { + if (TclGetIntFromObj(NULL, OBJ_AT_TOS, &i) == TCL_OK) { type1 = TCL_NUMBER_LONG; } #endif @@ -6049,7 +6049,7 @@ TEBCresume( /* [string is wideinteger] is -UWIDE_MAX to UWIDE_MAX range */ Tcl_WideInt w; - if (Tcl_GetWideIntFromObj(NULL, OBJ_AT_TOS, &w) == TCL_OK) { + if (TclGetWideIntFromObj(NULL, OBJ_AT_TOS, &w) == TCL_OK) { type1 = TCL_NUMBER_WIDE; } } @@ -8984,22 +8984,18 @@ ExecuteExtendedBinaryMathOp( #endif overflowExpon: - Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - if ((big2.used > 1) -#if DIGIT_BIT > 28 - || ((big2.used == 1) && (big2.dp[0] >= (1<<28))) -#endif - ) { - mp_clear(&big2); + + if ((TclGetWideIntFromObj(NULL, value2Ptr, &w2) != TCL_OK) + || (value2Ptr->typePtr != &tclIntType) + || (Tcl_WideUInt)w2 >= (1<<28)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "exponent too large", -1)); return GENERAL_ARITHMETIC_ERROR; } Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); mp_init(&bigResult); - mp_expt_d(&big1, big2.dp[0], &bigResult); + mp_expt_d(&big1, w2, &bigResult); mp_clear(&big1); - mp_clear(&big2); BIG_RESULT(&bigResult); } diff --git a/generic/tclTomMathInterface.c b/generic/tclTomMathInterface.c index d7da4ee..902fd8d 100644 --- a/generic/tclTomMathInterface.c +++ b/generic/tclTomMathInterface.c @@ -119,8 +119,7 @@ TclBNInitBignumFromLong( * Allocate enough memory to hold the largest possible long */ - status = mp_init_size(a, - (CHAR_BIT * sizeof(long) + DIGIT_BIT - 1) / DIGIT_BIT); + status = mp_init(a); if (status != MP_OKAY) { Tcl_Panic("initialization failure in TclBNInitBignumFromLong"); } @@ -206,8 +205,7 @@ TclBNInitBignumFromWideUInt( * Allocate enough memory to hold the largest possible Tcl_WideUInt. */ - status = mp_init_size(a, - (CHAR_BIT * sizeof(Tcl_WideUInt) + DIGIT_BIT - 1) / DIGIT_BIT); + status = mp_init(a); if (status != MP_OKAY) { Tcl_Panic("initialization failure in TclBNInitBignumFromWideUInt"); } diff --git a/libtommath/bn_mp_set_double.c b/libtommath/bn_mp_set_double.c index c96a3b3..12f8dad 100644 --- a/libtommath/bn_mp_set_double.c +++ b/libtommath/bn_mp_set_double.c @@ -15,11 +15,11 @@ #if defined(__STDC_IEC_559__) || defined(__GCC_IEC_559) int mp_set_double(mp_int *a, double b) { - uint64_t frac; + unsigned long long frac; int exp, res; union { double dbl; - uint64_t bits; + unsigned long long bits; } cast; cast.dbl = b; diff --git a/libtommath/bn_mp_sqrt.c b/libtommath/bn_mp_sqrt.c index bbca158..116fb14 100644 --- a/libtommath/bn_mp_sqrt.c +++ b/libtommath/bn_mp_sqrt.c @@ -14,6 +14,9 @@ #ifndef NO_FLOATING_POINT #include +#if (DIGIT_BIT != 28) || (FLT_RADIX != 2) || (DBL_MANT_DIG != 53) || (DBL_MAX_EXP != 1024) +#define NO_FLOATING_POINT +#endif #endif /* this function is less generic than mp_n_root, simpler and faster */ @@ -21,8 +24,8 @@ int mp_sqrt(const mp_int *arg, mp_int *ret) { int res; mp_int t1, t2; - int i, j, k; #ifndef NO_FLOATING_POINT + int i, j, k; volatile double d; mp_digit dig; #endif @@ -38,6 +41,8 @@ int mp_sqrt(const mp_int *arg, mp_int *ret) return MP_OKAY; } +#ifndef NO_FLOATING_POINT + i = (arg->used / 2) - 1; j = 2 * i; if ((res = mp_init_size(&t1, i+2)) != MP_OKAY) { @@ -52,8 +57,6 @@ int mp_sqrt(const mp_int *arg, mp_int *ret) t1.dp[k] = (mp_digit) 0; } -#ifndef NO_FLOATING_POINT - /* Estimate the square root using the hardware floating point unit. */ d = 0.0; @@ -96,11 +99,16 @@ int mp_sqrt(const mp_int *arg, mp_int *ret) #else - /* Estimate the square root as having 1 in the most significant place. */ + if ((res = mp_init_copy(&t1, arg)) != MP_OKAY) { + return res; + } + + if ((res = mp_init(&t2)) != MP_OKAY) { + goto E2; + } - t1.used = i + 2; - t1.dp[i+1] = (mp_digit) 1; - t1.dp[i] = (mp_digit) 0; + /* First approx. (not very bad for large arg) */ + mp_rshd(&t1, t1.used/2); #endif -- cgit v0.12