## float-format.pkg
# Compiled by:
# src/lib/std/src/standard-core.sublib# Code for converting from real (IEEE 64-bit floating-point) to string.
# This ought to be replaced with David Gay's conversion algorithm. XXX BUGGO FIXME
# This file is duplicated(?) as src/lib/src/float-format.pkg# XXX BUGGO FIXME
package float_format
: (weak)
api {
format_float: number_string::Float_Format -> Float -> String;
#
# The type should be: XXX BUGGO FIXME
# my fmtReal: number_string::Float_Format -> eight_byte_float::Float -> String
}
{
package string= string_guts; # string_guts is from src/lib/std/src/string-guts.pkg # inline_t is from src/lib/core/init/built-in.pkg infix val 50 ==== != ;
(+) = inline_t::f64::(+);
(-) = inline_t::f64::(-);
(*) = inline_t::f64::(*);
(/) = inline_t::f64::(/);
(-_) = inline_t::f64::neg;
neg = inline_t::f64::neg;
(<) = inline_t::f64::(<);
(>) = inline_t::f64::(>);
(>=) = inline_t::f64::(>=);
(====) = inline_t::f64::(====);
fun floor x
=
if (x < 1073741824.0
and x >= -1073741824.0
)
runtime::asm::floor x;
else
raise exception exceptions_guts::OVERFLOW; # exceptions_guts is from src/lib/std/src/exceptions-guts.pkg fi;
real = inline_t::f64::from_tagged_int;
my (+) = string::(+);
implode = string::implode;
cat = string::cat;
length = string::length;
package i= inline_t::default_int; # inline_t is from src/lib/core/init/built-in.pkg fun inc i = i::(+) (i, 1);
fun dec i = i::(-) (i, 1);
fun min (i, j) = if (i::(<) (i, j) ) i; else j; fi;
fun max (i, j) = if (i::(>) (i, j) ) i; else j; fi;
atoi = (num_format::format_int number_string::DECIMAL)
o
inline_t::i1::from_int;
fun zero_lpad (s, wid) = number_string::pad_left '0' wid s;
fun zero_rpad (s, wid) = number_string::pad_right '0' wid s;
fun make_digit d
=
inline_t::vector_of_chars::get ("0123456789abcdef", d);
# Decompose a non-zero real into a list of at most maxPrec significant digits
# (the first digit non-zero), and integer exponent. The return value
# (a ! b ! c..., exp)
# is produced from real argument
# a::bc... * (10 ^^ exp)
# If the list would consist of all 9's, the list consisting of 1 followed by
# all 0's is returned instead.
#
max_prec = 15;
fun decompose (f, e, precision_g)
=
{
fun scale_up (x, e)
=
if (x < 1.0 ) scale_up (10.0*x, dec e);
else (x, e); fi;
fun scale_dn (x, e)
=
if (x >= 10.0 ) scale_dn (0.1*x, inc e);
else (x, e); fi;
fun mkdigits (f, 0, odd)
=>
( [],
if (f < 5.0 ) 0;
else if (f > 5.0 ) 1;
else odd; fi;
fi
);
mkdigits (f, i, _)
=>
{ d = floor f;
my (digits, carry)
=
mkdigits (10.0 * (f - real d), dec i,
i::mod (d, 2));
my (digit, c)
=
case (d, carry)
(9, 1) => (0, 1);
_ => (i::(+) (d, carry), 0);
esac;
(digit ! digits, c);
};
end;
my (f, e)
=
if (f < 1.0 ) scale_up (f, e);
else if (f >= 10.0 ) scale_dn (f, e);
else (f, e); fi;
fi;
my (digits, carry)
=
mkdigits (f, max (0, min (precision_g e, max_prec)), 0);
case carry
0 => (digits, e);
_ => (1 ! digits, inc e);
esac;
};
fun float_fformat (r, prec)
=
{
fun pf e = i::(+) (e, inc prec);
fun rtoa (digits, e)
=
{
fun do_frac (_, 0, n, l) => prestring::rev_implode (n, l);
do_frac ([], p, n, l) => do_frac([], dec p, inc n, '0' ! l);
do_frac (hd ! tl, p, n, l)
=>
do_frac (tl, dec p, inc n, (make_digit hd) ! l);
end;
fun do_whole ([], e, n, l)
=>
if (i::(>=) (e, 0))
do_whole ([], dec e, inc n, '0' ! l);
else if (prec == 0)
prestring::rev_implode (n, l);
else do_frac ([], prec, inc n, '.' ! l);fi;
fi;
do_whole (arg as (hd ! tl), e, n, l)
=>
if (i::(>=) (e, 0))
do_whole (tl, dec e, inc n, (make_digit hd) ! l);
else if (prec == 0)
prestring::rev_implode (n, l);
else do_frac (arg, prec, inc n, '.' ! l); fi;
fi;
end;
fun do_zeros (_, 0, n, l) => prestring::rev_implode (n, l);
do_zeros (1, p, n, l) => do_frac (digits, p, n, l);
do_zeros (e, p, n, l) => do_zeros (dec e, dec p, inc n, '0' ! l);
end;
if (i::(>=) (e, 0))
do_whole (digits, e, 0, []);
else if (prec == 0)
"0";
else do_zeros (i::neg e, prec, 2, ['.', '0']); fi;
fi;
};
if (i::(<) (prec, 0) ) raise exception exceptions_guts::SIZE; fi;
if (r < 0.0)
{ sign => "-", mantissa => rtoa (decompose(-r, 0, pf)) };
else if (r > 0.0)
{ sign=>"", mantissa => rtoa (decompose (r, 0, pf)) };
else if (prec == 0)
{ sign=>"", mantissa => "0"};
else { sign=>"", mantissa => zero_rpad("0.", i::(+) (prec, 2)) }; fi;
fi;
fi;
}; # fun float_fformat
fun float_eformat (r, prec)
=
{
fun pf _ = inc prec;
fun rtoa (sign, (digits, e))
=
{
fun make_res (m, e)
=
{ sign,
mantissa => m,
exp => e
};
fun do_frac (_, 0, l) => implode (list::reverse l);
do_frac ([], n, l) => zero_rpad (implode (list::reverse l), n);
do_frac (hd ! tl, n, l) => do_frac (tl, dec n, (make_digit hd) ! l);
end;
if (prec == 0)
make_res (string::from_char (make_digit (list::head digits)), e);
else
make_res(
do_frac (list::tail digits, prec, ['.', make_digit (list::head digits)]),
e
);
fi;
};
if (i::(<) (prec, 0))
#
raise exception exceptions_guts::SIZE;
fi;
if (r < 0.0)
#
rtoa ("-", decompose(-r, 0, pf));
else
if (r > 0.0)
rtoa ("", decompose (r, 0, pf));
else if (prec == 0)
{ sign => "", mantissa => "0", exp => 0 };
else { sign => "", mantissa => zero_rpad("0.", i::(+) (prec, 2)), exp => 0 };fi;
fi;
fi;
}; # fun float_eformat
fun float_gformat (r, prec)
=
{
fun pf _ = prec;
fun rtoa (sign, (digits, e))
=
{
fun make_res (w, f, e)
=
{ sign,
whole => w,
frac => f,
exp => e
};
fun do_frac [] => [];
do_frac (0 ! tl)
=>
case (do_frac tl)
[] => [];
rest => '0' ! rest;
esac;
do_frac (hd ! tl)
=>
(make_digit hd) ! (do_frac tl);
end;
fun do_whole ([], e, wh)
=>
if (i::(>=) (e, 0))
do_whole([], dec e, '0' ! wh);
else make_res (implode (list::reverse wh), "", NULL);fi;
do_whole (arg as (hd ! tl), e, wh)
=>
if (i::(>=) (e, 0))
do_whole (tl, dec e, (make_digit hd) ! wh);
else make_res (implode (list::reverse wh), implode (do_frac arg), NULL);
fi;
end;
if (i::(<) (e, -4)
or i::(>=) (e, prec)
)
make_res(
string::from_char (make_digit (list::head digits)),
implode (do_frac (list::tail digits)),
THE e
);
else
if (i::(>=) (e, 0))
#
do_whole (digits, e, []);
else
frac = implode (do_frac digits);
make_res("0", zero_lpad (frac, i::(+) (length frac, i::(-) (-1, e))), NULL);
fi;
fi;
};
if (i::(<) (prec, 1)) raise exception exceptions_guts::SIZE; fi; # exceptions_guts is from src/lib/std/src/exceptions-guts.pkg if (r < 0.0)
#
rtoa("-", decompose(-r, 0, pf));
else
if (r > 0.0) rtoa("", decompose (r, 0, pf));
else { sign=>"", whole=>"0", frac=>"", exp=>NULL };
fi;
fi;
}; # fun float_gformat
infinity
=
bigger 100.0
where
fun bigger x
=
{ y = x*x;
#
if (y > x) bigger y;
else x;
fi;
};
end;
fun format_inf_nan x
=
if (x ==== infinity) "inf";
elif (x ==== -infinity) "-inf";
else "nan";
fi;
# Convert a real number to a string of
# the form [-]d::dddE[-]dd, where the
# precision (number of fractional digits)
# is specified by the second argument:
#
fun real_to_sci_string prec r
=
if (-infinity < r and r < infinity)
my { sign, mantissa, exp } = float_eformat (r, prec);
# Minimum size exponent string, no padding:
#
cat [sign, mantissa, "E", atoi exp];
else
format_inf_nan r;
fi;
# Convert a real number to a string of
# the form [-]ddd::ddd, where the
# precision (number of fractional digits)
# is specified by the second argument:
#
fun real_to_fix_string prec x
=
if (-infinity < x and x < infinity)
my { sign, mantissa } = float_fformat (x, prec);
sign + mantissa; # This '+' is string concatenation.
else
format_inf_nan x;
fi;
fun real_to_gen_string prec r
=
if (-infinity < r and r < infinity)
my { sign, whole, frac, exp }
=
float_gformat (r, prec);
my (frac, exp_string)
=
case exp
NULL => if (frac == "")
(".0", "");
else ("." + frac, ""); fi;
THE e => {
exp_string
=
if (i::(<) (e, 0))
"E-" + zero_lpad (atoi (i::neg e), 2);
else "E" + zero_lpad (atoi e, 2);fi;
( if (frac == "" ) ""; else "." + frac;fi,
exp_string
);
};
esac;
cat [sign, whole, frac, exp_string];
else
format_inf_nan r;
fi;
fun format_float (number_string::SCI NULL) => real_to_sci_string 6;
format_float (number_string::SCI (THE prec)) => real_to_sci_string prec;
format_float (number_string::FIX NULL) => real_to_fix_string 6;
format_float (number_string::FIX (THE prec)) => real_to_fix_string prec;
format_float (number_string::GEN NULL) => real_to_gen_string 12;
format_float (number_string::GEN (THE prec)) => real_to_gen_string prec;
format_float number_string::EXACT
=>
raise exception FAIL "RealFormat: format_float: EXACT not supported";
end;
};