use
constant
MPFR_FREE_LOCAL_CACHE
=> 1;
use
constant
MPFR_FREE_GLOBAL_CACHE
=> 2;
use
constant
LITTLE_ENDIAN
=>
$Config
{byteorder} =~ /^1/ ? 1 : 0;
use
constant
MM_HP
=> LITTLE_ENDIAN ?
'h*'
:
'H*'
;
use
constant
MPFR_3_1_6_OR_LATER
=> Math::MPFR::Random::_MPFR_VERSION() > 196869 ? 1 : 0;
use
constant
MPFR_4_0_2_OR_LATER
=> Math::MPFR::Random::_MPFR_VERSION() >= 262146 ? 1 : 0;
use
constant
MPFR_PV_NV_BUG
=> Math::MPFR::Random::_has_pv_nv_bug();
use
constant
WIN32_FMT_BUG
=> Math::MPFR::Random::_buggy();
use
constant
NV_IS_DOUBLEDOUBLE
=> 1 + (2 ** -200) > 1 ? 1 : 0;
use
constant
ISSUE_19550
=> Math::MPFR::Random::_issue_19550();
use
subs
qw(MPFR_VERSION MPFR_VERSION_MAJOR MPFR_VERSION_MINOR
MPFR_VERSION_PATCHLEVEL MPFR_VERSION_STRING
RMPFR_PREC_MIN RMPFR_PREC_MAX
MPFR_DBL_DIG MPFR_LDBL_DIG MPFR_FLT128_DIG
GMP_LIMB_BITS GMP_NAIL_BITS
)
;
'++'
=> \
&overload_inc
,
'--'
=> \
&overload_dec
,
'+'
=> \
&overload_add
,
'-'
=> \
&overload_sub
,
'*'
=> \
&overload_mul
,
'/'
=> \
&overload_div
,
'+='
=> \
&overload_add_eq
,
'-='
=> \
&overload_sub_eq
,
'*='
=> \
&overload_mul_eq
,
'/='
=> \
&overload_div_eq
,
'%'
=> \
&overload_fmod
,
'%='
=> \
&overload_fmod_eq
,
'""'
=> \
&overload_string
,
'>'
=> \
&overload_gt
,
'>='
=> \
&overload_gte
,
'<'
=> \
&overload_lt
,
'<='
=> \
&overload_lte
,
'<=>'
=> \
&overload_spaceship
,
'=='
=> \
&overload_equiv
,
'!='
=> \
&overload_not_equiv
,
'!'
=> \
&overload_not
,
'bool'
=> \
&overload_true
,
'='
=> \
&overload_copy
,
'abs'
=> \
&overload_abs
,
'**'
=> \
&overload_pow
,
'**='
=> \
&overload_pow_eq
,
'<<'
=> \
&overload_lshift
,
'<<='
=> \
&overload_lshift_eq
,
'>>'
=> \
&overload_rshift
,
'>>='
=> \
&overload_rshift_eq
,
'atan2'
=> \
&overload_atan2
,
'cos'
=> \
&overload_cos
,
'sin'
=> \
&overload_sin
,
'log'
=> \
&overload_log
,
'exp'
=> \
&overload_exp
,
'int'
=> \
&overload_int
,
'sqrt'
=> \
&overload_sqrt
;
*import
= \
&Exporter::import
;
my
@tags
=
qw(
GMP_RNDD GMP_RNDN GMP_RNDU GMP_RNDZ
IOK_flag NOK_flag POK_flag
MPFR_DBL_DIG MPFR_FLT128_DIG MPFR_LDBL_DIG
MPFR_FLAGS_ALL MPFR_FLAGS_DIVBY0 MPFR_FLAGS_ERANGE MPFR_FLAGS_INEXACT MPFR_FLAGS_NAN
MPFR_FLAGS_OVERFLOW MPFR_FLAGS_UNDERFLOW
MPFR_FREE_LOCAL_CACHE MPFR_FREE_GLOBAL_CACHE
MPFR_RNDA MPFR_RNDD MPFR_RNDF MPFR_RNDN MPFR_RNDU MPFR_RNDZ MPFR_PV_NV_BUG WIN32_FMT_BUG
MPFR_VERSION MPFR_VERSION_MAJOR MPFR_VERSION_MINOR MPFR_VERSION_PATCHLEVEL MPFR_VERSION_STRING
RMPFR_PREC_MAX RMPFR_PREC_MIN RMPFR_VERSION_NUM
log_2 log_10 sind cosd tand tangent
Rmpfr_abs Rmpfr_acos Rmpfr_acosh Rmpfr_acospi Rmpfr_acosu
Rmpfr_add Rmpfr_add_d Rmpfr_add_q Rmpfr_add_si Rmpfr_add_ui Rmpfr_add_z
Rmpfr_agm Rmpfr_ai
Rmpfr_asin Rmpfr_asinh Rmpfr_asinpi Rmpfr_asinu
Rmpfr_atan Rmpfr_atan2 Rmpfr_atan2pi Rmpfr_atan2u Rmpfr_atanh Rmpfr_atanpi Rmpfr_atanu
Rmpfr_beta
Rmpfr_buildopt_decimal_p Rmpfr_buildopt_float16_p Rmpfr_buildopt_float128_p
Rmpfr_buildopt_gmpinternals_p Rmpfr_buildopt_sharedcache_p Rmpfr_buildopt_tls_p
Rmpfr_buildopt_tune_case Rmpfr_can_round Rmpfr_cbrt Rmpfr_ceil Rmpfr_check_range
Rmpfr_clear Rmpfr_clear_divby0 Rmpfr_clear_erangeflag Rmpfr_clear_flags Rmpfr_clear_inexflag
Rmpfr_clear_nanflag Rmpfr_clear_overflow Rmpfr_clear_underflow Rmpfr_clears
Rmpfr_cmp Rmpfr_cmp_IV Rmpfr_cmp_NV Rmpfr_cmp_d Rmpfr_cmp_f Rmpfr_cmp_float128 Rmpfr_cmp_ld
Rmpfr_cmp_q Rmpfr_cmp_si Rmpfr_cmp_si_2exp Rmpfr_cmp_sj Rmpfr_cmp_ui Rmpfr_cmp_ui_2exp
Rmpfr_cmp_uj Rmpfr_cmp_z Rmpfr_cmpabs Rmpfr_cmpabs_ui
Rmpfr_compound Rmpfr_compound_si
Rmpfr_const_catalan Rmpfr_const_euler Rmpfr_const_log2 Rmpfr_const_pi
Rmpfr_copysign
Rmpfr_cos Rmpfr_cosh Rmpfr_cospi Rmpfr_cosu Rmpfr_cot Rmpfr_coth
Rmpfr_csc Rmpfr_csch
Rmpfr_d_div Rmpfr_d_sub Rmpfr_deref2 Rmpfr_digamma Rmpfr_dim
Rmpfr_div Rmpfr_div_2exp Rmpfr_div_2si Rmpfr_div_2ui Rmpfr_div_d Rmpfr_div_q Rmpfr_div_si
Rmpfr_div_ui Rmpfr_div_z Rmpfr_divby0_p
Rmpfr_dot Rmpfr_dump Rmpfr_eint Rmpfr_eq Rmpfr_equal_p Rmpfr_erandom Rmpfr_erangeflag_p
Rmpfr_erf Rmpfr_erfc Rmpfr_exp Rmpfr_exp10 Rmpfr_exp10m1 Rmpfr_exp2 Rmpfr_exp2m1 Rmpfr_expm1
Rmpfr_fac_ui
Rmpfr_fits_IV_p Rmpfr_fits_intmax_p Rmpfr_fits_sint_p Rmpfr_fits_slong_p Rmpfr_fits_sshort_p
Rmpfr_fits_uint_p Rmpfr_fits_uintmax_p Rmpfr_fits_ulong_p Rmpfr_fits_ushort_p
Rmpfr_flags_clear Rmpfr_flags_restore Rmpfr_flags_save Rmpfr_flags_set Rmpfr_flags_test
Rmpfr_floor
Rmpfr_fma Rmpfr_fmma Rmpfr_fmms Rmpfr_fmod Rmpfr_fmod_ui Rmpfr_fmodquo Rmpfr_fms
Rmpfr_fpif_export Rmpfr_fpif_import Rmpfr_fprintf Rmpfr_frac
Rmpfr_free_cache Rmpfr_free_cache2 Rmpfr_free_pool Rmpfr_frexp Rmpfr_gamma Rmpfr_gamma_inc
Rmpfr_get_DECIMAL128 Rmpfr_get_DECIMAL64 Rmpfr_get_FLOAT128 Rmpfr_get_IV Rmpfr_get_LD Rmpfr_get_NV
Rmpfr_get_d Rmpfr_get_d1 Rmpfr_get_d_2exp Rmpfr_get_default_prec Rmpfr_get_default_rounding_mode
Rmpfr_get_emax Rmpfr_get_emax_max Rmpfr_get_emax_min Rmpfr_get_emin Rmpfr_get_emin_max
Rmpfr_get_emin_min Rmpfr_get_exp Rmpfr_get_f Rmpfr_get_float128 Rmpfr_get_flt Rmpfr_get_float16
Rmpfr_get_ld Rmpfr_get_ld_2exp Rmpfr_get_patches Rmpfr_get_prec Rmpfr_get_q Rmpfr_get_si Rmpfr_get_sj
Rmpfr_get_str Rmpfr_get_str_ndigits Rmpfr_get_str_ndigits_alt Rmpfr_get_ui Rmpfr_get_uj
Rmpfr_get_version Rmpfr_get_z Rmpfr_get_z_2exp Rmpfr_get_z_exp
Rmpfr_grandom Rmpfr_greater_p Rmpfr_greaterequal_p Rmpfr_hypot Rmpfr_inexflag_p Rmpfr_inf_p
Rmpfr_init Rmpfr_init2 Rmpfr_init2_nobless Rmpfr_init_nobless Rmpfr_init_set Rmpfr_init_set_IV
Rmpfr_init_set_IV_nobless Rmpfr_init_set_NV Rmpfr_init_set_NV_nobless Rmpfr_init_set_d
Rmpfr_init_set_d_nobless Rmpfr_init_set_f Rmpfr_init_set_f_nobless Rmpfr_init_set_float128
Rmpfr_init_set_float128_nobless Rmpfr_init_set_ld Rmpfr_init_set_nobless Rmpfr_init_set_q
Rmpfr_init_set_q_nobless Rmpfr_init_set_si Rmpfr_init_set_si_nobless Rmpfr_init_set_str
Rmpfr_init_set_str_nobless Rmpfr_init_set_ui Rmpfr_init_set_ui_nobless Rmpfr_init_set_z
Rmpfr_init_set_z_nobless Rmpfr_inits Rmpfr_inits2 Rmpfr_inits2_nobless Rmpfr_inits_nobless
Rmpfr_inp_str Rmpfr_integer_p Rmpfr_integer_string Rmpfr_j0 Rmpfr_j1 Rmpfr_jn Rmpfr_less_p
Rmpfr_lessequal_p Rmpfr_lessgreater_p Rmpfr_lgamma Rmpfr_li2 Rmpfr_lngamma
Rmpfr_log Rmpfr_log10 Rmpfr_log10p1 Rmpfr_log1p Rmpfr_log2 Rmpfr_log2p1 Rmpfr_log_ui
Rmpfr_max Rmpfr_min Rmpfr_min_prec Rmpfr_modf
Rmpfr_mul Rmpfr_mul_2exp Rmpfr_mul_2si Rmpfr_mul_2ui Rmpfr_mul_d Rmpfr_mul_q Rmpfr_mul_si
Rmpfr_mul_ui Rmpfr_mul_z
Rmpfr_nan_p Rmpfr_nanflag_p Rmpfr_neg Rmpfr_nextabove Rmpfr_nextbelow Rmpfr_nexttoward
Rmpfr_nrandom Rmpfr_number_p Rmpfr_out_str Rmpfr_overflow_p
Rmpfr_pow Rmpfr_pow_IV Rmpfr_pow_si Rmpfr_pow_sj Rmpfr_pow_ui Rmpfr_pow_uj Rmpfr_pow_z
Rmpfr_pown Rmpfr_powr Rmpfr_prec_round Rmpfr_print_rnd_mode Rmpfr_printf Rmpfr_q_div
Rmpfr_randclear Rmpfr_randinit_default Rmpfr_randinit_lc_2exp Rmpfr_randinit_lc_2exp_size
Rmpfr_randinit_mt Rmpfr_random2 Rmpfr_randseed Rmpfr_randseed_ui Rmpfr_rec_root Rmpfr_rec_sqrt
Rmpfr_regular_p Rmpfr_reldiff Rmpfr_remainder Rmpfr_remquo
Rmpfr_rint Rmpfr_rint_ceil Rmpfr_rint_floor Rmpfr_rint_round Rmpfr_rint_roundeven Rmpfr_rint_trunc
Rmpfr_root Rmpfr_rootn_ui Rmpfr_round Rmpfr_round_nearest_away Rmpfr_roundeven
Rmpfr_sec Rmpfr_sech Rmpfr_set Rmpfr_set_DECIMAL128 Rmpfr_set_DECIMAL64 Rmpfr_set_FLOAT128
Rmpfr_set_IV Rmpfr_set_LD Rmpfr_set_NV Rmpfr_set_d Rmpfr_set_default_prec
Rmpfr_set_default_rounding_mode Rmpfr_set_divby0 Rmpfr_set_emax Rmpfr_set_emin Rmpfr_set_erangeflag
Rmpfr_set_exp Rmpfr_set_f Rmpfr_set_float128 Rmpfr_set_flt Rmpfr_set_float16 Rmpfr_set_inexflag Rmpfr_set_inf
Rmpfr_set_ld Rmpfr_set_nan Rmpfr_set_nanflag Rmpfr_set_overflow Rmpfr_set_prec Rmpfr_set_prec_raw
Rmpfr_set_q Rmpfr_set_si Rmpfr_set_si_2exp Rmpfr_set_sj Rmpfr_set_sj_2exp Rmpfr_set_str Rmpfr_set_ui
Rmpfr_set_ui_2exp Rmpfr_set_uj Rmpfr_set_uj_2exp Rmpfr_set_underflow Rmpfr_set_z Rmpfr_set_z_2exp
Rmpfr_set_zero Rmpfr_setsign Rmpfr_sgn Rmpfr_si_div Rmpfr_si_sub Rmpfr_signbit
Rmpfr_sin Rmpfr_sin_cos Rmpfr_sinh Rmpfr_sinh_cosh Rmpfr_sinpi Rmpfr_sinu
Rmpfr_snprintf Rmpfr_sprintf Rmpfr_sqr Rmpfr_sqrt Rmpfr_sqrt_ui Rmpfr_strtofr
Rmpfr_sub Rmpfr_sub_d Rmpfr_sub_q Rmpfr_sub_si Rmpfr_sub_ui Rmpfr_sub_z Rmpfr_subnormalize
Rmpfr_sum Rmpfr_swap
Rmpfr_tan Rmpfr_tanh Rmpfr_tanpi Rmpfr_tanu
Rmpfr_total_order_p Rmpfr_trigamma Rmpfr_trunc
Rmpfr_ui_div Rmpfr_ui_pow Rmpfr_ui_pow_ui Rmpfr_ui_sub Rmpfr_underflow_p Rmpfr_unordered_p
Rmpfr_urandom Rmpfr_urandomb Rmpfr_y0 Rmpfr_y1 Rmpfr_yn
Rmpfr_z_div Rmpfr_z_sub Rmpfr_zero_p Rmpfr_zeta Rmpfr_zeta_ui
TRmpfr_inp_str TRmpfr_out_str
anytoa atodouble atonum atonv
check_exact_decimal decimalize doubletoa dragon_test
fr_cmp_q_rounded mpfr_max_orig_len mpfr_min_inter_prec mpfrtoa numtoa nvtoa nv2mpfr nvtoa_test
prec_cast q_add_fr q_cmp_fr q_div_fr q_mul_fr q_sub_fr rndna
)
;
@Math::MPFR::EXPORT_OK
= (
@tags
,
'bytes'
);
our
$VERSION
=
'4.35'
;
Math::MPFR->DynaLoader::bootstrap(
$VERSION
);
%Math::MPFR::EXPORT_TAGS
=(
mpfr
=> [
@tags
]);
$Math::MPFR::NNW
= 0;
$Math::MPFR::NOK_POK
= 0;
$Math::MPFR::doubletoa_fallback
= 0;
$Math::MPFR::PERL_INFNAN
= 0;
my
$pinf
= 1e5000;
my
$ninf
= -
$pinf
;
my
$nanv
=
$pinf
/
$pinf
;
$Math::MPFR::pinfstr
=
"$pinf"
;
$Math::MPFR::ninfstr
=
"$ninf"
;
$Math::MPFR::nanvstr
=
"$nanv"
;
%Math::MPFR::NV_properties
= _get_NV_properties();
my
%bytes
= (
53
=> \
&_d_bytes
,
64
=> \
&_ld_bytes
,
2098
=> \
&_dd_bytes
,
113
=> \
&_f128_bytes
,
);
my
%fmt
= (
53
=>
'a8'
,
64
=>
'a10'
,
2098
=>
'a16'
,
113
=>
'a16'
,
);
sub
dl_load_flags {0}
sub
Rmpfr_out_str {
if
(
@_
== 4) {
die
"Inappropriate 1st arg supplied to Rmpfr_out_str"
if
_itsa(
$_
[0]) != _MATH_MPFR_T;
return
_Rmpfr_out_str(
$_
[0],
$_
[1],
$_
[2],
$_
[3]);
}
if
(
@_
== 5) {
if
(_itsa(
$_
[0]) == _MATH_MPFR_T) {
return
_Rmpfr_out_strS(
$_
[0],
$_
[1],
$_
[2],
$_
[3],
$_
[4])}
die
"Incorrect args supplied to Rmpfr_out_str"
if
_itsa(
$_
[1]) != _MATH_MPFR_T;
return
_Rmpfr_out_strP(
$_
[0],
$_
[1],
$_
[2],
$_
[3],
$_
[4]);
}
if
(
@_
== 6) {
die
"Inappropriate 2nd arg supplied to Rmpfr_out_str"
if
_itsa(
$_
[1]) != _MATH_MPFR_T;
return
_Rmpfr_out_strPS(
$_
[0],
$_
[1],
$_
[2],
$_
[3],
$_
[4],
$_
[5]);
}
die
"Wrong number of arguments supplied to Rmpfr_out_str()"
;
}
sub
TRmpfr_out_str {
if
(
@_
== 5) {
die
"Inappropriate 4th arg supplied to TRmpfr_out_str"
if
_itsa(
$_
[3]) != _MATH_MPFR_T;
return
_TRmpfr_out_str(
$_
[0],
$_
[1],
$_
[2],
$_
[3],
$_
[4]);
}
if
(
@_
== 6) {
if
(_itsa(
$_
[3]) == _MATH_MPFR_T) {
return
_TRmpfr_out_strS(
$_
[0],
$_
[1],
$_
[2],
$_
[3],
$_
[4],
$_
[5])}
die
"Incorrect args supplied to TRmpfr_out_str"
if
_itsa(
$_
[4]) != _MATH_MPFR_T;
return
_TRmpfr_out_strP(
$_
[0],
$_
[1],
$_
[2],
$_
[3],
$_
[4],
$_
[5]);
}
if
(
@_
== 7) {
die
"Inappropriate 5th arg supplied to TRmpfr_out_str"
if
_itsa(
$_
[4]) != _MATH_MPFR_T;
return
_TRmpfr_out_strPS(
$_
[0],
$_
[1],
$_
[2],
$_
[3],
$_
[4],
$_
[5],
$_
[6]);
}
die
"Wrong number of arguments supplied to TRmpfr_out_str()"
;
}
sub
Rmpfr_get_str {
my
(
$mantissa
,
$exponent
) = Rmpfr_deref2(
$_
[0],
$_
[1],
$_
[2],
$_
[3]);
if
(
$mantissa
=~ s/@//g) {
return
$mantissa
}
if
(
$mantissa
=~ /\-/ &&
$mantissa
!~ /[^0,\-]/) {
return
'-0'
}
if
(
$mantissa
!~ /[^0]/ ) {
return
'0'
}
my
$len
=
substr
(
$mantissa
, 0, 1) eq
'-'
? 2 : 1;
if
(!
$_
[2]) {
while
(
length
(
$mantissa
) >
$len
&&
substr
(
$mantissa
, -1, 1) eq
'0'
) {
substr
(
$mantissa
, -1, 1,
''
);
}
}
$exponent
--;
my
$sep
=
$_
[1] <= 10 ?
'e'
:
'@'
;
if
(
length
(
$mantissa
) ==
$len
) {
if
(
$exponent
) {
return
$mantissa
.
$sep
.
$exponent
}
return
$mantissa
;
}
substr
(
$mantissa
,
$len
, 0,
'.'
);
if
(
$exponent
) {
return
$mantissa
.
$sep
.
$exponent
}
return
$mantissa
;
}
sub
overload_string {
return
Rmpfr_get_str(
$_
[0], 10, 0, Rmpfr_get_default_rounding_mode());
}
sub
Rmpfr_integer_string {
if
(
$_
[1] < 2 ||
$_
[1] > 36) {
die
(
"Second argument supplied to Rmpfr_integer_string() is not in acceptable range"
)}
my
(
$mantissa
,
$exponent
) = Rmpfr_deref2(
$_
[0],
$_
[1], 0,
$_
[2]);
if
(
$mantissa
=~ s/@//g) {
return
$mantissa
}
if
(
$mantissa
=~ /\-/ &&
$mantissa
!~ /[^0,\-]/) {
return
'-0'
}
return
0
if
$exponent
< 1;
my
$sign
=
substr
(
$mantissa
, 0, 1) eq
'-'
? 1 : 0;
$mantissa
=
substr
(
$mantissa
, 0,
$exponent
+
$sign
);
return
$mantissa
;
}
sub
new {
if
(!
@_
) {
return
Rmpfr_init()}
if
(
@_
> 3) {
die
"Too many arguments supplied to new()"
}
if
(!
ref
(
$_
[0]) &&
$_
[0] eq
"Math::MPFR"
) {
shift
;
if
(!
@_
) {
return
Rmpfr_init()}
}
if
(
@_
> 2) {
die
"Too many arguments supplied to new() - expected no more than two"
}
my
(
$arg1
,
$type
,
$base
);
$arg1
=
shift
;
$base
= 0;
$type
= _itsa(
$arg1
);
if
(!
$type
) {
die
"Inappropriate argument supplied to new()"
}
my
@ret
;
if
(
$type
== _UOK_T) {
if
(
@_
) {
die
"Too many arguments supplied to new() - expected only one"
}
if
(Math::MPFR::_has_longlong()) {
my
$ret
= Rmpfr_init();
Rmpfr_set_uj(
$ret
,
$arg1
, Rmpfr_get_default_rounding_mode());
return
$ret
;
}
else
{
@ret
= Rmpfr_init_set_ui(
$arg1
, Rmpfr_get_default_rounding_mode());
return
$ret
[0];
}
}
if
(
$type
== _IOK_T) {
if
(
@_
) {
die
"Too many arguments supplied to new() - expected only one"
}
if
(Math::MPFR::_has_longlong()) {
my
$ret
= Rmpfr_init();
Rmpfr_set_sj(
$ret
,
$arg1
, Rmpfr_get_default_rounding_mode());
return
$ret
;
}
else
{
@ret
= Rmpfr_init_set_si(
$arg1
, Rmpfr_get_default_rounding_mode());
return
$ret
[0];
}
}
if
(
$type
== _NOK_T) {
if
(
@_
) {
die
"Too many arguments supplied to new() - expected only one"
}
if
(MPFR_PV_NV_BUG) {
if
(_SvPOK(
$arg1
)) {
set_nok_pok(nok_pokflag() + 1);
if
(
$Math::MPFR::NOK_POK
) {
warn
"Scalar passed to new() is both NV and PV. Using NV (numeric) value"
;
}
}
}
my
$ret
= Rmpfr_init();
Rmpfr_set_NV(
$ret
,
$arg1
, Rmpfr_get_default_rounding_mode());
return
$ret
;
}
if
(
$type
== _POK_T) {
if
(
@_
> 1) {
die
"Too many arguments supplied to new() - expected no more than two"
}
if
(_SvNOK(
$arg1
)) {
set_nok_pok(nok_pokflag() + 1);
if
(
$Math::MPFR::NOK_POK
) {
warn
"Scalar passed to new() is both NV and PV. Using PV (string) value"
;
}
}
$base
=
shift
if
@_
;
@ret
= Rmpfr_init_set_str(
$arg1
,
$base
, Rmpfr_get_default_rounding_mode());
return
$ret
[0];
}
if
(
$type
== _MATH_MPFR_T) {
if
(
@_
) {
die
"Too many arguments supplied to new() - expected only one"
}
@ret
= Rmpfr_init_set(
$arg1
, Rmpfr_get_default_rounding_mode());
return
$ret
[0];
}
if
(
$type
== _MATH_GMPf_T) {
if
(
@_
) {
die
"Too many arguments supplied to new() - expected only one"
}
@ret
= Rmpfr_init_set_f(
$arg1
, Rmpfr_get_default_rounding_mode());
return
$ret
[0];
}
if
(
$type
== _MATH_GMPq_T) {
if
(
@_
) {
die
"Too many arguments supplied to new() - expected only one"
}
@ret
= Rmpfr_init_set_q(
$arg1
, Rmpfr_get_default_rounding_mode());
return
$ret
[0];
}
if
(
$type
== _MATH_GMPz_T ||
$type
== _MATH_GMP_T) {
if
(
@_
) {
die
"Too many arguments supplied to new() - expected only one"
}
@ret
= Rmpfr_init_set_z(
$arg1
, Rmpfr_get_default_rounding_mode());
return
$ret
[0];
}
}
sub
Rmpfr_printf {
if
(
@_
== 3){
if
(_itsa(
$_
[1]) == 2) {wrap_mpfr_printf_rnd(
@_
)}
else
{
die
"The second (of 3) arguments given to Rmpfr_printf() is not a valid rounding argument"
}
}
else
{
die
"Rmpfr_printf must take 2 or 3 arguments: format string, [rounding,], and variable"
if
@_
!= 2;
my
$revised
= _rewrite_fmt_arg(
$_
[0],
$_
[1]);
if
(
$revised
) {
wrap_mpfr_printf(
$revised
, nv2mpfr(
$_
[1]));
}
else
{
wrap_mpfr_printf(
@_
);
}
}
}
sub
Rmpfr_fprintf {
if
(
@_
== 4){
if
(_itsa(
$_
[2]) == 2) {wrap_mpfr_fprintf_rnd(
@_
)}
else
{
die
"The third (of 4) arguments given to Rmpfr_fprintf() is not a valid rounding argument"
}
}
else
{
die
"Rmpfr_fprintf must take 3 or 4 arguments: filehandle, format string, [rounding,], and variable"
if
@_
!= 3;
my
$revised
= _rewrite_fmt_arg(
$_
[1],
$_
[2]);
if
(
$revised
) {
wrap_mpfr_fprintf(
$_
[0],
$revised
, nv2mpfr(
$_
[2]));
}
else
{
wrap_mpfr_fprintf(
@_
);
}
}
}
sub
Rmpfr_sprintf {
my
$len
;
if
(
@_
== 5){
if
(_itsa(
$_
[2]) == 2) {
$len
= wrap_mpfr_sprintf_rnd(
@_
);
return
$len
;
}
else
{
die
"The third (of 5) arguments given to Rmpfr_sprintf() is not a valid rounding argument"
}
}
die
"Rmpfr_sprintf must take 4 or 5 arguments: buffer, format string, [rounding,] variable and buffer size"
if
@_
!= 4;
my
$revised
= _rewrite_fmt_arg(
$_
[1],
$_
[2]);
if
(
$revised
) {
$len
= wrap_mpfr_sprintf(
$_
[0],
$revised
, nv2mpfr(
$_
[2]),
$_
[3]);
return
$len
;
}
$len
= wrap_mpfr_sprintf(
@_
);
return
$len
;
}
sub
Rmpfr_snprintf {
my
$len
;
if
(
@_
== 6){
if
(_itsa(
$_
[3]) == 2) {
$len
= wrap_mpfr_snprintf_rnd(
@_
);
return
$len
;
}
else
{
die
"The fourth (of 6) arguments given to Rmpfr_snprintf() is not a valid rounding argument"
}
}
die
"Rmpfr_snprintf must take 5 or 6 arguments: buffer, bytes written, format string, [rounding,], variable and buffer size"
if
@_
!= 5;
my
$revised
= _rewrite_fmt_arg(
$_
[2],
$_
[3]);
if
(
$revised
) {
$len
= wrap_mpfr_snprintf(
$_
[0],
$_
[1],
$revised
, nv2mpfr(
$_
[3]),
$_
[4]);
return
$len
;
}
$len
= wrap_mpfr_snprintf(
@_
);
return
$len
;
}
sub
Rmpfr_inits {
my
@ret
;
for
(1 ..
$_
[0]) {
$ret
[
$_
- 1] = Rmpfr_init();
}
return
@ret
;
}
sub
Rmpfr_inits2 {
my
@ret
;
for
(1 ..
$_
[1]) {
$ret
[
$_
- 1] = Rmpfr_init2(
$_
[0]);
}
return
@ret
;
}
sub
Rmpfr_inits_nobless {
my
@ret
;
for
(1 ..
$_
[0]) {
$ret
[
$_
- 1] = Rmpfr_init_nobless();
}
return
@ret
;
}
sub
Rmpfr_inits2_nobless {
my
@ret
;
for
(1 ..
$_
[1]) {
$ret
[
$_
- 1] = Rmpfr_init2_nobless(
$_
[0]);
}
return
@ret
;
}
sub
MPFR_VERSION () {
return
_MPFR_VERSION()}
sub
MPFR_VERSION_MAJOR () {
return
_MPFR_VERSION_MAJOR()}
sub
MPFR_VERSION_MINOR () {
return
_MPFR_VERSION_MINOR()}
sub
MPFR_VERSION_PATCHLEVEL () {
return
_MPFR_VERSION_PATCHLEVEL()}
sub
MPFR_VERSION_STRING () {
return
_MPFR_VERSION_STRING()}
sub
MPFR_DBL_DIG () {
return
_DBL_DIG()}
sub
MPFR_LDBL_DIG () {
return
_LDBL_DIG()}
sub
MPFR_FLT128_DIG () {
return
_FLT128_DIG()}
sub
GMP_LIMB_BITS () {
return
_GMP_LIMB_BITS()}
sub
GMP_NAIL_BITS () {
return
_GMP_NAIL_BITS()}
sub
atonum {
if
(MPFR_3_1_6_OR_LATER) {
return
atonv(
$_
[0])
if
$_
[0] =~ /^[\-\+]?inf|^[\-\+]?nan/i;
my
$copy
=
$_
[0];
my
$ret
=
"$copy"
+ 0;
return
$ret
if
_itsa(
$ret
) < 3;
return
atonv(
$_
[0]);
}
die
(
"atonum needs atonv, but atonv is not available with this version ("
, MPFR_VERSION_STRING,
") of the mpfr library"
);
}
sub
check_exact_decimal {
unless
( MPFR_3_1_6_OR_LATER ) {
warn
"check_exact_decimal() requires mpfr-3.1.6 or later\n"
;
die
"Math::MPFR was built against mpfr-"
, MPFR_VERSION_STRING;
}
my
(
$str
,
$op
) = (
shift
,
shift
);
if
( !Rmpfr_regular_p(
$op
) ) {
if
( Rmpfr_nan_p(
$op
) &&
$str
=~ /^nan$/i ) {
return
1 }
if
( Rmpfr_signbit(
$op
) ) {
if
( Rmpfr_zero_p(
$op
) &&
$str
eq
'-0'
) {
return
1 }
if
( Rmpfr_inf_p(
$op
) &&
$str
=~ /^\-inf$/i ) {
return
1 }
}
else
{
if
( Rmpfr_zero_p(
$op
) &&
$str
eq
'0'
) {
return
1 }
if
( Rmpfr_inf_p(
$op
) &&
$str
=~
'^inf$/i'
) {
return
1 }
}
return
0;
}
my
$check
= Rmpfr_init2(Rmpfr_get_prec(
$op
));
my
$inex
= Rmpfr_strtofr(
$check
,
$str
, 10, MPFR_RNDN);
if
(
$inex
== 0 &&
$op
==
$check
) {
return
1 }
return
0;
}
sub
mpfr_min_inter_prec {
die
"Wrong number of args to mpfr_min_inter_prec()"
unless
@_
== 3;
my
$ob
=
shift
;
my
$op
=
shift
;
my
$nb
=
shift
;
my
$np
;
my
%h
= (
2
=> 1,
4
=> 2,
8
=> 3,
16
=> 4,
32
=> 5,
64
=> 6,
3
=> 1,
9
=> 2,
27
=> 3,
5
=> 1,
25
=> 2,
6
=> 1,
36
=> 2,
7
=> 1,
49
=> 2);
return
$op
if
$ob
==
$nb
;
if
(_bases_are_power_of_same_integer(
$ob
,
$nb
)) {
$np
= POSIX::ceil(
$op
*
$h
{
$ob
} /
$h
{
$nb
});
return
$np
;
}
$np
= POSIX::ceil(1 + (
$op
*
log
(
$ob
) /
log
(
$nb
)));
return
$np
;
}
sub
mpfr_max_orig_len {
die
"Wrong number of args to maximum_orig_length()"
if
@_
!= 3;
my
$ob
=
shift
;
my
$nb
=
shift
;
my
$np
=
shift
;
my
$op
;
my
%h
= (
2
=> 1,
4
=> 2,
8
=> 3,
16
=> 4,
32
=> 5,
64
=> 6,
3
=> 1,
9
=> 2,
27
=> 3,
5
=> 1,
25
=> 2,
6
=> 1,
36
=> 2,
7
=> 1,
49
=> 2);
return
$np
if
$ob
==
$nb
;
if
(_bases_are_power_of_same_integer(
$ob
,
$nb
)) {
$op
= POSIX::floor(
$np
*
$h
{
$nb
} /
$h
{
$ob
});
return
$op
;
}
$op
= POSIX::floor((
$np
- 1) *
log
(
$nb
) /
log
(
$ob
));
return
$op
;
}
sub
_bases_are_power_of_same_integer {
return
1
if
( (
$_
[0] == 2 ||
$_
[0] == 16 ||
$_
[0] == 8 ||
$_
[0] == 64 ||
$_
[0] == 32 ||
$_
[0] == 4)
&&
(
$_
[1] == 2 ||
$_
[1] == 16 ||
$_
[1] == 8 ||
$_
[1] == 64 ||
$_
[1] == 32 ||
$_
[1] == 4) );
return
1
if
( (
$_
[0] == 3 ||
$_
[0] == 9 ||
$_
[0] == 27)
&&
(
$_
[1] == 3 ||
$_
[1] == 9 ||
$_
[1] == 27) );
return
1
if
( (
$_
[0] == 5 ||
$_
[0] == 25)
&&
(
$_
[1] == 5 ||
$_
[1] == 25) );
return
1
if
( (
$_
[0] == 6 ||
$_
[0] == 36)
&&
(
$_
[1] == 6 ||
$_
[1] == 36) );
return
1
if
( (
$_
[0] == 7 ||
$_
[0] == 49)
&&
(
$_
[1] == 7 ||
$_
[1] == 49) );
return
0;
}
sub
bytes {
my
(
$val
,
$bits
,
$ret
) = (
shift
,
shift
);
my
$itsa
= _itsa(
$val
);
die
"1st arg to Math::MPFR::bytes must be either a string or a Math::MPFR object"
if
(
$itsa
!= 4 &&
$itsa
!= 5);
die
"2nd argument given to Math::MPFR::bytes is neither 53 nor 64 nor 2098 nor 113"
unless
(
$bits
== 53 ||
$bits
== 64 ||
$bits
== 2098 ||
$bits
== 113);
$ret
=
$itsa
== 4 ?
unpack
MM_HP,
pack
$fmt
{
$bits
},
$bytes
{
$bits
} -> (
$val
)
:
unpack
MM_HP,
pack
$fmt
{
$bits
}, _bytes_fr(
$val
,
$bits
);
return
scalar
reverse
$ret
if
LITTLE_ENDIAN;
return
$ret
;
}
sub
rndna {
my
$coderef
=
shift
;
my
$rop
=
shift
;
my
$big_prec
= Rmpfr_get_prec(
$rop
) + 1;
my
$ret
;
if
(
$coderef
== \
&Rmpfr_prec_round
) {
my
$temp
= Rmpfr_init2(
$big_prec
);
Rmpfr_set(
$temp
,
$rop
, MPFR_RNDN);
$ret
= Rmpfr_prec_round(
$temp
,
$_
[0] + 1, MPFR_RNDN);
if
(!
$ret
) {
return
Rmpfr_prec_round(
$rop
,
$_
[0], MPFR_RNDA)}
return
Rmpfr_prec_round(
$rop
,
$_
[0], MPFR_RNDN);
}
Rmpfr_prec_round(
$rop
,
$big_prec
, MPFR_RNDN);
$ret
=
$coderef
->(
$rop
,
@_
, MPFR_RNDN);
if
(
$ret
) {
Rmpfr_prec_round(
$rop
,
$big_prec
- 1,
$ret
< 0 ? MPFR_RNDA : MPFR_RNDZ);
return
$ret
;
}
if
(_lsb(
$rop
) == 0) {
Rmpfr_prec_round(
$rop
,
$big_prec
- 1, MPFR_RNDZ);
return
0;
}
return
Rmpfr_prec_round(
$rop
,
$big_prec
- 1, MPFR_RNDA);
}
sub
Rmpfr_round_nearest_away {
my
$coderef
=
shift
;
my
$rop
=
shift
;
my
$big_prec
= Rmpfr_get_prec(
$rop
) + 1;
my
$ret
;
my
$emin
= Rmpfr_get_emin();
if
(
$emin
<= Rmpfr_get_emin_min()) {
warn
"\n Rmpfr_round_nearest_away requires that emin ($emin)\n"
,
" be greater than or equal to emin_min ("
, Rmpfr_get_emin_min(),
")\n"
;
die
" You need to set emin (using Rmpfr_set_emin()) accordingly"
;
}
Rmpfr_set_emin(
$emin
- 1);
if
(
$coderef
== \
&Rmpfr_prec_round
) {
my
$temp
= Rmpfr_init2(
$big_prec
);
Rmpfr_set(
$temp
,
$rop
, MPFR_RNDN);
$ret
= Rmpfr_prec_round(
$temp
,
$_
[0] + 1, MPFR_RNDN);
if
(!
$ret
) {
$ret
= Rmpfr_prec_round(
$rop
,
$_
[0], MPFR_RNDA);
Rmpfr_set_emin(
$emin
);
return
$ret
;
}
$ret
= Rmpfr_prec_round(
$rop
,
$_
[0], MPFR_RNDN);
Rmpfr_set_emin(
$emin
);
return
$ret
;
}
Rmpfr_prec_round(
$rop
,
$big_prec
, MPFR_RNDN);
$ret
=
$coderef
->(
$rop
,
@_
, MPFR_RNDN);
if
(
$ret
) {
Rmpfr_prec_round(
$rop
,
$big_prec
- 1,
$ret
< 0 ? MPFR_RNDA : MPFR_RNDZ);
Rmpfr_set_emin(
$emin
);
return
$ret
;
}
my
$nuisance
= Rmpfr_init();
Rmpfr_set_ui (
$nuisance
, 2, MPFR_RNDD);
Rmpfr_pow_si (
$nuisance
,
$nuisance
, Rmpfr_get_emin(), MPFR_RNDD);
Rmpfr_div_2ui(
$nuisance
,
$nuisance
, 1, MPFR_RNDD);
if
(
abs
(
$rop
) ==
$nuisance
) {
Rmpfr_mul_ui(
$rop
,
$rop
, 2, MPFR_RNDD);
Rmpfr_set_emin(
$emin
);
return
(Rmpfr_signbit(
$rop
) ? -1 : 1);
}
if
(_lsb(
$rop
) == 0) {
Rmpfr_prec_round(
$rop
,
$big_prec
- 1, MPFR_RNDZ);
Rmpfr_set_emin(
$emin
);
return
0;
}
$ret
= Rmpfr_prec_round(
$rop
,
$big_prec
- 1, MPFR_RNDA);
Rmpfr_set_emin(
$emin
);
return
$ret
;
}
sub
_get_NV_properties {
my
(
$bits
,
$PREC
,
$max_dig
,
$min_pow
,
$normal_min
,
$NV_MAX
,
$nvtype
,
$emax
,
$emin
);
if
(
$Config
{nvtype} eq
'double'
) {
$bits
= 53;
$PREC
= 64;
$max_dig
= 17;
$min_pow
= -1074;
$normal_min
= 2 ** -1022;
$NV_MAX
= POSIX::DBL_MAX;
$emin
= -1073;
$emax
= 1024;
}
elsif
(
$Config
{nvtype} eq
'__float128'
) {
$bits
= 113;
$PREC
= 128;
$max_dig
= 36;
$min_pow
= -16494;
$normal_min
= 2 ** -16382;
$NV_MAX
= 1.18973149535723176508575932662800702e+4932;
$emin
= -16493;
$emax
= 16384;
}
elsif
(
$Config
{nvtype} eq
'long double'
) {
if
(_required_ldbl_mant_dig() == 53) {
$bits
= 53;
$PREC
= 64;
$max_dig
= 17;
$min_pow
= -1074;
$normal_min
= 2 ** -1022;
$NV_MAX
= POSIX::DBL_MAX;
$emin
= -1073;
$emax
= 1024;
}
elsif
(_required_ldbl_mant_dig() == 113) {
$bits
= 113;
$PREC
= 128;
$max_dig
= 36;
$min_pow
= -16494;
$normal_min
= 2 ** -16382;
$NV_MAX
= POSIX::LDBL_MAX;
$emin
= -16493;
$emax
= 16384;
}
elsif
(_required_ldbl_mant_dig() == 64) {
$bits
= 64;
$PREC
= 80;
$max_dig
= 21;
$min_pow
= -16445;
$normal_min
= 2 ** -16382;
$NV_MAX
= POSIX::LDBL_MAX;
$emin
= -16444;
$emax
= 16384;
}
elsif
(_required_ldbl_mant_dig() == 2098) {
$bits
= 2098;
$PREC
= 2104;
$max_dig
= 33;
$min_pow
= -1074;
$normal_min
= 2 ** -1022;
$NV_MAX
= POSIX::LDBL_MAX;
$emin
= -1073;
$emax
= 1024;
}
else
{
my
%properties
= (
'type'
=>
'unknown long double type'
);
return
%properties
;
}
}
else
{
my
%properties
= (
'type'
=>
'unknown nv type'
);
return
%properties
;
}
my
%properties
= (
'bits'
=>
$bits
,
'PREC'
=>
$PREC
,
'max_dig'
=>
$max_dig
,
'min_pow'
=>
$min_pow
,
'normal_min'
=>
$normal_min
,
'NV_MAX'
=>
$NV_MAX
,
'emin'
=>
$emin
,
'emax'
=>
$emax
,
);
return
%properties
;
}
sub
perl_set_fallback_flag {
$Math::MPFR::doubletoa_fallback
++;
}
sub
mpfrtoa {
die
"1st arg to mpfrtoa() must be a Math::MPFR object"
unless
ref
(
$_
[0]) eq
'Math::MPFR'
;
my
$obj
=
shift
;
my
$min_normal_prec
=
defined
(
$_
[0]) ?
shift
: 0;
return
_mpfrtoa(
$obj
,
$min_normal_prec
);
}
sub
anytoa {
die
"1st argument given to anytoa() must be a Math::MPFR object"
unless
Math::MPFR::_itsa(
$_
[0]) == 5;
my
$v
=
shift
;
die
"anytoa() now takes only one argument"
if
defined
(
$_
[0]) ;
my
$bits
= Rmpfr_get_prec(
$v
);
die
"Precision of arg given to anytoa() must be 53 or 64 or 113 or 2098"
unless
(
$bits
== 53 ||
$bits
== 64 ||
$bits
== 113 ||
$bits
== 2098);
my
$emax
= Rmpfr_get_emax();
my
$emin
= Rmpfr_get_emin();
my
$f_init
= Rmpfr_init2(
$bits
);
my
%emax_emin
= (
53
=> [1024, -1073, -1022 ],
64
=> [16384, -16444, -16382],
2098
=> [1024, -1073, -1022 ],
113
=> [16384, -16493, -16382],
);
Rmpfr_set_emax(
$emax_emin
{
$bits
}->[0]);
Rmpfr_set_emin(
$emax_emin
{
$bits
}->[1]);
if
(
$bits
== 2098) {
Rmpfr_strtofr(
$f_init
,
"$v"
, 0, MPFR_RNDN);
if
(!Rmpfr_regular_p(
$f_init
)) {
Rmpfr_set_emax(
$emax
);
Rmpfr_set_emin(
$emin
);
return
mpfrtoa(
$f_init
);
}
my
(
$msd
,
$lsd
) = _mpfr2dd(
$f_init
);
if
(
$lsd
== 0 ) {
my
$f
= Rmpfr_init2(53);
Rmpfr_set_d(
$f
,
$msd
, MPFR_RNDN);
Rmpfr_set_emax(
$emax
);
Rmpfr_set_emin(
$emin
);
return
anytoa(
$f
);
}
my
$intermediates
= _intermediate_bits(
$msd
,
$lsd
);
my
$f_final
= Rmpfr_init2(106 +
$intermediates
);
Rmpfr_set_d(
$f_final
,
$msd
, MPFR_RNDN);
Rmpfr_add_d(
$f_final
,
$f_final
,
$lsd
, MPFR_RNDN);
Rmpfr_set_emax(
$emax
);
Rmpfr_set_emin(
$emin
);
return
mpfrtoa(
$f_final
);
}
my
$inex
= Rmpfr_strtofr(
$f_init
,
"$v"
, 0, MPFR_RNDN);
if
(Rmpfr_regular_p(
$f_init
) && Rmpfr_get_exp(
$f_init
) <
$emax_emin
{
$bits
}->[2]) {
Rmpfr_subnormalize(
$f_init
,
$inex
, MPFR_RNDN);
my
(
$significand
,
$exponent
) = Rmpfr_deref2(
$f_init
, 2, 0, MPFR_RNDN);
my
$f_final
= Rmpfr_init2(1 +
$exponent
-
$emax_emin
{
$bits
}->[1]);
if
(
$significand
=~ s/^\-/-0./) {
Rmpfr_strtofr(
$f_final
,
"${significand}p$exponent"
, 2, MPFR_RNDN);
}
else
{
Rmpfr_strtofr(
$f_final
,
"0.${significand}p$exponent"
, 2, MPFR_RNDN);
}
Rmpfr_set_emax(
$emax
);
Rmpfr_set_emin(
$emin
);
return
mpfrtoa(
$f_final
);
}
Rmpfr_set_emax(
$emax
);
Rmpfr_set_emin(
$emin
);
return
mpfrtoa(
$f_init
);
}
sub
nvtoa_test {
warn
"nvtoa_test() is DEPRECATED. Please use dragon_test() instead"
;
die
"nvtoa_test() requires at least version 3.1.6 of the MPFR library"
if
196870 > MPFR_VERSION;
my
(
$s
,
$n
,
$is_nv
,
$ret
) = (
shift
,
shift
, 0, 0);
my
(
$check
,
$debug
);
$debug
=
defined
(
$_
[0]) ?
$_
[0] : 0;
print
"ARG1: $s\nARG2: $n\n"
if
$debug
;
die
"First arg to nvtoa_test() must be a string"
unless
_SvPOK(
$s
);
if
(
ref
(
$n
) eq
'Math::MPFR'
) {
$check
= Rmpfr_init2(Rmpfr_get_prec(
$n
));
Rmpfr_set_str(
$check
,
$s
, 10, MPFR_RNDN);
Rmpfr_abs(
$check
,
$check
, MPFR_RNDN);
}
else
{
die
"2nd arg to nvtoa_test() must be either an NV or a Math::MPFR object"
unless
_SvNOK(
$n
);
$is_nv
= 1;
$check
=
abs
(atonv(
"$s"
));
}
if
(
$s
=~ s/^\-//) {
die
"In nvtoa_test(): signs do not match"
if
$n
> 0;
}
else
{
die
"In nvtoa_test():mismatch of signs"
if
(
$n
< 0);
}
$n
=
abs
(
$n
);
if
(
$check
== 0) {
return
15
if
$n
== 0;
return
0;
}
return
0
if
$n
== 0;
my
$new
= Math::MPFR->new(
$check
);
if
(Rmpfr_nan_p(
$new
)) {
return
15
if
$n
!=
$n
;
return
0;
}
return
0
if
$n
!=
$n
;
if
(Rmpfr_inf_p(
$new
)) {
return
15
if
$new
==
$n
;
return
0;
}
return
0
if
$n
/
$n
!=
$n
/
$n
;
$ret
++
if
$check
==
$n
;
my
@r
=
split
/e/i,
$s
;
if
(
$debug
) {
print
"SPLIT:\n$r[0]"
;
if
(
defined
(
$r
[1])) {
print
" $r[1]\n"
}
else
{
print
" no exponent\n"
}
}
if
(!
defined
(
$r
[1])) {
$ret
+= 8
if
(
$r
[0] =~ /\.0$/ ||
$r
[0] !~ /0$/);
$r
[1] = 0;
}
else
{
$ret
+= 8
unless
$r
[0] =~ /0$/;
}
chop
(
$r
[0])
while
$r
[0] =~ /0$/;
$r
[0] =~ s/\.$//;
while
(
$r
[0] =~ /0$/) {
chop
$r
[0];
$r
[1]++;
}
return
$ret
+ 6
if
length
(
$r
[0]) < 2;
substr
(
$r
[0], -1, 1,
'0'
);
my
$chopped
=
$r
[1] ?
$r
[0] .
'e'
.
$r
[1]
:
$r
[0];
print
"CHOPPED:\n$chopped\n\n"
if
$debug
;
if
(
$is_nv
) {
$ret
+= 2
if
atonv(
$chopped
) <
$n
;
}
else
{
Rmpfr_set_str(
$check
,
$chopped
, 10, MPFR_RNDN);
$ret
+= 2
if
$check
<
$n
;
}
if
(
$r
[0] =~ /\./) {
my
@mantissa
=
split
/\./,
$r
[0];
my
$point_pos
= -(
length
(
$mantissa
[1]));
my
$t
=
$mantissa
[0] .
$mantissa
[1];
print
"Man (if):\n$t\n"
if
$debug
== 2;
$t
++
for
1..10;
print
"Man++ (if):\n$t\n"
if
$debug
== 2;
substr
(
$t
,
$point_pos
, 0,
'.'
);
$r
[0] =
$t
;
}
else
{
print
"R0 (else):\n$r[0]\n"
if
$debug
== 2;
$r
[0]++
for
1..10;
print
"R0++ (else):\n$r[0]\n"
if
$debug
== 2;
}
my
$incremented
=
defined
(
$r
[1]) ?
$r
[0] .
'e'
.
$r
[1]
:
$r
[0];
print
"INCREMENTED:\n$incremented\n"
if
$debug
;
if
(
$is_nv
) {
$ret
+= 4
if
atonv(
$incremented
) >
$n
;
}
else
{
Rmpfr_set_str(
$check
,
$incremented
, 10, MPFR_RNDN);
$ret
+= 4
if
$check
>
$n
;
}
return
$ret
;
}
sub
dragon_test {
die
"dragon_test() requires at least version 3.1.6 of the MPFR library"
if
196870 > MPFR_VERSION;
my
(
$repro
,
$op
,
$reco
,
$is_nv
,
$ret
,
$debug
);
$debug
= 1
if
(
@_
== 2 &&
$_
[1] =~ /debug/i);
if
(
ref
(
$_
[0]) eq
'Math::MPFR'
) {
$repro
= mpfrtoa(
$_
[0]);
}
else
{
unless
(_SvNOK(
$_
[0]) || _itsa(
$_
[0]) < 3) {
die
"1st arg to dragon_test() must be either an IV or an NV or a Math::MPFR object"
}
$is_nv
= 1;
$repro
= nvtoa(
$_
[0]);
}
if
(
$repro
=~ s/^\-//) {
die
"In dragon_test(): signs do not match"
if
$_
[0] > 0;
}
else
{
die
"In dragon_test():mismatch of signs"
if
(
$_
[0] < 0);
}
if
(
$is_nv
) {
$op
=
abs
(
$_
[0]);
$reco
= atonv(
$repro
);
}
else
{
$op
= Rmpfr_init2(Rmpfr_get_prec(
$_
[0]));
my
$inex
= Rmpfr_abs(
$op
,
$_
[0], MPFR_RNDN);
die
"Copying of argument in dragon_test() failed"
if
$inex
;
$reco
= Rmpfr_init2(Rmpfr_get_prec(
$_
[0]));
Rmpfr_set_str(
$reco
,
$repro
, 10, MPFR_RNDN);
}
print
"OP: $op\nREPRO: $repro\n"
if
$debug
;
if
(
$op
== 0) {
return
15
if
$reco
== 0;
return
0;
}
if
(
$is_nv
) {
if
(Rmpfr_nan_p(Math::MPFR->new(
$op
))) {
return
15
if
$repro
=~ /^nan/i;
return
0;
}
if
(Rmpfr_inf_p(Math::MPFR->new(
$op
))) {
return
15
if
$repro
=~ /^inf/i;
return
0;
}
}
else
{
if
(Rmpfr_nan_p(
$op
)) {
return
15
if
$repro
=~ /^nan/i;
return
0;
}
if
(Rmpfr_inf_p(
$op
)) {
return
15
if
$repro
=~ /^inf/i;
return
0;
}
}
$ret
++
if
$reco
==
$op
;
my
@r
=
split
/e/i,
$repro
;
if
(
$debug
) {
print
"SPLIT:\n$r[0]"
;
if
(
defined
(
$r
[1])) {
print
" $r[1]\n"
}
else
{
print
" no exponent\n"
}
}
if
(!
defined
(
$r
[1])) {
$ret
+= 8
if
(
$r
[0] =~ /\.0$/ ||
$r
[0] !~ /0$/);
$r
[1] = 0;
}
else
{
$ret
+= 8
unless
$r
[0] =~ /0$/;
}
chop
(
$r
[0])
while
$r
[0] =~ /0$/;
$r
[0] =~ s/\.$//;
while
(
$r
[0] =~ /0$/) {
chop
$r
[0];
$r
[1]++;
}
return
$ret
+ 6
if
length
(
$r
[0]) < 2;
substr
(
$r
[0], -1, 1,
'0'
);
my
$chopped
=
$r
[1] ?
$r
[0] .
'e'
.
$r
[1]
:
$r
[0];
print
"CHOPPED:\n$chopped\n\n"
if
$debug
;
if
(
$is_nv
) {
$ret
+= 2
if
atonv(
$chopped
) <
$op
;
}
else
{
Rmpfr_set_str(
$reco
,
$chopped
, 10, MPFR_RNDN);
$ret
+= 2
if
$reco
<
$op
;
}
if
(
$r
[0] =~ /\./) {
my
@mantissa
=
split
/\./,
$r
[0];
my
$point_pos
= -(
length
(
$mantissa
[1]));
my
$t
=
$mantissa
[0] .
$mantissa
[1];
$t
++
for
1..10;
substr
(
$t
,
$point_pos
, 0,
'.'
);
$r
[0] =
$t
;
}
else
{
$r
[0]++
for
1..10;
}
my
$incremented
=
defined
(
$r
[1]) ?
$r
[0] .
'e'
.
$r
[1]
:
$r
[0];
print
"INCREMENTED:\n$incremented\n"
if
$debug
;
if
(
$is_nv
) {
$ret
+= 4
if
atonv(
$incremented
) >
$op
;
}
else
{
Rmpfr_set_str(
$reco
,
$incremented
, 10, MPFR_RNDN);
$ret
+= 4
if
$reco
>
$op
;
}
return
$ret
;
}
sub
_mpfr2dd {
my
$obj
=
shift
;
my
$msd
= Rmpfr_get_d(
$obj
, MPFR_RNDN);
$obj
-=
$msd
;
return
(
$msd
, Rmpfr_get_d(
$obj
, MPFR_RNDN));
}
sub
_intermediate_bits {
my
(
$exp1
,
$exp2
) = (_get_exp(
shift
), _get_exp(
shift
));
return
$exp1
- 53 -
$exp2
;
}
sub
_get_exp {
my
$hex
;
if
(LITTLE_ENDIAN) {
$hex
=
scalar
reverse
unpack
"h*"
,
pack
"d"
,
$_
[0];
}
else
{
$hex
=
unpack
"H*"
,
pack
"d"
,
$_
[0];
}
my
$exp
=
hex
(
substr
(
$hex
, 0, 3));
$exp
-= 2048
if
$exp
> 2047;
$exp
++
unless
$exp
;
return
(
$exp
- 1023);
}
*Rmpfr_get_z_exp
= \
&Rmpfr_get_z_2exp
;
*prec_cast
= \
&Math::MPFR::Prec::prec_cast
;
*Rmpfr_randinit_default
= \
&Math::MPFR::Random::Rmpfr_randinit_default
;
*Rmpfr_randinit_mt
= \
&Math::MPFR::Random::Rmpfr_randinit_mt
;
*Rmpfr_randinit_lc_2exp
= \
&Math::MPFR::Random::Rmpfr_randinit_lc_2exp
;
*Rmpfr_randinit_lc_2exp_size
= \
&Math::MPFR::Random::Rmpfr_randinit_lc_2exp_size
;
sub
nvtoa {
if
(NV_IS_DOUBLEDOUBLE) {
my
$nv
=
shift
;
my
$unpacked
=
unpack
"H*"
,
pack
"D>"
,
$nv
;
my
$msd
=
unpack
"d>"
,
pack
"H*"
,
substr
(
$unpacked
, 0, 16);
my
$lsd
=
unpack
"d>"
,
pack
"H*"
,
substr
(
$unpacked
, 16, 16);
my
$mpfr
= Rmpfr_init2(2098);
Rmpfr_set_ld(
$mpfr
,
$nv
, MPFR_RNDN);
my
(
$neg
,
$prec
,
$different_signs
) = (Rmpfr_signbit(
$mpfr
), 0, 0);
unless
(Rmpfr_regular_p(
$mpfr
)) {
if
(Rmpfr_zero_p(
$mpfr
)) {
return
"-0.0"
if
$neg
;
return
"0.0"
;
}
return
"NaN"
if
Rmpfr_nan_p(
$mpfr
);
return
"-Inf"
if
$neg
;
return
"Inf"
;
}
if
(
$mpfr
< 0) {
Rmpfr_neg(
$mpfr
,
$mpfr
, MPFR_RNDN);
$neg
= 1;
}
my
$exp
= Rmpfr_get_exp(
$mpfr
);
if
(
$lsd
== 0) {
my
$addon
= 1074;
unless
( MPFR_4_0_2_OR_LATER ) {
if
(
$exp
== -1073) {
my
$ret
=
$neg
?
'-5e-324'
:
'5e-324'
;
return
$ret
;
}
}
$prec
=
$addon
+
$exp
;
Rmpfr_prec_round(
$mpfr
,
$prec
, MPFR_RNDN);
return
'-'
. mpfrtoa(
$mpfr
, 728)
if
$neg
;
return
mpfrtoa(
$mpfr
, 728);
}
my
$m_msd
= Rmpfr_init2(53);
my
$m_lsd
= Rmpfr_init2(53);
Rmpfr_set_d(
$m_msd
,
$msd
, MPFR_RNDN);
Rmpfr_set_d(
$m_lsd
,
$lsd
, MPFR_RNDN);
if
(
abs
(
$lsd
) >= 2 ** -1022) {
$prec
= Rmpfr_get_exp(
$m_msd
) - Rmpfr_get_exp(
$m_lsd
) + 53;
if
( (
$lsd
< 0 &&
$msd
> 0) || (
$msd
< 0 &&
$lsd
> 0) ) {
$prec
--;
$different_signs
= 1;
}
my
$mpfr_copy
= Rmpfr_init2(2098);
Rmpfr_set(
$mpfr_copy
,
$mpfr
, MPFR_RNDN);
Rmpfr_prec_round(
$mpfr_copy
,
$prec
, MPFR_RNDN);
my
$trial_repro
= mpfrtoa(
$mpfr_copy
);
my
$trial_dd
= atonv(
$trial_repro
);
if
(
$trial_dd
==
$nv
|| (
$neg
== 1 &&
$trial_dd
==
abs
(
$nv
)) ) {
return
'-'
.
$trial_repro
if
$neg
;
return
$trial_repro
;
}
$prec
++;
}
else
{
$prec
= Rmpfr_get_exp(
$m_msd
) + 1073;
$prec
++
if
$prec
== 0;
my
$mpfr_copy
= Rmpfr_init2(2098);
Rmpfr_set(
$mpfr_copy
,
$mpfr
, MPFR_RNDN);
Rmpfr_prec_round(
$mpfr_copy
,
$prec
, MPFR_RNDN);
my
$trial_repro
= mpfrtoa(
$mpfr_copy
);
my
$trial_dd
= atonv(
$trial_repro
);
if
(
$trial_dd
==
$nv
|| (
$neg
== 1 &&
$trial_dd
==
abs
(
$nv
)) ) {
return
'-'
.
$trial_repro
if
$neg
;
return
$trial_repro
;
}
$prec
++;
}
my
$mpfr_orig
= Rmpfr_init2(2098);
Rmpfr_set(
$mpfr_orig
,
$mpfr
, MPFR_RNDN);
Rmpfr_prec_round(
$mpfr
,
$prec
, MPFR_RNDN);
if
(
$different_signs
) {
my
$candidate
= mpfrtoa(
$mpfr
, 53);
if
(
abs
(
$nv
) != atonv(
$candidate
)) {
my
$ret
= _decrement(
$candidate
);
if
(
abs
(
$nv
) == atonv(
$ret
)) {
return
'-'
.
$ret
if
$neg
;
return
$ret
;
}
$prec
++;
Rmpfr_prec_round(
$mpfr_orig
,
$prec
, MPFR_RNDN);
return
'-'
. mpfrtoa(
$mpfr_orig
, 53)
if
$neg
;
return
mpfrtoa(
$mpfr_orig
, 53);
}
my
$ret
= _chop_test(
$candidate
,
$nv
, 0);
if
(
$ret
eq
'ok'
) {
return
'-'
.
$candidate
if
$neg
;
return
$candidate
;
}
return
'-'
.
$ret
if
$neg
;
return
$ret
;
}
else
{
my
$can
= mpfrtoa(
$mpfr
, 53);
my
$ret
= _chop_test(
$can
,
$nv
, 1);
if
(
$ret
eq
'ok'
) {
return
'-'
.
$can
if
$neg
;
return
$can
;
}
return
'-'
.
$ret
if
$neg
;
return
$ret
;
}
}
else
{
return
_nvtoa(
shift
);
}
}
sub
numtoa {
if
(NV_IS_DOUBLEDOUBLE) {
my
$arg
=
shift
;
return
nvtoa(
$arg
)
if
_SvNOK(
$arg
);
return
_numtoa(
$arg
);
}
else
{
return
_numtoa(
shift
);
}
}
sub
_chop_test {
my
@r
=
split
/e/i,
shift
;
my
$op
=
shift
;
my
$do_increment
=
defined
(
$_
[0]) ?
shift
: 0;
chop
(
$r
[0])
while
$r
[0] =~ /0$/;
$r
[0] =~ s/\.$//;
$r
[1] =
defined
$r
[1] ?
$r
[1] : 0;
while
(
$r
[0] =~ /0$/) {
chop
$r
[0];
$r
[1]++;
}
return
'ok'
if
length
(
$r
[0]) < 2;
substr
(
$r
[0], -1, 1,
''
);
$r
[1]++
unless
$r
[0] =~ /\./;
$r
[0] =~ s/\.$/.0/
unless
$r
[1];
$r
[0] =~ s/\.$//;
if
(!
$do_increment
) {
my
$chopped
=
$r
[1] ?
$r
[0] .
'e'
.
$r
[1]
:
$r
[0];
return
'ok'
if
atonv(
$chopped
) <
abs
(
$op
);
return
$chopped
;
}
if
(
$r
[0] =~ /\./) {
my
@mantissa
=
split
/\./,
$r
[0];
my
$point_pos
= -(
length
(
$mantissa
[1]));
my
$t
=
$mantissa
[0] .
$mantissa
[1];
$t
++;
substr
(
$t
,
$point_pos
, 0,
'.'
);
$r
[0] =
$t
;
}
else
{
$r
[0]++;
$r
[1]++
while
$r
[0] =~ s/0$//;
}
my
$incremented
=
$r
[1] ?
$r
[0] .
'e'
.
$r
[1]
:
$r
[0];
return
$incremented
if
atonv(
$incremented
) ==
abs
(
$op
);
return
'ok'
;
}
sub
_decrement {
my
$shift
=
shift
;
my
@r
=
split
/e/i,
$shift
;
if
(
$r
[0] =~ /\./) {
chop
(
$r
[0])
while
$r
[0] =~ /0$/;
}
$r
[0] =~ s/\.$//;
$r
[1] =
defined
$r
[1] ?
$r
[1] : 0;
while
(
$r
[0] =~ /0$/) {
chop
$r
[0];
$r
[1]++;
}
return
$shift
if
length
(
$r
[0]) < 2;
my
$substitute
=
substr
(
$r
[0], -1, 1) - 1;
substr
(
$r
[0], -1, 1,
"$substitute"
);
my
$ret
=
$r
[1] ?
$r
[0] .
'e'
.
$r
[1]
:
$r
[0];
return
$ret
;
}
sub
_rewrite_fmt_arg {
my
$arg
=
shift
;
if
(
$arg
=~ /^
%L
?[a,A]/) {
my
$match
= $&;
if
(!Math::MPFR::_SvNOK(
$_
[0])) {
die
"\"$match\" formatting applies only to NVs. Use \"%Ra\" for Math::MPFR objects."
}
if
(
$match
=~ /L/) {
die
"\"$match\" formatting applies only to long doubles."
unless
$Config
{nvtype} eq
'long double'
; }
else
{
die
"\"$match\" formatting applies only to doubles."
unless
$Config
{nvtype} eq
'double'
; }
if
(WIN32_FMT_BUG) {
$arg
=~ s/^
%L
?/
%R
/;
return
$arg
;
}
return
''
;
}
if
(
$arg
=~ /[^%]
%L
?[a,A]/) {
my
$match
= $&;
if
(!Math::MPFR::_SvNOK(
$_
[0])) {
die
"\""
,
substr
(
$match
, 1),
"\" formatting applies only to NVs. Use \"%Ra\" for Math::MPFR objects."
}
if
(
$match
=~ /L/) {
die
"\""
,
substr
(
$match
, 1),
"\" formatting applies only to long doubles."
unless
$Config
{nvtype} eq
'long double'
; }
else
{
die
"\""
,
substr
(
$match
, 1),
"\" formatting applies only to doubles."
unless
$Config
{nvtype} eq
'double'
; }
if
(WIN32_FMT_BUG) {
my
$and_init
=
$match
;
my
$temp
=
$match
;
my
$start
=
substr
(
$temp
, 0, 1,
''
);
$temp
=~ s/^
%L
?/
%R
/;
$start
.=
$temp
;
$arg
=~ s/
$and_init
/
$start
/;
return
$arg
;
}
}
return
''
;
}
sub
nv2mpfr {
my
$prec
= Rmpfr_get_default_prec();
Rmpfr_set_default_prec(
$Math::MPFR::NV_properties
{bits});
my
$ret
= Math::MPFR->new(
$_
[0]);
Rmpfr_set_default_prec(
$prec
);
return
$ret
;
}
sub
_win32_formatting_ok {
my
$cc
= _gmp_cc();
my
$cflags
= _gmp_cflags();
return
1
if
(
defined
(
$cc
) &&
$cc
=~/\-D__USE_MINGW_ANSI_STDIO/ );
return
1
if
(
defined
(
$cflags
) &&
$cflags
=~/\-D__USE_MINGW_ANSI_STDIO/ );
return
0;
}
sub
_hex_fmt_ok {
my
$fmt
=
shift
;
if
(
$fmt
=~ /^
%L
?[a,A]|[^%]
%L
?[a,A]/) {
$fmt
= $&;
if
(!Math::MPFR::_SvNOK(
$_
[0])) {
die
"\"%a\" formatting applies only to NVs. Use \"%Ra\" for Math::MPFR objects."
}
if
(
$fmt
=~ /L/) {
die
"\"%La\" formatting applies only to long doubles."
unless
$Config
{nvtype} eq
'long double'
; }
else
{
die
"\"%a\" formatting applies only to doubles."
unless
$Config
{nvtype} eq
'double'
; }
return
0
if
WIN32_FMT_BUG;
return
1;
}
else
{
return
1}
}
sub
overload_lshift {
if
(
$_
[2] || !_looks_like_number(
$_
[1])) {
die
"Math::MPFR: When overloading '<<', the argument that specifies the number of bits to be shifted must be a perl number"
;
}
return
_overload_lshift(
@_
)
if
$_
[1] >= 0;
return
_overload_rshift(
$_
[0], -
$_
[1],
$_
[2]);
}
sub
overload_lshift_eq {
if
(
$_
[2] || !_looks_like_number(
$_
[1])) {
die
"Math::MPFR: When overloading '<<=', the argument that specifies the number of bits to be shifted must be a perl number"
;
}
return
_overload_lshift_eq(
@_
)
if
$_
[1] >= 0;
return
_overload_rshift_eq(
$_
[0], -
$_
[1],
$_
[2]);
}
sub
overload_rshift {
if
(
$_
[2] || !_looks_like_number(
$_
[1])) {
die
"Math::MPFR: When overloading '>>', the argument that specifies the number of bits to be shifted must be a perl number"
;
}
return
_overload_rshift(
@_
)
if
$_
[1] >= 0;
return
_overload_lshift(
$_
[0], -
$_
[1],
$_
[2]);
}
sub
overload_rshift_eq {
if
(
$_
[2] || !_looks_like_number(
$_
[1])) {
die
"Math::MPFR: When overloading '>>=', the argument that specifies the number of bits to be shifted must be a perl number"
;
}
return
_overload_rshift_eq(
@_
)
if
$_
[1] >= 0;
return
_overload_lshift_eq(
$_
[0], -
$_
[1],
$_
[2]);
}
sub
overload_fmod {
if
(
ref
(
$_
[1]) ne
'Math::MPFR'
) {
return
_overload_fmod(
$_
[0], Math::MPFR->new(
$_
[1]), 0)
unless
$_
[2];
return
_overload_fmod(Math::MPFR->new(
$_
[1]),
$_
[0], 0);
}
return
_overload_fmod(
@_
);
}
sub
overload_fmod_eq {
if
(
ref
(
$_
[1]) ne
'Math::MPFR'
) {
return
_overload_fmod_eq(
$_
[0], Math::MPFR->new(
$_
[1]), 0)
unless
$_
[2];
return
_overload_fmod_eq(Math::MPFR->new(
$_
[1]),
$_
[0], 0);
}
return
_overload_fmod_eq(
@_
);
}
1;