diff --git a/src/c/Makefile.in b/src/c/Makefile.in index 4889acf57..32c461133 100644 --- a/src/c/Makefile.in +++ b/src/c/Makefile.in @@ -43,6 +43,8 @@ OBJS = main.o symbol.o package.o list.o\ instance.o gfun.o reference.o character.o\ file.o read.o print.o error.o string.o cfun.o\ reader/parse_integer.o reader/parse_number.o \ + printer/float_to_digits.o printer/float_to_string.o \ + printer/integer_to_string.o \ typespec.o assignment.o \ predicate.o number.o\ num_pred.o num_comp.o num_arith.o num_sfun.o num_co.o\ diff --git a/src/c/format.d b/src/c/format.d index c2ed6329b..f5fd47f5e 100644 --- a/src/c/format.d +++ b/src/c/format.d @@ -15,8 +15,15 @@ See file '../Copyright' for full details. */ +#include +#include +#define ECL_INCLUDE_MATH_H +#define ECL_DEFINE_FENV_CONSTANTS #include #include +#if defined(HAVE_FENV_H) +# include +#endif #include #if !defined(ECL_CMU_FORMAT) @@ -736,6 +743,113 @@ fmt_character(format_stack fmt, bool colon, bool atsign) } } +/* The floating point precision is required to make the + most-positive-long-float printed expression readable. + If this is too small, then the rounded off fraction, may be too big + to read */ + +/* Maximum number of significant digits required to represent accurately + * a double or single float. */ + +#define LOG10_2 0.30103 +#define DBL_SIG ((int)(DBL_MANT_DIG * LOG10_2 + 1)) +#define FLT_SIG ((int)(FLT_MANT_DIG * LOG10_2 + 1)) + +/* This is the maximum number of decimal digits that our numbers will have. + * Notice that we leave some extra margin, to ensure that reading the number + * again will produce the same floating point number. + */ +#ifdef ECL_LONG_FLOAT +# define LDBL_SIG ((int)(LDBL_MANT_DIG * LOG10_2 + 1)) +# define DBL_MAX_DIGITS (LDBL_SIG + 3) +# define DBL_EXPONENT_SIZE (1 + 1 + 4) +#else +# define DBL_MAX_DIGITS (DBL_SIG + 3) +# define DBL_EXPONENT_SIZE (1 + 1 + 3) /* Exponent marker 'e' + sign + digits .*/ +#endif + +/* The sinificant digits + the possible sign + the decimal dot. */ +#define DBL_MANTISSA_SIZE (DBL_MAX_DIGITS + 1 + 1) +/* Total estimated size that a floating point number can take. */ +#define DBL_SIZE (DBL_MANTISSA_SIZE + DBL_EXPONENT_SIZE) + +#ifdef ECL_LONG_FLOAT +#define EXP_STRING "Le" +#define G_EXP_STRING "Lg" +#define DBL_TYPE long double +#define strtod strtold +extern long double strtold(const char *nptr, char **endptr); +#else +#define EXP_STRING "e" +#define G_EXP_STRING "g" +#define DBL_TYPE double +#endif + +static int +edit_double(int n, DBL_TYPE d, int *sp, char *s, int *ep) +{ + char *exponent, buff[DBL_SIZE + 1]; + int length; +#if defined(HAVE_FENV_H) || defined(ECL_MS_WINDOWS_HOST) + fenv_t env; + feholdexcept(&env); +#endif + unlikely_if (isnan(d) || !isfinite(d)) { + FEerror("Can't print a non-number.", 0); + } + if (n < -DBL_MAX_DIGITS) + n = DBL_MAX_DIGITS; + if (n < 0) { + DBL_TYPE aux; + n = -n; + do { + sprintf(buff, "%- *.*" EXP_STRING, n + 1 + 1 + DBL_EXPONENT_SIZE, n-1, d); + aux = strtod(buff, NULL); +#ifdef ECL_LONG_FLOAT + if (n < LDBL_SIG) + aux = (double) aux; +#endif + if (n < DBL_SIG) + aux = (float)aux; + n++; + } while (d != aux && n <= DBL_MAX_DIGITS); + n--; + } else { + sprintf(buff, "%- *.*" EXP_STRING, DBL_SIZE, + (n <= DBL_MAX_DIGITS)? (n-1) : (DBL_MAX_DIGITS-1), d); + } + exponent = strchr(buff, 'e'); + + /* Get the exponent */ + *ep = strtol(exponent+1, NULL, 10); + + /* Get the sign */ + *sp = (buff[0] == '-') ? -1 : +1; + + /* Get the digits of the mantissa */ + buff[2] = buff[1]; + + /* Get the actual number of digits in the mantissa */ + length = exponent - (buff + 2); + + /* The output consists of a string {d1,d2,d3,...,dn} + with all N digits of the mantissa. If we ask for more + digits than there are, the last ones are set to zero. */ + if (n <= length) { + memcpy(s, buff+2, n); + } else { + cl_index i; + memcpy(s, buff+2, length); + for (i = length; i < n; i++) + s[i] = '0'; + } + s[n] = '\0'; +#if defined(HAVE_FENV_H) || defined(ECL_MS_WINDOWS_HOST) + feupdateenv(&env); +#endif + return length; +} + static void fmt_fix_float(format_stack fmt, bool colon, bool atsign) { diff --git a/src/c/load.d b/src/c/load.d index 062ad42b8..92a2daf25 100755 --- a/src/c/load.d +++ b/src/c/load.d @@ -259,14 +259,10 @@ ecl_library_open(cl_object filename, bool force_reload) { block = other; } else { si_set_finalizer(block, Ct); -#if 0 if (block->cblock.handle != NULL) cl_core.libraries = CONS(block, cl_core.libraries); else ecl_library_close(block); -#else - cl_core.libraries = CONS(block, cl_core.libraries); -#endif } } return block; diff --git a/src/c/num_co.d b/src/c/num_co.d index dedd7d1da..948eac8ae 100644 --- a/src/c/num_co.d +++ b/src/c/num_co.d @@ -1001,8 +1001,7 @@ cl_integer_decode_float(cl_object x) x = MAKE_FIXNUM(0); } else { d = frexpl(d, &e); - /* FIXME! Loss of precision! */ - x = double_to_integer(ldexpl(d, LDBL_MANT_DIG)); + x = long_double_to_integer(ldexpl(d, LDBL_MANT_DIG)); e -= LDBL_MANT_DIG; } break; diff --git a/src/c/print.d b/src/c/print.d index e49b97525..1bc1651f4 100644 --- a/src/c/print.d +++ b/src/c/print.d @@ -18,16 +18,10 @@ #include #include #include -#include #ifndef _MSC_VER # include #endif -#define ECL_INCLUDE_MATH_H #include -#if defined(HAVE_FENV_H) -# include -#endif -#define ECL_DEFINE_FENV_CONSTANTS #include #include @@ -444,29 +438,41 @@ write_pathname(cl_object path, cl_object stream) } static void -write_positive_fixnum(cl_index i, int base, cl_index len, cl_object stream) +write_integer(cl_object number, cl_object stream) { - /* The maximum number of digits is achieved for base 2 and it - is always < FIXNUM_BITS, since we use at least one bit for - tagging */ - short digits[FIXNUM_BITS]; - int j = 0; - if (i == 0) { - digits[j++] = '0'; - } else do { - digits[j++] = ecl_digit_char(i % base, base); - i /= base; - } while (i > 0); - while (len-- > j) - write_ch('0', stream); - while (j-- > 0) - write_ch(digits[j], stream); + cl_object s = si_get_buffer_string(); + int print_base = ecl_print_base(); + si_integer_to_string(s, number, + MAKE_FIXNUM(print_base), + ecl_symbol_value(@'*print-radix*'), + Ct /* decimal syntax */); + si_do_write_sequence(s, stream, MAKE_FIXNUM(0), Cnil); + si_put_buffer_string(s); } static void write_decimal(cl_fixnum i, cl_object stream) { - write_positive_fixnum(i, 10, 0, stream); + cl_object s = si_get_buffer_string(); + si_integer_to_string(s, MAKE_FIXNUM(i), MAKE_FIXNUM(10), Cnil, Cnil); + si_do_write_sequence(s, stream, MAKE_FIXNUM(0), Cnil); + si_put_buffer_string(s); +} + +static void +write_ratio(cl_object r, cl_object stream) +{ + cl_object s = si_get_buffer_string(); + int print_base = ecl_print_base(); + si_integer_to_string(s, r->ratio.num, MAKE_FIXNUM(print_base), + ecl_symbol_value(@'*print-radix*'), + Cnil /* decimal syntax */); + ecl_string_push_extend(s, '/'); + si_integer_to_string(s, r->ratio.den, + MAKE_FIXNUM(print_base), + Cnil, Cnil); + si_do_write_sequence(s, stream, MAKE_FIXNUM(0), Cnil); + si_put_buffer_string(s); } static void @@ -485,265 +491,14 @@ write_addr(cl_object x, cl_object stream) } static void -write_base(int base, cl_object stream) +write_float(cl_object f, cl_object stream) { - if (base == 2) - write_str("#b", stream); - else if (base == 8) - write_str("#o", stream); - else if (base == 16) - write_str("#x", stream); - else if (base >= 10) { - write_ch('#', stream); - write_ch(base/10+'0', stream); - write_ch(base%10+'0', stream); - write_ch('r', stream); - } else { - write_ch('#', stream); - write_ch(base+'0', stream); - write_ch('r', stream); - } + cl_object s = si_get_buffer_string(); + s = si_float_to_string_free(s, f, MAKE_FIXNUM(-3), MAKE_FIXNUM(8)); + si_do_write_sequence(s, stream, MAKE_FIXNUM(0), Cnil); + si_put_buffer_string(s); } -/* The floating point precision is required to make the - most-positive-long-float printed expression readable. - If this is too small, then the rounded off fraction, may be too big - to read */ - -/* Maximum number of significant digits required to represent accurately - * a double or single float. */ - -#define LOG10_2 0.30103 -#define DBL_SIG ((int)(DBL_MANT_DIG * LOG10_2 + 1)) -#define FLT_SIG ((int)(FLT_MANT_DIG * LOG10_2 + 1)) - -/* This is the maximum number of decimal digits that our numbers will have. - * Notice that we leave some extra margin, to ensure that reading the number - * again will produce the same floating point number. - */ -#ifdef ECL_LONG_FLOAT -# define LDBL_SIG ((int)(LDBL_MANT_DIG * LOG10_2 + 1)) -# define DBL_MAX_DIGITS (LDBL_SIG + 3) -# define DBL_EXPONENT_SIZE (1 + 1 + 4) -#else -# define DBL_MAX_DIGITS (DBL_SIG + 3) -# define DBL_EXPONENT_SIZE (1 + 1 + 3) /* Exponent marker 'e' + sign + digits .*/ -#endif - -/* The sinificant digits + the possible sign + the decimal dot. */ -#define DBL_MANTISSA_SIZE (DBL_MAX_DIGITS + 1 + 1) -/* Total estimated size that a floating point number can take. */ -#define DBL_SIZE (DBL_MANTISSA_SIZE + DBL_EXPONENT_SIZE) - -#ifdef ECL_LONG_FLOAT -#define EXP_STRING "Le" -#define G_EXP_STRING "Lg" -#define DBL_TYPE long double -#define strtod strtold -extern long double strtold(const char *nptr, char **endptr); -#else -#define EXP_STRING "e" -#define G_EXP_STRING "g" -#define DBL_TYPE double -#endif - -int edit_double(int n, DBL_TYPE d, int *sp, char *s, int *ep) -{ - char *exponent, buff[DBL_SIZE + 1]; - int length; -#if defined(HAVE_FENV_H) || defined(ECL_MS_WINDOWS_HOST) - fenv_t env; - feholdexcept(&env); -#endif - unlikely_if (isnan(d) || !isfinite(d)) { - FEerror("Can't print a non-number.", 0); - } - if (n < -DBL_MAX_DIGITS) - n = DBL_MAX_DIGITS; - if (n < 0) { - DBL_TYPE aux; - n = -n; - do { - sprintf(buff, "%- *.*" EXP_STRING, n + 1 + 1 + DBL_EXPONENT_SIZE, n-1, d); - aux = strtod(buff, NULL); -#ifdef ECL_LONG_FLOAT - if (n < LDBL_SIG) - aux = (double) aux; -#endif - if (n < DBL_SIG) - aux = (float)aux; - n++; - } while (d != aux && n <= DBL_MAX_DIGITS); - n--; - } else { - sprintf(buff, "%- *.*" EXP_STRING, DBL_SIZE, - (n <= DBL_MAX_DIGITS)? (n-1) : (DBL_MAX_DIGITS-1), d); - } - exponent = strchr(buff, 'e'); - - /* Get the exponent */ - *ep = strtol(exponent+1, NULL, 10); - - /* Get the sign */ - *sp = (buff[0] == '-') ? -1 : +1; - - /* Get the digits of the mantissa */ - buff[2] = buff[1]; - - /* Get the actual number of digits in the mantissa */ - length = exponent - (buff + 2); - - /* The output consists of a string {d1,d2,d3,...,dn} - with all N digits of the mantissa. If we ask for more - digits than there are, the last ones are set to zero. */ - if (n <= length) { - memcpy(s, buff+2, n); - } else { - cl_index i; - memcpy(s, buff+2, length); - for (i = length; i < n; i++) - s[i] = '0'; - } - s[n] = '\0'; -#if defined(HAVE_FENV_H) || defined(ECL_MS_WINDOWS_HOST) - feupdateenv(&env); -#endif - return length; -} - -static void -write_double(DBL_TYPE d, int e, int n, cl_object stream, cl_object o) -{ - int exp; -#if defined(HAVE_FENV_H) || defined(ECL_MS_WINDOWS_HOST) - fenv_t env; - feholdexcept(&env); -#endif - if (isnan(d)) { - if (ecl_print_readably()) -# ifdef ECL_LONG_FLOAT - FEprint_not_readable(ecl_make_longfloat(d)); -# else - FEprint_not_readable(ecl_make_doublefloat(d)); -# endif - funcall(3, @'ext::output-float-nan', o, stream); - return; - } - if (!isfinite(d)) { - funcall(3, @'ext::output-float-infinity', o, stream); - return; - } - if (d < 0) { - write_ch('-', stream); - d = -d; - } - if (d == 0.0) { -#if defined(ECL_SIGNED_ZERO) && defined(signbit) - if (signbit(d)) - write_str("-0.0", stream); - else -#endif - write_str("0.0", stream); - exp = 0; - } else if (d < 1e-3 || d > 1e7) { - int sign; - char buff[DBL_MANTISSA_SIZE + 1]; - n = edit_double(-n, d, &sign, buff, &exp); - write_ch(buff[0], stream); - write_ch('.', stream); - for (; --n > 1; ) { - if (buff[n] != '0') { - break; - } - buff[n] = '\0'; - } - write_str(buff+1, stream); - } else { - char buff[DBL_MANTISSA_SIZE + 1]; - int i; - DBL_TYPE aux; - /* Print in fixed point notation with enough number of - * digits to preserve all information when reading again - */ - do { - sprintf(buff, "%0*.*" G_EXP_STRING, DBL_MANTISSA_SIZE, n, d); - aux = strtod(buff, NULL); -#ifdef LDBL_SIG - if (n < LDBL_SIG) aux = (double)aux; -#endif - if (n < DBL_SIG) aux = (float)aux; - n++; - } while (aux != d && n <= DBL_MAX_DIGITS); - n--; - /* We look for the first nonzero character. There is - * always one because our floating point number is not - * zero.*/ - for (i = 0; buff[i] == '0' && buff[i+1] != '.'; i++) - ; - write_str(buff + i, stream); - if (strchr(buff, '.') == 0) { - write_str(".0", stream); - } - exp = 0; - } - if (exp || e) { - if (e == 0) - e = 'E'; - write_ch(e, stream); - if (exp < 0) { - write_ch('-', stream); - exp = -exp; - } - write_decimal(exp, stream); - } -#if defined(HAVE_FENV_H) || defined(ECL_MS_WINDOWS_HOST) - feupdateenv(&env); -#endif -} - - -#ifdef WITH_GMP - -static void -write_bignum(cl_object x, cl_object stream) -{ - int base = ecl_print_base(); - /* Include space for a sign and a terminating null character */ - cl_index str_size = mpz_sizeinbase(x->big.big_num, base) + 2; - if (str_size <= 32) { - char txt[32]; - mpz_get_str(txt, base, x->big.big_num); - write_str(txt, stream); - } else { - char *txt = ecl_alloc_atomic(str_size + 2); - mpz_get_str(txt, base, x->big.big_num); - write_str(txt, stream); - ecl_dealloc(txt); - } -} - -#else /* WITH_GMP */ - -static void -write_positive_bignum(big_num_t x, cl_object stream) -{ - /* The maximum number of digits is achieved for base 2 and it - is always < 8*sizeof(big_num_t) */ - int base = ecl_print_base(); - short digits[8*sizeof(big_num_t)]; - int j = 0; - if (x == (big_num_t)0) { - digits[j++] = '0'; - } else do { - digits[j++] = ecl_digit_char((cl_fixnum)(x % (big_num_t)base), base); - x /= base; - } while (x > (big_num_t)0); - /* while (len-- > j) - write_ch('0', stream); */ - while (j-- > 0) - write_ch(digits[j], stream); -} -#endif /* WITH_GMP */ static bool all_dots(cl_object s) @@ -1124,81 +879,20 @@ si_write_ugly_object(cl_object x, cl_object stream) write_ch('>', stream); break; - case t_fixnum: { - bool print_radix = ecl_print_radix(); - int print_base = ecl_print_base(); - if (print_radix && print_base != 10) - write_base(print_base, stream); - if (x == MAKE_FIXNUM(0)) { - write_ch('0', stream); - } else if (FIXNUM_MINUSP(x)) { - write_ch('-', stream); - write_positive_fixnum(-fix(x), print_base, 0, stream); - } else { - write_positive_fixnum(fix(x), print_base, 0, stream); - } - if (print_radix && print_base == 10) { - write_ch('.', stream); - } - break; - } - case t_bignum: { - bool print_radix = ecl_print_radix(); - int print_base = ecl_print_base(); - if (print_radix && print_base != 10) - write_base(print_base, stream); -#ifdef WITH_GMP - write_bignum(x, stream); -#else /* WITH_GMP */ - if (_ecl_big_zerop(x)) { - write_ch('0', stream); - } else if (_ecl_big_sign(x) < 0) { - write_ch('-', stream); - write_positive_bignum(-(x->big.big_num), stream); - } else { - write_positive_bignum(x->big.big_num, stream); - } -#endif /* WITH_GMP */ - - if (print_radix && print_base == 10) - write_ch('.', stream); - break; - } - case t_ratio: { - const cl_env_ptr env = ecl_process_env(); - if (ecl_print_radix()) { - write_base(ecl_print_base(), stream); - } - ecl_bds_bind(env, @'*print-radix*', Cnil); - si_write_ugly_object(x->ratio.num, stream); - write_ch('/', stream); - si_write_ugly_object(x->ratio.den, stream); - ecl_bds_unwind1(env); - break; - } + case t_fixnum: + case t_bignum: + write_integer(x, stream); + break; + case t_ratio: + write_ratio(x, stream); + break; case t_singlefloat: - r = ecl_symbol_value(@'*read-default-float-format*'); - write_double(sf(x), (r == @'single-float' || r == @'short-float')? 0 : 's', - FLT_SIG, stream, x); - break; + case t_doublefloat: #ifdef ECL_LONG_FLOAT - case t_doublefloat: - r = ecl_symbol_value(@'*read-default-float-format*'); - write_double(df(x), (r == @'double-float')? 0 : 'd', DBL_SIG, stream, - x); - break; case t_longfloat: - r = ecl_symbol_value(@'*read-default-float-format*'); - write_double(ecl_long_float(x), (r == @'long-float')? 0 : 'l', - LDBL_SIG, stream, x); - break; -#else - case t_doublefloat: - r = ecl_symbol_value(@'*read-default-float-format*'); - write_double(df(x), (r == @'double-float' || r == @'long-float')? 0 : 'd', - DBL_SIG, stream, x); - break; #endif + write_float(x, stream); + break; case t_complex: write_str("#C(", stream); si_write_ugly_object(x->complex.real, stream); diff --git a/src/c/printer/float_string_old.d b/src/c/printer/float_string_old.d new file mode 100644 index 000000000..09967a559 --- /dev/null +++ b/src/c/printer/float_string_old.d @@ -0,0 +1,316 @@ +/* -*- mode: c; c-basic-offset: 8 -*- */ +/* + Copyright (c) 2010, Juan Jose Garcia Ripoll. + + ECL is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version. + + See file '../../Copyright' for full details. +*/ + +#include +#include + +/* + * This is a port of CMUCL's FLOAT-STRING routine which converts a + * floating point number of arbitrary representation into a text + * representation which contains the least number of digits for the + * given precision. + */ +/* Written by Bill Maddox + * Translated to C by Juan Jose Garcia Ripoll + * + * FLONUM-TO-STRING (and its subsidiary function FLOAT-STRING) does most of + * the work for all printing of floating point numbers in the printer and in + * FORMAT. It converts a floating point number to a string in a free or + * fixed format with no exponent. The interpretation of the arguments is as + * follows: + * + * X - The floating point number to convert, which must not be + * negative. + * WIDTH - The preferred field width, used to determine the number + * of fraction digits to produce if the FDIGITS parameter + * is unspecified or NIL. If the non-fraction digits and the + * decimal point alone exceed this width, no fraction digits + * will be produced unless a non-NIL value of FDIGITS has been + * specified. Field overflow is not considerd an error at this + * level. + * FDIGITS - The number of fractional digits to produce. Insignificant + * trailing zeroes may be introduced as needed. May be + * unspecified or NIL, in which case as many digits as possible + * are generated, subject to the constraint that there are no + * trailing zeroes. + * SCALE - If this parameter is specified or non-NIL, then the number + * printed is (* x (expt 10 scale)). This scaling is exact, + * and cannot lose precision. + * FMIN - This parameter, if specified or non-NIL, is the minimum + * number of fraction digits which will be produced, regardless + * of the value of WIDTH or FDIGITS. This feature is used by + * the ~E format directive to prevent complete loss of + * significance in the printed value due to a bogus choice of + * scale factor. + * + * Most of the optional arguments are for the benefit for FORMAT and are not + * used by the printer. + * + * Returns: + * (VALUES DIGIT-STRING DIGIT-LENGTH LEADING-POINT TRAILING-POINT DECPNT) + * where the results have the following interpretation: + * + * DIGIT-STRING - The decimal representation of X, with decimal point. + * DIGIT-LENGTH - The length of the string DIGIT-STRING. + * LEADING-POINT - True if the first character of DIGIT-STRING is the + * decimal point. + * TRAILING-POINT - True if the last character of DIGIT-STRING is the + * decimal point. + * POINT-POS - The position of the digit preceding the decimal + * point. Zero indicates point before first digit. + * + * NOTE: FLONUM-TO-STRING goes to a lot of trouble to guarantee accuracy. + * Specifically, the decimal number printed is the closest possible + * approximation to the true value of the binary number to be printed from + * among all decimal representations with the same number of digits. In + * free-format output, i.e. with the number of digits unconstrained, it is + * guaranteed that all the information is preserved, so that a properly- + * rounding reader can reconstruct the original binary number, bit-for-bit, + * from its printed decimal representation. Furthermore, only as many digits + * as necessary to satisfy this condition will be printed. + * + * + * FLOAT-STRING actually generates the digits for positive numbers. The + * algorithm is essentially that of algorithm Dragon4 in "How to Print + * Floating-Point Numbers Accurately" by Steele and White. The current + * (draft) version of this paper may be found in [CMUC]tradix.press. + * DO NOT EVEN THINK OF ATTEMPTING TO UNDERSTAND THIS CODE WITHOUT READING + * THE PAPER! + */ + +static bool +large_mantissa(cl_object r, cl_object mp, cl_object s) +{ + return ecl_greatereq(ecl_plus(ecl_ash(r,1), mp), + ecl_ash(s, 1)); +} + +static cl_fixnum +assert_floating_point_width(cl_object width) +{ + if (!FIXNUMP(width) || ecl_lower(width,MAKE_FIXNUM(1))) { + FEerror("Invalid number of floating point digits." + "~%~A~%is not an integer within bounds", + 1, width); + } + return fix(width); +} + +static cl_object +float_string(cl_object digits_string, + cl_object fraction, cl_object exponent, cl_object precision, + cl_object width, cl_object fdigits, cl_object scale, cl_object fmin) +{ + cl_object r = fraction; + cl_object s = MAKE_FIXNUM(1); + cl_object mm = s; + cl_object mp = s; + cl_fixnum i, k = 0, digits = 0, decpnt = 0, cutoff = 0; + cl_object u; + char *buffer; + bool roundup = 0, cutoffp = 0, low = 0, high = 0; + + if (Null(digits_string)) { + digits_string = si_make_vector(@'base-char', MAKE_FIXNUM(10), + Ct /* adjustable */, + MAKE_FIXNUM(0) /* fill pointer */, + Cnil /* displacement */, + Cnil /* displ. offset */); + } + /* Represent fraction as r/s, error bounds as m+/s and m-/s. + * Rational arithmetic avoids loss of precision in subsequent + * calculations. + */ + { + int sign = ecl_number_compare(exponent, MAKE_FIXNUM(0)); + if (sign > 0) { + r = cl_ash(fraction, exponent); + mm = cl_ash(MAKE_FIXNUM(1), exponent); + mp = mm; + } else if (sign < 0) { + s = cl_ash(MAKE_FIXNUM(1), ecl_negate(exponent)); + } + } + /* Adjust error bounds m+ and m- for unequal gaps */ + if (ecl_number_equalp(fraction, cl_ash(MAKE_FIXNUM(1), precision))) { + mp = ecl_ash(mm, 1); + r = ecl_ash(r, 1); + s = ecl_ash(s, 1); + } + /* Scale value by requested amount and update error bounds */ + if (!Null(scale)) { + if (ecl_minusp(scale)) { + cl_object factor = cl_expt(MAKE_FIXNUM(10), + ecl_negate(scale)); + s = ecl_times(s, factor); + } else { + cl_object factor = cl_expt(MAKE_FIXNUM(10), scale); + r = ecl_times(r, factor); + mm = ecl_times(mm, factor); + mp = ecl_times(mp, factor); + } + } + while (ecl_lower(r, ecl_ceiling2(s, MAKE_FIXNUM(10)))) { + k--; + r = ecl_times(r, MAKE_FIXNUM(10)); + mm = ecl_times(r, MAKE_FIXNUM(10)); + mp = ecl_times(r, MAKE_FIXNUM(10)); + } + do { + /* Ensure mantissa (r + m+)/s is smaller than one */ + while (large_mantissa(r, mp, s)) { + s = ecl_times(s, MAKE_FIXNUM(10)); + k++; + } + /* Determine the number of digits to generate */ + if (!Null(fdigits)) { + cutoffp = 1; + cutoff = assert_floating_point_width(width); + } else if (!Null(width)) { + cutoffp = 1; + cutoff = assert_floating_point_width(width); + if (k < 0) { + cutoff = cutoff - 1; + } else { + cutoff = cutoff - k + 1; + } + } + /* ... and ensure it is never less than fmin */ + if (cutoffp) { + cl_fixnum a, i; + cl_object y; + if (!Null(fmin)) { + cl_fixnum f = assert_floating_point_width(fmin); + if (cutoff < f) + cutoff = f; + } + /* If we decided to cut off digit generation before precision + * has been exhausted, rounding the last digit may cause a + * carry propagation. We can prevent this, preserving + * left-to-right digit generation, with a few magical + * adjustments to m- and m+. Of course, correct rounding is + * also preserved. */ + a = k - cutoff; + y = s; + if (a < 0) { + for (i = 0, a = -a; i < a; i++) { + y = ecl_ceiling2(y, MAKE_FIXNUM(10)); + } + } else { + for (i = 0, a = -a; i < a; i++) { + y = ecl_times(y, MAKE_FIXNUM(10)); + } + } + mm = cl_max(2, y, mm); + mp = cl_max(2, y, mp); + roundup = ecl_number_equalp(mp, y); + } + } while (large_mantissa(r, mp, s)); + /* Zero-fill before fraction if no integer part */ + if (k < 0) { + decpnt = digits; + ecl_string_push_extend(digits_string, '.'); + for (i = k; i; i++) { + digits++; + ecl_string_push_extend(digits_string, '0'); + } + } + /* Generate least significant digits */ + do { + int sign; + if (--k == -1) { + ecl_string_push_extend(digits_string, '.'); + decpnt = digits; + } + u = ecl_truncate2(ecl_times(r, MAKE_FIXNUM(10)), s); + r = VALUES(1); + mm = ecl_times(mm, MAKE_FIXNUM(10)); + mp = ecl_times(mp, MAKE_FIXNUM(10)); + low = ecl_lower(ecl_ash(r,1), mm); + sign = ecl_number_compare(ecl_ash(r,1), ecl_minus(ecl_ash(s,1),mp)); + high = roundup? (sign >= 0) : (sign > 0); + /* stop when either precision is exhausted or we have printed as many + * fraction digits as permitted */ + if (low || high || (cutoffp && (k + cutoff <= 0))) + break; + ecl_string_push_extend(digits_string, ecl_digit_char(fix(u), 10)); + digits++; + } while(1); + /* If cutof occured before first digit, then no digits generated at all */ + if (!cutoffp || (k + cutoff) >= 0) { + /* Last digit may need rounding */ + int digit = fix(u); + if (low && !high) + digit = fix(u); + else if (high && !low) + digit = fix(u)+1; + else if (ecl_lower(ecl_ash(r,1), s)) + digit = fix(u); + else + digit = fix(u) + 1; + ecl_string_push_extend(digits_string, ecl_digit_char(digit, 10)); + digits++; + } + /* Zero-fill after integer part if no fraction */ + if (k >= 0) { + for (i = 0; i < k; i++) { + ecl_string_push_extend(digits_string, '0'); + digits++; + } + ecl_string_push_extend(digits_string, '.'); + decpnt = digits; + } + /* Add trailing zeroes to pad fraction if fdigits needed */ + if (!Null(fdigits)) { + cl_fixnum f = assert_floating_point_width(fdigits) - (digits - decpnt); + for (i = 0; i < f; i++) { + ecl_string_push_extend(digits_string, '0'); + digits++; + } + } + /* All done */ + @(return + digits_string + MAKE_FIXNUM(1+digits) + ((decpnt == 0)? Ct : Cnil) + ((decpnt == digits)? Ct : Cnil) + MAKE_FIXNUM(decpnt)) +} + +ecl_def_ct_base_string(str_dot,".",1,static,const); + +@(defun ext::float-string (string x &optional width fdigits scale fmin) +@ +{ + if (ecl_zerop(x)) { + if (Null(fdigits)) { + cl_object s = cl_make_string(3, ecl_one_plus(fdigits), + @':initial-element', + CODE_CHAR('0')); + ecl_char_set(s, 0, '.'); + @(return s cl_length(s) Ct cl_zerop(fdigits) MAKE_FIXNUM(0)); + } else { + @(return str_dot MAKE_FIXNUM(1) Ct Ct MAKE_FIXNUM(0)); + } + } else { + cl_object sig = cl_integer_decode_float(x); + cl_object exp = VALUES(1); + cl_object precision = cl_float_precision(x); + cl_object digits = cl_float_digits(x); + cl_object fudge = ecl_minus(digits, precision); + cl_object w = Null(width)? Cnil : cl_max(2, width, MAKE_FIXNUM(1)); + return float_string(string, cl_ash(sig, ecl_negate(fudge)), + ecl_plus(exp, fudge), precision, w, + fdigits, scale, fmin); + } +} +@) diff --git a/src/c/printer/float_to_digits.d b/src/c/printer/float_to_digits.d new file mode 100644 index 000000000..291cc315e --- /dev/null +++ b/src/c/printer/float_to_digits.d @@ -0,0 +1,219 @@ +/* -*- mode: c; c-basic-offset: 8 -*- */ +/* + Copyright (c) 2010, Juan Jose Garcia Ripoll. + + ECL is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version. + + See file '../../Copyright' for full details. +*/ + +#define ECL_INCLUDE_MATH_H +#include +#include +#include + +#define PRINT_BASE MAKE_FIXNUM(10) +#define EXPT_RADIX(x) ecl_ash(MAKE_FIXNUM(1),x) + +typedef struct { + cl_object r; + cl_object s; + cl_object mm; + cl_object mp; + bool high_ok; + bool low_ok; +} float_approx; + +static cl_object +times2(cl_object x) +{ + return ecl_plus(x, x); +} + +static float_approx * +setup(cl_object number, float_approx *approx) +{ + cl_object f = cl_integer_decode_float(number); + cl_fixnum e = fix(VALUES(1)), min_e; + bool limit_f = 0; + switch (type_of(number)) { + case t_singlefloat: + min_e = FLT_MIN_EXP; + limit_f = (number->SF.SFVAL == + ldexpf(FLT_RADIX, FLT_MANT_DIG-1)); + break; + case t_doublefloat: + min_e = DBL_MIN_EXP; + limit_f = (number->DF.DFVAL == + ldexp(FLT_RADIX, DBL_MANT_DIG-1)); + break; +#ifdef ECL_LONG_FLOAT + case t_longfloat: + min_e = LDBL_MIN_EXP; + limit_f = (number->longfloat.value == + ldexpl(FLT_RADIX, LDBL_MANT_DIG-1)); +#endif + } + approx->low_ok = approx->high_ok = ecl_evenp(f); + if (e > 0) { + cl_object be = EXPT_RADIX(e); + if (limit_f) { + cl_object be1 = ecl_times(be, MAKE_FIXNUM(FLT_RADIX)); + approx->r = times2(ecl_times(f, be1)); + approx->s = MAKE_FIXNUM(FLT_RADIX*2); + approx->mm = be; + approx->mp = be1; + } else { + approx->r = times2(ecl_times(f, be)); + approx->s = MAKE_FIXNUM(2); + approx->mm = be; + approx->mp = be; + } + } else if (!limit_f || (e == min_e)) { + approx->r = times2(f); + approx->s = times2(EXPT_RADIX(-e)); + approx->mp = MAKE_FIXNUM(1); + approx->mm = MAKE_FIXNUM(1); + } else { + approx->r = times2(MAKE_FIXNUM(FLT_RADIX)); + approx->s = times2(EXPT_RADIX(1-e)); + approx->mp = MAKE_FIXNUM(FLT_RADIX); + approx->mm = MAKE_FIXNUM(1); + } + return approx; +} + +static cl_fixnum +scale(float_approx *approx) +{ + cl_fixnum k = 0; + cl_object x = ecl_plus(approx->r, approx->mp); + int sign; + do { + sign = ecl_number_compare(x, approx->s); + if (approx->high_ok) { + if (sign < 0) + break; + } else { + if (sign <= 0) + break; + } + approx->s = ecl_times(approx->s, PRINT_BASE); + k++; + } while(1); + do { + x = ecl_times(x, PRINT_BASE); + sign = ecl_number_compare(x, approx->s); + if (approx->high_ok) { + if (sign >= 0) + break; + } else { + if (sign > 0) + break; + } + k--; + approx->r = ecl_times(approx->r, PRINT_BASE); + approx->mm = ecl_times(approx->mm, PRINT_BASE); + approx->mp = ecl_times(approx->mp, PRINT_BASE); + } while(1); + return k; +} + +static cl_object +generate(cl_object digits, float_approx *approx) +{ + cl_object d, x; + cl_fixnum digit; + bool tc1, tc2; + do { + d = ecl_truncate2(ecl_times(approx->r, PRINT_BASE), approx->s); + approx->r = VALUES(1); + approx->mp = ecl_times(approx->mp, PRINT_BASE); + approx->mm = ecl_times(approx->mm, PRINT_BASE); + tc1 = approx->low_ok? + ecl_lowereq(approx->r, approx->mm) : + ecl_lower(approx->r, approx->mm); + x = ecl_plus(approx->r, approx->mp); + tc2 = approx->high_ok? + ecl_greatereq(x, approx->s) : + ecl_greater(x, approx->s); + if (tc1 || tc2) { + break; + } + ecl_string_push_extend(digits, ecl_digit_char(fix(d), 10)); + } while (1); + if (tc2 && !tc1) { + digit = fix(d) + 1; + } else if (tc1 && !tc2) { + digit = fix(d); + } else if (ecl_lower(times2(approx->r), approx->s)) { + digit = fix(d); + } else { + digit = fix(d) + 1; + } + ecl_string_push_extend(digits, ecl_digit_char(digit, 10)); + return digits; +} + +static void +change_precision(float_approx *approx, cl_object position, cl_object relativep) +{ + cl_fixnum pos; + if (Null(position)) + return; + pos = fix(position); + if (!Null(relativep)) { + cl_object k = MAKE_FIXNUM(0); + cl_object l = MAKE_FIXNUM(1); + while (ecl_lower(ecl_times(approx->s, l), + ecl_plus(approx->r, approx->mp))) { + k = ecl_one_plus(k); + l = ecl_times(l, PRINT_BASE); + } + position = ecl_minus(k, position); + { + cl_object e1 = cl_expt(PRINT_BASE, position); + cl_object e2 = ecl_divide(e1, MAKE_FIXNUM(2)); + cl_object e3 = cl_expt(PRINT_BASE, k); + if (ecl_greatereq(ecl_plus(approx->r, ecl_times(approx->s, e1)), + ecl_times(approx->s, e2))) + position = ecl_one_minus(position); + } + } + { + cl_object x = ecl_times(approx->s, cl_expt(PRINT_BASE, position)); + cl_object e = ecl_divide(x, MAKE_FIXNUM(2)); + cl_object low = cl_max(2, approx->mm, e); + cl_object high = cl_max(2, approx->mp, e); + if (ecl_lowereq(approx->mm, low)) { + approx->mm = low; + approx->low_ok = 1; + } + if (ecl_lowereq(approx->mp, high)) { + approx->mp = high; + approx->high_ok = 1; + } + } +} + +cl_object +si_float_to_digits(cl_object digits, cl_object number, cl_object position, + cl_object relativep) +{ + cl_fixnum k; + float_approx approx[1]; + setup(number, approx); + change_precision(approx, position, relativep); + k = scale(approx); + if (Null(digits)) + digits = si_make_vector(@'base-char', MAKE_FIXNUM(10), + Ct /* adjustable */, + MAKE_FIXNUM(0) /* fill pointer */, + Cnil /* displacement */, + Cnil /* displ. offset */); + generate(digits, approx); + @(return MAKE_FIXNUM(k) digits) +} diff --git a/src/c/printer/float_to_string.d b/src/c/printer/float_to_string.d new file mode 100644 index 000000000..467ab61cf --- /dev/null +++ b/src/c/printer/float_to_string.d @@ -0,0 +1,131 @@ +/* -*- mode: c; c-basic-offset: 8 -*- */ +/* + Copyright (c) 2010, Juan Jose Garcia Ripoll. + + ECL is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version. + + See file '../../Copyright' for full details. +*/ + +#define ECL_INCLUDE_MATH_H +#include +#include +#include + +cl_object +_ecl_ensure_buffer(cl_object buffer, cl_fixnum length) +{ + if (Null(buffer)) { + buffer = si_make_vector(@'base-char', MAKE_FIXNUM(length), + Ct /* adjustable */, + MAKE_FIXNUM(0) /* fill pointer */, + Cnil /* displacement */, + Cnil /* displ. offset */); + } + return buffer; +} + +void +_ecl_string_push_c_string(cl_object s, const char *c) +{ + for (; *c; c++) { + ecl_string_push_extend(s, *c); + } +} + +static void +insert_char(cl_object buffer, cl_index where, cl_fixnum c) +{ + cl_fixnum end = buffer->base_string.fillp; + ecl_string_push_extend(buffer, '.'); + ecl_copy_subarray(buffer, where+1, buffer, where, end); + ecl_char_set(buffer, where, c); +} + +static cl_object +push_base_string(cl_object buffer, cl_object s) +{ + buffer = _ecl_ensure_buffer(buffer, s->base_string.fillp); + _ecl_string_push_c_string(buffer, s->base_string.self); + return buffer; +} + +/********************************************************************** + * FREE FORMAT (FIXED OR EXPONENT) OF FLOATS + */ + +static cl_object +print_float_exponent(cl_object buffer, cl_object number, cl_fixnum exp) +{ + cl_object r = ecl_symbol_value(@'*read-default-float-format*'); + cl_fixnum e; + switch (type_of(number)) { + case t_singlefloat: + e = (r == @'single-float' || r == @'short-float')? 'e' : 'f'; + break; +#ifdef ECL_LONG_FLOAT + case t_longfloat: + e = (r == @'long-float') ? 'e' : 'l'; + break; + case t_doublefloat: + e = (r == @'double-float')? 'e' : 'd'; + break; +#else + case t_doublefloat: + e = (r == @'double-float' || r == @'long-float')? 'e' : 'd'; + break; +#endif + } + if (e != 'e' || exp != 0) { + ecl_string_push_extend(buffer, e); + si_integer_to_string(buffer, MAKE_FIXNUM(exp), MAKE_FIXNUM(10), + Cnil, Cnil); + } +} + +cl_object +si_float_to_string_free(cl_object buffer_or_nil, cl_object number, + cl_object e_min, cl_object e_max) +{ + cl_fixnum base, e; + cl_object exp, buffer; + + if (ecl_float_nan_p(number)) { + cl_object s = funcall(2, @'ext::float-nan-string', number); + @(return push_base_string(buffer, s)); + } else if (ecl_float_infinity_p(number)) { + cl_object s = funcall(2, @'ext::float-infinity-string', number); + @(return push_base_string(buffer, s)); + } + base = ecl_length(buffer_or_nil); + exp = si_float_to_digits(buffer_or_nil, number, Cnil, Cnil); + buffer = VALUES(1); + e = fix(exp); + + if (ecl_minusp(number)) { + insert_char(buffer, base++, '-'); + } + /* Do we have to print in exponent notation? */ + if (ecl_lowereq(exp, e_min) || ecl_lowereq(e_max, exp)) { + insert_char(buffer, base+1, '.'); + print_float_exponent(buffer, number, e-1); + } else if (e > 0) { + cl_fixnum l = buffer->base_string.fillp - base; + while (l++ <= e) { + ecl_string_push_extend(buffer, '0'); + } + insert_char(buffer, base+e, '.'); + print_float_exponent(buffer, number, 0); + } else { + insert_char(buffer, base++, '0'); + insert_char(buffer, base++, '.'); + for (e = -e; e; e--) { + insert_char(buffer, base++, '0'); + } + print_float_exponent(buffer, number, 0); + } + @(return buffer); +} diff --git a/src/c/printer/integer_to_string.d b/src/c/printer/integer_to_string.d new file mode 100644 index 000000000..91225f7fc --- /dev/null +++ b/src/c/printer/integer_to_string.d @@ -0,0 +1,93 @@ +/* -*- mode: c; c-basic-offset: 8 -*- */ +/* + Copyright (c) 2010, Juan Jose Garcia Ripoll. + + ECL is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version. + + See file '../../Copyright' for full details. +*/ + +#define ECL_INCLUDE_MATH_H +#include +#include +#include + +static cl_object +bignum_to_string(cl_object buffer, cl_object x, cl_object base) +{ + cl_index str_size; + int b; + if (!FIXNUMP(base) || ((b = fix(base)) < 2) || (b > 36)) { + FEwrong_type_nth_arg(@[si::integer-to-string], 3, base, + cl_list(3, @'integer', MAKE_FIXNUM(2), + MAKE_FIXNUM(36))); + } + str_size = mpz_sizeinbase(x->big.big_num, b); + buffer = _ecl_ensure_buffer(buffer, str_size+1); + if (str_size <= 64) { + char txt[64]; + mpz_get_str(txt, b, x->big.big_num); + _ecl_string_push_c_string(buffer, txt); + } else { + char *txt = ecl_alloc_atomic(str_size + 2); + mpz_get_str(txt, b, x->big.big_num); + _ecl_string_push_c_string(buffer, txt); + ecl_dealloc(txt); + } + return buffer; +} + +static void +write_base_prefix(cl_object buffer, int base) +{ + if (base == 2) { + _ecl_string_push_c_string(buffer, "#b"); + } else if (base == 8) { + _ecl_string_push_c_string(buffer, "#o"); + } else if (base == 16) { + _ecl_string_push_c_string(buffer, "#x"); + } else if (base >= 10) { + char prefix[5] = "#00r"; + prefix[1] = base/10 + '0'; + prefix[2] = base%10 + '0'; + _ecl_string_push_c_string(buffer, prefix); + } else { + char prefix[4] = "#0r"; + prefix[1] = base + '0'; + _ecl_string_push_c_string(buffer, prefix); + } +} + +cl_object +si_integer_to_string(cl_object buffer, cl_object integer, + cl_object base, cl_object radix, cl_object decimalp) +{ + if (!Null(radix)) { + if (Null(decimalp) || base != MAKE_FIXNUM(10)) { + buffer = _ecl_ensure_buffer(buffer, 10); + write_base_prefix(buffer, fix(base)); + } + buffer = si_integer_to_string(buffer, integer, base, Cnil, Cnil); + if (!Null(decimalp) && base == MAKE_FIXNUM(10)) { + _ecl_string_push_c_string(buffer, "."); + } + @(return buffer) + } + switch (type_of(integer)) { + case t_fixnum: { + cl_object big = _ecl_big_register0(); + _ecl_big_set_fixnum(big, fix(integer)); + buffer = bignum_to_string(buffer, big, base); + _ecl_big_register_free(big); + return buffer; + } + case t_bignum: + return bignum_to_string(buffer, integer, base); + default: + FEwrong_type_nth_arg(@[si::integer-to-string], 2, + @'integer', integer); + } +} diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 429c9a5a1..45ef18e18 100755 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1820,8 +1820,8 @@ cl_symbols[] = { {SYS_ "READ-OBJECT-OR-IGNORE", EXT_ORDINARY, si_read_object_or_ignore, 2, OBJNULL}, -{EXT_ "OUTPUT-FLOAT-NAN", EXT_ORDINARY, NULL, -1, OBJNULL}, -{EXT_ "OUTPUT-FLOAT-INFINITY", EXT_ORDINARY, NULL, -1, OBJNULL}, +{EXT_ "FLOAT-NAN-STRING", EXT_ORDINARY, NULL, 1, OBJNULL}, +{EXT_ "FLOAT-INFINITY-STRING", EXT_ORDINARY, NULL, 1, OBJNULL}, {EXT_ "READTABLE-LOCK", EXT_ORDINARY, si_readtable_lock, -1, OBJNULL}, @@ -1949,5 +1949,9 @@ cl_symbols[] = { {EXT_ "ASSUME-RIGHT-TYPE", EXT_ORDINARY, NULL, -1, OBJNULL}, +{SYS_ "FLOAT-TO-DIGITS", SI_ORDINARY, si_float_to_digits, 4, OBJNULL}, +{SYS_ "FLOAT-TO-STRING-FREE", SI_ORDINARY, si_float_to_string_free, 4, OBJNULL}, +{SYS_ "INTEGER-TO-STRING", SI_ORDINARY, si_integer_to_string, 5, OBJNULL}, + /* Tag for end of list */ {NULL, CL_ORDINARY, NULL, -1, OBJNULL}}; diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h index 6587870ae..a3144cfdd 100755 --- a/src/c/symbols_list2.h +++ b/src/c/symbols_list2.h @@ -1820,8 +1820,8 @@ cl_symbols[] = { {SYS_ "READ-OBJECT-OR-IGNORE","si_read_object_or_ignore"}, -{EXT_ "OUTPUT-FLOAT-NAN",NULL}, -{EXT_ "OUTPUT-FLOAT-INFINITY",NULL}, +{EXT_ "FLOAT-NAN-STRING",NULL}, +{EXT_ "FLOAT-INFINITY-STRING",NULL}, {EXT_ "READTABLE-LOCK","si_readtable_lock"}, @@ -1949,5 +1949,9 @@ cl_symbols[] = { {EXT_ "ASSUME-RIGHT-TYPE",NULL}, +{SYS_ "FLOAT-TO-DIGITS","si_float_to_digits"}, +{SYS_ "FLOAT-TO-STRING-FREE","si_float_to_string_free"}, +{SYS_ "INTEGER-TO-STRING","si_integer_to_string"}, + /* Tag for end of list */ {NULL,NULL}}; diff --git a/src/clos/print.lsp b/src/clos/print.lsp index 2b16a4c5f..4f1bf0c74 100644 --- a/src/clos/print.lsp +++ b/src/clos/print.lsp @@ -154,32 +154,38 @@ printer and we should rather use MAKE-LOAD-FORM." (method-specializers m))) m) -(defun ext::output-float-nan (x stream) - (print-unreadable-object (x stream :type t) - (princ "quiet NaN" stream))) +(defun ext::float-nan-string (x) + (when *print-readably* + (error 'print-not-readable :object x)) + (cdr (assoc (type-of x) + '((single-float . "#") + (double-float . "#") + (long-float . "#") + (short-float . "#"))))) -(defun ext::output-float-infinity (x stream) +(defun ext::float-infinity-string (x) (when (and *print-readably* (null *read-eval*)) (error 'print-not-readable :object x)) (let ((*print-circle* nil) (*print-package* #.(find-package :keyword)) - (infinities '((#.ext::single-float-negative-infinity . - ext::single-float-negative-infinity) - (#.ext::double-float-negative-infinity . - ext::double-float-negative-infinity) - (#.ext::short-float-negative-infinity . - ext::short-float-negative-infinity) - (#.ext::long-float-negative-infinity . - ext::long-float-negative-infinity) - (#.ext::single-float-positive-infinity . - ext::single-float-positive-infinity) - (#.ext::double-float-positive-infinity . - ext::double-float-positive-infinity) - (#.ext::short-float-positive-infinity . - ext::short-float-positive-infinity) - (#.ext::long-float-positive-infinity . - ext::long-float-positive-infinity)))) - (format stream "#.~S" (cdr (assoc x infinities))))) + (negative-infinities '((single-float . + "#.ext::single-float-negative-infinity") + (double-float . + "#.ext::double-float-negative-infinity") + (long-float . + "#.ext::long-float-negative-infinity") + (short-float . + "#.ext::short-float-negative-infinity"))) + (positive-infinities '((single-float . + "#.ext::single-float-positive-infinity") + (double-float . + "#.ext::double-float-positive-infinity") + (long-float . + "#.ext::long-float-positive-infinity") + (short-float . + "#.ext::short-float-positive-infinity")))) + (cdr (assoc (type-of x) + (if (plusp x) positive-infinities negative-infinities))))) ;;; ---------------------------------------------------------------------- ;;; Describe diff --git a/src/h/external.h b/src/h/external.h index 48a43af94..e5a4838d5 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -564,7 +564,7 @@ extern ECL_API void FEend_of_file(cl_object strm) ecl_attr_noreturn; extern ECL_API void FEclosed_stream(cl_object strm) ecl_attr_noreturn; extern ECL_API void FEwrong_type_argument(cl_object type, cl_object value) ecl_attr_noreturn; extern ECL_API void FEwrong_type_only_arg(cl_object function, cl_object type, cl_object value) ecl_attr_noreturn; -extern ECL_API void FEwrong_type_nth_arg(cl_object function, cl_narg narg, cl_object type, cl_object value) ecl_attr_noreturn; +extern ECL_API void FEwrong_type_nth_arg(cl_object function, cl_narg narg, cl_object value, cl_object type) ecl_attr_noreturn; extern ECL_API void FEwrong_type_key_arg(cl_object function, cl_object keyo, cl_object type, cl_object value) ecl_attr_noreturn; extern ECL_API void FEwrong_num_arguments(cl_object fun) ecl_attr_noreturn; extern ECL_API void FEwrong_num_arguments_anonym(void) ecl_attr_noreturn; @@ -1168,7 +1168,10 @@ extern ECL_API cl_object cl_min _ARGS((cl_narg narg, cl_object min, ...)); extern ECL_API int ecl_number_equalp(cl_object x, cl_object y); extern ECL_API int ecl_number_compare(cl_object x, cl_object y); - +#define ecl_lowereq(x,y) (ecl_number_compare((x),(y)) <= 0) +#define ecl_greatereq(x,y) (ecl_number_compare((x),(y)) >= 0) +#define ecl_lower(x,y) (ecl_number_compare((x),(y)) < 0) +#define ecl_greater(x,y) (ecl_number_compare((x),(y)) > 0) /* num_log.c */ @@ -1427,6 +1430,18 @@ extern ECL_API void ecl_write_string(cl_object strng, cl_object strm); extern ECL_API void ecl_princ_str(const char *s, cl_object sym); extern ECL_API void ecl_princ_char(int c, cl_object sym); +/* printer/integer_to_string.d */ +extern ECL_API cl_object si_integer_to_string(cl_object buffer, cl_object integer, cl_object base, cl_object radix, cl_object decimalp); + +/* printer/float_string.d */ +extern ECL_API cl_object si_float_string(cl_narg narg, cl_object string, cl_object x, ...); + +/* printer/float_to_digits.d */ +extern ECL_API cl_object si_float_to_digits(cl_object digits, cl_object number, cl_object position, cl_object relativep); + +/* printer/float_to_string.d */ +extern ECL_API cl_object si_float_to_string_free(cl_object buffer, cl_object number, cl_object e_min, cl_object e_max); + /* profile.c */ #ifdef PROFILE diff --git a/src/h/internal.h b/src/h/internal.h index d702d5cf8..252447ba7 100644 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -287,14 +287,12 @@ extern cl_object FEnot_funcallable_vararg(cl_narg narg, ...); /* print.d */ +extern cl_object _ecl_ensure_buffer(cl_object buffer, cl_fixnum length); +extern void _ecl_string_push_c_string(cl_object s, const char *c); + #define ECL_PPRINT_QUEUE_SIZE 128 #define ECL_PPRINT_INDENTATION_STACK_SIZE 256 -#ifdef ECL_LONG_FLOAT -extern int edit_double(int n, long double d, int *sp, char *s, int *ep); -#else -extern int edit_double(int n, double d, int *sp, char *s, int *ep); -#endif extern void cl_write_object(cl_object x, cl_object stream); /* global locks */ diff --git a/src/lsp/format.lsp b/src/lsp/format.lsp index 85b8b144a..1430b8abc 100644 --- a/src/lsp/format.lsp +++ b/src/lsp/format.lsp @@ -93,137 +93,71 @@ (defvar *digits* "0123456789") (defun flonum-to-string (x &optional width fdigits scale fmin) + (declare (type float x)) + ;; FIXME: I think only FORMAT-DOLLARS calls FLONUM-TO-STRING with + ;; possibly-negative X. + (setf x (abs x)) (cond ((zerop x) - ;;zero is a special case which float-string cannot handle - (if fdigits - (let ((s (make-string (1+ fdigits) :initial-element #\0))) - (setf (schar s 0) #\.) - (values s (length s) t (zerop fdigits) 0)) - (values "." 1 t t 0))) - (t - (multiple-value-bind (sig exp) - (integer-decode-float x) - (let* ((precision (float-precision x)) - (digits (float-digits x)) - (fudge (- digits precision)) - (width (if width (max width 1) nil))) - (float-string (ash sig (- fudge)) (+ exp fudge) precision width - fdigits scale fmin)))))) - - -(defun float-string (fraction exponent precision width fdigits scale fmin) - (declare (si::c-local)) - (let ((r fraction) (s 1) (m- 1) (m+ 1) (k 0) - (digits 0) (decpnt 0) (cutoff nil) (roundup nil) u low high - (digit-string (make-array 50 :element-type 'base-char - :fill-pointer 0 :adjustable t))) - ;;Represent fraction as r/s, error bounds as m+/s and m-/s. - ;;Rational arithmetic avoids loss of precision in subsequent calculations. - (cond ((> exponent 0) - (setq r (ash fraction exponent)) - (setq m- (ash 1 exponent)) - (setq m+ m-)) - ((< exponent 0) - (setq s (ash 1 (- exponent))))) - ;;adjust the error bounds m+ and m- for unequal gaps - (when (= fraction (ash 1 precision)) - (setq m+ (ash m+ 1)) - (setq r (ash r 1)) - (setq s (ash s 1))) - ;;scale value by requested amount, and update error bounds - (when scale - (if (minusp scale) - (let ((scale-factor (expt 10 (- scale)))) - (setq s (* s scale-factor))) - (let ((scale-factor (expt 10 scale))) - (setq r (* r scale-factor)) - (setq m+ (* m+ scale-factor)) - (setq m- (* m- scale-factor))))) - ;;scale r and s and compute initial k, the base 10 logarithm of r - (do () - ((>= r (ceiling s 10))) - (decf k) - (setq r (* r 10)) - (setq m- (* m- 10)) - (setq m+ (* m+ 10))) - (do ()(nil) - (do () - ((< (+ (ash r 1) m+) (ash s 1))) - (setq s (* s 10)) - (incf k)) - ;;determine number of fraction digits to generate - (cond (fdigits - ;;use specified number of fraction digits - (setq cutoff (- fdigits)) - ;;don't allow less than fmin fraction digits - (if (and fmin (> cutoff (- fmin))) (setq cutoff (- fmin)))) - (width - ;;use as many fraction digits as width will permit - ;;but force at least fmin digits even if width will be exceeded - (if (< k 0) - (setq cutoff (- 1 width)) - (setq cutoff (1+ (- k width)))) - (if (and fmin (> cutoff (- fmin))) (setq cutoff (- fmin))))) - ;;If we decided to cut off digit generation before precision has - ;;been exhausted, rounding the last digit may cause a carry propagation. - ;;We can prevent this, preserving left-to-right digit generation, with - ;;a few magical adjustments to m- and m+. Of course, correct rounding - ;;is also preserved. - (when (or fdigits width) - (let ((a (- cutoff k)) - (y s)) - (if (>= a 0) - (dotimes (i a) (setq y (* y 10))) - (dotimes (i (- a)) (setq y (ceiling y 10)))) - (setq m- (max y m-)) - (setq m+ (max y m+)) - (when (= m+ y) (setq roundup t)))) - (when (< (+ (ash r 1) m+) (ash s 1)) (return))) - ;;zero-fill before fraction if no integer part - (when (< k 0) - (setq decpnt digits) - (vector-push-extend #\. digit-string) - (dotimes (i (- k)) - (incf digits) (vector-push-extend #\0 digit-string))) - ;;generate the significant digits - (do ()(nil) - (decf k) - (when (= k -1) - (vector-push-extend #\. digit-string) - (setq decpnt digits)) - (multiple-value-setq (u r) (truncate (* r 10) s)) - (setq m- (* m- 10)) - (setq m+ (* m+ 10)) - (setq low (< (ash r 1) m-)) - (if roundup - (setq high (>= (ash r 1) (- (ash s 1) m+))) - (setq high (> (ash r 1) (- (ash s 1) m+)))) - ;;stop when either precision is exhausted or we have printed as many - ;;fraction digits as permitted - (when (or low high (and cutoff (<= k cutoff))) (return)) - (vector-push-extend (char *digits* u) digit-string) - (incf digits)) - ;;if cutoff occured before first digit, then no digits generated at all - (when (or (not cutoff) (>= k cutoff)) - ;;last digit may need rounding - (vector-push-extend (char *digits* - (cond ((and low (not high)) u) - ((and high (not low)) (1+ u)) - (t (if (<= (ash r 1) s) u (1+ u))))) - digit-string) - (incf digits)) - ;;zero-fill after integer part if no fraction - (when (>= k 0) - (dotimes (i k) (incf digits) (vector-push-extend #\0 digit-string)) - (vector-push-extend #\. digit-string) - (setq decpnt digits)) - ;;add trailing zeroes to pad fraction if fdigits specified - (when fdigits - (dotimes (i (- fdigits (- digits decpnt))) - (incf digits) - (vector-push-extend #\0 digit-string))) - ;;all done - (values digit-string (1+ digits) (= decpnt 0) (= decpnt digits) decpnt))) + ;; Zero is a special case which FLOAT-STRING cannot handle. + (if fdigits + (let ((s (make-string (1+ fdigits) :initial-element #\0))) + (setf (schar s 0) #\.) + (values s (length s) t (zerop fdigits) 0)) + (values "." 1 t t 0))) + (t + (multiple-value-bind (e string) + (if fdigits + (float-to-digits nil x + (min (- (+ fdigits (or scale 0))) + (- (or fmin 0))) + nil) + (if (and width (> width 1)) + (let ((w (multiple-value-list + (float-to-digits nil x + (max 1 + (+ (1- width) + (if (and scale (minusp scale)) + scale 0))) + t))) + (f (multiple-value-list + (float-to-digits nil x + (- (+ (or fmin 0) + (if scale scale 0))) + nil)))) + (cond + ((>= (length (cadr w)) (length (cadr f))) + (values-list w)) + (t (values-list f)))) + (float-to-digits nil x nil nil))) + (let ((e (+ e (or scale 0))) + (stream (make-string-output-stream))) + (if (plusp e) + (progn + (write-string string stream :end (min (length string) + e)) + (dotimes (i (- e (length string))) + (write-char #\0 stream)) + (write-char #\. stream) + (write-string string stream :start (min (length + string) e)) + (when fdigits + (dotimes (i (- fdigits + (- (length string) + (min (length string) e)))) + (write-char #\0 stream)))) + (progn + (write-string "." stream) + (dotimes (i (- e)) + (write-char #\0 stream)) + (write-string string stream) + (when fdigits + (dotimes (i (+ fdigits e (- (length string)))) + (write-char #\0 stream))))) + (let ((string (get-output-stream-string stream))) + (values string (length string) + (char= (char string 0) #\.) + (char= (char string (1- (length string))) #\.) + (position #\. string)))))))) ;;; SCALE-EXPONENT -- Internal ;;;