Index: libguile/numbers.c =================================================================== RCS file: /cvsroot/guile/guile/guile-core/libguile/numbers.c,v retrieving revision 1.220 diff -u -r1.220 numbers.c --- libguile/numbers.c 3 Jan 2004 21:38:38 -0000 1.220 +++ libguile/numbers.c 6 Jan 2004 18:13:50 -0000 @@ -91,7 +91,7 @@ /* FLOBUFLEN is the maximum number of characters neccessary for the * printed or scm_string representation of an inexact number. */ -#define FLOBUFLEN (10+2*(sizeof(double)/sizeof(char)*SCM_CHAR_BIT*3+9)/10) +#define FLOBUFLEN (40+2*(sizeof(double)/sizeof(char)*SCM_CHAR_BIT*3+9)/10) #if defined (SCO) #if ! defined (HAVE_ISNAN) @@ -1848,19 +1848,71 @@ #undef FUNC_NAME /*** NUMBERS -> STRINGS ***/ -int scm_dblprec; -static const double fx[] = -{ 0.0, 5e-1, 5e-2, 5e-3, 5e-4, 5e-5, - 5e-6, 5e-7, 5e-8, 5e-9, 5e-10, - 5e-11, 5e-12, 5e-13, 5e-14, 5e-15, - 5e-16, 5e-17, 5e-18, 5e-19, 5e-20}; +#define SCM_MAX_DBL_PREC 60 +#define SCM_MAX_DBL_RADIX 36 + +/* this is an array starting with radix 2, and ending with radix SCM_MAX_DBL_RADIX */ +static int scm_dblprec[SCM_MAX_DBL_RADIX - 1]; +static double fx_per_radix[SCM_MAX_DBL_RADIX - 1][SCM_MAX_DBL_PREC]; + +static +void init_dblprec(int *prec, int radix) { + /* determine floating point precision by adding successively + smaller increments to 1.0 until it is considered == 1.0 */ + double f = ((double)1.0)/radix; + double fsum = 1.0 + f; + + *prec = 0; + while (fsum != 1.0) + { + if (++(*prec) > SCM_MAX_DBL_PREC) + fsum = 1.0; + else + { + f /= radix; + fsum = f + 1.0; + } + } + (*prec) -= 1; +} + +static +void init_fx_radix(double *fx_list, int radix) +{ + /* initialize a per-radix list of tolerances. When added + to a number < 1.0, we can determine if we should raund + up and quit converting a number to a string. */ + int i; + fx_list[0] = 0.0; + fx_list[1] = 0.5; + for( i = 2 ; i < SCM_MAX_DBL_PREC; ++i ) + fx_list[i] = (fx_list[i-1] / radix); +} + +/* use this array as a way to generate a single digit */ +static const char*number_chars="0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"; static size_t -idbl2str (double f, char *a) +idbl2str (double f, char *a, int radix) { - int efmt, dpt, d, i, wp = scm_dblprec; - size_t ch = 0; - int exp = 0; + int efmt, dpt, d, i, wp; + double *fx; +#ifdef DBL_MIN_10_EXP + double f_cpy; + int exp_cpy; +#endif /* DBL_MIN_10_EXP */ + size_t ch = 0; + int exp = 0; + + if(radix < 2 || + radix > SCM_MAX_DBL_RADIX) + { + /* revert to existing behavior */ + radix = 10; + } + + wp = scm_dblprec[radix-2]; + fx = fx_per_radix[radix-2]; if (f == 0.0) { @@ -1870,7 +1922,6 @@ if (sgn < 0.0) a[ch++] = '-'; #endif - goto zero; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */ } @@ -1896,10 +1947,15 @@ #ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from make-uniform-vector, from causing infinite loops. */ - while (f < 1.0) + /* just do the checking...if it passes, we do the conversion for our + radix again below */ + f_cpy = f; + exp_cpy = exp; + + while (f_cpy < 1.0) { - f *= 10.0; - if (exp-- < DBL_MIN_10_EXP) + f_cpy *= 10.0; + if (exp_cpy-- < DBL_MIN_10_EXP) { a[ch++] = '#'; a[ch++] = '.'; @@ -1907,10 +1963,10 @@ return ch; } } - while (f > 10.0) + while (f_cpy > 10.0) { - f *= 0.10; - if (exp++ > DBL_MAX_10_EXP) + f_cpy *= 0.10; + if (exp_cpy++ > DBL_MAX_10_EXP) { a[ch++] = '#'; a[ch++] = '.'; @@ -1918,25 +1974,27 @@ return ch; } } -#else +#endif + while (f < 1.0) { - f *= 10.0; + f *= radix; exp--; } - while (f > 10.0) + while (f > radix) { - f /= 10.0; + f /= radix; exp++; } -#endif - if (f + fx[wp] >= 10.0) + + if (f + fx[wp] >= radix) { f = 1.0; exp++; } zero: -#ifdef ENGNOT +#ifdef ENGNOT + /* adding 9999 makes this equivalent to abs(x) % 3 */ dpt = (exp + 9999) % 3; exp -= dpt++; efmt = 1; @@ -1963,15 +2021,15 @@ { d = f; f -= d; - a[ch++] = d + '0'; + a[ch++] = number_chars[d]; if (f < fx[wp]) break; if (f + fx[wp] >= 1.0) { - a[ch - 1]++; + a[ch - 1] = number_chars[d+1]; break; } - f *= 10.0; + f *= radix; if (!(--dpt)) a[ch++] = '.'; } @@ -2006,26 +2064,25 @@ exp = -exp; a[ch++] = '-'; } - for (i = 10; i <= exp; i *= 10); - for (i /= 10; i; i /= 10) + for (i = radix; i <= exp; i *= radix); + for (i /= radix; i; i /= radix) { - a[ch++] = exp / i + '0'; + a[ch++] = number_chars[exp / i]; exp %= i; } } return ch; } - static size_t -iflo2str (SCM flt, char *str) +iflo2str (SCM flt, char *str, int radix) { size_t i; if (SCM_REALP (flt)) - i = idbl2str (SCM_REAL_VALUE (flt), str); + i = idbl2str (SCM_REAL_VALUE (flt), str, radix); else { - i = idbl2str (SCM_COMPLEX_REAL (flt), str); + i = idbl2str (SCM_COMPLEX_REAL (flt), str, radix); if (SCM_COMPLEX_IMAG (flt) != 0.0) { double imag = SCM_COMPLEX_IMAG (flt); @@ -2033,7 +2090,7 @@ NaN. They will provide their own sign. */ if (0 <= imag && !xisinf (imag) && !xisnan (imag)) str[i++] = '+'; - i += idbl2str (imag, &str[i]); + i += idbl2str (imag, &str[i], radix); str[i++] = 'i'; } } @@ -2114,7 +2171,7 @@ else if (SCM_INEXACTP (n)) { char num_buf [FLOBUFLEN]; - return scm_mem2string (num_buf, iflo2str (n, num_buf)); + return scm_mem2string (num_buf, iflo2str (n, num_buf, base)); } else SCM_WRONG_TYPE_ARG (1, n); @@ -2129,7 +2186,7 @@ scm_print_real (SCM sexp, SCM port, scm_print_state *pstate SCM_UNUSED) { char num_buf[FLOBUFLEN]; - scm_lfwrite (num_buf, iflo2str (sexp, num_buf), port); + scm_lfwrite (num_buf, iflo2str (sexp, num_buf, 10), port); return !0; } @@ -2138,7 +2195,7 @@ { char num_buf[FLOBUFLEN]; - scm_lfwrite (num_buf, iflo2str (sexp, num_buf), port); + scm_lfwrite (num_buf, iflo2str (sexp, num_buf, 10), port); return !0; } @@ -5538,13 +5595,12 @@ #undef FUNC_NAME #endif - void scm_init_numbers () { + int i; abs_most_negative_fixnum = scm_i_long2big (- SCM_MOST_NEGATIVE_FIXNUM); scm_permanent_object (abs_most_negative_fixnum); - mpz_init_set_si (z_negative_one, -1); /* It may be possible to tune the performance of some algorithms by using @@ -5559,25 +5615,17 @@ scm_add_feature ("complex"); scm_add_feature ("inexact"); scm_flo0 = scm_make_real (0.0); + + /* determine floating point precision */ + for(i=2; i <= SCM_MAX_DBL_RADIX; ++i) + { + init_dblprec(&scm_dblprec[i-2],i); + init_fx_radix(fx_per_radix[i-2],i); + } #ifdef DBL_DIG - scm_dblprec = (DBL_DIG > 20) ? 20 : DBL_DIG; -#else - { /* determine floating point precision */ - double f = 0.1; - double fsum = 1.0 + f; - while (fsum != 1.0) - { - if (++scm_dblprec > 20) - fsum = 1.0; - else - { - f /= 10.0; - fsum = f + 1.0; - } - } - scm_dblprec = scm_dblprec - 1; - } -#endif /* DBL_DIG */ + /* hard code precision for base 10 if the preprocessor tells us to... */ + scm_dblprec[10-2] = (DBL_DIG > 20) ? 20 : DBL_DIG; +#endif #ifdef GUILE_DEBUG check_sanity ();