mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-16 14:21:48 -08:00
Code Issues Projects Releases Packages Wiki Activity

Ported SBCL's FLONUM-TO-STRING to ECL's core (in C).

Browse source 
New function INTEGER-TO-STRING added to ECL's core.
Both FLOAT-TO-STRING and INTEGER-TO-STRING are used in ECL's printer.
FORMAT uses ECL's new FLOAT-TO-STRING.
This commit is contained in:
Juan Jose Garcia Ripoll 2010-10-15 21:53:58 +02:00
parent f8c9558a5d
commit 4f23ce577c
15 changed files with 1043 additions and 518 deletions
Download patch file Download diff file Expand all files Collapse all files

2
src/c/Makefile.in
View file

@ -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\

114
src/c/format.d
View file

@ -15,8 +15,15 @@
See file '../Copyright' for full details.
*/
#include <string.h>
#include <float.h>
#define ECL_INCLUDE_MATH_H
#define ECL_DEFINE_FENV_CONSTANTS
#include <ecl/ecl.h>
#include <limits.h>
#if defined(HAVE_FENV_H)
# include <fenv.h>
#endif
#include <ecl/internal.h>
#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)
{

4
src/c/load.d
View file

@ -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;

3
src/c/num_co.d
View file

@ -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;

394
src/c/print.d
View file

@ -18,16 +18,10 @@
#include <string.h>
#include <stdlib.h>
#include <stdio.h>
#include <float.h>
#ifndef _MSC_VER
# include <unistd.h>
#endif
#define ECL_INCLUDE_MATH_H
#include <ecl/ecl.h>
#if defined(HAVE_FENV_H)
# include <fenv.h>
#endif
#define ECL_DEFINE_FENV_CONSTANTS
#include <ecl/internal.h>
#include <ecl/bytecodes.h>
@ -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);

316
src/c/printer/float_string_old.d Normal file
View file

@ -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 <ecl/ecl.h>
#include <ecl/ecl-inl.h>
/*
* 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]<steele>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);
}
}
@)

219
src/c/printer/float_to_digits.d Normal file
View file

@ -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 <float.h>
#include <ecl/ecl.h>
#include <ecl/ecl-inl.h>
#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)
}

131
src/c/printer/float_to_string.d Normal file
View file

@ -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 <float.h>
#include <ecl/ecl.h>
#include <ecl/internal.h>
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);
}

93
src/c/printer/integer_to_string.d Normal file
View file

@ -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 <float.h>
#include <ecl/ecl.h>
#include <ecl/internal.h>
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);
}
}

8
src/c/symbols_list.h
View file

@ -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}};

8
src/c/symbols_list2.h
View file

@ -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}};

48
src/clos/print.lsp
View file

@ -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 . "#<single-float quiet NaN>")
(double-float . "#<double-float quiet NaN>")
(long-float . "#<long-float quiet NaN>")
(short-float . "#<short-float quiet NaN>")))))
(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

19
src/h/external.h
View file

@ -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

8
src/h/internal.h
View file

@ -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 */

194
src/lsp/format.lsp
View file

@ -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
;;;