Rebase to latest 8.7

5 files changed, 102 insertions, 57 deletions

diff --git a/generic/tcl.decls b/generic/tcl.decls
index 59d0ece..6283089 100644
--- a/generic/tcl.decls
+++ b/generic/tcl.decls
@@ -2560,11 +2560,11 @@ declare 683 {
 #    void Tcl_SetWideUIntObj(Tcl_Obj *objPtr, Tcl_WideUInt uwideValue)
 #}
 
-# TIP #650 (reserved)
-#declare 686 {
-#    int Tcl_GetWideUIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
-#	    Tcl_WideUInt *uwidePtr)
-#}
+# TIP #650
+declare 686 {
+    int Tcl_GetWideUIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
+	    Tcl_WideUInt *uwidePtr)
+}
 
 # TIP 651
 declare 687 {
diff --git a/generic/tclDecls.h b/generic/tclDecls.h
index 3a57b2f..eb15582 100644
--- a/generic/tclDecls.h
+++ b/generic/tclDecls.h
@@ -2042,7 +2042,9 @@ EXTERN int		Tcl_RemoveChannelMode(Tcl_Interp *interp,
 EXTERN int		Tcl_GetEncodingNulLength(Tcl_Encoding encoding);
 /* Slot 684 is reserved */
 /* Slot 685 is reserved */
-/* Slot 686 is reserved */
+/* 686 */
+EXTERN int		Tcl_GetWideUIntFromObj(Tcl_Interp *interp,
+				Tcl_Obj *objPtr, Tcl_WideUInt *uwidePtr);
 /* 687 */
 EXTERN Tcl_Obj *	Tcl_DStringToObj(Tcl_DString *dsPtr);
 
@@ -2766,7 +2768,7 @@ typedef struct TclStubs {
     int (*tcl_GetEncodingNulLength) (Tcl_Encoding encoding); /* 683 */
     void (*reserved684)(void);
     void (*reserved685)(void);
-    void (*reserved686)(void);
+    int (*tcl_GetWideUIntFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_WideUInt *uwidePtr); /* 686 */
     Tcl_Obj * (*tcl_DStringToObj) (Tcl_DString *dsPtr); /* 687 */
 } TclStubs;
 
@@ -4168,7 +4170,8 @@ extern const TclStubs *tclStubsPtr;
 	(tclStubsPtr->tcl_GetEncodingNulLength) /* 683 */
 /* Slot 684 is reserved */
 /* Slot 685 is reserved */
-/* Slot 686 is reserved */
+#define Tcl_GetWideUIntFromObj \
+	(tclStubsPtr->tcl_GetWideUIntFromObj) /* 686 */
 #define Tcl_DStringToObj \
 	(tclStubsPtr->tcl_DStringToObj) /* 687 */
 
diff --git a/generic/tclLink.c b/generic/tclLink.c
index 1973067..cd2c731 100644
--- a/generic/tclLink.c
+++ b/generic/tclLink.c
@@ -526,56 +526,14 @@ GetUWide(
     Tcl_Obj *objPtr,
     Tcl_WideUInt *uwidePtr)
 {
-    Tcl_WideInt *widePtr = (Tcl_WideInt *) uwidePtr;
-    void *clientData;
-    int type, intValue;
-
-    if (Tcl_GetNumberFromObj(NULL, objPtr, &clientData, &type) == TCL_OK) {
-	if (type == TCL_NUMBER_INT) {
-	    *widePtr = *((const Tcl_WideInt *) clientData);
-	    return (*widePtr < 0);
-	} else if (type == TCL_NUMBER_BIG) {
-	    mp_int *numPtr = (mp_int *)clientData;
-	    Tcl_WideUInt value = 0;
-	    union {
-		Tcl_WideUInt value;
-		unsigned char bytes[sizeof(Tcl_WideUInt)];
-	    } scratch;
-	    size_t numBytes;
-	    unsigned char *bytes = scratch.bytes;
-
-	    if (numPtr->sign || (MP_OKAY != mp_to_ubin(numPtr,
-		    bytes, sizeof(Tcl_WideUInt), &numBytes))) {
-		/*
-		 * If the sign bit is set (a negative value) or if the value
-		 * can't possibly fit in the bits of an unsigned wide, there's
-		 * no point in doing further conversion.
-		 */
-		return 1;
-	    }
-#ifndef WORDS_BIGENDIAN
-	    while (numBytes-- > 0) {
-		value = (value << CHAR_BIT) | *bytes++;
-	    }
-#else /* WORDS_BIGENDIAN */
-	    /*
-	     * Big-endian can read the value directly.
-	     */
-	    value = scratch.value;
-#endif /* WORDS_BIGENDIAN */
-	    *uwidePtr = value;
-	    return 0;
-	}
-    }
-
-    /*
-     * Evil edge case fallback.
-     */
+    if (Tcl_GetWideUIntFromObj(NULL, objPtr, uwidePtr) != TCL_OK) {
+	int intValue;
 
-    if (GetInvalidIntFromObj(objPtr, &intValue) != TCL_OK) {
-	return 1;
+	if (GetInvalidIntFromObj(objPtr, &intValue) != TCL_OK) {
+	    return 1;
+	}
+	*uwidePtr = intValue;
     }
-    *uwidePtr = intValue;
     return 0;
 }
 
diff --git a/generic/tclObj.c b/generic/tclObj.c
index ce8e610..e496b1e 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -3401,6 +3401,90 @@ Tcl_GetWideIntFromObj(
 /*
  *----------------------------------------------------------------------
  *
+ * Tcl_GetWideUIntFromObj --
+ *
+ *	Attempt to return a unsigned wide integer from the Tcl object "objPtr". If the
+ *	object is not already a wide int object or a bignum object, an attempt will
+ *	be made to convert it to one.
+ *
+ * Results:
+ *	The return value is a standard Tcl object result. If an error occurs
+ *	during conversion, an error message is left in the interpreter's
+ *	result unless "interp" is NULL.
+ *
+ * Side effects:
+ *	If the object is not already an int object, the conversion will free
+ *	any old internal representation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_GetWideUIntFromObj(
+    Tcl_Interp *interp,         /* Used for error reporting if not NULL. */
+    Tcl_Obj *objPtr,	/* Object from which to get a wide int. */
+    Tcl_WideUInt *wideUIntPtr)
+				/* Place to store resulting long. */
+{
+    do {
+	if (objPtr->typePtr == &tclIntType) {
+	    if (objPtr->internalRep.wideValue < 0) {
+	wideUIntOutOfRange:
+		if (interp != NULL) {
+		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+			    "expected unsigned integer but got \"%s\"",
+			    TclGetString(objPtr)));
+		    Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL);
+		}
+		return TCL_ERROR;
+	    }
+	    *wideUIntPtr = (Tcl_WideUInt)objPtr->internalRep.wideValue;
+	    return TCL_OK;
+	}
+	if (objPtr->typePtr == &tclDoubleType) {
+	    goto wideUIntOutOfRange;
+	}
+	if (objPtr->typePtr == &tclBignumType) {
+	    /*
+	     * Must check for those bignum values that can fit in a
+	     * Tcl_WideUInt, even when auto-narrowing is enabled.
+	     */
+
+	    mp_int big;
+	    Tcl_WideUInt value = 0;
+	    size_t numBytes;
+	    Tcl_WideUInt scratch;
+	    unsigned char *bytes = (unsigned char *) &scratch;
+
+	    TclUnpackBignum(objPtr, big);
+	    if (big.sign == MP_NEG) {
+		goto wideUIntOutOfRange;
+	    }
+	    if (mp_to_ubin(&big, bytes, sizeof(Tcl_WideUInt), &numBytes) == MP_OKAY) {
+		while (numBytes-- > 0) {
+		    value = (value << CHAR_BIT) | *bytes++;
+		}
+		*wideUIntPtr = (Tcl_WideUInt)value;
+		return TCL_OK;
+	    }
+
+	    if (interp != NULL) {
+		const char *s = "integer value too large to represent";
+		Tcl_Obj *msg = Tcl_NewStringObj(s, -1);
+
+		Tcl_SetObjResult(interp, msg);
+		Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL);
+	    }
+	    return TCL_ERROR;
+	}
+    } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL,
+	    TCL_PARSE_INTEGER_ONLY)==TCL_OK);
+    return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * TclGetWideBitsFromObj --
  *
  *	Attempt to return a wide integer from the Tcl object "objPtr". If the
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index b3eb0de..865effe 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -2057,7 +2057,7 @@ const TclStubs tclStubs = {
     Tcl_GetEncodingNulLength, /* 683 */
     0, /* 684 */
     0, /* 685 */
-    0, /* 686 */
+    Tcl_GetWideUIntFromObj, /* 686 */
     Tcl_DStringToObj, /* 687 */
 };