From 496282eb49d6e1f93e445ed27bbdefda520a1dc5 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 1 Sep 2014 08:11:52 +0000 Subject: Combine TCL_SHLIB_LD_EXTRAS+TK_SHLIB_LD_EXTRAS (for Cygwin and FreeBSD) to a single SHLIB_LD_LIBS usable for both Tcl and Tk. --- unix/configure | 6 ++---- unix/tcl.m4 | 6 ++---- 2 files changed, 4 insertions(+), 8 deletions(-) diff --git a/unix/configure b/unix/configure index e4ff106..d11e7d2 100755 --- a/unix/configure +++ b/unix/configure @@ -6938,8 +6938,7 @@ fi LD_SEARCH_FLAGS="" TCL_NEEDS_EXP_FILE=1 TCL_EXPORT_FILE_SUFFIX='${VERSION}\$\{DBGX\}.dll.a' - TCL_SHLIB_LD_EXTRAS='-Wl,--out-implib,$@.a' - TK_SHLIB_LD_EXTRAS='-Wl,--out-implib,$@.a' + SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -Wl,--out-implib,\$@.a" echo "$as_me:$LINENO: checking for Cygwin version of gcc" >&5 echo $ECHO_N "checking for Cygwin version of gcc... $ECHO_C" >&6 if test "${ac_cv_cygwin+set}" = set; then @@ -7644,8 +7643,7 @@ fi # This configuration from FreeBSD Ports. SHLIB_CFLAGS="-fPIC" SHLIB_LD="${CC} -shared" - TCL_SHLIB_LD_EXTRAS="-Wl,-soname,\$@" - TK_SHLIB_LD_EXTRAS="-Wl,-soname,\$@" + SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -Wl,-soname,\$@" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" diff --git a/unix/tcl.m4 b/unix/tcl.m4 index b6c86b6..437ce3d 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -1246,8 +1246,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ LD_SEARCH_FLAGS="" TCL_NEEDS_EXP_FILE=1 TCL_EXPORT_FILE_SUFFIX='${VERSION}\$\{DBGX\}.dll.a' - TCL_SHLIB_LD_EXTRAS='-Wl,--out-implib,$[@].a' - TK_SHLIB_LD_EXTRAS='-Wl,--out-implib,$[@].a' + SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -Wl,--out-implib,\$[@].a" AC_CACHE_CHECK(for Cygwin version of gcc, ac_cv_cygwin, AC_TRY_COMPILE([ @@ -1555,8 +1554,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ # This configuration from FreeBSD Ports. SHLIB_CFLAGS="-fPIC" SHLIB_LD="${CC} -shared" - TCL_SHLIB_LD_EXTRAS="-Wl,-soname,\$[@]" - TK_SHLIB_LD_EXTRAS="-Wl,-soname,\$[@]" + SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -Wl,-soname,\$[@]" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" -- cgit v0.12 From b15ae226b92170c6bdb640bf648891cfc177a956 Mon Sep 17 00:00:00 2001 From: ferrieux Date: Tue, 2 Sep 2014 21:57:20 +0000 Subject: Add test cases in very first position for hang-on-exit, both in (normal) quick-exit and TCL_FINALIZE_ON_EXIT=1 modes. --- tests/aaa_exit.test | 41 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 41 insertions(+) create mode 100644 tests/aaa_exit.test diff --git a/tests/aaa_exit.test b/tests/aaa_exit.test new file mode 100644 index 0000000..51a94d7 --- /dev/null +++ b/tests/aaa_exit.test @@ -0,0 +1,41 @@ +# Commands covered: exit, emphasis on finalization hangs +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994-1997 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# +# 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 2 + namespace import -force ::tcltest::* +} + + +test exit-1.1 {normal, quick exit} { + set f [open "|[interpreter] << \"exec [interpreter] << {set ::env(TCL_FINALIZE_ON_EXIT) 0;exit}\" 2>@ stderr" r] + set aft [after 5000 {set done "Quick exit hangs !!!"}] + fileevent $f readable {after cancel $aft;set done OK} + vwait done + catch {fconfigure $f -blocking 0;close $f} + set done +} OK + +test exit-1.2 {full-finalized exit} { + set f [open "|[interpreter] << \"exec [interpreter] << {set ::env(TCL_FINALIZE_ON_EXIT) 1;exit}\" 2>@ stderr" r] + set aft [after 5000 {set done "Full-finalized exit hangs !!!"}] + fileevent $f readable {after cancel $aft;set done OK} + vwait done + catch {fconfigure $f -blocking 0;close $f} + set done +} OK + + +# cleanup +::tcltest::cleanupTests +return -- cgit v0.12 From a4a3d764f5bc4047858e2a14a54d26c55b1cf0c0 Mon Sep 17 00:00:00 2001 From: ferrieux Date: Tue, 2 Sep 2014 22:00:03 +0000 Subject: Refrain from calling TclFinalizeThreadData() in quick-exit case as it is useless (just memory freeing). Superficially fixes [Bug 132fad6f]; that bug is still exerciseable thanks to recent additions to the test suite that exercise full finalization. --- generic/tclEvent.c | 24 +++++++++++++----------- 1 file changed, 13 insertions(+), 11 deletions(-) diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 941d566..ab219a6 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -1299,18 +1299,20 @@ Tcl_FinalizeThread(void) TclFinalizeAsync(); TclFinalizeThreadObjects(); } + if (TclFullFinalizationRequested()) { /* useless if we are facing a quick-exit */ - /* - * Blow away all thread local storage blocks. - * - * Note that Tcl API allows creation of threads which do not use any Tcl - * interp or other Tcl subsytems. Those threads might, however, use thread - * local storage, so we must unconditionally finalize it. - * - * Fix [Bug #571002] - */ - - TclFinalizeThreadData(); + /* + * Blow away all thread local storage blocks. + * + * Note that Tcl API allows creation of threads which do not use any Tcl + * interp or other Tcl subsytems. Those threads might, however, use thread + * local storage, so we must unconditionally finalize it. + * + * Fix [Bug #571002] + */ + + TclFinalizeThreadData(); + } } /* -- cgit v0.12 From 497aa76e901586dee5b41e797c50da9fb9d8f569 Mon Sep 17 00:00:00 2001 From: ashok Date: Wed, 3 Sep 2014 15:48:56 +0000 Subject: [132fad6fde]. Fixed GetCache to use TclpSysAlloc+memset instead of calloc. Now consistent with tclWinThrd.c which no longer uses malloc in its TclpSysAlloc implementation. --- generic/tclThreadAlloc.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/generic/tclThreadAlloc.c b/generic/tclThreadAlloc.c index 5cb8027..560556d 100644 --- a/generic/tclThreadAlloc.c +++ b/generic/tclThreadAlloc.c @@ -217,10 +217,11 @@ GetCache(void) cachePtr = TclpGetAllocCache(); if (cachePtr == NULL) { - cachePtr = calloc(1, sizeof(Cache)); + cachePtr = TclpSysAlloc(sizeof(Cache), 0); if (cachePtr == NULL) { Tcl_Panic("alloc: could not allocate new cache"); } + memset(cachePtr, 0, sizeof(Cache)); Tcl_MutexLock(listLockPtr); cachePtr->nextPtr = firstCachePtr; firstCachePtr = cachePtr; -- cgit v0.12 From 8d5c986031606a4565659bb82dcbba7ab9ce0186 Mon Sep 17 00:00:00 2001 From: ferrieux Date: Wed, 3 Sep 2014 19:44:29 +0000 Subject: Distinguish hanging from crashing in exit tests. --- tests/aaa_exit.test | 27 ++++++++++++++++++++------- 1 file changed, 20 insertions(+), 7 deletions(-) diff --git a/tests/aaa_exit.test b/tests/aaa_exit.test index 51a94d7..3ba5167 100644 --- a/tests/aaa_exit.test +++ b/tests/aaa_exit.test @@ -16,22 +16,35 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } - test exit-1.1 {normal, quick exit} { - set f [open "|[interpreter] << \"exec [interpreter] << {set ::env(TCL_FINALIZE_ON_EXIT) 0;exit}\" 2>@ stderr" r] - set aft [after 5000 {set done "Quick exit hangs !!!"}] + set f [open "|[interpreter] << \"exec [interpreter] << {set ::env(TCL_FINALIZE_ON_EXIT) 0;exit}\"" r] + set aft [after 1000 {set done "Quick exit hangs !!!"}] fileevent $f readable {after cancel $aft;set done OK} vwait done - catch {fconfigure $f -blocking 0;close $f} + if {$done != "OK"} { + fconfigure $f -blocking 0 + close $f + } else { + if {[catch {close $f} err]} { + set done "Quick exit misbehaves: $err" + } + } set done } OK test exit-1.2 {full-finalized exit} { - set f [open "|[interpreter] << \"exec [interpreter] << {set ::env(TCL_FINALIZE_ON_EXIT) 1;exit}\" 2>@ stderr" r] - set aft [after 5000 {set done "Full-finalized exit hangs !!!"}] + set f [open "|[interpreter] << \"exec [interpreter] << {set ::env(TCL_FINALIZE_ON_EXIT) 1;exit}\"" r] + set aft [after 1000 {set done "Full-finalized exit hangs !!!"}] fileevent $f readable {after cancel $aft;set done OK} vwait done - catch {fconfigure $f -blocking 0;close $f} + if {$done != "OK"} { + fconfigure $f -blocking 0 + close $f + } else { + if {[catch {close $f} err]} { + set done "Full-finalized exit misbehaves: $err" + } + } set done } OK -- cgit v0.12 From 1ce040baf210e345e2c8f8a19fe7b8d821274c4b Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 4 Sep 2014 22:05:21 +0000 Subject: Remove ChannelHandlerEvent struct, which has never been used in all of recorded Tcl history. Still need to purge comments of mentions of ChannelHandlerEventProc() which is similarly pre-historic. --- generic/tclIO.c | 11 ----------- 1 file changed, 11 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index eaa0aeb..4bd90cc 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -58,17 +58,6 @@ typedef struct NextChannelHandler { } NextChannelHandler; /* - * The following structure describes the event that is added to the Tcl - * event queue by the channel handler check procedure. - */ - -typedef struct ChannelHandlerEvent { - Tcl_Event header; /* Standard header for all events. */ - Channel *chanPtr; /* The channel that is ready. */ - int readyMask; /* Events that have occurred. */ -} ChannelHandlerEvent; - -/* * The following structure is used by Tcl_GetsObj() to encapsulates the * state for a "gets" operation. */ -- cgit v0.12 From 0b7aa99ede7838e4390b0c14bcda9485a08d0cf4 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 5 Sep 2014 10:05:05 +0000 Subject: [ccc2c2cc98]: lreplace edge case --- generic/tclCompCmdsGR.c | 14 +++++++++++++- tests/lreplace.test | 14 +++++++++++++- 2 files changed, 26 insertions(+), 2 deletions(-) diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 166fea0..64dcaa6 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -1480,7 +1480,7 @@ TclCompileLreplaceCmd( Tcl_Token *tokenPtr, *listTokenPtr; DefineLineInformation; /* TIP #280 */ Tcl_Obj *tmpObj; - int idx1, idx2, i, offset; + int idx1, idx2, i, offset, offset2; if (parsePtr->numWords < 4) { return TCL_ERROR; @@ -1586,12 +1586,18 @@ TclCompileLreplaceCmd( TclEmitOpcode( INST_GT, envPtr); offset = CurrentOffset(envPtr); TclEmitInstInt1( INST_JUMP_TRUE1, 0, envPtr); + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_LIST_LENGTH, envPtr); + offset2 = CurrentOffset(envPtr); + TclEmitInstInt1( INST_JUMP_FALSE1, 0, envPtr); TclEmitPush(TclAddLiteralObj(envPtr, Tcl_ObjPrintf( "list doesn't contain element %d", idx1), NULL), envPtr); CompileReturnInternal(envPtr, INST_RETURN_IMM, TCL_ERROR, 0, Tcl_ObjPrintf("-errorcode {TCL OPERATION LREPLACE BADIDX}")); TclStoreInt1AtPtr(CurrentOffset(envPtr) - offset, envPtr->codeStart + offset + 1); + TclStoreInt1AtPtr(CurrentOffset(envPtr) - offset2, + envPtr->codeStart + offset2 + 1); TclAdjustStackDepth(-1, envPtr); } TclEmitOpcode( INST_DUP, envPtr); @@ -1636,12 +1642,18 @@ TclCompileLreplaceCmd( TclEmitOpcode( INST_GT, envPtr); offset = CurrentOffset(envPtr); TclEmitInstInt1( INST_JUMP_TRUE1, 0, envPtr); + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_LIST_LENGTH, envPtr); + offset2 = CurrentOffset(envPtr); + TclEmitInstInt1( INST_JUMP_TRUE1, 0, envPtr); TclEmitPush(TclAddLiteralObj(envPtr, Tcl_ObjPrintf( "list doesn't contain element %d", idx1), NULL), envPtr); CompileReturnInternal(envPtr, INST_RETURN_IMM, TCL_ERROR, 0, Tcl_ObjPrintf("-errorcode {TCL OPERATION LREPLACE BADIDX}")); TclStoreInt1AtPtr(CurrentOffset(envPtr) - offset, envPtr->codeStart + offset + 1); + TclStoreInt1AtPtr(CurrentOffset(envPtr) - offset2, + envPtr->codeStart + offset2 + 1); TclAdjustStackDepth(-1, envPtr); } TclEmitOpcode( INST_DUP, envPtr); diff --git a/tests/lreplace.test b/tests/lreplace.test index 5f675bc..b976788 100644 --- a/tests/lreplace.test +++ b/tests/lreplace.test @@ -15,7 +15,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } - + test lreplace-1.1 {lreplace command} { lreplace {1 2 3 4 5} 0 0 a } {a 2 3 4 5} @@ -130,7 +130,19 @@ test lreplace-3.1 {lreplace won't modify shared argument objects} { p } "a b c" +test lreplace-4.1 {Bug ccc2c2cc98: lreplace edge case} { + lreplace {} 1 1 +} {} +# Note that this test will fail in 8.5 +test lreplace-4.2 {Bug ccc2c2cc98: lreplace edge case} { + lreplace { } 1 1 +} {} + # cleanup catch {unset foo} ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: -- cgit v0.12 From 3db46bb5c46e8ac5171b91b2e137979406d131b6 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 5 Sep 2014 18:30:57 +0000 Subject: Make corrections to long-false comments. --- generic/tclIO.c | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 4bd90cc..dcde8d1 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -35,15 +35,15 @@ typedef struct ChannelHandler { /* * This structure keeps track of the current ChannelHandler being invoked in - * the current invocation of ChannelHandlerEventProc. There is a potential + * the current invocation of Tcl_NotifyChannel. There is a potential * problem if a ChannelHandler is deleted while it is the current one, since - * ChannelHandlerEventProc needs to look at the nextPtr field. To handle this + * Tcl_NotifyChannel needs to look at the nextPtr field. To handle this * problem, structures of the type below indicate the next handler to be * processed for any (recursively nested) dispatches in progress. The * nextHandlerPtr field is updated if the handler being pointed to is deleted. - * The nextPtr field is used to chain together all recursive invocations, so - * that Tcl_DeleteChannelHandler can find all the recursively nested - * invocations of ChannelHandlerEventProc and compare the handler being + * The nestedHandlerPtr field is used to chain together all recursive + * invocations, so that Tcl_DeleteChannelHandler can find all the recursively + * nested invocations of Tcl_NotifyChannel and compare the handler being * deleted against the NEXT handler to be invoked in that invocation; when it * finds such a situation, Tcl_DeleteChannelHandler updates the nextHandlerPtr * field of the structure to the next handler. @@ -54,7 +54,7 @@ typedef struct NextChannelHandler { * this invocation. */ struct NextChannelHandler *nestedHandlerPtr; /* Next nested invocation of - * ChannelHandlerEventProc. */ + * Tcl_NotifyChannel. */ } NextChannelHandler; /* @@ -119,7 +119,7 @@ typedef struct CopyState { typedef struct ThreadSpecificData { NextChannelHandler *nestedHandlerPtr; /* This variable holds the list of nested - * ChannelHandlerEventProc invocations. */ + * Tcl_NotifyChannel invocations. */ ChannelState *firstCSPtr; /* List of all channels currently open, * indexed by ChannelState, as only one * ChannelState exists per set of stacked @@ -8089,7 +8089,7 @@ Tcl_NotifyChannel( /* * Add this invocation to the list of recursive invocations of - * ChannelHandlerEventProc. + * Tcl_NotifyChannel. */ nh.nextHandlerPtr = NULL; @@ -8408,7 +8408,7 @@ Tcl_DeleteChannelHandler( } /* - * If ChannelHandlerEventProc is about to process this handler, tell it to + * If Tcl_NotifyChannel is about to process this handler, tell it to * process the next one instead - we are going to delete *this* one. */ -- cgit v0.12 From 277e045c81735e0509f6c38c56047faa52b5f246 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 5 Sep 2014 19:04:43 +0000 Subject: Remove unused macros. --- unix/tclUnixTime.c | 3 --- 1 file changed, 3 deletions(-) diff --git a/unix/tclUnixTime.c b/unix/tclUnixTime.c index 926e8f4..4452022 100644 --- a/unix/tclUnixTime.c +++ b/unix/tclUnixTime.c @@ -16,9 +16,6 @@ #include #endif -#define TM_YEAR_BASE 1900 -#define IsLeapYear(x) (((x)%4 == 0) && ((x)%100 != 0 || (x)%400 == 0)) - /* * TclpGetDate is coded to return a pointer to a 'struct tm'. For thread * safety, this structure must be in thread-specific data. The 'tmKey' -- cgit v0.12 From aa5429b146778774bfc447513e15c08126877653 Mon Sep 17 00:00:00 2001 From: stwo Date: Mon, 8 Sep 2014 00:37:22 +0000 Subject: Change one '#ifdef' to '#if defined()' for improved consistency within the file, as in checkin [211aa43013]. --- unix/tclUnixCompat.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unix/tclUnixCompat.c b/unix/tclUnixCompat.c index 0fc51b7..3d2b7b8 100644 --- a/unix/tclUnixCompat.c +++ b/unix/tclUnixCompat.c @@ -370,7 +370,7 @@ TclpGetGrNam( #else ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); -#ifdef HAVE_GETGRNAM_R_5 +#if defined(HAVE_GETGRNAM_R_5) struct group *grPtr = NULL; /* -- cgit v0.12 From 07be9a8aa0887809dd6d79d2f079fa1d1558790e Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 8 Sep 2014 21:22:05 +0000 Subject: Exceptional handling of oo::class has to be consistent throughout. --- generic/tclOO.c | 4 +++- tests/oo.test | 10 ++++++++++ 2 files changed, 13 insertions(+), 1 deletion(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index ace47fe..77e668b 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -1287,7 +1287,9 @@ TclOORemoveFromInstances( removeInstance: if (Deleted(clsPtr->thisPtr)) { - DelRef(clsPtr->instances.list[i]); + if (!IsRootClass(clsPtr)) { + DelRef(clsPtr->instances.list[i]); + } clsPtr->instances.list[i] = NULL; } else { clsPtr->instances.num--; diff --git a/tests/oo.test b/tests/oo.test index 8c515da..2c189ca 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -271,6 +271,16 @@ test oo-1.18.1 {Bug 75b8433707: memory leak in oo-1.18} -setup { } -cleanup { rename test-oo-1.18 {} } -result 0 +test oo-1.18.2 {Bug 21c144f0f5} -setup { + interp create slave +} -body { + slave eval { + oo::define [oo::class create foo] superclass oo::class + oo::class destroy + } +} -cleanup { + interp delete slave +} test oo-1.19 {basic test of OO functionality: teardown order} -body { oo::object create o namespace delete [info object namespace o] -- cgit v0.12 From 04d10eb983cb26686f38383404b6b6ef9876f9e1 Mon Sep 17 00:00:00 2001 From: ferrieux Date: Mon, 8 Sep 2014 22:50:11 +0000 Subject: Refine TclFinalizeThreadData so that the quick-exit optimization really only affects exit. --- generic/tclEvent.c | 23 ++++++++++------------- generic/tclThread.c | 7 ++++++- 2 files changed, 16 insertions(+), 14 deletions(-) diff --git a/generic/tclEvent.c b/generic/tclEvent.c index ab219a6..3985767 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -1299,20 +1299,17 @@ Tcl_FinalizeThread(void) TclFinalizeAsync(); TclFinalizeThreadObjects(); } - if (TclFullFinalizationRequested()) { /* useless if we are facing a quick-exit */ - /* - * Blow away all thread local storage blocks. - * - * Note that Tcl API allows creation of threads which do not use any Tcl - * interp or other Tcl subsytems. Those threads might, however, use thread - * local storage, so we must unconditionally finalize it. - * - * Fix [Bug #571002] - */ - - TclFinalizeThreadData(); - } + /* + * Blow away all thread local storage blocks. + * + * Note that Tcl API allows creation of threads which do not use any Tcl + * interp or other Tcl subsytems. Those threads might, however, use thread + * local storage, so we must unconditionally finalize it. + * + * Fix [Bug #571002] + */ + TclFinalizeThreadData(); } /* diff --git a/generic/tclThread.c b/generic/tclThread.c index 8c972a8..5ac6a8d 100644 --- a/generic/tclThread.c +++ b/generic/tclThread.c @@ -357,7 +357,12 @@ TclFinalizeThreadData(void) { TclFinalizeThreadDataThread(); #if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) - TclFinalizeThreadAllocThread(); + if ((!TclInExit())||TclFullFinalizationRequested()) { + /* + * Quick exit principle makes it useless to terminate allocators + */ + TclFinalizeThreadAllocThread(); + } #endif } -- cgit v0.12 From e19c2ce585d7fe309059bb96044b08dbfa850a6b Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 9 Sep 2014 19:49:08 +0000 Subject: [84af1192f5]: [regsub] compiler no longer confused by quantification handling. --- generic/tclCompCmdsGR.c | 7 ++++--- generic/tclCompCmdsSZ.c | 2 +- generic/tclInt.h | 3 ++- generic/tclRegexp.c | 3 ++- generic/tclUtil.c | 9 ++++++++- tests/regexpComp.test | 5 +++++ 6 files changed, 22 insertions(+), 7 deletions(-) diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 64dcaa6..603c51d 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -2270,7 +2270,7 @@ TclCompileRegexpCmd( * converted pattern as a literal. */ - if (TclReToGlob(NULL, varTokenPtr[1].start, len, &ds, &exact) + if (TclReToGlob(NULL, varTokenPtr[1].start, len, &ds, &exact, NULL) == TCL_OK) { simple = 1; PushLiteral(envPtr, Tcl_DStringValue(&ds),Tcl_DStringLength(&ds)); @@ -2362,7 +2362,7 @@ TclCompileRegsubCmd( Tcl_Obj *patternObj = NULL, *replacementObj = NULL; Tcl_DString pattern; const char *bytes; - int len, exact, result = TCL_ERROR; + int len, exact, quantified, result = TCL_ERROR; if (parsePtr->numWords < 5 || parsePtr->numWords > 6) { return TCL_ERROR; @@ -2422,7 +2422,8 @@ TclCompileRegsubCmd( */ bytes = Tcl_GetStringFromObj(patternObj, &len); - if (TclReToGlob(NULL, bytes, len, &pattern, &exact) != TCL_OK || exact) { + if (TclReToGlob(NULL, bytes, len, &pattern, &exact, &quantified) + != TCL_OK || exact || quantified) { goto done; } bytes = Tcl_DStringValue(&pattern); diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index f2e5dd2..28cab1e 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -2091,7 +2091,7 @@ IssueSwitchChainedTests( */ if (TclReToGlob(NULL, bodyToken[i]->start, - bodyToken[i]->size, &ds, &exact) == TCL_OK) { + bodyToken[i]->size, &ds, &exact, NULL) == TCL_OK){ simple = 1; PushLiteral(envPtr, Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)); diff --git a/generic/tclInt.h b/generic/tclInt.h index 6bf1ef9..7287a13 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3095,7 +3095,8 @@ MODULE_SCOPE void TclRememberJoinableThread(Tcl_ThreadId id); MODULE_SCOPE void TclRememberMutex(Tcl_Mutex *mutex); MODULE_SCOPE void TclRemoveScriptLimitCallbacks(Tcl_Interp *interp); MODULE_SCOPE int TclReToGlob(Tcl_Interp *interp, const char *reStr, - int reStrLen, Tcl_DString *dsPtr, int *flagsPtr); + int reStrLen, Tcl_DString *dsPtr, int *flagsPtr, + int *quantifiersFoundPtr); MODULE_SCOPE int TclScanElement(const char *string, int length, int *flagPtr); MODULE_SCOPE void TclSetBgErrorHandler(Tcl_Interp *interp, diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c index 6348e4a..5bc3aa2 100644 --- a/generic/tclRegexp.c +++ b/generic/tclRegexp.c @@ -946,7 +946,8 @@ CompileRegexp( * Tcl_RegExpExecObj to optionally do a fast match (avoids RE engine). */ - if (TclReToGlob(NULL, string, length, &stringBuf, &exact) == TCL_OK) { + if (TclReToGlob(NULL, string, length, &stringBuf, &exact, + NULL) == TCL_OK) { regexpPtr->globObjPtr = TclDStringToObj(&stringBuf); Tcl_IncrRefCount(regexpPtr->globObjPtr); } else { diff --git a/generic/tclUtil.c b/generic/tclUtil.c index ae3adae..64589a2 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -4249,7 +4249,8 @@ TclReToGlob( const char *reStr, int reStrLen, Tcl_DString *dsPtr, - int *exactPtr) + int *exactPtr, + int *quantifiersFoundPtr) { int anchorLeft, anchorRight, lastIsStar, numStars; char *dsStr, *dsStrStart; @@ -4257,6 +4258,9 @@ TclReToGlob( strEnd = reStr + reStrLen; Tcl_DStringInit(dsPtr); + if (quantifiersFoundPtr != NULL) { + *quantifiersFoundPtr = 0; + } /* * "***=xxx" == "*xxx*", watch for glob-sensitive chars. @@ -4369,6 +4373,9 @@ TclReToGlob( } break; case '.': + if (quantifiersFoundPtr != NULL) { + *quantifiersFoundPtr = 1; + } anchorLeft = 0; /* prevent exact match */ if (p+1 < strEnd) { if (p[1] == '*') { diff --git a/tests/regexpComp.test b/tests/regexpComp.test index 7be1195..01ef06d 100644 --- a/tests/regexpComp.test +++ b/tests/regexpComp.test @@ -526,6 +526,11 @@ test regexpComp-9.6 {-all option to regsub} { list [regsub -all ^ xxx 123 foo] $foo } } {1 123xxx} +test regexpComp-9.7 {Bug 84af1192f5: -all option to regsub} { + evalInProc { + regsub -all {\(.*} 123(qwe) "" + } +} 123 test regexpComp-10.1 {expanded syntax in regsub} { evalInProc { -- cgit v0.12 From 186cc4a17e82ce9bd90edccc45ab943c63b40c30 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 10 Sep 2014 08:20:46 +0000 Subject: [2486824] Improve error message; not all that upvars is an upvar. --- generic/tclVar.c | 9 ++++----- tests/upvar.test | 11 +++++++---- tests/var.test | 2 +- 3 files changed, 12 insertions(+), 10 deletions(-) diff --git a/generic/tclVar.c b/generic/tclVar.c index fda5ff5..a6f6cf4 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -3605,9 +3605,8 @@ ObjMakeUpvar( || !HasLocalVars(varFramePtr) || (strstr(TclGetString(myNamePtr), "::") != NULL))) { Tcl_AppendResult((Tcl_Interp *) iPtr, "bad variable name \"", - TclGetString(myNamePtr), "\": upvar won't create " - "namespace variable that refers to procedure variable", - NULL); + TclGetString(myNamePtr), "\": can't create namespace " + "variable that refers to procedure variable", NULL); return TCL_ERROR; } } @@ -3705,8 +3704,8 @@ TclPtrObjMakeUpvar( */ Tcl_AppendResult((Tcl_Interp *) iPtr, "bad variable name \"", - myName, "\": upvar won't create a scalar variable " - "that looks like an array element", NULL); + myName, "\": can't create a scalar variable that " + "looks like an array element", NULL); return TCL_ERROR; } } diff --git a/tests/upvar.test b/tests/upvar.test index 79c2d53..d18fd3b 100644 --- a/tests/upvar.test +++ b/tests/upvar.test @@ -17,7 +17,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} { } testConstraint testupvar [llength [info commands testupvar]] - + test upvar-1.1 {reading variables with upvar} { proc p1 {a b} {set c 22; set d 33; p2} proc p2 {} {upvar a x1 b x2 c x3 d x4; set a abc; list $x1 $x2 $x3 $x4 $a} @@ -332,7 +332,7 @@ test upvar-8.9 {upvar won't create namespace variable that refers to procedure v unset ::test_ns_1::a } list [catch {MakeLink 1} msg] $msg -} {1 {bad variable name "a": upvar won't create namespace variable that refers to procedure variable}} +} {1 {bad variable name "a": can't create namespace variable that refers to procedure variable}} test upvar-8.10 {upvar will create element alias for new array element} { catch {unset upvarArray} array set upvarArray {} @@ -583,8 +583,11 @@ test upvar-NS-3.3 {CompileWord OBOE} -setup { } -cleanup { rename linenumber {} } -result 1 - - + # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/var.test b/tests/var.test index 45b7207..c852ca9 100644 --- a/tests/var.test +++ b/tests/var.test @@ -275,7 +275,7 @@ test var-3.11 {MakeUpvar, my var looks like array elem} -body { catch {unset aaaaa} set aaaaa 789789 upvar #0 aaaaa foo(bar) -} -returnCodes 1 -result {bad variable name "foo(bar)": upvar won't create a scalar variable that looks like an array element} +} -returnCodes 1 -result {bad variable name "foo(bar)": can't create a scalar variable that looks like an array element} test var-4.1 {Tcl_GetVariableName, global variable} testgetvarfullname { catch {unset a} -- cgit v0.12 From 7e17c358eb7a149fbec81f4c2e5d1adefcc90bdd Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 10 Sep 2014 22:17:21 +0000 Subject: [cee90e4e88] Correct error in stack depth checking. --- generic/tclCompCmdsSZ.c | 1 + tests/error.test | 6 ++++++ 2 files changed, 7 insertions(+) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 28cab1e..ed9c088 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -3038,6 +3038,7 @@ IssueTryClausesInstructions( if (!handlerTokens[i]) { forwardsNeedFixing = 1; JUMP4( JUMP, forwardsToFix[i]); + TclAdjustStackDepth(1, envPtr); } else { int dontChangeOptions; diff --git a/tests/error.test b/tests/error.test index 0de644c..af07ed7 100644 --- a/tests/error.test +++ b/tests/error.test @@ -1184,6 +1184,12 @@ test error-21.8 {memory leaks in try: Bug 2910044} memory { } } 0 +test error-21.9 {Bug cee90e4e88} { + # Just don't panic. + apply {{} {try {} on ok {} - on return {} {}}} +} {} + + # negative case try tests - bad "trap" handler # what is the effect if we attempt to trap an errorcode that is not a list? # nested try -- cgit v0.12