New function Tcl_GetWideUIntFromObj

7 files changed, 118 insertions, 36 deletions

diff --git a/doc/IntObj.3 b/doc/IntObj.3
index d640dbb..18d867e 100644
--- a/doc/IntObj.3
+++ b/doc/IntObj.3
@@ -8,7 +8,7 @@
 .so man.macros
 .BS
 .SH NAME
-Tcl_NewIntObj, Tcl_NewLongObj, Tcl_NewWideIntObj, Tcl_SetIntObj, Tcl_SetLongObj, Tcl_SetWideIntObj, Tcl_GetIntFromObj, Tcl_GetIntForIndex, Tcl_GetLongFromObj, Tcl_GetWideIntFromObj, Tcl_NewBignumObj, Tcl_SetBignumObj, Tcl_GetBignumFromObj, Tcl_TakeBignumFromObj \- manipulate Tcl values as integers
+Tcl_NewIntObj, Tcl_NewLongObj, Tcl_NewWideIntObj, Tcl_SetIntObj, Tcl_SetLongObj, Tcl_SetWideIntObj, Tcl_GetIntFromObj, Tcl_GetIntForIndex, Tcl_GetLongFromObj, Tcl_GetWideIntFromObj, Tcl_GetWideUIntFromObj, Tcl_NewBignumObj, Tcl_SetBignumObj, Tcl_GetBignumFromObj, Tcl_TakeBignumFromObj \- manipulate Tcl values as integers
 .SH SYNOPSIS
 .nf
 \fB#include <tcl.h>\fR
@@ -40,6 +40,9 @@ int
 int
 \fBTcl_GetWideIntFromObj\fR(\fIinterp, objPtr, widePtr\fR)
 .sp
+int
+\fBTcl_GetWideUIntFromObj\fR(\fIinterp, objPtr, uwidePtr\fR)
+.sp
 .sp
 \fB#include <tclTomMath.h>\fR
 .sp
@@ -82,6 +85,8 @@ Points to place to store the integer value retrieved from \fIobjPtr\fR.
 Points to place to store the long integer value retrieved from \fIobjPtr\fR.
 .AP Tcl_WideInt *widePtr out
 Points to place to store the wide integer value retrieved from \fIobjPtr\fR.
+.AP Tcl_WideUInt *uwidePtr out
+Points to place to store the unsigned wide integer value retrieved from \fIobjPtr\fR.
 .AP mp_int *bigValue in/out
 Points to a multi-precision integer structure declared by the LibTomMath
 library.
diff --git a/doc/LinkVar.3 b/doc/LinkVar.3
index 6d7ef12..f5e97b4 100644
--- a/doc/LinkVar.3
+++ b/doc/LinkVar.3
@@ -239,8 +239,7 @@ The C variable, or each element of the C array, is of type \fBTcl_WideUInt\fR
 (which is an unsigned integer type at least 64-bits wide on all platforms that
 can support it.)
 Any value written into the Tcl variable must have a proper unsigned
-wideinteger form acceptable to \fBTcl_GetBignumFromObj\fR and in the
-platform's defined range for the \fBTcl_WideUInt\fR type;
+wideinteger form acceptable to \fBTcl_GetWideUIntFromObj\fR;
 attempts to write non-integer values into \fIvarName\fR will be
 rejected with Tcl errors. Incomplete integer representations (like
 the empty string, '+', '-' or the hex/octal/decimal/binary prefix) are accepted
diff --git a/generic/tcl.decls b/generic/tcl.decls
index 6d9fbbd..2128880 100644
--- a/generic/tcl.decls
+++ b/generic/tcl.decls
@@ -2552,6 +2552,11 @@ declare 683 {
    int Tcl_GetEncodingNulLength(Tcl_Encoding encoding)
 }
 
+declare 687 {
+    int Tcl_GetWideUIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
+	    Tcl_WideUInt *uwidePtr)
+}
+
 # ----- BASELINE -- FOR -- 8.7.0 ----- #
 
 ##############################################################################
diff --git a/generic/tclDecls.h b/generic/tclDecls.h
index 0888ecf..9c70434 100644
--- a/generic/tclDecls.h
+++ b/generic/tclDecls.h
@@ -2040,6 +2040,12 @@ EXTERN int		Tcl_RemoveChannelMode(Tcl_Interp *interp,
 				Tcl_Channel chan, int mode);
 /* 683 */
 EXTERN int		Tcl_GetEncodingNulLength(Tcl_Encoding encoding);
+/* Slot 684 is reserved */
+/* Slot 685 is reserved */
+/* Slot 686 is reserved */
+/* 687 */
+EXTERN int		Tcl_GetWideUIntFromObj(Tcl_Interp *interp,
+				Tcl_Obj *objPtr, Tcl_WideUInt *uwidePtr);
 
 typedef struct {
     const struct TclPlatStubs *tclPlatStubs;
@@ -2759,6 +2765,10 @@ typedef struct TclStubs {
     int (*tcl_GetNumber) (Tcl_Interp *interp, const char *bytes, size_t numBytes, void **clientDataPtr, int *typePtr); /* 681 */
     int (*tcl_RemoveChannelMode) (Tcl_Interp *interp, Tcl_Channel chan, int mode); /* 682 */
     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); /* 687 */
 } TclStubs;
 
 extern const TclStubs *tclStubsPtr;
@@ -4157,6 +4167,11 @@ extern const TclStubs *tclStubsPtr;
 	(tclStubsPtr->tcl_RemoveChannelMode) /* 682 */
 #define Tcl_GetEncodingNulLength \
 	(tclStubsPtr->tcl_GetEncodingNulLength) /* 683 */
+/* Slot 684 is reserved */
+/* Slot 685 is reserved */
+/* Slot 686 is reserved */
+#define Tcl_GetWideUIntFromObj \
+	(tclStubsPtr->tcl_GetWideUIntFromObj) /* 687 */
 
 #endif /* defined(USE_TCL_STUBS) */
 
diff --git a/generic/tclLink.c b/generic/tclLink.c
index 397c9bc..cd2c731 100644
--- a/generic/tclLink.c
+++ b/generic/tclLink.c
@@ -526,41 +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;
-	    size_t numBytes;
-
-	    if (numPtr->sign || (MP_OKAY != mp_pack(&value, 1,
-		    &numBytes, 0, sizeof(Tcl_WideUInt), 0, 0, numPtr))) {
-		/*
-		 * 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;
-	    }
-	    *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 bad3f85..5a52e29 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -3394,6 +3394,87 @@ 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_WideInt, even when auto-narrowing is enabled.
+	     */
+
+	    mp_int big;
+	    Tcl_WideUInt value = 0;
+	    size_t numBytes;
+
+	    TclUnpackBignum(objPtr, big);
+	    if (mp_pack(&value, 1,
+			    &numBytes, 0, sizeof(Tcl_WideUInt), 0, 0, &big) == MP_OKAY) {
+		if (big.sign == MP_NEG) {
+		    goto wideUIntOutOfRange;
+		}
+		if (value <= (Tcl_WideUInt)UWIDE_MAX) {
+		    *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 ad60fc3..e3c519b 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -2055,6 +2055,10 @@ const TclStubs tclStubs = {
     Tcl_GetNumber, /* 681 */
     Tcl_RemoveChannelMode, /* 682 */
     Tcl_GetEncodingNulLength, /* 683 */
+    0, /* 684 */
+    0, /* 685 */
+    0, /* 686 */
+    Tcl_GetWideUIntFromObj, /* 687 */
 };
 
 /* !END!: Do not edit above this line. */