## ieee-float.pkg
#
# Interface to IEEE-float functionality. # "IEEE" is "Institute of Electrical and Electronics Engineers",
# # the group which defined the reigning standard for how
# # floating point numbers should behave. For more info see www.ieee.org.
# Compiled by:
# src/lib/std/src/standard-core.sublibstipulate
package ci = mythryl_callable_c_library_interface; # mythryl_callable_c_library_interface is from src/lib/std/src/unsafe/mythryl-callable-c-library-interface.pkgherein
package ieee_float
: (weak) Ieee_Float # Ieee_Float is from src/lib/std/src/ieee-float.api {
# This may cause portability problems to 64-bit systems XXX BUGGO FIXME
#
package int= tagged_int; # tagged_int is from src/lib/std/types-only/basis-structs.pkg exception UNORDERED_EXCEPTION; # Apparently unused...
Real_Order = LESS | EQUAL | GREATER | UNORDERED;
Nan_Mode = QUIET | SIGNALLING;
Float_Ilk
= NAN Nan_Mode
| INF
| ZERO
| NORMAL
| SUBNORMAL
;
Rounding_Mode
= TO_NEAREST
| TO_NEGINF
| TO_POSINF
| TO_ZERO
;
get_or_set_rounding_mode
=
ci::find_c_function { lib_name => "math", fun_name => "get_or_set_rounding_mode" } # get_or_set_rounding_mode def in src/c/lib/math/get-or-set-rounding-mode.c
:
Null_Or( Int ) -> Int;
#
###############################################################=======
# NB: The above fn is (probably) a true syscall to the kernel, but
# it is a global resource affecting the entire program, so it should
# be set once at program startup, hence should not be a concern re
# interactive thread latency, so there's no point in switching over
# from using find_c_function() to using find_c_function'().
# -- 2012-04-21 CrT
fun int_to_rm 0 => TO_NEAREST;
int_to_rm 1 => TO_ZERO;
int_to_rm 2 => TO_POSINF;
int_to_rm 3 => TO_NEGINF;
int_to_rm _ => raise exception MATCH; # Shut up compiler
end;
fun set_rounding_mode' m
=
{ get_or_set_rounding_mode (THE m);
();
};
fun set_rounding_mode TO_NEAREST => set_rounding_mode' 0;
set_rounding_mode TO_ZERO => set_rounding_mode' 1;
set_rounding_mode TO_POSINF => set_rounding_mode' 2;
set_rounding_mode TO_NEGINF => set_rounding_mode' 3;
end;
fun get_rounding_mode ()
=
int_to_rm (get_or_set_rounding_mode NULL);
Decimal_Approx
=
{ kind: Float_Ilk,
sign: Bool,
digits: List( Int ),
expression: Int
};
fun to_string { kind, sign, digits, expression }
=
{ fun fmt_expression 0 => [];
fmt_expression i => ["E", int_guts::to_string i];
end;
fun fmt_digits ([], tail)
=>
tail;
fmt_digits (d ! r, tail)
=>
(int_guts::to_string d) ! fmt_digits (r, tail);
end;
case (sign, kind, digits)
(TRUE, ZERO, _) => "-0.0";
(FALSE, ZERO, _) => "0.0";
(TRUE, (NORMAL|SUBNORMAL), []) => "-0.0";
(FALSE, (NORMAL|SUBNORMAL), []) => "0.0";
(TRUE, (NORMAL|SUBNORMAL), _)
=>
string_guts::cat ("-0." ! fmt_digits (digits, fmt_expression expression));
(FALSE, (NORMAL|SUBNORMAL), _)
=>
string_guts::cat ("0." ! fmt_digits (digits, fmt_expression expression));
(TRUE, INF, _) => "-inf";
(FALSE, INF, _) => "inf";
(_, NAN _, []) => "nan";
(_, NAN _, _) => string_guts::cat ("nan(" ! fmt_digits (digits, [")"]));
esac;
};
# FSM-based implementation of scan:
#
fun scan gc
=
start
where
is_digit = char::is_digit;
to_lower = char::to_lower;
# Check for a literal sequence of
# case-insensitive chanacters:
#
fun check ([], ss)
=>
THE ss;
check (x ! xs, ss)
=>
case (gc ss)
THE (c, ss')
=>
if (to_lower c == x) check (xs, ss');
else NULL;
fi;
NULL => NULL;
esac;
end;
# Return INF or NAN
#
fun infnan (ilk, sign, ss)
=
THE ( { kind => ilk,
sign,
digits => [],
expression => 0
},
ss
);
# We have seen "i" (or "I"),
# now check for "nf (inity)?"
#
fun check_nf_inity (sign, ss)
=
case (check (['n', 'f'], ss))
THE ss'
=>
case (check (['i', 'n', 'i', 't', 'y'], ss'))
THE ss'' => infnan (INF, sign, ss'');
NULL => infnan (INF, sign, ss' );
esac;
NULL => NULL;
esac;
# We have seen "n" (or "N"), now check for "an"
#
fun check_an (sign, ss)
=
case (check (['a', 'n'], ss))
THE ss'
=>
infnan (NAN QUIET, sign, ss');
NULL => NULL;
esac;
# We have succeeded constructing a normal number,
# dl is still reversed and might have trailing zeros...
#
fun normal (ss, sign, dl, n)
=
{ fun srev ([], r) => r;
srev (0 ! l, []) => srev (l, []);
srev (x ! l, r) => srev (l, x ! r);
end;
THE ( case (srev (dl, []))
[] => { kind => ZERO,
sign,
digits => [],
expression => 0
};
digits => { kind => NORMAL,
sign,
digits,
expression => n
};
esac,
ss
);
};
# Scanned exponent (e), adjusted by
# position of decimal point (n)
#
fun exponent (n, esign, edl)
=
{ e = fold_backward
(\\ (d, e) = 10 * e + d)
0 edl;
n + (esign ?? -e :: e);
};
# Scanning the remaining
# digits of the exponent:
#
fun edigits (ss, sign, dl, n, esign, edl)
=
{ fun is_zero 0 => TRUE;
is_zero _ => FALSE;
end;
fun ovfl ()
=
THE ( { sign,
digits => [],
expression => 0,
kind => (esign or list::all is_zero dl) ?? ZERO
:: INF
},
ss
);
case (gc ss)
#
NULL =>
normal (ss, sign, dl, exponent (n, esign, edl))
except
exceptions_guts::OVERFLOW = ovfl (); # exceptions_guts is from src/lib/std/src/exceptions-guts.pkg THE (dg, ss')
=>
if (is_digit dg)
#
edigits (ss', sign, dl, n, esign,
(char::to_int dg - char::to_int '0') ! edl);
else
normal (ss, sign, dl, exponent (n, esign, edl))
except
exceptions_guts::OVERFLOW = ovfl ();
fi;
esac;
};
# Scanning first digit of exponent:
#
fun edigit1 (ss, sign, dl, n, esign)
=
case (gc ss)
THE (dg, ss')
=>
if (is_digit dg)
edigits (ss', sign, dl, n, esign, [char::to_int dg - char::to_int '0']);
else
NULL;
fi;
NULL => NULL;
esac;
# We have seen the "e" (or "E")
# and are now scanning an exponent:
#
fun expression (ss, sign, dl, n)
=
case (gc ss)
THE ('+', ss') => edigit1 (ss', sign, dl, n, FALSE);
THE ('-', ss') => edigit1 (ss', sign, dl, n, TRUE);
THE _ => edigit1 (ss, sign, dl, n, FALSE);
NULL => NULL;
esac;
# Digits in fractional part
#
fun fdigits (ss, sign, dl, n)
=
{ fun dig (ss, dg)
=
fdigits (ss, sign, (char::to_int dg - char::to_int '0') ! dl, n);
case (gc ss)
NULL =>
normal (ss, sign, dl, n);
THE (('e' | 'E'), ss')
=>
expression (ss', sign, dl, n);
THE ('0', ss')
=>
case dl
[] => fdigits (ss', sign, dl, n - 1);
_ => dig (ss', '0');
esac;
THE (dg, ss')
=>
if (is_digit dg) dig (ss', dg);
else normal (ss, sign, dl, n);
fi;
esac;
};
# Digits in integral part:
#
fun idigits (ss, sign, dl, n)
=
{ fun dig (ss', dg)
=
idigits (ss', sign, (char::to_int dg - char::to_int '0') ! dl, n + 1);
case (gc ss)
NULL =>
normal (ss, sign, dl, n);
THE ('.', ss')
=>
fdigits (ss', sign, dl, n);
THE (('e' | 'E'), ss')
=>
expression (ss', sign, dl, n);
THE ('0', ss')
=>
case dl
# Ignore leading zeros in integral part:
#
[] => idigits (ss', sign, dl, n);
_ => dig (ss', '0');
esac;
THE (dg, ss')
=>
if (is_digit dg) dig (ss', dg);
else normal (ss, sign, dl, n);
fi;
esac;
};
# We know the sign of the mantissa,
# now let's get it:
#
fun signed (sign, ss)
=
case (gc ss)
THE (('i' | 'I'), ss') => check_nf_inity (sign, ss');
THE (('n' | 'N'), ss') => check_an (sign, ss');
THE ('.', ss') => fdigits (ss', sign, [], 0);
THE (dg, _) => if (is_digit dg) idigits (ss, sign, [], 0);
else NULL;
fi;
NULL => NULL;
esac;
# Start state: check for sign of mantissa
#
fun start ss
=
case (gc ss)
THE ('+', ss') => signed (FALSE, ss');
THE ('-', ss') => signed (TRUE, ss');
THE _ => signed (FALSE, ss);
NULL => NULL;
esac;
end; # fun scan
fun from_string s
=
number_string::scan_string scan s;
}; # package ieee_float
end;