diff options
Diffstat (limited to 'generic/tclUtil.c')
| -rw-r--r-- | generic/tclUtil.c | 473 |
1 files changed, 232 insertions, 241 deletions
diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 5119456..a1c1996 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -13,7 +13,7 @@ */ #include "tclInt.h" -#include <float.h> +#include "tclParse.h" #include <math.h> /* @@ -40,11 +40,11 @@ static ProcessGlobalValue executableName = { * quoting not be used when converting the list * element. * TCL_DONT_QUOTE_HASH - 1 means the caller insists that a leading hash - * character ('#') should *not* be quoted. This - * is appropriate when the caller can guarantee - * the element is not the first element of a - * list, so [eval] cannot mis-parse the element - * as a comment. + * character ('#') should *not* be quoted. This + * is appropriate when the caller can guarantee + * the element is not the first element of a + * list, so [eval] cannot mis-parse the element + * as a comment. * * The remaining values which can be carried by the flags of these routines * are for internal use only. Make sure they do not overlap with the public @@ -107,9 +107,9 @@ static void ClearHash(Tcl_HashTable *tablePtr); static void FreeProcessGlobalValue(ClientData clientData); static void FreeThreadHash(ClientData clientData); static Tcl_HashTable * GetThreadHash(Tcl_ThreadDataKey *keyPtr); -static int SetEndOffsetFromAny(Tcl_Interp* interp, - Tcl_Obj* objPtr); -static void UpdateStringOfEndOffset(Tcl_Obj* objPtr); +static int SetEndOffsetFromAny(Tcl_Interp *interp, + Tcl_Obj *objPtr); +static void UpdateStringOfEndOffset(Tcl_Obj *objPtr); /* * The following is the Tcl object type definition for an object that @@ -118,7 +118,7 @@ static void UpdateStringOfEndOffset(Tcl_Obj* objPtr); * integer, so no memory management is required for it. */ -Tcl_ObjType tclEndOffsetType = { +const Tcl_ObjType tclEndOffsetType = { "end-offset", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ @@ -384,9 +384,9 @@ Tcl_ObjType tclEndOffsetType = { int TclMaxListLength( - CONST char *bytes, + const char *bytes, int numBytes, - CONST char **endPtr) + const char **endPtr) { int count = 0; @@ -473,13 +473,13 @@ TclFindElement( Tcl_Interp *interp, /* Interpreter to use for error reporting. If * NULL, then no error message is left after * errors. */ - CONST char *list, /* Points to the first byte of a string + const char *list, /* Points to the first byte of a string * containing a Tcl list with zero or more * elements (possibly in braces). */ int listLength, /* Number of bytes in the list's string. */ - CONST char **elementPtr, /* Where to put address of first significant + const char **elementPtr, /* Where to put address of first significant * character in first element of list. */ - CONST char **nextPtr, /* Fill in with location of character just + const char **nextPtr, /* Fill in with location of character just * after all white space following end of * argument (next arg or end of list). */ int *sizePtr, /* If non-zero, fill in with size of @@ -491,15 +491,15 @@ TclFindElement( * does not/does require a call to * TclCopyAndCollapse() by the caller. */ { - CONST char *p = list; - CONST char *elemStart; /* Points to first byte of first element. */ - CONST char *limit; /* Points just after list's last byte. */ + const char *p = list; + const char *elemStart; /* Points to first byte of first element. */ + const char *limit; /* Points just after list's last byte. */ int openBraces = 0; /* Brace nesting level during parse. */ int inQuotes = 0; int size = 0; /* lint. */ int numChars; int literal = 1; - CONST char *p2; + const char *p2; /* * Skim off leading white space and check for an opening brace or quote. @@ -570,6 +570,8 @@ TclFindElement( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "list element in braces followed by \"%.*s\" " "instead of space", (int) (p2-p), p)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "JUNK", + NULL); } return TCL_ERROR; } @@ -636,6 +638,8 @@ TclFindElement( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "list element in quotes followed by \"%.*s\" " "instead of space", (int) (p2-p), p)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "JUNK", + NULL); } return TCL_ERROR; } @@ -653,12 +657,16 @@ TclFindElement( if (interp != NULL) { Tcl_SetResult(interp, "unmatched open brace in list", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "BRACE", + NULL); } return TCL_ERROR; } else if (inQuotes) { if (interp != NULL) { Tcl_SetResult(interp, "unmatched open quote in list", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "QUOTE", + NULL); } return TCL_ERROR; } @@ -702,7 +710,7 @@ TclFindElement( int TclCopyAndCollapse( int count, /* Number of byte to copy from src. */ - CONST char *src, /* Copy from here... */ + const char *src, /* Copy from here... */ char *dst) /* ... to here. */ { int newCount = 0; @@ -761,18 +769,18 @@ int Tcl_SplitList( Tcl_Interp *interp, /* Interpreter to use for error reporting. If * NULL, no error message is left. */ - CONST char *list, /* Pointer to string with list structure. */ + const char *list, /* Pointer to string with list structure. */ int *argcPtr, /* Pointer to location to fill in with the * number of elements in the list. */ - CONST char ***argvPtr) /* Pointer to place to store pointer to array + const char ***argvPtr) /* Pointer to place to store pointer to array * of pointers to list elements. */ { - CONST char **argv, *end, *element; + const char **argv, *end, *element; char *p; int length, size, i, result, elSize; /* - * Allocate enough space to work in. A (CONST char *) for each + * Allocate enough space to work in. A (const char *) for each * (possible) list element plus one more for terminating NULL, * plus as many bytes as in the original string value, plus one * more for a terminating '\0'. Space used to hold element separating @@ -782,29 +790,30 @@ Tcl_SplitList( size = TclMaxListLength(list, -1, &end) + 1; length = end - list; - argv = (CONST char **) ckalloc((unsigned) - ((size * sizeof(char *)) + length + 1)); + argv = ckalloc((size * sizeof(char *)) + length + 1); for (i = 0, p = ((char *) argv) + size*sizeof(char *); *list != 0; i++) { - CONST char *prevList = list; + const char *prevList = list; int literal; result = TclFindElement(interp, list, length, &element, &list, &elSize, &literal); length -= (list - prevList); if (result != TCL_OK) { - ckfree((char *) argv); + ckfree(argv); return result; } if (*element == 0) { break; } if (i >= size) { - ckfree((char *) argv); + ckfree(argv); if (interp != NULL) { Tcl_SetResult(interp, "internal error in Tcl_SplitList", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "INTERNAL", "Tcl_SplitList", + NULL); } return TCL_ERROR; } @@ -848,7 +857,7 @@ Tcl_SplitList( int Tcl_ScanElement( - register CONST char *src, /* String to convert to list element. */ + register const char *src, /* String to convert to list element. */ register int *flagPtr) /* Where to store information to guide * Tcl_ConvertCountedElement. */ { @@ -880,7 +889,7 @@ Tcl_ScanElement( int Tcl_ScanCountedElement( - CONST char *src, /* String to convert to Tcl list element. */ + const char *src, /* String to convert to Tcl list element. */ int length, /* Number of bytes in src, or -1. */ int *flagPtr) /* Where to store information to guide * Tcl_ConvertElement. */ @@ -924,12 +933,12 @@ Tcl_ScanCountedElement( int TclScanElement( - CONST char *src, /* String to convert to Tcl list element. */ + const char *src, /* String to convert to Tcl list element. */ int length, /* Number of bytes in src, or -1. */ int *flagPtr) /* Where to store information to guide * Tcl_ConvertElement. */ { - CONST char *p = src; + const char *p = src; int nestingLevel = 0; /* Brace nesting count */ int forbidNone = 0; /* Do not permit CONVERT_NONE mode. Something needs protection or escape. */ @@ -964,15 +973,16 @@ TclScanElement( } while (length) { + if (CHAR_TYPE(*p) != TYPE_NORMAL) { switch (*p) { - case '{': + case '{': /* TYPE_BRACE */ #if COMPAT braceCount++; #endif extra++; /* Escape '{' => '\{' */ nestingLevel++; break; - case '}': + case '}': /* TYPE_BRACE */ #if COMPAT braceCount++; #endif @@ -983,8 +993,8 @@ TclScanElement( requireEscape = 1; } break; - case ']': - case '"': + case ']': /* TYPE_CLOSE_BRACK */ + case '"': /* TYPE_SPACE */ #if COMPAT forbidNone = 1; extra++; /* Escapes all just prepend a backslash */ @@ -993,22 +1003,22 @@ TclScanElement( #else /* FLOW THROUGH */ #endif - case '[': - case '$': - case ';': - case ' ': - case '\f': - case '\n': - case '\r': - case '\t': - case '\v': + case '[': /* TYPE_SUBS */ + case '$': /* TYPE_SUBS */ + case ';': /* TYPE_COMMAND_END */ + case ' ': /* TYPE_SPACE */ + case '\f': /* TYPE_SPACE */ + case '\n': /* TYPE_COMMAND_END */ + case '\r': /* TYPE_SPACE */ + case '\t': /* TYPE_SPACE */ + case '\v': /* TYPE_SPACE */ forbidNone = 1; extra++; /* Escape sequences all one byte longer. */ #if COMPAT preferBrace = 1; #endif break; - case '\\': + case '\\': /* TYPE_SUBS */ extra++; /* Escape '\' => '\\' */ if ((length == 1) || ((length == -1) && (p[1] == '\0'))) { /* Final backslash. Cannot format with brace quoting. */ @@ -1033,13 +1043,14 @@ TclScanElement( preferBrace = 1; #endif break; - case '\0': + case '\0': /* TYPE_SUBS */ if (length == -1) { goto endOfString; } /* TODO: Panic on improper encoding? */ break; } + } length -= (length > 0); p++; } @@ -1164,7 +1175,7 @@ TclScanElement( int Tcl_ConvertElement( - register CONST char *src, /* Source information for list element. */ + register const char *src, /* Source information for list element. */ register char *dst, /* Place to put list-ified element. */ register int flags) /* Flags produced by Tcl_ScanElement. */ { @@ -1194,7 +1205,7 @@ Tcl_ConvertElement( int Tcl_ConvertCountedElement( - register CONST char *src, /* Source information for list element. */ + register const char *src, /* Source information for list element. */ int length, /* Number of bytes in src, or -1. */ char *dst, /* Place to put list-ified element. */ int flags) /* Flags produced by Tcl_ScanElement. */ @@ -1226,7 +1237,7 @@ Tcl_ConvertCountedElement( */ int TclConvertElement( - register CONST char *src, /* Source information for list element. */ + register const char *src, /* Source information for list element. */ int length, /* Number of bytes in src, or -1. */ char *dst, /* Place to put list-ified element. */ int flags) /* Flags produced by Tcl_ScanElement. */ @@ -1389,7 +1400,7 @@ int TclConvertElement( char * Tcl_Merge( int argc, /* How many strings to merge. */ - CONST char * CONST *argv) /* Array of string values. */ + const char *const *argv) /* Array of string values. */ { # define LOCAL_SIZE 20 int localFlags[LOCAL_SIZE], *flagPtr = NULL; @@ -1428,7 +1439,7 @@ Tcl_Merge( */ Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } else { - flagPtr = (int *) ckalloc((unsigned) argc*sizeof(int)); + flagPtr = ckalloc(argc * sizeof(int)); } for (i = 0; i < argc; i++) { flagPtr[i] = ( i ? TCL_DONT_QUOTE_HASH : 0 ); @@ -1446,7 +1457,7 @@ Tcl_Merge( * Pass two: copy into the result area. */ - result = ckalloc((unsigned) bytesNeeded); + result = ckalloc(bytesNeeded); dst = result; for (i = 0; i < argc; i++) { flagPtr[i] |= ( i ? TCL_DONT_QUOTE_HASH : 0 ); @@ -1457,7 +1468,7 @@ Tcl_Merge( dst[-1] = 0; if (flagPtr != localFlags) { - ckfree((char *) flagPtr); + ckfree(flagPtr); } return result; } @@ -1483,7 +1494,7 @@ Tcl_Merge( char Tcl_Backslash( - CONST char *src, /* Points to the backslash character of a + const char *src, /* Points to the backslash character of a * backslash sequence. */ int *readPtr) /* Fill in with number of characters read from * src, unless NULL. */ @@ -1657,7 +1668,7 @@ TclTrimLeft( char * Tcl_Concat( int argc, /* Number of strings to concatenate. */ - CONST char * CONST *argv) /* Array of strings to concatenate. */ + const char *const *argv) /* Array of strings to concatenate. */ { int i, needSpace = 0, bytesNeeded = 0; char *result, *p; @@ -1745,7 +1756,7 @@ Tcl_Concat( Tcl_Obj * Tcl_ConcatObj( int objc, /* Number of objects to concatenate. */ - Tcl_Obj *CONST objv[]) /* Array of objects to concatenate. */ + Tcl_Obj *const objv[]) /* Array of objects to concatenate. */ { int i, elemLength, needSpace = 0, bytesNeeded = 0; const char *element; @@ -1770,31 +1781,16 @@ Tcl_ConcatObj( } } if (i == objc) { - Tcl_Obj **listv; - int listc; - resPtr = NULL; for (i = 0; i < objc; i++) { - /* - * Tcl_ListObjAppendList could be used here, but this saves us a - * bit of type checking (since we've already done it). Use of - * INT_MAX tells us to always put the new stuff on the end. It - * will be set right in Tcl_ListObjReplace. - * Note that all objs at this point are either lists or have an - * empty string rep. - */ - objPtr = objv[i]; if (objPtr->bytes && objPtr->length == 0) { continue; } - TclListObjGetElements(NULL, objPtr, &listc, &listv); - if (listc) { - if (resPtr) { - Tcl_ListObjReplace(NULL, resPtr, INT_MAX, 0, listc, listv); - } else { - resPtr = TclListObjCopy(NULL, objPtr); - } + if (resPtr) { + Tcl_ListObjAppendList(NULL, resPtr, objPtr); + } else { + resPtr = TclListObjCopy(NULL, objPtr); } } if (!resPtr) { @@ -1879,8 +1875,8 @@ Tcl_ConcatObj( int Tcl_StringMatch( - CONST char *str, /* String. */ - CONST char *pattern) /* Pattern, which may contain special + const char *str, /* String. */ + const char *pattern) /* Pattern, which may contain special * characters. */ { return Tcl_StringCaseMatch(str, pattern, 0); @@ -1907,13 +1903,13 @@ Tcl_StringMatch( int Tcl_StringCaseMatch( - CONST char *str, /* String. */ - CONST char *pattern, /* Pattern, which may contain special + const char *str, /* String. */ + const char *pattern, /* Pattern, which may contain special * characters. */ int nocase) /* 0 for case sensitive, 1 for insensitive */ { int p, charLen; - CONST char *pstart = pattern; + const char *pstart = pattern; Tcl_UniChar ch1, ch2; while (1) { @@ -2140,11 +2136,12 @@ Tcl_StringCaseMatch( int TclByteArrayMatch( - const unsigned char *string, /* String. */ - int strLen, /* Length of String */ - const unsigned char *pattern, /* Pattern, which may contain special - * characters. */ - int ptnLen, /* Length of Pattern */ + const unsigned char *string,/* String. */ + int strLen, /* Length of String */ + const unsigned char *pattern, + /* Pattern, which may contain special + * characters. */ + int ptnLen, /* Length of Pattern */ int flags) { const unsigned char *stringEnd, *patternEnd; @@ -2315,9 +2312,10 @@ TclByteArrayMatch( int TclStringMatchObj( - Tcl_Obj *strObj, /* string object. */ - Tcl_Obj *ptnObj, /* pattern object. */ - int flags) /* Only TCL_MATCH_NOCASE should be passed or 0. */ + Tcl_Obj *strObj, /* string object. */ + Tcl_Obj *ptnObj, /* pattern object. */ + int flags) /* Only TCL_MATCH_NOCASE should be passed, or + * 0. */ { int match, length, plen; @@ -2328,13 +2326,13 @@ TclStringMatchObj( trivial = nocase ? 0 : TclMatchIsTrivial(TclGetString(ptnObj)); */ - if ((strObj->typePtr == &tclStringType)) { + if ((strObj->typePtr == &tclStringType) || (strObj->typePtr == NULL)) { Tcl_UniChar *udata, *uptn; udata = Tcl_GetUnicodeFromObj(strObj, &length); uptn = Tcl_GetUnicodeFromObj(ptnObj, &plen); match = TclUniCharMatch(udata, length, uptn, plen, flags); - } else if ((strObj->typePtr == &tclByteArrayType) && !flags) { + } else if (TclIsPureByteArray(strObj) && !flags) { unsigned char *data, *ptn; data = Tcl_GetByteArrayFromObj(strObj, &length); @@ -2396,15 +2394,13 @@ Tcl_DStringInit( char * Tcl_DStringAppend( Tcl_DString *dsPtr, /* Structure describing dynamic string. */ - CONST char *bytes, /* String to append. If length is -1 then this + const char *bytes, /* String to append. If length is -1 then this * must be null-terminated. */ int length) /* Number of bytes from "bytes" to append. If * < 0, then append all of bytes, up to null * at end. */ { int newSize; - char *dst; - CONST char *end; if (length < 0) { length = strlen(bytes); @@ -2420,13 +2416,12 @@ Tcl_DStringAppend( if (newSize >= dsPtr->spaceAvl) { dsPtr->spaceAvl = newSize * 2; if (dsPtr->string == dsPtr->staticSpace) { - char *newString = ckalloc((unsigned) dsPtr->spaceAvl); + char *newString = ckalloc(dsPtr->spaceAvl); memcpy(newString, dsPtr->string, (size_t) dsPtr->length); dsPtr->string = newString; } else { - dsPtr->string = ckrealloc((void *) dsPtr->string, - (size_t) dsPtr->spaceAvl); + dsPtr->string = ckrealloc(dsPtr->string, dsPtr->spaceAvl); } } @@ -2434,12 +2429,9 @@ Tcl_DStringAppend( * Copy the new string into the buffer at the end of the old one. */ - for (dst = dsPtr->string + dsPtr->length, end = bytes+length; - bytes < end; bytes++, dst++) { - *dst = *bytes; - } - *dst = '\0'; + memcpy(dsPtr->string + dsPtr->length, bytes, length); dsPtr->length += length; + dsPtr->string[dsPtr->length] = '\0'; return dsPtr->string; } @@ -2464,7 +2456,7 @@ Tcl_DStringAppend( char * Tcl_DStringAppendElement( Tcl_DString *dsPtr, /* Structure describing dynamic string. */ - CONST char *element) /* String to append. Must be + const char *element) /* String to append. Must be * null-terminated. */ { char *dst = dsPtr->string + dsPtr->length; @@ -2484,13 +2476,12 @@ Tcl_DStringAppendElement( if (newSize >= dsPtr->spaceAvl) { dsPtr->spaceAvl = newSize * 2; if (dsPtr->string == dsPtr->staticSpace) { - char *newString = ckalloc((unsigned) dsPtr->spaceAvl); + char *newString = ckalloc(dsPtr->spaceAvl); memcpy(newString, dsPtr->string, (size_t) dsPtr->length); dsPtr->string = newString; } else { - dsPtr->string = (char *) ckrealloc((void *) dsPtr->string, - (size_t) dsPtr->spaceAvl); + dsPtr->string = ckrealloc(dsPtr->string, dsPtr->spaceAvl); } dst = dsPtr->string + dsPtr->length; } @@ -2567,13 +2558,12 @@ Tcl_DStringSetLength( dsPtr->spaceAvl = length + 1; } if (dsPtr->string == dsPtr->staticSpace) { - char *newString = ckalloc((unsigned) dsPtr->spaceAvl); + char *newString = ckalloc(dsPtr->spaceAvl); memcpy(newString, dsPtr->string, (size_t) dsPtr->length); dsPtr->string = newString; } else { - dsPtr->string = (char *) ckrealloc((void *) dsPtr->string, - (size_t) dsPtr->spaceAvl); + dsPtr->string = ckrealloc(dsPtr->string, dsPtr->spaceAvl); } } dsPtr->length = length; @@ -2636,14 +2626,16 @@ Tcl_DStringResult( Tcl_DString *dsPtr) /* Dynamic string that is to become the * result of interp. */ { + Interp *iPtr = (Interp *) interp; + Tcl_ResetResult(interp); if (dsPtr->string != dsPtr->staticSpace) { - interp->result = dsPtr->string; - interp->freeProc = TCL_DYNAMIC; + iPtr->result = dsPtr->string; + iPtr->freeProc = TCL_DYNAMIC; } else if (dsPtr->length < TCL_RESULT_SIZE) { - interp->result = ((Interp *) interp)->resultSpace; - strcpy(interp->result, dsPtr->string); + iPtr->result = iPtr->resultSpace; + memcpy(iPtr->result, dsPtr->string, dsPtr->length + 1); } else { Tcl_SetResult(interp, dsPtr->string, TCL_VOLATILE); } @@ -2699,9 +2691,9 @@ Tcl_DStringGetResult( dsPtr->string = iPtr->result; dsPtr->spaceAvl = dsPtr->length+1; } else { - dsPtr->string = (char *) ckalloc((unsigned) (dsPtr->length+1)); + dsPtr->string = ckalloc(dsPtr->length+1); memcpy(dsPtr->string, iPtr->result, (unsigned) dsPtr->length+1); - (*iPtr->freeProc)(iPtr->result); + iPtr->freeProc(iPtr->result); } dsPtr->spaceAvl = dsPtr->length+1; iPtr->freeProc = NULL; @@ -2710,7 +2702,7 @@ Tcl_DStringGetResult( dsPtr->string = dsPtr->staticSpace; dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; } else { - dsPtr->string = (char *) ckalloc((unsigned) (dsPtr->length + 1)); + dsPtr->string = ckalloc(dsPtr->length+1); dsPtr->spaceAvl = dsPtr->length + 1; } memcpy(dsPtr->string, iPtr->result, (unsigned) dsPtr->length+1); @@ -2806,63 +2798,62 @@ Tcl_PrintDouble( char *p, c; int exponent; int signum; - char* digits; - char* end; - - int *precisionPtr = Tcl_GetThreadData(&precisionKey, (int)sizeof(int)); + char *digits; + char *end; + int *precisionPtr = Tcl_GetThreadData(&precisionKey, (int) sizeof(int)); /* - * Handle NaN. - */ - - if (TclIsNaN(value)) { - TclFormatNaN(value, dst); - return; - } - - /* - * Handle infinities. - */ + * Handle NaN. + */ + + if (TclIsNaN(value)) { + TclFormatNaN(value, dst); + return; + } - if (TclIsInfinite(value)) { + /* + * Handle infinities. + */ + + if (TclIsInfinite(value)) { /* * Remember to copy the terminating NUL too. */ - if (value < 0) { + if (value < 0) { memcpy(dst, "-Inf", 5); - } else { + } else { memcpy(dst, "Inf", 4); - } - return; } + return; + } - /* - * Ordinary (normal and denormal) values. - */ - + /* + * Ordinary (normal and denormal) values. + */ + if (*precisionPtr == 0) { digits = TclDoubleDigits(value, -1, TCL_DD_SHORTEST, - &exponent, &signum, &end); + &exponent, &signum, &end); } else { /* * There are at least two possible interpretations for tcl_precision. * * The first is, "choose the decimal representation having - * $tcl_precision digits of significance that is nearest to the - * given number, breaking ties by rounding to even, and then - * trimming trailing zeros." This gives the greatest possible - * precision in the decimal string, but offers the anomaly that - * [expr 0.1] will be "0.10000000000000001". + * $tcl_precision digits of significance that is nearest to the given + * number, breaking ties by rounding to even, and then trimming + * trailing zeros." This gives the greatest possible precision in the + * decimal string, but offers the anomaly that [expr 0.1] will be + * "0.10000000000000001". * - * The second is "choose the decimal representation having at - * most $tcl_precision digits of significance that is nearest - * to the given number. If no such representation converts - * exactly to the given number, choose the one that is closest, - * breaking ties by rounding to even. If more than one such - * representation converts exactly to the given number, choose - * the shortest, breaking ties in favour of the nearest, breaking - * remaining ties in favour of the one ending in an even digit." + * The second is "choose the decimal representation having at most + * $tcl_precision digits of significance that is nearest to the given + * number. If no such representation converts exactly to the given + * number, choose the one that is closest, breaking ties by rounding + * to even. If more than one such representation converts exactly to + * the given number, choose the shortest, breaking ties in favour of + * the nearest, breaking remaining ties in favour of the one ending in + * an even digit." * * Tcl 8.4 implements the first of these, which gives rise to * anomalies in formatting: @@ -2875,22 +2866,22 @@ Tcl_PrintDouble( * 9.9999999999999995e-08 * * For human readability, it appears better to choose the second rule, - * and let [expr 0.1] return 0.1. But for 8.4 compatibility, we - * prefer the first (the recommended zero value for tcl_precision - * avoids the problem entirely). + * and let [expr 0.1] return 0.1. But for 8.4 compatibility, we prefer + * the first (the recommended zero value for tcl_precision avoids the + * problem entirely). * - * Uncomment TCL_DD_SHORTEN_FLAG in the next call to prefer the - * method that allows floating point values to be shortened if - * it can be done without loss of precision. + * Uncomment TCL_DD_SHORTEN_FLAG in the next call to prefer the method + * that allows floating point values to be shortened if it can be done + * without loss of precision. */ digits = TclDoubleDigits(value, *precisionPtr, TCL_DD_E_FORMAT /* | TCL_DD_SHORTEN_FLAG */, &exponent, &signum, &end); } - if (signum) { - *dst++ = '-'; - } + if (signum) { + *dst++ = '-'; + } p = digits; if (exponent < -4 || exponent > 16) { /* @@ -2906,10 +2897,12 @@ Tcl_PrintDouble( c = *++p; } } - /* - * Tcl 8.4 appears to format with at least a two-digit exponent; \ + + /* + * Tcl 8.4 appears to format with at least a two-digit exponent; * preserve that behaviour when tcl_precision != 0 */ + if (*precisionPtr == 0) { sprintf(dst, "e%+d", exponent); } else { @@ -2974,11 +2967,11 @@ char * TclPrecTraceProc( ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Interpreter containing variable. */ - CONST char *name1, /* Name of variable. */ - CONST char *name2, /* Second part of variable name. */ + const char *name1, /* Name of variable. */ + const char *name2, /* Second part of variable name. */ int flags) /* Information about what happened. */ { - Tcl_Obj* value; + Tcl_Obj *value; int prec; int *precisionPtr = Tcl_GetThreadData(&precisionKey, (int) sizeof(int)); @@ -3015,13 +3008,13 @@ TclPrecTraceProc( */ if (Tcl_IsSafe(interp)) { - return "can't modify precision from a safe interpreter"; + return (char *) "can't modify precision from a safe interpreter"; } value = Tcl_GetVar2Ex(interp, name1, name2, flags & TCL_GLOBAL_ONLY); if (value == NULL - || Tcl_GetIntFromObj((Tcl_Interp*) NULL, value, &prec) != TCL_OK + || Tcl_GetIntFromObj(NULL, value, &prec) != TCL_OK || prec < 0 || prec > TCL_MAX_PREC) { - return "improper value for precision"; + return (char *) "improper value for precision"; } *precisionPtr = prec; return NULL; @@ -3046,8 +3039,8 @@ TclPrecTraceProc( int TclNeedSpace( - CONST char *start, /* First character in string. */ - CONST char *end) /* End of string (place where space will be + const char *start, /* First character in string. */ + const char *end) /* End of string (place where space will be * added, if appropriate). */ { /* @@ -3097,6 +3090,7 @@ TclNeedSpace( * NOTE: Remove this if other Unicode spaces ever get accepted as * list-element separators. */ + return 1; } switch (*end) { @@ -3121,19 +3115,19 @@ TclNeedSpace( * This procedure formats an integer into a sequence of decimal digit * characters in a buffer. If the integer is negative, a minus sign is * inserted at the start of the buffer. A null character is inserted at - * the end of the formatted characters. It is the caller's - * responsibility to ensure that enough storage is available. This - * procedure has the effect of sprintf(buffer, "%ld", n) but is faster - * as proven in benchmarks. This is key to UpdateStringOfInt, which - * is a common path for a lot of code (e.g. int-indexed arrays). + * the end of the formatted characters. It is the caller's responsibility + * to ensure that enough storage is available. This procedure has the + * effect of sprintf(buffer, "%ld", n) but is faster as proven in + * benchmarks. This is key to UpdateStringOfInt, which is a common path + * for a lot of code (e.g. int-indexed arrays). * * Results: * An integer representing the number of characters formatted, not * including the terminating \0. * * Side effects: - * The formatted characters are written into the storage pointer to - * by the "buffer" argument. + * The formatted characters are written into the storage pointer to by + * the "buffer" argument. * *---------------------------------------------------------------------- */ @@ -3147,7 +3141,7 @@ TclFormatInt(buffer, n) long intVal; int i; int numFormatted, j; - char *digits = "0123456789"; + const char *digits = "0123456789"; /* * Check first whether "n" is zero. @@ -3237,7 +3231,8 @@ TclGetIntForIndex( * representing an index. */ { int length; - char *opPtr, *bytes; + char *opPtr; + const char *bytes; if (TclGetIntFromObj(NULL, objPtr, indexPtr) == TCL_OK) { return TCL_OK; @@ -3298,14 +3293,13 @@ TclGetIntForIndex( parseError: if (interp != NULL) { - char *bytes = Tcl_GetString(objPtr); - /* * The result might not be empty; this resets it which should be both * a cheap operation, and of little problem because this is an * error-generation path anyway. */ + bytes = Tcl_GetString(objPtr); Tcl_ResetResult(interp); Tcl_AppendResult(interp, "bad index \"", bytes, "\": must be integer?[+-]integer? or end?[+-]integer?", NULL); @@ -3313,6 +3307,7 @@ TclGetIntForIndex( bytes += 4; } TclCheckBadOctal(interp, bytes); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL); } return TCL_ERROR; @@ -3340,12 +3335,12 @@ TclGetIntForIndex( static void UpdateStringOfEndOffset( - register Tcl_Obj* objPtr) + register Tcl_Obj *objPtr) { char buffer[TCL_INTEGER_SPACE + sizeof("end") + 1]; register int len; - strcpy(buffer, "end"); + memcpy(buffer, "end", sizeof("end") + 1); len = sizeof("end") - 1; if (objPtr->internalRep.longValue != 0) { buffer[len++] = '-'; @@ -3380,7 +3375,7 @@ SetEndOffsetFromAny( Tcl_Obj *objPtr) /* Pointer to the object to parse */ { int offset; /* Offset in the "end-offset" expression */ - register char* bytes; /* String rep of the object */ + register const char *bytes; /* String rep of the object */ int length; /* Length of the object's string rep */ /* @@ -3402,6 +3397,7 @@ SetEndOffsetFromAny( Tcl_ResetResult(interp); Tcl_AppendResult(interp, "bad index \"", bytes, "\": must be end?[+-]integer?", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL); } return TCL_ERROR; } @@ -3419,7 +3415,7 @@ SetEndOffsetFromAny( */ if (TclIsSpaceProc(bytes[4])) { - return TCL_ERROR; + goto badIndexFormat; } if (Tcl_GetInt(interp, bytes+4, &offset) != TCL_OK) { return TCL_ERROR; @@ -3432,10 +3428,12 @@ SetEndOffsetFromAny( * Conversion failed. Report the error. */ + badIndexFormat: if (interp != NULL) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "bad index \"", bytes, "\": must be end?[+-]integer?", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL); } return TCL_ERROR; } @@ -3474,9 +3472,9 @@ TclCheckBadOctal( Tcl_Interp *interp, /* Interpreter to use for error reporting. If * NULL, then no error message is left after * errors. */ - CONST char *value) /* String to check. */ + const char *value) /* String to check. */ { - register CONST char *p = value; + register const char *p = value; /* * A frequent mistake is invalid octal values due to an unwanted leading @@ -3491,7 +3489,7 @@ TclCheckBadOctal( } if (*p == '0') { if ((p[1] == 'o') || p[1] == 'O') { - p+=2; + p += 2; } while (isdigit(UCHAR(*p))) { /* INTL: digit. */ p++; @@ -3538,7 +3536,8 @@ ClearHash( for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - Tcl_Obj *objPtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr); + Tcl_Obj *objPtr = Tcl_GetHashValue(hPtr); + Tcl_DecrRefCount(objPtr); Tcl_DeleteHashEntry(hPtr); } @@ -3566,12 +3565,12 @@ static Tcl_HashTable * GetThreadHash( Tcl_ThreadDataKey *keyPtr) { - Tcl_HashTable **tablePtrPtr = (Tcl_HashTable **) - Tcl_GetThreadData(keyPtr, (int) sizeof(Tcl_HashTable *)); + Tcl_HashTable **tablePtrPtr = + Tcl_GetThreadData(keyPtr, sizeof(Tcl_HashTable *)); if (NULL == *tablePtrPtr) { - *tablePtrPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); - Tcl_CreateThreadExitHandler(FreeThreadHash, (ClientData)*tablePtrPtr); + *tablePtrPtr = ckalloc(sizeof(Tcl_HashTable)); + Tcl_CreateThreadExitHandler(FreeThreadHash, *tablePtrPtr); Tcl_InitHashTable(*tablePtrPtr, TCL_ONE_WORD_KEYS); } return *tablePtrPtr; @@ -3595,11 +3594,11 @@ static void FreeThreadHash( ClientData clientData) { - Tcl_HashTable *tablePtr = (Tcl_HashTable *) clientData; + Tcl_HashTable *tablePtr = clientData; ClearHash(tablePtr); Tcl_DeleteHashTable(tablePtr); - ckfree((char *) tablePtr); + ckfree(tablePtr); } /* @@ -3617,7 +3616,7 @@ static void FreeProcessGlobalValue( ClientData clientData) { - ProcessGlobalValue *pgvPtr = (ProcessGlobalValue *) clientData; + ProcessGlobalValue *pgvPtr = clientData; pgvPtr->epoch++; pgvPtr->numBytes = 0; @@ -3647,7 +3646,7 @@ TclSetProcessGlobalValue( Tcl_Obj *newValue, Tcl_Encoding encoding) { - CONST char *bytes; + const char *bytes; Tcl_HashTable *cacheMap; Tcl_HashEntry *hPtr; int dummy; @@ -3665,7 +3664,7 @@ TclSetProcessGlobalValue( Tcl_CreateExitHandler(FreeProcessGlobalValue, (ClientData) pgvPtr); } bytes = Tcl_GetStringFromObj(newValue, &pgvPtr->numBytes); - pgvPtr->value = ckalloc((unsigned) pgvPtr->numBytes + 1); + pgvPtr->value = ckalloc(pgvPtr->numBytes + 1); memcpy(pgvPtr->value, bytes, (unsigned) pgvPtr->numBytes + 1); if (pgvPtr->encoding) { Tcl_FreeEncoding(pgvPtr->encoding); @@ -3681,9 +3680,8 @@ TclSetProcessGlobalValue( Tcl_IncrRefCount(newValue); cacheMap = GetThreadHash(&pgvPtr->key); ClearHash(cacheMap); - hPtr = Tcl_CreateHashEntry(cacheMap, - (char *) INT2PTR(pgvPtr->epoch), &dummy); - Tcl_SetHashValue(hPtr, (ClientData) newValue); + hPtr = Tcl_CreateHashEntry(cacheMap, INT2PTR(pgvPtr->epoch), &dummy); + Tcl_SetHashValue(hPtr, newValue); Tcl_MutexUnlock(&pgvPtr->mutex); } @@ -3731,8 +3729,7 @@ TclGetProcessGlobalValue( Tcl_DStringLength(&native), &newValue); Tcl_DStringFree(&native); ckfree(pgvPtr->value); - pgvPtr->value = ckalloc((unsigned int) - Tcl_DStringLength(&newValue) + 1); + pgvPtr->value = ckalloc(Tcl_DStringLength(&newValue) + 1); memcpy(pgvPtr->value, Tcl_DStringValue(&newValue), (size_t) Tcl_DStringLength(&newValue) + 1); Tcl_DStringFree(&newValue); @@ -3764,12 +3761,11 @@ TclGetProcessGlobalValue( Tcl_MutexLock(&pgvPtr->mutex); if ((NULL == pgvPtr->value) && (pgvPtr->proc)) { pgvPtr->epoch++; - (*(pgvPtr->proc))(&pgvPtr->value, &pgvPtr->numBytes, - &pgvPtr->encoding); + pgvPtr->proc(&pgvPtr->value,&pgvPtr->numBytes,&pgvPtr->encoding); if (pgvPtr->value == NULL) { Tcl_Panic("PGV Initializer did not initialize"); } - Tcl_CreateExitHandler(FreeProcessGlobalValue, (ClientData)pgvPtr); + Tcl_CreateExitHandler(FreeProcessGlobalValue, pgvPtr); } /* @@ -3778,12 +3774,12 @@ TclGetProcessGlobalValue( value = Tcl_NewStringObj(pgvPtr->value, pgvPtr->numBytes); hPtr = Tcl_CreateHashEntry(cacheMap, - (char *) INT2PTR(pgvPtr->epoch), &dummy); + INT2PTR(pgvPtr->epoch), &dummy); Tcl_MutexUnlock(&pgvPtr->mutex); - Tcl_SetHashValue(hPtr, (ClientData) value); + Tcl_SetHashValue(hPtr, value); Tcl_IncrRefCount(value); } - return (Tcl_Obj *) Tcl_GetHashValue(hPtr); + return Tcl_GetHashValue(hPtr); } /* @@ -3795,7 +3791,7 @@ TclGetProcessGlobalValue( * (normally as computed by TclpFindExecutable). * * Results: - * None. + * None. * * Side effects: * Stores the executable name. @@ -3826,7 +3822,7 @@ TclSetObjNameOfExecutable( * pathname of the application is unknown. * * Side effects: - * None. + * None. * *---------------------------------------------------------------------- */ @@ -3845,20 +3841,20 @@ TclGetObjNameOfExecutable(void) * This function retrieves the absolute pathname of the application in * which the Tcl library is running, and returns it in string form. * - * The returned string belongs to Tcl and should be copied if the caller - * plans to keep it, to guard against it becoming invalid. + * The returned string belongs to Tcl and should be copied if the caller + * plans to keep it, to guard against it becoming invalid. * * Results: * A pointer to the internal string or NULL if the internal full path * name has not been computed or unknown. * * Side effects: - * None. + * None. * *---------------------------------------------------------------------- */ -CONST char * +const char * Tcl_GetNameOfExecutable(void) { int numBytes; @@ -3948,8 +3944,8 @@ TclReToGlob( int *exactPtr) { int anchorLeft, anchorRight, lastIsStar, numStars; - char *dsStr, *dsStrStart, *msg; - const char *p, *strEnd; + char *dsStr, *dsStrStart; + const char *msg, *p, *strEnd, *code; strEnd = reStr + reStrLen; Tcl_DStringInit(dsPtr); @@ -3960,10 +3956,11 @@ TclReToGlob( if ((reStrLen >= 4) && (memcmp("***=", reStr, 4) == 0)) { /* - * At most, the glob pattern has length 2*reStrLen + 2 to - * backslash escape every character and have * at each end. + * At most, the glob pattern has length 2*reStrLen + 2 to backslash + * escape every character and have * at each end. */ - Tcl_DStringSetLength(dsPtr, 2*reStrLen + 2); + + Tcl_DStringSetLength(dsPtr, reStrLen + 2); dsStr = dsStrStart = Tcl_DStringValue(dsPtr); *dsStr++ = '*'; for (p = reStr + 4; p < strEnd; p++) { @@ -3986,8 +3983,8 @@ TclReToGlob( } /* - * At most, the glob pattern has length reStrLen + 2 to account - * for possible * at each end. + * At most, the glob pattern has length reStrLen + 2 to account for + * possible * at each end. */ Tcl_DStringSetLength(dsPtr, reStrLen + 2); @@ -3997,12 +3994,12 @@ TclReToGlob( * Check for anchored REs (ie ^foo$), so we can use string equal if * possible. Do not alter the start of str so we can free it correctly. * - * Keep track of the last char being an unescaped star to prevent - * multiple instances. Simpler than checking that the last star - * may be escaped. + * Keep track of the last char being an unescaped star to prevent multiple + * instances. Simpler than checking that the last star may be escaped. */ msg = NULL; + code = NULL; p = reStr; anchorRight = 0; lastIsStar = 0; @@ -4059,6 +4056,7 @@ TclReToGlob( break; default: msg = "invalid escape sequence"; + code = "BADESCAPE"; goto invalidGlob; } break; @@ -4087,6 +4085,7 @@ TclReToGlob( case '$': if (p+1 != strEnd) { msg = "$ not anchor"; + code = "NONANCHOR"; goto invalidGlob; } anchorRight = 1; @@ -4094,8 +4093,8 @@ TclReToGlob( case '*': case '+': case '?': case '|': case '^': case '{': case '}': case '(': case ')': case '[': case ']': msg = "unhandled RE special char"; + code = "UNHANDLED"; goto invalidGlob; - break; default: *dsStr++ = *p; break; @@ -4107,7 +4106,9 @@ TclReToGlob( * Heuristic: if >1 non-anchoring *, the risk is large that glob * matching is slower than the RE engine, so report invalid. */ + msg = "excessive recursive glob backtrack potential"; + code = "OVERCOMPLEX"; goto invalidGlob; } @@ -4120,22 +4121,12 @@ TclReToGlob( *exactPtr = (anchorLeft && anchorRight); } -#if 0 - fprintf(stderr, "INPUT RE '%.*s' OUTPUT GLOB '%s' anchor %d:%d \n", - reStrLen, reStr, - Tcl_DStringValue(dsPtr), anchorLeft, anchorRight); - fflush(stderr); -#endif return TCL_OK; invalidGlob: -#if 0 - fprintf(stderr, "INPUT RE '%.*s' NO OUTPUT GLOB %s (%c)\n", - reStrLen, reStr, msg, *p); - fflush(stderr); -#endif if (interp != NULL) { Tcl_AppendResult(interp, msg, NULL); + Tcl_SetErrorCode(interp, "TCL", "RE2GLOB", code, NULL); } Tcl_DStringFree(dsPtr); return TCL_ERROR; |