diff options
Diffstat (limited to 'generic/tclUtil.c')
| -rw-r--r-- | generic/tclUtil.c | 188 |
1 files changed, 147 insertions, 41 deletions
diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 869169a..278380d 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -11,10 +11,32 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUtil.c,v 1.58 2005/05/05 18:38:06 dgp Exp $ + * RCS: @(#) $Id: tclUtil.c,v 1.59 2005/05/10 18:34:52 kennykb Exp $ */ #include "tclInt.h" +#include <float.h> +#include <math.h> + +/* + * Define test for NaN + */ + +#ifdef _MSC_VER +#define IS_NAN(f) (_isnan((f))) +#else +#define IS_NAN(f) ((f) != (f)) +#endif + +/* + * Define test for Inf + */ + +#ifdef _MSC_VER +#define IS_INF(f) ( ! (_finite((f)))) +#else +#define IS_INF(f) ( (f) > DBL_MAX || (f) < -DBL_MAX ) +#endif /* * The absolute pathname of the executable in which this Tcl library @@ -56,12 +78,9 @@ static ProcessGlobalValue executableName = {0, 0, NULL, NULL, NULL, NULL, NULL}; * TclPrecTraceProc. */ -static char precisionString[10] = "12"; - /* The string value of all the tcl_precision - * variables. */ -static char precisionFormat[10] = "%.12g"; - /* The format string actually used in calls - * to sprintf. */ +static int precision = 0; /* Precision of floating point conversions, + * in the range 0-17 inclusive. */ + TCL_DECLARE_MUTEX(precisionMutex) /* @@ -1879,33 +1898,125 @@ Tcl_PrintDouble(interp, value, dst) * characters. */ { char *p, c; + int prec; + int exp; + int signum; + char buffer[TCL_DOUBLE_SPACE]; Tcl_UniChar ch; Tcl_MutexLock(&precisionMutex); - sprintf(dst, precisionFormat, value); + prec = precision; Tcl_MutexUnlock(&precisionMutex); /* - * If the ASCII result looks like an integer, add ".0" so that it - * doesn't look like an integer anymore. This prevents floating-point - * values from being converted to integers unintentionally. - * Check for ASCII specifically to speed up the function. + * If prec == 0, then use TclDoubleDigits to develop a decimal + * significand and exponent, then format it in E or F format as + * appropriate. If prec != 0, use the native sprintf and then + * add a trailing ".0" if there is no decimal point in the rep. */ - for (p = dst; *p != 0; ) { - if (UCHAR(*p) < 0x80) { - c = *p++; - } else { - p += Tcl_UtfToUniChar(p, &ch); - c = UCHAR(ch); + if ( prec == 0 ) { + + /* Handle NaN */ + + if ( IS_NAN( value ) ) { + TclFormatNaN( value, dst ); + return; } - if ((c == '.') || isalpha(UCHAR(c))) { /* INTL: ISO only. */ + + /* Handle infinities */ + + if ( IS_INF( value ) ) { + if ( value < 0 ) { + strcpy( dst, "-Inf" ); + } else { + strcpy( dst, "Inf" ); + } return; } + + /* Ordinary (normal and denormal) values */ + + exp = TclDoubleDigits( buffer, value, &signum ); + if ( signum ) { + *dst++ = '-'; + } + prec = strlen( buffer ); + p = buffer; + if ( exp < -3 || exp > 17 ) { + + /* E format for numbers < 1e-3 or >= 1e17 */ + + *dst++ = *p++; + c = *p; + if ( c != '\0' ) { + *dst++ = '.'; + while ( c != '\0' ) { + *dst++ = c; + c = *++p; + } + } + sprintf( dst, "e%+d", exp-1 ); + } else { + + /* F format for others */ + + if ( exp <= 0 ) { + *dst++ = '0'; + } + c = *p; + while ( exp-- > 0 ) { + if ( c != '\0' ) { + *dst++ = c; + c = *++p; + } else { + *dst++ = '0'; + } + } + *dst++ = '.'; + if ( c == '\0' ) { + *dst++ = '0'; + } else { + while ( ++exp < 0 ) { + *dst++ = '0'; + } + while ( c != '\0' ) { + *dst++ = c; + c = *++p; + } + } + *dst++ = '\0'; + } + + } else { + + /* tcl_precision is supplied, pass it to the native sprintf */ + + sprintf( dst, "%.*g", prec, value ); + + /* + * If the ASCII result looks like an integer, add ".0" so that it + * doesn't look like an integer anymore. This prevents floating-point + * values from being converted to integers unintentionally. + * Check for ASCII specifically to speed up the function. + */ + + for (p = dst; *p != 0; ) { + if (UCHAR(*p) < 0x80) { + c = *p++; + } else { + p += Tcl_UtfToUniChar(p, &ch); + c = UCHAR(ch); + } + if ((c == '.') || isalpha(UCHAR(c))) { /* INTL: ISO only. */ + return; + } + } + p[0] = '.'; + p[1] = '0'; + p[2] = 0; + } - p[0] = '.'; - p[1] = '0'; - p[2] = 0; } /* @@ -1937,8 +2048,7 @@ TclPrecTraceProc(clientData, interp, name1, name2, flags) CONST char *name2; /* Second part of variable name. */ int flags; /* Information about what happened. */ { - CONST char *value; - char *end; + Tcl_Obj* value; int prec; /* @@ -1961,11 +2071,11 @@ TclPrecTraceProc(clientData, interp, name1, name2, flags) * out of date. */ - Tcl_MutexLock(&precisionMutex); if (flags & TCL_TRACE_READS) { - Tcl_SetVar2(interp, name1, name2, precisionString, - flags & TCL_GLOBAL_ONLY); + Tcl_MutexLock(&precisionMutex); + Tcl_SetVar2Ex( interp, name1, name2, Tcl_NewIntObj( precision ), + flags & TCL_GLOBAL_ONLY ); Tcl_MutexUnlock(&precisionMutex); return (char *) NULL; } @@ -1978,25 +2088,21 @@ TclPrecTraceProc(clientData, interp, name1, name2, flags) */ if (Tcl_IsSafe(interp)) { - Tcl_SetVar2(interp, name1, name2, precisionString, - flags & TCL_GLOBAL_ONLY); + Tcl_MutexLock(&precisionMutex); + Tcl_SetVar2Ex( interp, name1, name2, Tcl_NewIntObj( precision ), + flags & TCL_GLOBAL_ONLY ); Tcl_MutexUnlock(&precisionMutex); return "can't modify precision from a safe interpreter"; } - value = Tcl_GetVar2(interp, name1, name2, flags & TCL_GLOBAL_ONLY); - if (value == NULL) { - value = ""; - } - prec = strtoul(value, &end, 10); - if ((prec <= 0) || (prec > TCL_MAX_PREC) || (prec > 100) || - (end == value) || (*end != 0)) { - Tcl_SetVar2(interp, name1, name2, precisionString, - flags & TCL_GLOBAL_ONLY); - Tcl_MutexUnlock(&precisionMutex); + value = Tcl_GetVar2Ex(interp, name1, name2, flags & TCL_GLOBAL_ONLY); + if ( value == NULL + || Tcl_GetIntFromObj( (Tcl_Interp*) NULL, value, &prec ) != TCL_OK + || prec < 0 + || prec > TCL_MAX_PREC ) { return "improper value for precision"; } - TclFormatInt(precisionString, prec); - sprintf(precisionFormat, "%%.%dg", prec); + Tcl_MutexLock( &precisionMutex ); + precision = prec; Tcl_MutexUnlock(&precisionMutex); return (char *) NULL; } |