## 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
stipulate
package di = inline_t::default_int; # inline_t is from src/lib/core/init/built-in.pkg package it = inline_t; # inline_t is from src/lib/core/init/built-in.pkg package ns = number_string; # number_string is from src/lib/std/src/number-string.pkg package ps = protostring; # protostring is from src/lib/std/src/protostring.pkg package sg = string_guts; # string_guts is from src/lib/std/src/string-guts.pkg package g2d = exceptions_guts; # exceptions_guts is from src/lib/std/src/exceptions-guts.pkgherein
package float_format
: (weak)
api {
format_float: ns::Float_Format -> Float -> String;
#
# The type should be: XXX BUGGO FIXME
# my fmtReal: ns::Float_Format -> eight_byte_float::Float -> String
}
{
infix my 50 ==== != ;
(+) = it::f64::(+);
(-) = it::f64::(-);
(*) = it::f64::(*);
(/) = it::f64::(/);
(-_) = it::f64::neg;
neg = it::f64::neg;
(<) = it::f64::(<);
(>) = it::f64::(>);
(>=) = it::f64::(>=);
(====) = it::f64::(====);
fun floor x
=
if (x < 1073741824.0
and x >= -1073741824.0
)
runtime::asm::floor x;
else
raise exception g2d::OVERFLOW;
fi;
real = it::f64::from_tagged_int;
(+) = sg::(+);
implode = sg::implode;
cat = sg::cat;
length = sg::length_in_bytes;
fun inc i = di::(+) (i, 1);
fun dec i = di::(-) (i, 1);
fun min (i, j) = if (di::(<) (i, j) ) i; else j; fi;
fun max (i, j) = if (di::(>) (i, j) ) i; else j; fi;
atoi = (number_format::format_int ns::DECIMAL)
o
it::i1::from_int;
fun zero_lpad (s, wid) = ns::pad_left '0' wid s;
fun zero_rpad (s, wid) = ns::pad_right '0' wid s;
fun make_digit d
=
it::vector_of_chars::get_byte_as_char ("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;
elif (f > 5.0) 1;
else odd;
fi
);
mkdigits (f, i, _)
=>
{ d = floor f;
#
my (digits, carry)
=
mkdigits (10.0 * (f - real d), dec i,
di::mod (d, 2));
my (digit, c)
=
case (d, carry)
#
(9, 1) => (0, 1);
_ => (di::(+) (d, carry), 0);
esac;
(digit ! digits, c);
};
end;
my (f, e)
=
if (f < 1.0 ) scale_up (f, e);
elif (f >= 10.0) scale_dn (f, e);
else (f, e);
fi;
(mkdigits (f, max (0, min (precision_g e, max_prec)), 0))
->
(digits, carry);
case carry
#
0 => (digits, e);
_ => (1 ! digits, inc e);
esac;
};
fun float_fformat (r, prec)
=
{
fun pf e
=
di::(+) (e, inc prec);
fun rtoa (digits, e)
=
{
fun do_frac (_, 0, n, l) => ps::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 (di::(>=) (e, 0)) do_whole ([], dec e, inc n, '0' ! l);
elif (prec == 0) ps::rev_implode (n, l);
else do_frac ([], prec, inc n, '.' ! l);
fi;
do_whole (arg as (hd ! tl), e, n, l)
=>
if (di::(>=) (e, 0)) do_whole (tl, dec e, inc n, (make_digit hd) ! l);
elif (prec == 0) ps::rev_implode (n, l);
else do_frac (arg, prec, inc n, '.' ! l);
fi;
end;
fun do_zeros (_, 0, n, l) => ps::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 (di::(>=) (e, 0)) do_whole (digits, e, 0, []);
elif (prec == 0) "0";
else do_zeros (di::neg e, prec, 2, ['.', '0']);
fi;
};
if (di::(<) (prec, 0)) raise exception g2d::SIZE; fi;
if (r < 0.0) { sign => "-", mantissa => rtoa (decompose(-r, 0, pf)) };
elif (r > 0.0) { sign=>"", mantissa => rtoa (decompose (r, 0, pf)) };
elif (prec == 0) { sign=>"", mantissa => "0"};
else { sign=>"", mantissa => zero_rpad("0.", di::(+) (prec, 2)) };
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 (sg::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 (di::(<) (prec, 0))
#
raise exception g2d::SIZE;
fi;
if (r < 0.0) rtoa ("-", decompose(-r, 0, pf));
elif (r > 0.0) rtoa ("", decompose (r, 0, pf));
elif (prec == 0) { sign => "", mantissa => "0", exp => 0 };
else { sign => "", mantissa => zero_rpad("0.", di::(+) (prec, 2)), exp => 0 };
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 (di::(>=) (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 (di::(>=) (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 (di::(<) (e, -4)
or di::(>=) (e, prec)
)
make_res(
sg::from_char (make_digit (list::head digits)),
implode (do_frac (list::tail digits)),
THE e
);
else
if (di::(>=) (e, 0))
#
do_whole (digits, e, []);
else
frac = implode (do_frac digits);
make_res("0", zero_lpad (frac, di::(+) (length frac, di::(-) (-1, e))), NULL);
fi;
fi;
};
if (di::(<) (prec, 1)) raise exception g2d::SIZE; fi; # exceptions_guts is from src/lib/std/src/exceptions-guts.pkg if (r < 0.0) rtoa("-", decompose(-r, 0, pf));
elif (r > 0.0) rtoa("", decompose (r, 0, pf));
else { sign=>"", whole=>"0", frac=>"", exp=>NULL };
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)
#
(float_eformat (r, prec))
->
{ sign, mantissa, exp };
cat [sign, mantissa, "E", atoi exp]; # Minimum size exponent string, no padding.
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)
#
(float_fformat (x, prec))
->
{ sign, mantissa };
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)
#
(float_gformat (r, prec))
->
{ sign, whole, frac, exp };
my (frac, exp_string)
=
case exp
#
NULL => if (frac == "")
(".0", "");
else ("." + frac, ""); fi;
THE e => {
exp_string
=
if (di::(<) (e, 0)) "E-" + zero_lpad (atoi (di::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 (ns::SCI NULL) => real_to_sci_string 6;
format_float (ns::SCI (THE prec)) => real_to_sci_string prec;
format_float (ns::FIX NULL) => real_to_fix_string 6;
format_float (ns::FIX (THE prec)) => real_to_fix_string prec;
format_float (ns::GEN NULL) => real_to_gen_string 12;
format_float (ns::GEN (THE prec)) => real_to_gen_string prec;
format_float ns::EXACT
=>
raise exception DIE "RealFormat: format_float: EXACT not supported";
end;
};
end;