summaryrefslogtreecommitdiffstats
path: root/generic/tclUtil.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclUtil.c')
-rw-r--r--generic/tclUtil.c473
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;