summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--generic/tclCmdMZ.c14
-rw-r--r--generic/tclEnsemble.c6
-rw-r--r--generic/tclEvent.c23
-rw-r--r--generic/tclExecute.c21
-rw-r--r--generic/tclInt.h7
-rw-r--r--generic/tclTomMath.h4
-rw-r--r--tests/execute.test39
-rw-r--r--tests/namespace.test21
-rw-r--r--win/tclWinPort.h8
9 files changed, 111 insertions, 32 deletions
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 06b6058..b4283d0 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -4304,14 +4304,14 @@ Tcl_TimeRateObjCmd(
register Tcl_Obj *objPtr;
register int result, i;
Tcl_Obj *calibrate = NULL, *direct = NULL;
- Tcl_WideUInt count = 0; /* Holds repetition count */
+ TclWideMUInt count = 0; /* Holds repetition count */
Tcl_WideInt maxms = WIDE_MIN;
/* Maximal running time (in milliseconds) */
- Tcl_WideUInt maxcnt = WIDE_MAX;
+ TclWideMUInt maxcnt = WIDE_MAX;
/* Maximal count of iterations. */
- Tcl_WideUInt threshold = 1; /* Current threshold for check time (faster
+ TclWideMUInt threshold = 1; /* Current threshold for check time (faster
* repeat count without time check) */
- Tcl_WideUInt maxIterTm = 1; /* Max time of some iteration as max
+ TclWideMUInt maxIterTm = 1; /* Max time of some iteration as max
* threshold, additionally avoiding divide to
* zero (i.e., never < 1) */
unsigned short factor = 50; /* Factor (4..50) limiting threshold to avoid
@@ -4686,13 +4686,13 @@ Tcl_TimeRateObjCmd(
{
Tcl_Obj *objarr[8], **objs = objarr;
- Tcl_WideUInt usec, val;
+ TclWideMUInt usec, val;
int digits;
/*
* Absolute execution time in microseconds or in wide clicks.
*/
- usec = (Tcl_WideUInt)(middle - start);
+ usec = (TclWideMUInt)(middle - start);
#ifdef TCL_WIDE_CLICKS
/*
@@ -4721,7 +4721,7 @@ Tcl_TimeRateObjCmd(
* Estimate the time of overhead (microsecs).
*/
- Tcl_WideUInt curOverhead = overhead * count;
+ TclWideMUInt curOverhead = overhead * count;
if (usec > curOverhead) {
usec -= curOverhead;
diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c
index dfffe12..3352d1f 100644
--- a/generic/tclEnsemble.c
+++ b/generic/tclEnsemble.c
@@ -2694,7 +2694,11 @@ BuildEnsembleConfig(
if (isNew) {
Tcl_Obj *cmdObj, *cmdPrefixObj;
- cmdObj = Tcl_NewStringObj(nsCmdName, -1);
+ TclNewObj(cmdObj);
+ Tcl_AppendStringsToObj(cmdObj,
+ ensemblePtr->nsPtr->fullName,
+ (ensemblePtr->nsPtr->parentPtr ? "::" : ""),
+ nsCmdName, NULL);
cmdPrefixObj = Tcl_NewListObj(1, &cmdObj);
Tcl_SetHashValue(hPtr, cmdPrefixObj);
Tcl_IncrRefCount(cmdPrefixObj);
diff --git a/generic/tclEvent.c b/generic/tclEvent.c
index b0b8188..b0bfc15 100644
--- a/generic/tclEvent.c
+++ b/generic/tclEvent.c
@@ -944,16 +944,20 @@ Tcl_Exit(
currentAppExitPtr = appExitPtr;
Tcl_MutexUnlock(&exitMutex);
+ /*
+ * Warning: this function SHOULD NOT return, as there is code that depends
+ * on Tcl_Exit never returning. In fact, we will Tcl_Panic if anyone
+ * returns, so critical is this dependcy.
+ *
+ * If subsystems are not (yet) initialized, proper Tcl-finalization is
+ * impossible, so fallback to system exit, see bug-[f8a33ce3db5d8cc2].
+ */
+
if (currentAppExitPtr) {
- /*
- * Warning: this code SHOULD NOT return, as there is code that depends
- * on Tcl_Exit never returning. In fact, we will Tcl_Panic if anyone
- * returns, so critical is this dependcy.
- */
currentAppExitPtr(INT2PTR(status));
- Tcl_Panic("AppExitProc returned unexpectedly");
- } else {
+
+ } else if (subsystemsInitialized) {
if (TclFullFinalizationRequested()) {
@@ -986,9 +990,10 @@ Tcl_Exit(
FinalizeThread(/* quick */ 1);
}
- TclpExit(status);
- Tcl_Panic("OS exit failed!");
}
+
+ TclpExit(status);
+ Tcl_Panic("OS exit failed!");
}
/*
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index bf2d7bc..413c753 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -3716,31 +3716,36 @@ TEBCresume(
{
int createdNewObj = 0;
+ Tcl_Obj *valueToAssign;
if (!objResultPtr) {
- objResultPtr = valuePtr;
+ valueToAssign = valuePtr;
} else if (TclListObjLength(interp, objResultPtr, &len)!=TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
} else {
if (Tcl_IsShared(objResultPtr)) {
- objResultPtr = Tcl_DuplicateObj(objResultPtr);
+ valueToAssign = Tcl_DuplicateObj(objResultPtr);
createdNewObj = 1;
+ } else {
+ valueToAssign = objResultPtr;
}
- if (Tcl_ListObjReplace(interp, objResultPtr, len,0, objc,objv)
- != TCL_OK) {
+ if (Tcl_ListObjReplace(interp, valueToAssign, len, 0,
+ objc, objv) != TCL_OK) {
+ if (createdNewObj) {
+ TclDecrRefCount(valueToAssign);
+ }
goto errorInLappendListPtr;
}
}
DECACHE_STACK_INFO();
+ Tcl_IncrRefCount(valueToAssign);
objResultPtr = TclPtrSetVarIdx(interp, varPtr, arrayPtr, part1Ptr,
- part2Ptr, objResultPtr, TCL_LEAVE_ERR_MSG, opnd);
+ part2Ptr, valueToAssign, TCL_LEAVE_ERR_MSG, opnd);
+ TclDecrRefCount(valueToAssign);
CACHE_STACK_INFO();
if (!objResultPtr) {
errorInLappendListPtr:
- if (createdNewObj) {
- TclDecrRefCount(objResultPtr);
- }
TRACE_ERROR(interp);
goto gotError;
}
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 288176d..7b2055c 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3202,6 +3202,13 @@ MODULE_SCOPE void TclInitThreadStorage(void);
MODULE_SCOPE void TclFinalizeThreadDataThread(void);
MODULE_SCOPE void TclFinalizeThreadStorage(void);
+/* TclWideMUInt -- wide integer used for measurement calculations: */
+#if (!defined(_WIN32) || !defined(_MSC_VER) || (_MSC_VER >= 1400))
+# define TclWideMUInt Tcl_WideUInt
+#else
+/* older MSVS may not allow conversions between unsigned __int64 and double) */
+# define TclWideMUInt Tcl_WideInt
+#endif
#ifdef TCL_WIDE_CLICKS
MODULE_SCOPE Tcl_WideInt TclpGetWideClicks(void);
MODULE_SCOPE double TclpWideClicksToNanoseconds(Tcl_WideInt clicks);
diff --git a/generic/tclTomMath.h b/generic/tclTomMath.h
index eba0ceb..0106317 100644
--- a/generic/tclTomMath.h
+++ b/generic/tclTomMath.h
@@ -89,7 +89,11 @@ typedef unsigned int mp_digit;
#define MP_DIGIT_DECLARED
#endif
#ifndef MP_WORD_DECLARED
+#ifdef _WIN32
+typedef unsigned __int64 private_mp_word;
+#else
typedef unsigned long long private_mp_word;
+#endif
#define MP_WORD_DECLARED
#endif
diff --git a/tests/execute.test b/tests/execute.test
index e1ed68b..e9668a9 100644
--- a/tests/execute.test
+++ b/tests/execute.test
@@ -1066,6 +1066,45 @@ test execute-11.3 {Bug a0ece9d6d4} -setup {
trace remove execution crash enterstep {apply {args {info frame -2}}}
rename crash {}
} -result 1
+
+test execute-12.1 {failing multi-lappend to unshared} -setup {
+ unset -nocomplain x y
+} -body {
+ set x 1
+ lappend x 2 3
+ trace add variable x write {apply {args {error boo}}}
+ lappend x 4 5
+} -cleanup {
+ unset -nocomplain x y
+} -returnCodes error -result {can't set "x": boo}
+test execute-12.2 {failing multi-lappend to shared} -setup {
+ unset -nocomplain x y
+} -body {
+ set x 1
+ lappend x 2 3
+ set y $x
+ trace add variable x write {apply {args {error boo}}}
+ lappend x 4 5
+} -cleanup {
+ unset -nocomplain x y
+} -returnCodes error -result {can't set "x": boo}
+test execute-12.3 {failing multi-lappend to unshared: LVT} -body {
+ apply {{} {
+ set x 1
+ lappend x 2 3
+ trace add variable x write {apply {args {error boo}}}
+ lappend x 4 5
+ }}
+} -returnCodes error -result {can't set "x": boo}
+test execute-12.4 {failing multi-lappend to shared: LVT} -body {
+ apply {{} {
+ set x 1
+ lappend x 2 3
+ set y $x
+ trace add variable x write {apply {args {error boo}}}
+ lappend x 4 5
+ }}
+} -returnCodes error -result {can't set "x": boo}
# cleanup
if {[info commands testobj] != {}} {
diff --git a/tests/namespace.test b/tests/namespace.test
index 1d26512..ad82abe 100644
--- a/tests/namespace.test
+++ b/tests/namespace.test
@@ -1797,7 +1797,7 @@ test namespace-42.7 {ensembles: nested} -body {
list [ns x0 z] [ns x1] [ns x2] [ns x3]
} -cleanup {
namespace delete ns
-} -result {{1 z} 1 2 3}
+} -result {{1 ::ns::x0::z} 1 2 3}
test namespace-42.8 {
ensembles: [Bug 1670091], panic due to pointer to a deallocated List
struct.
@@ -2128,7 +2128,7 @@ test namespace-47.1 {ensemble: unknown handler} {
lappend result [catch {ns c d e} msg] $msg
lappend result [catch {ns Magic foo bar spong wibble} msg] $msg
list $result [lsort [info commands ::ns::*]] $log [namespace delete ns]
-} {{0 2 0 2 0 2 0 2 1 {unknown or protected subcommand "Magic"}} {::ns::Magic ::ns::a ::ns::b ::ns::c} {{making a} {running a b c} {running a b c} {making b} {running b c d} {making c} {running c d e} {unknown Magic - args = foo bar spong wibble}} {}}
+} {{0 2 0 2 0 2 0 2 1 {unknown or protected subcommand "Magic"}} {::ns::Magic ::ns::a ::ns::b ::ns::c} {{making a} {running ::ns::a b c} {running ::ns::a b c} {making b} {running ::ns::b c d} {making c} {running ::ns::c d e} {unknown Magic - args = foo bar spong wibble}} {}}
test namespace-47.2 {ensemble: unknown handler} {
namespace eval ns {
namespace export {[a-z]*}
@@ -3227,7 +3227,7 @@ test namespace-53.10 {ensembles: nested rewrite} -setup {
1 {wrong # args: should be "ns z1 x a1"}\
1 {wrong # args: should be "ns z2 x a1 a2"}\
1 {wrong # args: should be "ns z2 x a1 a2"}\
- 1 {wrong # args: should be "z0"}\
+ 1 {wrong # args: should be "::ns::x::z0"}\
0 {1 v}\
1 {wrong # args: should be "ns v x z2 a2"}\
0 {2 v v2}}
@@ -3312,7 +3312,7 @@ test namespace-56.3 {bug f97d4ee020: mutually-entangled deletion} {
}
} {::testing::abc::def ::testing::abc::ghi}
-test namespace-56.4 {bug 16fe1b5807: names starting with ":"} {
+test namespace-56.4 {bug 16fe1b5807: names starting with ":"} knownBug {
namespace eval : {
namespace ensemble create
namespace export *
@@ -3323,6 +3323,19 @@ namespace eval : {
: p1
} 16fe1b5807
+
+test namespace-56.5 {Bug 8b9854c3d8} -setup {
+ namespace eval namespace-56.5 {
+ proc cmd {} {string match ::* [lindex [[string cat info] level 0] 0]}
+ namespace export *
+ namespace ensemble create
+ }
+} -body {
+ namespace-56.5 cmd
+} -cleanup {
+ namespace delete namespace-56.5
+} -result 1
+
# cleanup
catch {rename cmd1 {}}
diff --git a/win/tclWinPort.h b/win/tclWinPort.h
index 29b1447..20b2fe0 100644
--- a/win/tclWinPort.h
+++ b/win/tclWinPort.h
@@ -480,10 +480,12 @@ typedef DWORD_PTR * PDWORD_PTR;
* including the *printf family and others. Tell it to shut up.
* (_MSC_VER is 1200 for VC6, 1300 or 1310 for vc7.net, 1400 for 8.0)
*/
-#if defined(_MSC_VER) && (_MSC_VER >= 1400)
+#if defined(_MSC_VER)
# pragma warning(disable:4244)
-# pragma warning(disable:4267)
-# pragma warning(disable:4996)
+# if _MSC_VER >= 1400
+# pragma warning(disable:4267)
+# pragma warning(disable:4996)
+# endif
#endif
/*
generated by cgit v0.12 at 2025-12-25 13:48:14 (GMT)