diff options
Diffstat (limited to 'generic/tclUtil.c')
| -rw-r--r-- | generic/tclUtil.c | 486 |
1 files changed, 247 insertions, 239 deletions
diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 51508d2..bc1490e 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -13,6 +13,7 @@ */ #include "tclInt.h" +#include <float.h> #include <math.h> /* @@ -39,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 @@ -62,7 +63,7 @@ static ProcessGlobalValue executableName = { * CONVERT_MASK A mask value used to extract the conversion mode from * the flags argument. * Also indicates a strange conversion mode where all - * special characters are escaped with backslashes + * special characters are escaped with backslashes * *except for braces*. This is a strange and unnecessary * case, but it's part of the historical way in which * lists have been formatted in Tcl. To experiment with @@ -80,7 +81,7 @@ static ProcessGlobalValue executableName = { * in other cases this means an overestimate of the * required size. * - * For more details, see the comments on the Tcl*Scan*Element and + * For more details, see the comments on the Tcl*Scan*Element and * Tcl*Convert*Element routines. */ @@ -106,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 @@ -117,7 +118,7 @@ static void UpdateStringOfEndOffset(Tcl_Obj *objPtr); * integer, so no memory management is required for it. */ -const Tcl_ObjType tclEndOffsetType = { +Tcl_ObjType tclEndOffsetType = { "end-offset", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ @@ -166,20 +167,20 @@ const Tcl_ObjType tclEndOffsetType = { * separating whitespace, or a string terminator. It is just * another character in a list element. * - * The interpretaton of a formatted substring as a list element follows + * The interpretation of a formatted substring as a list element follows * rules similar to the parsing of the words of a command in a Tcl script. * Backslash substitution plays a key role, and is defined exactly as it is * in command parsing. The same routine, TclParseBackslash() is used in both - * command parsing and list parsing. + * command parsing and list parsing. * * NOTE: This means that if and when backslash substitution rules ever * change for command parsing, the interpretation of strings as lists also * changes. - * + * * Backslash substitution replaces an "escape sequence" of one or more * characters starting with * \u005c \ BACKSLASH - * with a single character. The one character escape sequent case happens + * with a single character. The one character escape sequence case happens * only when BACKSLASH is the last character in the string. In all other * cases, the escape sequence is at least two characters long. * @@ -188,7 +189,7 @@ const Tcl_ObjType tclEndOffsetType = { * * * If the first character of a formatted substring is * \u007b { OPEN BRACE - * then the end of the substring is the matching + * then the end of the substring is the matching * \u007d } CLOSE BRACE * character, where matching is determined by counting nesting levels, * and not including any brace characters that are contained within a @@ -210,7 +211,7 @@ const Tcl_ObjType tclEndOffsetType = { * that includes an unbalanced brace not in a backslash escape sequence, * and any value that ends with a backslash not itself in a backslash * escape sequence. - * + * * * If the first character of a formatted substring is * \u0022 " QUOTE * then the end of the substring is the next QUOTE character, not counting @@ -245,7 +246,7 @@ const Tcl_ObjType tclEndOffsetType = { * minimum be able to produce escape sequences for the 10 characters * identified above that have significance to a list parser. * - * * * CANONICAL LISTS * * * * * + * * * CANONICAL LISTS * * * * * * * In addition to the basic rules for parsing strings into Tcl lists, there * are additional properties to be met by the set of list values that are @@ -296,7 +297,7 @@ const Tcl_ObjType tclEndOffsetType = { * This sort of coding was once fairly common, though it's become more * idiomatic to see the following instead: * set script [list puts [list $one $two $three]]; eval $script - * In order to support this guarantee, every canonical list must have + * In order to support this guarantee, every canonical list must have * balance when counting those braces that are not in escape sequences. * * Within these constraints, the canonical list generation routines @@ -338,7 +339,7 @@ const Tcl_ObjType tclEndOffsetType = { * #if COMPAT directives. This makes it easy to experiment with eliminating * this formatting mode simply with "#define COMPAT 0" above. I believe * this is worth considering. - * + * * Another consideration is the treatment of QUOTE characters in list elements. * TclConvertElement() must have the ability to produce the escape sequence * \" so that when a list element begins with a QUOTE we do not confuse @@ -383,9 +384,9 @@ const Tcl_ObjType tclEndOffsetType = { int TclMaxListLength( - const char *bytes, + CONST char *bytes, int numBytes, - const char **endPtr) + CONST char **endPtr) { int count = 0; @@ -395,7 +396,7 @@ TclMaxListLength( } /* No list element before leading white space */ - count += 1 - TclIsSpaceProc(*bytes); + count += 1 - TclIsSpaceProc(*bytes); /* Count white space runs as potential element separators */ while (numBytes) { @@ -419,7 +420,7 @@ TclMaxListLength( } /* No list element following trailing white space */ - count -= TclIsSpaceProc(bytes[-1]); + count -= TclIsSpaceProc(bytes[-1]); done: if (endPtr) { @@ -472,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 @@ -487,18 +488,18 @@ TclFindElement( * indicate that the substring of *sizePtr * bytes starting at **elementPtr is/is not * the literal list element and therefore - * does not/does require a call to + * 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. @@ -569,8 +570,6 @@ 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; } @@ -637,8 +636,6 @@ 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; } @@ -656,16 +653,12 @@ 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; } @@ -709,7 +702,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; @@ -768,18 +761,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 @@ -789,30 +782,29 @@ Tcl_SplitList( size = TclMaxListLength(list, -1, &end) + 1; length = end - list; - argv = ckalloc((size * sizeof(char *)) + length + 1); + argv = (CONST char **) ckalloc((unsigned) + ((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(argv); + ckfree((char *) argv); return result; } if (*element == 0) { break; } if (i >= size) { - ckfree(argv); + ckfree((char *) 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; } @@ -856,7 +848,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. */ { @@ -888,7 +880,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. */ @@ -932,12 +924,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. */ @@ -953,7 +945,7 @@ TclScanElement( int preferBrace = 0; /* CONVERT_MASK mode. */ int braceCount = 0; /* Count of all braces '{' '}' seen. */ #endif - + if ((p == NULL) || (length == 0) || ((*p == '\0') && (length == -1))) { /* Empty string element must be brace quoted. */ *flagPtr = CONVERT_BRACE; @@ -1020,7 +1012,7 @@ TclScanElement( extra++; /* Escape '\' => '\\' */ if ((length == 1) || ((length == -1) && (p[1] == '\0'))) { /* Final backslash. Cannot format with brace quoting. */ - requireEscape = 1; + requireEscape = 1; break; } if (p[1] == '\n') { @@ -1095,7 +1087,7 @@ TclScanElement( if (preferEscape && !preferBrace) { /* * If we are quoting solely due to ] or internal " characters - * use the CONVERT_MASK mode where we escape all special + * use the CONVERT_MASK mode where we escape all special * characters except for braces. "extra" counted space needed * to escape braces too, so substract "braceCount" to get our * actual needs. @@ -1172,7 +1164,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. */ { @@ -1202,7 +1194,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. */ @@ -1234,7 +1226,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. */ @@ -1359,7 +1351,7 @@ int TclConvertElement( if (length == -1) { return p - dst; } - /* + /* * If we reach this point, there's an embedded NULL in the * string range being processed, which should not happen when * the encoding rules for Tcl strings are properly followed. @@ -1397,7 +1389,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; @@ -1425,7 +1417,7 @@ Tcl_Merge( /* * We cannot allocate a large enough flag array to format this * list in one pass. We could imagine converting this routine - * to a multi-pass implementation, but for sizeof(int) == 4, + * to a multi-pass implementation, but for sizeof(int) == 4, * the limit is a max of 2^30 list elements and since each element * is at least one byte formatted, and requires one byte space * between it and the next one, that a minimum space requirement @@ -1436,7 +1428,7 @@ Tcl_Merge( */ Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } else { - flagPtr = ckalloc(argc * sizeof(int)); + flagPtr = (int *) ckalloc((unsigned) argc*sizeof(int)); } for (i = 0; i < argc; i++) { flagPtr[i] = ( i ? TCL_DONT_QUOTE_HASH : 0 ); @@ -1454,7 +1446,7 @@ Tcl_Merge( * Pass two: copy into the result area. */ - result = ckalloc(bytesNeeded); + result = ckalloc((unsigned) bytesNeeded); dst = result; for (i = 0; i < argc; i++) { flagPtr[i] |= ( i ? TCL_DONT_QUOTE_HASH : 0 ); @@ -1465,7 +1457,7 @@ Tcl_Merge( dst[-1] = 0; if (flagPtr != localFlags) { - ckfree(flagPtr); + ckfree((char *) flagPtr); } return result; } @@ -1491,7 +1483,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. */ @@ -1665,7 +1657,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; @@ -1686,7 +1678,7 @@ Tcl_Concat( } if (bytesNeeded + argc - 1 < 0) { /* - * Panic test could be tighter, but not going to bother for + * Panic test could be tighter, but not going to bother for * this legacy routine. */ Tcl_Panic("Tcl_Concat: max size of Tcl value exceeded"); @@ -1697,7 +1689,7 @@ Tcl_Concat( for (p = result, i = 0; i < argc; i++) { int trim, elemLength; const char *element; - + element = argv[i]; elemLength = strlen(argv[i]); @@ -1753,7 +1745,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; @@ -1778,16 +1770,36 @@ 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; } - if (resPtr) { - Tcl_ListObjAppendList(NULL, resPtr, objPtr); - } else { - resPtr = TclListObjCopy(NULL, objPtr); + TclListObjGetElements(NULL, objPtr, &listc, &listv); + if (listc) { + if (resPtr) { + if (TCL_OK != Tcl_ListObjReplace(NULL, resPtr, + INT_MAX, 0, listc, listv)) { + /* Abandon ship! */ + Tcl_DecrRefCount(resPtr); + goto slow; + } + } else { + resPtr = TclListObjCopy(NULL, objPtr); + } } } if (!resPtr) { @@ -1801,6 +1813,7 @@ Tcl_ConcatObj( * the slow way, using the string representations. */ + slow: /* First try to pre-allocate the size required */ for (i = 0; i < objc; i++) { element = TclGetStringFromObj(objv[i], &elemLength); @@ -1820,7 +1833,7 @@ Tcl_ConcatObj( for (i = 0; i < objc; i++) { int trim; - + element = TclGetStringFromObj(objv[i], &elemLength); /* Trim away the leading whitespace */ @@ -1872,8 +1885,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); @@ -1900,13 +1913,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) { @@ -2133,12 +2146,11 @@ 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; @@ -2309,10 +2321,9 @@ 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; @@ -2323,7 +2334,7 @@ TclStringMatchObj( trivial = nocase ? 0 : TclMatchIsTrivial(TclGetString(ptnObj)); */ - if ((strObj->typePtr == &tclStringType) || (strObj->typePtr == NULL)) { + if (strObj->typePtr == &tclStringType) { Tcl_UniChar *udata, *uptn; udata = Tcl_GetUnicodeFromObj(strObj, &length); @@ -2391,13 +2402,15 @@ 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); @@ -2413,12 +2426,13 @@ Tcl_DStringAppend( if (newSize >= dsPtr->spaceAvl) { dsPtr->spaceAvl = newSize * 2; if (dsPtr->string == dsPtr->staticSpace) { - char *newString = ckalloc(dsPtr->spaceAvl); + char *newString = ckalloc((unsigned) dsPtr->spaceAvl); memcpy(newString, dsPtr->string, (size_t) dsPtr->length); dsPtr->string = newString; } else { - dsPtr->string = ckrealloc(dsPtr->string, dsPtr->spaceAvl); + dsPtr->string = ckrealloc((void *) dsPtr->string, + (size_t) dsPtr->spaceAvl); } } @@ -2426,9 +2440,12 @@ Tcl_DStringAppend( * Copy the new string into the buffer at the end of the old one. */ - memcpy(dsPtr->string + dsPtr->length, bytes, length); + for (dst = dsPtr->string + dsPtr->length, end = bytes+length; + bytes < end; bytes++, dst++) { + *dst = *bytes; + } + *dst = '\0'; dsPtr->length += length; - dsPtr->string[dsPtr->length] = '\0'; return dsPtr->string; } @@ -2453,7 +2470,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; @@ -2473,12 +2490,13 @@ Tcl_DStringAppendElement( if (newSize >= dsPtr->spaceAvl) { dsPtr->spaceAvl = newSize * 2; if (dsPtr->string == dsPtr->staticSpace) { - char *newString = ckalloc(dsPtr->spaceAvl); + char *newString = ckalloc((unsigned) dsPtr->spaceAvl); memcpy(newString, dsPtr->string, (size_t) dsPtr->length); dsPtr->string = newString; } else { - dsPtr->string = ckrealloc(dsPtr->string, dsPtr->spaceAvl); + dsPtr->string = (char *) ckrealloc((void *) dsPtr->string, + (size_t) dsPtr->spaceAvl); } dst = dsPtr->string + dsPtr->length; } @@ -2555,12 +2573,13 @@ Tcl_DStringSetLength( dsPtr->spaceAvl = length + 1; } if (dsPtr->string == dsPtr->staticSpace) { - char *newString = ckalloc(dsPtr->spaceAvl); + char *newString = ckalloc((unsigned) dsPtr->spaceAvl); memcpy(newString, dsPtr->string, (size_t) dsPtr->length); dsPtr->string = newString; } else { - dsPtr->string = ckrealloc(dsPtr->string, dsPtr->spaceAvl); + dsPtr->string = (char *) ckrealloc((void *) dsPtr->string, + (size_t) dsPtr->spaceAvl); } } dsPtr->length = length; @@ -2623,16 +2642,14 @@ 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) { - iPtr->result = dsPtr->string; - iPtr->freeProc = TCL_DYNAMIC; + interp->result = dsPtr->string; + interp->freeProc = TCL_DYNAMIC; } else if (dsPtr->length < TCL_RESULT_SIZE) { - iPtr->result = iPtr->resultSpace; - memcpy(iPtr->result, dsPtr->string, dsPtr->length + 1); + interp->result = ((Interp *) interp)->resultSpace; + strcpy(interp->result, dsPtr->string); } else { Tcl_SetResult(interp, dsPtr->string, TCL_VOLATILE); } @@ -2688,9 +2705,9 @@ Tcl_DStringGetResult( dsPtr->string = iPtr->result; dsPtr->spaceAvl = dsPtr->length+1; } else { - dsPtr->string = ckalloc(dsPtr->length+1); + dsPtr->string = (char *) ckalloc((unsigned) (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; @@ -2699,7 +2716,7 @@ Tcl_DStringGetResult( dsPtr->string = dsPtr->staticSpace; dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; } else { - dsPtr->string = ckalloc(dsPtr->length+1); + dsPtr->string = (char *) ckalloc((unsigned) (dsPtr->length + 1)); dsPtr->spaceAvl = dsPtr->length + 1; } memcpy(dsPtr->string, iPtr->result, (unsigned) dsPtr->length+1); @@ -2795,62 +2812,63 @@ 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; - /* - * Handle NaN. - */ - - if (TclIsNaN(value)) { - TclFormatNaN(value, dst); - return; - } + int *precisionPtr = Tcl_GetThreadData(&precisionKey, (int)sizeof(int)); /* - * Handle infinities. - */ - - if (TclIsInfinite(value)) { + * Handle NaN. + */ + + if (TclIsNaN(value)) { + TclFormatNaN(value, dst); + return; + } + + /* + * 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: @@ -2863,28 +2881,28 @@ 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 */, + TCL_DD_E_FORMAT /* | TCL_DD_SHORTEN_FLAG */, &exponent, &signum, &end); } - if (signum) { - *dst++ = '-'; - } + if (signum) { + *dst++ = '-'; + } p = digits; if (exponent < -4 || exponent > 16) { /* * E format for numbers < 1e-3 or >= 1e17. */ - + *dst++ = *p++; c = *p; if (c != '\0') { @@ -2894,12 +2912,10 @@ 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 { @@ -2909,7 +2925,7 @@ Tcl_PrintDouble( /* * F format for others. */ - + if (exponent < 0) { *dst++ = '0'; } @@ -2964,11 +2980,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)); @@ -3005,13 +3021,13 @@ TclPrecTraceProc( */ if (Tcl_IsSafe(interp)) { - return (char *) "can't modify precision from a safe interpreter"; + return "can't modify precision from a safe interpreter"; } value = Tcl_GetVar2Ex(interp, name1, name2, flags & TCL_GLOBAL_ONLY); if (value == NULL - || Tcl_GetIntFromObj(NULL, value, &prec) != TCL_OK + || Tcl_GetIntFromObj((Tcl_Interp*) NULL, value, &prec) != TCL_OK || prec < 0 || prec > TCL_MAX_PREC) { - return (char *) "improper value for precision"; + return "improper value for precision"; } *precisionPtr = prec; return NULL; @@ -3036,8 +3052,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). */ { /* @@ -3087,7 +3103,6 @@ TclNeedSpace( * NOTE: Remove this if other Unicode spaces ever get accepted as * list-element separators. */ - return 1; } switch (*end) { @@ -3112,19 +3127,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. * *---------------------------------------------------------------------- */ @@ -3138,7 +3153,7 @@ TclFormatInt(buffer, n) long intVal; int i; int numFormatted, j; - const char *digits = "0123456789"; + char *digits = "0123456789"; /* * Check first whether "n" is zero. @@ -3156,7 +3171,8 @@ TclFormatInt(buffer, n) * negating it produces the same value. */ - if (n == -n) { + intVal = -n; /* [Bug 3390638] Workaround for*/ + if (n == -n || intVal == n) { /* broken compiler optimizers. */ return sprintf(buffer, "%ld", n); } @@ -3227,8 +3243,7 @@ TclGetIntForIndex( * representing an index. */ { int length; - char *opPtr; - const char *bytes; + char *opPtr, *bytes; if (TclGetIntFromObj(NULL, objPtr, indexPtr) == TCL_OK) { return TCL_OK; @@ -3289,13 +3304,14 @@ 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); @@ -3303,7 +3319,6 @@ TclGetIntForIndex( bytes += 4; } TclCheckBadOctal(interp, bytes); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL); } return TCL_ERROR; @@ -3331,12 +3346,12 @@ TclGetIntForIndex( static void UpdateStringOfEndOffset( - register Tcl_Obj *objPtr) + register Tcl_Obj* objPtr) { char buffer[TCL_INTEGER_SPACE + sizeof("end") + 1]; register int len; - memcpy(buffer, "end", sizeof("end") + 1); + strcpy(buffer, "end"); len = sizeof("end") - 1; if (objPtr->internalRep.longValue != 0) { buffer[len++] = '-'; @@ -3371,7 +3386,7 @@ SetEndOffsetFromAny( 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 */ + register char* bytes; /* String rep of the object */ int length; /* Length of the object's string rep */ /* @@ -3393,7 +3408,6 @@ 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; } @@ -3411,7 +3425,7 @@ SetEndOffsetFromAny( */ if (TclIsSpaceProc(bytes[4])) { - goto badIndexFormat; + return TCL_ERROR; } if (Tcl_GetInt(interp, bytes+4, &offset) != TCL_OK) { return TCL_ERROR; @@ -3424,12 +3438,10 @@ 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; } @@ -3468,9 +3480,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 @@ -3485,7 +3497,7 @@ TclCheckBadOctal( } if (*p == '0') { if ((p[1] == 'o') || p[1] == 'O') { - p += 2; + p+=2; } while (isdigit(UCHAR(*p))) { /* INTL: digit. */ p++; @@ -3532,8 +3544,7 @@ ClearHash( for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - Tcl_Obj *objPtr = Tcl_GetHashValue(hPtr); - + Tcl_Obj *objPtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr); Tcl_DecrRefCount(objPtr); Tcl_DeleteHashEntry(hPtr); } @@ -3561,12 +3572,12 @@ static Tcl_HashTable * GetThreadHash( Tcl_ThreadDataKey *keyPtr) { - Tcl_HashTable **tablePtrPtr = - Tcl_GetThreadData(keyPtr, sizeof(Tcl_HashTable *)); + Tcl_HashTable **tablePtrPtr = (Tcl_HashTable **) + Tcl_GetThreadData(keyPtr, (int) sizeof(Tcl_HashTable *)); if (NULL == *tablePtrPtr) { - *tablePtrPtr = ckalloc(sizeof(Tcl_HashTable)); - Tcl_CreateThreadExitHandler(FreeThreadHash, *tablePtrPtr); + *tablePtrPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); + Tcl_CreateThreadExitHandler(FreeThreadHash, (ClientData)*tablePtrPtr); Tcl_InitHashTable(*tablePtrPtr, TCL_ONE_WORD_KEYS); } return *tablePtrPtr; @@ -3590,11 +3601,11 @@ static void FreeThreadHash( ClientData clientData) { - Tcl_HashTable *tablePtr = clientData; + Tcl_HashTable *tablePtr = (Tcl_HashTable *) clientData; ClearHash(tablePtr); Tcl_DeleteHashTable(tablePtr); - ckfree(tablePtr); + ckfree((char *) tablePtr); } /* @@ -3612,7 +3623,7 @@ static void FreeProcessGlobalValue( ClientData clientData) { - ProcessGlobalValue *pgvPtr = clientData; + ProcessGlobalValue *pgvPtr = (ProcessGlobalValue *) clientData; pgvPtr->epoch++; pgvPtr->numBytes = 0; @@ -3642,7 +3653,7 @@ TclSetProcessGlobalValue( Tcl_Obj *newValue, Tcl_Encoding encoding) { - const char *bytes; + CONST char *bytes; Tcl_HashTable *cacheMap; Tcl_HashEntry *hPtr; int dummy; @@ -3660,7 +3671,7 @@ TclSetProcessGlobalValue( Tcl_CreateExitHandler(FreeProcessGlobalValue, (ClientData) pgvPtr); } bytes = Tcl_GetStringFromObj(newValue, &pgvPtr->numBytes); - pgvPtr->value = ckalloc(pgvPtr->numBytes + 1); + pgvPtr->value = ckalloc((unsigned) pgvPtr->numBytes + 1); memcpy(pgvPtr->value, bytes, (unsigned) pgvPtr->numBytes + 1); if (pgvPtr->encoding) { Tcl_FreeEncoding(pgvPtr->encoding); @@ -3676,8 +3687,9 @@ TclSetProcessGlobalValue( Tcl_IncrRefCount(newValue); cacheMap = GetThreadHash(&pgvPtr->key); ClearHash(cacheMap); - hPtr = Tcl_CreateHashEntry(cacheMap, INT2PTR(pgvPtr->epoch), &dummy); - Tcl_SetHashValue(hPtr, newValue); + hPtr = Tcl_CreateHashEntry(cacheMap, + (char *) INT2PTR(pgvPtr->epoch), &dummy); + Tcl_SetHashValue(hPtr, (ClientData) newValue); Tcl_MutexUnlock(&pgvPtr->mutex); } @@ -3725,7 +3737,8 @@ TclGetProcessGlobalValue( Tcl_DStringLength(&native), &newValue); Tcl_DStringFree(&native); ckfree(pgvPtr->value); - pgvPtr->value = ckalloc(Tcl_DStringLength(&newValue) + 1); + pgvPtr->value = ckalloc((unsigned int) + Tcl_DStringLength(&newValue) + 1); memcpy(pgvPtr->value, Tcl_DStringValue(&newValue), (size_t) Tcl_DStringLength(&newValue) + 1); Tcl_DStringFree(&newValue); @@ -3757,11 +3770,12 @@ 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, pgvPtr); + Tcl_CreateExitHandler(FreeProcessGlobalValue, (ClientData)pgvPtr); } /* @@ -3770,12 +3784,12 @@ TclGetProcessGlobalValue( value = Tcl_NewStringObj(pgvPtr->value, pgvPtr->numBytes); hPtr = Tcl_CreateHashEntry(cacheMap, - INT2PTR(pgvPtr->epoch), &dummy); + (char *) INT2PTR(pgvPtr->epoch), &dummy); Tcl_MutexUnlock(&pgvPtr->mutex); - Tcl_SetHashValue(hPtr, value); + Tcl_SetHashValue(hPtr, (ClientData) value); Tcl_IncrRefCount(value); } - return Tcl_GetHashValue(hPtr); + return (Tcl_Obj *) Tcl_GetHashValue(hPtr); } /* @@ -3787,7 +3801,7 @@ TclGetProcessGlobalValue( * (normally as computed by TclpFindExecutable). * * Results: - * None. + * None. * * Side effects: * Stores the executable name. @@ -3818,7 +3832,7 @@ TclSetObjNameOfExecutable( * pathname of the application is unknown. * * Side effects: - * None. + * None. * *---------------------------------------------------------------------- */ @@ -3837,20 +3851,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; @@ -3940,8 +3954,8 @@ TclReToGlob( int *exactPtr) { int anchorLeft, anchorRight, lastIsStar, numStars; - char *dsStr, *dsStrStart; - const char *msg, *p, *strEnd, *code; + char *dsStr, *dsStrStart, *msg; + const char *p, *strEnd; strEnd = reStr + reStrLen; Tcl_DStringInit(dsPtr); @@ -3952,11 +3966,10 @@ 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, reStrLen + 2); + Tcl_DStringSetLength(dsPtr, 2*reStrLen + 2); dsStr = dsStrStart = Tcl_DStringValue(dsPtr); *dsStr++ = '*'; for (p = reStr + 4; p < strEnd; p++) { @@ -3979,8 +3992,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); @@ -3990,12 +4003,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; @@ -4052,7 +4065,6 @@ TclReToGlob( break; default: msg = "invalid escape sequence"; - code = "BADESCAPE"; goto invalidGlob; } break; @@ -4081,7 +4093,6 @@ TclReToGlob( case '$': if (p+1 != strEnd) { msg = "$ not anchor"; - code = "NONANCHOR"; goto invalidGlob; } anchorRight = 1; @@ -4089,8 +4100,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; @@ -4102,9 +4113,7 @@ 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; } @@ -4133,7 +4142,6 @@ TclReToGlob( #endif if (interp != NULL) { Tcl_AppendResult(interp, msg, NULL); - Tcl_SetErrorCode(interp, "TCL", "RE2GLOB", code, NULL); } Tcl_DStringFree(dsPtr); return TCL_ERROR; |