merge 8.7

1 files changed, 422 insertions, 22 deletions

diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index e759392..3bf485b 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -17,6 +17,7 @@
  */
 
 #include "tclInt.h"
+#include "tclCompile.h"
 #include "tclRegexp.h"
 #include "tclStringTrim.h"
 
@@ -1221,8 +1222,8 @@ Tcl_SplitObjCmd(
 	    fullchar = ch;
 
 #if TCL_UTF_MAX <= 4
-	    if (!len) {
-		len += TclUtfToUniChar(stringPtr, &ch);
+	    if ((ch >= 0xD800) && (len < 3)) {
+		len += TclUtfToUniChar(stringPtr + len, &ch);
 		fullchar = (((fullchar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000;
 	    }
 #endif
@@ -1444,11 +1445,11 @@ StringIndexCmd(
 
 	    Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(&uch, 1));
 	} else {
-	    char buf[4];
+	    char buf[4] = "";
 
 	    length = Tcl_UniCharToUtf(ch, buf);
-	    if (!length) {
-		length = Tcl_UniCharToUtf(-1, buf);
+	    if ((ch >= 0xD800) && (length < 3)) {
+		length += Tcl_UniCharToUtf(-1, buf + length);
 	    }
 	    Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, length));
 	}
@@ -1628,7 +1629,7 @@ StringIsCmd(
     case STR_IS_BOOL:
     case STR_IS_TRUE:
     case STR_IS_FALSE:
-	if ((objPtr->typePtr != &tclBooleanType)
+	if (!TclHasIntRep(objPtr, &tclBooleanType)
 		&& (TCL_OK != TclSetBooleanFromAny(NULL, objPtr))) {
 	    if (strict) {
 		result = 0;
@@ -1698,9 +1699,9 @@ StringIsCmd(
 	chcomp = Tcl_UniCharIsDigit;
 	break;
     case STR_IS_DOUBLE: {
-	if ((objPtr->typePtr == &tclDoubleType) ||
-		(objPtr->typePtr == &tclIntType) ||
-		(objPtr->typePtr == &tclBignumType)) {
+	if (TclHasIntRep(objPtr, &tclDoubleType) ||
+		TclHasIntRep(objPtr, &tclIntType) ||
+		TclHasIntRep(objPtr, &tclBignumType)) {
 	    break;
 	}
 	string1 = TclGetStringFromObj(objPtr, &length1);
@@ -1729,8 +1730,8 @@ StringIsCmd(
 	break;
     case STR_IS_INT:
     case STR_IS_ENTIER:
-	if ((objPtr->typePtr == &tclIntType) ||
-		(objPtr->typePtr == &tclBignumType)) {
+	if (TclHasIntRep(objPtr, &tclIntType) ||
+		TclHasIntRep(objPtr, &tclBignumType)) {
 	    break;
 	}
 	string1 = TclGetStringFromObj(objPtr, &length1);
@@ -1911,8 +1912,8 @@ StringIsCmd(
 	    length2 = TclUtfToUniChar(string1, &ch);
 	    fullchar = ch;
 #if TCL_UTF_MAX <= 4
-	    if (!length2) {
-	    	length2 = TclUtfToUniChar(string1, &ch);
+	    if ((ch >= 0xD800) && (length2 < 3)) {
+	    	length2 += TclUtfToUniChar(string1 + length2, &ch);
 	    	fullchar = (((fullchar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000;
 	    }
 #endif
@@ -1992,7 +1993,7 @@ StringMapCmd(
 	const char *string = TclGetStringFromObj(objv[1], &length2);
 
 	if ((length2 > 1) &&
-		strncmp(string, "-nocase", (size_t) length2) == 0) {
+		strncmp(string, "-nocase", length2) == 0) {
 	    nocase = 1;
 	} else {
 	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
@@ -2009,7 +2010,7 @@ StringMapCmd(
      */
 
     if (!TclHasStringRep(objv[objc-2])
-	    && (objv[objc-2]->typePtr == &tclDictType)){
+	    && TclHasIntRep(objv[objc-2], &tclDictType)){
 	int i, done;
 	Tcl_DictSearch search;
 
@@ -2171,7 +2172,7 @@ StringMapCmd(
 			(Tcl_UniCharToLower(*ustring1) == u2lc[index/2]))) &&
 			/* Restrict max compare length. */
 			(end-ustring1 >= length2) && ((length2 == 1) ||
-			!strCmpFn(ustring2, ustring1, (unsigned) length2))) {
+			!strCmpFn(ustring2, ustring1, length2))) {
 		    if (p != ustring1) {
 			/*
 			 * Put the skipped chars onto the result first.
@@ -2260,7 +2261,7 @@ StringMatchCmd(
 	const char *string = TclGetStringFromObj(objv[1], &length);
 
 	if ((length > 1) &&
-	    strncmp(string, "-nocase", (size_t) length) == 0) {
+	    strncmp(string, "-nocase", length) == 0) {
 	    nocase = TCL_MATCH_NOCASE;
 	} else {
 	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
@@ -2662,10 +2663,10 @@ StringEqualCmd(
 
     for (i = 1; i < objc-2; i++) {
 	string2 = TclGetStringFromObj(objv[i], &length);
-	if ((length > 1) && !strncmp(string2, "-nocase", (size_t)length)) {
+	if ((length > 1) && !strncmp(string2, "-nocase", length)) {
 	    nocase = 1;
 	} else if ((length > 1)
-		&& !strncmp(string2, "-length", (size_t)length)) {
+		&& !strncmp(string2, "-length", length)) {
 	    if (i+1 >= objc-2) {
 		goto str_cmp_args;
 	    }
@@ -2760,10 +2761,10 @@ TclStringCmpOpts(
 
     for (i = 1; i < objc-2; i++) {
 	string = TclGetStringFromObj(objv[i], &length);
-	if ((length > 1) && !strncmp(string, "-nocase", (size_t)length)) {
+	if ((length > 1) && !strncmp(string, "-nocase", length)) {
 	    *nocase = 1;
 	} else if ((length > 1)
-		&& !strncmp(string, "-length", (size_t)length)) {
+		&& !strncmp(string, "-length", length)) {
 	    if (i+1 >= objc-2) {
 		goto str_cmp_args;
 	    }
@@ -4088,7 +4089,7 @@ Tcl_TimeObjCmd(
     start = TclpGetWideClicks();
 #endif
     while (i-- > 0) {
-	result = Tcl_EvalObjEx(interp, objPtr, 0);
+	result = TclEvalObjEx(interp, objPtr, 0, NULL, 0);
 	if (result != TCL_OK) {
 	    return result;
 	}
@@ -4128,6 +4129,399 @@ Tcl_TimeObjCmd(
 /*
  *----------------------------------------------------------------------
  *
+ * Tcl_TimeRateObjCmd --
+ *
+ *	This object-based procedure is invoked to process the "timerate" Tcl
+ *	command.
+ *	This is similar to command "time", except the execution limited by
+ *	given time (in milliseconds) instead of repetition count.
+ *
+ * Example:
+ *	timerate {after 5} 1000 ; # equivalent for `time {after 5} [expr 1000/5]`
+ *
+ * Results:
+ *	A standard Tcl object result.
+ *
+ * Side effects:
+ *	See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_TimeRateObjCmd(
+    ClientData dummy,		/* Not used. */
+    Tcl_Interp *interp,		/* Current interpreter. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *const objv[])	/* Argument objects. */
+{
+    static double measureOverhead = 0; /* global measure-overhead */
+    double overhead = -1;	/* given measure-overhead */
+    register Tcl_Obj *objPtr;
+    register int result, i;
+    Tcl_Obj *calibrate = NULL, *direct = NULL;
+    Tcl_WideUInt count = 0;	/* Holds repetition count */
+    Tcl_WideInt  maxms  = WIDE_MIN;
+				/* Maximal running time (in milliseconds) */
+    Tcl_WideUInt maxcnt = WIDE_MAX;
+				/* Maximal count of iterations. */
+    Tcl_WideUInt threshold = 1;	/* Current threshold for check time (faster
+				 * repeat count without time check) */
+    Tcl_WideUInt maxIterTm = 1;	/* Max time of some iteration as max threshold
+				 * additionally avoid divide to zero (never < 1) */
+    unsigned short factor = 50;	/* Factor (4..50) limiting threshold to avoid
+				 * growth of execution time. */
+    register Tcl_WideInt start, middle, stop;
+#ifndef TCL_WIDE_CLICKS
+    Tcl_Time now;
+#endif
+
+    static const char *const options[] = {
+	"-direct",	"-overhead",	"-calibrate",	"--",	NULL
+    };
+    enum options {
+	TMRT_EV_DIRECT,	TMRT_OVERHEAD,	TMRT_CALIBRATE,	TMRT_LAST
+    };
+
+    NRE_callback *rootPtr;
+    ByteCode	 *codePtr = NULL;
+
+    for (i = 1; i < objc - 1; i++) {
+    	int index;
+	if (Tcl_GetIndexFromObj(NULL, objv[i], options, "option", TCL_EXACT,
+		&index) != TCL_OK) {
+	    break;
+	}
+	if (index == TMRT_LAST) {
+	    i++;
+	    break;
+	}
+	switch (index) {
+	case TMRT_EV_DIRECT:
+	    direct = objv[i];
+	    break;
+	case TMRT_OVERHEAD:
+	    if (++i >= objc - 1) {
+		goto usage;
+	    }
+	    if (Tcl_GetDoubleFromObj(interp, objv[i], &overhead) != TCL_OK) {
+		return TCL_ERROR;
+	    }
+	    break;
+	case TMRT_CALIBRATE:
+	    calibrate = objv[i];
+	    break;
+	}
+    }
+
+    if (i >= objc || i < objc-3) {
+usage:
+	Tcl_WrongNumArgs(interp, 1, objv, "?-direct? ?-calibrate? ?-overhead double? command ?time ?max-count??");
+	return TCL_ERROR;
+    }
+    objPtr = objv[i++];
+    if (i < objc) {	/* max-time */
+	result = Tcl_GetWideIntFromObj(interp, objv[i++], &maxms);
+	if (result != TCL_OK) {
+	    return result;
+	}
+	if (i < objc) {	/* max-count*/
+	    Tcl_WideInt v;
+	    result = Tcl_GetWideIntFromObj(interp, objv[i], &v);
+	    if (result != TCL_OK) {
+		return result;
+	    }
+	    maxcnt = (v > 0) ? v : 0;
+	}
+    }
+
+    /* if calibrate */
+    if (calibrate) {
+
+	/* if no time specified for the calibration */
+	if (maxms == WIDE_MIN) {
+	    Tcl_Obj *clobjv[6];
+	    Tcl_WideInt maxCalTime = 5000;
+	    double lastMeasureOverhead = measureOverhead;
+
+	    clobjv[0] = objv[0];
+	    i = 1;
+	    if (direct) {
+	    	clobjv[i++] = direct;
+	    }
+	    clobjv[i++] = objPtr;
+
+	    /* reset last measurement overhead */
+	    measureOverhead = (double)0;
+
+	    /* self-call with 100 milliseconds to warm-up,
+	     * before entering the calibration cycle */
+	    TclNewIntObj(clobjv[i], 100);
+	    Tcl_IncrRefCount(clobjv[i]);
+	    result = Tcl_TimeRateObjCmd(dummy, interp, i+1, clobjv);
+	    Tcl_DecrRefCount(clobjv[i]);
+	    if (result != TCL_OK) {
+		return result;
+	    }
+
+	    i--;
+	    clobjv[i++] = calibrate;
+	    clobjv[i++] = objPtr;
+
+	    /* set last measurement overhead to max */
+	    measureOverhead = (double)UWIDE_MAX;
+
+	    /* calibration cycle until it'll be preciser */
+	    maxms = -1000;
+	    do {
+		lastMeasureOverhead = measureOverhead;
+		TclNewIntObj(clobjv[i], (int)maxms);
+		Tcl_IncrRefCount(clobjv[i]);
+		result = Tcl_TimeRateObjCmd(dummy, interp, i+1, clobjv);
+		Tcl_DecrRefCount(clobjv[i]);
+		if (result != TCL_OK) {
+		    return result;
+		}
+		maxCalTime += maxms;
+		/* increase maxms for preciser calibration */
+		maxms -= (-maxms / 4);
+		/* as long as new value more as 0.05% better */
+	    } while ( (measureOverhead >= lastMeasureOverhead
+		    || measureOverhead / lastMeasureOverhead <= 0.9995)
+		    && maxCalTime > 0
+	    );
+
+	    return result;
+	}
+	if (maxms == 0) {
+	    /* reset last measurement overhead */
+	    measureOverhead = 0;
+	    Tcl_SetObjResult(interp, Tcl_NewLongObj(0));
+	    return TCL_OK;
+	}
+
+	/* if time is negative - make current overhead more precise */
+	if (maxms > 0) {
+	    /* set last measurement overhead to max */
+	    measureOverhead = (double)UWIDE_MAX;
+	} else {
+	    maxms = -maxms;
+	}
+
+    }
+
+    if (maxms == WIDE_MIN) {
+    	maxms = 1000;
+    }
+    if (overhead == -1) {
+	overhead = measureOverhead;
+    }
+
+    /* be sure that resetting of result will not smudge the further measurement */
+    Tcl_ResetResult(interp);
+
+    /* compile object */
+    if (!direct) {
+	if (TclInterpReady(interp) != TCL_OK) {
+	    return TCL_ERROR;
+	}
+	codePtr = TclCompileObj(interp, objPtr, NULL, 0);
+	TclPreserveByteCode(codePtr);
+    }
+
+    /* get start and stop time */
+#ifdef TCL_WIDE_CLICKS
+    start = middle = TclpGetWideClicks();
+    /* time to stop execution (in wide clicks) */
+    stop = start + (maxms * 1000 / TclpWideClickInMicrosec());
+#else
+    Tcl_GetTime(&now);
+    start = now.sec; start *= 1000000; start += now.usec;
+    middle = start;
+    /* time to stop execution (in microsecs) */
+    stop = start + maxms * 1000;
+#endif
+
+    /* start measurement */
+    if (maxcnt > 0)
+    while (1) {
+    	/* eval single iteration */
+    	count++;
+
+	if (!direct) {
+	    /* precompiled */
+	    rootPtr = TOP_CB(interp);
+	    result = TclNRExecuteByteCode(interp, codePtr);
+	    result = TclNRRunCallbacks(interp, result, rootPtr);
+	} else {
+	    /* eval */
+	    result = TclEvalObjEx(interp, objPtr, 0, NULL, 0);
+	}
+	if (result != TCL_OK) {
+	    /* allow break from measurement cycle (used for conditional stop) */
+	    if (result != TCL_BREAK) {
+		goto done;
+	    }
+	    /* force stop immediately */
+	    threshold = 1;
+	    maxcnt = 0;
+	    result = TCL_OK;
+	}
+
+	/* don't check time up to threshold */
+	if (--threshold > 0) continue;
+
+	/* check stop time reached, estimate new threshold */
+    #ifdef TCL_WIDE_CLICKS
+	middle = TclpGetWideClicks();
+    #else
+	Tcl_GetTime(&now);
+	middle = now.sec; middle *= 1000000; middle += now.usec;
+    #endif
+	if (middle >= stop || count >= maxcnt) {
+	    break;
+	}
+
+	/* don't calculate threshold by few iterations, because sometimes first
+	 * iteration(s) can be too fast or slow (cached, delayed clean up, etc) */
+	if (count < 10) {
+	   threshold = 1; continue;
+	}
+
+	/* average iteration time in microsecs */
+	threshold = (middle - start) / count;
+	if (threshold > maxIterTm) {
+	    maxIterTm = threshold;
+	    /* interations seems to be longer */
+	    if (threshold > (maxIterTm * 2)) {
+		if ((factor *= 2) > 50) factor = 50;
+	    } else {
+		if (factor < 50) factor++;
+	    }
+	} else if (factor > 4) {
+	    /* interations seems to be shorter */
+	    if (threshold < (maxIterTm / 2)) {
+		if ((factor /= 2) < 4) factor = 4;
+	    } else {
+		factor--;
+	    }
+	}
+	/* as relation between remaining time and time since last check,
+	 * maximal some % of time (by factor), so avoid growing of the execution time
+	 * if iterations are not consistent, e. g. wax continuously on time) */
+	threshold = ((stop - middle) / maxIterTm) / factor + 1;
+	if (threshold > 100000) {	    /* fix for too large threshold */
+	    threshold = 100000;
+	}
+	/* consider max-count */
+	if (threshold > maxcnt - count) {
+	    threshold = maxcnt - count;
+	}
+    }
+
+    {
+	Tcl_Obj *objarr[8], **objs = objarr;
+	Tcl_WideInt val;
+	const char *fmt;
+
+	middle -= start;		     /* execution time in microsecs */
+
+    #ifdef TCL_WIDE_CLICKS
+	/* convert execution time in wide clicks to microsecs */
+	middle *= TclpWideClickInMicrosec();
+    #endif
+
+	if (!count) { /* no iterations - avoid divide by zero */
+	    objs[0] = objs[2] = objs[4] = Tcl_NewWideIntObj(0);
+	    goto retRes;
+	}
+
+	/* if not calibrate */
+	if (!calibrate) {
+	    /* minimize influence of measurement overhead */
+	    if (overhead > 0) {
+		/* estimate the time of overhead (microsecs) */
+		Tcl_WideUInt curOverhead = overhead * count;
+		if (middle > (Tcl_WideInt)curOverhead) {
+		    middle -= curOverhead;
+		} else {
+		    middle = 0;
+		}
+	    }
+	} else {
+	    /* calibration - obtaining new measurement overhead */
+	    if (measureOverhead > (double)middle / count) {
+		measureOverhead = (double)middle / count;
+	    }
+	    objs[0] = Tcl_NewDoubleObj(measureOverhead);
+	    TclNewLiteralStringObj(objs[1], "\xC2\xB5s/#-overhead"); /* mics */
+	    objs += 2;
+	}
+
+	val = middle / count;		     /* microsecs per iteration */
+	if (val >= 1000000) {
+	    objs[0] = Tcl_NewWideIntObj(val);
+	} else {
+	    if (val < 10)    { fmt = "%.6f"; } else
+	    if (val < 100)   { fmt = "%.4f"; } else
+	    if (val < 1000)  { fmt = "%.3f"; } else
+	    if (val < 10000) { fmt = "%.2f"; } else
+			     { fmt = "%.1f"; };
+	    objs[0] = Tcl_ObjPrintf(fmt, ((double)middle)/count);
+	}
+
+	objs[2] = Tcl_NewWideIntObj(count); /* iterations */
+
+	/* calculate speed as rate (count) per sec */
+	if (!middle) middle++; /* +1 ms, just to avoid divide by zero */
+	if (count < (WIDE_MAX / 1000000)) {
+	    val = (count * 1000000) / middle;
+	    if (val < 100000) {
+		if (val < 100)	{ fmt = "%.3f"; } else
+		if (val < 1000) { fmt = "%.2f"; } else
+				{ fmt = "%.1f"; };
+		objs[4] = Tcl_ObjPrintf(fmt, ((double)(count * 1000000)) / middle);
+	    } else {
+		objs[4] = Tcl_NewWideIntObj(val);
+	    }
+	} else {
+	    objs[4] = Tcl_NewWideIntObj((count / middle) * 1000000);
+	}
+
+    retRes:
+	/* estimated net execution time (in millisecs) */
+	if (!calibrate) {
+	    if (middle >= 1) {
+		objs[6] = Tcl_ObjPrintf("%.3f", (double)middle / 1000);
+	    } else {
+		objs[6] = Tcl_NewWideIntObj(0);
+	    }
+	    TclNewLiteralStringObj(objs[7], "nett-ms");
+	}
+
+	/*
+	* Construct the result as a list because many programs have always parsed
+	* as such (extracting the first element, typically).
+	*/
+
+	TclNewLiteralStringObj(objs[1], "\xC2\xB5s/#"); /* mics/# */
+	TclNewLiteralStringObj(objs[3], "#");
+	TclNewLiteralStringObj(objs[5], "#/sec");
+	Tcl_SetObjResult(interp, Tcl_NewListObj(8, objarr));
+    }
+
+done:
+
+    if (codePtr != NULL) {
+	TclReleaseByteCode(codePtr);
+    }
+
+    return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * Tcl_TryObjCmd, TclNRTryObjCmd --
  *
  *	This procedure is invoked to process the "try" Tcl command. See the
@@ -4476,18 +4870,24 @@ 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 {
 		/*