mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-25 22:12:40 -08:00
Code Issues Projects Releases Packages Wiki Activity

Customizable printing of floating point NaNs and infinities

Browse source
This commit is contained in:
Juan Jose Garcia Ripoll 2009-06-13 22:47:08 +02:00
parent f87b297133
commit 1e89003142
5 changed files with 29 additions and 14 deletions
Download patch file Download diff file Expand all files Collapse all files

8
src/CHANGELOG
View file

@ -1,3 +1,11 @@
ECL 9.6.2:
==========
* Numerics:
- EXT:OUTPUT-FLOAT-NAN and EXT:OUTPUT-FLOAT-INFINITY can be redefined to
customized how NaNs and infinities are output.
ECL 9.6:
========

23
src/c/print.d
View file

@ -602,7 +602,7 @@ int edit_double(int n, DBL_TYPE d, int *sp, char *s, int *ep)
}
static void
write_double(DBL_TYPE d, int e, int n, cl_object stream, const char *type_name)
write_double(DBL_TYPE d, int e, int n, cl_object stream, cl_object o)
{
int exp;
#if defined(HAVE_FENV_H) || defined(_MSC_VER) || defined(mingw32)
@ -616,16 +616,11 @@ write_double(DBL_TYPE d, int e, int n, cl_object stream, const char *type_name)
# else
FEprint_not_readable(ecl_make_doublefloat(d));
# endif
write_str("#<", stream);
write_str(type_name, stream);
write_str(" quiet NaN>", stream);
funcall(3, @'ext::output-float-nan', o, stream);
return;
}
if (!isfinite(d)) {
write_str("#.EXT:", stream);
write_str(type_name, stream);
write_str(signbit(d)? "-NEGATIVE-INFINITY" : "-POSITIVE-INFINITY",
stream);
funcall(3, @'ext::output-float-infinity', o, stream);
return;
}
if (d < 0) {
@ -1149,36 +1144,36 @@ si_write_ugly_object(cl_object x, cl_object stream)
case t_shortfloat:
r = ecl_symbol_value(@'*read-default-float-format*');
write_double(ecl_short_float(x), (r == @'short-float')? 0 : 'f',
FLT_SIG, stream, "SHORT-FLOAT");
FLT_SIG, stream, x);
break;
case t_singlefloat:
r = ecl_symbol_value(@'*read-default-float-format*');
write_double(sf(x), (r == @'single-float')? 0 : 's',
FLT_SIG, stream, "SINGLE-FLOAT");
FLT_SIG, stream, x);
break;
#else
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, "SINGLE-FLOAT");
FLT_SIG, stream, x);
break;
#endif
#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,
"DOUBLE-FLOAT");
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, "LONG-FLOAT");
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, "DOUBLE-FLOAT");
DBL_SIG, stream, x);
break;
#endif
case t_complex:

3
src/c/symbols_list.h
View file

@ -1785,5 +1785,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},
/* Tag for end of list */
{NULL, CL_ORDINARY, NULL, -1, OBJNULL}};

3
src/c/symbols_list2.h
View file

@ -1785,5 +1785,8 @@ cl_symbols[] = {
{SYS_ "READ-OBJECT-OR-IGNORE","si_read_object_or_ignore"},
{EXT_ "OUTPUT-FLOAT-NAN",NULL},
{EXT_ "OUTPUT-FLOAT-INFINITY",NULL},
/* Tag for end of list */
{NULL,NULL}};

6
src/clos/print.lsp
View file

@ -154,6 +154,12 @@ printer and we should rather use MAKE-LOAD-FORM."
(method-specializers m)))
m)
(defun ext::output-float-nan (x stream)
(format stream "#<~A quiet NaN>" (type-of x)))
(defun ext::output-float-infinity (x stream)
(format stream "#.~A-~A-INFINITY" (type-of x)
(if (plusp x) "POSITIVE" "NEGATIVE")))
;;; ----------------------------------------------------------------------
;;; Describe