diff options
Diffstat (limited to 'generic/tclUtil.c')
| -rw-r--r-- | generic/tclUtil.c | 647 |
1 files changed, 369 insertions, 278 deletions
diff --git a/generic/tclUtil.c b/generic/tclUtil.c index fc5a2ac..4387c75 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -15,6 +15,7 @@ #include "tclInt.h" #include "tclParse.h" #include "tclStringTrim.h" +#include "tommath.h" #include <math.h> /* @@ -107,12 +108,11 @@ static Tcl_ThreadDataKey precisionKey; static void ClearHash(Tcl_HashTable *tablePtr); static void FreeProcessGlobalValue(ClientData clientData); static void FreeThreadHash(ClientData clientData); -static int GetEndOffsetFromObj(Tcl_Obj *objPtr, int endValue, - int *indexPtr); +static int GetEndOffsetFromObj(Tcl_Obj *objPtr, + size_t endValue, Tcl_WideInt *indexPtr); static Tcl_HashTable * GetThreadHash(Tcl_ThreadDataKey *keyPtr); -static int SetEndOffsetFromAny(Tcl_Interp *interp, - Tcl_Obj *objPtr); -static void UpdateStringOfEndOffset(Tcl_Obj *objPtr); +static int GetWideForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr, + size_t endValue, Tcl_WideInt *widePtr); static int FindElement(Tcl_Interp *interp, const char *string, int stringLength, const char *typeStr, const char *typeCode, const char **elementPtr, @@ -121,16 +121,20 @@ static int FindElement(Tcl_Interp *interp, const char *string, /* * The following is the Tcl object type definition for an object that * represents a list index in the form, "end-offset". It is used as a - * performance optimization in TclGetIntForIndex. The internal rep is an - * integer, so no memory management is required for it. + * performance optimization in Tcl_GetIntForIndex. The internal rep is + * stored directly in the wideValue, so no memory management is required + * for it. This is a caching intrep, keeping the result of a parse + * around. This type is only created from a pre-existing string, so an + * updateStringProc will never be called and need not exist. The type + * is unregistered, so has no need of a setFromAnyProc either. */ -const Tcl_ObjType tclEndOffsetType = { +static const Tcl_ObjType endOffsetType = { "end-offset", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ - UpdateStringOfEndOffset, /* updateStringProc */ - SetEndOffsetFromAny + NULL, /* updateStringProc */ + NULL /* setFromAnyProc */ }; /* @@ -901,7 +905,7 @@ Tcl_SplitList( } argv[i] = p; if (literal) { - memcpy(p, element, (size_t) elSize); + memcpy(p, element, elSize); p += elSize; *p = 0; p++; @@ -1403,9 +1407,9 @@ TclConvertElement( */ if ((src == NULL) || (length == 0) || (*src == '\0' && length == -1)) { - src = tclEmptyStringRep; - length = 0; - conversion = CONVERT_BRACE; + p[0] = '{'; + p[1] = '}'; + return 2; } /* @@ -1623,6 +1627,7 @@ Tcl_Merge( return result; } +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 /* *---------------------------------------------------------------------- * @@ -1649,13 +1654,14 @@ Tcl_Backslash( int *readPtr) /* Fill in with number of characters read from * src, unless NULL. */ { - char buf[TCL_UTF_MAX] = ""; + char buf[4] = ""; Tcl_UniChar ch = 0; Tcl_UtfBackslash(src, readPtr, buf); TclUtfToUniChar(buf, &ch); return (char) ch; } +#endif /* !TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -1719,13 +1725,13 @@ TrimRight( { const char *p = bytes + numBytes; int pInc; + Tcl_UniChar ch1 = 0, ch2 = 0; /* * Outer loop: iterate over string to be trimmed. */ do { - Tcl_UniChar ch1; const char *q = trim; int bytesLeft = numTrim; @@ -1737,7 +1743,6 @@ TrimRight( */ do { - Tcl_UniChar ch2; int qInc = TclUtfToUniChar(q, &ch2); if (ch1 == ch2) { @@ -1818,13 +1823,13 @@ TrimLeft( int numTrim) /* ...and its length in bytes */ { const char *p = bytes; + Tcl_UniChar ch1 = 0, ch2 = 0; /* * Outer loop: iterate over string to be trimmed. */ do { - Tcl_UniChar ch1; int pInc = TclUtfToUniChar(p, &ch1); const char *q = trim; int bytesLeft = numTrim; @@ -1834,7 +1839,6 @@ TrimLeft( */ do { - Tcl_UniChar ch2; int qInc = TclUtfToUniChar(q, &ch2); if (ch1 == ch2) { @@ -2012,7 +2016,7 @@ Tcl_Concat( * All element bytes + (argc - 1) spaces + 1 terminating NULL. */ - result = ckalloc((unsigned) (bytesNeeded + argc)); + result = ckalloc(bytesNeeded + argc); for (p = result, i = 0; i < argc; i++) { int triml, trimr, elemLength; @@ -2045,7 +2049,7 @@ Tcl_Concat( if (needSpace) { *p++ = ' '; } - memcpy(p, element, (size_t) elemLength); + memcpy(p, element, elemLength); p += elemLength; needSpace = 1; } @@ -2093,7 +2097,7 @@ Tcl_ConcatObj( if (TclListObjIsCanonical(objPtr)) { continue; } - Tcl_GetStringFromObj(objPtr, &length); + TclGetStringFromObj(objPtr, &length); if (length > 0) { break; } @@ -2102,7 +2106,7 @@ Tcl_ConcatObj( resPtr = NULL; for (i = 0; i < objc; i++) { objPtr = objv[i]; - if (objPtr->bytes && objPtr->length == 0) { + if (!TclListObjIsCanonical(objPtr)) { continue; } if (resPtr) { @@ -2182,6 +2186,7 @@ Tcl_ConcatObj( return resPtr; } +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 /* *---------------------------------------------------------------------- * @@ -2200,6 +2205,7 @@ Tcl_ConcatObj( *---------------------------------------------------------------------- */ +#undef Tcl_StringMatch int Tcl_StringMatch( const char *str, /* String. */ @@ -2208,7 +2214,7 @@ Tcl_StringMatch( { return Tcl_StringCaseMatch(str, pattern, 0); } - +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- * @@ -2237,7 +2243,7 @@ Tcl_StringCaseMatch( { int p, charLen; const char *pstart = pattern; - Tcl_UniChar ch1, ch2; + Tcl_UniChar ch1 = 0, ch2 = 0; while (1) { p = *pattern; @@ -2298,7 +2304,7 @@ Tcl_StringCaseMatch( if (nocase) { while (*str) { charLen = TclUtfToUniChar(str, &ch1); - if (ch2==ch1 || ch2==Tcl_UniCharToLower(ch1)) { + if (ch2==ch1 || ch2==(Tcl_UniChar)Tcl_UniCharToLower(ch1)) { break; } str += charLen; @@ -2347,7 +2353,7 @@ Tcl_StringCaseMatch( */ if (p == '[') { - Tcl_UniChar startChar, endChar; + Tcl_UniChar startChar = 0, endChar = 0; pattern++; if (UCHAR(*str) < 0x80) { @@ -2654,7 +2660,7 @@ TclStringMatchObj( trivial = nocase ? 0 : TclMatchIsTrivial(TclGetString(ptnObj)); */ - if ((strObj->typePtr == &tclStringType) || (strObj->typePtr == NULL)) { + if (TclHasIntRep(strObj, &tclStringType) || (strObj->typePtr == NULL)) { Tcl_UniChar *udata, *uptn; udata = Tcl_GetUnicodeFromObj(strObj, &length); @@ -2747,7 +2753,7 @@ Tcl_DStringAppend( if (dsPtr->string == dsPtr->staticSpace) { char *newString = ckalloc(dsPtr->spaceAvl); - memcpy(newString, dsPtr->string, (size_t) dsPtr->length); + memcpy(newString, dsPtr->string, dsPtr->length); dsPtr->string = newString; } else { int offset = -1; @@ -2793,7 +2799,7 @@ TclDStringAppendObj( Tcl_Obj *objPtr) { int length; - char *bytes = Tcl_GetStringFromObj(objPtr, &length); + char *bytes = TclGetStringFromObj(objPtr, &length); return Tcl_DStringAppend(dsPtr, bytes, length); } @@ -2850,7 +2856,7 @@ Tcl_DStringAppendElement( if (dsPtr->string == dsPtr->staticSpace) { char *newString = ckalloc(dsPtr->spaceAvl); - memcpy(newString, dsPtr->string, (size_t) dsPtr->length); + memcpy(newString, dsPtr->string, dsPtr->length); dsPtr->string = newString; } else { int offset = -1; @@ -2944,7 +2950,7 @@ Tcl_DStringSetLength( if (dsPtr->string == dsPtr->staticSpace) { char *newString = ckalloc(dsPtr->spaceAvl); - memcpy(newString, dsPtr->string, (size_t) dsPtr->length); + memcpy(newString, dsPtr->string, dsPtr->length); dsPtr->string = newString; } else { dsPtr->string = ckrealloc(dsPtr->string, dsPtr->spaceAvl); @@ -3010,7 +3016,6 @@ Tcl_DStringResult( Tcl_DString *dsPtr) /* Dynamic string that is to become the * result of interp. */ { - Tcl_ResetResult(interp); Tcl_SetObjResult(interp, TclDStringToObj(dsPtr)); } @@ -3040,6 +3045,14 @@ Tcl_DStringGetResult( Tcl_DString *dsPtr) /* Dynamic string that is to become the result * of interp. */ { +#ifdef TCL_NO_DEPRECATED + Tcl_Obj *obj = Tcl_GetObjResult(interp); + const char *bytes = TclGetString(obj); + + Tcl_DStringFree(dsPtr); + Tcl_DStringAppend(dsPtr, bytes, obj->length); + Tcl_ResetResult(interp); +#else Interp *iPtr = (Interp *) interp; if (dsPtr->string != dsPtr->staticSpace) { @@ -3048,7 +3061,7 @@ Tcl_DStringGetResult( /* * Do more efficient transfer when we know the result is a Tcl_Obj. When - * there's no st`ring result, we only have to deal with two cases: + * there's no string result, we only have to deal with two cases: * * 1. When the string rep is the empty string, when we don't copy but * instead use the staticSpace in the DString to hold an empty string. @@ -3063,17 +3076,17 @@ Tcl_DStringGetResult( if (!iPtr->result[0] && iPtr->objResultPtr && !Tcl_IsShared(iPtr->objResultPtr)) { - if (iPtr->objResultPtr->bytes == tclEmptyStringRep) { + if (iPtr->objResultPtr->bytes == &tclEmptyString) { dsPtr->string = dsPtr->staticSpace; dsPtr->string[0] = 0; dsPtr->length = 0; dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; } else { - dsPtr->string = Tcl_GetString(iPtr->objResultPtr); + dsPtr->string = TclGetString(iPtr->objResultPtr); dsPtr->length = iPtr->objResultPtr->length; dsPtr->spaceAvl = dsPtr->length + 1; TclFreeIntRep(iPtr->objResultPtr); - iPtr->objResultPtr->bytes = tclEmptyStringRep; + iPtr->objResultPtr->bytes = &tclEmptyString; iPtr->objResultPtr->length = 0; } return; @@ -3093,7 +3106,7 @@ Tcl_DStringGetResult( dsPtr->spaceAvl = dsPtr->length+1; } else { dsPtr->string = ckalloc(dsPtr->length+1); - memcpy(dsPtr->string, iPtr->result, (unsigned) dsPtr->length+1); + memcpy(dsPtr->string, iPtr->result, dsPtr->length+1); iPtr->freeProc(iPtr->result); } dsPtr->spaceAvl = dsPtr->length+1; @@ -3106,11 +3119,12 @@ Tcl_DStringGetResult( dsPtr->string = ckalloc(dsPtr->length+1); dsPtr->spaceAvl = dsPtr->length + 1; } - memcpy(dsPtr->string, iPtr->result, (unsigned) dsPtr->length+1); + memcpy(dsPtr->string, iPtr->result, dsPtr->length+1); } iPtr->result = iPtr->resultSpace; iPtr->resultSpace[0] = 0; +#endif /* !TCL_NO_DEPRECATED */ } /* @@ -3261,7 +3275,7 @@ Tcl_PrintDouble( int signum; char *digits; char *end; - int *precisionPtr = Tcl_GetThreadData(&precisionKey, (int) sizeof(int)); + int *precisionPtr = Tcl_GetThreadData(&precisionKey, sizeof(int)); /* * Handle NaN. @@ -3423,6 +3437,7 @@ Tcl_PrintDouble( *---------------------------------------------------------------------- */ +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 /* ARGSUSED */ char * TclPrecTraceProc( @@ -3433,8 +3448,8 @@ TclPrecTraceProc( int flags) /* Information about what happened. */ { Tcl_Obj *value; - int prec; - int *precisionPtr = Tcl_GetThreadData(&precisionKey, (int) sizeof(int)); + Tcl_WideInt prec; + int *precisionPtr = Tcl_GetThreadData(&precisionKey, sizeof(int)); /* * If the variable is unset, then recreate the trace. @@ -3457,7 +3472,7 @@ TclPrecTraceProc( if (flags & TCL_TRACE_READS) { - Tcl_SetVar2Ex(interp, name1, name2, Tcl_NewIntObj(*precisionPtr), + Tcl_SetVar2Ex(interp, name1, name2, Tcl_NewWideIntObj(*precisionPtr), flags & TCL_GLOBAL_ONLY); return NULL; } @@ -3473,13 +3488,14 @@ TclPrecTraceProc( } value = Tcl_GetVar2Ex(interp, name1, name2, flags & TCL_GLOBAL_ONLY); if (value == NULL - || Tcl_GetIntFromObj(NULL, value, &prec) != TCL_OK + || Tcl_GetWideIntFromObj(NULL, value, &prec) != TCL_OK || prec < 0 || prec > TCL_MAX_PREC) { return (char *) "improper value for precision"; } - *precisionPtr = prec; + *precisionPtr = (int)prec; return NULL; } +#endif /* !TCL_NO_DEPRECATED)*/ /* *---------------------------------------------------------------------- @@ -3597,9 +3613,9 @@ int TclFormatInt( char *buffer, /* Points to the storage into which the * formatted characters are written. */ - long n) /* The integer to format. */ + Tcl_WideInt n) /* The integer to format. */ { - long intVal; + Tcl_WideInt intVal; int i; int numFormatted, j; const char *digits = "0123456789"; @@ -3622,7 +3638,7 @@ TclFormatInt( intVal = -n; /* [Bug 3390638] Workaround for*/ if (n == -n || intVal == n) { /* broken compiler optimizers. */ - return sprintf(buffer, "%ld", n); + return sprintf(buffer, "%" TCL_LL_MODIFIER "d", n); } /* @@ -3659,165 +3675,263 @@ TclFormatInt( /* *---------------------------------------------------------------------- * - * TclGetIntForIndex -- - * - * Provides an integer corresponding to the list index held in a Tcl - * object. The string value 'objPtr' is expected have the format - * integer([+-]integer)? or end([+-]integer)?. - * - * Value - * TCL_OK - * - * The index is stored at the address given by by 'indexPtr'. If - * 'objPtr' has the value "end", the value stored is 'endValue'. + * GetWideForIndex -- * - * TCL_ERROR + * This function produces a wide integer value corresponding to the + * index value held in *objPtr. The parsing supports all values + * recognized as any size of integer, and the syntaxes end[-+]$integer + * and $integer[-+]$integer. The argument endValue is used to give + * the meaning of the literal index value "end". Index arithmetic + * on arguments outside the wide integer range are only accepted + * when interp is a working interpreter, not NULL. * - * The value of 'objPtr' does not have one of the expected formats. If - * 'interp' is non-NULL, an error message is left in the interpreter's - * result object. - * - * Effect + * Results: + * When parsing of *objPtr successfully recognizes an index value, + * TCL_OK is returned, and the wide integer value corresponding to + * the recognized index value is written to *widePtr. When parsing + * fails, TCL_ERROR is returned and error information is written to + * interp, if non-NULL. * - * The object referenced by 'objPtr' is converted, as needed, to an - * integer, wide integer, or end-based-index object. + * Side effects: + * The type of *objPtr may change. * *---------------------------------------------------------------------- */ -int -TclGetIntForIndex( - Tcl_Interp *interp, /* Interpreter to use for error reporting. If - * NULL, then no error message is left after - * errors. */ - Tcl_Obj *objPtr, /* Points to an object containing either "end" - * or an integer. */ - int endValue, /* The value to be stored at "indexPtr" if - * "objPtr" holds "end". */ - int *indexPtr) /* Location filled in with an integer - * representing an index. */ +static int +GetWideForIndex( + Tcl_Interp *interp, /* Interpreter to use for error reporting. If + * NULL, then no error message is left after + * errors. */ + Tcl_Obj *objPtr, /* Points to the value to be parsed */ + size_t endValue, /* The value to be stored at *widePtr if + * objPtr holds "end". + * NOTE: this value may be TCL_INDEX_NONE. */ + Tcl_WideInt *widePtr) /* Location filled in with a wide integer + * representing an index. */ { - int length; - char *opPtr; - const char *bytes; + ClientData cd; + const char *opPtr; + int numType, length, t1 = 0, t2 = 0; + int code = TclGetNumberFromObj(NULL, objPtr, &cd, &numType); + + if (code == TCL_OK) { + if (numType == TCL_NUMBER_INT) { + /* objPtr holds an integer in the signed wide range */ + *widePtr = *(Tcl_WideInt *)cd; + return TCL_OK; + } + if (numType != TCL_NUMBER_BIG) { + /* Must be a double -> not a valid index */ + goto parseError; + } - if (TclGetIntFromObj(NULL, objPtr, indexPtr) == TCL_OK) { - return TCL_OK; + /* objPtr holds an integer outside the signed wide range */ + /* Truncate to the signed wide range. */ + *widePtr = (((mp_int *)cd)->sign != MP_ZPOS) ? WIDE_MIN : WIDE_MAX; + return TCL_OK; } - if (GetEndOffsetFromObj(objPtr, endValue, indexPtr) == TCL_OK) { + /* objPtr does not hold a number, check the end+/- format... */ + if (GetEndOffsetFromObj(objPtr, endValue, widePtr) == TCL_OK) { return TCL_OK; } - bytes = TclGetStringFromObj(objPtr, &length); + /* If we reach here, the string rep of objPtr exists. */ /* - * Leading whitespace is acceptable in an index. + * The valid index syntax does not include any value that is + * a list of more than one element. This is necessary so that + * lists of index values can be reliably distinguished from any + * single index value. */ - while (length && TclIsSpaceProc(*bytes)) { - bytes++; - length--; + /* + * Quick scan to see if multi-value list is even possible. + * This relies on TclGetString() returning a NUL-terminated string. + */ + if ((TclMaxListLength(TclGetString(objPtr), -1, NULL) > 1) + + /* If it's possible, do the full list parse. */ + && (TCL_OK == Tcl_ListObjLength(NULL, objPtr, &length)) + && (length > 1)) { + goto parseError; } - if (TclParseNumber(NULL, NULL, NULL, bytes, length, (const char **)&opPtr, - TCL_PARSE_INTEGER_ONLY | TCL_PARSE_NO_WHITESPACE) == TCL_OK) { - int code, first, second; - char savedOp = *opPtr; + /* Passed the list screen, so parse for index arithmetic expression */ + if (TCL_OK == TclParseNumber(NULL, objPtr, NULL, NULL, -1, &opPtr, + TCL_PARSE_INTEGER_ONLY)) { + Tcl_WideInt w1=0, w2=0; - if ((savedOp != '+') && (savedOp != '-')) { - goto parseError; - } - if (TclIsSpaceProc(opPtr[1])) { - goto parseError; - } - *opPtr = '\0'; - code = Tcl_GetInt(interp, bytes, &first); - *opPtr = savedOp; - if (code == TCL_ERROR) { - goto parseError; - } - if (TCL_ERROR == Tcl_GetInt(interp, opPtr+1, &second)) { - goto parseError; - } - if (savedOp == '+') { - *indexPtr = first + second; - } else { - *indexPtr = first - second; + /* value starts with valid integer... */ + + if ((*opPtr == '-') || (*opPtr == '+')) { + /* ... value continues with [-+] ... */ + + /* Save first integer as wide if possible */ + TclGetNumberFromObj(NULL, objPtr, &cd, &t1); + if (t1 == TCL_NUMBER_INT) { + w1 = (*(Tcl_WideInt *)cd); + } + + if (TCL_OK == TclParseNumber(NULL, objPtr, NULL, opPtr + 1, + -1, NULL, TCL_PARSE_INTEGER_ONLY)) { + /* ... value concludes with second valid integer */ + + /* Save second integer as wide if possible */ + TclGetNumberFromObj(NULL, objPtr, &cd, &t2); + if (t2 == TCL_NUMBER_INT) { + w2 = (*(Tcl_WideInt *)cd); + } + } + } + /* Clear invalid intreps left by TclParseNumber */ + TclFreeIntRep(objPtr); + + if (t1 && t2) { + /* We have both integer values */ + if ((t1 == TCL_NUMBER_INT) && (t2 == TCL_NUMBER_INT)) { + /* Both are wide, do wide-integer math */ + if (*opPtr == '-') { + if ((w2 == WIDE_MIN) && (interp != NULL)) { + goto extreme; + } + w2 = -w2; + } + + if ((w1 ^ w2) < 0) { + /* Different signs, sum cannot overflow */ + *widePtr = w1 + w2; + } else if (w1 >= 0) { + if (w1 < WIDE_MAX - w2) { + *widePtr = w1 + w2; + } else { + *widePtr = WIDE_MAX; + } + } else { + if (w1 > WIDE_MIN - w2) { + *widePtr = w1 + w2; + } else { + *widePtr = WIDE_MIN; + } + } + } else if (interp == NULL) { + /* + * We use an interp to do bignum index calculations. + * If we don't get one, call all indices with bignums errors, + * and rely on callers to handle it. + */ + return TCL_ERROR; + } else { + /* + * At least one is big, do bignum math. Little reason to + * value performance here. Re-use code. Parse has verified + * objPtr is an expression. Compute it. + */ + + Tcl_Obj *sum; + + extreme: + Tcl_ExprObj(interp, objPtr, &sum); + TclGetNumberFromObj(NULL, sum, &cd, &numType); + + if (numType == TCL_NUMBER_INT) { + /* sum holds an integer in the signed wide range */ + *widePtr = *(Tcl_WideInt *)cd; + } else { + /* sum holds an integer outside the signed wide range */ + /* Truncate to the signed wide range. */ + if (((mp_int *)cd)->sign != MP_ZPOS) { + *widePtr = WIDE_MIN; + } else { + *widePtr = WIDE_MAX; + } + } + Tcl_DecrRefCount(sum); + } + return TCL_OK; } - return TCL_OK; } - /* - * Report a parse error. - */ - + /* Report a parse error. */ parseError: if (interp != NULL) { - bytes = Tcl_GetString(objPtr); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad index \"%s\": must be integer?[+-]integer? or" - " end?[+-]integer?", bytes)); - if (!strncmp(bytes, "end-", 4)) { - bytes += 4; - } - TclCheckBadOctal(interp, bytes); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL); + char * bytes = TclGetString(objPtr); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad index \"%s\": must be integer?[+-]integer? or" + " end?[+-]integer?", bytes)); + if (!strncmp(bytes, "end-", 4)) { + bytes += 4; + } + TclCheckBadOctal(interp, bytes); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL); } - return TCL_ERROR; } /* *---------------------------------------------------------------------- * - * UpdateStringOfEndOffset -- + * Tcl_GetIntForIndex -- * - * Update the string rep of a Tcl object holding an "end-offset" - * expression. + * This function returns an integer corresponding to the list index held + * in a Tcl object. The Tcl object's value is expected to be in the + * format integer([+-]integer)? or the format end([+-]integer)?. * * Results: - * None. + * The return value is normally TCL_OK, which means that the index was + * successfully stored into the location referenced by "indexPtr". If the + * Tcl object referenced by "objPtr" has the value "end", the value + * stored is "endValue". If "objPtr"s values is not of one of the + * expected formats, TCL_ERROR is returned and, if "interp" is non-NULL, + * an error message is left in the interpreter's result object. * * Side effects: - * Stores a valid string in the object's string rep. - * - * This function does NOT free any earlier string rep. If it is called on an - * object that already has a valid string rep, it will leak memory. + * The object referenced by "objPtr" might be converted to an integer, + * wide integer, or end-based-index object. * *---------------------------------------------------------------------- */ -static void -UpdateStringOfEndOffset( - register Tcl_Obj *objPtr) +int +Tcl_GetIntForIndex( + Tcl_Interp *interp, /* Interpreter to use for error reporting. If + * NULL, then no error message is left after + * errors. */ + Tcl_Obj *objPtr, /* Points to an object containing either "end" + * or an integer. */ + int endValue, /* The value to be stored at "indexPtr" if + * "objPtr" holds "end". */ + int *indexPtr) /* Location filled in with an integer + * representing an index. */ { - char buffer[TCL_INTEGER_SPACE + 5]; - register int len = 3; + Tcl_WideInt wide; - memcpy(buffer, "end", 4); - if (objPtr->internalRep.longValue != 0) { - buffer[len++] = '-'; - len += TclFormatInt(buffer+len, -(objPtr->internalRep.longValue)); + if (GetWideForIndex(interp, objPtr, endValue, &wide) == TCL_ERROR) { + return TCL_ERROR; + } + if (wide < 0) { + *indexPtr = -1; + } else if (wide > INT_MAX) { + *indexPtr = INT_MAX; + } else { + *indexPtr = (int) wide; } - objPtr->bytes = ckalloc((unsigned) len+1); - memcpy(objPtr->bytes, buffer, (unsigned) len+1); - objPtr->length = len; + return TCL_OK; } - /* *---------------------------------------------------------------------- * * GetEndOffsetFromObj -- * - * Look for a string of the form "end[+-]offset" and convert it to an - * internal representation holding the offset. + * Look for a string of the form "end[+-]offset" and convert it to an + * internal representation holding the offset. * * Results: - * Tcl return code. + * Tcl return code. * * Side effects: - * May store a Tcl_ObjType. + * May store a Tcl_ObjType. * *---------------------------------------------------------------------- */ @@ -3825,117 +3939,86 @@ UpdateStringOfEndOffset( static int GetEndOffsetFromObj( Tcl_Obj *objPtr, /* Pointer to the object to parse */ - int endValue, /* The value to be stored at "indexPtr" if + size_t endValue, /* The value to be stored at "indexPtr" if * "objPtr" holds "end". */ - int *indexPtr) /* Location filled in with an integer + Tcl_WideInt *widePtr) /* Location filled in with an integer * representing an index. */ { - if (SetEndOffsetFromAny(NULL, objPtr) != TCL_OK) { - return TCL_ERROR; - } + Tcl_ObjIntRep *irPtr; + Tcl_WideInt offset = 0; /* Offset in the "end-offset" expression */ - /* TODO: Handle overflow cases sensibly */ - *indexPtr = endValue + (int)objPtr->internalRep.longValue; - return TCL_OK; -} + while ((irPtr = TclFetchIntRep(objPtr, &endOffsetType)) == NULL) { + Tcl_ObjIntRep ir; + int length; + const char *bytes = TclGetStringFromObj(objPtr, &length); + if ((length < 3) || (length == 4)) { + /* Too short to be "end" or to be "end-$integer" */ + return TCL_ERROR; + } + if ((*bytes != 'e') || (strncmp(bytes, "end", 3) != 0)) { + /* Value doesn't start with "end" */ + return TCL_ERROR; + } -/* - *---------------------------------------------------------------------- - * - * SetEndOffsetFromAny -- - * - * Look for a string of the form "end[+-]offset" and convert it to an - * internal representation holding the offset. - * - * Results: - * Returns TCL_OK if ok, TCL_ERROR if the string was badly formed. - * - * Side effects: - * If interp is not NULL, stores an error message in the interpreter - * result. - * - *---------------------------------------------------------------------- - */ + if (length > 4) { + ClientData cd; + int t; -static int -SetEndOffsetFromAny( - Tcl_Interp *interp, /* Tcl interpreter or NULL */ - Tcl_Obj *objPtr) /* Pointer to the object to parse */ -{ - int offset; /* Offset in the "end-offset" expression */ - register const char *bytes; /* String rep of the object */ - int length; /* Length of the object's string rep */ + /* Parse for the "end-..." or "end+..." formats */ - /* - * If it's already the right type, we're fine. - */ + if ((bytes[3] != '-') && (bytes[3] != '+')) { + /* No operator where we need one */ + return TCL_ERROR; + } + if (TclIsSpaceProc(bytes[4])) { + /* Space after + or - not permitted. */ + return TCL_ERROR; + } - if (objPtr->typePtr == &tclEndOffsetType) { - return TCL_OK; - } + /* Parse the integer offset */ + if (TCL_OK != TclParseNumber(NULL, objPtr, NULL, + bytes+4, length-4, NULL, TCL_PARSE_INTEGER_ONLY)) { + /* Not a recognized integer format */ + return TCL_ERROR; + } - /* - * Check for a string rep of the right form. - */ + /* Got an integer offset; pull it from where parser left it. */ + TclGetNumberFromObj(NULL, objPtr, &cd, &t); - bytes = TclGetStringFromObj(objPtr, &length); - if ((*bytes != 'e') || (strncmp(bytes, "end", - (size_t)((length > 3) ? 3 : length)) != 0)) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad index \"%s\": must be end?[+-]integer?", bytes)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL); + if (t == TCL_NUMBER_BIG) { + /* Truncate to the signed wide range. */ + if (((mp_int *)cd)->sign != MP_ZPOS) { + offset = (bytes[3] == '-') ? WIDE_MAX : WIDE_MIN; + } else { + offset = (bytes[3] == '-') ? WIDE_MIN : WIDE_MAX; + } + } else { + /* assert (t == TCL_NUMBER_INT); */ + offset = (*(Tcl_WideInt *)cd); + if (bytes[3] == '-') { + offset = (offset == WIDE_MIN) ? WIDE_MAX : -offset; + } + } } - return TCL_ERROR; - } - /* - * Convert the string rep. - */ - - if (length <= 3) { - offset = 0; - } else if ((length > 4) && ((bytes[3] == '-') || (bytes[3] == '+'))) { - /* - * This is our limited string expression evaluator. Pass everything - * after "end-" to Tcl_GetInt, then reverse for offset. - */ + /* Success. Store the new internal rep. */ + ir.wideValue = offset; + Tcl_StoreIntRep(objPtr, &endOffsetType, &ir); + } - if (TclIsSpaceProc(bytes[4])) { - goto badIndexFormat; - } - if (Tcl_GetInt(interp, bytes+4, &offset) != TCL_OK) { - return TCL_ERROR; - } - if (bytes[3] == '-') { + offset = irPtr->wideValue; - /* TODO: Review overflow concerns here! */ - offset = -offset; - } + if (endValue == (size_t)-1) { + *widePtr = offset - 1; + } else if (offset < 0) { + /* Different signs, sum cannot overflow */ + *widePtr = endValue + offset; + } else if (endValue < (Tcl_WideUInt)WIDE_MAX - offset) { + *widePtr = endValue + offset; } else { - /* - * Conversion failed. Report the error. - */ - - badIndexFormat: - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad index \"%s\": must be end?[+-]integer?", bytes)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL); - } - return TCL_ERROR; + *widePtr = WIDE_MAX; } - - /* - * The conversion succeeded. Free the old internal rep and set the new - * one. - */ - - TclFreeIntRep(objPtr); - objPtr->internalRep.longValue = offset; - objPtr->typePtr = &tclEndOffsetType; - return TCL_OK; } @@ -3951,7 +4034,7 @@ SetEndOffsetFromAny( * arithmetic expressions. The absolute index values that can be * directly meaningful as an index into either a list or a string are * those integer values >= TCL_INDEX_START (0) - * and < TCL_INDEX_AFTER (INT_MAX). + * and < INT_MAX. * The largest string supported in Tcl 8 has bytelength INT_MAX. * This means the largest supported character length is also INT_MAX, * and the index of the last character in a string of length INT_MAX @@ -3960,9 +4043,9 @@ SetEndOffsetFromAny( * Any absolute index value parsed outside that range is encoded * using the before and after values passed in by the * caller as the encoding to use for indices that are either - * less than or greater than the usable index range. TCL_INDEX_AFTER + * less than or greater than the usable index range. TCL_INDEX_NONE * is available as a good choice for most callers to use for - * after. Likewise, the value TCL_INDEX_BEFORE is good for + * after. Likewise, the value TCL_INDEX_NONE is good for * most callers to use for before. Other values are possible * when the caller knows it is helpful in producing its own behavior * for indices before and after the indexed item. @@ -4002,43 +4085,48 @@ TclIndexEncode( int after, /* Value to return for index after end */ int *indexPtr) /* Where to write the encoded answer, not NULL */ { - int idx; + ClientData cd; + Tcl_WideInt wide; + int idx, numType, code = TclGetNumberFromObj(NULL, objPtr, &cd, &numType); - if (TCL_OK == TclGetIntFromObj(NULL, objPtr, &idx)) { - /* We parsed a value in the range INT_MIN...INT_MAX */ + if ((code == TCL_OK) && (numType == TCL_NUMBER_INT)) { + /* We parsed a value in the range WIDE_MIN...WIDE_MAX */ + wide = (*(Tcl_WideInt *)cd); integerEncode: - if (idx < TCL_INDEX_START) { + if (wide < TCL_INDEX_START) { /* All negative absolute indices are "before the beginning" */ idx = before; - } else if (idx == INT_MAX) { + } else if (wide >= INT_MAX) { /* This index value is always "after the end" */ idx = after; - } + } else { + idx = (int) wide; + } /* usual case, the absolute index value encodes itself */ - } else if (TCL_OK == GetEndOffsetFromObj(objPtr, 0, &idx)) { + } else if (TCL_OK == GetEndOffsetFromObj(objPtr, 0, &wide)) { /* * We parsed an end+offset index value. - * idx holds the offset value in the range INT_MIN...INT_MAX. + * wide holds the offset value in the range WIDE_MIN...WIDE_MAX. */ - if (idx > 0) { + if (wide > 0) { /* * All end+postive or end-negative expressions * always indicate "after the end". */ idx = after; - } else if (idx < INT_MIN - TCL_INDEX_END) { + } else if (wide < INT_MIN - TCL_INDEX_END) { /* These indices always indicate "before the beginning */ idx = before; } else { /* Encoded end-positive (or end+negative) are offset */ - idx += TCL_INDEX_END; + idx = (int)wide + TCL_INDEX_END; } /* TODO: Consider flag to suppress repeated end-offset parse. */ - } else if (TCL_OK == TclGetIntForIndexM(interp, objPtr, 0, &idx)) { + } else if (TCL_OK == GetWideForIndex(interp, objPtr, 0, &wide)) { /* * Only reach this case when the index value is a - * constant index arithmetic expression, and idx + * constant index arithmetic expression, and wide * holds the result. Treat it the same as if it were * parsed as an absolute integer value. */ @@ -4070,10 +4158,14 @@ TclIndexDecode( int encoded, /* Value to decode */ int endValue) /* Meaning of "end" to use, > TCL_INDEX_END */ { - if (encoded <= TCL_INDEX_END) { - return (encoded - TCL_INDEX_END) + endValue; + if (encoded > TCL_INDEX_END) { + return encoded; } - return encoded; + endValue += encoded - TCL_INDEX_END; + if (endValue >= 0) { + return endValue; + } + return TCL_INDEX_NONE; } /* @@ -4289,9 +4381,10 @@ TclSetProcessGlobalValue( } else { Tcl_CreateExitHandler(FreeProcessGlobalValue, pgvPtr); } - bytes = Tcl_GetStringFromObj(newValue, &pgvPtr->numBytes); + bytes = TclGetString(newValue); + pgvPtr->numBytes = newValue->length; pgvPtr->value = ckalloc(pgvPtr->numBytes + 1); - memcpy(pgvPtr->value, bytes, (unsigned) pgvPtr->numBytes + 1); + memcpy(pgvPtr->value, bytes, pgvPtr->numBytes + 1); if (pgvPtr->encoding) { Tcl_FreeEncoding(pgvPtr->encoding); } @@ -4306,7 +4399,7 @@ TclSetProcessGlobalValue( Tcl_IncrRefCount(newValue); cacheMap = GetThreadHash(&pgvPtr->key); ClearHash(cacheMap); - hPtr = Tcl_CreateHashEntry(cacheMap, INT2PTR(pgvPtr->epoch), &dummy); + hPtr = Tcl_CreateHashEntry(cacheMap, (void *)(size_t)(pgvPtr->epoch), &dummy); Tcl_SetHashValue(hPtr, newValue); Tcl_MutexUnlock(&pgvPtr->mutex); } @@ -4332,7 +4425,7 @@ TclGetProcessGlobalValue( Tcl_Obj *value = NULL; Tcl_HashTable *cacheMap; Tcl_HashEntry *hPtr; - int epoch = pgvPtr->epoch; + unsigned int epoch = pgvPtr->epoch; if (pgvPtr->encoding) { Tcl_Encoding current = Tcl_GetEncoding(NULL, NULL); @@ -4347,8 +4440,7 @@ TclGetProcessGlobalValue( Tcl_DString native, newValue; Tcl_MutexLock(&pgvPtr->mutex); - pgvPtr->epoch++; - epoch = pgvPtr->epoch; + epoch = ++pgvPtr->epoch; Tcl_UtfToExternalDString(pgvPtr->encoding, pgvPtr->value, pgvPtr->numBytes, &native); Tcl_ExternalToUtfDString(current, Tcl_DStringValue(&native), @@ -4357,7 +4449,7 @@ TclGetProcessGlobalValue( ckfree(pgvPtr->value); pgvPtr->value = ckalloc(Tcl_DStringLength(&newValue) + 1); memcpy(pgvPtr->value, Tcl_DStringValue(&newValue), - (size_t) Tcl_DStringLength(&newValue) + 1); + Tcl_DStringLength(&newValue) + 1); Tcl_DStringFree(&newValue); Tcl_FreeEncoding(pgvPtr->encoding); pgvPtr->encoding = current; @@ -4367,7 +4459,7 @@ TclGetProcessGlobalValue( } } cacheMap = GetThreadHash(&pgvPtr->key); - hPtr = Tcl_FindHashEntry(cacheMap, (char *) INT2PTR(epoch)); + hPtr = Tcl_FindHashEntry(cacheMap, (void *)(size_t)epoch); if (NULL == hPtr) { int dummy; @@ -4400,7 +4492,7 @@ TclGetProcessGlobalValue( value = Tcl_NewStringObj(pgvPtr->value, pgvPtr->numBytes); hPtr = Tcl_CreateHashEntry(cacheMap, - INT2PTR(pgvPtr->epoch), &dummy); + (void *)(size_t)(pgvPtr->epoch), &dummy); Tcl_MutexUnlock(&pgvPtr->mutex); Tcl_SetHashValue(hPtr, value); Tcl_IncrRefCount(value); @@ -4483,11 +4575,10 @@ TclGetObjNameOfExecutable(void) const char * Tcl_GetNameOfExecutable(void) { - int numBytes; - const char *bytes = - Tcl_GetStringFromObj(TclGetObjNameOfExecutable(), &numBytes); + Tcl_Obj *obj = TclGetObjNameOfExecutable(); + const char *bytes = TclGetString(obj); - if (numBytes == 0) { + if (obj->length == 0) { return NULL; } return bytes; |