summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tcl.decls10
-rw-r--r--generic/tclDecls.h12
-rw-r--r--generic/tclLink.c39
-rw-r--r--generic/tclObj.c81
-rw-r--r--generic/tclStubInit.c3
5 files changed, 107 insertions, 38 deletions
diff --git a/generic/tcl.decls b/generic/tcl.decls
index adaaf7c..d3df327 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)
+}
# ----- BASELINE -- FOR -- 8.7.0 / 9.0.0 ----- #
diff --git a/generic/tclDecls.h b/generic/tclDecls.h
index 0888ecf..1bddb16 100644
--- a/generic/tclDecls.h
+++ b/generic/tclDecls.h
@@ -2040,6 +2040,11 @@ 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 */
+/* 686 */
+EXTERN int Tcl_GetWideUIntFromObj(Tcl_Interp *interp,
+ Tcl_Obj *objPtr, Tcl_WideUInt *uwidePtr);
typedef struct {
const struct TclPlatStubs *tclPlatStubs;
@@ -2759,6 +2764,9 @@ 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);
+ int (*tcl_GetWideUIntFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_WideUInt *uwidePtr); /* 686 */
} TclStubs;
extern const TclStubs *tclStubsPtr;
@@ -4157,6 +4165,10 @@ extern const TclStubs *tclStubsPtr;
(tclStubsPtr->tcl_RemoveChannelMode) /* 682 */
#define Tcl_GetEncodingNulLength \
(tclStubsPtr->tcl_GetEncodingNulLength) /* 683 */
+/* Slot 684 is reserved */
+/* Slot 685 is reserved */
+#define Tcl_GetWideUIntFromObj \
+ (tclStubsPtr->tcl_GetWideUIntFromObj) /* 686 */
#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..793aad3 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -2055,6 +2055,9 @@ const TclStubs tclStubs = {
Tcl_GetNumber, /* 681 */
Tcl_RemoveChannelMode, /* 682 */
Tcl_GetEncodingNulLength, /* 683 */
+ 0, /* 684 */
+ 0, /* 685 */
+ Tcl_GetWideUIntFromObj, /* 686 */
};
/* !END!: Do not edit above this line. */
generated by cgit v0.12 at 2024-11-16 02:11:23 (GMT)