From d13a3cd5020a792d88f940a51eb79639c12331c3 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 15 Nov 2022 14:03:34 +0000 Subject: New function Tcl_GetWideUIntFromObj --- doc/IntObj.3 | 7 ++++- doc/LinkVar.3 | 3 +- generic/tcl.decls | 5 ++++ generic/tclDecls.h | 15 ++++++++++ generic/tclLink.c | 39 ++++--------------------- generic/tclObj.c | 81 +++++++++++++++++++++++++++++++++++++++++++++++++++ generic/tclStubInit.c | 4 +++ 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 \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 \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. */ -- cgit v0.12 From 1c1ee1c59dab10aa856f9ecc8a2e9613aa69c04e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 18 Nov 2022 21:43:40 +0000 Subject: Backout [52a52a65f0], let's see if this fixes the Windows crash --- generic/tclLink.c | 54 ++++++++++++++++++++++++++++++++++++++++++++++++------ generic/tclObj.c | 49 +++++++++++++++++++++++++++++++++---------------- 2 files changed, 81 insertions(+), 22 deletions(-) diff --git a/generic/tclLink.c b/generic/tclLink.c index cd2c731..1973067 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -526,14 +526,56 @@ GetUWide( Tcl_Obj *objPtr, Tcl_WideUInt *uwidePtr) { - if (Tcl_GetWideUIntFromObj(NULL, objPtr, uwidePtr) != TCL_OK) { - int intValue; - - if (GetInvalidIntFromObj(objPtr, &intValue) != TCL_OK) { - return 1; + 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; } - *uwidePtr = intValue; } + + /* + * Evil edge case fallback. + */ + + if (GetInvalidIntFromObj(objPtr, &intValue) != TCL_OK) { + return 1; + } + *uwidePtr = intValue; return 0; } diff --git a/generic/tclObj.c b/generic/tclObj.c index 5a52e29..cc792c7 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -3124,12 +3124,15 @@ Tcl_GetLongFromObj( { mp_int big; - unsigned long value = 0; + unsigned long scratch, value = 0; + unsigned char *bytes = (unsigned char *) &scratch; size_t numBytes; TclUnpackBignum(objPtr, big); - if (mp_pack(&value, 1, - &numBytes, 0, sizeof(Tcl_WideUInt), 0, 0, &big) == MP_OKAY) { + if (mp_to_ubin(&big, bytes, sizeof(long), &numBytes) == MP_OKAY) { + while (numBytes-- > 0) { + value = (value << CHAR_BIT) | *bytes++; + } if (big.sign) { if (value <= 1 + (unsigned long)LONG_MAX) { *longPtr = (long)(-value); @@ -3361,10 +3364,14 @@ Tcl_GetWideIntFromObj( mp_int big; Tcl_WideUInt value = 0; size_t numBytes; + Tcl_WideInt scratch; + unsigned char *bytes = (unsigned char *) &scratch; TclUnpackBignum(objPtr, big); - if (mp_pack(&value, 1, - &numBytes, 0, sizeof(Tcl_WideUInt), 0, 0, &big) == MP_OKAY) { + if (mp_to_ubin(&big, bytes, sizeof(Tcl_WideInt), &numBytes) == MP_OKAY) { + while (numBytes-- > 0) { + value = (value << CHAR_BIT) | *bytes++; + } if (big.sign) { if (value <= 1 + ~(Tcl_WideUInt)WIDE_MIN) { *wideIntPtr = (Tcl_WideInt)(-value); @@ -3440,24 +3447,27 @@ Tcl_GetWideUIntFromObj( if (objPtr->typePtr == &tclBignumType) { /* * Must check for those bignum values that can fit in a - * Tcl_WideInt, even when auto-narrowing is enabled. + * 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 (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 (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); @@ -3518,18 +3528,21 @@ TclGetWideBitsFromObj( mp_int big; mp_err err; - Tcl_WideUInt value = 0; + Tcl_WideUInt value = 0, scratch; size_t numBytes; + unsigned char *bytes = (unsigned char *) &scratch; Tcl_GetBignumFromObj(NULL, objPtr, &big); err = mp_mod_2d(&big, (int) (CHAR_BIT * sizeof(Tcl_WideInt)), &big); if (err == MP_OKAY) { - err = mp_pack(&value, 1, - &numBytes, 0, sizeof(Tcl_WideUInt), 0, 0, &big); + err = mp_to_ubin(&big, bytes, sizeof(Tcl_WideInt), &numBytes); } if (err != MP_OKAY) { return TCL_ERROR; } + while (numBytes-- > 0) { + value = (value << CHAR_BIT) | *bytes++; + } *wideIntPtr = !big.sign ? (Tcl_WideInt)value : -(Tcl_WideInt)value; mp_clear(&big); return TCL_OK; @@ -3899,15 +3912,19 @@ Tcl_SetBignumObj( { Tcl_WideUInt value = 0; size_t numBytes; + Tcl_WideUInt scratch; + unsigned char *bytes = (unsigned char *) &scratch; mp_int *bignumValue = (mp_int *) big; if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetBignumObj"); } - if (mp_pack(&value, 1, - &numBytes, 0, sizeof(Tcl_WideUInt), 0, 0, bignumValue) != MP_OKAY) { + if (mp_to_ubin(bignumValue, bytes, sizeof(Tcl_WideUInt), &numBytes) != MP_OKAY) { goto tooLargeForWide; } + while (numBytes-- > 0) { + value = (value << CHAR_BIT) | *bytes++; + } if (value > ((Tcl_WideUInt)WIDE_MAX + bignumValue->sign)) { goto tooLargeForWide; } -- cgit v0.12