Math-MPFR-4.38/0000755060175106010010000000000014766136504011674 5ustar OwnerNoneMath-MPFR-4.38/CHANGES0000755060175106010010000010041714765756127012705 0ustar OwnerNoneRevision history for Perl module Math::MPFR 4.38 - Enable the Rmpf_*_uj and Rmpfr_*_sj functions (except for Rmpfr_get_uj and Rmpfr_get_sj) for all perl configurations. Also enable Rmpfr_pown. - Relocate math_mpfr_include.h conditional defining of "mpfr_exp_t" to below the #inclusion of mpfr.h. 4.37 - Fix bug in t/cross_class_mpq.t that caused failures like: http://www.cpantesters.org/cpan/report/cfa1541e-f6d4-11ef-a0db-2a526e8775ea 4.36 - Fix bug in t/atonv.t - fixes https://rt.cpan.org/Ticket/Display.html?id=160048. Thanks Slaven Rezic. - Add new function q_fmod_fr() - Simplify "OPERATOR OVERLOADING" in MPFR.pod 4.35 - Add Rmpfr_get_float16, Rmpfr_set_float16 and Rmpfr_buildopt_float16_p. All 3 are new in mpfr-4.3.0. - Overload '%' operator to perform fmod(). - Accommodate overloading of Math::GMP objects. - Alter overloading of left shift and right shift operations to be compatible with perl and Math::BigFloat - Fix https://rt.cpan.org/Public/Bug/Display.html?id=158699 (introduced in 4.25). Thanks SREZIC. 4.34 - Fix http://www.cpantesters.org/cpan/report/b5e0d3db-6deb-1014-9c2b-9eec45d75318 Thanks @twata_1. - Sanitize Rmpfr_*printf handling of "%a" formatting. - Add new utility function nv2mpfr(). 4.33 - Add new (in MPFR-4.3.0) function Rmpfr_trigamma and new test script t/trigamma.t - Add dragon_test() as a replacement for the (now) deprecated nvtoa_test(). 4.32 - Workaround a bug in some Win32 builds. See https://github.com/StrawberryPerl/Perl-Dist-Strawberry/issues/226 4.31 - Reduce the testing done in t/LongDouble.t to simply test the correctness of Rmpfr_set_LD() and Rmpfr_get_LD(). - Add log_2(),log_10(), sind(), cosd(), tand() and tangent() functions. - Optionally allow (via setting of $Math::MPFR::PERL_INFNAN) infs and nans to be stringified by nv2a() to the same as perl provides. Previously they have been stringified by nv2a() strictly as "Inf", "-Inf" and "Nan" - which could differ from perl's presentation. See "DISPLAYING INFS AND NANS" in the documentation. 4.29 - Add new (in MPFR-4.3.0) function Rmpfr_compound and new test script t/compound.t. - In math_mpfr_include.h, re-specify MATH_MPFR_NV_MAX in hex, as 32-bit Windows perl-5.39.7 (nvtype of 'double') was apparently unable to evaluate the decimal form correctly. - Silence pointless compilation warnings generated by MPFR.xs. 4.28 - Correct the testing for the presence of the Windows subnormal bug in t/nvtoa2.t. - Small tweaks to Rmpfr_cmp_IV and Rmpfr_set_IV. - Avoid monitoring PL_markstack_ptr in MPFR.xs. - In Rmpfr_deref2, replace 1st arg of '0' in mpfr_get_str() call with 'NULL'. 4.27 - Remove stray '}' from Rmpfr_add_z - Simplify overloading of '++' and '--' 4.26 - Alter t/out_str.t and t/printf.t to accommodate sisyphus' MSVC-built perls. 4.25 - work on fixing bugs in nvtoa() for DoubleDoubles. (Use _mpfrtoa instead of _nvtoa.) - Fix typos in pod. Thanks Vincent Lefevre - https://github.com/sisyphus/math-mpfr/pull/6. - Alter the Makefile.PL (and some test scripts) to accommodate sisyphus' MSVC-built perls. 4.24 - add nvtoa_test() to facilitate validation of results returned by nvtoa() and mpfrtoa(). - mpfrtoa() now takes a second optional arg that specifies the minimum normal precision. If the precision of the Math::MPFR object is less than the specified value, then the the object is deemed to hold a subnormalized value. 4.23 - Fix bug in overload_spaceship() handling of NaN. If the first arg was non-nan and thesecond arg was a Math::MPFR nan object, then the spaceship operator returned 0 instead of undef. (Added a test for this to t/overload.t.) - Fix overload_dec() to handle DEAL_WITH_NANFLAG_BUG_OVERLOADED macro. See https://github.com/sisyphus/math-mpfr/pull/5 4.22 - Add overloading of '<<' and '>>'. (Left shifts and right shifts don't make a lot of sense in floating-point environments. These overloads simply call mul_2ui or mul_2si or (respectively) div_2ui or div_2si, thereby altering the value of the exponent, but having no effect on the mantissa. - Work around perl bug in https://github.com/Perl/perl5/issues/19550. (Affected only perl-5.35.10.) 4.21 - Fix bug re inconsistent settings of POK and NOK flag, which manifests itself as (eg): http://www.cpantesters.org/cpan/report/dc17e330-900b-11ec-bfc9-d1f1448276d4 It's a bug that rarely bites, and applies mainly (but not only) to perl-5.18.x and earlier. 4.19 - Fix https://github.com/sisyphus/math-decimal64/pull/1 (also aplies to Math::MPFR) Thanks to @hiratara - Deal with deprecations of mpfr_root() and mpfr_grandom(). These 2 functions will now croak() if Math::MPFR has been built against mpfr-4.0.0 or later. - Replace four instances of mpz_cmp_ui(z, 0) with less expensive mpz_sgn(z) - Fix doubletoa() handling of negative zero. (Was hanging.) - Remove references to _MSC_VER - Replace sv_2mortal(newSVpv()) with more efficient newSVpvn_flags() where applicable. This is done via the MORTALIZED_PV() macro in math_mpfr_include.h 4.18 - Allow anytoa() to (optionally) take just one (Math::MPFR object) arg, instead of the two args originally mandated. - Simplify Makefile.PL. - Replace XS defines NV_IS_FLOAT128 and NV_IS_LONG_DOUBLE with USE_QUADMATH and USE_LONG_DOUBLE (which are already defined by perl headers). - Replace XS defines NV_IS_DOUBLE and NV_IS_53_BIT with the condition NVSIZE == 8 (which is already defined in the perl headers). - Add Rmpfr_set_IV. - Utilize Rmpfr_cmp_IV and Rmpfr_cmp_NV in the overloaded comparison subs. - Remove the *_UV functions and adapt the corresponding *_IV functions to handle the case that SvUOK() is true. (This is how it should always have been.) - Add Rmpfr_init_set_IV, Rmpfr_init_set_NV and Rmpfr_init_set_float128. - Add Rmpfr_cmp_float128. - Rmpfr_cmp_IV, Rmpfr_set_IV, Rmpfr_init_set_IV, Rmpfr_cmp_NV, Rmpfr_set_NV and Rmpfr_init_set_NV accept only scalars that are IOK or (respectively) NOK as their 2nd argument. - Add POK_flag(), IOK_flag(), NOK_flag (@EXPORT_OK only) 4.17 - In Rmpfr_set_default_prec(), Rmpfr_set_prec() and Rmpfr_set_prec_raw(), check that the argument is not less than 2 if mpfr version is less than 4.0.0. (This change was actually applied to Rmpfr_set_default_prec in Math-MPFR-4.16.) - Remove all occurrences of "scalar reverse" in demos\doubledouble.p and t\subnormal_doubles.t. - Add q_add_fr, q_sub_fr, q_mul_fr, q_div_fr and fr_cmp_q_rounded functions. - Add Rmpfr_cmp_IV, Rmpfr_cmp_UV, Rmpfr_cmp_sj and Rmpfr_cmp_uj (though the MPFR library currently contains neither mpfr_cmp_sj nor mpfr_cmp_uj). - Fix Rmpfr_get_str_ndigits and Rmpfr_get_str_ndigits_alt so that they don't change the inexflag from unset to set. (This was fixed for mpfr_get_str_ndigits in mpfr versions > 4.1.0.) - Add new function mpfrtoa. - Fix typo in Rmpfr_get_str_ndigits code: https://github.com/sisyphus/math-mpfr/commit/1f47b34b4d6b289bef9a40994f95ff57da3c6952#commitcomment-50313325 Thanks @trizen. - Add new functions Rmpfr_acosu, Rmpfr_acospi, Rmpfr_asinu, Rmpfr_asinpi, Rmpfr_atanu, Rmpfr_atanpi, Rmpfr_atan2u, Rmpfr_atan2pi, Rmpfr_powr, Rmpfr_pown, Rmpfr_pow_uj, Rmpfr_pow_sj, Rmpfr_log2p1, Rmpfr_log10p1, Rmpfr_compound_si, Rmpfr_exp2m1 and Rmpfr_exp10m1. - Add Rmpfr_pow_IV and Rmpfr_pow_UV - Alter decimalize() such that, if a second argument is provided, the function returns the projected number of significant digits. This does not break backward compatibility. (See the POD for elaboration.) - Add anytoa() function. - Use POSIX in demos/doubledouble.p to fix a (rarely encountered) bug. - Refactor IV/UV/NV/PV handling inside overload subs. 4.16 - Workaround mpfr library assertion failure in decimalize() could occur when precision is 1 && mpfr library version is less than 4.0.2. 4.15 - Make some changes in test files relating to bareword filehandles and indirect object syntax. - Enhance the Makefile.PL's capability of detecting that mpfr/gmp libraries are not going to be found when needed. - Add decimalize() and check_exact_decimal(). - For mpfr-4.2.0 and later only: add Rmpfr_sinu, Rmpfr_cosu, Rmpfr_tanu, Rmpfr_sinpi, Rmpfr_cospi, Rmpfr_tanpi. - Add Rmpfr_fmod_ui - new in mpfr-4.2.0, but also implemented here in Math::MPFR when built against earlier versions of the mpfr library. - Move code out of MPFR.xs and into (newly created) grisu3.c. 4.14 - Add numtoa() and atonum(). - #include at beginning of grisu3.h to address: https://www.cpantesters.org/cpan/report/0d8a8dfd-6bf4-1014-a7c0-8323ad4a5811 - Fix https://www.cpantesters.org/cpan/report/3622b742-4202-11ea-8c53-8f701f24ea8f by amending Makefile.PL - Add some debug statements throughout nvtoa() in MPFR.xs - relies on NVTOA_DEBUG=1 being provided as a Makefile.PL command line argument . - Correct test 5 of t/numtoa.t for DoubleDouble nvtype. - Add wrapping of mpfr_total_order_p (previously missed) which is new in 4.1.0. - Add wrapping of mpfr_cmpabs_ui (previously missed) which is new in 4.1.0. - In atonv() pre-processing replace " & " with " && " as the former (which was a mistake, anyway) is not guaranteed to yield the correct result. 4.13 - Fix bug in t/rndna.t and t/rndna2.t (exposed by: http://www.cpantesters.org/cpan/report/90030d18-8f4f-11e9-a14c-c69b77725194 ) - Change stringification of 'inf' & 'nan' from '@Inf@' & '@NaN@'to 'Inf' & 'NaN, except for Rmpfr_deref2(), which will still retain the actual inf or nan string returned by mpfr - ie '@Inf@' & '@NaN@'. - Remove definition of MAXIMUM_ALLOWABLE_BASE as it is always 62 now that we no longer support versions of MPFR older than 3.0.0. - Accommodate extended range of allowable bases for mpfr_out_str with MPFR-4.1.0 and later. - Cleanup of some code called by nvtoa(). - Fix bug in _get_exp_and_bits() for DoubleDoubles. Integer values > 2 ** 105 were being misrepresented by nvtoa(). - Improve the private functions _d_bytes, _ld_bytes, _dd_bytes, _f128_bytes - Replace the private functions _d_bytes_fr, _ld_bytes_fr, _dd_bytes_fr, _f128_bytes_fr with the single function _bytes_fr. - Remove mpfr_min_inter_base() and mpfr_max_orig_base() as both are of no value. 4.12 - Fix bug in nvtoa() that had values with negative single digit significands && exponents less than -4 appearing as "-x.e-EXP" instead of "-xe-EXP" - Add doubletoa() function. (Uses grisu3 algorithm.) 4.11 - Optimizations to nvtoa() 4.09 - Hopefully fix bugs in t/nvtoa.t reported by (eg): http://www.cpantesters.org/cpan/report/844b433e-2463-11e9-b3bd-8a932d9bfb17 and http://www.cpantesters.org/cpan/report/608800de-245b-11e9-b3bd-8a932d9bfb17 - Add t/nvtoa2.t for additional testing of nvtoa function\ - Fix nvtoa() for Double-Double long doubles. (Previous to fix, strings being returned by nvtoa() for this nvtype were not always the minimum required length.) 4.08 - In nvtoa(), Work around mpfr_get_str() bug that was not fixed until mpfr-4.0.2 4.07 - Fix bug in t/atonv.t. (Thanks Dana Jacobsen) - Add nvtoa() - Alter the way that atonv() is called. - Emit deprecation warnings in Rmpfr_grandom and Rmpfr_root if mpfr version >= 4.0 4.06 - Fix bug (https://bugs.debian.org/918673) in t/subnormal_doubles.t 4.05 - Add atodouble() function - Fix atonv to correctly handle subnormal double-doubles - Add Rmpfr_dot() and Rmpfr_get_str_ndigits. (New in 4.1.0.) - Correct Rmpfr_sum to return signed int, not unsigned value. - Add Rmpfr_set_DECIMAL128 and Rmpfr_get_DECIMAL128. (New in 4.1.0.) 4.04 - Support only mpfr-3.0.0 and later - Check that first arg given to atonv() is of correct precision. - In MPFR.xs - replace NULL FILE* arguments with stdin/stdout in mpfr_out_str/mpfr_inp_str. (Thanks Vincent Lefevre.) 4.03 - Values less than DENORM_MIN were automatically denormalized to 0 ... but should have been denormalized to DENORM_MIN when greater than DENORM_MIN/2. - Attend to various other issues involving handling of subnormals. - Remove Math::Float128 and Math::Decimal64 from PREREQ_PM. - Add atonv(). 4.02 - mpfr_subnormalize() in _d_bytes(), _ld_bytes() and _f128_bytes(). (These 3 functions are used by Math::NV.) 4.01 - Automatically build Math::MPFR with __float128 support if mpfr_buildopt_float128_p() returns true && 'F128=0' has not been provided as an argument to Makefile.PL. - Automatically build Math::MPFR with _Decimal64 support if mpfr_buildopt_decimal_p() returns true && 'D64=0' has not been provided as an argument to Makefile.PL. - Make sure that _Float128 is a known type when MPFR_WANT_FLOAT128 is defined (because it appears in mpfr.h in mpfr-4.1.0). - Add '-lquadmath' to LIBS in Makefile.PL (as some Cygwin builds apparently want it). - Prototype those subs specified in 'use subs'. - Alter Prec.xs, Random.xs and V.xs to accommodate perl.h's defining (as of 5.28.7) of INTMAX_C and UINTMAX_C. (Replaced '#include ' with '#include "../math_mpfr_include.h" 4.0 - Add Rmpfr_free_cache2 and Rmpfr_free_pool. - Add MPFR_RNDF rounding mode - Fix bug in Rmpfr_cmp_NV and add the tests (test 8 in t/nan_cmp.t) that would have detected it. The bug affected only quadmath builds of perl, and only then if CAN_PASS_FLOAT128 was not defined. - Improve performance of Rmpfr_set_NV and Rmpfr_cmp_NV for quadmath builds of perl where CAN_PASS_FLOAT128 is not defined. - Add Rmpfr_rootn_ui (mpfr-4.0.0 and later only). - Add tests to Rmpfr_get_q.t to check that Rmpfr_get_q canonicalizes the rational. (Trizen pointed out that, with 4.0.0-RC1, mpfr_get_q did NOT canonicalize.) 3.36 - Add Rmpfr_rec_root, provided by Vincent Lefevre: (See https://sympa.inria.fr/sympa/arc/mpfr/2016-12/msg00032.html) Re-arranged as an XSub, and some special case handling added. - Add Rmpfr_beta (mpfr-4.0.0 and later only). - Rename t/new_in_3.2.0.t to t/new_in_4.0.0.t - Add Rmpfr_q_div and Rmpfr_z_div and use them in overload_div to replace the existing code (that was rounding twice). - Add overloading of comparisons with mpq_t and mpz_t - use mpfr library of version of mpfr_get_q (in preference to homegrown rendition) if MPFR_VERSION_MAJOR >= 4. - Workaround mpfr_get_float128() failure to round subnormals reliably. (Workaround was removed soon after - when the mpfr_get_float128 problem was fixed in mpfr source.) 3.35 - In Makefile.PL define -DNV_IS_DOUBLE if appropriate (for use in math_mpfr_include.h as part of fix for __float128 handling in nvtype=double DEBUGGING builds of perl). - Tighten the conditions under which _win32_infnanstring() is called. (Now called only if OS is MS Windows && $] < 5.022.) - Add Rmpfr_round_nearest_away() - Move POD from MPFR.pm to MPFR.pod 3.34 - eval{} Rmpfr_z_sub in t/flags.t (test 23). - Remove -DUSE_LONG_DOUBLE (from Makefile.PL). - Add _is_infnanstring to MPFR.xs (for use with overloaded string operations). - Add Rmpfr_cmp_NV. 3.33 - Document Rmpfr_grandom as deprecated as of mpfr-3.2.0. - Add the following functions which will be available when mpfr-4.0.0 (or higher) is installed: Rmpfr_fmodquo, Rmpfr_fpif_export, Rmpfr_fpif_import, Rmpfr_flags_clear, Rmpfr_flags_set, Rmpfr_flags_test, Rmpfr_flags_save, Rmpfr_flags_restore, Rmpfr_rint_roundeven, Rmpfr_roundeven, Rmpfr_nrandom, Rmpfr_erandom, Rmpfr_fmma, Rmpfr_fmms, Rmpfr_log_ui and Rmpfr_gamma_inc - Add support for IEEE 754 long doubles to bytes() function, and rewrite bytes() documentation. - Remove library functions (gmp_v and Rmpfr_get_version) from Math::MPFR::V, as we don't want any library functions in that module. - Handle the setting of the NaN flag with mpfr_add/sub_ui/si functions for versions of mpfr (3.1.4 and earlier only). The bug should be fixed in later versions of mpfr. - Replace SvNV/SvUV/SvIV with SvNVX/SvUVX/SvIVX where appropriate. (In typemap, too.) - Add Rmpfr_buildopt_float128_p and Rmpfr_buildopt_sharedcache_p - t/_1basic.t now ouptuts the values of the various (available) buildopt functions. 3.32 - Corrections to fixes to t/DoubleDouble2.t and t/bytes.t. (Same problem existed with some addtional architectures, too.) Version 3.31 will be marked for removal to backpan. 3.31 - Fixes to t/DoubleDouble2.t and t/bytes.t (which were failing on machines that had the "double-double" type, but only when perl's nvtype was double). 3.30 - Correction to the negative zero bug workaround in Rmpfr_fits_uintmax_p (which had previously been returning false for (-0, MPFR_RNDD). - Remove Rmpfr_set_str_binary and Rmpfr_print_binary. (Obsolete in mpfr library.) - Fix t/LongDouble.t for change to Math::LongDouble output precision (ticket #111813) 3.29 - Add _d_bytes XSub. - Simplify demos/doubledouble.p - Allow _d_bytes, _ld_bytes, and _f128_bytes to determine the base of the given argument. - Add _d_bytes_fr, _dd_bytes_fr, _ld_bytes_fr and _f128_bytes_fr - Add bytes() function. - Amend typedef of __float128 alignment (Windows only) - Add Rmpfr_get_q (even though MPFR does not implement mpfr_get_q) - define mp_bitcnt_t to unsigned long int for pre-gmp-5.0.0 3.28 - Fix mistake in test 5 in t/bytes.t. 3.27 - Replace mpfr_set_default_prec() calls in _ld_bytes and _f128_bytes with appropriate mpfr_init2() calls. 3.26 - Re-phrase misleading message in t/use64bitint.t. (Message implied that absence of 'long long int' implied that ivsize was 32-bit.) - Add Rmpfr_print_rnd_mode - previously missed. - Rewrite rounding value check as CHECK_ROUNDING_VALUE macro - Add _ld_bytes and _f128_bytes XSub (for use of Math::NV) 3.25 - Catch the error of giving too large a "size" argument to mpfr_sum.t and add a check for this to t/sum.t - Amend the #definition of LNGAMMA_BUG to cater for the fact that mpfr-3.1.3 did *not* contain a fix for the lngamma bug. 3.24 - Rename the Rgmp_randstate* functions to Rmpfr_randstate*, and move them into their own (Math::MPFR::Random) module. - Standardise numeric treatment of strings that contain non-numeric characters. Add Math::MPFR::NNW and Math::MPFR::nnumflag() & friends. - Correction to t/native_float128.t - Use NVtoD64 to assign NV to Math::Decimal64 object in D64_LD.t - as Math::Decimal64::new() is no longer capable of making that assignment. 3.23 - Rename Rmpfr_get_decimal64, Rmpfr_set_decimal64, Rmpfr_get_float128 & Rmpfr_set_float128 to Rmpfr_get_DECIMAL64, Rmpfr_set_DECIMAL64, Rmpfr_get_FLOAT128 & Rmpfr_set_FLOAT128 - Provide Rmpfr_get_float128 & Rmpfr_set_float128 which pass the __float128 value as an NV - Ensure that when casting an IV/NV to an mpfr_t, the mpfr_t has enough precision to accurately represent the value. - No longer define USE_64_BIT_INT if ivtype is 'long'. (Thus had to tweak some test files.) - Rename USE_64_BIT_INT #define to MATH_MPFR_NEED_LONG_LONG_INT - Define IVSIZE_BITS (in XS file) if MATH_MPFR_NEED_LONG_LONG_INT is defined - for use in initialization of mpfr_t in some of the overload functions. - Add FLOAT128_DIG 3.22 - Add some metadata to Makefile.PL. - Fix the LNGAMMA_BUG workaround in mpfr.c, and change test 69 in t/test1.t to test for correct behaviour of mpfr_lngamma(). - Add Rmpfr_set_NV - and use it in new(). - Remove Rmpfr_sprintf_ret and Rmpfr_snprintf_ret. - No longer include inttypes.h on the basis of USE_LONG_DOUBLE being defined. (Was harmless ... but didn't make much sense.) - Define PERL_NO_GET_CONTEXT. - Tweaks to Math::MPFR::gmp_v() and Math::MPFR::V::gmp_v() 3.21 - Fix errors in t/decimal64_conv.t 3.19 - Rewrite _wrap_mpfr_sprintf(), _wrap_mpfr_snprintf(), _wrap_mpfr_sprintf_rnd() and _wrap_mpfr_snprintf_rnd(). Their first arg has been changed from a char* to an SV*, and they take an additional argument that specifies the size of the buffer (1st arg) into which the resultant string is written. - Change Rmpfr_sprintf_ret() and Rmpfr_snprintf_ret(). The first arg (buffer) has been removed, and an additional argument that specifies the size of the buffer into which the resultant string is written needs to be provided. - Fix spelling error in doc. Thanks Salvatore Bonaccorso. (Ticket #89710) - Add Rmpfr_set_float128 and Rmpfr_get_float128. These provide access to the '__float128' data type (for compilers that support the type) via the Math::Float128 module. - Simplify querying of Decimal64 support in the mpfr library being used - Add MPFR_DBL_DIG, MPFR_LDBL_DIG, mpfr_max_orig_len, mpfr_min_inter_prec, mpfr_min_inter_base and mpfr_max_orig_base. - Have lngamma(-0) be +Inf instead of NaN. (Bug in mpfr 3.1.2 and earlier.) 3.18 - Depending upon the rounding mode values, the mpfr library may incorrectly return false for mpfr_fits_u*_p(x) for -1.0 < x < 0.0 or for -0.5 < x <0.0. (This should be fixed in versions of mpfr later than 3.1.2.) Have the Rmpfr_fits_u*_p() functions return correct result irrespective of the version of mpfr being used - and have the Math:MPFR test suite test for this. - The 'P' type specifier (precision) wasn't working correctly on big-endian machines when mp_prec_t size is less than IV size. Add a prec_cast function to fix this. - Add an _mp_sizes function (not exportable) that returns the sizes of mpfr_exp_t, mpfr_prec_t and mpfr_rnd_t. - Add Math::MPFR::_ivsize (not exportable). - Add Math::MPFR::_nvsize (not exportable). - Correct the Rmpfr_*printf functions so that they croak with an appropriate error message if a rounding arg is supplied but the last arg is not a Math::MPFR object. 3.17 - Apply patch to MPFR.xs from Daniel Kahn Gillmor that eliminates "null argument where non-null required" warnings. - Fix typo in croak() message in MPFR.xs (also caught by Daniel). 3.16 - Add Rmpfr_set_LD() and Rmpfr_get_LD(). These provide access to the 'long double' data type (for perls whose nvtype is double) via the Math::LongDouble module. 3.15 - Add _Decimal64-mpfr_t conversion 3.14 - Fix pod. (The ' ' symbol was causing pod.t failures.) Also took care of some other typos/oversights in the documentation. 3.13 - Add Math::MPFR::V - Add pre/post increment/decrement operations (overload_add and overload_inc) - Allow (cross-class) overloading of basic math operations with Math::GMPz, Math::GMPq and Math::GMPf objects. 3.12 - Remove 'not' from overloads. Apparently achieved nothing anyway, and 5.16 warns that it's invalid. 3.11 - Add t/tls.t and t/tls_flags.t (to test the thread local storage capabilities, where applicable). 3.10 - Add the following functions (conditional upon building against mpfr-3.1.0 or later): Rmpfr_set_divby0, Rmpfr_clear_divby0, Rmpfr_divby0_p, Rmpfr_buildopt_tune_case, Rmpfr_frexp, Rmpfr_grandom, Rmpfr_z_sub, Rmpfr_buildopt_gmpinternals_p. - Add Rgmp_randinit_mt. - In Rmpfr_get_d_2exp and Rmpfr_get_ld_2exp, replace sv_setuv (was incorrect) with sv_setiv. - Replace New/Newz with Newx/Newxz on perls that support the new symbols (Newx/Newxz). 3.02 - Rmpfr_min_prec now available only when building against mpfr-3.0.0 or later. (The mpfr_min_prec function was not available until 3.0.0.) 3.01 - Remove the (outdated) link to http://www.loria.fr/projets/mpfr/mpfr-current/mpfr.html in the "DESCRIPTION" section of the documentation. (Thanks Hugh Myers.) - In the documentation, elaborate on the way that Rmpfr_get-version() and MPFR_VERSION & friends determine their values. (Thanks Vincent Lefevre.) - Correct Rmpfr_min_prec(), and remove Rmpfr_max_prec(). 3.0 - Corresponding to release of mpfr-3.0.0. (Still needs only 2.4.0, but 3.0.0 needed to take advantage of all features.) - Add MPFR_* rounding modes (including MPFR_RNDA for builds against mpfr-3.0.0) - Add Rmpfr_buildopt_tls_p() and Rmpfr_buildopt_decimal_p() (mpfr-3.0.0 only) - Add the following functions, specific to mpfr-3.0.0: Rmpfr_regular_p, Rmpfr_set_zero, Rmpfr_digamma, Rmpfr_ai, Rmpfr_set_flt, Rmpfr_get_flt, Rmpfr_urandom and Rmpfr_set_z_2exp. - Add Rmpfr_get_z_2exp (mpfr_get_z_exp is now renamed to mpfr_get_z_2exp). - Add gmp_randstate_t* to the Math::MPFR typemap. - Change handling of NaNs (wrt overloaded comparison operators). The overloaded spaceship operator now returns undef when NaNs are involved (more in keeping with perl behaviour), and the erange flag is now set whenever a comparison involving NaNs is performed (more in keeping with the mpfr library behaviour). This is irrespective of whether the NaN is a Math::MPFR object or a perl NV. The other comparison operators now also set the erange flag when a NaN is involved (for compatibility with the mpfr library). - Add Rmpfr_snprintf and Rmpfr_snprintf_ret. - Add Rmpfr_inits, Rmpfr_inits2 and Rmpfr_clears functions. - The overload_copy sub now preserves the precision of the copied object (instead of taking on default precision). 2.03 - Needs version 2.4.0 (or later) of the mpfr library. - Add the following functions (new in mpfr-2.4.0): Rmpfr_add_d, Rmpfr_sub_d, Rmpfr_d_sub Rmpfr_mul_d, Rmpfr_div_d, Rmpfr_d_div, Rmpfr_rec_sqrt, Rmpfr_sinh_cosh, Rmpfr_li2, Rmpfr_zeta_ui, Rmpfr_modf, Rmpfr_fmod, Rmpfr_printf, Rmpfr_fprintf, Rmpfr_sprintf, Rmpfr_sprintf_ret - Fix overload_sqrt() so that it returns a NaN for negative operands instead of croaking, as was originally the case. - Remove (the need for) INLINE.h - Add RMPFR_PREC_MIN and RMPFR_PREC_MAX. - Add Rmpfr_sum, Rmpfr_get_d_2exp, Rmpfr_get_ld_2exp, Rmpfr_dim, Rmpfr_fits_ushort_p, Rmpfr_fits_sshort_p, Rmpfr_fits_uint_p, Rmpfr_fits_sint_p, Rmpfr_fits_uintmax_p, Rmpfr_fits_intmax_p, Rmpfr_fits_IV_p, Rmpfr_fits_UV_p Rmpfr_add_si Rmpfr_get_UV Rmpfr_get_IV Rmpfr_get_NV 2.02 - Add TRmpfr_out_str/TRmpfr_inp_str (which wraps mpfr_out_str/mpfr_inp_str more Truly than Rmpfr_out_str/Rmpfr_inp_str). - Rmpfr_out_str now has the option to take a prefix string. - Remove the tests in the Makefile.PL that test for the presence of a suitable compiler, GMP library and MPFR library. 2.01 - Needs version 2.3.0 (or later) of the mpfr library. - Add Rmpfr_j0, Rmpfr_j1, Rmpfr_jn, Rmpfr_y0, Rmpfr_y1, Rmpfr_yn, Rmpfr_lgamma, Rmpfr_remainder, Rmpfr_remquo, Rmpfr_fms, Rmpfr_signbit, Rmpfr_setsign, and Rmpfr_copysign(all new in 2.3.0). Add also Rmpfr_get_patches (documented for the first time in 2.3.0). - Add Rmpfr_init_set_ld. - Add Rmpfr_deref2 to the list of exportable functions, and document its usage in the POD section. - Rmpfr_deref2 now has the mpfr library allocate (and free) memory for the mantissa. - Add Rmpfr_hypot (previously missed). - Rmpfr_out_str now takes an optional fifth argument (a string that will be appended to the mpfr_out_str output). And the output buffer is now flushed each time Rmpfr_out_str is called. - Rewrite new() - to make it a little tidier. - Add Rmpfr_set_uj and Rmpfr_set_uj_2exp to @EXPORT_TAGS. (Previously overlooked.) - Add Rmpfr_integer_string() - mainly to provide a simple means of getting 'sj' and 'uj' values on a 64-bit perl where the MPFR library does not support mpfr_get_uj and mpfr_get_sj functions - which happens with libraries built with Microsoft Compilers. - Fix the rendering of Inf and NaN values. (Now matches the mpfr_out_str output for Inf and NaN.) - Change the format returned by Rmpfr_get_str. (Hence the output of Rmpfr_get_string and Math::MPFR::overload_string have changed from earlier versions of Math::MPFR.) - Fix some of the overloaded subroutines as regards their handling of NaN. 1.11 - Fix bug in Rmpfr_get_str. (Sometimes printed out one less digit than it ought.) - Remove mpfr.info from distribution. Refer instead to: http://www.mpfr.org/mpfr-current/mpfr.html - Have 'make clean' remove comp.exe, check.exe and version.exe. - Add support for perls built with -Duselongdouble (Rmpfr_*_ld functions, except Rmpfr_init_set_ld() which is not available in unpatched 2.2.1). - Add Rmpfr_cmp_d, Rmpfr_exp10 and the Rmpfr_*_uj functions (which had somehow been earlier overlooked). - Fix handling of unsigned long longs on perls built with -Duse64bitint. - Allow assignment of mpz, mpq, and mpf types using new() 1.10 - No longer assign Exporter and DynaLoader to @Math::MPFR::ISA. - Add support for perls built with -Duse64bitint. This involved the inclusion of the Rmpfr_set_sj, Rmpfr_set_sj_2exp and Rmpfr_get_sj functions - as well as some alterations to the overload subs. 1.09 - Changes to the format returned by Rmpfr_get_str and overload_string. - Add a new() method/function for creation of mpfr_t objects. - Fix Rmpfr_out_str() and Rmpfr_inp_str() - were segfaulting with MS compilers. 1.08 - As of this version, MPFR-2.2.x is required. - Add new functions made available with the release of MPFR-2.2.0: Rmpfr_set_overflow Rmpfr_set_underflow Rmpfr_set_inexflag Rmpfr_set_erangeflag Rmpfr_set_nanflag Rmpfr_erfc Rmpfr_atan2 Rmpfr_pow_z Rmpfr_subnormalize Rmpfr_const_catalan Rmpfr_sec Rmpfr_csc Rmpfr_cot Rmpfr_root Rmpfr_eint Rmpfr_get_f Rmpfr_sech Rmpfr_csch Rmpfr_coth Rmpfr_lngamma RMPFR_VERSION_NUM - Add constants (actually implemented as subroutines): MPFR_VERSION MPFR_VERSION_MAJOR MPFR_VERSION_MINOR MPFR_VERSION_PATCHLEVEL MPFR_VERSION_STRING - Remove Rmpfr_add_one_ulp and Rmpfr_sub_one_ulp (no longer supported by the MPFR library). - Redefine '__gmpfr_default_rounding_mode' in MPFR.xs as it's no longer in mpfr.h. (Been moved to mpfr-impl.h which I don't want to include.) - Rewrite of overload_atan2 - now that mpfr_atan2 is available in MPFR-2.2.0. (Also fixes a bug in overload_atan2). 1.07 - New() was allocating more memory than necessary in many instances. Rewrote the XS code (in those instances) to fix that. - Add Rmpfr_strtofr 1.06 - Modify the Makefile.PL checks added in version 1.05 to cater for those building with a Microsoft compiler - Alter Rmpfr_set_str and Rmpfr_init_set_str so that a base of 0 can be specified - in which case the base is determined from the input string - Added the following functions: Rmpfr_get_ui Rmpfr_get_si Rmpfr_fits_ulong_p Rmpfr_fits_slong_p - Fix a bug in 'Rmpfr_deref2()' - used by 'overload_print()' - Provide more complete testing with 4 new test files - namely test4.t, trig.t, set_str.t and exceptions.t. 1.05 - Add some checks to Makefile.PL to ensure that anyone trying to build this module has an up-to-date MPFR library. This is mainly an attempt to stop cpan testers who don't have an up-to-date MPFR from testing the module and subsequently reporting "FAIL" or "NA". 1.04 - Math::MPFR-1.04 to 1.07 require MPFR-2.1.x. - Added the following functions, not available with versions earlier than 2.1.0 : Rmpfr_set_ui_2exp Rmpfr_set_si_2exp Rmpfr_get_z Rmpfr_si_sub Rmpfr_sub_si Rmpfr_mul_si Rmpfr_si_div Rmpfr_div_si Rmpfr_sqr Rmpfr_cmp_z Rmpfr_cmp_q Rmpfr_cmp_f Rmpfr_zero_p Rmpfr_free_cache Rmpfr_get_version Rmpfr_get_emin_min Rmpfr_get_emin_max Rmpfr_get_emax_min Rmpfr_get_emax_max Rmpfr_clear_erangeflag Rmpfr_erangeflag_p Rmpfr_rint_round Rmpfr_rint_trunc Rmpfr_rint_ceil Rmpfr_rint_floor 1.03 - Replace 'SvROK()' with 'sv_isobject()' in the overload functions. - Make 'get_refcnt()' and 'get_package_name()' non-exportable. 1.02 - Make overloading work with strings. - Add 'Rmpfr_dump'. - Add 'Math::MPFR::gmp_v' (not exportable). 1.01 - Eradicate segfault that was occurring when 'overload_add', 'overload_sub', 'overload_mul', 'overload_div' and 'overload_pow' croaked due to invalid argument(s). 0.07 - Replace 'Rmpfr_round_prec' with 'Rmpfr_prec_round' in keeping with changes to the MPFR library. - Remove 'Rmpfr_random' (deprecated). - Add 'Rmpfr_cbrt', 'Rmpfr_cmpabs', ', 'Rmpfr_greater_p', 'Rmpfr_greaterequal_p', 'Rmpfr_less_p', 'Rmpfr_lessequal_p', 'Rmpfr_lessgreater_p', 'Rmpfr_equal_p', 'Rmpfr_unordered_p', 'Rmpfr_inp_str', 'Rmpfr_frac', 'Rmpfr_integer_p', 'Rmpfr_nexttoward', 'Rmpfr_nextabove', 'Rmpfr_next_below', 'Rmpfr_min', 'Rmpfr_max', 'Rmpfr_get_exp', 'Rmpfr_set_exp' 'Rgmp_randinit_default', 'Rgmp_randinit_lc_2exp', 'Rgmp_randinit_lc_2exp_size', 'Rgmp_randseed', 'Rgmp_randseed_ui', 'Rgmp_randclear'. - Change module name from 'Math::GnuMPfr' to 'Math::MPFR'. 0.06 - Add 'Rmpfr_gamma()', 'Rmpfr_zeta()', and 'Rmpfr_erf()'. - Add overloading for 'atan2', 'cos', 'sin', 'log', 'exp', and 'int'. 0.05 - Requires mpfr-2.0.3 - Add 'Rmpfr_out_str()' - Add 'Rmpfr_get_default_rounding_mode()' - Rename 'Rmpfr_set_str_raw()' to 'Rmpfr_set_str_binary()' in keeping with changes to the MPFR library. - Alter 'Rmpfr_check_range()' in keeping with change to 'mpfr_check_range()' in the MPFR library. - Introduce operator overloading. Math-MPFR-4.38/checklib.in0000755060175106010010000000014714765756127014005 0ustar OwnerNone #include int main(void) { printf("%s", "Found the mpfr and gmp libraries"); return 0; } Math-MPFR-4.38/demos/0000755060175106010010000000000014766136501013000 5ustar OwnerNoneMath-MPFR-4.38/demos/doubledouble.p0000755060175106010010000001037614765756127015653 0ustar OwnerNone# Provide floating point values on the command line (@ARGV) and see those # values represented in doubledouble big endian format. # The subs dd_str() and dd_obj() return both doubles ($msd, $lsd) - where $msd is the most # significant double and $lsd the least significant double. The actual value represented by # the double is the sum of the two doubles. # As an example, try: # perl doubledouble.p 2.3 1e+127 0x17.fe99991f9999999999999888888888888888888 use warnings; use strict; use Math::MPFR qw(:mpfr); use POSIX; # Needed by dd_str() and dd_obj() to deal # with 2 specific cases. die "Must provide at least one command line argument" if !@ARGV; for my $float(@ARGV) { my($msd, $lsd) = dd_str($float); print "$float\n"; printf "%.17g %.17g\n", $msd, $lsd; print internal_hex($msd) . " "; print internal_hex($lsd) . "\n"; my $test = Rmpfr_init2(2098); Rmpfr_set_str($test, $float, 0, MPFR_RNDN); my @check = dd_obj($test); if($check[0] == $msd && $check[1] == $lsd) { print "dd_obj() checks out correctly\n"; } else {print "dd_obj() failed\n"} @check = dd2dd($msd, $lsd); if($check[0] == $msd && $check[1] == $lsd) { print "dd2dd() checks out correctly\n\n"; } else {print "dd2dd() failed\n\n"} } ################################################ ################################################ sub dd_str { my $val = Rmpfr_init2(2098); # Max precision that can be encapsulated in doubledouble Rmpfr_set_str($val, $_[0], 0, MPFR_RNDN); my $msd = Rmpfr_get_d($val, MPFR_RNDN); if($msd == 0 || $msd != $msd || $msd / $msd != 1) {return ($msd, 0.0)} # it's inf, nan or zero. $val -= $msd; my $lsd = Rmpfr_get_d($val, MPFR_RNDN); # At this point, we could simply return ($msd, $lsd) # if not for the possibility that $msd and $lsd have # the same sign && abs($msd) == POSIX::DBL_MAX && # abs($lsd) == 2 ** 970 return ($msd, $lsd) unless ($msd == POSIX::DBL_MAX && $lsd == 2 ** 970) || ($msd == -POSIX::DBL_MAX && $lsd == -(2 ** 970)); return ($msd + $lsd, 0); # ie return (Inf, 0) or (-Inf, 0) as appropriate } # sub dd_obj takes a Math::MPFR object (with 2098-bit precision) as its arg sub dd_obj { my $obj = shift; die "arg to dd_obj() is not a Math::MPFR object" if Math::MPFR::_itsa($obj) != 5; my $prec = Rmpfr_get_prec($obj); die "arg to dd_obj() has $prec bits of precision - but needs to have 2098 bits" if $prec != 2098; my $msd = Rmpfr_get_d($obj, MPFR_RNDN); if($msd == 0 || $msd != $msd || $msd / $msd != 1) {return ($msd, 0.0)} # $msd is zero, nan, or inf. $obj -= $msd; my $lsd = Rmpfr_get_d($obj, MPFR_RNDN); # At this point, we could simply return ($msd, $lsd) # if not for the possibility that $msd and $lsd have # the same sign && abs($msd) == POSIX::DBL_MAX && # abs($lsd) == 2 ** 970 return ($msd, $lsd) unless ($msd == POSIX::DBL_MAX && $lsd == 2 ** 970) || ($msd == -POSIX::DBL_MAX && $lsd == -(2 ** 970)); return ($msd + $lsd, 0); # ie return (Inf, 0) or (-Inf, 0) as appropriate } # sub dd2dd takes 2 doubles as arguments. It returns the 2 doubles (msd, lsd) that form the # double-double representation of the sum of the 2 arguments. We can therefore use this function # to question whether the 2 arguments are a valid double-double pair - the answer being "yes" if # and only if dd2dd() returns the identical 2 values that it received as arguments. # In the process, it prints out the internal hex representations of both arguments, and the # internal hex representations of the 2 doubles that it returns. sub dd2dd { my $val = Rmpfr_init2(2098); Rmpfr_set_ui($val, 0, MPFR_RNDN); print " HEX_INPUT : ", internal_hex($_[0]), " ", internal_hex($_[1]), "\n"; Rmpfr_add_d($val, $val, $_[0], MPFR_RNDN); Rmpfr_add_d($val, $val, $_[1], MPFR_RNDN); my @ret = dd_obj($val); print " HEX_OUTPUT: ", internal_hex($ret[0]), " ", internal_hex($ret[1]), "\n"; return @ret; } # sub internal_hex returns the internal hex format (byte structure) of the double precision # argument it received. sub internal_hex { return unpack("H*", (pack "d>", $_[0])); } # sub internal_hex2dec does the reverse of internal_hex() - ie returns the value, derived from # the internal hex argument. sub internal_hex2dec { return unpack "d>", pack "H*", $_[0]; } __END__ Math-MPFR-4.38/demos/euler.p0000755060175106010010000001675514765756127014331 0ustar OwnerNone################################################################################# # This script requires Math::GMPq, Math::GMPz, and Math::MPFR. # # It calculates the euler number e (2.7182818...), correct to $ARGV[0] bits. # # The calculated value is displayed unless $ARGV[1] is both provided and false. # # With each iteration of the for{} loop (below) we get closer and closer to # # the actual value of e. Furthermore, with successive iterations of the for{} # # loop, the values alternate between "less than e" and "greater than e". # # Hence the actual (irrational) value of e is always between the values # # calculated by successive iterations of the for{} loop. # # # # Of course, the simplest and most efficient way to get the value of e, to # # $ARGV[0] bits is simply to do: # # Rmpfr_exp($rop, Math::MPFR->new(1), MPFR_RNDN) # # where $rop is a $ARGV[0]-bit precision Math::MPFR object. # # But doing it that way is a bit less interesting. # # # # The same for{} loop can be also used to calculate the exact probabilities of # # "winning" at a simplistic solitaire-type card game. See demos/solitaire.p # # in the Math::GMPz source distro. # ################################################################################# use strict; use warnings; use Math::GMPz qw(:mpz); use Math::GMPq qw(:mpq); use Math::MPFR qw(:mpfr); die "Usage: perl euler.pl bits [True|False]" unless @ARGV; my $bits = shift; Rmpfr_set_default_prec($bits); my $display_value; $display_value = defined($ARGV[0]) ? shift : 1; ################################################################################# # For the sanity checks (below), set $e_big_p to e, correct to $bits+100 bits. # # Then convert $e_big_p exactly to a rational, $e_q (a Math::GMPq object). # ################################################################################# my $e_q = Math::GMPq->new(); # my $e_big_p = Rmpfr_init2($bits + 100); # Rmpfr_exp($e_big_p, Math::MPFR->new(1), MPFR_RNDN); # Rmpfr_get_q($e_q, $e_big_p); # ################################################################################# ################################################################# # Create some variables, and assign some initial values # ################################################################# my $first = Math::GMPz->new(1); # my $second = Math::GMPz->new(0); # my $current_items = 2; # my $factorial = Math::GMPz->new(1); # my $e_check = Math::GMPq->new(); # my ($e, $e_first_fr, $e_second_fr) = (Math::MPFR->new(), # Math::MPFR->new(), # Math::MPFR->new(), # ); # my $chance; # becomes a MATH::GMPz object on assignment # my $e_first = Math::GMPq->new(3); # my $e_second = Math::GMPq->new(); # my $count = 0; # my $t = Math::GMPq->new(); # my $save = Math::GMPq->new(4); # ################################################################# ################################################################# # Set $e to a $bits-bit approximation of the euler number, # # rounded to nearest. # # This should exactly equal the number that we calculate. # ################################################################# Rmpfr_exp($e, Math::MPFR->new(1), MPFR_RNDN); # ################################################################# ######################### # Do the calculations # ######################### for(;;) { $count++; Rmpz_mul_ui($factorial, $factorial, $current_items); #$factorial *= $current_items; $chance = ($current_items - 1) * ($first + $second); ######################################################### # In this block we just perform some sanity checks. # # This block plays no part in the calculation of the # # actual value. # # Assign the calculated rational value to $e_check. # # Check that for every 2nd iteration, $e_check > $e_q # # and that for every other iteration, $e_check < $e_q # # Also check that, with each iteration, we get closer # # to the value of e (ie closer to the value of $e_q) # ######################################################### Rmpq_set_num($e_check, $factorial); # Rmpq_set_den($e_check, $chance); # Rmpq_canonicalize($e_check); # gcd(num, den) == 1 # if($count % 2) { # unless($e_check < $e_q) {die "$count: >="} # } # else { # unless($e_check > $e_q) {die "$count: <="} # } # Rmpq_sub($t, $e_q, $e_check); # if(abs($t) < $save) {Rmpq_set($save, abs($t))} # else {die "$count: No closer to e"} # ######################################################### Rmpq_set_num($e_second, $factorial); Rmpq_set_den($e_second, $chance); Rmpq_canonicalize($e_second); # gcd(num, den) == 1 Rmpfr_set_q($e_first_fr, $e_first, MPFR_RNDN); Rmpfr_set_q($e_second_fr, $e_second, MPFR_RNDN); ######################################################### # Exit the loop when $e_first_fr == $e_second_fr # # as this equivalence indicates that both variables # # contain the euler number, correct to $bits bits. # ######################################################### last if Rmpfr_equal_p($e_first_fr, $e_second_fr); # ######################################################### Rmpz_set($first, $second); Rmpz_set($second, $chance); Rmpq_set($e_first, $e_second); $current_items++; } if($e == $e_first_fr) { print "Iterations: $count ok\n"; if($display_value) {print "$e_first_fr\n"} } else {print print "Iterations: $count not ok\n$e\n$e_first_fr\n"} __END__ The sequence: With 1st iteration, e = 2! divided by 1 (ie divided by 1 * (1 + 0 )) With 2nd iteration, e = 3! divided by 2 (ie divided by 2 * (0 + 1 )) With 3rd iteration, e = 4! divided by 9 (ie divided by 3 * (1 + 2 )) With 4th iteration, e = 5! divided by 44 (ie divided by 4 * (2 + 9 )) With 5th iteration, e = 6! divided by 265 (ie divided by 5 * (9 + 44 )) With 6th iteration, e = 7! divided by 1854 (ie divided by 6 * (44 + 265 )) With 7th iteration, e = 8! divided by 14833 (ie divided by 7 * (265 + 1854 )) With 8th iteration, e = 9! divided by 133496 (ie divided by 8 * (1854 + 14833 )) With 9th iteration, e = 10! divided by 1334961 (ie divided by 9 * (14833 + 133496)) Math-MPFR-4.38/grisu3.c0000755060175106010010000002301414765756127013267 0ustar OwnerNone#include #include "grisu3.h" /* This code is part of an implementation of the "grisu3" double to string conversion algorithm described in the research paper "Printing Floating-Point Numbers Quickly And Accurately with Integers" by Florian Loitsch, available at http://www.cs.tufts.edu/~nr/cs257/archive/florian-loitsch/printf.pdf */ /* This grisu3 implementation is used by doubletoa() in MPFR.xs */ /* See grisu3.h for definition of symbols and types */ static const power pow_cache[] = { { 0xfa8fd5a0081c0288ULL, -1220, -348 }, { 0xbaaee17fa23ebf76ULL, -1193, -340 }, { 0x8b16fb203055ac76ULL, -1166, -332 }, { 0xcf42894a5dce35eaULL, -1140, -324 }, { 0x9a6bb0aa55653b2dULL, -1113, -316 }, { 0xe61acf033d1a45dfULL, -1087, -308 }, { 0xab70fe17c79ac6caULL, -1060, -300 }, { 0xff77b1fcbebcdc4fULL, -1034, -292 }, { 0xbe5691ef416bd60cULL, -1007, -284 }, { 0x8dd01fad907ffc3cULL, -980, -276 }, { 0xd3515c2831559a83ULL, -954, -268 }, { 0x9d71ac8fada6c9b5ULL, -927, -260 }, { 0xea9c227723ee8bcbULL, -901, -252 }, { 0xaecc49914078536dULL, -874, -244 }, { 0x823c12795db6ce57ULL, -847, -236 }, { 0xc21094364dfb5637ULL, -821, -228 }, { 0x9096ea6f3848984fULL, -794, -220 }, { 0xd77485cb25823ac7ULL, -768, -212 }, { 0xa086cfcd97bf97f4ULL, -741, -204 }, { 0xef340a98172aace5ULL, -715, -196 }, { 0xb23867fb2a35b28eULL, -688, -188 }, { 0x84c8d4dfd2c63f3bULL, -661, -180 }, { 0xc5dd44271ad3cdbaULL, -635, -172 }, { 0x936b9fcebb25c996ULL, -608, -164 }, { 0xdbac6c247d62a584ULL, -582, -156 }, { 0xa3ab66580d5fdaf6ULL, -555, -148 }, { 0xf3e2f893dec3f126ULL, -529, -140 }, { 0xb5b5ada8aaff80b8ULL, -502, -132 }, { 0x87625f056c7c4a8bULL, -475, -124 }, { 0xc9bcff6034c13053ULL, -449, -116 }, { 0x964e858c91ba2655ULL, -422, -108 }, { 0xdff9772470297ebdULL, -396, -100 }, { 0xa6dfbd9fb8e5b88fULL, -369, -92 }, { 0xf8a95fcf88747d94ULL, -343, -84 }, { 0xb94470938fa89bcfULL, -316, -76 }, { 0x8a08f0f8bf0f156bULL, -289, -68 }, { 0xcdb02555653131b6ULL, -263, -60 }, { 0x993fe2c6d07b7facULL, -236, -52 }, { 0xe45c10c42a2b3b06ULL, -210, -44 }, { 0xaa242499697392d3ULL, -183, -36 }, { 0xfd87b5f28300ca0eULL, -157, -28 }, { 0xbce5086492111aebULL, -130, -20 }, { 0x8cbccc096f5088ccULL, -103, -12 }, { 0xd1b71758e219652cULL, -77, -4 }, { 0x9c40000000000000ULL, -50, 4 }, { 0xe8d4a51000000000ULL, -24, 12 }, { 0xad78ebc5ac620000ULL, 3, 20 }, { 0x813f3978f8940984ULL, 30, 28 }, { 0xc097ce7bc90715b3ULL, 56, 36 }, { 0x8f7e32ce7bea5c70ULL, 83, 44 }, { 0xd5d238a4abe98068ULL, 109, 52 }, { 0x9f4f2726179a2245ULL, 136, 60 }, { 0xed63a231d4c4fb27ULL, 162, 68 }, { 0xb0de65388cc8ada8ULL, 189, 76 }, { 0x83c7088e1aab65dbULL, 216, 84 }, { 0xc45d1df942711d9aULL, 242, 92 }, { 0x924d692ca61be758ULL, 269, 100 }, { 0xda01ee641a708deaULL, 295, 108 }, { 0xa26da3999aef774aULL, 322, 116 }, { 0xf209787bb47d6b85ULL, 348, 124 }, { 0xb454e4a179dd1877ULL, 375, 132 }, { 0x865b86925b9bc5c2ULL, 402, 140 }, { 0xc83553c5c8965d3dULL, 428, 148 }, { 0x952ab45cfa97a0b3ULL, 455, 156 }, { 0xde469fbd99a05fe3ULL, 481, 164 }, { 0xa59bc234db398c25ULL, 508, 172 }, { 0xf6c69a72a3989f5cULL, 534, 180 }, { 0xb7dcbf5354e9beceULL, 561, 188 }, { 0x88fcf317f22241e2ULL, 588, 196 }, { 0xcc20ce9bd35c78a5ULL, 614, 204 }, { 0x98165af37b2153dfULL, 641, 212 }, { 0xe2a0b5dc971f303aULL, 667, 220 }, { 0xa8d9d1535ce3b396ULL, 694, 228 }, { 0xfb9b7cd9a4a7443cULL, 720, 236 }, { 0xbb764c4ca7a44410ULL, 747, 244 }, { 0x8bab8eefb6409c1aULL, 774, 252 }, { 0xd01fef10a657842cULL, 800, 260 }, { 0x9b10a4e5e9913129ULL, 827, 268 }, { 0xe7109bfba19c0c9dULL, 853, 276 }, { 0xac2820d9623bf429ULL, 880, 284 }, { 0x80444b5e7aa7cf85ULL, 907, 292 }, { 0xbf21e44003acdd2dULL, 933, 300 }, { 0x8e679c2f5e44ff8fULL, 960, 308 }, { 0xd433179d9c8cb841ULL, 986, 316 }, { 0x9e19db92b4e31ba9ULL, 1013, 324 }, { 0xeb96bf6ebadf77d9ULL, 1039, 332 }, { 0xaf87023b9bf0ee6bULL, 1066, 340 } }; /* pow10_cache[i] = 10^(i-1) */ static const unsigned int pow10_cache[] = { 0, 1, 10, 100, 1000, 10000, 100000, 1000000, 10000000, 100000000, 1000000000 }; static int cached_pow(int exp, diy_fp *p) { int k = (int)ceil((exp+DIYFP_FRACT_SIZE-1) * D_1_LOG2_10); int i = (k-MIN_CACHED_EXP-1) / CACHED_EXP_STEP + 1; p->f = pow_cache[i].fract; p->e = pow_cache[i].b_exp; return pow_cache[i].d_exp; } static diy_fp minus(diy_fp x, diy_fp y) { diy_fp d; d.f = x.f - y.f; d.e = x.e; #ifdef DTOA_ASSERT if(x.e != y.e) croak("x.e != y.e"); if(x.f < y.f) croak("x.f < y.f"); /* assert(x.e == y.e && x.f >= y.f); */ #endif return d; } static diy_fp multiply(diy_fp x, diy_fp y) { uint64_t a, b, c, d, ac, bc, ad, bd, tmp; diy_fp r; a = x.f >> 32; b = x.f & MASK32; c = y.f >> 32; d = y.f & MASK32; ac = a*c; bc = b*c; ad = a*d; bd = b*d; tmp = (bd >> 32) + (ad & MASK32) + (bc & MASK32); tmp += 1U << 31; /* round */ r.f = ac + (ad >> 32) + (bc >> 32) + (tmp >> 32); r.e = x.e + y.e + 64; return r; } static diy_fp normalize_diy_fp(diy_fp n) { #ifdef DTOA_ASSERT if(n.f == 0) croak("n.f == 0"); /* assert(n.f != 0); */ #endif while(!(n.f & 0xFFC0000000000000ULL)) { n.f <<= 10; n.e -= 10; } while(!(n.f & D64_SIGN)) { n.f <<= 1; --n.e; } return n; } static diy_fp double2diy_fp(double d) { diy_fp fp; uint64_t u64 = CAST_U64(d); if(!(u64 & D64_EXP_MASK)) { fp.f = u64 & D64_FRACT_MASK; fp.e = 1 - D64_EXP_BIAS; } else { fp.f = (u64 & D64_FRACT_MASK) + D64_IMPLICIT_ONE; fp.e = (int)((u64 & D64_EXP_MASK) >> D64_EXP_POS) - D64_EXP_BIAS; } return fp; } static int largest_pow10(uint32_t n, int n_bits, uint32_t *power) { int guess = ((n_bits + 1) * 1233 >> 12) + 1/*skip first entry*/; if(n < pow10_cache[guess]) --guess; /* We don't have any guarantees that 2^n_bits <= n. */ *power = pow10_cache[guess]; return guess; } static int round_weed(char *buffer, int len, uint64_t wp_W, uint64_t delta, uint64_t rest, uint64_t ten_kappa, uint64_t ulp) { uint64_t wp_Wup = wp_W - ulp; uint64_t wp_Wdown = wp_W + ulp; while(rest < wp_Wup && delta - rest >= ten_kappa && (rest + ten_kappa < wp_Wup || wp_Wup - rest >= rest + ten_kappa - wp_Wup)) { --buffer[len-1]; rest += ten_kappa; } if(rest < wp_Wdown && delta - rest >= ten_kappa && (rest + ten_kappa < wp_Wdown || wp_Wdown - rest > rest + ten_kappa - wp_Wdown)) return 0; return 2*ulp <= rest && rest <= delta - 4*ulp; } static int digit_gen(diy_fp low, diy_fp w, diy_fp high, char *buffer, int *length, int *kappa) { uint64_t unit = 1; diy_fp too_low = { low.f - unit, low.e }; diy_fp too_high = { high.f + unit, high.e }; diy_fp unsafe_interval = minus(too_high, too_low); diy_fp one = { 1ULL << -w.e, w.e }; uint32_t p1 = (uint32_t)(too_high.f >> -one.e); uint64_t p2 = too_high.f & (one.f - 1); uint32_t div; *kappa = largest_pow10(p1, DIYFP_FRACT_SIZE + one.e, &div); *length = 0; while(*kappa > 0) { uint64_t rest; int digit = p1 / div; buffer[*length] = (char)('0' + digit); ++*length; p1 %= div; --*kappa; rest = ((uint64_t)p1 << -one.e) + p2; if (rest < unsafe_interval.f) return round_weed(buffer, *length, minus(too_high, w).f, unsafe_interval.f, rest, (uint64_t)div << -one.e, unit); div /= 10; } for(;;) { int digit; p2 *= 10; unit *= 10; unsafe_interval.f *= 10; /* Integer division by one. */ digit = (int)(p2 >> -one.e); buffer[*length] = (char)('0' + digit); ++*length; p2 &= one.f - 1; /* Modulo by one. */ --*kappa; if (p2 < unsafe_interval.f) return round_weed(buffer, *length, minus(too_high, w).f * unit, unsafe_interval.f, p2, one.f, unit); } } int grisu3(double v, char *buffer, int *length, int *d_exp) { int mk, kappa, success; diy_fp dfp = double2diy_fp(v); diy_fp w = normalize_diy_fp(dfp); /* normalize boundaries */ diy_fp t = { (dfp.f << 1) + 1, dfp.e - 1 }; diy_fp b_plus = normalize_diy_fp(t); diy_fp b_minus; diy_fp c_mk; /* Cached power of ten: 10^-k */ uint64_t u64 = CAST_U64(v); #ifdef DTOA_ASSERT if(v <= 0) croak("v <= 0, but Grisu only handles strictly positive finite numbers"); if(v > 1.7976931348623157e308) croak("v > 1.7976931348623157e308, but Grisu only handles strictly positive finite numbers"); /* assert(v > 0 && v <= 1.7976931348623157e308); *//* Grisu only handles strictly positive finite numbers. */ #endif if (!(u64 & D64_FRACT_MASK) && (u64 & D64_EXP_MASK) != 0) { b_minus.f = (dfp.f << 2) - 1; b_minus.e = dfp.e - 2;} /* lower boundary is closer? */ else { b_minus.f = (dfp.f << 1) - 1; b_minus.e = dfp.e - 1; } b_minus.f = b_minus.f << (b_minus.e - b_plus.e); b_minus.e = b_plus.e; mk = cached_pow(MIN_TARGET_EXP - DIYFP_FRACT_SIZE - w.e, &c_mk); w = multiply(w, c_mk); b_minus = multiply(b_minus, c_mk); b_plus = multiply(b_plus, c_mk); success = digit_gen(b_minus, w, b_plus, buffer, length, &kappa); *d_exp = kappa - mk; return success; } int i_to_str(int val, char *str) { int len, i; char *s; char *begin = str; if(val < 0) { *str++ = '-'; val = -val; if(val < 10) *str++ = '0'; } else { if (val) *str++ = '+'; } s = str; for(;;) { int ni = val / 10; int digit = val - ni*10; *s++ = (char)('0' + digit); if(ni == 0) break; val = ni; } *s = '\0'; len = (int)(s - str); for(i = 0; i < len/2; ++i) { char ch = str[i]; str[i] = str[len-1-i]; str[len-1-i] = ch; } return (int)(s - begin); } Math-MPFR-4.38/grisu3.h0000755060175106010010000000244214765756127013276 0ustar OwnerNone /* This file is part of an implementation of the "grisu3" double to string conversion algorithm described in the research paper "Printing Floating-Point Numbers Quickly And Accurately with Integers" by Florian Loitsch, available at http://www.cs.tufts.edu/~nr/cs257/archive/florian-loitsch/printf.pdf */ #include /* #include */ /* not wanted in Math::MPFR */ #ifdef _MSC_VER #pragma warning(disable : 4204) /* nonstandard extension used : non-constant aggregate initializer */ #endif #define D64_SIGN 0x8000000000000000ULL #define D64_EXP_MASK 0x7FF0000000000000ULL #define D64_FRACT_MASK 0x000FFFFFFFFFFFFFULL #define D64_IMPLICIT_ONE 0x0010000000000000ULL #define D64_EXP_POS 52 #define D64_EXP_BIAS 1075 #define DIYFP_FRACT_SIZE 64 #define D_1_LOG2_10 0.30102999566398114 /* 1 / lg(10) */ #define MIN_TARGET_EXP -60 #define MASK32 0xFFFFFFFFULL #define CAST_U64(d) (*(uint64_t*)&d) #define GRISU3_MIN(x,y) ((x) <= (y) ? (x) : (y)) #define GRISU3_MAX(x,y) ((x) >= (y) ? (x) : (y)) #define MIN_CACHED_EXP -348 #define CACHED_EXP_STEP 8 typedef struct diy_fp { uint64_t f; int e; } diy_fp; typedef struct power { uint64_t fract; int16_t b_exp, d_exp; } power; int grisu3(double, char*, int*, int*); int i_to_str(int, char*); Math-MPFR-4.38/have_d128.in0000755060175106010010000000005714765756127013722 0ustar OwnerNoneint main(void) { _Decimal128 x; return 0; } Math-MPFR-4.38/have_d64.in0000755060175106010010000000005614765756127013640 0ustar OwnerNoneint main(void) { _Decimal64 x; return 0; } Math-MPFR-4.38/have_f128.in0000755060175106010010000000005614765756127013723 0ustar OwnerNoneint main(void) { __float128 x; return 0; } Math-MPFR-4.38/have_float16.in0000755060175106010010000000030714765756127014516 0ustar OwnerNone#include #include #include int main(void) { int s; s = (int)sizeof(_Float16); if(s == 2) { if(mpfr_buildopt_float16_p()) s -= 4; } printf("%d", s); return 0; } Math-MPFR-4.38/Makefile.PL0000755060175106010010000003664114765756127013673 0ustar OwnerNoneuse strict; use warnings; use Config; use ExtUtils::MakeMaker; #require 5.008008; our %args = map { split /\s*=\s*/ } @ARGV; our $LIBS = $args{ LIBS } || "-lmpfr -lgmp"; our $INC = $args{ INC }; our $DEFS = ''; my $defines = ''; my $use_64_bit_int = 0; # Let perl decide whether to include 64-bit 'long long' support my $use_long_double = 0; # Let perl decide whether to include 'long double' support my $use_quadmath = 0; # Let perl decide whether to include '__float128' support my $have_decimal64 = undef; # Default value my $have_decimal128 = undef; # Default value my $have_float128 = undef; # Default value my $want_float128 = undef; # Default value my $have_float16 = undef; # Default value my $checklib = 1; # Check for availability of mpfr and gmp libraries. my $skip_msvc = 0; # Will be reset to 1 for MS compiler builds of perl. my ($d64_message, $d128_message, $float128_message); for(@ARGV) { $have_decimal128 = 1 if $_ eq 'D128=1'; $have_decimal128 = 0 if $_ eq 'D128=0'; $have_float16 = 1 if $_ eq 'F16=1'; $have_float16 = 0 if $_ eq 'F16=0'; } # The following tests don't work with perls built using MS Visual Studio. # We skip them all, as they are not particularly important ... some are # even irrelevant. # In skipping these tests we assumpe (perhaps incorrectly) that, if you're # running MS Visual Studio, then you have gmp and mpfr libraries that are # compatible with that toolchain, && that those libraries will be found # when needed. $skip_msvc = 1 if ($Config{'make'} eq 'nmake' && $Config{'cc'} eq 'cl'); unless($skip_msvc) { print " Running some (possibly noisy) pre-build checks\n to find out what's available ....\n\n"; my $SAVE; my $save = open $SAVE, '>', 'save_config.txt'; warn "Couldn't open save_config.txt for writing: $!" unless $save; my($mycc, $mklib, $mkinc, $mylibpth) = ('', '', '', '') ; if(@ARGV) { for my $arg(@ARGV) { $mycc = (split /=/, $arg)[1] if $arg =~ /^cc=/i; $mklib = (split /=/, $arg)[1] if $arg =~ /^libs=/i; $mkinc = (split /=/, $arg)[1] if $arg =~ /^inc=/i; $checklib = 0 if $arg =~ /^check=0/i; } } unless($mycc) { $mycc = defined($Config{cc}) ? $Config{cc} : 'cc'; } my @libpth = split /\s+/, $Config{libpth}; for(@libpth) { $mylibpth .= " -L$_" } $mylibpth .= " -lmpfr -lgmp"; ############################################################### # Check that -lmpfr and -lgmp can be found. Don't worry about # # checking for mpfr.h and gmp.h - if they can't be found when # # needed by a smoker then it won't be reported as a FAIL # ############################################################### if($checklib) { my $mylibs = $mklib . " " . $mylibpth; my $out = `$mycc -o checklib.exe -x c checklib.in $mylibs 2>&1`; if($out) { print "$out\n"; if($save) {print $SAVE "checklib build: $out\n"} } if(-e 'checklib.exe') { $out = $^O =~ /MSWin32/i ? `checklib.exe` : `./checklib.exe`; if($save) {print $SAVE "checklib.exe: $out\n"} } else { warn "\n Could not resolve '-lmpfr' and/or '-lgmp'\n", " If this is incorrect please see the 'Checklib' section in the README\n", " Aborting the build of Math::MPFR\n"; exit 0; } } ################################## # Whether _Float16 is recognized # ################################## unless(defined($have_float16)) { # make no changes and conduct no further # tests if $have_float16 is defined. if($Config{ptrsize} == 4) { $have_float16 = 0; # Currently not supported by Math::MPFR } else { my $mylibs = $mklib . " " . $mylibpth; my $out = `$mycc -o have_float16.exe -x c have_float16.in $mylibs 2>&1`; if( -e 'have_float16.exe') { my $size = $^O =~ /MSWin32/i ? `have_float16.exe` : `./have_float16.exe`; $have_float16 = 1 if $size eq '-2'; } } } $defines .= ' -DHAVE_FLOAT16 -DMPFR_WANT_FLOAT16=1' if $have_float16 == 1; ############################################ # Whether to build with _Decimal64 support # ############################################ for(@ARGV) { $have_decimal64 = 1 if $_ eq 'D64=1'; $have_decimal64 = 0 if $_ eq 'D64=0'; } if(!defined($have_decimal64)) { # _Decimal64 support still undetermined my $mylibs = $mklib . " " . $mylibpth; my $out = `$mycc -o have_d64.exe -x c have_d64.in 2>&1`; if($out) { print "$out\n"; if($save) {print $SAVE "try_64 build: $out\n"} } unless(-e 'have_d64.exe') {$have_decimal64 = 0} else { # _Decimal64 support still undetermined my $out = `$mycc -o try_dec64.exe -x c try_dec64.in $mkinc $mylibs 2>&1`; if($out) { print "$out\n"; if($save) {print $SAVE "try_dec64 build: $out\n"} } if(-e 'try_dec64.exe') { $out = $^O =~ /MSWin32/i ? `try_dec64.exe` : `./try_dec64.exe`; { no warnings 'numeric'; if($out == 42) {$have_decimal64 = 1} } if($save) {print $SAVE "try_dec64.exe: $out\n"} } } } $d64_message = $have_decimal64 ? "Attempting to build with Math::Decimal64 support\n" : "Building without Math::Decimal64 support\n"; ############################################# ############################################# # Whether to build with _Decimal128 support # ############################################# if(!defined($have_decimal128)) { # _Decimal128 support still undetermined my $mylibs = $mklib . " " . $mylibpth; my $out = `$mycc -o have_d128.exe -x c have_d128.in 2>&1`; if($out) { print "$out\n"; if($save) {print $SAVE "try_128 build: $out\n"} } unless(-e 'have_d128.exe') {$have_decimal128 = 0} else { # _Decimal128 support still undetermined my $out = `$mycc -o try_dec128.exe -x c try_dec128.in $mkinc $mylibs 2>&1`; if($out) { print "$out\n"; if($save) {print $SAVE "try_dec128 build: $out\n"} } if(-e 'try_dec128.exe') { $out = $^O =~ /MSWin32/i ? `try_dec128.exe` : `./try_dec128.exe`; { no warnings 'numeric'; if($out == 128) {$have_decimal128 = 1} } if($save) {print $SAVE "try_dec128.exe: $out\n"} } } } $d128_message = $have_decimal128 ? "Attempting to build with Math::Decimal128 support\n" : "Building without Math::Decimal128 support\n"; ########################################### ########################################### # Whether to build with __float128 support # ########################################### for(@ARGV) { $have_float128 = 1 if $_ eq 'F128=1'; $have_float128 = 0 if $_ eq 'F128=0'; } if(!defined($have_float128)) { # __float128 support, having not yet been # specified by the user, is still undetermined print $SAVE "\n\n" if $save; my $mylibs = $mklib . " " . $mylibpth . " -lquadmath"; # First up, build have_f128.exe from have_f128.c. # This simply establishes whether the __float128 type is available. # The gmp and mpfr libraries are not needed for this' my $out = `$mycc -o have_f128.exe -x c have_f128.in 2>&1`; if($out) { print "$out\n"; if($save) {print $SAVE "have_f128 build: $out\n"} } # If have_f128.exe does not exist, we assume that the __float128 # type is unavailable, and that __float128 support is therefore # impossible. The messages written to 'save_config.txt' should # confirm the correctness of this assessment. unless(-e 'have_f128.exe') {$have_float128 = 0} # But if have_f128.exe exists then we need to establish whether # the mpfr library has been built with support for the __float128 # type. For this we attempt to build try_flt128.exe from # try_flt128.in. This build *does* require the gmp and mpfr headers # and libraries. # If the execution of try_flt128.exe produces output of 42, then # we know that the mpfr library has been built with --enable-float128, # we set $have_float128 to 1, and Math::MPFR will then be built to # utilise that __float128 support. # Otherwise we leave $have_float128 as undef, and no __float128 # support will be built into Math::MPFR. else { # $Config{ccflags} might include the '-I' switch needed to # locate the gmp and mpfr header files. We therefore include # those ccflags inthe command: my $ccflags = $Config{ccflags}; my $out = `$mycc $ccflags -o try_flt128.exe -x c try_flt128.in $mkinc $mylibs 2>&1`; if($out) { # print "$out\n"; # No need to confuse people by # displaying contents of $out. if($save) {print $SAVE "try_flt128 build: $out\n"} } if(-e 'try_flt128.exe') { $out = $^O =~ /MSWin32/i ? `try_flt128.exe` : `./try_flt128.exe`; { no warnings 'numeric'; if($out == 42) {$have_float128 = 1} } if($save) {print $SAVE "try_flt128.exe: $out\n"} } } } close $SAVE or warn "Couldn't close save_config.txt"; print " .... pre-build checks completed\n\n"; $float128_message = $have_float128 ? "Attempting to build with Math::Float128 support\n" : "Building without Math::Float128 support\n"; } # close 'unless($kip_msvc) $defines .= $] < 5.008 ? " -DOLDPERL" : " -DNEWPERL"; #################################### # Next, we check to see whether there's some unhelpful beaviour regarding # the setting of the POK flag - but only if $] < 5.035010. # This typically occurs in versions of perl prior to 5.22.0, but it can # arise elsewhere, eg: # http://www.cpantesters.org/cpan/report/dc17e330-900b-11ec-bfc9-d1f1448276d4 # This procedure is stolen from: # https://metacpan.org/release/HAARG/Sub-Quote-2.006006/source/t/quotify.t # Thank you, Haarg. if($] < 5.035010) { use B qw(svref_2object); my %flags; { no strict 'refs'; for my $flag (qw( SVf_IOK SVf_NOK SVf_POK SVp_IOK SVp_NOK SVp_POK )) { if (defined &{'B::'.$flag}) { $flags{$flag} = &{'B::'.$flag}; } } } sub flags { my $flags = B::svref_2object(\($_[0]))->FLAGS; join ' ', sort grep $flags & $flags{$_}, keys %flags; } my $pv_nv_bug = 0; my $test_nv = 1.3; my $buggery = "$test_nv"; my $f = flags($test_nv); if($f =~ /SVf_POK/) { print "Dealing with unhelpful setting of POK flag\n"; $pv_nv_bug = 1; } if($pv_nv_bug) { $defines .= " -DMPFR_PV_NV_BUG"; $DEFS .= " -DMPFR_PV_NV_BUG"; print "Defining MPFR_PV_NV_BUG\n\n"; } else { print "Not defining MPFR_PV_NV_BUG\n\n"; } } else { print "Not defining MPFR_PV_NV_BUG as perl version >= 5.035010\n\n" } #################################### unless($Config{ivsize} < 8 || $Config{ivtype} eq 'long') { $defines .= " -DMATH_MPFR_NEED_LONG_LONG_INT -DIVSIZE_BITS=" . (8 * $Config{ivsize}); } if($Config::Config{nvsize} > 8 ) { $use_quadmath = 1 if $Config{nvtype} eq '__float128'; $use_long_double = 1 if $Config{nvtype} eq 'long double'; } $defines .= " -DMPFR_WANT_DECIMAL_FLOATS" if ($have_decimal64 || $have_decimal128); $defines .= " -DMPFR_WANT_DECIMAL64" if $have_decimal64; $defines .= " -DMPFR_WANT_DECIMAL128" if $have_decimal128; $defines .= " -DMPFR_WANT_FLOAT128" if $have_float128; print "\nThis module requires the following C libraries:\n"; print " gmp-4.2.0 (or later)\n mpfr-3.0.0 (or later)\n\n"; $defines =~ /\-DMATH_MPFR_NEED_LONG_LONG_INT/ ? print "Building with 'long long' support\n" : print "Building without 'long long' support\n"; if($use_long_double || $use_quadmath) { print "Building with 'long double' support\n"; } else { print "Building without 'long double' support\n"; } if($use_quadmath) { print "Building with support for a __float128 NV\n"; } else { print "Building without support for a __float128 NV\n"; } unless($skip_msvc) { print "\n$d64_message"; print "If this is wrong, see the \"Decimal64 and Decimal128 conversion\" section in the README\n\n"; print "\n$d128_message"; print "If this is wrong, see the \"Decimal64 and Decimal128 conversion\" section in the README\n\n"; print "\n$float128_message"; print "If this is wrong, see the \"Math::Float128 conversion\" section in the README\n\n"; } $defines .= $Config::Config{byteorder} =~ /^1234/ ? " -DMPFR_HAVE_LENDIAN" : " -DMPFR_HAVE_BENDIAN"; if(defined $Config{longdblkind}) { if($Config{longdblkind} == 1 || $Config{longdblkind} == 2) { $defines .= " -DHAVE_IEEE_754_LONG_DOUBLE"; } if($Config{longdblkind} == 3 || $Config{longdblkind} == 4) { $defines .= " -DHAVE_EXTENDED_PRECISION_LONG_DOUBLE"; } } if($^O =~ /MSWin32/i && $] < 5.022) { $defines .= " -D_WIN32_BIZARRE_INFNAN"; } if($Config{nvsize} == 8) { my $fallback_notify = 1; for(@ARGV) { $fallback_notify = 0 if $_ eq "FB=0"; } if($fallback_notify) { $defines .= " -DFALLBACK_NOTIFY"; print "\ndoubletoa() fallback notification ENABLED (default)\n\n"; } else { print "\ndoubletoa() fallback notification DISABLED\n\n" } } # The following defines serve as debugging # aids for nvtoa() and doubletoa() for(@ARGV) { $defines .= ' -DNVTOA_DEBUG' if $_ =~ /NVTOA_DEBUG/i; # prints out (to STDERR) intermediate # values in nvtoa(). $defines .= ' -DDTOA_ASSERT' if $_ =~ /DTOA_ASSERT/i; # runs checks at various points in doubletoa() # and croaks whenever a check fails. } # NOTE: The '-lquadmath' link we provide below # to 'LIBS' is generally not needed. # It is, however, currently needed on at # least some quadmath Cygwin builds. # Jan 8 2018. # If the quadmath library cannot be found # then EU::MM should remove that link - # so no big deal ... right ? # But then there's (eg): # https://www.cpantesters.org/report/7bc0f088-0b21-11ef-a9cc-b541ccdb2386 # where the link cannot be resolved, yet # it does NOT get removed. WTF ?? # Apparently EU::MM can locate the library # but the build process cannot. my %options = ( NAME => 'Math::MPFR', AUTHOR => 'Sisyphus (sisyphus at (@) cpan dot (.) org)', ABSTRACT => 'Perl interface to the MPFR (floating point) library', DEFINE => $defines, LIBS => [ '-lmpfr -lgmp -lquadmath' ], PREREQ_PM => { 'Test::More' => '0.88', }, #OBJECT => '$(O_FILES)', # set below if $Config{nvsize} == 8 LICENSE => 'perl', VERSION_FROM => 'MPFR.pm', clean => { FILES => '*.exe *.txt' }, META_MERGE => { 'meta-spec' => { version => 2 }, resources => { repository => { type => 'git', url => 'https://github.com/sisyphus/math-mpfr.git', web => 'https://github.com/sisyphus/math-mpfr', }, }, }, ); # Invlolve grisu3.h and grisu3.c if $Config{nvsize} == 8. # Otherwise they're not needed : $options{OBJECT} = '$(O_FILES)' if $Config{nvsize} == 8; # The following stuffs up Decimal128 conversions # & __float128 conversions, though it does allow # support for _Float16 on 32-bit windows. # $options{CCFLAGS} = $Config{ccflags} . " -msse2 " # if($Config{ptrsize} == 4 && $have_float16 == 1); WriteMakefile(%options); # Remove the Makefile dependency. Causes problems on a few systems. sub MY::makefile { '' } Math-MPFR-4.38/MANIFEST0000755060175106010010000000414214765756127013041 0ustar OwnerNoneMANIFEST Makefile.PL MPFR.pm MPFR.pod grisu3.c grisu3.h math_mpfr_include.h math_mpfr_unused.h MPFR.xs README CHANGES checklib.in have_d64.in have_d128.in have_float16.in have_f128.in try_dec64.in try_dec128.in try_flt128.in Prec/Prec.xs Prec/Prec.pm Prec/Makefile.PL Random/Random.xs Random/Random.pm Random/Makefile.PL demos/doubledouble.p demos/euler.p V/V.xs V/V.pm V/Makefile.PL t/_1aaa_v.t t/_1basic.t t/_itsa.t t/_2exp.t t/_Float16.t t/anomaly.t t/anytoa.t t/atonum.t t/atonv.t t/base_conversion.t t/bessel.t t/buildopt.t t/bytes.t t/cmp_uj_sj.t t/compound.t t/constants.t t/cross_class_mpq.t t/D64_LD.t t/decimal64_conv.t t/decimal128_conv.t t/decimalize.t t/div_by_zero.t t/DoubleDouble.t t/DoubleDouble2.t t/doubletoa.t t/exceptions.t t/faithful_rounding.t t/flags.t t/float128_conv.t t/float128_subnormal.t t/get_IV.t t/get_NV.t t/grandom.t t/hex_fmt.t t/infnan_str.t t/integer_string.t t/inits.t t/lngamma_bug.t t/LongDouble.t t/mpfrtoa.t t/mpfrtoa_precisions.t t/MPFR_RND.t t/nan_cmp.t t/native_float128.t t/neg_zero_bug.t t/NOK_and_POK.t t/not_zero.t t/new.t t/new_in_4.0.0.t t/new_in_4.1.0.t t/new_pow_log_exp.t t/numtoa.t t/nvtoa.t t/nvtoa_dd.t t/nvtoa_subnormal.t t/nvtoa2.t t/nvtoa3.t t/NV_overloading.t t/out_str.t t/overload.t t/overload_cmp_q.t t/overload_cmp_z.t t/overload_cross_class.t t/overload_float128.t t/overload_math_gmp.t t/overload_mod.t t/overload_shift.t t/overload_switch.t t/overloadex.t t/P_specifier.t t/pod.t t/printf.t t/PV_NV_BUG.t t/q_arith.t t/random2.t t/random3.t t/remainder.t t/Rmpfr_asinu.t t/Rmpfr_fmod_ui.t t/Rmpfr_get_q.t t/Rmpfr_q_div_and_Rmpfr_z_div.t t/Rmpfr_rec_root.t t/Rmpfr_rootn_ui.t t/Rmpfr_sinu.t t/rndna.t t/rndna2.t t/ryu_checks.t t/set_IV.t t/set_NV.t t/set_str.t t/sign.t t/sizes.t t/snprintf.t t/sprintf.t t/subnormal_doubles.t t/sum.t t/test1.t t/test2.t t/test3.t t/test4.t t/tls.t t/tls_flags.t t/trig.t t/trigamma.t t/TRmpfr_out_str.t t/underflow.t t/use64bitint.t t/uselongdouble.t t/view_config.t typemap META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Math-MPFR-4.38/math_mpfr_include.h0000755060175106010010000004641314765756127015550 0ustar OwnerNone/************************************************* Documentation of symbols defined by Math::MPFR MPFR_WANT_FLOAT128 : Defined by Makefile.PL if $have_float128 is set to a true value. $have_float128 can be set to a true value by either editing the Makefile.PL appropriately or by specifying F128=1 in the Makefile.PL's @ARGV. The quadmath.h header is included if this symbol is defined. NOTE: If MPFR_WANT_FLOAT128 is defined, it is assumed that the mpfr library was built with __float128 support - ie was configured with the '--enable-float128' option. MPFR_WANT_FLOAT128 must NOT be defined if the mpfr library has NOT been built with __float128 support. MPFR_WANT_FLOAT128 does not imply that nvtype is __float128 - perhaps we have defined MPFR_WANT_FLOAT128 solely because we wish to make use of the Math::Float128-Math::MPFR interface. CAN_PASS_FLOAT128 : Defined only when both MPFR_WANT_FLOAT128 and USE_QUADMATH is defined, and then only if the mpfr library is at version 4.0.0 or later. (There was no __float128 support in the mpfr library prior to 4.0.0.) DANGER: The assumption is that if MPFR_WANT_FLOAT128 is defined then the mpfr library has been built with __float128 support, which may not be the case. Hopefully the configure probing done by the Makefile.PL will get it right. MPFR_WANT_DECIMAL_FLOATS : The symbol needs to be defined (before mpfr.h is included) in order to enable _Decimal64 and/or _Decimal128 support. Hence we define it in the Makefile.PL by setting $have_decimal64 or setting $have_decimal128 to a true value. $have_decimal64 can be forcibly set to a true value by specifying D64=1 in the Makefile.PL's @ARGV. And $have_decimal128 can likewise be set to a true value by specifying D128=1 in the Makefile.PL's @ARGV. $have_decimal64 must not be set to a true value if the mpfr library has not been built with _Decimal64 support. And $have_decimal128 must not be set to a true value if the mpfr library has not been built with _Decimal128 support. We define the symbol solely to enable a Math::MPFR interface with Math::Decimal64 and/or Math::Decimal128. Otherwise there's no point (apparent to me) in defining it. MPFR_WANT_DECIMAL64 : Defined by the Makefile.PL only if support for the _Decimal64 type in the mpfr library is detected. Can be forcibly defined by specifying D64=1 in the Makefile.PL's @ARGV. Can be forcibly not defined by specifying D64=0 in the Makefile.PL's @ARGV. We define the symbol solely to enable a Math::Decimal64-Math::MPFR interface. MPFR_WANT_DECIMAL128 : Defined by the Makefile.PL only if support for the _Decimal128 type in the mpfr library is detected. Can be forcibly defined by specifying D128=1 in the Makefile.PL's @ARGV. Can be forcibly not defined by specifying D128=0 in the Makefile.PL's @ARGV. We define the symbol solely to enable a Math::Decimal128-Math::MPFR interface. HAVE_IEEE_754_LONG_DOUBLE :Used only by the test suite. Defined by Makefile.PL if ($Config{longdblkind} == 1 || $Config{longdblkind} == 2) This implies that long double is the quad (128-bit) long double. HAVE_EXTENDED_PRECISION_LONG_DOUBLE : Used only by the test suite. Defined by Makefile.PL if ($Config{longdblkind} == 3 || $Config{longdblkind} == 4) This implies that nvtype is the extended precision (80-bit) long double. REQUIRED_LDBL_MANT_DIG : Defined to float.h's LDBL_MANT_DIG unless LDBL_MANT_DIG is 106 (ie long double is double-double) - in which case it is defined to be 2098. This is needed to ensure that the mpfr value is an accurate rendition of the double-double value. CHECK_ROUNDING_VALUE : Macro that checks (on pre-4.0.0 mpfr versions only) that the rounding value provided is in the allowable range of 0-4 inclusive. (On 2.x.x versions the allowable range is only 0-3, but we don't support those versions anyway.) FAILS_CHECK_INPUT_BASE : Macro that checks that the base (where specified) is in the accepted range. FAILS_CHECK_OUTPUT_BASE : Macro that checks that the base (where specified) is in the accepted range. DEAL_WITH_NANFLAG_BUG : Macro that corrects certain failures (in mpfr versions prior to 3.1.4) to set the NaN flag. DEAL_WITH_NANFLAG_BUG_OVERLOADED : Another macro that corrects the same bug as DEAL_WITH_NANFLAG_BUG - but recoded for the overloaded operations affected by the bug. MATH_MPFR_NEED_LONG_LONG_INT : Defined by Makefile.PL if $Config{ivsize} >= 8 && $Config{ivtype} is not 'long' && $use_64_bit_int (in the Makefile.PL) has not been set to -1. This symbol will also be defined if $use_64_bit_int is set to 1. The setting of this symbol is taken to imply that the mpfr _uj/_sj functions are needed for converting mpfr integer values to perl integers. Conversely, if the symbol is not defined, then the implication is that the _uj/sj functions are not needed (because the _ui/_si functions, which are alway available) provide the same functionality) - and therefore those _uj/_sj functions are then not made available. IVSIZE_BITS : Defined only if MATH_MPFR_NEED_LONG_LONG_INT is defined - whereupon it will be set to the bitsize of the IV (perl's integer type). Currently, I think this symbol will only ever be either undefined or set to 64 - and I suspect that it could (currently) be replaced with a hard coded 64 wherever it occurs in the code. NVSIZE_BITS : Defined to the maximum number of bits effectively representable by the NV. This will be either 53, 64, 113 or 2098 - depending on perl's NV type. _WIN32_BIZARRE_INFNAN : Defined (on Windows only) when the perl version (as expressed by $]) is less than 5.022. These earlier perl versions had bizarre strings representing NaNs (eg 1.#IND) and Infs (eg 1.#INF) on Win32. LD_SUBNORMAL_BUG : Defined for mpfr-3.1.4 and earlier if and only if LDBL_MANT_DIG == 64 (The bug is in mpfr_get_ld) FALLBACK_NOTIFY : If defined, $Math::MPFR::doubletoa_fallback (initially set to 0) will be incremented by 1 on those rare occasions where grisu3 fails and falls back to the fallback routine. For more details, see the doubletoa documentation. *************************************************/ #include #include /* * In mpfr-4.1.0, the _Float128 type is exposed in mpfr.h if MPFR_WANT_FLOAT128 is defined. * We fall back to defining it to __float128 if the _Float128 type is unknown. */ #if defined(MPFR_WANT_FLOAT128) && defined(__GNUC__) && !defined(__FLT128_MAX__) && !defined(_BITS_FLOATN_H) #define _Float128 __float128 #endif #include #include #include #if MPFR_VERSION_MAJOR < 3 #define mpfr_exp_t mp_exp_t #endif #if defined(MPFR_WANT_FLOAT128) || defined(USE_QUADMATH) #include #if defined(USE_QUADMATH) && defined(MPFR_WANT_FLOAT128) && defined(MPFR_VERSION) && MPFR_VERSION >= MPFR_VERSION_NUM(4,0,0) #define CAN_PASS_FLOAT128 #endif #if defined(__MINGW32__) && !defined(__MINGW64__) typedef __float128 float128 __attribute__ ((aligned(32))); #elif defined(__MINGW64__) || (defined(DEBUGGING) && NVSIZE == 8) typedef __float128 float128 __attribute__ ((aligned(8))); #else typedef __float128 float128; #endif #endif #if defined(MPFR_WANT_DECIMAL128) #if defined(__MINGW64__) || (defined(DEBUGGING) && NVSIZE == 8) typedef _Decimal128 D128 __attribute__ ((aligned(8))); #else typedef _Decimal128 D128; #endif #endif #define SIS_PERL_VERSION PERL_REVISION*1000000+PERL_VERSION*1000+PERL_SUBVERSION #if SIS_PERL_VERSION >= 5012000 /* perl-5.12.0 and later */ # define MORTALIZED_PV(x) newSVpvn_flags(x,strlen(x),SVs_TEMP) #else # define MORTALIZED_PV(x) sv_2mortal(newSVpv(x,0)) #endif /* Facilitate altering the numeric flags that we * * look at (in case it becomes necessary) */ #define SV_IS_IOK(x) \ SvIOK(x) #define SV_IS_POK(x) \ SvPOK(x) #define SV_IS_NOK(x) \ SvNOK(x) #if (!defined(MPFR_VERSION) || MPFR_VERSION <= 196868) && LDBL_MANT_DIG == 64 #define LD_SUBNORMAL_BUG 1 #endif #if LDBL_MANT_DIG == 106 #define REQUIRED_LDBL_MANT_DIG 2098 #else #define REQUIRED_LDBL_MANT_DIG LDBL_MANT_DIG #endif #define FAILS_CHECK_INPUT_BASE \ !SV_IS_IOK(base) || SvIVX(base) < 0 || SvIVX(base) > 62 || SvIVX(base) == 1 #if MPFR_VERSION >= 262400 /* Allowable range of base has been expanded */ #define FAILS_CHECK_OUTPUT_BASE \ !(SV_IS_IOK(base) && ((SvIVX(base) >= 2 && SvIVX(base) <= 62) || (SvIVX(base) >= -36 && SvIVX(base) <= -2))) #else #define FAILS_CHECK_OUTPUT_BASE \ !(SV_IS_IOK(base) && SvIVX(base) >= 2 && SvIVX(base) <= 62) #endif /* Don't use CHECK_ROUNDING_VALUE macro with Rmpfr_set_NV * * (as this function's "round" arg is "unsigned int", not SV*) */ #if MPFR_VERSION_MAJOR < 4 #define CHECK_ROUNDING_VALUE \ if((mp_rnd_t)SvUV(round) > 4) \ croak("Illegal rounding value supplied for this version (%s) of the mpfr library", MPFR_VERSION_STRING); #else #define CHECK_ROUNDING_VALUE #endif #define NOK_POK_DUALVAR_CHECK \ if(SV_IS_NOK(b)) { \ nok_pok++; \ if(SvIV(get_sv("Math::MPFR::NOK_POK", 0))) \ warn("Scalar passed to %s is both NV and PV. Using PV (string) value" /* Don't use NON_NUMERIC_CHAR_CHECK macro with Rmpfr_inp_str as this * * function requires a different condition (!ret vs ret). */ #define NON_NUMERIC_CHAR_CHECK(inputstr) \ if(ret) { \ nnum++; \ if(SvIV(get_sv("Math::MPFR::NNW", 0))) \ warn("string used (%s) in %s contains non-numeric characters", SvPV_nolen(inputstr) #define BITSEARCH_4 \ if(tmp & 8) { \ subnormal_prec_adjustment += 1; \ break; \ } \ if(tmp & 4) { \ subnormal_prec_adjustment += 2; \ break; \ } \ if(tmp & 2) { \ subnormal_prec_adjustment += 3; \ break; \ } \ subnormal_prec_adjustment += 4; #define BITSEARCH_8 \ if(tmp & 128) { \ subnormal_prec_adjustment += 1; \ break; \ } \ if(tmp & 64) { \ subnormal_prec_adjustment += 2; \ break; \ } \ if(tmp & 32) { \ subnormal_prec_adjustment += 3; \ break; \ } \ if(tmp & 16) { \ subnormal_prec_adjustment += 4; \ break; \ } \ if(tmp & 8) { \ subnormal_prec_adjustment += 5; \ break; \ } \ if(tmp & 4) { \ subnormal_prec_adjustment += 6; \ break; \ } \ if(tmp & 2) { \ subnormal_prec_adjustment += 7; \ break; \ } \ subnormal_prec_adjustment += 8; #define NEG_ZERO_BUG 196866 /* A bug affecting mpfr_fits_u*_p functions */ /* Fixed in mpfr after MPFR_VERSION 196866 (3.1.2) */ /* For earlier versions of mpfr, we fix this bug in */ /* our own code */ #define LNGAMMA_BUG 196867 /* lngamma(-0) set to NaN instead of +Inf */ /* Fixed in mpfr after MPFR_VERSION 196867 (3.1.3) */ /* For earlier versions of mpfr, we fix this bug in */ /* our own code */ #define NANFLAG_BUG 196868 /* A bug affecting setting of the NaN flag */ /* Fixed in mpfr after MPFR_VERSION 196868 (3.1.4) */ /* For earlier versions of mpfr, we fix this bug in */ /* our own code */ #define DD_INF_BUG 196869 /* mpfr_get_ld on (double-double platforms only) */ /* might return NaN when it sould return Inf. */ /* Presumably, this will be */ /* fixed in mpfr after MPFR_VERSION 196869 (3.1.5) */ /* For earlier versions of mpfr, we fix this bug in */ /* our own code */ #if !defined(MPFR_VERSION) || (defined(MPFR_VERSION) && MPFR_VERSION <= NANFLAG_BUG) #define DEAL_WITH_NANFLAG_BUG if(mpfr_nan_p(*b))mpfr_set_nanflag(); #define DEAL_WITH_NANFLAG_BUG_OVERLOADED if(mpfr_nan_p(*(INT2PTR(mpfr_t *,SvIVX(SvRV(a))))))mpfr_set_nanflag(); #else #define DEAL_WITH_NANFLAG_BUG #define DEAL_WITH_NANFLAG_BUG_OVERLOADED #endif /* #ifdef _MSC_VER #pragma warning(disable:4700 4715 4716) #endif */ #ifdef OLDPERL #define SvUOK SvIsUV #endif #ifndef Newx # define Newx(v,n,t) New(0,v,n,t) #endif #ifndef Newxz # define Newxz(v,n,t) Newz(0,v,n,t) #endif /* A perl bug in perl-5.20 onwards can break &PL_sv_yes and * * &PL_sv_no. In the overload subs we therefore instead * * use SvTRUE_nomg_NN where possible, which is available * * beginning with perl-5.18.0. * * Otherwise we continue using &PL_sv_yes as original * * (&PL_sv_no is not used by this module.) * * See See https://github.com/sisyphus/math-decimal64/pull/1 */ #if defined SvTRUE_nomg_NN #define SWITCH_ARGS SvTRUE_nomg_NN(third) #define NO_SWITCH_ARGS !SvTRUE_nomg_NN(third) #else #define SWITCH_ARGS third==&PL_sv_yes #define NO_SWITCH_ARGS third!=&PL_sv_yes #endif /* May one day be removed from mpfr.h */ #ifndef mp_rnd_t # define mp_rnd_t mpfr_rnd_t #endif #ifndef mp_prec_t # define mp_prec_t mpfr_prec_t #endif #ifndef __gmpfr_default_rounding_mode #define __gmpfr_default_rounding_mode mpfr_get_default_rounding_mode() #endif #if !defined(__GNU_MP_VERSION) || __GNU_MP_VERSION < 5 #define mp_bitcnt_t unsigned long int #endif /* For nvtoa() */ #if defined(MPFR_HAVE_BENDIAN) /* big endian architecture - defined by Makefile.PL */ #define INC_OR_DEC(p) p++ #else /* little endian */ #define INC_OR_DEC(p) p-- #endif #if NVSIZE == 8 #define MATH_MPFR_MAX_DIG 17 #define NVSIZE_BITS 53 #define MATH_MPFR_NV_MAX 0x1.fffffffffffffp+1023 /* 32-bit Windows has a problem with evaluating the * * decimal form of this value if -std=c99 is specified */ #define MATH_MPFR_NORMAL_MIN 0x1p-1022 # if defined(MPFR_HAVE_BENDIAN) /* big endian architecture - defined by Makefile.PL */ # define D_CONDITION_1(p) p<=7 # define DIND_0 0 # define DIND_1 1 # define DIND_2 2 # else /* little endian architecture */ # define D_CONDITION_1(p) p>=0 # define DIND_0 7 # define DIND_1 6 # define DIND_2 5 # endif #elif defined(USE_LONG_DOUBLE) && REQUIRED_LDBL_MANT_DIG == 64 #define MATH_MPFR_MAX_DIG 21 #define NVSIZE_BITS 64 #define MATH_MPFR_NV_MAX 0xf.fffffffffffffffp+16380L #define MATH_MPFR_NORMAL_MIN 0x8p-16385L # if defined(MPFR_HAVE_BENDIAN) /* big endian architecture - defined by Makefile.PL */ # define LD_CONDITION_1(p) p<=9 # define LDIND_0 0 # define LDIND_1 1 # define LDIND_2 2 # else /* little endian architecture */ # define LD_CONDITION_1(p) p>=0 # define LDIND_0 9 # define LDIND_1 8 # define LDIND_2 7 # endif #elif defined(USE_LONG_DOUBLE) && REQUIRED_LDBL_MANT_DIG == 2098 #define MATH_MPFR_MAX_DIG 33 #define NVSIZE_BITS 2098 #define MATH_MPFR_NV_MAX 1.797693134862315807937289714053e+308L #define MATH_MPFR_NORMAL_MIN 2.2250738585072014e-308 #else #define MATH_MPFR_MAX_DIG 36 #define NVSIZE_BITS 113 #define MATH_MPFR_NV_MAX 0x1.ffffffffffffffffffffffffffffp+16383Q #define MATH_MPFR_NORMAL_MIN 0x1p-16382Q /* == 0x8p-16385 */ # if defined(MPFR_HAVE_BENDIAN) /* big endian architecture - defined by Makefile.PL */ # define Q_CONDITION_1(p) p<=15 # define QIND_0 0 # define QIND_1 1 # define QIND_2 2 # else /* little endian architecture */ # define Q_CONDITION_1(p) p>=0 # define QIND_0 15 # define QIND_1 14 # define QIND_2 13 # endif #endif /* End of defines for nvtoa() */ #define NEW_MATH_MPFR_OBJECT(PACNAME,FUNCNAME) \ Newx(mpfr_t_obj, 1, mpfr_t); \ if(mpfr_t_obj == NULL) croak("Failed to allocate memory in FUNCNAME function"); \ obj_ref = newSV(0); \ obj = newSVrv(obj_ref, PACNAME); #define OBJ_READONLY_ON \ sv_setiv(obj, INT2PTR(IV,mpfr_t_obj)); \ SvREADONLY_on(obj); #define RETURN_STACK_2 \ ST(0) = sv_2mortal(obj_ref); \ ST(1) = sv_2mortal(newSViv(ret)); \ XSRETURN(2); Math-MPFR-4.38/math_mpfr_unused.h0000755060175106010010000000152414765756127015422 0ustar OwnerNone #ifndef MATH_MPFR_UNUSED_H #define MATH_MPFR_UNUSED_H 1 #define PERL_UNUSED_ARG2(a,b) PERL_UNUSED_ARG(a);PERL_UNUSED_ARG(b); #define PERL_UNUSED_ARG3(a,b,c) PERL_UNUSED_ARG(a);PERL_UNUSED_ARG(b);\ PERL_UNUSED_ARG(c); #define PERL_UNUSED_ARG4(a,b,c,d) PERL_UNUSED_ARG(a);PERL_UNUSED_ARG(b);\ PERL_UNUSED_ARG(c);PERL_UNUSED_ARG(d); #define PERL_UNUSED_ARG5(a,b,c,d,e) PERL_UNUSED_ARG(a);PERL_UNUSED_ARG(b);\ PERL_UNUSED_ARG(c);PERL_UNUSED_ARG(d);\ PERL_UNUSED_ARG(e); #define PERL_UNUSED_ARG6(a,b,c,d,e,f) PERL_UNUSED_ARG(a);PERL_UNUSED_ARG(b);\ PERL_UNUSED_ARG(c);PERL_UNUSED_ARG(d);\ PERL_UNUSED_ARG(e);PERL_UNUSED_ARG(f); #endif Math-MPFR-4.38/META.json0000664060175106010010000000221414766136504013316 0ustar OwnerNone{ "abstract" : "Perl interface to the MPFR (floating point) library", "author" : [ "Sisyphus (sisyphus at (@) cpan dot (.) org)" ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.70, CPAN::Meta::Converter version 2.150010", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Math-MPFR", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Test::More" : "0.88" } } }, "release_status" : "stable", "resources" : { "repository" : { "type" : "git", "url" : "https://github.com/sisyphus/math-mpfr.git", "web" : "https://github.com/sisyphus/math-mpfr" } }, "version" : "4.38", "x_serialization_backend" : "JSON::PP version 4.16" } Math-MPFR-4.38/META.yml0000664060175106010010000000122114766136502013141 0ustar OwnerNone--- abstract: 'Perl interface to the MPFR (floating point) library' author: - 'Sisyphus (sisyphus at (@) cpan dot (.) org)' build_requires: ExtUtils::MakeMaker: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.70, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Math-MPFR no_index: directory: - t - inc requires: Test::More: '0.88' resources: repository: https://github.com/sisyphus/math-mpfr.git version: '4.38' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Math-MPFR-4.38/MPFR.pm0000755060175106010010000016465114765756127013026 0ustar OwnerNone package Math::MPFR; use strict; use warnings; use POSIX; use Config; use Math::MPFR::Prec; use Math::MPFR::Random; # Needs to be loaded before Math::MPFR as # it contains relevant configuration info. use constant GMP_RNDN => 0; use constant GMP_RNDZ => 1; use constant GMP_RNDU => 2; use constant GMP_RNDD => 3; use constant MPFR_RNDN => 0; use constant MPFR_RNDZ => 1; use constant MPFR_RNDU => 2; use constant MPFR_RNDD => 3; use constant MPFR_RNDA => 4; use constant MPFR_RNDF => 5; use constant _UOK_T => 1; use constant _IOK_T => 2; use constant _NOK_T => 3; use constant _POK_T => 4; use constant _MATH_MPFR_T => 5; use constant _MATH_GMPf_T => 6; use constant _MATH_GMPq_T => 7; use constant _MATH_GMPz_T => 8; use constant _MATH_GMP_T => 9; use constant _MATH_MPC_T => 10; use constant MPFR_FLAGS_UNDERFLOW => 1; use constant MPFR_FLAGS_OVERFLOW => 2; use constant MPFR_FLAGS_NAN => 4; use constant MPFR_FLAGS_INEXACT => 8; use constant MPFR_FLAGS_ERANGE => 16; use constant MPFR_FLAGS_DIVBY0 => 32; use constant MPFR_FLAGS_ALL => 63; 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(); # https://github.com/StrawberryPerl/Perl-Dist-Strawberry/issues/226 # Math::MPFR::Random::_buggy() was modified in version 4.34 to # accommodate use of vcpkg-built gmp & mpfr libraries on MS Windows. use constant WIN32_FMT_BUG => Math::MPFR::Random::_buggy(); use constant NV_IS_DOUBLEDOUBLE => 1 + (2 ** -200) > 1 ? 1 : 0; # Inspired by https://github.com/Perl/perl5/issues/19550, which affects only perl-5.35.10: 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 ); use overload '++' => \&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; require Exporter; *import = \&Exporter::import; require DynaLoader; 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_fmod_fr q_mul_fr q_sub_fr rndna ); @Math::MPFR::EXPORT_OK = (@tags, 'bytes'); our $VERSION = '4.38'; #$VERSION = eval $VERSION; Math::MPFR->DynaLoader::bootstrap($VERSION); # The ':mpfr' tag (below) is the same as @EXPORT_OK, # except that the ':mpfr' tag does not include 'bytes'. %Math::MPFR::EXPORT_TAGS =(mpfr => [@tags]); $Math::MPFR::NNW = 0; # Set to 1 to allow "non-numeric" warnings for operations involving # strings that contain non-numeric characters. $Math::MPFR::NOK_POK = 0; # Set to 1 to allow warnings in new() and overloaded operations when # a scalar that has set both NOK (NV) and POK (PV) flags is encountered $Math::MPFR::doubletoa_fallback = 0; # If FALLBACK_NOTIFY is defined, this scalar Will be automatically # incremented whenever the grisu3 algorithm (used by doubletoa) fails # to produce correct result, and thus falls back to its designated # fallback routine. (See the doubletoa documentation for details.) $Math::MPFR::PERL_INFNAN = 0; my $pinf = 1e5000; # +infinity my $ninf = -$pinf; # -infinity my $nanv = $pinf/$pinf; # not a number $Math::MPFR::pinfstr = "$pinf"; # perl's string representation of +infinity $Math::MPFR::ninfstr = "$ninf"; # perl's string representation of -infinity $Math::MPFR::nanvstr = "$nanv"; # perl's string representation of a nan %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} # Prevent DynaLoader from complaining and croaking 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 { # This function caters for 2 possibilities: # 1) that 'new' has been called OOP style - in which # case there will be a maximum of 3 args # 2) that 'new' has been called as a function - in # which case there will be a maximum of 2 args. # If there are no args, then we just want to return an # initialized Math::MPFR object if(!@_) {return Rmpfr_init()} if(@_ > 3) {die "Too many arguments supplied to new()"} # If 'new' has been called OOP style, the first arg is the string # "Math::MPFR" which we don't need - so let's remove it. However, # if the first arg is a Math::MPFR object (which is a possibility), # then we'll get a fatal error when we check it for equivalence to # the string "Math::MPFR". So we first need to check that it's not # an object - which we'll do by using the ref() function: if(!ref($_[0]) && $_[0] eq "Math::MPFR") { shift; if(!@_) {return Rmpfr_init()} } # @_ can now contain a maximum of 2 args - the value, and if the value is # a string, (optionally) the base of the numeric string. if(@_ > 2) {die "Too many arguments supplied to new() - expected no more than two"} my ($arg1, $type, $base); # $_[0] is the value, $_[1] (if supplied) is the base of the number # in the string $[_0]. $arg1 = shift; # At this point, an infnan might acquire a POK flag - thus # assigning to $type a value of 4, instead of 3. Such behaviour also # turns $arg into a PV and NV dualvar. It's a fairly inconsequential # bug - https://github.com/Perl/perl5/issues/19550. # I could workaround this by simply not shifting and re-assigning, but # I'll leave it as it is - otherwise there's nothing to mark that this # minor issue (which might also show up in user code) ever existed. $base = 0; $type = _itsa($arg1); if(!$type) {die "Inappropriate argument supplied to new()"} my @ret; # Create a Math::MPFR object that has $arg1 as its value. # Die if there are any additional args (unless $type == 4) 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(@_)} # $_[1] is rounding argument (IOK). 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) { # IV $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; } # Alternatively, this should work, but it crashes intermittently # if(!_hex_fmt_ok($_[1], $_[2])) { # $len = _gmp_sprintf_nv(@_); # return $len; # } $len = wrap_mpfr_sprintf(@_); return $len; } sub Rmpfr_snprintf { my $len; if(@_ == 6){ if(_itsa($_[3]) == 2) { # IV $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; # buggy perls can numify infnan strings to 0. my $copy = $_[0]; # Don't mess with $_[0] flags my $ret = "$copy" + 0; return $ret if _itsa($ret) < 3; # IV return atonv($_[0]); # NV } 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) ) { # $op is either zero, inf, or nan. 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; # base of original representation my $op = shift; # precision (no. of base $ob digits in mantissa) of original representation my $nb = shift; # base of new representation my $np; # min required precision (no. of base $nb digits in mantissa) of new representation 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; # base of original representation my $nb = shift; # base of new representation my $np = shift; # precision (no. of base $nb digits in mantissa) of new representation my $op; # max precision (no. of base $ob digits in mantissa) of original representation 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 { # This function currently doesn't get called if $_[0] == $_[1] # Return true if: # 1) Both $_[0] and $_[1] are in the range 2..64 (inclusive) # && # 2) Both $_[0] and $_[1] are powers of the same integer - eg 8 & 32, or 9 & 27, or 7 & 49, .... # Else return false. 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); # $itsa == 4 implies that $val's POK flag is set && IOK flag is unset. # $itsa == 5 implies that $val is a Math::MPFR::object. # We now croak if neither of those cases is satisfied. 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); # need a temp object 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) { # not a midpoint value 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); # need a temp object 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) { # not a midpoint value 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(); # Save original value my $emin = Rmpfr_get_emin(); # Save original value 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]); # DoubleDouble if($bits == 2098) { Rmpfr_strtofr($f_init, "$v", 0, MPFR_RNDN); if(!Rmpfr_regular_p($f_init)) { Rmpfr_set_emax($emax); # Revert to original value Rmpfr_set_emin($emin); # Revert to original value return mpfrtoa($f_init); } # Obtain the pair of doubles pertinent to $f_init. # $msd is the "more siginificant double" and $lsd # is the "less significant double". 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); # Revert to original value Rmpfr_set_emin($emin); # Revert to original value return anytoa($f); } # Determine the no. of implied (intermediate) # bits that lie between the end of $msd and # and the start of $lsd 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); # Revert to original value Rmpfr_set_emin($emin); # Revert to original value return mpfrtoa($f_final); } # End DoubleDouble # The next 4 lines cater for the possibility that # the value is either subnormal or infinite or # zero for the floating point type specified by # the value of $bits. 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]) { # The value is subnormal, and therefore requires further treatment. 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./) { # The value is -ve. Rmpfr_strtofr($f_final, "${significand}p$exponent", 2, MPFR_RNDN); } else { # The value is positive Rmpfr_strtofr($f_final, "0.${significand}p$exponent", 2, MPFR_RNDN); } Rmpfr_set_emax($emax); # Revert to original value Rmpfr_set_emin($emin); # Revert to original value return mpfrtoa($f_final); } Rmpfr_set_emax($emax); # Revert to original value Rmpfr_set_emin($emin); # Revert to original value return mpfrtoa($f_init); } ########################### ########################### sub nvtoa_test { # 1st arg must be a string (POK); # 2nd arg must be either an NV (NOK) or a Math::MPFR object 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")); } # Check that signs match: 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); # deal only with the +ve form # for simplicity. # Handle inf, nan and zero - test that both $n and $check # are the same. No further testing required. 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; # round trip successful 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" } } # Increment $ret by 8 if and only if there are no errant trailing # zeroes in $r[0] . if(!defined($r[1])) { $ret += 8 if ($r[0] =~ /\.0$/ || $r[0] !~ /0$/); $r[1] = 0; # define $r[1] by setting it to zero. } else { $ret += 8 unless $r[0] =~ /0$/; } # We remove from $s any trailing mantissa zeroes, and then # replace the least significant digit with zero. # IOW, we effectively chop off the least siginificant digit, thereby # rounding it down to the next lowest decimal precision.) # This altered string should assign to a value less than $n. 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; # chop test and increment test inapplicable. 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; # chop test ok. } else { Rmpfr_set_str($check, $chopped, 10, MPFR_RNDN); $ret += 2 if $check < $n; # chop test ok. } # Now we derive a value that is $s rounded up to the next lowest # decimal representation. # This new string should assign to a value that is greater # than the given $n. if($r[0] =~ /\./) { # We must remove the '.', do the string increment, # and then reinsert the '.' in the appropriate place. 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; # increment test ok. } else { Rmpfr_set_str($check, $incremented, 10, MPFR_RNDN); $ret += 4 if $check > $n; # chop test ok. } return $ret; } ############################# ############################# ############################# ############################# sub dragon_test { # 1st arg must be either an NV (NOK) or an IV(IOK) or a Math::MPFR object # If there's a 2nd arg (optional) and it matches /debug/i, then $debug # is set to 1, and some debug info is output during the running of the 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) { # $_[0] needs to be IV/UV/NV 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]); } # Check that signs match: 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); } # Deal only with the +ve form for simplicity. if($is_nv) { $op = abs($_[0]); # Can change $_[0] from NV to IV # but that doesn't matter. $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; # Handle inf, nan and zero - test that both $n and $check # are the same. No further testing required. 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; # round trip successful 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" } } # Increment $ret by 8 if and only if there are no errant trailing # zeroes in $r[0] . if(!defined($r[1])) { $ret += 8 if ($r[0] =~ /\.0$/ || $r[0] !~ /0$/); $r[1] = 0; # define $r[1] by setting it to zero. } else { $ret += 8 unless $r[0] =~ /0$/; } # We remove from $repro any trailing mantissa zeroes, and then # replace the least significant digit with zero. # IOW, we effectively chop off the least siginificant digit, thereby # rounding it down to the next lowest decimal precision.) # This altered string should assign to a value less than $op. 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; # chop test and increment test inapplicable. 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; # chop test ok. } else { Rmpfr_set_str($reco, $chopped, 10, MPFR_RNDN); $ret += 2 if $reco < $op; # chop test ok. } # Now we derive a value that is $chopped rounded up to the next lowest # decimal representation. # This new string should assign to a value that is greater # than the given $op. if($r[0] =~ /\./) { # We must remove the '.', do the string increment, # and then reinsert the '.' in the appropriate place. 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; # increment test ok. } else { Rmpfr_set_str($reco, $incremented, 10, MPFR_RNDN); $ret += 4 if $reco > $op; # increment test ok. } return $ret; } ############################# ############################# sub _mpfr2dd { # Can be called from anytoa() my $obj = shift; my $msd = Rmpfr_get_d($obj, MPFR_RNDN); $obj -= $msd; return ($msd, Rmpfr_get_d($obj, MPFR_RNDN)); } sub _intermediate_bits { # Can be called from anytoa() my($exp1, $exp2) = (_get_exp(shift), _get_exp(shift)); return $exp1 - 53 - $exp2; } sub _get_exp { # Can be called from anytoa(), via _intermediate_bits(). # For as long as we support perl-5.8, we cannot use # the "d<" and "d>" templates. 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; # Remove sign bit $exp++ unless $exp; # increment if 0 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 { # Special handling required for DoubleDouble # Unable to get the _nvtoa XSub to work flawlessly with DoubleDoubles, # I've switched to using the _mpfrtoa XSub, as I did with Math::FakeDD # It's an emabrrassingly awful hack, but will have to do until something # better comes along. if(NV_IS_DOUBLEDOUBLE) { my $nv = shift; my $unpacked = unpack "H*", pack "D>", $nv; my $msd = unpack "d>", pack "H*", substr($unpacked, 0, 16); # more significant double my $lsd = unpack "d>", pack "H*", substr($unpacked, 16, 16); # less significant double 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); # Must be Inf return "-Inf" if $neg; return "Inf"; } # set $mpfr to abs($mpfr) # $nv remains unaltered 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 ) { # 4.0.1 or earlier # Prior to mpfr-4.0.2, there are issues with precision < 2, # but DBL_DENORM_MIN calls for a precision of one bit. # We therefore return the hard coded value for this case. if($exp == -1073) { # $mpfr is 2 ** -1074 my $ret = $neg ? '-5e-324' : '5e-324'; return $ret; } } $prec = $addon + $exp; Rmpfr_prec_round($mpfr, $prec, MPFR_RNDN); # Provide 2nd arg of 728 to mpfrtoa(). # 2 ** -348 (prec = 727) needs this. return '-' . mpfrtoa($mpfr, 728) if $neg; return mpfrtoa($mpfr, 728); } # close $lsd == 0 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) { # lsd is not subnormal. $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; # one double < 0, the other > 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++; # Might need to be incremented again if the 2 doubles have different sign. } else { $prec = Rmpfr_get_exp($m_msd) + 1073; # $prec should be > 0 $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); # copy $mpfr to $mpfr_orig Rmpfr_prec_round($mpfr, $prec, MPFR_RNDN); if($different_signs) { my $candidate = mpfrtoa($mpfr, 53); # Might fail either the "chop" test or # the "round trip" test, but not both. if(abs($nv) != atonv($candidate)) { # First check whether decrementing the mantissa # allows the round trip to succeed. my $ret = _decrement($candidate); if(abs($nv) == atonv($ret)) { return '-' . $ret if $neg; return $ret; } # Fails round trip - so we increment $prec. We then # can't use $mpfr again as its precision has already # been altered, so we use $mpfr_orig. $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; } # The value we now return is the value calculated # for precision $prec, but with the least significant # mantissa digit removed. return '-' . $ret if $neg; return $ret; } # close different signs else { # We need to detect the (rare) case that a chopped and # then incremented mantissa passes the round trip. 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; } # close same signs } else { # Not a doubledouble - simply use the _nvtoa XSub return _nvtoa(shift); } } sub numtoa { # Special handling required for DoubleDouble 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; # If $do_increment is set, then all we are not interested # in the result of the chop test. We are interested in the # result of the incrmentation - which we requires that we # first perform the chop. my $do_increment = defined($_[0]) ? shift : 0; # We remove from $r[0] any trailing mantissa zeroes, and then # replace the least significant digit with zero. # IOW, we effectively chop off the least siginificant digit, thereby # rounding it down to the next lowest decimal precision.) # This altered string should assign to a DoubleDouble value that is # less than the given $op. 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; # chop test inapplicable. substr($r[0], -1, 1, ''); $r[1]++ unless $r[0] =~ /\./; $r[0] =~ s/\.$/.0/ unless $r[1]; $r[0] =~ s/\.$//; if(!$do_increment) { # We are interested only in the chop test my $chopped = $r[1] ? $r[0] . 'e' . $r[1] : $r[0]; return 'ok' if atonv($chopped) < abs($op); # chop test ok. return $chopped; } # We are not interested in the chop test - the "chop" was # done only as the first step in the incrementation, and # it's the result of the following incrementation that # interests us. Now we want, in effect, to do: # ++$r[0]; # This value should then assign to a DoubleDouble value # that is greater than the given $op. if($r[0] =~ /\./) { # We must remove the '.', do the string increment, # and then reinsert the '.' in the appropriate place. 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; # Remove all trailing zeroes from $r[0]; 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 { # Can Return a true value if and only if the constant # WIN32_FMT_BUG is set to a true value, in which case it # returns a rewritten format string. # We allow "%a"/"%A" formatting only if nvtype is 'double' and # we allow "%La"/"%LA" formatting only if nvtype is 'long double'. my $arg = shift; # First check for a match of (eg) "%La" or "%A" # at the beginning of $arg. 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 ''; } # Need to match (eg) "%La" or "%A", but also to NOT match (eg) "%%La" or "%%A". 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 ''; # Nothing to modify - no action necessary. } 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 { # Duplicated in Random/Random.pm # Return 1 if either __GMP_CC or __GMP_CFLAGS # include the string '-D__USE_MINGW_ANSI_STDIO'. # Else return 0. my $cc = _gmp_cc(); # __GMP_CC my $cflags = _gmp_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 { # Return 1 if no hex ("%a") formatting is requested. # Return 1 if the requested hex format ("%a"/"%A"/"%La"/"%LA") is appropriate. # If we haven't died or returned by now, then return 0 if WIN32_FMT_BUG is set; # otherwise return 1. # A return of 1 tells the caller (Rmpfr_*printf) that no other action is necessary. # A return of 0 tells the caller(Rmpfr_*printf) that it needs to call _rewrite_fmt_arg(). 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; # Tells the caller to call the relevant _gmp_*printf_nv() function return 1; } else {return 1} # No %a formatting requested. Proceed as normal. } 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; __END__ Math-MPFR-4.38/MPFR.pod0000755060175106010010000037460414765756127013175 0ustar OwnerNone=pod =head1 NAME Math::MPFR - perl interface to the MPFR (floating point) library. =head1 DEPENDENCIES This module needs the MPFR and GMP C libraries. (Install the GMP library first as it is a pre-requisite for MPFR.) The GMP library is available from https://gmplib.org . The MPFR library is available from https://www.mpfr.org . Documentation for current mpfr functions can be found at: www.mpfr.org/mpfr-current/mpfr.html#Function-and-Type-Index . =head1 DESCRIPTION A bigfloat module utilising the MPFR library. The main aim of this module is to wrap the floating point functions provided by that library. We also access many of those functions via operator overloading. (A small number of customised functions, not found in the MPFR library, are also available.) =head1 SYNOPSIS # This synopsis is very brief. My attempts at providing a # reasonable coverage in this section always result in # something that is ridiculously complex :-( use Math::MPFR qw(:mpfr); # Create a Math::MPFR object with an assigned value. The # returned object will have current default precision, and # the value will be rounded according to current dwfault # rounding mode. In this example, we provide a string as the # argument, but non-string arguments are also permitted. my $rop = Math::MPFR->new('1.2e-10'); # Other ways of assigning a string using new() to create an # equivalent Math::MPFR object include: # my $rop = Math::MPFR->new('1.2@-10'); # my $rop = Math::MPFR->new("1.2\@-10"); # Octal (base 8): # my $rop = Math::MPFR->new('1.0176077644330267e-11', 8); # my $rop = Math::MPFR->new('0x1.07e1fe91b0b7p-33'); # Specify base (16) if '0x' prefix is not provided: # my $rop = Math::MPFR->new('1.07e1fe91b0b7p-33', 16); # Display the value held by $rop. print $rop; # 1.2e-10 # Other ways of printing out the value include: # print mpfrtoa($rop); # 1.2e-10 # Rmpfr_printf("%Rg", $rop); # 1.2e-10 =head1 ROUNDING MODE As of mpfr-3.0.0, the rounding values are: MPFR_RNDN (numeric value = 0): Round to nearest. MPFR_RNDZ (numeric value = 1): Round towards zero. MPFR_RNDU (numeric value = 2): Round towards +infinity. MPFR_RNDD (numeric value = 3): Round towards -infinity. Previously they were named (respectively) GMP_RNDN, GMP_RNDZ, GMP_RNDU and GMP_RNDD. You can use either the "GMP_*" or the "MPFR_*" renditions, but the former is discouraged. Also available are: mpfr-3.0.0 and later: MPFR_RNDA (numeric value = 4): Round away from zero. mpfr-4.0.0 and later: MPFR_RNDF (numeric value = 5): Faithful rounding. These last two rounding modes will cause a fatal error if the mpfr library against which Math::MPFR has been built is not sufficiently recent. MPFR_RNDF is experimental - the computed value is either that corresponding to MPFR_RNDD or that corresponding to MPFR_RNDU. In particular when those values are identical, i.e., when the result of the corresponding operation is exactly representable, that exact result is returned. Thus, the computed result can take at most two possible values, and in absence of underflow/overflow, the corresponding error is strictly less than one ulp (unit in the last place) of that result and of the exact result. For MPFR_RNDF, the returned value and the inexact flag are unspecified, the divide-by-zero flag is as with other roundings, and the underflow and overflow flags match what would be obtained in the case the computed value is the same as with MPFR_RNDD or MPFR_RNDU. The results may not be reproducible, and it may not work with all functions. Please report bugs. MPFR_RNDN (the 'round to nearest' mode) works as in the IEEE P754 standard: in case the number to be rounded lies exactly in the middle of two representable numbers, it is rounded to the one with the least significant bit set to zero. For example, the number 5, which is represented by '101' in binary, is rounded to '10p1' (4) with a precision of two bits, and not to '11p1' (6). This rule avoids the "drift" phenomenon mentioned by Knuth in volume 2 of The Art of Computer Programming (section 4.2.2, pages 221-222). Most Math::MPFR functions take as first argument the destination variable, as second and following arguments the input variables, as last argument a rounding mode, and have a return value of type 'int'. If this value is zero, it usually means that the value stored in the destination variable is the exact result of the corresponding mathematical function. If the returned value is positive (resp. negative), it usually means the value stored in the destination variable is greater (resp. lower) than the exact result. For example with the 'GMP_RNDU' rounding mode, the returned value is usually positive, except when the result is exact, in which case it is zero. In the case of an infinite result, it is considered as inexact when it was obtained by overflow, and exact otherwise. A NaN result (Not-a-Number) always corresponds to an inexact return value. See also the Rmpfr_round_nearest_away() function in the ROUNDING MODE FUNCTIONS section for the mode "round to nearest, ties away from zero". =head1 MEMORY MANAGEMENT Objects are created with new() or with the Rmpfr_init* functions. All of these functions return an object that has been blessed into the package Math::MPFR. They will therefore be automatically cleaned up by the DESTROY() function whenever they go out of scope. For each Rmpfr_init* function there is a corresponding function called Rmpfr_init*_nobless which returns an unblessed object. If you create Math::MPFR objects using the '_nobless' versions, it will then be up to you to clean up the memory associated with these objects by calling Rmpfr_clear($op) for each object, or Rmpfr_clears($op1, $op2, ....). Alternatively such objects will be cleaned up when the script ends. Because these objects have not been blessed into the Math::MPFR package, the overloaded operators will not work with them. =head1 MIXING GMP OBJECTS WITH MPFR OBJECTS Some of the Math::MPFR functions below take as arguments one or more of the GMP types mpz (integer), mpq (rational) and mpf (floating point). (Such functions are marked as taking mpz/mpq/mpf arguments.) For these functions to work you need to have loaded either: 1) Math::GMP from CPAN. (This module provides access to mpz objects only - NOT mpf and mpq objects.) AND/OR 2) Math::GMPz (for mpz types), Math::GMPq (for mpq types) and Math::GMPf (for mpf types). =head1 PASSING __float128 VALUES There are 3 ways to pass __float128 values to/from Math::MPFR. Option 1) is the preferred option: 1) Build perl (5.21.4 or later) with -Dusequadmath; build the mpfr-4.0.0 (or later) library with the configure option --enable-float128. Then build Math::MPFR in the usual way. If the build process does not then result in a Math::MPFR module that supports the __float128 NV try providing the "F128=1" arg to the Makefile.PL (which will define the symbol MPFR_WANT_FLOAT128): perl Makefile.PL F128=1 (And please file a bug report, because the aim is that you should not need to specify F128=1 here.) Then you can pass your perl's __float128 NV values directly to/from Math::MPFR using: Rmpfr_set_float128() or Rmpfr_set_NV() and Rmpfr_get_float128() or Rmpfr_get_NV() This will also mean that overloaded operations that receive an NV will evaluate that (__float128) NV to its full precision. And assigning the NV as Math::MPFR->new($NV) will also work as intended. NOTE: If you have built perl with -Dusequadmath, but the mpfr library was not built with float128 support , then both Rmpfr_set_NV() and Rmpfr_get_NV() will still set/get __float128 values. Also, overloaded operations that receive an NV will still evaluate that (__float128) NV to its full precision. It's only Rmpfr_set_float128() and Rmpfr_get_float128() that will not be available. 2) On a perl that was not built with -Dusequadmath, install Math::Float128, build the mpfr-4.0.0 (or later) library with the configure option --enable-float128, and build Math::MPFR by providing the "F128=1" arg to the Makefile.pl: perl Makefile.PL F128=1 Then you can pass the values of the Math::Float128 objects to and from Math::MPFR objects using: Rmpfr_set_FLOAT128() and Rmpfr_get_FLOAT128() 3) Convert the __float128 values to a string and pass them to and from Math::MPFR using: Rmpfr_strtofr()/Rmpfr_set_str() and Rmpfr_get_str() =head1 PASSING _Decimal64 & _Decimal128 VALUES Install Math::Decimal64 and/or Math::Decimal128 and build the mpfr library (version 3.1.0 or later for _Decimal64, version 4.1.0 or later for _Decimal128) with the --enable-decimal-float option. The Math::MPFR build process should detect the _Decimal64/_Decimal128 availability and include or exclude the support accordingly. If the auto-detection fails to detect the availability, you can override it by providing the "D64=1" and/or "D128=1" arg to the the Makefile.PL (either of which will define MPFR_WANT_DECIMAL_FLOATS): perl Makefile.PL D64=1 D128=1 You can then pass _Decimal64/_Decimal128 values between Math::MPFR and Math::Decimal64/Math::Decimal128 using: Rmpfr_set_DECIMAL64() and Rmpfr_get_DECIMAL64() Rmpfr_set_DECIMAL128() and Rmpfr_get_DECIMAL128() NOTE: It is allowable to pass any or all of "D64=1", "D128=1" and "F128=1" args to the Makefile.PL. To force the removal of _Decimal64/Decimal128 support in Math::MPFR, simply provide "D64=0" and/or "D128=0" as arguments to the Makefile.PL: perl Makefile.PL D64=0 D128=0 =head1 FUNCTIONS The following functions are generally wrappers around an mpfr function of the same name. eg. Rmpfr_swap() is a wrapper around mpfr_swap(). "$rop", "$op1", "$op2", etc. are Math::MPFR objects. "$inex" is a signed integer value (IV) returned by many of the mpfr functions. $inex == 0 indicates that the function's result was exact; $inex < 0 indicates that the function's result was rounded to a value that is less than the exact result; $inex > 0 indicates that the function's result was rounded to a a value that is greater than the exact result. "$ui" means any integer that will fit into a C 'unsigned long int', "$si" means any integer that will fit into a C 'signed long int'. "$uj" means any integer that will fit into a C 'uintmax_t'. Don't use any of these functions unless your perl's UV is at least as big as a 'uintmax_t'. "$sj" means any integer that will fit into a C 'intmax_t'. Don't use any of these functions unless your perl's IV is at least as big as an 'intmax_t'. "$double" is a C double and "$float" is a C float ... but both will be represented in Perl as an NV. "$ld" means a long double. Don't use these functions if the precision of your Perl's NV is less than the precision of a 'long double'. "$f128" means a __float128. Don't use these functions unless your Perl's NV is a __float128 && mpfr has been configured with '--enable-float128'. (Note that versions of mpfr prior to 4.0.0 cannot be configured with '--enable-float128'.) "$bool" means a value (usually a 'signed long int') in which the only interest is whether it evaluates as false or true. "$str" simply means a string of symbols that represent a number, eg '1234567890987654321234567E7' or 'zsa34760sdfgq123r5@11'. Valid bases for MPFR numbers are 2 to 62. "$rnd" is simply one of the 5 rounding mode values (discussed above) that many of the functions require as their rounding arg. In my code, rather than providing them as a perl scalar, I usually write them in their bareword form - MPFR_RNDN or MPFR_RNDU or ..., etc. "$p" is the (signed int) value for precision. ############## ROUNDING MODE FUNCTIONS Rmpfr_set_default_rounding_mode($rnd); Sets the default rounding mode to $rnd (where $rnd can be one of MPFR_RNDN, MPFR_RNDU, MPFR_RNDZ, MPFR_RNDD and MPFR_RNDA. Note that MPFR_RNDA is available only if Math::MPFR has been built against mpfr-3.0.0 or later. The default rounding mode is to nearest initially (MPFR_RNDN). The default rounding mode is the rounding mode that is used in in overloaded operations. $si = Rmpfr_get_default_rounding_mode(); Returns to $si the numeric value (0, 1, 2, 3 or 4) of the current default rounding mode. This will initially be 0. $inex = Rmpfr_prec_round($rop, $p, $rnd); Rounds $rop according to $rnd with precision $p, which may be different from that of $rop. If $p is greater or equal to the precision of $rop, then new space is allocated for the mantissa, and it is filled with zeroes. Otherwise, the mantissa is rounded to precision $p with the given direction. In both cases, the precision of $rop is changed to $p. The precision $p can be any integer between RMPFR_PREC_MIN and RMPFR_PREC_MAX. $inex = Rmpfr_round_nearest_away(\&function, $rop, @input_args); This is a perl implementation (and not a wrapping) of the mpfr_round_nearest_away macro introduced in mpfr-4.0.0. You can use this function so long as Math::MPFR has been built against mpfr-3.0.0 or later. This rounding is defined in the same way as MPFR_RNDN, except in case of tie, where the value away from zero is returned. The first arg is a reference to the perl subroutine you wish to call, and the remaining args are the args that the subroutine usually takes (minus the rounding arg). For example: $inex = Rmpfr_round_nearest_away(\&Rmpfr_add, $rop, $op1, $op2); $inex = Rmpfr_round_nearest_away(\&Rmpfr_strtofr, $rop, '1e-200', 10); $inex = Rmpfr_round_nearest_away(\&Rmpfr_prec_round, $rop, $prec); The "function" being called must be one that returns the ternary int (-ve for "less than", 0 for "exact", and +ve for "greater than"). Unlike the more efficient rndna(), this function requires that Rmpfr_get_emin() is greater than Rmpfr_get_emin_min(). If you're not concerned about correct rounding (nearest away) of the value +/- 0.25 * (2 ** Rmpfr_get_emin()) then you can instead use the rndna function (immediately below). $inex = rndna(\&function, $rop, @input_args); A more efficient version of the (above) Rmpfr_round_nearest_away function. However, it will not correctly deal with the value +/- 0.25 * (2 ** Rmpfr_get_emin()). Unlike Rmpfr_round_nearest_away(), this function allows that Rmpfr_get_emin() == Rmpfr_get_emin_min(). ############## INITIALIZATION A variable should be initialized once only. First read the section 'MEMORY MANAGEMENT' (above). Rmpfr_set_default_prec($p); Set the default precision to be *exactly* $p bits. The precision of a variable means the number of bits used to store its mantissa. All subsequent calls to 'mpfr_init' will use this precision, but previously initialized variables are unaffected. This default precision is set to 53 bits initially. The precision can be any integer between RMPFR_PREC_MIN and RMPFR_PREC_MAX. $ui = Rmpfr_get_default_prec(); Returns the default MPFR precision in bits. $rop = Math::MPFR->new(); $rop = Math::MPFR::new(); $rop = new Math::MPFR(); $rop = Rmpfr_init(); $rop = Rmpfr_init_nobless(); Initialize $rop, and set its value to NaN. The precision of $rop is the default precision, which can be changed by a call to 'Rmpfr_set_default_prec'. NOTE: The new() sub can accept an argument - in which case $rop is initialized and the given value assigned to it. See COMBINED INITIALIZATION AND ASSIGNMENT below for more details. $rop = Rmpfr_init2($p); $rop = Rmpfr_init2_nobless($p); Initialize $rop, set its precision to be *exactly* $p bits, and set its value to NaN. To change the precision of a variable which has already been initialized, use 'Rmpfr_set_prec' instead. The precision $p can be any integer between RMPFR_PREC_MIN and RMPFR_PREC_MAX. @rops = Rmpfr_inits($how_many); @rops = Rmpfr_inits_nobless($how_many); Returns an array of $how_many Math::MPFR objects - initialized, with a value of NaN, and with default precision. (These functions do not wrap mpfr_inits.) @rops = Rmpfr_inits2($p, $how_many); @rops = Rmpfr_inits2_nobless($p, $how_many); Returns an array of $how_many Math::MPFR objects - initialized, with a value of NaN, and with precision of $p. (These functions do not wrap mpfr_inits2.) Rmpfr_set_prec($op, $p); Reset the precision of $op to be *exactly* $p bits. The previous value stored in $op is lost. The precision $p can be any integer between RMPFR_PREC_MIN and RMPFR_PREC_MAX. If you want to keep the previous value stored in $op, use 'Rmpfr_prec_round' instead. $si = Rmpfr_get_prec($op); Return to $si the precision actually used for assignments of $op, i.e. the number of bits used to store its mantissa. Rmpfr_set_prec_raw($rop, $p); Reset the precision of $rop to be *exactly* $p bits. The only difference with 'mpfr_set_prec' is that $p is assumed to be small enough so that the mantissa fits into the current allocated memory space for $rop. Otherwise an error will occur. $min_prec = Rmpfr_min_prec($op); (This function is implemented only when Math::MPFR is built against mpfr-3.0.0 or later. The mpfr_min_prec function was not present in earlier versions of mpfr.) $min_prec is set to the minimal number of bits required to store the significand of $op, and 0 for special values, including 0. (Warning: the returned value can be less than RMPFR_PREC_MIN.) $minimum_precision = RMPFR_PREC_MIN; $maximum_precision = RMPFR_PREC_MAX; Returns the minimum/maximum precision for Math::MPFR objects allowed by the mpfr library being used. ########## ASSIGNMENT $inex = Rmpfr_set($rop, $op, $rnd); $inex = Rmpfr_set_ui($rop, $ui, $rnd); $inex = Rmpfr_set_si($rop, $si, $rnd); $inex = Rmpfr_set_sj($rop, $sj, $rnd); $inex = Rmpfr_set_uj($rop, $uj, $rnd); $inex = Rmpfr_set_IV($rop, $iv, $rnd); # $iv is $Config{ivtype} $inex = Rmpfr_set_d ($rop, $double, $rnd); $inex = Rmpfr_set_ld($rop, $ld, $rnd); # long double $inex = Rmpfr_set_NV($rop, $nv, $rnd); # $nv is $Config{nvtype} $inex = Rmpfr_set_LD($rop, $LD, $rnd); # $LD is a Math::LongDouble # object $inex = Rmpfr_set_z($rop, $z, $rnd); # $z is a mpz object. $inex = Rmpfr_set_q($rop, $q, $rnd); # $q is a mpq object. $inex = Rmpfr_set_f($rop, $f, $rnd); # $f is a mpf object. $inex = Rmpfr_set_flt($rop, $float, $rnd); # mpfr-3.0.0 and later only $inex = Rmpfr_set_float16($rop, $f16, $rnd); # mpfr-4.3.0 and later only # & only on 64-bit systems. $inex = Rmpfr_set_float128($rop, $f128, $rnd);# nvtype is __float128 # && mpfr-4.0.0 or later # && mpfr lib built with # --enable-float128. $inex = Rmpfr_set_DECIMAL64($rop, $D64, $rnd);# mpfr-3.1.0 or later && # mpfr lib built with # --enable-decimal-float # $D64 is a # Math::Decimal64 object $inex = Rmpfr_set_DECIMAL128($rop, $D128, $rnd);# mpfr-3.1.0 or later && # mpfr lib built with # --enable-decimal-float. # $D128 is a # Math::Decimal128 object $inex = Rmpfr_set_FLOAT128($rop, $F128, $rnd);# mpfr-4.0.0 and later # && mpfr lib built with # --enable-float128. # $F128 is a # Math::Float128 object. Set the value of $rop from 2nd arg, rounded to the precision of $rop towards the given direction $rnd. Please note that even a 'long int' may have to be rounded if the destination precision is less than the machine word width. The return value is zero when $rop==2nd arg, positive when $rop>2nd arg, and negative when $rop<2nd arg. For 'mpfr_set_d', be careful that the input number $double may not be exactly representable as a double-precision number (this happens for 0.1 for instance), in which case it is first rounded by the C compiler to a double-precision number, and then only to a mpfr floating-point number. Rmpfr_set_float16 is currently unavailable to 32-bit systems. NOTE: 1) Rmpfr_set_IV requires that $iv has it's IOK flag set, and Rmpfr_set_NV requires that $nv has its NOK flag set. Otherwise these functions will croak. Best to first check IOK_flag($iv) or NOK_flag($nv), both of which will return a non-zero value if and only if the flag in question is set. 2) Rmpfr_set_IV also handles unsigned (UV) arguments. $inex = Rmpfr_set_ui_2exp($rop, $ui, $exp, $rnd); $inex = Rmpfr_set_si_2exp($rop, $si, $exp, $rnd); $inex = Rmpfr_set_uj_2exp($rop, $sj, $exp, $rnd); $inex = Rmpfr_set_sj_2exp($rop, $sj, $exp, $rnd); $inex = Rmpfr_set_z_2exp($rop, $z, $exp, $rnd); # mpfr-3.0.0 & later only Set the value of $rop from the 2nd arg multiplied by two to the power $exp, rounded towards the given direction $rnd. Note that the input 0 is converted to +0. ($z is a GMP mpz object.) $iv = Rmpfr_set_str($rop, $str, $base, $rnd); Set $rop to the value of $str in base $base (0,2..36) or, if Math::MPFR has been built against mpfr-3.0.0 or later, (0,2..62), rounded in direction $rnd to the precision of $rop. The exponent is read in decimal. This function returns 0 if the entire string is a valid number in base $base. Otherwise it returns -1. If -1 is returned: 1) the non-numeric flag (which was initialised to 0) will be incremented. You can query/clear/reset the value of the flag with (resp.) nnumflag()/clear_nnum()/set_nnum() - all of which are documented below (in "MISCELLANEOUS"); 2) A warning will be emitted if $Math::MPFR::NNW is set to 1 (default is 0). If $base is zero, the base is set according to the following rules: if the string starts with '0b' or '0B' the base is set to 2; if the string starts with '0x' or '0X' the base is set to 16; otherwise the base is set to 10. The following exponent symbols can be used: '@' - can be used for any base; 'e' or 'E' - can be used only with bases <= 10; 'p' or 'P' - can be used to introduce binary exponents with hexadecimal or binary strings. See the MPFR library documentation for more details. See also 'Rmpfr_inp_str' (below). Because of the special significance of the '@' symbol in perl, make sure you assign to strings using single quotes, not double quotes, when using '@' as the exponent marker. If you must use double quotes (which is hard to believe) then you need to escape the '@'. ie the following two assignments are equivalent: Rmpfr_set_str($rop, '.1234@-5', 10, GMP_RNDN); Rmpfr_set_str($rop, ".1234\@-5", 10, GMP_RNDN); But the following assignment won't do what you want: Rmpfr_set_str($rop, ".1234@-5", 10, GMP_RNDN); $inex = Rmpfr_strtofr($rop, $str, $base, $rnd); This function differs from Rmpfr_set_str() mainly in that it returns the usual "exactness" ternary value ($inex). Read a floating point number from a string $str in base $base, rounded in the direction $rnd. If successful, the result is stored in $rop. If $str doesn't start with a valid number then $rop is set to zero. Parsing follows the standard C 'strtod' function with some extensions. Case is ignored. After optional leading whitespace, one has a subject sequence consisting of an optional sign ('+' or '-'), and either numeric data or special data. The subject sequence is defined as the longest initial subsequence of the input string, starting with the first non-whitespace character, that is of the expected form. The form of numeric data is a non-empty sequence of significand digits with an optional decimal point, and an optional exponent consisting of an exponent prefix followed by an optional sign and a non-empty sequence of decimal digits. A significand digit is either a decimal digit or a Latin letter (62 possible characters), with 'a' = 10, 'b' = 11, ..., 'z' = 36; its value must be strictly less than the base. The decimal point can be either the one defined by the current locale or the period (the first one is accepted for consistency with the C standard and the practice, the second one is accepted to allow the programmer to provide MPFR numbers from strings in a way that does not depend on the current locale). The exponent prefix can be 'e' or 'E' for bases up to 10, or '@' in any base; it indicates a multiplication by a power of the base. In bases 2 and 16, the exponent prefix can also be 'p' or 'P', in which case it introduces a binary exponent: it indicates a multiplication by a power of 2 (there is a difference only for base 16). The value of an exponent is always written in base 10. In base 2, the significand can start with '0b' or '0B', and in base 16, it can start with '0x' or '0X'. If the argument $base is 0, then the base is automatically detected as follows. If the significand starts with '0b' or '0B', base 2 is assumed. If the significand starts with '0x' or '0X', base 16 is assumed. Otherwise base 10 is assumed. Other allowable values for $base are 2 to 62. Note: The exponent must contain at least a digit. Otherwise the possible exponent prefix and sign are not part of the number (which ends with the significand). Similarly, if '0b', '0B', '0x' or '0X' is not followed by a binary/hexadecimal digit, then the subject sequence stops at the character '0'. Special data (for infinities and NaN) can be '@inf@' or '@nan@(n-char-sequence)', and if BASE <= 16, it can also be 'infinity', 'inf', 'nan' or 'nan(n-char-sequence)', all case insensitive. A 'n-char-sequence' is a non-empty string containing only digits, Latin letters and the underscore (0, 1, 2, ..., 9, a, b, ..., z, A, B, ..., Z, _). Note: one has an optional sign for all data, even NaN. Rmpfr_set_inf($rop, $si); Rmpfr_set_nan($rop); Rmpfr_set_zero($rop, $si); # mpfr-3.0.0 and later only. Set the variable $rop to infinity or NaN (Not-a-Number) or zero respectively. In 'Rmpfr_set_inf' and 'Rmpfr_set_zero', the sign of $rop is positive if 2nd arg >= 0. Else the sign is negative. Rmpfr_swap($op1, $op2); Swap the values $op1 and $op2 efficiently. Warning: the precisions are exchanged too; in case the precisions are different, 'mpfr_swap' is thus not equivalent to three 'mpfr_set' calls using a third auxiliary variable. ################################################ COMBINED INITIALIZATION AND ASSIGNMENT NOTE: Do NOT use these functions if $rop has already been initialised. Use the Rmpfr_set* functions in the section 'ASSIGNMENT' (above). First read the section 'MEMORY MANAGEMENT' (above). $rop = Math::MPFR->new($arg); $rop = Math::MPFR::new($arg); $rop = new Math::MPFR($arg); Returns a Math::MPFR object with the value of $arg, rounded in the default rounding direction, with default precision. $arg can be either a number (signed integer, unsigned integer, signed fraction or unsigned fraction), a string that represents a numeric value, or an object (of type Math::GMPf, Math::GMPq, Math::GMPz, orMath::GMP) If $arg is a string, an optional additional argument that specifies the base of the number can be supplied to new(). Legal values for base are 0 and 2 to 62. If $arg is a string and no additional argument is supplied, the base will be deduced. See 'Rmpfr_set_str' above for an explanation of how that deduction is made, and for rules regarding the string format. NOTE: If $arg is *both* an NV (floating point value) and PV (string), then the value specified by the PV (string) will be used. This is probably what you want (less likely so with perl-5.18.4 and earlier). However, there's no guaranteed way for the new() function to correctly tell and it's best to avoid passing such values, or to explicitly use the value you want by doing an Rmpfr_init() followed by the appropriate 'Rmpfr_set_*' function documented in the previous section. Or, if such exists, you could instead call the appropriate 'Rmpfr_init_set_*' function documented immediately below. Note that these functions (below) return a list of 2 values. ($rop, $inex) = Rmpfr_init_set ($op, $rnd); ($rop, $inex) = Rmpfr_init_set_nobless($op, $rnd); ($rop, $inex) = Rmpfr_init_set_ui ($ui, $rnd); ($rop, $inex) = Rmpfr_init_set_ui_nobless($ui, $rnd); ($rop, $inex) = Rmpfr_init_set_si ($si, $rnd); ($rop, $inex) = Rmpfr_init_set_si_nobless($si, $rnd); ($rop, $inex) = Rmpfr_init_set_d ($double, $rnd); ($rop, $inex) = Rmpfr_init_set_d_nobless($double, $rnd); ($rop, $inex) = Rmpfr_init_set_ld ($ld, $rnd); ($rop, $inex) = Rmpfr_init_set_ld_nobless($ld, $rnd); ($rop, $inex) = Rmpfr_init_set_float128 ($f128, $rnd); ($rop, $inex) = Rmpfr_init_set_float128_nobless($f128, $rnd); ($rop, $inex) = Rmpfr_init_set_f ($f, $rnd);# $f is a mpf object ($rop, $inex) = Rmpfr_init_set_f_nobless($f, $rnd);# $f is a mpf object ($rop, $inex) = Rmpfr_init_set_z ($z, $rnd);# $z is a mpz object ($rop, $inex) = Rmpfr_init_set_z_nobless($z, $rnd);# $z is a mpz object ($rop, $inex) = Rmpfr_init_set_q ($q, $rnd);# $q is a mpq object ($rop, $inex) = Rmpfr_init_set_q_nobless($q, $rnd);# $q is a mpq object ($rop, $inex) = Rmpfr_init_set_IV ($IV,$rnd);# $IV is $Config{ivtype} ($rop, $inex) = Rmpfr_init_set_IV_nobless($IV,$rnd);# $IV is $Config{ivtype} ($rop, $inex) = Rmpfr_init_set_NV ($NV,$rnd);# $NV is $Config{nvtype} ($rop, $inex) = Rmpfr_init_set_NV_nobless($NV,$rnd);# $NV is $Config{nvtype} Initialize $rop and set its value from the 1st arg, rounded to direction $rnd. The precision of $rop will be taken from the active default precision, as set by 'Rmpfr_set_default_prec'. ($rop, $si) = Rmpfr_init_set_str($str, $base, $rnd); ($rop, $si) = Rmpfr_init_set_str_nobless($str, $base, $rnd); Initialize $rop and set its value from $str in base $base, rounded to direction $rnd. If $str was a valid number, then $si will be set to 0. Else it will be set to -1. If $si is -1 : 1) the non-numeric flag (which was initialised to 0) will be incremented. You can query/clear/reset the value of the flag with (resp.) nnumflag()/clear_nnum()/set_nnum() - all of which are documented below (in "MISCELLANEOUS"); 2) A warning will be emitted if $Math::MPFR::NNW is set to 1 (default is 0). See 'Rmpfr_set_str' (above) and 'Rmpfr_inp_str' (below). ########## CONVERSION $str = Rmpfr_get_str($op, $base, $digits, $rnd); Returns a string of the form, eg, '8.3456712@2' which means '834.56712'. The "mantissa" portion fo the returned string will be presented in base $base. The "exponent" portion will be in base 10. $digits specifies the number of digits required to be output in the mantissa. (Trailing zeroes are removed.) If $digits is 0, the number of digits of the mantissa is chosen large enough so that re-reading the printed value with the same precision, assuming both output and input use rounding to nearest, will recover the original value of $op. $str will be set to 'Nan', '-Inf' or 'Inf' whenever $op is (respectively) a NaN, a negative infinity or a positive infinity. ($str, $si) = Rmpfr_deref2($op, $base, $digits, $rnd); Returns the mantissa to $str (as a string of base $base digits, prefixed with a minus sign if $op is negative), and returns the exponent to $si as a base 10 value. There's an implicit decimal point to the left of the first digit in $str. $digits specifies the number of digits required to be output in the mantissa. If $digits is 0, the number of digits of the mantissa is chosen large enough so that re-reading the printed value with the same precision, assuming both output and input use rounding to nearest, will recover the original value of $op. Unlike Rmpfr_get_str() and Rmpfr_integer_string(), $str will be set to '@NaN@', '-@Inf@' or '@Inf@' whenever $op is (respectively) a NaN, a negative infinity or a positive infinity, as those are the strings that the mpfr library assigns. $str = Rmpfr_integer_string($op, $base, $rnd); Returns the truncated integer value of $op as a string. (No exponent is returned). For example, if $op contains the value 2.3145679e2, $str will be set to "231". $str will be set to 'Nan', '-Inf' or 'Inf' whenever $op is (respectively) a NaN, a negative infinity or a positive infinity. $bool = Rmpfr_fits_ushort_p($op, $rnd); # fits in unsigned short $bool = Rmpfr_fits_sshort_p($op, $rnd); # fits in signed short $bool = Rmpfr_fits_uint_p($op, $rnd); # fits in unsigned int $bool = Rmpfr_fits_sint_p($op, $rnd); # fits in signed int $bool = Rmpfr_fits_ulong_p($op, $rnd); # fits in unsigned long $bool = Rmpfr_fits_slong_p($op, $rnd); # fits in signed long $bool = Rmpfr_fits_uintmax_p($op, $rnd); # fits in uintmax_t $bool = Rmpfr_fits_intmax_p($op, $rnd); # fits in intmax_t $bool = Rmpfr_fits_IV_p($op, $rnd); # fits in perl IV or UV Return non-zero if $op would fit in the respective data type, when rounded to an integer in the direction $rnd. $ui = Rmpfr_get_ui($op, $rnd); $si = Rmpfr_get_si($op, $rnd); $sj = Rmpfr_get_sj($op, $rnd); # Available only when ivtype is 'long long'. $uj = Rmpfr_get_uj($op, $rnd); # Available only when ivtype is 'long long'. $IV = Rmpfr_get_IV($op, $rnd); # $IV is $Config{ivtype} Convert $op to an 'unsigned long long', a 'signed long', a 'signed long long', an 'unsigned long long' or an 'IV' - after rounding it with respect to $rnd. If $op is NaN, the result is undefined. If $op is too big for the return type, it returns the maximum or the minimum of the corresponding C type, depending on the direction of the overflow. The flag erange is then also set. $double = Rmpfr_get_d($op, $rnd); $ld = Rmpfr_get_ld($op, $rnd); $f128 = Rmpfr_get_float128($op, $rnd);# nvtype is __float128 # && mpfr-4.0.0 or later # && mpfr lib built with # --enable-float128. $NV = Rmpfr_get_NV ($op, $rnd); # double/long double/__float128 $NV = Rmpfr_get_flt ($op, $rnd); # mpfr-3.0.0 and later $NV = Rmpfr_get_float16($op, $rnd); # mpfr-4.3.0 and later, and # only on 64-bit systems. Rmpfr_get_LD($LD, $op, $rnd); # $LD is a Math::LongDouble object. Rmpfr_get_DECIMAL64($d64, $op, $rnd); # mpfr-3.1.0 or later && # mpfr lib built with # --enable-decimal-float # && D64=1 arg given to # Makefile.PL. $D64 is a # Math::Decimal64 object Rmpfr_get_FLOAT128($F128, $op, $rnd);# mpfr-4.0.0 and later && # mpfr library built with # --enable-float128. # $F128 is a Math::Float128 # object. Convert $op to a 'double', a 'long double', a '__float128', an 'NV', a 'float', a '_Float16', a Math::LongDouble object, ''' a Math::Decimal64 object, or a Math::Float128 object using the rounding mode $rnd. Rmpfr_get_float16 is currently unavailable to 32-bit systems. $double = Rmpfr_get_d1($op); Convert $op to a double, using the default MPFR rounding mode. THIS FUNCTION IS DEPRECATED. Instead, do: $double = Rmpfr_get_d($op, Rmpfr_get_default_prec()); $si = Rmpfr_get_z_exp($z, $op); # $z is a mpz object $si = Rmpfr_get_z_2exp($z, $op); # $z is a mpz object (Identical functions. Use either - 'get_z_exp' might one day be removed.) Puts the mantissa of $rop into $z, and returns the exponent $si such that $rop == $z * (2 ** $ui). $inex = Rmpfr_get_z($z, $op, $rnd); # $z is a mpz object. Convert $op to an mpz object ($z), after rounding it with respect to RND. If built against mpfr-3.0.0 or later, return the usual ternary value. (The function returns undef when using mpfr-2.x.x.) Croak with appropriate error message if $op is NaN or Inf. $inex = Rmpfr_get_f ($f, $op, $rnd); # $f is a Math::GMPf object. Convert $op to a 'mpf_t', after rounding it with respect to $rnd. When built against mpfr-3.0.0 or later, this function returns the usual ternary value. When built against earlier versions of mpfr, return zero if no error occurred. Croak with appropriate error message if $op is NaN or Inf. Rmpfr_get_q ($q, $op); # $q is a Math::GMPq object. Convert $op to a rational value. $q will be set to the exact value contained in $op - hence no need for a rounding argument. Croak with appropriate error message if $op is NaN or Inf. $d = Rmpfr_get_d_2exp ($exp, $op, $rnd); # $d is NV (double) $d = Rmpfr_get_ld_2exp ($exp, $op, $rnd); # $d is NV (long double) Set $exp and $d such that 0.5<=abs($d)<1 and $d times 2 raised to $exp equals $op rounded to double (resp. long double) precision, using the given rounding mode. If $op is zero, then a zero of the same sign (or an unsigned zero, if the implementation does not have signed zeros) is returned, and $exp is set to 0. If $op is NaN or an infinity, then the corresponding double precision (resp. long-double precision) value is returned, and $exp is undefined. $inex = Rmpfr_frexp($si, $rop, $op, $rnd); # mpfr-3.1.0 and later only Set $si and $rop such that 0.5<=abs($rop)<1 and $rop * (2 ** $si) equals $op rounded to the precision of $rop, using the given rounding mode. If $op is zero, then $rop is set to zero (of the same sign) and $exp is set to 0. If $op is NaN or an infinity, then $rop is set to the same value and the value of $exp is meaningless (and should be ignored). $ui1 = Rmpfr_get_str_ndigits($ui2, $ui3); # new with mpfr-4.1.0 Note: $ui2 must be in the range 2..62 (inclusive). Return the minimal integer $ui1 such that any number of precision $ui3 bits, when output with $ui1 digits in radix $ui2 with rounding to nearest, can be recovered exactly when read again, still with rounding to nearest. More precisely, we have $ui1 = 1 + ceil($ui3 * log(2) / log($ui2)), with $ui3 decremented by 1 if $ui2 is a power of 2. This function wraps mpfr_get_str_ndigits if mpfr version is 4.1.0 or later. Otherwise it calls Rmpfr_get_str_ndigits_alt, which does not require mpfr-4.1.0. $ui1 = Rmpfr_get_str_ndigits_alt($ui2, $ui3); Provided as a fallback (though it can also be called separately) for Rmpfr_get_str_ndigits when mpfr version is older than 4.1.0. Unlike Rmpfr_get_str_ndigits, this function does not require that $ui2 is in the range 2..62. ########## ARITHMETIC $inex = Rmpfr_add($rop, $op1, $op2, $rnd); $inex = Rmpfr_add_ui($rop, $op, $ui, $rnd); $inex = Rmpfr_add_si($rop, $op, $si1, $rnd); $inex = Rmpfr_add_d($rop, $op, $double, $rnd); $inex = Rmpfr_add_z($rop, $op, $z, $rnd); # $z is a mpz object. $inex = Rmpfr_add_q($rop, $op, $q, $rnd); # $q is a mpq object. Set $rop to 2nd arg + 3rd arg rounded in the direction $rnd. The return value is zero if $rop is exactly 2nd arg + 3rd arg, positive if $rop is larger than 2nd arg + 3rd arg, and negative if $rop is smaller than 2nd arg + 3rd arg. $inex = Rmpfr_sum($rop, \@ops, scalar(@ops), $rnd); @ops is an array consisting entirely of Math::MPFR objects. Set $rop to the sum of all members of @ops, rounded in the direction $rnd. $si is zero when the computed value is the exact value, and non-zero when this cannot be guaranteed, without giving the direction of the error as the other functions do. $inex = Rmpfr_sub($rop, $op1, $op2, $rnd); $inex = Rmpfr_sub_ui($rop, $op, $ui, $rnd); $inex = Rmpfr_sub_z($rop, $op, $z, $rnd); # $z is a mpz object. $inex = Rmpfr_z_sub($rop, $z, $op, $rnd); # mpfr-3.1.0 and later only $inex = Rmpfr_sub_q($rop, $op, $q, $rnd); # $q is a mpq object. $inex = Rmpfr_ui_sub($rop, $ui, $op, $rnd); $inex = Rmpfr_si_sub($rop, $si1, $op, $rnd); $inex = Rmpfr_sub_si($rop, $op, $si1, $rnd); $inex = Rmpfr_sub_d($rop, $op, $double, $rnd); $inex = Rmpfr_d_sub($rop, $double, $op, $rnd); Set $rop to 2nd arg - 3rd arg rounded in the direction $rnd. The return value is zero if $rop is exactly 2nd arg - 3rd arg, positive if $rop is larger than 2nd arg - 3rd arg, and negative if $rop is smaller than 2nd arg - 3rd arg. $inex = Rmpfr_mul($rop, $op1, $op2, $rnd); $inex = Rmpfr_mul_ui($rop, $op, $ui, $rnd); $inex = Rmpfr_mul_si($rop, $op, $si1, $rnd); $inex = Rmpfr_mul_d($rop, $op, $double, $rnd); $inex = Rmpfr_mul_z($rop, $op, $z, $rnd); # $z is a mpz object. $inex = Rmpfr_mul_q($rop, $op, $q, $rnd); # $q is a mpq object. Set $rop to 2nd arg * 3rd arg rounded in the direction $rnd. Return 0 if the result is exact, a positive value if $rop is greater than 2nd arg times 3rd arg, a negative value otherwise. $inex = Rmpfr_div($rop, $op1, $op2, $rnd); $inex = Rmpfr_div_ui($rop, $op, $ui, $rnd); $inex = Rmpfr_ui_div($rop, $ui, $op, $rnd); $inex = Rmpfr_div_si($rop, $op, $si1, $rnd); $inex = Rmpfr_si_div($rop, $si1, $op, $rnd); $inex = Rmpfr_div_d($rop, $op, $double, $rnd); $inex = Rmpfr_d_div($rop, $double, $op, $rnd); $inex = Rmpfr_div_z($rop, $op, $z, $rnd); # $z is a mpz object. $inex = Rmpfr_z_div($rop, $z, $op, $rnd); # $z is a mpz object. $inex = Rmpfr_div_q($rop, $op, $q, $rnd); # $q is a mpq object. $inex = Rmpfr_q_div($rop, $q, $op, $rnd); # $q is a mpq object. NOTE: The mpfr library does not provide mpfr_z_div and mpfr_q_div functions. Set $rop to 2nd arg / 3rd arg rounded in the direction $rnd. These functions return 0 if the division is exact, a positive value when $rop is larger than 2nd arg divided by 3rd arg, and a negative value otherwise. q_add_fr($q1, $q2, $op); # $q1, $q2 are mpq objects Set $q1 to the exact rational value of $q2 + $op. q_sub_fr($q1, $q2, $op); # $q1, $q2 are mpq objects Set $q1 to the exact rational value of $q2 - $op. q_mul_fr($q1, $q2, $op); # $q1, $q2 are mpq objects Set $q1 to the exact rational value of $q2 * $op. q_div_fr($q1, $q2, $op); # $q1, $q2 are mpq objects Set $q1 to the exact rational value of $q2 % p. q_fmod_fr($q1, $q2, $op); # $q1, $q2 are mpq objects Set $q1 to the exact rational value of fmod($q2,$op). $inex = Rmpfr_sqr($rop, $op, $rnd); Set $rop to the square of $op, rounded in direction $rnd. $inex = Rmpfr_sqrt($rop, $op, $rnd); $inex = Rmpfr_sqrt_ui($rop, $ui, $rnd); Set $rop to the square root of the 2nd arg rounded in the direction $rnd. Set $rop to NaN if 2nd arg is negative. Return 0 if the operation is exact, a non-zero value otherwise. $inex = Rmpfr_rec_sqrt($rop, $op, $rnd); Set $rop to $op ** (-1 / 2) rounded in the direction $rnd. Set $rop to +Inf if $op is 0, and 0 if $op is +Inf. Set $rop to NaN if $op is less than zero. $inex = Rmpfr_rec_root($rop, $op, $ui, $rnd); NOTE: There is no such mpfr function as mpfr_rec_root. This function originally provided as a perl implementation by Vincent Lefevre - and rewritten by sisyphus as an XSub. (See https://sympa.inria.fr/sympa/arc/mpfr/2016-12/msg00032.html) Set $rop to $op ** (-1 / $ui) rounded in the direction $rnd. This function sets its $rop to the reciprocal of the $rop that is set by Rmpfr_rootn_ui (below) for identical arguments. May not correctly handle overflow or underflow. $inex = Rmpfr_cbrt($rop, $op, $rnd); Set $rop to the cubic root of $op, rounded in the direction $rnd. $inex = Rmpfr_root($rop, $op, $ui $rnd); Deprecated in mpfr-4.0.0 - use Rmpfr_rootn_ui with mpfr-4 and later. This function will croak with "deprecation" warning if Math::MPFR has been built against mpfr-4.x.x or later. Set $rop to the $ui'th root of $op, rounded in the direction $rnd. Return 0 if the operation is exact, a non-zero value otherwise. $inex = Rmpfr_rootn_ui($rop, $op, $ui $rnd); # mpfr-4.0.0 and later Same as Rmpfr_root except that $rop is set to +0 (instead of -0) when $op is -0 and $ui is even. This function (and Rmpfr_cbrt) agree with the rootn function of the IEEE 754-2008 standard (Section 9.2). $inex = Rmpfr_pow_ui($rop, $op, $ui, $rnd); $inex = Rmpfr_pow_uj($rop, $op, $uj, $rnd); $inex = Rmpfr_pow_si($rop, $op, $si, $rnd); $inex = Rmpfr_pow_sj($rop, $op, $sj, $rnd); $inex = Rmpfr_pown($rop, $op, $sj, $rnd); # same as Rmpfr_pow_sj $inex = Rmpfr_ui_pow_ui($rop, $ui, $ui, $rnd); $inex = Rmpfr_ui_pow($rop, $ui, $op, $rnd); $inex = Rmpfr_pow ($rop, $op1, $op2, $rnd); $inex = Rmpfr_pow_z ($rop, $op, $z, $rnd); # $z is a mpz object $inex = Rmpfr_pow_IV($rop, $op, $IV, $rnd); # $IV is $Config{ivtype} Set $rop to 2nd arg raised to 3rd arg, rounded to the direction $rnd with the precision of $rop. Return zero if the result is exact, a positive value when the result is greater than 2nd arg to the power 3rd arg, and a negative value when it is smaller. See the MPFR documentation for documentation regarding special cases (ie when nan or signed inf/zero values are involved). $inex = Rmpfr_powr($rop, $op1, $op2, $rnd); Corresponds to the 'powr' function from IEEE 754: $rop = exp($op2 * log($op1)) rounded to the direction $rnd with the precision of $rop. $inex = Rmpfr_compound ($rop, $op1, $op2, $rnd); # New in 4.3.0 $inex = Rmpfr_compound_si($rop, $op1, $si, $rnd); # New in 4.2.0 $rop = ($op1 + 1) ** 3rd_arg, rounded according to $rnd, to the precision of $rop. However, there are special cases: $rop is set to NaN when $op1 < -1; $rop is set to 1 when $op1 is NaN and $op2 is 0; $rop is set to +Inf when $op1 is -1 and $op2 < 0; $rop is set to +0 when $op1 is -1 and $op2 > 0. The other special cases follow the 'Rmpfr_pow' rules on (1 + OP1, OP2). $inex = Rmpfr_neg($rop, $op, $rnd); Set $rop to -$op rounded in the direction $rnd. Just changes the sign if $rop and $op are the same variable. $inex = Rmpfr_abs($rop, $op, $rnd); Set $rop to the absolute value of $op, rounded in the direction $rnd. Return 0 if the result is exact, a positive value if $rop is larger than the absolute value of $op, and a negative value otherwise. $inex = Rmpfr_dim($rop, $op1, $op2, $rnd); Set $rop to the positive difference of $op1 and $op2, i.e., $op1 - $op2 rounded in the direction $rnd if $op1 > $op2, and +0 otherwise. $rop is set to NaN when $op1 or $op2 is NaN. $inex = Rmpfr_mul_2exp($rop, $op, $ui, $rnd); $inex = Rmpfr_mul_2ui($rop, $op, $ui, $rnd); $inex = Rmpfr_mul_2si($rop, $op, $si, $rnd); Set $rop to 2nd arg times 2 raised to 3rd arg rounded to the direction $rnd. Just increases the exponent by 3rd arg when $rop and 2nd arg are identical. Return zero when $rop = 2nd arg, a positive value when $rop > 2nd arg, and a negative value when $rop < 2nd arg. Note: The 'Rmpfr_mul_2exp' function is defined for compatibility reasons; you should use 'Rmpfr_mul_2ui' (or 'Rmpfr_mul_2si') instead. $inex = Rmpfr_div_2exp($rop, $op, $ui, $rnd); $inex = Rmpfr_div_2ui($rop, $op, $ui, $rnd); $inex = Rmpfr_div_2si($rop, $op, $si, $rnd); Set $rop to 2nd arg divided by 2 raised to 3rd arg rounded to the direction $rnd. Just decreases the exponent by 3rd arg when $rop and 2nd arg are identical. Return zero when $rop = 2nd arg, a positive value when $rop > 2nd arg, and a negative value when $rop < 2nd arg. Note: The 'Rmpfr_div_2exp' function is defined for compatibility reasons; you should use 'Rmpfr_div_2ui' (or 'Rmpfr_div_2si') instead. ########## COMPARISON $si = Rmpfr_cmp($op1, $op2); $si = Rmpfr_cmpabs($op1, $op2); $si = Rmpfr_cmpabs_ui($op, $ui); # requires mpfr-4.1.0 and later $si = Rmpfr_cmp_ui($op, $ui); $si = Rmpfr_cmp_si($op, $si); $si = Rmpfr_cmp_d($op, $double); $si = Rmpfr_cmp_ld($op, $ld); # long double $si = Rmpfr_cmp_float128($op, $f128); # __float128 $si = Rmpfr_cmp_z($op, $z); # $z is a mpz object $si = Rmpfr_cmp_q($op, $q); # $q is a mpq object $si = Rmpfr_cmp_f($op, $f); # $f is a mpf object $si = Rmpfr_cmp_IV($op, $iv); # $iv is $Config{ivtype} $si = Rmpfr_cmp_NV($op, $nv); # $nv is $Config{nvtype} Compare 1st and 2nd args. In the case of 'Rmpfr_cmpabs()' and 'Rmpfr_cmpabs_ui' compare the absolute values of the 2 args. Return a positive value if 1st arg > 2nd arg, zero if 1st arg = 2nd arg, and a negative value if 1st arg < 2nd arg. Both args are considered to their full own precision, which may differ. In case 1st and 2nd args are of same sign but different, the absolute value returned is one plus the absolute difference of their exponents. If one of the operands is NaN (Not-a-Number), return zero and set the erange flag. NOTE: 1) Rmpfr_cmp_IV() requires that the 2nd argument has its IOK flag set, and Rmpfr_cmp_NV() requires that the 2nd argument has its NOK flag set. Otherwise these functions croak. Suggestion: first check the status of the flag using IOK_flag($iv) or NOK_flag($nv),which return a non-zero value if and only if the flag in question is set. 2) Rmpfr_cmp_IV handles both signed and unsigned IV args. $si = fr_cmp_q_rounded($op, $q, $rnd); # $q is a mpq object Convert $q to an mpfr object of current default precision, rounded in accordance with the value specified by $rnd. Then compare $op with this mpfr object, according to the rules specified for Rmpfr_cmp (above). $bool = Rmpfr_total_order_p($op1, $op2); # new with mpfr-4.1.0 This function implements the totalOrder predicate from IEEE 754-2008, where -NaN < -Inf < negative finite numbers < -0 < +0 < positive finite numbers < +Inf < +NaN. It returns a non-zero value (true) when X is smaller than or equal to Y for this order relation, and zero (false) otherwise. Contrary to 'Rmpfr_cmp($x, $y)', which returns a ternary value, 'Rmpfr_total_order_p' returns a binary value (zero or non-zero). In particular, 'Rmpfr_total_order_p($x, $x)' returns true, 'Rmpfr_total_order_p(-0, +0)' returns true and 'Rmpfr_total_order_p(+0, -0)' returns false. The sign bit of NaN also matters. This function falls back to our own implementation if the mpfr version is older than 4.1.0 (because, in that case, mpfr_total_order_p is unavailable). $si = Rmpfr_cmp_ui_2exp($op, $ui, $si); $si = Rmpfr_cmp_si_2exp($op, $si, $si); Compare 1st arg and 2nd arg multiplied by two to the power 3rd arg. $bool = Rmpfr_eq($op1, $op2, $ui); The mpfr library function mpfr_eq may change in future releases of the mpfr library (post 2.4.0). If that happens, the change will also be reflected in Rmpfr_eq. Return non-zero if the first $ui bits of $op1 and $op2 are equal, zero otherwise. I.e., tests if $op1 and $op2 are approximately equal. $bool = Rmpfr_nan_p($op); Return non-zero if $op is Not-a-Number (NaN), zero otherwise. $bool = Rmpfr_inf_p($op); Return non-zero if $op is plus or minus infinity, zero otherwise. $bool = Rmpfr_number_p($op); Return non-zero if $op is an ordinary number, i.e. neither Not-a-Number nor plus or minus infinity. $bool = Rmpfr_zero_p($op); Return non-zero if $op is zero. Else return 0. $bool = Rmpfr_regular_p($op); # mpfr-3.0.0 and later only Return non-zero if $op is a regular number (i.e. neither NaN, nor an infinity nor zero). Return zero otherwise. Rmpfr_reldiff($rop, $op1, $op2, $rnd); Compute the relative difference between $op1 and $op2 and store the result in $rop. This function does not guarantee the exact rounding on the relative difference; it just computes abs($op1-$op2)/$op1, using the rounding mode $rnd for all operations. $si = Rmpfr_sgn($op); Return a positive value if op > 0, zero if $op = 0, and a negative value if $op < 0. Its result is not specified when $op is NaN (Not-a-Number). $bool = Rmpfr_greater_p($op1, $op2); Return non-zero if $op1 > $op2, zero otherwise. $bool = Rmpfr_greaterequal_p($op1, $op2); Return non-zero if $op1 >= $op2, zero otherwise. $bool = Rmpfr_less_p($op1, $op2); Return non-zero if $op1 < $op2, zero otherwise. $bool = Rmpfr_lessequal_p($op1, $op2); Return non-zero if $op1 <= $op2, zero otherwise. $bool = Rmpfr_lessgreater_p($op1, $op2); Return non-zero if $op1 < $op2 or $op1 > $op2 (i.e. neither $op1, nor $op2 is NaN, and $op1 <> $op2), zero otherwise (i.e. $op1 and/or $op2 are NaN, or $op1 = $op2). $bool = Rmpfr_equal_p($op1, $op2); Return non-zero if $op1 = $op2, zero otherwise (i.e. $op1 and/or $op2 are NaN, or $op1 <> $op2). $bool = Rmpfr_unordered_p($op1, $op2); Return non-zero if $op1 or $op2 is a NaN (i.e. they cannot be compared), zero otherwise. ####### SPECIAL $rop = log_2 ($op); $rop = log_10($op); Return log2 of $op (resp. log10 of $op), set to default precision and using default rounding mode. These are the functions that log2 and log10 overloading would call if log2 and log10 overloading was available. $inex = Rmpfr_log($rop, $op, $rnd); $inex = Rmpfr_log_ui($rop, $ui, $rnd); # mpfr-4.0.0 & later only $inex = Rmpfr_log2($rop, $op, $rnd); $inex = Rmpfr_log10($rop, $op, $rnd); Set $rop to the natural logarithm of $op, the natural logarithm of $ui, log2($op) or log10($op), respectively, rounded in the direction $rnd. $inex = Rmpfr_exp($rop, $op, $rnd); $inex = Rmpfr_exp2($rop, $op, $rnd); $inex = Rmpfr_exp10($rop, $op, $rnd); Set rop to the exponential of op, to 2 power of op or to 10 power of op, respectively, rounded in the direction rnd. $rop = sind($op); # Value of $op is in degrees (not radians) $rop = cosd($op); # Value of $op is in degrees (not radians) Return (respectively) sin() and cos() of $op, where the value of $op is expressed in degrees. The return value is calculated using default precision and default rounding mode. These are essentially the same as the overloaded sin and cos functions except that the given argument is in degrees. $rop = tand($op); # $op is in degrees (not radians) $rop = tangent($op); # $op is in radians Return tan($op) calculated with default precision and default rounding mode. $inex = Rmpfr_sin($rop $op, $rnd); $inex = Rmpfr_cos($rop, $op, $rnd); $inex = Rmpfr_tan($rop, $op, $rnd); Set $rop to the sine/cosine/tangent respectively of $op, rounded to the direction $rnd with the precision of $rop. Return 0 if the result is exact (this occurs in fact only when $op is 0 i.e. the sine is 0, the cosine is 1, and the tangent is 0). Return a negative value if the result is less than the actual value. Return a positive result if the return is greater than the actual value. $si = Rmpfr_sin_cos($rop1, $rop2, $op, $rnd); Set simultaneously $rop1 to the sine of $op and $rop2 to the cosine of $op, rounded to the direction $rnd with their corresponding precisions. Return 0 if both results are exact. $inex = Rmpfr_cosu($rop, $op, $ui, $rnd); # mpfr-4.2.0 and later only $inex = Rmpfr_sinu($rop, $op, $ui, $rnd); # mpfr-4.2.0 and later only $inex = Rmpfr_tanu($rop, $op, $ui, $rnd); # mpfr-4.2.0 and later only Set $rop to the cosine (resp. sine and tangent) of $op multiplied by 2*Pi and divided by $ui. For example, if $ui equals 360, one gets the cosine (resp. sine and tangent) for $op in degrees. For 'Rmpfr_cosu', when $op multiplied by 2 and divided by $ui is a half-integer, the result is +0, following IEEE 754-2019 (cosPi), so that the function is even. For 'Rmpfr_sinu', when $op multiplied by 2 and divided by $ui is an integer, the result is zero with the same sign as $op, following IEEE 754-2019 (sinPi), so that the function is odd. Similarly, the function 'Rmpfr_tanu' follows IEEE 754-2019 (tanPi). $inex = Rmpfr_acosu($rop, $op, $ui, $rnd); # mpfr-4.2.0 and later only $inex = Rmpfr_asinu($rop, $op, $ui, $rnd); # mpfr-4.2.0 and later only $inex = Rmpfr_atanu($rop, $op, $ui, $rnd); # mpfr-4.2.0 and later only Set $rop to X multiplied by $ui and divided by 2*Pi, where X is the arc-cosine (resp. arc-sine and arc-tangent) of $op. For example, if $ui equals 360, mpfr_acosu yields the arc-cosine in degrees. $inex = Rmpfr_cospi($rop, $op, $rnd); # mpfr-4.2.0 and later only $inex = Rmpfr_sinpi($rop, $op, $rnd); # mpfr-4.2.0 and later only $inex = Rmpfr_tanpi($rop, $op, $rnd); # mpfr-4.2.0 and later only Set $rop to the cosine (resp. sine and tangent) of $op multiplied by Pi. See the description of 'Rmpfr_sinu', 'Rmpfr_cosu' and 'Rmpfr_tanu' for special values. $inex = Rmpfr_acospi($rop, $op, $rnd); # mpfr-4.2.0 and later only $inex = Rmpfr_asinpi($rop, $op, $rnd); # mpfr-4.2.0 and later only $inex = Rmpfr_atanpi($rop, $op, $rnd); # mpfr-4.2.0 and later only $rop = acos($op)/Pi, resp. asin($op)/Pi and atan($op)/Pi. $inex = Rmpfr_sinh_cosh($rop1, $rop2, $op, $rnd); Set simultaneously $rop1 to the hyperbolic sine of $op and $rop2 to the hyperbolic cosine of $op, rounded in the direction $rnd with the corresponding precision of $rop1 and $rop2 which must be different variables. Return 0 if both results are exact. $inex = Rmpfr_acos($rop, $op, $rnd); $inex = Rmpfr_asin($rop, $op, $rnd); $inex = Rmpfr_atan($rop, $op, $rnd); Set $rop to the arc-cosine, arc-sine or arc-tangent of $op, rounded to the direction $rnd with the precision of $rop. Return 0 if the result is exact. Return a negative value if the result is less than the actual value. Return a positive result if the return is greater than the actual value. $inex = Rmpfr_atan2($rop, $op1, $op2, $rnd); Set $rop to the tangent of $op1/$op2, rounded to the direction $rnd with the precision of $rop. Return 0 if the result is exact. Return a negative value if the result is less than the actual value. Return a positive result if the return is greater than the actual value. See the MPFR documentation for details regarding special cases. $inex = Rmpfr_atan2u($rop, $op1, $op2, $ui, $rnd); Same as taking the Rmpfr_atan2() result and multiplying it by $ui/(2*Pi). $inex = Rmpfr_atan2pi($rop, $op1, $op2, $rnd); Same as Rmpfr_atan2u() with $ui = 2. $inex = Rmpfr_cosh($rop, $op, $rnd); $inex = Rmpfr_sinh($rop, $op, $rnd); $inex = Rmpfr_tanh($rop, $op, $rnd); Set $rop to the hyperbolic cosine/hyperbolic sine/hyperbolic tangent respectively of $op, rounded to the direction $rnd with the precision of $rop. Return 0 if the result is exact (this occurs in fact only when $op is 0 i.e. the result is 1). Return a negative value if the result is less than the actual value. Return a positive result if the return is greater than the actual value. $inex = Rmpfr_acosh($rop, $op, $rnd); $inex = Rmpfr_asinh($rop, $op, $rnd); $inex = Rmpfr_atanh($rop, $op, $rnd); Set $rop to the inverse hyperbolic cosine, sine or tangent of $op, rounded to the direction $rnd with the precision of $rop. Return 0 if the result is exact. $inex = Rmpfr_sec ($rop, $op, $rnd); $inex = Rmpfr_csc ($rop, $op, $rnd); $inex = Rmpfr_cot ($rop, $op, $rnd); Set $rop to the secant of $op, cosecant of $op, cotangent of $op, rounded in the direction RND. Return 0 if the result is exact. Return a negative value if the result is less than the actual value. Return a positive result if the return is greater than the actual value. $inex = Rmpfr_sech ($rop, $op, $rnd); $inex = Rmpfr_csch ($rop, $op, $rnd); $inex = Rmpfr_coth ($rop, $op, $rnd); Set $rop to the hyperbolic secant of $op, cosecant of $op, cotangent of $op, rounded in the direction RND. Return 0 if the result is exact. Return a negative value if the result is less than the actual value. Return a positive result if the return is greater than the actual value. $inex = Rmpfr_fac_ui($rop, $ui, $rnd); Set $rop to the factorial of $ui, rounded to the direction $rnd with the precision of $rop. $inex = Rmpfr_log1p ($rop, $op, $rnd); $inex = Rmpfr_log2p1 ($rop, $op, $rnd); $inex = Rmpfr_log10p1($rop, $op, $rnd); In Rmpfr_log1p set $rop = log( $op + 1). In Rmpfr_log2p1 set $rop = log2( $op + 1). In Rmpfr_log10p1 set $rop = log10($op + 1). In all three cases, round the result in the direction $rnd to the precision of $rop. $inex = Rmpfr_expm1 ($rop, $op, $rnd); $inex = Rmpfr_exp2m1 ($rop, $op, $rnd); $inex = Rmpfr_exp10m1($rop, $op, $rnd); In Rmpfr_expm1, set $rop to the exponential of $op followed by a subtraction of 1. $rop = (e ** $op) - 1. In Rmpfr_exp2p1, set $rop = (2 ** $op) - 1. In Rmpfr_exp10p1, set $rop = (10 ** $op) - 1. For all three, the result is rounded to the direction $rnd with the precision of $rop. $inex = Rmpfr_fma($rop, $op1, $op2, $op3, $rnd); Set $rop to $op1 * $op2 + $op3, rounded to the direction $rnd. $inex = Rmpfr_fmma($rop, $op1, $op2, $op3, $op4, $rnd); NOTE: Needs mpfr-4.0.0 or later Set $rop to $op1 * $op2 + $op3 * $op4, rounded to the direction $rnd. $inex = Rmpfr_fms($rop, $op1, $op2, $op3, $rnd); Set $rop to $op1 * $op2 - $op3, rounded to the direction $rnd. $inex = Rmpfr_fmms($rop, $op1, $op2, $op3, $op4, $rnd); NOTE: Needs mpfr-4.0.0 or later Set $rop to $op1 * $op2 - $op3 * $op4, rounded to the direction $rnd. $inex = Rmpfr_agm($rop, $op1, $op2, $rnd); Set $rop to the arithmetic-geometric mean of $op1 and $op2, rounded to the direction $rnd with the precision of $rop. Return zero if $rop is exact, a positive value if $rop is larger than the exact value, or a negative value if $rop is less than the exact value. $inex = Rmpfr_hypot ($rop, $op1, $op2, $rnd); Set $rop to the Euclidean norm of $op1 and $op2, i.e. the square root of the sum of the squares of $op1 and $op2, rounded in the direction $rnd. Special values are currently handled as described in Section F.9.4.3 of the ISO C99 standard, for the hypot function (note this may change in future versions): If $op1 or $op2 is an infinity, then plus infinity is returned in $rop, even if the other number is NaN. $inex = Rmpfr_ai($rop, $op, $rnd); # mpfr-3.0.0 and later only Set $rop to the value of the Airy function Ai on $op, rounded in the direction $rnd. When $op is NaN, $rop is always set to NaN. When $op is +Inf or -Inf, $rop is +0. The current implementation is not intended to be used with large arguments. It works with $op typically smaller than 500. For larger arguments, other methods should be used and will be implemented soon. $inex = Rmpfr_const_log2($rop, $rnd); Set $rop to the logarithm of 2 rounded to the direction $rnd with the precision of $rop. This function stores the computed value to avoid another calculation if a lower or equal precision is requested. Return zero if $rop is exact, a positive value if $rop is larger than the exact value, or a negative value if $rop is less than the exact value. $inex = Rmpfr_const_pi($rop, $rnd); Set $rop to the value of Pi rounded to the direction $rnd with the precision of $rop. This function uses the Borwein, Borwein, Plouffe formula which directly gives the expansion of Pi in base 16. Return zero if $rop is exact, a positive value if $rop is larger than the exact value, or a negative value if $rop is less than the exact value. $inex = Rmpfr_const_euler($rop, $rnd); Set $rop to the value of Euler's constant 0.577... rounded to the direction $rnd with the precision of $rop. Return zero if $rop is exact, a positive value if $rop is larger than the exact value, or a negative value if $rop is less than the exact value. inex = Rmpfr_const_catalan($rop, $rnd); Set $rop to the value of Catalan's constant 0.915... rounded to the direction $rnd with the precision of $rop. Return zero if $rop is exact, a positive value if $rop is larger than the exact value, or a negative value if $rop is less than the exact value. Rmpfr_free_cache(); Free the cache used by the functions computing constants if needed (currently 'mpfr_const_log2', 'mpfr_const_pi' and 'mpfr_const_euler'). Rmpfr_free_cache2($ui); # mpfr-4.0.0 and later only Free various caches and pools used by MPFR internally, as specified by $ui, which is a set of flags: a) those local to the current thread if flag MPFR_FREE_LOCAL_CACHE is set; b) those shared by all threads if flag MPFR_FREE_GLOBAL_CACHE is set. The other bits of $ui are currently ignored and are reserved for future use; they should be zero. Note: Rmpfr_free_cache2(MPFR_FREE_LOCAL_CACHE|MPFR_FREE_GLOBAL_CACHE) is currently equivalent to mpfr_free_cache(). Rmpfr_free_pool() # mpfr-4.0.0 and later only Free the pools used by mpfr internally. Note: This function is automatically called after the thread-local caches are freed (with mpfr_free_cache or mpfr_free_cache2). $inex = Rmpfr_beta($rop, $op1, $op2, $rnd); # mpfr-4.0.0 & # later only Set $rop to the beta function at $op1, $op2, rounded according to $rnd. $inex = Rmpfr_gamma($rop, $op, $rnd); $inex = Rmpfr_lngamma($rop, $op, $rnd); Set $rop to the value of the Gamma function on $op (and, respectively, its natural logarithm) rounded to the direction $rnd. Return zero if $rop is exact, a positive value if $rop is larger than the exact value, or a negative value if $rop is less than the exact value. 'Rmpfr_gamma' sets $rop to NaN when $op is negative. $inex = Rmpfr_gamma_inc($rop, $op1, $op2, $rnd); # mpfr-4.0.0 & # later only Set $rop to the value of the incomplete Gamma function on $op1 and $op2, rounded in the direction $rnd. When $op2 is zero and $op1 is a negative value, $rop is set to NaN. Note: the current implementation is slow for large values of $rop and $op, in which case some internal overflow might also occur. ($signp, $si) = Rmpfr_lgamma ($rop, $op, $rnd); Set $rop to the value of the logarithm of the absolute value of the gamma function on $op, rounded in the direction $rnd. The sign (1 or -1) of gamma($op) is returned in $signp. When $op is an infinity or a non-positive integer, +Inf is returned. When $op is NaN, -Inf or a negative integer, $signp is undefined, and when $op is 0, $signp is the sign of the zero. $inex = Rmpfr_digamma($rop, $op, $rnd); # mpfr-3.0.0 and later only Set $rop to digammma($op), rounded according to $rnd. $inex = Rmpfr_trigamma ($rop, $op, $rnd); # mpfr-4.3.0 and later only Set $rop to trigammma($op), rounded according to $rnd. $inex = Rmpfr_zeta($rop, $op, $rnd); $inex = Rmpfr_zeta_ui($rop, $ul, $rnd); Set $rop to the value of the Riemann Zeta function on 2nd arg, rounded to the direction $rnd. Return zero if $rop is exact, a positive value if $rop is larger than the exact value, or a negative value if $rop is less than the exact value. $inex = Rmpfr_erf($rop, $op, $rnd); Set $rop to the value of the error function on $op, rounded to the direction $rnd. Return zero if $rop is exact, a positive value if $rop is larger than the exact value, or a negative value if $rop is less than the exact value. $inex = Rmpfr_erfc($rop, $op, $rnd); Set $rop to the complementary error function on $op, rounded to the direction $rnd. Return zero if $rop is exact, a positive value if $rop is larger than the exact value, or a negative value if $rop is less than the exact value. $inex = Rmpfr_j0 ($rop, $op, $rnd); $inex = Rmpfr_j1 ($rop, $op, $rnd); $inex = Rmpfr_jn ($rop, $si2, $op, $rnd); Set $rop to the value of the first order Bessel function of order 0, 1 and $si2 on $op, rounded in the direction $rnd. When $op is NaN, $rop is always set to NaN. When $op is plus or minus Infinity, $rop is set to +0. When $op is zero, and $si2 is not zero, $rop is +0 or -0 depending on the parity and sign of $si2, and the sign of $op. $inex = Rmpfr_y0 ($rop, $op, $rnd); $inex = Rmpfr_y1 ($rop, $op, $rnd); $inex = Rmpfr_yn ($rop, $si2, $op, $rnd); Set $rop to the value of the second order Bessel function of order 0, 1 and $si2 on $op, rounded in the direction $rnd. When $op is NaN or negative, $rop is always set to NaN. When $op is +Inf, $rop is +0. When $op is zero, $rop is +Inf or -Inf depending on the parity and sign of $si2. $inex = Rmpfr_eint ($rop, $op, $rnd) Set $rop to the exponential integral of $op, rounded in the direction $rnd. See the MPFR documentation for details. As of mpfr-4.0.0 Rmpfr_eint() returns the value of the E1/eint1 function for negative input. (With previous versions of mpfr NaN was returned for negative argument.) $inex = Rmpfr_li2 ($rop, $op, $rnd); Set $rop to real part of the dilogarithm of $op, rounded in the direction $rnd. The dilogarithm function is defined here as the integral of -log(1-t)/t from 0 to x. $inex = Rmpfr_dot ($rop, \@op1, \@op2, $ui, $rnd); # mpfr-4.1.0 & # later only Set $rop to the dot product of elements of @op1 by those of @op2, whose common size is $ui (== scalar @op1), correctly rounded in the direction $rnd. This function is experimental, and does not yet handle intermediate overflows and underflows. ############# I-O FUNCTIONS $ui = Rmpfr_out_str([$prefix,] $op, $base, $digits, $round [, $suffix]); BEST TO USE TRmpfr_out_str INSTEAD Output $op to STDOUT, as a string of digits in base $base, rounded in direction $round. $base may be in the range 2 to 62 (or -36..-2, 2 .. 62 if Math::MPFR has been built against mpfr-4.1.0 or later). Print $digits significant digits exactly, or if $digits is 0, enough digits so that $op can be read back exactly (see Rmpfr_get_str). In addition to the significant digits, a decimal point at the right of the first digit and a trailing exponent in base 10, in the form 'eNNN', are printed If $base is greater than 10, '@' will be used instead of 'e' as exponent delimiter. The optional arguments, $prefix and $suffix, are strings that will be prepended/appended to the mpfr_out_str output. Return the number of bytes written (not counting those contained in $suffix and $prefix), or if an error occurred, return 0. (Note that none, one or both of $prefix and $suffix can be supplied.) $ui = TRmpfr_out_str([$prefix,] $stream, $base, $digits, $op, $round [, $suffix]); As for Rmpfr_out_str, except that there's the capability to print to somewhere other than STDOUT. Note that the order of the args is different (to match the order of the mpfr_out_str args). To print to STDERR: TRmpfr_out_str(*stderr, $base, $digits, $op, $round); To print to an open filehandle (let's call it $fh): TRmpfr_out_str(\*$fh, $base, $digits, $op, $round); $ui = Rmpfr_inp_str($rop, $base, $round); BEST TO USE TRmpfr_inp_str INSTEAD. Input a string in base $base from STDIN, rounded in direction $round, and put the read float in $rop. The string is of the form 'M@N' or, if the base is 10 or less, alternatively 'MeN' or 'MEN', or, if the base is 16, alternatively 'MpB' or 'MPB'. 'M' is the mantissa in the specified base, 'N' is the exponent written in decimal for the specified base, and in base 16, 'B' is the binary exponent written in decimal (i.e. it indicates the power of 2 by which the mantissa is to be scaled). The argument $base may be in the range 2 to 62. Special values can be read as follows (the case does not matter): '@NaN@', '@Inf@', '+@Inf@' and '-@Inf@', possibly followed by other characters; if the base is smaller or equal to 16, the following strings are accepted too: 'NaN', 'Inf', '+Inf' and '-Inf'. Return the number of bytes read, or if non-numeric characters were encountered in the input, return 0. If 0 is returned: 1) the non-numeric flag (which was initialised to 0) will be incremented. You can query/clear/reset the value of the flag with (resp.) nnumflag()/clear_nnum()/set_nnum() - all of which are documented below; 2) A warning will be emitted if $Math::MPFR::NNW is set to 1 (default is 0). $ui = TRmpfr_inp_str($rop, $stream, $base, $round); As for Rmpfr_inp_str, except that there's the capability to read from somewhere other than STDIN. To read from STDIN: TRmpfr_inp_str($rop, *stdin, $base, $round); To read from an open filehandle (let's call it $fh): TRmpfr_inp_str($rop, \*$fh, $base, $round); Rmpfr_dump($op); Output "$op\n" on stdout in base 2. As with 'Rmpfr_print_binary' the exponent is in base 10. $si = Rmpfr_fpif_export ($stream, $op); # Needs mpfr-4.0.0 $si = Rmpfr_fpif_export ($op, $stream); # Needs mpfr-4.0.0 Note: These function are experimental and their interface might change in future versions of mpfr. Export/import the number $op to/from the stream $stream in a floating-point interchange format. In particular one can export on a 32-bit computer and import on a 64-bit computer, or export on a little-endian computer and import on a big-endian computer. The precision of OP is stored too. The import function fails if the precision (which is read from the stream) is greater than MPFR_PREC_MAX. Return 0 if the export/import was successful. ######################## DISPLAYING INFS AND NANS Generally, these will be displayed as 'Inf', '-Inf' and 'NaN'. However, if you set $Math::MPFR::PERL_INFNAN to a TRUE value, then nvtoa($num) and numtoa($num) (which are documented below in 'MISCELLANEOUS') will display them in the same way that perl itself displays them. Note that nvtoa() and numtoa() expect a plain numeric perl scalar as their argument - not a Math::MPFR object. $Math::MPFR::PERL_INFNAN has the initial (default) value of 0. ########## EXCEPTIONS $inex = Rmpfr_subnormalize ($op, $si, $rnd); This function rounds $op emulating subnormal number arithmetic. See the MPFR documentation for mpfr_subnormalize at: www.mpfr.org/mpfr-current/mpfr.html#Function-and-Type-Index $si = Rmpfr_get_emin(); $si = Rmpfr_get_emax(); Return to $si the (current) smallest and largest exponents allowed for a floating-point variable. $si = Rmpfr_get_emin_min(); $si = Rmpfr_get_emin_max(); $si = Rmpfr_get_emax_min(); $si = Rmpfr_get_emax_max(); Return to $si the minimum and maximum of the smallest and largest exponents allowed for 'mpfr_set_emin' and 'mpfr_set_emax'. These values are implementation dependent $bool = Rmpfr_set_emin($si); $bool = Rmpfr_set_emax($si); Set the smallest and largest exponents allowed for a floating-point variable. Return a non-zero value when $si is not in the range of exponents accepted by the implementation (in that case the smallest or largest exponent is not changed), and zero otherwise. If the user changes the exponent range, it is her/his responsibility to check that all current floating-point variables are in the new allowed range (for example using 'Rmpfr_check_range', otherwise the subsequent behaviour will be undefined, in the sense of the ISO C standard. $inex = Rmpfr_check_range($op, $si, $rnd); This function assumes that $op is the correctly rounded value of some real value X in the direction $rnd and some extended exponent range, and that $si is the corresponding ternary value. Thus $si is negative if $op is smaller than X, positive if $op is larger than X, and zero if $op equals X. This function modifies $op if needed to be in the current range of acceptable values. It generates an underflow or an overflow if the exponent of $op is outside the current allowed range; the value of $si may be used to avoid a double rounding. This function returns zero if the new value of $op equals the exact one X, a positive value if that new value is larger than X, and a negative value if it is smaller than X. Note that unlike most functions, the new result $op is compared to the (unknown) exact one X, not the input value $op, i.e., the ternary value is propagated. Note: If $op is an infinity and $inex is different from zero (i.e., if the rounded result is an inexact infinity), then the overflow flag is set. Rmpfr_set_underflow(); Rmpfr_set_overflow(); Rmpfr_set_nanflag(); Rmpfr_set_inexflag(); Rmpfr_set_erangeflag(); Rmpfr_set_divby0(); # mpfr-3.1.0 and later only Rmpfr_clear_underflow(); Rmpfr_clear_overflow(); Rmpfr_clear_nanflag(); Rmpfr_clear_inexflag(); Rmpfr_clear_erangeflag(); Rmpfr_clear_divby0(); # mpfr-3.1.0 and later only Set/clear the underflow, overflow, invalid, inexact, erange and divide-by-zero flags. Rmpfr_clear_flags(); Clear all global flags (underflow, overflow, inexact, invalid, erange and divide-by-zero). $bool = Rmpfr_underflow_p(); $bool = Rmpfr_overflow_p(); $bool = Rmpfr_nanflag_p(); $bool = Rmpfr_inexflag_p(); $bool = Rmpfr_erangeflag_p(); $bool = Rmpfr_divby0_p(); # mpfr-3.1.0 and later only Return the corresponding (underflow, overflow, invalid, inexact, erange, divide-by-zero) flag, which is non-zero if the flag is set. Rmpfr_flags_clear($mask); # needs mpfr-4.0.0 or later Rmpfr_flags_set($mask); # needs mpfr-4.0.0 or later $mask2 = Rmpfr_flags_test($mask); # needs mpfr-4.0.0 or later $mask = Rmpfr_flags_save(); # needs mpfr-4.0.0 or later Rmpfr_flags_restore($mask1, $mask2); # needs mpfr-4.0.0 or later $mask is an integer value resulting from OR'ing (or adding) any of the following constants together: MPFR_FLAGS_UNDERFLOW MPFR_FLAGS_OVERFLOW MPFR_FLAGS_NAN MPFR_FLAGS_INEXACT MPFR_FLAGS_ERANGE MPFR_FLAGS_DIVBY0 MPFR_FLAGS_ALL MPFR_FLAGS_ALL is the same as all of those constants OR'ed (added) together. Examples: Clear the divby0 and nan flags, without affecting the status of any other flags: Rmpfr_flags_clear(MPFR_FLAGS_DIVBY0|MPFR_FLAGS_NAN); Set the underflow and erange flags, without affecting the status of any other flags: Rmpfr_flags_set(MPFR_FLAGS_UNDERFLOW|MPFR_FLAGS_ERANGE); Test the status of specific flags, ignoring all other flags. This particular example will set $mask to the value of MPFR_FLAGS_NAN if the nan flag is set - else $mask will be set to zero: $mask = Rmpfr_flags_test(MPFR_FLAGS_UNDERFLOW); Return all flags: $mask = Rmpfr_flags_save(); Equivalently, this can be done with: $mask = Rmpfr_flags_test(MPFR_FLAGS_ALL); Set flags specified in $mask2 to the state specified in $mask1, For this example, the overflow flag will be set && the nan flag will be cleared. The underflow flag will remain untouched. $mask1 = MPFR_FLAGS_UNDERFLOW | MPFR_FLAGS_OVERFLOW; $mask2 = MPFR_FLAGS_OVERFLOW | MPFR_FLAGS_NAN; Rmpfr_flags_restore($mask1, $mask2); ############# MISCELLANEOUS $rop = nv2mpfr($sv); Return a new Math::MMPFR object whose value is the same as that held by $sv, with the same precision as that of $Config{nvtype}. $str = doubletoa($double [, $x]); # Available only when # $Config{nvsize} == 8. # Else use nvtoa(). Sets $str to the value of $double. $str will appear in standard decimal format such that the condition ($str == $double) is true. The grisu3 algorithm used by this function, whilst very quick, will fail for about 0.5% of values. When this happens doubletoa will (by default) fall back to using nvtoa() - which is slower, but reliable. Alternatively, providing a second argument to doubletoa (any scalar will do) will ensure that it falls back to returning sprintf("%.17g", $double).This will be an accurate return, and it will be quicker than the nvtoa() fallback, but it often provides more digits than are necessary. Whenever doubletoa reverts to a fallback routine, $Math::MPFR::doubletoa_fallback (which is initially set to 0) will be incremented. This feature can be disabled by providing the FB=0 argument to the 'perl Makefile.PL' step of the Math::MPFR build. $str = nvtoa($NV); # Available irrespective of $Config{nvsize} # and $Config{nvtype} Sets $str to the value of $NV. $str will appear in standard decimal format, containing the *minimum* number of digits such that the condition ($str == $NV) is true. NOTE 1: Except for perls whose nvtype is __float128: 1) perl versions prior to 5.30.0 are buggy in their assignment of values to the NV; 2) perl versions from 5.30.0 on that don't define $Config{d_strtod} (or respectively $Config{d_strtold} for -Duselongdouble builds) are also buggy in their assignment of values to the NV. The nvtoa() function looks only at the value that was passed to it - which, with such buggy perls, may differ from the intended value by a few ULPs. On these buggy perls, the bug can be avoided by assigning with atonv() - which requires mpfr-3.1.6 or later. NOTE 2: Be wary of values assigned by perl to double-double NVs, as such assignments may also be buggy, irrespective of the perl version. Again, with these perls, assign using atonv() - which requires mpfr-3.1.6 or later. With double-double NVs, nvtoa() currently requires mpfr-4.0.0 or later. $str = mpfrtoa($op [, $uv]); # $uv is optional, but mysterious # and discouraged !!! As for nvtoa(), except that mpfrtoa() instead takes a Math::MPFR object as its argument. Sets $str to the value of $op. $str will appear in standard decimal format, containing the *minimum* number of significant digits such that the condition ($str == $op) is true when the current default precision equals the precision of $op. (The overloaded '==' operator evaluates $str according to the current default precision, so that condition might be untrue whenever the default precision != the precision of $op.) The second (optional) arg became available with Math-MPFR-4.24 and it can alter the behaviour of mpfrtoa when the value of $uv is greater than the precision of $op. AFAIK, it is used only (and arcanely in Math:FakeDD::dd_repro(), and the option will be removed as soon as Math::FakeDD::dd_repro() can be adapted to that removal. $str = anytoa($op); # $op precision must be 53 or 64 or 113 or 2098 For example, you want to know what nvtoa(sqrt 3) would return on a perl whose nvtype is the 113-bit precision __float128 (or IEEE-754 128-bit long double) but you don't have access to such a perl. You can do: my $bits = 113; Rmpfr_set_default_prec($bits); $op = sqrt(Math::MPFR->new('3')); my $s = anytoa($op); print "$s\n"; # 1.7320508075688772935274463415058723 Similarly, changing $bits to 53, or 64, or 2098 would provide the same as nvtoa(sqrt 3) for (respectively) the 53-bit precision double nvtype , the 64-bit extended precision long double nvtype, and the double-double nvtype. The value returned will be the same as returned by mpfrtoa($op) unless: 1) $op holds a finite value that is of such magnitude that it will become (+ or -) Inf when converted to the specified nvtype; or 2) $op holds a finite non-zero value that is so close to zero that the specified nvtype will either round it to zero or denormalize it; or 3) the precision of $op is 2098 bits. $mask = nvtoa_test($str, $arg [, $debug]); DEPRECATED - dragon_test (see below) is recommended instead. If $arg is a Math::MPFR object, then $str must be the string returned by mpfrtoa($arg). Else it must be the string returned by nvtoa($arg). Otherwise, nvtoa_test is essentially the same as dragon_test. If you want to back yourself to provide the appropriate $str/$arg combination, then please feel free to keep using nvtoa_test until such time as it is removed. $mask = dragon_test($arg [, $debug]); If $debug is provided and matches /debug/i, then some debug info is output during the running of this function. $arg can be either an IV or an NV or a Math::MPFR object. For an IV or NV we test the string returned by nvtoa($arg) for correctness. For a Math::MPFR object we test the string returned by mpfrtoa($arg) for correctness. In both cases we establish that the string will assign to $arg, and that the mantissa portion of the string also contains the minimum number of significant decimal digits required for that round trip to succeed. $mask is initially set to zero. If the string assigns to $arg (as it should) then $mask is set to 1. Also, we chop the least significant digit off the mantissa portion of the string, and add 2 to $mask if this chopped string assigns to a value less than $arg. Then we increment the least significant mantissa digit of this chopped string - and add 4 to $mask if this chopped-and-incremented string assigns to a value greater than $arg. Also, we check that the mantissa portion of $str contains no unwelcome trailing zeroes - and add 8 to $mask if this check passes. $mask is then returned. If all is correct, it's value will be 15. If the value of the returned $mask is not 15, then we can determine which part(s) of the test failed by examining $mask's 4 lowest bits. In the event of a failure, re-running the test with 'debug' will provide some clarifying info. For inf, nan, and single-digit mantissas, we do only the initial test and return 15 if that test has passed, or 0 if that test has failed. (The other 3 tests don't really apply to these cases.) $str = numtoa($sv); As for nvtoa() but prints out UVs and IVs in integer format. (If UV-precision is greater than NV-precision then nvtoa() output can lose precision as it prints out UVs and IVs in floating point format.) $double = atodouble($str); # Needs mpfr-3.1.6 or later Sets $double to the value of the double that's represented by the string $str. If $Config{nvtype} is double, it therefore returns the same value as atonv. See atonv() below. $NV = atonv($str); # Needs mpfr-3.1.6 or later Sets $NV to the NV value represented by the string $str. If $str expresses a base 2 value, begin it with '0b' or '0B'. If $str expresses a base 16 value, begin it with '0x' or '0X. For example: atonv('0x0.89p5'), atonv('0x0.112@2'), atonv('17.125') and atonv('0b0.10001001e5') all return 17.125. NOTE: ORIGINALLY TOOK 2 ARGUMENTS - NOW TAKES ONLY 1, as of Math-MPFR-4.07. $sv = atonum($str); # Needs mpfr-3.1.6 or later If $str numifies to an IV, return that IV. Else return the NV that is returned by atonv($str). $ret = decimalize($op [, $anything]); # 2nd (optional) arg # can be any scalar. If no second argument is provided, return an exact base 10 string representation of the value held in $op. Else, instead return the number of decimal digits (not counting leading zeros) contained in the significand of that "exact base 10 representation", as estimated by decimalize(). This value could be one greater than the actual number of those significand digits. If a second arg is supplied && $op is Inf or NaN or Zero, then the returned value will be zero. NOTE: https://www.exploringbinary.com/maximum-number-of-decimal-digits-in-binary-floating-point-numbers/ explains that the maximum number of significant digits returned for a double precision value will be 767: 1074 + floor(log10(2**53-1) / 2**1074))+1 = 767 $bool = check_exact_decimal($str, $op); Can be used to verify the string returned by decimalize(). Return 1 if $str is an exact decimal representation of the value held in $op. Else return 0. $MPFR_version = Rmpfr_get_version(); Returns the version of the MPFR library (eg 4.0.2) being used by Math::MPFR. $GMP_version = Math::MPFR::gmp_v(); Returns the version of the gmp library (eg. 4.1.3) being used by the mpfr library that's being used by Math::MPFR. The function is not exportable. $ui = MPFR_VERSION; An integer whose value is dependent upon the 'major', 'minor' and 'patchlevel' values of the MPFR library against which Math::MPFR was built. This value is from the mpfr.h that was in use when the compilation of Math::MPFR took place. $ui = MPFR_VERSION_MAJOR; The 'x' in the 'x.y.z' of the MPFR library version. This value is from the mpfr.h that was in use when the compilation of Math::MPFR took place. $ui = MPFR_VERSION_MINOR; The 'y' in the 'x.y.z' of the MPFR library version. This value is from the mpfr.h that was in use when the compilation of Math::MPFR took place. $ui = MPFR_VERSION_PATCHLEVEL; The 'z' in the 'x.y.z' of the MPFR library version. This value is from the mpfr.h that was in use when the compilation of Math::MPFR took place. $string = MPFR_VERSION_STRING; $string is set to the version of the MPFR library (eg 2.1.0) against which Math::MPFR was built. This value is from the mpfr.h that was in use when the compilation of Math::MPFR took place. $ui = MPFR_VERSION_NUM($major, $minor, $patchlevel); Returns the value for MPFR_VERSION for "MPFR-$major.$minor.$patchlevel". $str = Rmpfr_get_patches(); Return a string containing the ids of the patches applied to the MPFR library (contents of the 'PATCHES' file), separated by spaces. Note: If the program has been compiled with an older MPFR version and is dynamically linked with a new MPFR library version, the ids of the patches applied to the old (compile-time) MPFR version are not available (however this information should not have much interest in general). $bool = Rmpfr_buildopt_tls_p(); # mpfr-3.0.0 and later only Return a non-zero value if mpfr was compiled as thread safe using compiler-level Thread Local Storage (that is mpfr was built with the '--enable-thread-safe' configure option), else return zero. $bool = Rmpfr_buildopt_decimal_p(); # mpfr-3.0.0 and later only Return a non-zero value if mpfr was compiled with decimal float support (that is mpfr was built with the '--enable-decimal-float' configure option), return zero otherwise. $bool = Rmpfr_buildopt_float128_p(); # mpfr-4.0.0 and later only Return a non-zero value if mpfr was compiled with __float128 support (that is mpfr was built with the '--enable-decimal-float' configure option), return zero otherwise. $bool = Rmpfr_buildopt_gmpinternals_p(); # mpfr-3.1.0 and later only Return a non-zero value if mpfr was compiled with gmp internals (that is, mpfr was built with either '--with-gmp-build' or '--enable-gmp-internals' configure option), return zero otherwise. $bool = Rmpfr_buildopt_sharedcache_p(); # mpfr-4.0.0 and later only Return a non-zero value if MPFR was compiled so that all threads share the same cache for the one MPFR constant, like `mpfr_const_pi' or `mpfr_const_log2' (that is, MPFR was built with the `--enable-shared-cache' configure option), return zero otherwise. $str = Rmpfr_buildopt_tune_case(); # mpfr-3.1.0 and later only Return a string saying which thresholds file has been used at compile time. This file is normally selected from the processor type. If "make tune" has been used, then it will return "src/mparam.h". Otherwise it will say which official mparam.h file has been used. $inex = Rmpfr_rint($rop, $op, $rnd); $inex = Rmpfr_ceil($rop, $op); $inex = Rmpfr_floor($rop, $op); $inex = Rmpfr_round($rop, $op); $inex = Rmpfr_roundeven($rop, $op); # mpfr-4.0.0 and later only $inex = Rmpfr_trunc($rop, $op); Set $rop to $op rounded to an integer. 'Rmpfr_ceil' rounds to the next higher representable integer, 'Rmpfr_floor' to the next lower, 'Rmpfr_round' to the nearest representable integer, rounding halfway cases away from zero, 'Rmpfr_roundeven' to the nearest representable integer, rounding halfway cases with the even- rounding rule and 'Rmpfr_trunc' to the representable integer towards zero. 'Rmpfr_rint' behaves like one of these four functions, depending on the rounding mode. Further to its usual meaning, $inex is 0 when $op is an integer representable in $rop, 1 or -1 when $op is an integer that is not representable in $rop, 2 or -2 when $op is not an integer. $inex = Rmpfr_rint_ceil($rop, $op, $rnd); $inex = Rmpfr_rint_floor($rop, $op, $rnd); $inex = Rmpfr_rint_round($rop, $op, $rnd); $inex = Rmpfr_rint_roundeven($rop, $op, $rnd); # mpfr-4.0.0 & later $inex = Rmpfr_rint_trunc($rop, $op, $rnd); Set $rop to $op rounded to an integer. 'Rmpfr_rint_ceil' rounds to the next higher or equal integer, 'Rmpfr_rint_floor' to the next lower or equal integer, 'Rmpfr_rint_round' to the nearest integer, rounding halfway cases away from zero, 'Rmpfr_rint_roundeven' to the nearest integer,rounding halfway cases to the nearest even integer and 'Rmpfr_rint_trunc' to the next integer towards zero. If the result is not representable, it is rounded in the direction $rnd. $inex = Rmpfr_frac($rop, $op, $round); Set $rop to the fractional part of $op, having the same sign as $op, rounded in the direction $round (unlike in 'mpfr_rint', $round affects only how the exact fractional part is rounded, not how the fractional part is generated). $inex = Rmpfr_modf ($rop1, $rop2, $op, $rnd); Set simultaneously $rop1 to the integral part of $op and $rop2 to the fractional part of $op, rounded in the direction RND with the corresponding precision of $rop1 and $rop2 (equivalent to 'Rmpfr_trunc($rop1, $op, $rnd)' and 'Rmpfr_frac($rop1, $op, $rnd)'). The variables $rop1 and $rop2 must be different. Return 0 if both results are exact. $inex = Rmpfr_remainder($rop, $op1, $op2, $rnd); $inex = Rmpfr_fmod($rop, $op1, $op2, $rnd); ($si2, $si) = Rmpfr_remquo ($rop, $op1, $op2, $rnd); ($si2, $si) = Rmpfr_fmodquo ($rop, $op1, $op2, $rnd); # mpfr-4.0.0 & # later only Set $rop to the value of $op - N*$op2, rounded according to the direction $rnd, where N is the integer quotient of $op1 divided by $op2, defined as follows: N is rounded toward zero for 'Rmpfr_fmod' and 'Rmpfr_fmodquo', and to the nearest integer (ties rounded to even) for 'mpfr_remainder' and 'mpfr_remquo'. Special values are handled as described in Section F.9.7.1 of the ISO C99 standard: If $op1 is infinite or $op2 is zero, $rop is NaN. If $op2 is infinite and $op1 is finite, $rop is $op1 rounded to the precision of $rop. If $rop is zero, it has the sign of $op1. The return value is the ternary value corresponding to $rop. Additionally, 'Rmpfr_remquo' and 'Rmpfr_fmodquo store the low significant bits from the quotient in $si2 (more precisely the number of bits in a 'long' minus one), with the sign of $op1 divided by $op2 (except if those low bits are all zero, in which case zero is returned). Note that $op1 may be so large in magnitude relative to $op2 that an exact representation of the quotient is not practical. 'Rmpfr_remainder' and Rmpfr_remquo' functions are useful for additive argument reduction. $inex = Rmpfr_fmod_ui($rop, $op1, $ui, $rnd); As for Rmpfr_fmod(), above, except that the 3rd arg is an unsigned long int instead of a Math::MPFR object. This function was introduced in mpfr-4.2.0-dev, but is implemented (suboptimally) in Math::MPFR built against older versions of the mpfr library. $bool = Rmpfr_integer_p($op); Return non-zero if $op is an integer. Rmpfr_nexttoward($op1, $op2); If $op1 or $op2 is NaN, set $op1 to NaN. Otherwise, if $op1 is different from $op2, replace $op1 by the next floating-point number (with the precision of $op1 and the current exponent range) in the direction of $op2, if there is one (the infinite values are seen as the smallest and largest floating-point numbers). If the result is zero, it keeps the same sign. No underflow or overflow is generated. Rmpfr_nextabove($op1); Equivalent to 'mpfr_nexttoward' where $op2 is plus infinity. Rmpfr_nextbelow($op1); Equivalent to 'mpfr_nexttoward' where $op2 is minus infinity. $inex = Rmpfr_min($rop, $op1, $op2, $round); Set $rop to the minimum of $op1 and $op2. If $op1 and $op2 are both NaN, then $rop is set to NaN. If $op1 or $op2 is NaN, then $rop is set to the numeric value. If $op1 and $op2 are zeros of different signs, then $rop is set to -0. $inex = Rmpfr_max($rop, $op1, $op2, $round); Set $rop to the maximum of $op1 and $op2. If $op1 and $op2 are both NaN, then $rop is set to NaN. If $op1 or $op2 is NaN, then $rop is set to the numeric value. If $op1 and $op2 are zeros of different signs, then $rop is set to +0. $IV = Math::MPFR::nnumflag(); # not exported Returns the value of the non-numeric flag. This flag is initialized to zero, but incremented by 1 whenever the a string containing non-numeric characters is passed to an mpfr function. The value of the flag therefore tells us how many times such strings were passed to mpfr functions . The flag can be reset to 0 by running clear_nnum(). $IV = Math::MPFR::nok_pokflag(); # not exported Returns the value of the nok_pok flag. This flag is initialized to zero, but incremented by 1 whenever a scalar that is both a float (NOK) and string (POK) is passed to new() or to an overloaded operator. The value of the flag therefore tells us how many times such events occurred . The flag can be reset to 0 by running clear_nok_pok(). Math::MPFR::set_nnum($IV); # not exported Resets the global non-numeric flag to the value specified by $IV. Math::MPFR::set_nok_pok($IV); # not exported Resets the nok_pok flag to the value specified by $IV. Math::MPFR::clear_nnum(); # not exported Resets the global non-numeric flag to 0.(Essentially the same as running set_nnum(0).) Math::MPFR::clear_nok_pok(); # not exported Resets the nok_pok flag to 0.(Essentially the same as running set_nok_pok(0).) $bytes = Math::MPFR::bytes($val, $bits); (The semantics for calling this function have changed as of Math-MPFR-4.13.) $val must either be a string (eg '1.613e-45', '2.3', '0x17.8') or a Math::MPFR object. $bits must be one of 53, 64, 2098 or 113. $bytes will be set to the hex representation of $val. If $bits is 53, $bytes will display the byte structure (in hex) of the standard 8-byte double, $val. If $bits is 64, the structure returned will be that of $val as an extended precision 10-byte long double. If $bits is 2098, the structure returned will be that of $val as the 16-byte IBM doubledouble. If $bits is 113, the structure returned will be that of $val as the quad precision 16-byte IEEE long double (or __float128, which is identical in byte structure). eg: bytes('1.3', 53) returns 3ff4cccccccccccd bytes('1.3', 64) returns 3fffa666666666666666 bytes('1.3', 2098) returns 3ff4cccccccccccdbc8999999999999a bytes('1.3', 113) returns 3fff4ccccccccccccccccccccccccccd If $val is a Math::MPFR object, its precision must be $bits. For many architectures and mpfr configurations, the structures for all 4 allowed values of $bits will be accessible. In some cases, however, $bits values of 64 and/or 113 might throw a fatal error (with diagnostic message stating that the requested byte structure is not currently available). $si = IOK_flag($sv); # $sv is a perl scalar variable. $si = NOK_flag($sv); $si = POK_flag($sv); Return 0 if $sv's IOK/NOK/POK flag is unset. Else return 1. If the IsUV flag is set, then IOK_flag() returns 2, thereby indicating that both the IOK and IsUV flags are set (and that the integer value held by $sv should therefore be treated as unsigned). ############## RANDOM NUMBERS Rmpfr_urandomb(@r, $state); Each member of @r is a Math::MPFR object. $state is a reference to a gmp_randstate_t structure. Set each member of @r to a uniformly distributed random float in the interval 0 <= $_ < 1. Before using this function you must first create $state by calling one of the 4 Rmpfr_randinit functions, then seed $state by calling one of the 2 Rmpfr_randseed functions. The memory associated with $state will be freed automatically when $state goes out of scope. Rmpfr_random2($rop, $si, $ui); # not implemented in # mpfr-3.0.0 and later Attempting to use this function when Math::MPFR has been built against mpfr-3.0.0 (or later) will cause the program to die, with an appropriate error message. Generate a random float of at most abs($si) limbs, with long strings of zeros and ones in the binary representation. The exponent of the number is in the interval -$ui to $ui. This function is useful for testing functions and algorithms, since this kind of random numbers have proven to be more likely to trigger corner-case bugs. Negative random numbers are generated when $si is negative. $si = Rmpfr_urandom ($rop, $state, $rnd); # mpfr-3.0.0 and # later only Generate a uniformly distributed random float. The floating-point number $rop can be seen as if a random real number is generated according to the continuous uniform distribution on the interval[0, 1] and then rounded in the direction RND. Before using this function you must first create $state by calling one of the Rmpfr_randinit functions (below), then seed $state by calling one of the Rmpfr_randseed functions. $si = Rmpfr_grandom($rop1, $rop2, $state, $rnd); Available only with mpfr-3.1.x. (Was deprecated in 4.0.0.) Use Rmpfr_nrandom() if Rmpfr_grandom() is unavailable. This function will croak with an appropriate message if Math::MPFR is built against an mpfr version other than 3.1.x. Generate two random floats according to a standard normal gaussian distribution. The floating-point numbers $rop1 and $rop2 can be seen as if a random real number were generated according to the standard normal gaussian distribution and then rounded in the direction $rnd. Before using this function you must first create $state by calling one of the Rmpfr_randinit functions (below), then seed $state by calling one of the Rmpfr_randseed functions. $si = Rmpfr_nrandom ($rop, $state, $rnd); # mpfr-4.0.0 and # later only Generate a random floating-point number according to a standard normal Gaussian distribution (with mean zero and variance one). The floating-point number $rop can be seen as if a random real number were generated according to the standard normal Gaussian distribution and then rounded in the direction $rnd. This function is more efficient than Rmpfr_grandom. $si = Rmpfr_erandom($rop, $state, $rnd); # mpfr-4.0.0 and # later only Generate one random floating-point number according to an exponential distribution, with mean one. Other characteristics are identical to 'Rmpfr_nrandom'. $state = Rmpfr_randinit_default(); Initialise $state with a default algorithm. This will be a compromise between speed and randomness, and is recommended for applications with no special requirements. $state = Rmpfr_randinit_mt(); Initialize state for a Mersenne Twister algorithm. This algorithm is fast and has good randomness properties. $state = Rmpfr_randinit_lc_2exp($a, $c, $m2exp); This function is not tested in the test suite. Use with caution - I often select values here that cause Rmpf_urandomb() to behave non-randomly. Initialise $state with a linear congruential algorithm: X = ($a * X + $c) % 2 ** $m2exp The low bits in X are not very random - for this reason only the high half of each X is actually used. $c and $m2exp are both unsigned longs. $a can be any one of Math::GMP, or Math::GMPz objects. Or it can be a string. If it is a string of hex digits it must be prefixed with either OX or Ox. If it is a string of octal digits it must be prefixed with 'O'. Else it is assumed to be a decimal integer. No other bases are allowed. $state = Rmpfr_randinit_lc_2exp_size($ui); Initialise state as per Rmpfr_randinit_lc_2exp. The values for $a, $c and $m2exp are selected from a table, chosen so that $ui bits (or more) of each X will be used. Rmpfr_randseed($state, $seed); $state is a reference to a gmp_randstate_t structure (the return value of one of the Rmpfr_randinit functions). $seed is the seed. It can be any one of Math::GMP, or Math::GMPz objects. Or it can be a string of digits. If it is a string of hex digits it must be prefixed with either OX or Ox. If it is a string of octal digits it must be prefixed with 'O'. Else it is assumed to be a decimal integer. No other bases are allowed. Rmpfr_randseed_ui($state, $ui); $state is a reference to a gmp_randstate_t structure (the return value of one of the Rmpfr_randinit functions). $ui is the seed. ######### INTERNALS $bool = Rmpfr_can_round($op, $ui, $rnd1, $rnd2, $p); Assuming $op is an approximation of an unknown number X in direction $rnd1 with error at most two to the power E(b)-$ui where E(b) is the exponent of $op, returns 1 if one is able to round exactly X to precision $p with direction $rnd2, and 0 otherwise. This function *does not modify* its arguments. $str = Rmpfr_print_rnd_mode($rnd); Return a string ("MPFR_RNDD", "MPFR_RNDU", "MPFR_RNDN", "MPFR_RNDZ", "MPFR_RNDA") corresponding to the rounding mode $rnd, or return undef if $rnd is an invalid rounding mode. $si = Rmpfr_get_exp($op); Return to $si the exponent of $op. The behavior for nan, infinity or zero is undefined. $si = Rmpfr_set_exp($op, $si); Set the exponent of $op if $si is in the current exponent range, and return 0 (even if $op is not a non-zero ordinary number); otherwise, return a non-zero value. $si = Rmpfr_signbit ($op); Return a non-zero value if $op has its sign bit set (i.e. if it is negative, -0, or a NaN whose representation has its sign bit set). $si2 = Rmpfr_setsign ($rop, $op, $si, $rnd); Set the value of $rop from $op, rounded towards the given direction $rnd, then set/clear its sign bit if $si is true/false (even when $op is a NaN). $si = Rmpfr_copysign ($rop, $op1, $op2, $rnd); Set the value of $rop from $op1, rounded towards the given direction $rnd, then set its sign bit to that of $op2 (even when $op1 or $op2 is a NaN). This function is equivalent to: Rmpfr_setsign ($rop, $op1, Rmpfr_signbit ($op2), $rnd)'. #################### OPERATOR OVERLOADING Overloading works with numbers, strings (bases 2, 10, and 16 only - see step '4.' below) and Math::MPFR objects. Overloaded operations are performed using the current "default rounding mode" (which you can determine using the 'Rmpfr_get_default_rounding_mode' function, and change using the 'Rmpfr_set_default_rounding_mode' function). Be aware that when you use overloading with a string operand, the overload subroutine converts that string operand to a Math::MPFR object with *current default precision*, and using the *current default rounding mode*. Note that any comparison using the spaceship operator ( <=> ) will return undef if either/both of the operands is a NaN. All comparisons ( < <= > >= == != <=> ) involving one or more NaNs will set the erange flag. For the purposes of the overloaded 'not', '!' and 'bool' operators, a "false" Math::MPFR object is one whose value is either 0 (including -0) or NaN. (A "true" Math::MPFR object is, of course, simply one that is not "false".) The following operators are overloaded: + - * / % ** sqrt (Return object has default precision) += -= *= /= %= **= ++ -- (Precision remains unchanged) < <= > >= == != <=> ! bool abs atan2 cos sin log exp (Return object has default precision) int (On perl 5.8+ only, NA on perl 5.6. The return object has default precision) "" (Interpolates the value of the Math::MPFR object to a decimal string) << >> <<= >>= (The Math::MPFR object is first truncated to an integer value. Left shifts will increase the exponent by the value of the given " left shift" argument. For right shifts, the Math::MPFR object's value is then altered according to the rules of integer right shifts. Thereby, for both left and right shifts the resultant value of the object is an integer value. Negative values for the 'shift' argument are allowed, in which case the shift value is multiplied by -1 and the direction of the shift is reversed. This is consistent with perl's shifting of NVs.) = (The copy has the same precision as the copied object.) NOTE: Making use of the '=' overloading is not recommended unless you understand its caveats. See 'perldoc overload' and read it thoroughly, including the documentation regarding 'copy constructors'. Furthermore, all overloaded comparisons ( < <= > >= == != <=> ) between Math::MPFR and Math::GMPz objects or between Math::MPFR and Math::GMPq objects are permitted. Comparison oprations between Math::MPFR and Math::GMP objects must be constructed such that Math::MPFR (not Math::GMP) overloading is invoked. Some additional cross-class overloading is also allowed. Let $M be a Math::MPFR object, and $G be any one of a Math::GMPz, Math::GMPq, or Math::GMP object. Then it is now permissible to do: $M + $G; $M += $G; $M - $G; $M -= $G; $M * $G; $M *= $G; $M / $G; $M /= $G; $M % $G; (Wraps the mpfr_fmod function) $M %= $G; (Wraps the mpfr_fmod function) $M ** $G; $M **= $G; YMMV if you use old versions of Math::GMPz and Math::GMPq, but if you have Math-GMPz-0.63 (or later) and Math-GMPq-0.61 (or later), and $G is either a Math::GMPz or Math::GMPq object, then it is also permissible to do: $G + $M; $G += $M; $G - $M; $G -= $M; $G * $M; $G *= $M; $G / $M; $G /= $M; $G % $M; (Wraps the mpfr_fmod function) $G %= $M; (Wraps the mpfr_fmod function) $G ** $M; $G **= $M; NOTE: In cross-class overloading a ** (power) or % (mpfr_fmod) operation that involves a Math::GMPq object, the value of the Math::GMPq object is assigned to a Math::MPFR object - using current default precision and current default rounding mode. Otherwise, the argument $G will be evaluated to "infinite" precision. The returned (Math::MPFR object) result will have been rounded to default precision, using default rounding mode. To determine the type and value of the second argument received by the overloading subroutines, we work through the following steps (in order), using the first value we find, or croaking if we get to step 6: 1. If the variable is a UV then that value is used. The variable is considered to be a UV if the IOK and IsUV flags are set. 2. If the variable is an IV, then that value is used. The variable is considered to be an IV if the IOK flag is set. 3. If the variable is a string (ie the POK flag is set) then the value of that string is used. If the POK flag is set, but the string is not a valid number, the subroutine croaks with an appropriate error message. If the string starts with '0b' or '0B' it is regarded as a base 2 number. If it starts with '0x' or '0X' it is regarded as a base 16 number. Otherwise it is regarded as a base 10 number. The value is then handed to a temporary Math::MPFR object that has current default precision. Any rounding required will be done in accordance with current default rounding mode. See "STRING OVERLOADING ANOMALY" (below) for an example of possible anomalies regarding string overloading. 4. If the variable is an NV (floating point value) then that value is used. The variable is considered to be an NV if the NOK flag is set. Note therefore, that if the variable is both an NV (NOK flag set) and PV (POK flag also set) then the string value in the PV slot will be used. This is probably, but not necessarily, what you want, and it's recommended not to pass such values to the overloaded operators. 5. If the variable is a Math::MPFR, Math::GMPz, or Math::GMPq, or Math::GMP object then the value of that object is used. If the particular operation does not accept the given type of object, then the operation dies with an appropriate error message if such an object is received. 6. If none of the above is true, then the second variable is deemed to be of an invalid type. The operation croaks with an appropriate error message. ##################### STRING OVERLOADING ANOMALY An example, when $Config{ivsize} == 8, default precision <= 63, default rounding mode is either MPFR_RNDN, MPFR_RNDU or MPFR_RNDA : my $f = Math::MPFR->new(2 ** 64); # 0x1p+64 my $i = 18446744073709551615; # 1 less than 2 ** 64 print ($f <=> $i ); # prints 1 print ($f <=> "$i"); # prints 0 If you want an integer string in an overloaded expression to be evaluated to its full (arbitrary) precision, then convert it to a Math::GMPz object first: print ($f <=> Math::GMPz->new("$i")); # prints 1 See t/anomaly.t in the test suite for further examples. ##################### FORMATTED OUTPUT NOTE: Bear in mind that, if the variable to be formatted by Rmpfr_printf/Rmpfr_fprintf/Rmpfr_sprintf/Rmpfr_snprintf is a normal perl string or numeric scalar (ie PV or IV or NV) then the formatting will actually be handled by the underlying gmp/mpfr C functionality, and not by the (more lenient) perl formatting functionality. For example, Rmpfr_printf("%.17g", 65416) will output rubbish, while printf("%.17g", 65416) will output 65416. But then ... why would you invoke Rmpfr_printf to do something when you have perl to DWYM ? NOTE: When using the 'P' (precision) type specifier, instead of providing $prec to the 'P' specifier, it's now advisable to provide prec_cast($prec). The 'P' specifier expects an mp_prec_t but, prior to 3.18, we could pass it only an IV. This didn't work on at least some big-endian machines if the size of the IV was greater than the size of the mp_prec_t. The Math::MPFR::Prec package (which is part of this distribution) exists solely to provide the prec_cast sub. And the prec_cast sub's return value should be passed *only* to the 'P' type specifier. Nothing else will understand it. Passing it to something other than the 'P' specifier may produce a garbage result - might even cause a segfault. prec_cast($prec); Ensures that the 'P' type specifier will provide correct results. In Math::MPFR versions prior to 3.18 we could do only (eg) : Rmpfr_printf("%Pu\n", Rmpfr_get_prec($op)); But that didn't work correctly for all architectures. As of 3.18, that can be rewritten as: Rmpfr_printf("%Pu\n", prec_cast(Rmpfr_get_prec($op))); which should work on all architectures. Rmpfr_printf($format_string, [$rnd,] $var); This function (unlike the MPFR counterpart) is limited to taking 2 or 3 arguments - the format string, optionally a rounding argument, and the variable to be formatted. That is, you can currently Rmpfr_printf only one variable at a time. If there's no variable to be formatted, just add a '0' as the final argument. ie this will work fine: Rmpfr_printf("hello world\n", 0); NOTE: The rounding argument $rnd can be provided *only* if $var is a Math::MPFR object. To do otherwise is a fatal error. A better way (IMO) to specify the rounding arg is to include it in the formatting spec. For example, instead of doing: Rmpfr_printf("%.17R*g\n", MPFR_RNDU, $op); do: Rmpfr_printf("%.17RUg\n", $op); See the mpfr documentation for details re the formatting options: http://www.mpfr.org/mpfr-current/mpfr.html#Formatted-Output-Functions Rmpfr_fprintf($fh, $format_string, [$rnd,] $var); This function (unlike the MPFR counterpart) is limited to taking 3 or 4 arguments - the filehandle, the format string, optionally a rounding argument, and the variable to be formatted. That is, you can Rmpfr_fprintf only one variable at a time. If there's no variable to be formatted, just add a '0' as the final argument. ie this will work fine: Rmpfr_fprintf($fh, "hello world\n", 0); NOTE: The rounding argument $rnd can be provided *only* if $var is a Math::MPFR object. To do otherwise is a fatal error. As for Rmpfr_printf (above), the rounding argument can be given in the formatting spec, rather than as a separate argument. See the mpfr documentation for details re the formatting options: http://www.mpfr.org/mpfr-current/mpfr.html#Formatted-Output-Functions Rmpfr_sprintf($buffer, $format_string, [$rnd,] $var, $buflen); This function (unlike the MPFR counterpart) is limited to taking 4 or 5 arguments - the buffer, the format string, optionally a rounding argument, the variable to be formatted and the size of the buffer ($buflen) into which the result will be written. $buflen must specify a size (characters) that is at least large enough to accommodate the formatted string (including the terminating NULL). The formatted string will be placed in $buffer. If there's no variable to be formatted, just insert a '0' as the value for $var. ie this will work fine: Rmpfr_sprintf($buffer, "hello world", 0, $buflen); NOTE: The rounding argument $rnd can be provided *only* if $var is a Math::MPFR object. To do otherwise is a fatal error. As for Rmpfr_printf (above), the rounding argument can be given in the formatting spec, rather than as a separate argument. See the mpfr documentation for details re the formatting options: http://www.mpfr.org/mpfr-current/mpfr.html#Formatted-Output-Functions Rmpfr_snprintf($buffer, $bytes, $format_string, [$rnd,] $var, $buflen); This function (unlike the MPFR counterpart) is limited to taking 5 or 6 arguments - the buffer, the number of bytes to be written, the format string, optionally a rounding argument, the variable to be formatted and the size of the buffer ($buflen). $buflen must specify a size (characters) that is at least large enough to accommodate the formatted string (including the terminating NULL). The formatted string will be placed in $buffer. If there's no variable to be formatted, just insert a '0' as the value for $arg. ie this will work fine: Rmpfr_snprintf($buffer, 12, "hello world", 0, $buflen); NOTE: The rounding argument $rnd can be provided *only* if $var is a Math::MPFR object. To do otherwise is a fatal error. As for Rmpfr_printf (above), the rounding argument can be given in the formatting spec, rather than as a separate argument. See the mpfr documentation for further details: http://www.mpfr.org/mpfr-current/mpfr.html#Formatted-Output-Functions ##################### BASE CONVERSIONS $DBL_DIG = MPFR_DBL_DIG; # Will be undef if float.h doesn't define # DBL_DIG. $LDBL_DIG = MPFR_LDBL_DIG; # Will be undef if float.h doesn't define # LDBL_DIG. $FLT128_DIG = MPFR_FLT128_DIG; # Will be undef if quadmath.h has not # been loaded, or quadmath.h does not # define FLT128_DIG . $min_prec = mpfr_min_inter_prec($orig_base, $orig_prec, $to_base); NOTE: $min_prec can be (very rarely) off by one if $orig_prec is in the millions, or if either $orig_base or $to_base are outside of the range 2..64. Example 1: Let's say we have some base 10 integers comprising 16 base 10 digits, and we want to represent those numbers in base 2 (binary). What is the minimum required number of bits, such that it can be guaranteed that converting the base 2 representations back to base 10 will result in the original 16 digit representations ? We can calculate that minimum required precision with: $min_prec = mpfr_min_inter_prec($orig_base, $orig_prec, $to_base); In this example case that becomes: $min_prec = mpfr_min_inter_prec(10, 16, 2); which will set $min_prec to 55. That is, so long as our base 2 representations provide at least 55 bits, we can pass 16-digit, base 10, integer values to them, and be assured of retrieving the original base 10 representation when we convert the base 2 representations back to base 10. Sure ... not all 16-digit values require 55 bits, but there are some that do ... and there are none that require more than 55 bits. Example 2: $min_prec = mpfr_min_inter_prec(2, 53, 10); $min_prec is set to 17. This tells us that a base 10 representation of a 53-bit integer needs to comprise at least 17 digits if we are to be assured that assigning that base 10 representation to a 53-bit integer will result in a 53-bit integer that is identical to the first. Otherwise, there is no such assurance. $max_prec = mpfr_max_orig_prec ($orig_base, $to_base, $to_prec); NOTE: $max_prec can be (very rarely) off by one if $to_prec is in the millions, or if either $orig_base or $to_base are outside of the range 2..64. For example: To determine the maximum significant number of base 10 digits that can be specified, when assigning to a 53-bit double. We have: $max_len = mpfr_max_orig_len($orig_base, $to_base, $to_prec); For this example that becomes: $max_len = mpfr_max_orig_len(10, 2, 53); which will set $max_len to 15. That is, so long as our base 10 integer consists of no more than 15 significant digits, we can assign it to a 53-bit double and be assured of retrieving the original value upon converting that double back to a 15-digit base 10 representation. Otherwise, there is no such assurance. It is to be expected that mpfr_max_orig_len(10, 2, 53) == DBL_DIG and mpfr_max_orig_len(10, 2, 113) == FLT128_DIG and mpfr_max_orig_len(10, 2, $long_double_prec) == LDBL_DIG (where $long_double_prec is the precision, in bits, of the the C 'long double' type - usually either 53 or 64 or 113.) ##################### =head1 TODO Look at wrapping mpfr_mp_memory_cleanup, mp_set_memory_functions =head1 BUGS You can get segfaults if you pass the wrong type of argument to the functions - so if you get a segfault, the first thing to do is to check that the argument types you have supplied are appropriate. =head1 ACKNOWLEDGEMENTS Thanks to Vincent Lefevre for providing corrections to errors and omissions, and suggesting improvements (which were duly put in place). =head1 LICENSE This program is free software; you may redistribute it and/or modify it under the same terms as Perl itself. Copyright 2006-2024 Sisyphus =head1 AUTHOR Sisyphus =cut Math-MPFR-4.38/MPFR.xs0000755060175106010010000122357114765756127013042 0ustar OwnerNone #ifdef __MINGW32__ #ifndef __USE_MINGW_ANSI_STDIO #define __USE_MINGW_ANSI_STDIO 1 #endif #endif #define PERL_NO_GET_CONTEXT 1 #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "math_mpfr_include.h" #include "math_mpfr_unused.h" #if NVSIZE == 8 # include "grisu3.h" #endif int nnum = 0; /* flag that is incremented whenever a string containing non-numeric characters is treated as a number */ int nok_pok = 0; /* flag that is incremented whenever a scalar that is both NOK and POK is passed to new or an overloaded operator */ int NNW_val(pTHX) { /* return the numeric value of $Math::MPFR::NNW - ie the no. of non-numeric instances encountered */ return (int)SvIV(get_sv("Math::MPFR::NNW", 0)); } int NOK_POK_val(pTHX) { /* return the numeric value of $Math::MPFR::NOK_POK */ return (int)SvIV(get_sv("Math::MPFR::NOK_POK", 0)); } int _win32_infnanstring(char * s) { /* MS Windows only - detect 1.#INF and 1.#IND * Need to do this to correctly handle a scalar * that is both NOK and POK on older win32 perls */ /************************************* * if input string =~ /^\-1\.#INF$/ return -1 * elsif input string =~ /^\+?1\.#INF$/i return 1 * elsif input string =~ /^(\-|\+)?1\.#IND$/i return 2 * else return 0 **************************************/ #ifdef _WIN32_BIZARRE_INFNAN int sign = 1; int factor = 1; if(s[0] == '-') { sign = -1; s++; } else { if(s[0] == '+') s++; } if(!strcmp(s, "1.#INF")) return sign; if(!strcmp(s, "1.#IND")) return 2; return 0; #else PERL_UNUSED_ARG(s); croak("Math::MPFR::_win32_infnanstring not implemented for this build of perl"); #endif } /* _fmt_flt is used by _nvtoa, doubletoa and _mpfrtoa to format numeric strings */ SV * _fmt_flt(pTHX_ char * out, int k, int sign, int max_decimal_prec, int sf) { /* out : the string that contains the mantissa of the value as decimal digits; does not contain a radix point. k : the exponent of the value. sign : is 0 if the value is non-negative; else is non-zero. max_decimal_prec: calculated as ceil(0x1.34413509f79ffp-2 * p) + 1, where p is the precision in bits of the given floating point value. sf : If non-zero, then Safefree(out) will be run prior to this function returning; else Safefree(out) will not be run. The doubletoa function requires that Safefree(out) is not run. */ int k_index, critical, skip; SV * outsv; char *bstr; char str[] = {'\0','\0','\0','\0','\0','\0','\0','\0','\0','\0','\0','\0','\0','\0','\0','\0'}; /*******************************/ /* Include following to return * * the string as is - ie with * * no reformatting */ /******************************** * int as_is = 1; * if(as_is) { * sprintf(str, "e%03d", k); * strcat(out, str); * outsv = newSVpv(out, 0); * if(sf) Safefree(out); * return outsv; * } ********************************/ k_index = (int)strlen(out); critical = k; /* formatting is based around this value */ k -= k_index; if(critical < -3) { sprintf(str, "e%03d", critical - 1); if(sign || k_index > 1) { /* insert decimal point */ for(skip = k_index + sign; skip > 1 + sign; skip--) { out[skip] = out[skip - 1 - sign]; } if(k_index > 1) { out[1 + sign] = '.'; out[k_index + 1 + sign] = 0; } if(sign) { out[1] = out[0]; out[0] = '-'; } } strcat(out, str); outsv = newSVpv(out, 0); if(sf) Safefree(out); return outsv; } if(critical <= 0 ) { /* bstr = concatenate "0." . ("0" x -critical) . out; */ Newxz(bstr, 8 - critical + strlen(out), char); /* Note: 'critical' has -ve value */ /* Newxz(bstr, (int)(16 + ceil(0.30103 * NVSIZE_BITS)), char); <= OLD VERSION */ if(bstr == NULL) croak("Failed to allocate memory for 2nd output string in _fmt_flt sub"); if(sign) bstr[0] = '-'; bstr[0 + sign] = '0'; bstr[1 + sign] = '.'; sign += 2; for(skip = critical; skip < 0; skip++) { bstr[sign] = '0'; sign++; } bstr[sign] = 0; strcat(bstr, out); outsv = newSVpv(bstr, 0); if(sf) Safefree(out); Safefree(bstr); return outsv; } if(critical < max_decimal_prec) { if(sign) { for(skip = k_index; skip > 0; skip--) out[skip] = out[skip - 1]; out[0] = '-'; out[k_index + 1] = 0; } if(k >= 0) { /* out = concatenate out . ('0' x k); */ for(skip = 0; skip < k; skip++) out[k_index + skip + sign] = '0'; out[k_index + k + sign] = '.'; out[k_index + k + sign + 1] = '0'; out[k_index + k + sign + 2] = 0; outsv = newSVpv(out, 0); if(sf) Safefree(out); return outsv; } /* insert decimal point; */ for(skip = k_index + sign; skip > k_index + k + sign; skip--) out[skip] = out[skip - 1]; out[k_index + k + sign] = '.'; out[k_index + sign + 1] = 0; outsv = newSVpv(out, 0); if(sf) Safefree(out); return outsv; } if( k_index > 1) { /* insert decimal point */ for(skip = k_index + sign; skip > 1 + sign; skip--) { out[skip] = out[skip - 1 - sign]; } out[1 + sign] = '.'; out[k_index + 1 + sign] = 0; } if(sign) { out[1] = out[0]; out[0] = '-'; } sprintf(str, "e+%d", critical - 1); strcat(out, str); outsv = newSVpv(out, 0); if(sf) Safefree(out); return outsv; } void Rmpfr_set_default_rounding_mode(pTHX_ SV * round) { CHECK_ROUNDING_VALUE mpfr_set_default_rounding_mode((mpfr_rnd_t)SvUV(round)); } unsigned long Rmpfr_get_default_rounding_mode(void) { return __gmpfr_default_rounding_mode; } SV * Rmpfr_prec_round(pTHX_ mpfr_t * p, SV * prec, SV * round) { return newSViv(mpfr_prec_round(*p, (mpfr_prec_t)SvIV(prec), (mpfr_rnd_t)SvUV(round))); } void DESTROY(pTHX_ mpfr_t * p) { mpfr_clear(*p); Safefree(p); } void Rmpfr_clear(pTHX_ mpfr_t * p) { mpfr_clear(*p); Safefree(p); } void Rmpfr_clear_mpfr(mpfr_t * p) { mpfr_clear(*p); } void Rmpfr_clear_ptr(pTHX_ mpfr_t * p) { Safefree(p); } void Rmpfr_clears(pTHX_ SV * p, ...) { dXSARGS; long int i; PERL_UNUSED_ARG(p); for(i = 0; i < items; i++) { mpfr_clear(*(INT2PTR(mpfr_t *, SvIVX(SvRV(ST(i)))))); Safefree(INT2PTR(mpfr_t *, SvIVX(SvRV(ST(i))))); } XSRETURN(0); } SV * Rmpfr_init(pTHX) { mpfr_t * mpfr_t_obj; SV * obj_ref, * obj; NEW_MATH_MPFR_OBJECT("Math::MPFR",Rmpfr_init) /* defined in math_mpfr_include.h */ mpfr_init(*mpfr_t_obj); OBJ_READONLY_ON /*defined in math_mpfr_include.h */ return obj_ref; } SV * Rmpfr_init2(pTHX_ SV * prec) { mpfr_t * mpfr_t_obj; SV * obj_ref, * obj; NEW_MATH_MPFR_OBJECT("Math::MPFR",Rmpfr_init2) /* defined in math_mpfr_include.h */ mpfr_init2 (*mpfr_t_obj, (mpfr_prec_t)SvIV(prec)); OBJ_READONLY_ON /*defined in math_mpfr_include.h */ return obj_ref; } SV * Rmpfr_init_nobless(pTHX) { mpfr_t * mpfr_t_obj; SV * obj_ref, * obj; NEW_MATH_MPFR_OBJECT(NULL,Rmpfr_init_nobless) /* defined in math_mpfr_include.h */ mpfr_init(*mpfr_t_obj); OBJ_READONLY_ON /*defined in math_mpfr_include.h */ return obj_ref; } SV * Rmpfr_init2_nobless(pTHX_ SV * prec) { mpfr_t * mpfr_t_obj; SV * obj_ref, * obj; NEW_MATH_MPFR_OBJECT(NULL,Rmpfr_init2_nobless) /* defined in math_mpfr_include.h */ mpfr_init2 (*mpfr_t_obj, (mpfr_prec_t)SvIV(prec)); OBJ_READONLY_ON /*defined in math_mpfr_include.h */ return obj_ref; } void Rmpfr_init_set(pTHX_ mpfr_t * q, SV * round) { dXSARGS; mpfr_t * mpfr_t_obj; SV * obj_ref, * obj; int ret; PERL_UNUSED_ARG(items); CHECK_ROUNDING_VALUE NEW_MATH_MPFR_OBJECT("Math::MPFR",Rmpfr_init_set) /* defined in math_mpfr_include.h */ ret = mpfr_init_set(*mpfr_t_obj, *q, (mpfr_rnd_t)SvUV(round)); OBJ_READONLY_ON /*defined in math_mpfr_include.h */ RETURN_STACK_2 /*defined in math_mpfr_include.h */ } void Rmpfr_init_set_ui(pTHX_ SV * q, SV * round) { dXSARGS; mpfr_t * mpfr_t_obj; SV * obj_ref, * obj; int ret; PERL_UNUSED_ARG(items); CHECK_ROUNDING_VALUE NEW_MATH_MPFR_OBJECT("Math::MPFR",Rmpfr_init_set_ui) /* defined in math_mpfr_include.h */ ret = mpfr_init_set_ui(*mpfr_t_obj, (unsigned long)SvUV(q), (mpfr_rnd_t)SvUV(round)); OBJ_READONLY_ON /*defined in math_mpfr_include.h */ RETURN_STACK_2 /*defined in math_mpfr_include.h */ } void Rmpfr_init_set_si(pTHX_ SV * q, SV * round) { dXSARGS; mpfr_t * mpfr_t_obj; SV * obj_ref, * obj; int ret; PERL_UNUSED_ARG(items); CHECK_ROUNDING_VALUE NEW_MATH_MPFR_OBJECT("Math::MPFR",Rmpfr_init_set_si) /* defined in math_mpfr_include.h */ ret = mpfr_init_set_si(*mpfr_t_obj, (long)SvIV(q), (mpfr_rnd_t)SvUV(round)); OBJ_READONLY_ON /*defined in math_mpfr_include.h */ RETURN_STACK_2 /*defined in math_mpfr_include.h */ } void Rmpfr_init_set_d(pTHX_ SV * q, SV * round) { dXSARGS; mpfr_t * mpfr_t_obj; SV * obj_ref, * obj; int ret; PERL_UNUSED_ARG(items); CHECK_ROUNDING_VALUE NEW_MATH_MPFR_OBJECT("Math::MPFR",Rmpfr_init_set_d) /* defined in math_mpfr_include.h */ ret = mpfr_init_set_d(*mpfr_t_obj, (double)SvNV(q), (mpfr_rnd_t)SvUV(round)); OBJ_READONLY_ON /*defined in math_mpfr_include.h */ RETURN_STACK_2 /*defined in math_mpfr_include.h */ } void Rmpfr_init_set_ld(pTHX_ SV * q, SV * round) { #ifdef USE_LONG_DOUBLE dXSARGS; mpfr_t * mpfr_t_obj; SV * obj_ref, * obj; int ret; PERL_UNUSED_ARG(items); CHECK_ROUNDING_VALUE NEW_MATH_MPFR_OBJECT("Math::MPFR",Rmpfr_init_set_ld) /* defined in math_mpfr_include.h */ ret = mpfr_init_set_ld(*mpfr_t_obj, (long double)SvNV(q), (mpfr_rnd_t)SvUV(round)); OBJ_READONLY_ON /*defined in math_mpfr_include.h */ RETURN_STACK_2 /*defined in math_mpfr_include.h */ #else PERL_UNUSED_ARG2(q, round); croak("Rmpfr_init_set_ld not implemented on this build of perl"); #endif } void Rmpfr_init_set_f(pTHX_ mpf_t * q, SV * round) { dXSARGS; mpfr_t * mpfr_t_obj; SV * obj_ref, * obj; int ret; PERL_UNUSED_ARG(items); CHECK_ROUNDING_VALUE NEW_MATH_MPFR_OBJECT("Math::MPFR",Rmpfr_init_set_f) /* defined in math_mpfr_include.h */ ret = mpfr_init_set_f(*mpfr_t_obj, *q, (mpfr_rnd_t)SvUV(round)); OBJ_READONLY_ON /*defined in math_mpfr_include.h */ RETURN_STACK_2 /*defined in math_mpfr_include.h */ } void Rmpfr_init_set_z(pTHX_ mpz_t * q, SV * round) { dXSARGS; mpfr_t * mpfr_t_obj; SV * obj_ref, * obj; int ret; PERL_UNUSED_ARG(items); CHECK_ROUNDING_VALUE NEW_MATH_MPFR_OBJECT("Math::MPFR",Rmpfr_init_set_z) /* defined in math_mpfr_include.h */ ret = mpfr_init_set_z(*mpfr_t_obj, *q, (mpfr_rnd_t)SvUV(round)); OBJ_READONLY_ON /*defined in math_mpfr_include.h */ RETURN_STACK_2 /*defined in math_mpfr_include.h */ } void Rmpfr_init_set_q(pTHX_ mpq_t * q, SV * round) { dXSARGS; mpfr_t * mpfr_t_obj; SV * obj_ref, * obj; int ret; PERL_UNUSED_ARG(items); CHECK_ROUNDING_VALUE NEW_MATH_MPFR_OBJECT("Math::MPFR",Rmpfr_init_set_q) /* defined in math_mpfr_include.h */ ret = mpfr_init_set_q(*mpfr_t_obj, *q, (mpfr_rnd_t)SvUV(round)); OBJ_READONLY_ON /*defined in math_mpfr_include.h */ RETURN_STACK_2 /*defined in math_mpfr_include.h */ } void Rmpfr_init_set_str(pTHX_ SV * q, SV * base, SV * round) { dXSARGS; mpfr_t * mpfr_t_obj; SV * obj_ref, * obj; int ret; #ifdef _WIN32_BIZARRE_INFNAN int inf_or_nan; #endif PERL_UNUSED_ARG(items); CHECK_ROUNDING_VALUE if( FAILS_CHECK_INPUT_BASE ) croak("2nd argument supplied to Rmpfr_init_set str is out of allowable range"); NEW_MATH_MPFR_OBJECT("Math::MPFR",Rmpfr_init_set_str) /* defined in math_mpfr_include.h */ OBJ_READONLY_ON /*defined in math_mpfr_include.h */ #ifdef _WIN32_BIZARRE_INFNAN inf_or_nan = _win32_infnanstring(SvPV_nolen(q)); if(inf_or_nan) { mpfr_init(*mpfr_t_obj); if(inf_or_nan != 2) mpfr_set_inf(*mpfr_t_obj, inf_or_nan); } else { ret = mpfr_init_set_str(*mpfr_t_obj, SvPV_nolen(q), (int)SvIV(base), (mpfr_rnd_t)SvUV(round)); } #else ret = mpfr_init_set_str(*mpfr_t_obj, SvPV_nolen(q), (int)SvIV(base), (mpfr_rnd_t)SvUV(round)); #endif NON_NUMERIC_CHAR_CHECK(q), "Rmpfr_init_set_str");} RETURN_STACK_2 /*defined in math_mpfr_include.h */ } void Rmpfr_init_set_nobless(pTHX_ mpfr_t * q, SV * round) { dXSARGS; mpfr_t * mpfr_t_obj; SV * obj_ref, * obj; int ret; PERL_UNUSED_ARG(items); CHECK_ROUNDING_VALUE NEW_MATH_MPFR_OBJECT(NULL,Rmpfr_init_set_nobless) /* defined in math_mpfr_include.h */ ret = mpfr_init_set(*mpfr_t_obj, *q, (mpfr_rnd_t)SvUV(round)); OBJ_READONLY_ON /*defined in math_mpfr_include.h */ RETURN_STACK_2 /*defined in math_mpfr_include.h */ } void Rmpfr_init_set_ui_nobless(pTHX_ SV * q, SV * round) { dXSARGS; mpfr_t * mpfr_t_obj; SV * obj_ref, * obj; int ret; PERL_UNUSED_ARG(items); CHECK_ROUNDING_VALUE NEW_MATH_MPFR_OBJECT(NULL,Rmpfr_init_set_ui_nobless) /* defined in math_mpfr_include.h */ ret = mpfr_init_set_ui(*mpfr_t_obj, (unsigned long)SvUV(q), (mpfr_rnd_t)SvUV(round)); OBJ_READONLY_ON /*defined in math_mpfr_include.h */ RETURN_STACK_2 /*defined in math_mpfr_include.h */ } void Rmpfr_init_set_si_nobless(pTHX_ SV * q, SV * round) { dXSARGS; mpfr_t * mpfr_t_obj; SV * obj_ref, * obj; int ret; PERL_UNUSED_ARG(items); CHECK_ROUNDING_VALUE NEW_MATH_MPFR_OBJECT(NULL,Rmpfr_init_set_si_nobless) /* defined in math_mpfr_include.h */ ret = mpfr_init_set_si(*mpfr_t_obj, (long)SvIV(q), (mpfr_rnd_t)SvUV(round)); OBJ_READONLY_ON /*defined in math_mpfr_include.h */ RETURN_STACK_2 /*defined in math_mpfr_include.h */ } void Rmpfr_init_set_d_nobless(pTHX_ SV * q, SV * round) { dXSARGS; mpfr_t * mpfr_t_obj; SV * obj_ref, * obj; int ret; PERL_UNUSED_ARG(items); CHECK_ROUNDING_VALUE NEW_MATH_MPFR_OBJECT(NULL,Rmpfr_init_set_d_nobless) /* defined in math_mpfr_include.h */ ret = mpfr_init_set_d(*mpfr_t_obj, (double)SvNV(q), (mpfr_rnd_t)SvUV(round)); OBJ_READONLY_ON /*defined in math_mpfr_include.h */ RETURN_STACK_2 /*defined in math_mpfr_include.h */ } void Rmpfr_init_set_ld_nobless(pTHX_ SV * q, SV * round) { #ifdef USE_LONG_DOUBLE dXSARGS; mpfr_t * mpfr_t_obj; SV * obj_ref, * obj; int ret; PERL_UNUSED_ARG(items); CHECK_ROUNDING_VALUE NEW_MATH_MPFR_OBJECT(NULL,Rmpfr_init_set_ld_nobless) /* defined in math_mpfr_include.h */ ret = mpfr_init_set_ld(*mpfr_t_obj, (long double)SvNV(q), (mpfr_rnd_t)SvUV(round)); OBJ_READONLY_ON /*defined in math_mpfr_include.h */ RETURN_STACK_2 /*defined in math_mpfr_include.h */ #else PERL_UNUSED_ARG2(q, round); croak("Rmpfr_init_set_ld_nobless not implemented on this build of perl"); #endif } void Rmpfr_init_set_f_nobless(pTHX_ mpf_t * q, SV * round) { dXSARGS; mpfr_t * mpfr_t_obj; SV * obj_ref, * obj; int ret; PERL_UNUSED_ARG(items); CHECK_ROUNDING_VALUE NEW_MATH_MPFR_OBJECT(NULL,Rmpfr_init_set_f_nobless) /* defined in math_mpfr_include.h */ ret = mpfr_init_set_f(*mpfr_t_obj, *q, (mpfr_rnd_t)SvUV(round)); OBJ_READONLY_ON /*defined in math_mpfr_include.h */ RETURN_STACK_2 /*defined in math_mpfr_include.h */ } void Rmpfr_init_set_z_nobless(pTHX_ mpz_t * q, SV * round) { dXSARGS; mpfr_t * mpfr_t_obj; SV * obj_ref, * obj; int ret; PERL_UNUSED_ARG(items); CHECK_ROUNDING_VALUE NEW_MATH_MPFR_OBJECT(NULL,Rmpfr_init_set_z_nobless) /* defined in math_mpfr_include.h */ ret = mpfr_init_set_z(*mpfr_t_obj, *q, (mpfr_rnd_t)SvUV(round)); OBJ_READONLY_ON /*defined in math_mpfr_include.h */ RETURN_STACK_2 /*defined in math_mpfr_include.h */ } void Rmpfr_init_set_q_nobless(pTHX_ mpq_t * q, SV * round) { dXSARGS; mpfr_t * mpfr_t_obj; SV * obj_ref, * obj; int ret; PERL_UNUSED_ARG(items); CHECK_ROUNDING_VALUE NEW_MATH_MPFR_OBJECT(NULL,Rmpfr_init_set_q_nobless) /* defined in math_mpfr_include.h */ ret = mpfr_init_set_q(*mpfr_t_obj, *q, (mpfr_rnd_t)SvUV(round)); OBJ_READONLY_ON /*defined in math_mpfr_include.h */ RETURN_STACK_2 /*defined in math_mpfr_include.h */ } void Rmpfr_init_set_str_nobless(pTHX_ SV * q, SV * base, SV * round) { dXSARGS; mpfr_t * mpfr_t_obj; SV * obj_ref, * obj; int ret; PERL_UNUSED_ARG(items); CHECK_ROUNDING_VALUE if( FAILS_CHECK_INPUT_BASE ) croak("2nd argument supplied to Rmpfr_init_set_str_nobless is out of allowable range"); NEW_MATH_MPFR_OBJECT(NULL,Rmpfr_init_set_str_nobless) /* defined in math_mpfr_include.h */ OBJ_READONLY_ON /*defined in math_mpfr_include.h */ ret = mpfr_init_set_str(*mpfr_t_obj, SvPV_nolen(q), (int)SvIV(base), (mpfr_rnd_t)SvUV(round)); NON_NUMERIC_CHAR_CHECK(q), "Rmpfr_init_set_str_nobless");} RETURN_STACK_2 /*defined in math_mpfr_include.h */ } void Rmpfr_deref2(pTHX_ mpfr_t * p, SV * base, SV * n_digits, SV * round) { dXSARGS; char * out; mpfr_exp_t ptr; PERL_UNUSED_ARG(items); CHECK_ROUNDING_VALUE if( FAILS_CHECK_OUTPUT_BASE ) croak("Second argument supplied to Rmpfr_get_str is not in acceptable range"); out = mpfr_get_str(NULL, &ptr, (int)SvIV(base), (unsigned long)SvUV(n_digits), *p, (mpfr_rnd_t)SvUV(round)); if(out == NULL) croak("An error occurred in memory allocation in mpfr_get_str\n"); ST(0) = MORTALIZED_PV(out); /* defined in math_mpfr_include.h */ mpfr_free_str(out); ST(1) = sv_2mortal(newSViv(ptr)); XSRETURN(2); } void Rmpfr_set_default_prec(pTHX_ SV * prec) { #if MPFR_VERSION < 262144 /* earlier than version 4.0.0 */ if(SvIV(prec) < 2) croak("Precision must be set to at least 2 for this version (%s) of the mpfr library", MPFR_VERSION_STRING); #endif mpfr_set_default_prec((mpfr_prec_t)SvIV(prec)); } SV * Rmpfr_get_default_prec(pTHX) { return newSViv(mpfr_get_default_prec()); } SV * Rmpfr_min_prec(pTHX_ mpfr_t * x) { return newSViv((mpfr_prec_t)mpfr_min_prec(*x)); } void Rmpfr_set_prec(pTHX_ mpfr_t * p, SV * prec) { #if MPFR_VERSION < 262144 /* earlier than version 4.0.0 */ if(SvIV(prec) < 2) croak("Precision must be set to at least 2 for this version (%s) of the mpfr library", MPFR_VERSION_STRING); #endif mpfr_set_prec(*p, (mpfr_prec_t)SvIV(prec)); } void Rmpfr_set_prec_raw(pTHX_ mpfr_t * p, SV * prec) { #if MPFR_VERSION < 262144 /* earlier than version 4.0.0 */ if(SvIV(prec) < 2) croak("Precision must be set to at least 2 for this version (%s) of the mpfr library", MPFR_VERSION_STRING); #endif mpfr_set_prec_raw(*p, (mpfr_prec_t)SvIV(prec)); } SV * Rmpfr_get_prec(pTHX_ mpfr_t * p) { return newSViv(mpfr_get_prec(*p)); } SV * Rmpfr_set(pTHX_ mpfr_t * p, mpfr_t * q, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_set(*p, *q, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_set_ui(pTHX_ mpfr_t * p, SV * q, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_set_ui(*p, (unsigned long)SvUV(q), (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_set_si(pTHX_ mpfr_t * p, SV * q, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_set_si(*p, (long)SvIV(q), (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_set_uj(pTHX_ mpfr_t * p, SV * q, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_set_uj(*p, (uintmax_t)SvUV(q), (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_set_sj(pTHX_ mpfr_t * p, SV * q, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_set_sj(*p, (intmax_t)SvIV(q), (mpfr_rnd_t)SvUV(round))); } int Rmpfr_set_NV(pTHX_ mpfr_t * p, SV * q, unsigned int round) { #if MPFR_VERSION_MAJOR < 3 if((mpfr_rnd_t)round > 3) croak("Illegal rounding value supplied for this version (%s) of the mpfr library", MPFR_VERSION_STRING); #endif #if defined(USE_LONG_DOUBLE) if(!SV_IS_NOK(q)) croak("In Rmpfr_set_NV, 2nd argument is not an NV"); return mpfr_set_ld(*p, (long double)SvNV(q), (mpfr_rnd_t)round); #elif defined(CAN_PASS_FLOAT128) if(!SV_IS_NOK(q)) croak("In Rmpfr_set_NV, 2nd argument is not an NV"); return mpfr_set_float128(*p, (float128)SvNV(q), (mpfr_rnd_t)round); #elif defined(USE_QUADMATH) char buffer[45]; int exp; float128 ld; int returned; if(!SV_IS_NOK(q)) croak("In Rmpfr_set_NV, 2nd argument is not an NV"); ld = (float128)SvNV(q); if(ld != ld) { mpfr_set_nan(*p); return 0; } if(ld != 0.0Q && (ld / ld != 1)) { returned = ld > 0.0Q ? 1 : -1; mpfr_set_inf(*p, returned); return 0; } ld = frexpq(ld, &exp); /* 0.5 <= returned value < 1.0 */ /* Convert ld to an integer by right shifting it 113 bits */ ld *= 0x1p+113Q; /* ld *= powq(2.0Q, 113); */ returned = quadmath_snprintf(buffer, 45, "%.0Qf", ld); if(returned < 0) croak("In Rmpfr_set_NV, encoding error in quadmath_snprintf function"); if(returned >= 45) croak("In Rmpfr_set_NV, buffer given to quadmath_snprintf function was too small"); returned = mpfr_set_str(*p, buffer, 10, (mpfr_rnd_t)round); mpfr_mul_2si(*p, *p, exp - 113, GMP_RNDN); return returned; #else if(!SV_IS_NOK(q)) croak("In Rmpfr_set_NV, 2nd argument is not an NV"); return mpfr_set_d (*p, SvNV(q), (mpfr_rnd_t)round); #endif } void Rmpfr_init_set_NV(pTHX_ SV * q, SV * round) { dXSARGS; mpfr_t * mpfr_t_obj; SV * obj_ref, * obj; int ret; PERL_UNUSED_ARG(items); CHECK_ROUNDING_VALUE NEW_MATH_MPFR_OBJECT("Math::MPFR",Rmpfr_init_set_NV) /* defined in math_mpfr_include.h */ mpfr_init(*mpfr_t_obj); sv_setiv(obj, INT2PTR(IV,mpfr_t_obj)); ret = Rmpfr_set_NV(aTHX_ mpfr_t_obj, q, (mpfr_rnd_t)SvUV(round)); SvREADONLY_on(obj); RETURN_STACK_2 /*defined in math_mpfr_include.h */ } void Rmpfr_init_set_NV_nobless(pTHX_ SV * q, SV * round) { dXSARGS; mpfr_t * mpfr_t_obj; SV * obj_ref, * obj; int ret; PERL_UNUSED_ARG(items); CHECK_ROUNDING_VALUE NEW_MATH_MPFR_OBJECT(NULL,Rmpfr_init_set_NV_nobless) /* defined in math_mpfr_include.h */ mpfr_init(*mpfr_t_obj); sv_setiv(obj, INT2PTR(IV,mpfr_t_obj)); ret = Rmpfr_set_NV(aTHX_ mpfr_t_obj, q, (mpfr_rnd_t)SvUV(round)); SvREADONLY_on(obj); RETURN_STACK_2 /*defined in math_mpfr_include.h */ } int Rmpfr_cmp_float128(pTHX_ mpfr_t * a, SV * b) { #if defined(CAN_PASS_FLOAT128) mpfr_t t; int ret; mpfr_init2(t, FLT128_MANT_DIG); mpfr_set_float128(t, SvNV(b), GMP_RNDN); ret = mpfr_cmp(*a, t); mpfr_clear(t); return ret; #elif defined(USE_QUADMATH) mpfr_t t; char buffer[45]; int exp; float128 ld; int returned; ld = (float128)SvNV(b); if(ld != ld || mpfr_nan_p(*a)) { mpfr_set_erangeflag(); return 0; } if(ld != 0.0Q && (ld / ld != 1)) { if(ld > 0.0Q) { if(mpfr_inf_p(*a)) { if(mpfr_signbit(*a)) return -1; return 0; } return -1; } if(mpfr_inf_p(*a)) { if(mpfr_signbit(*a)) return 0; return 1; } return 1; } if(ld == 0.0Q) { if(mpfr_zero_p (*a)) return 0; if(mpfr_signbit(*a)) return -1; return 1; } ld = frexpq(ld, &exp); /* 0.5 <= returned value < 1.0 */ /* Convert ld to an integer by right shifting it 113 bits */ ld *= 0x1p+113Q; /* ld *= powq(2.0Q, 113); */ returned = quadmath_snprintf(buffer, 45, "%.0Qf", ld); if(returned < 0) croak("In Rmpfr_set_NV, encoding error in quadmath_snprintf function"); if(returned >= 45) croak("In Rmpfr_set_NV, buffer given to quadmath_snprintf function was too small"); mpfr_init2(t, FLT128_MANT_DIG); returned = mpfr_set_str(t, buffer, 10, GMP_RNDN); mpfr_mul_2si(t, t, exp - 113, GMP_RNDN); returned = mpfr_cmp(*a, t); mpfr_clear(t); return returned; #else PERL_UNUSED_ARG2(a, b); croak("Rmpfr_cmp_float128 not available on this build of perl"); #endif } int Rmpfr_cmp_NV(pTHX_ mpfr_t * a, SV * b) { if(!SvNOK(b)) croak("In Rmpfr_cmp_NV, 2nd argument is not an NV"); #if defined(USE_LONG_DOUBLE) return mpfr_cmp_ld(*a, SvNV(b)); #elif defined(USE_QUADMATH) return Rmpfr_cmp_float128(aTHX_ a, b); #else return mpfr_cmp_d(*a, SvNV(b)); #endif } SV * Rmpfr_set_ld(pTHX_ mpfr_t * p, SV * q, SV * round) { CHECK_ROUNDING_VALUE #if defined(USE_LONG_DOUBLE) || defined(USE_QUADMATH) return newSViv(mpfr_set_ld(*p, (long double)SvNV(q), (mpfr_rnd_t)SvUV(round))); #else PERL_UNUSED_ARG3(p, q, round); croak("Rmpfr_set_ld not implemented on this build of perl"); #endif } SV * Rmpfr_set_d(pTHX_ mpfr_t * p, SV * q, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_set_d(*p, (double)SvNV(q), (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_set_z(pTHX_ mpfr_t * p, mpz_t * q, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_set_z(*p, *q, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_set_q(pTHX_ mpfr_t * p, mpq_t * q, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_set_q(*p, *q, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_set_f(pTHX_ mpfr_t * p, mpf_t * q, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_set_f(*p, *q, (mpfr_rnd_t)SvUV(round))); } int Rmpfr_set_str(pTHX_ mpfr_t * p, SV * num, SV * base, SV * round) { int ret; #ifdef _WIN32_BIZARRE_INFNAN int inf_or_nan; #endif CHECK_ROUNDING_VALUE if( FAILS_CHECK_INPUT_BASE ) croak("3rd argument supplied to Rmpfr_set_str is out of allowable range"); #ifdef _WIN32_BIZARRE_INFNAN inf_or_nan = _win32_infnanstring(SvPV_nolen(num)); if(inf_or_nan) { if(inf_or_nan == 2) { mpfr_set_nan(*p); } else mpfr_set_inf(*p, inf_or_nan); } else { ret = mpfr_set_str(*p, SvPV_nolen(num), (int)SvIV(base), (mpfr_rnd_t)SvUV(round)); } #else ret = mpfr_set_str(*p, SvPV_nolen(num), (int)SvIV(base), (mpfr_rnd_t)SvUV(round)); #endif NON_NUMERIC_CHAR_CHECK(num), "Rmpfr_set_str");} return ret; } void Rmpfr_set_inf(mpfr_t * p, int sign) { mpfr_set_inf(*p, sign); } void Rmpfr_set_nan(mpfr_t * p) { mpfr_set_nan(*p); } void Rmpfr_swap(mpfr_t *p, mpfr_t * q) { mpfr_swap(*p, *q); } SV * Rmpfr_get_d(pTHX_ mpfr_t * p, SV * round){ CHECK_ROUNDING_VALUE return newSVnv(mpfr_get_d(*p, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_get_d_2exp(pTHX_ SV * exp, mpfr_t * p, SV * round){ long _exp; double ret; CHECK_ROUNDING_VALUE ret = mpfr_get_d_2exp(&_exp, *p, (mpfr_rnd_t)SvUV(round)); sv_setiv(exp, _exp); return newSVnv(ret); } SV * Rmpfr_get_ld_2exp(pTHX_ SV * exp, mpfr_t * p, SV * round){ #if defined(USE_LONG_DOUBLE) || defined(USE_QUADMATH) # if defined(USE_QUADMATH) && defined(__GNUC__) && ((__GNUC__ > 4 && __GNUC__ < 7) || (__GNUC__ == 4 && __GNUC_MINOR__ >= 9)) /* Casting long double Inf to float128 might result in NaN. This is GCC bug 77265, which was fixed for GCC 7: https://gcc.gnu.org/bugzilla/show_bug.cgi?id=77265 The fix might yet be backported to GCC 6. (Not sure.) It was earlier reported (also by me) to MinGW: https://sourceforge.net/p/mingw-w64/bugs/479/ Let us take the cautious approach and simply avoid making that cast. Instead, we will cast the double Inf to a float128. */ if(mpfr_inf_p(*p)) return newSVnv(mpfr_get_d(*p, (mpfr_rnd_t)SvUV(round))); # endif long _exp; long double ret; CHECK_ROUNDING_VALUE ret = mpfr_get_ld_2exp(&_exp, *p, (mpfr_rnd_t)SvUV(round)); sv_setiv(exp, _exp); return newSVnv(ret); #else PERL_UNUSED_ARG3(exp, p, round); croak("Rmpfr_get_ld_2exp not implemented on this build of perl"); #endif } SV * Rmpfr_get_ld(pTHX_ mpfr_t * p, SV * round){ CHECK_ROUNDING_VALUE #if defined(USE_LONG_DOUBLE) || defined(USE_QUADMATH) # if defined(USE_QUADMATH) && defined(__GNUC__) && ((__GNUC__ > 4 && __GNUC__ < 7) || (__GNUC__ == 4 && __GNUC_MINOR__ >= 9)) /* Casting long double Inf to float128 might result in NaN. This is GCC bug 77265, which was fixed for GCC 7: https://gcc.gnu.org/bugzilla/show_bug.cgi?id=77265 The fix might yet be backported to GCC 6. (Not sure.) It was earlier reported (also by me) to MinGW: https://sourceforge.net/p/mingw-w64/bugs/479/ Let us take the cautious approach and simply avoid making that cast. Instead, we will cast the double Inf to a float128. */ if(mpfr_inf_p(*p)) return newSVnv(mpfr_get_d(*p, (mpfr_rnd_t)SvUV(round))); # elif LDBL_MANT_DIG == 106 # if !defined(MPFR_VERSION) || (defined(MPFR_VERSION) && MPFR_VERSION <= DD_INF_BUG) double d = mpfr_get_ld(*p, (mpfr_rnd_t)SvUV(round)); if(d == 0.0 || d != d || d / d != 1) return newSVnv((long double)d); # endif # endif # if defined MPFR_VERSION && MPFR_VERSION > 196868 /* mpfr_get_ld handles subnormals correctly */ return newSVnv(mpfr_get_ld(*p, (mpfr_rnd_t)SvUV(round))); # else /* mpfr_get_ld handling of subnormals is buggy */ if(strtold("2e-4956", NULL) == 0.0L) { /* extended precision (80-bit) long double */ if(mpfr_regular_p(*p) && mpfr_get_exp(*p) < -16381 && mpfr_get_exp(*p) >= -16445) { warn("\n mpfr_get_ld is buggy (subnormal values only)\n for this version (%s) of the MPFR library\n", MPFR_VERSION_STRING); croak(" Version 3.1.5 or later is required"); } } return newSVnv(mpfr_get_ld(*p, (mpfr_rnd_t)SvUV(round))); # endif #else PERL_UNUSED_ARG2(p, round); croak("Rmpfr_get_ld not implemented on this build of perl"); #endif } double Rmpfr_get_d1(mpfr_t * p) { return mpfr_get_d1(*p); } /* Alias for the perl function Rmpfr_get_z_exp * (which will perhaps one day be removed). * The mpfr headers define 'mpfr_get_z_exp' to * 'mpfr_get_z_2exp' when that function is * available. */ SV * Rmpfr_get_z_2exp(pTHX_ mpz_t * z, mpfr_t * p){ return newSViv(mpfr_get_z_exp(*z, *p)); } SV * Rmpfr_add(pTHX_ mpfr_t * a, mpfr_t * b, mpfr_t * c, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_add(*a, *b, *c, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_add_ui(pTHX_ mpfr_t * a, mpfr_t * b, SV * c, SV * round){ CHECK_ROUNDING_VALUE DEAL_WITH_NANFLAG_BUG return newSViv(mpfr_add_ui(*a, *b, (unsigned long)SvUV(c), (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_add_d(pTHX_ mpfr_t * a, mpfr_t * b, SV * c, SV * round){ CHECK_ROUNDING_VALUE return newSViv(mpfr_add_d(*a, *b, (double)SvNV(c), (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_add_si(pTHX_ mpfr_t * a, mpfr_t * b, SV * c, SV * round){ CHECK_ROUNDING_VALUE DEAL_WITH_NANFLAG_BUG return newSViv(mpfr_add_si(*a, *b, (int)SvIV(c), (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_add_z(pTHX_ mpfr_t * a, mpfr_t * b, mpz_t * c, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_add_z(*a, *b, *c, (mpfr_rnd_t)SvUV(round))); } /* No need for rounding as result will be exact */ void Rmpfr_get_q(mpq_t * a, mpfr_t * b) { #if defined(MPFR_VERSION_MAJOR) && MPFR_VERSION_MAJOR >= 4 if(!mpfr_number_p(*b)) croak("In Rmpfr_get_q: Cannot coerce an 'Inf' or 'NaN' to a Math::GMPq object"); mpfr_get_q(*a, *b); #else mpf_t temp; if(!mpfr_number_p(*b)) croak("In Rmpfr_get_q: Cannot coerce an 'Inf' or 'NaN' to a Math::GMPq object"); mpf_init2 (temp, (mp_bitcnt_t)mpfr_get_prec(*b)); mpfr_get_f(temp, *b, GMP_RNDN); mpq_set_f (*a, temp); mpf_clear(temp); #endif } SV * Rmpfr_add_q(pTHX_ mpfr_t * a, mpfr_t * b, mpq_t * c, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_add_q(*a, *b, *c, (mpfr_rnd_t)SvUV(round))); } void q_add_fr(mpq_t * a, mpq_t * b, mpfr_t * c) { mpq_t temp; mpq_init(temp); #if defined(MPFR_VERSION_MAJOR) && MPFR_VERSION_MAJOR >= 4 mpfr_get_q(temp, *c); #else Rmpfr_get_q(&temp, c); #endif mpq_add(*a, *b, temp); mpq_clear(temp); } SV * Rmpfr_sub(pTHX_ mpfr_t * a, mpfr_t * b, mpfr_t * c, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_sub(*a, *b, *c, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_sub_ui(pTHX_ mpfr_t * a, mpfr_t * b, SV * c, SV * round) { CHECK_ROUNDING_VALUE DEAL_WITH_NANFLAG_BUG return newSViv(mpfr_sub_ui(*a, *b, (unsigned long)SvUV(c), (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_sub_d(pTHX_ mpfr_t * a, mpfr_t * b, SV * c, SV * round){ CHECK_ROUNDING_VALUE return newSViv(mpfr_sub_d(*a, *b, (double)SvNV(c), (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_sub_z(pTHX_ mpfr_t * a, mpfr_t * b, mpz_t * c, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_sub_z(*a, *b, *c, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_sub_q(pTHX_ mpfr_t * a, mpfr_t * b, mpq_t * c, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_sub_q(*a, *b, *c, (mpfr_rnd_t)SvUV(round))); } void q_sub_fr(mpq_t * a, mpq_t * b, mpfr_t * c) { mpq_t temp; mpq_init(temp); #if defined(MPFR_VERSION_MAJOR) && MPFR_VERSION_MAJOR >= 4 mpfr_get_q(temp, *c); #else Rmpfr_get_q(&temp, c); #endif mpq_sub(*a, *b, temp); mpq_clear(temp); } SV * Rmpfr_ui_sub(pTHX_ mpfr_t * a, SV * b, mpfr_t * c, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_ui_sub(*a, (unsigned long)SvUV(b), *c, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_d_sub(pTHX_ mpfr_t * a, SV * b, mpfr_t * c, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_d_sub(*a, (double)SvNV(b), *c, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_mul(pTHX_ mpfr_t * a, mpfr_t * b, mpfr_t * c, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_mul(*a, *b, *c, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_mul_ui(pTHX_ mpfr_t * a, mpfr_t * b, SV * c, SV * round){ CHECK_ROUNDING_VALUE return newSViv(mpfr_mul_ui(*a, *b, (unsigned long)SvUV(c), (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_mul_d(pTHX_ mpfr_t * a, mpfr_t * b, SV * c, SV * round){ CHECK_ROUNDING_VALUE return newSViv(mpfr_mul_d(*a, *b, (double)SvNV(c), (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_mul_z(pTHX_ mpfr_t * a, mpfr_t * b, mpz_t * c, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_mul_z(*a, *b, *c, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_mul_q(pTHX_ mpfr_t * a, mpfr_t * b, mpq_t * c, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_mul_q(*a, *b, *c, (mpfr_rnd_t)SvUV(round))); } void q_mul_fr(mpq_t * a, mpq_t * b, mpfr_t * c) { mpq_t temp; mpq_init(temp); #if defined(MPFR_VERSION_MAJOR) && MPFR_VERSION_MAJOR >= 4 mpfr_get_q(temp, *c); #else Rmpfr_get_q(&temp, c); #endif mpq_mul(*a, *b, temp); mpq_clear(temp); } SV * Rmpfr_dim(pTHX_ mpfr_t * rop, mpfr_t * op1, mpfr_t * op2, SV * round) { CHECK_ROUNDING_VALUE int ret = mpfr_dim( *rop, *op1, *op2, (mpfr_rnd_t)SvUV(round)); return newSViv(ret); } SV * Rmpfr_div(pTHX_ mpfr_t * a, mpfr_t * b, mpfr_t * c, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_div(*a, *b, *c, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_div_ui(pTHX_ mpfr_t * a, mpfr_t * b, SV * c, SV * round){ CHECK_ROUNDING_VALUE return newSViv(mpfr_div_ui(*a, *b, (unsigned long)SvUV(c), (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_div_d(pTHX_ mpfr_t * a, mpfr_t * b, SV * c, SV * round){ CHECK_ROUNDING_VALUE return newSViv(mpfr_div_d(*a, *b, (double)SvNV(c), (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_div_z(pTHX_ mpfr_t * a, mpfr_t * b, mpz_t * c, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_div_z(*a, *b, *c, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_div_q(pTHX_ mpfr_t * a, mpfr_t * b, mpq_t * c, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_div_q(*a, *b, *c, (mpfr_rnd_t)SvUV(round))); } void q_div_fr(mpq_t * a, mpq_t * b, mpfr_t * c) { mpq_t temp; mpq_init(temp); #if defined(MPFR_VERSION_MAJOR) && MPFR_VERSION_MAJOR >= 4 mpfr_get_q(temp, *c); #else Rmpfr_get_q(&temp, c); #endif mpq_div(*a, *b, temp); mpq_clear(temp); } void q_fmod_fr(mpq_t * a, mpq_t * b, mpfr_t * c) { mpq_t q; mpz_t z; mpq_init(q); mpz_init(z); #if defined(MPFR_VERSION_MAJOR) && MPFR_VERSION_MAJOR >= 4 mpfr_get_q(q, *c); #else Rmpfr_get_q(&q, c); #endif mpq_div(*a, *b, q); mpz_set_q(z, *a); mpq_set_z(*a, z); mpz_clear(z); mpq_mul(*a, q, *a); mpq_clear(q); mpq_sub(*a, *b, *a); } SV * Rmpfr_ui_div(pTHX_ mpfr_t * a, SV * b, mpfr_t * c, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_ui_div(*a, (unsigned long)SvUV(b), *c, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_d_div(pTHX_ mpfr_t * a, SV * b, mpfr_t * c, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_d_div(*a, (double)SvNV(b), *c, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_sqrt(pTHX_ mpfr_t * a, mpfr_t * b, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_sqrt(*a, *b, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_rec_sqrt(pTHX_ mpfr_t * a, mpfr_t * b, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_rec_sqrt(*a, *b, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_cbrt(pTHX_ mpfr_t * a, mpfr_t * b, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_cbrt(*a, *b, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_sqrt_ui(pTHX_ mpfr_t * a, SV * b, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_sqrt_ui(*a, (unsigned long)SvUV(b), (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_pow_ui(pTHX_ mpfr_t * a, mpfr_t * b, SV * c, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_pow_ui(*a, *b, (unsigned long)SvUV(c), (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_pow_uj(pTHX_ mpfr_t * a, mpfr_t * b, SV * c, SV * round) { #if MPFR_VERSION >= 262656 /* 4.2.0 */ return newSViv(mpfr_pow_uj(*a, *b, (uintmax_t)SvUV(c), (mpfr_rnd_t)SvUV(round))); #else PERL_UNUSED_ARG4(a, b, c, round); croak("Rmpfr_pow_uj function not implemented until mpfr-4.2.0. (You have only version %s) ", MPFR_VERSION_STRING); #endif } SV * Rmpfr_pow_IV(pTHX_ mpfr_t * a, mpfr_t * b, SV * c, SV * round) { if(SV_IS_IOK(c)) { #if defined(MATH_MPFR_NEED_LONG_LONG_INT) # if MPFR_VERSION >= 262656 if(SvUOK(c)) { return newSViv(mpfr_pow_uj(*a, *b, (uintmax_t)SvUV(c), (mpfr_rnd_t)SvUV(round))); } return newSViv(mpfr_pow_sj(*a, *b, (intmax_t)SvIV(c), (mpfr_rnd_t)SvUV(round))); # else mpfr_t t; int ret; mpfr_init2(t, 64); if(SvUOK(c)) { mpfr_set_uj(t, (uintmax_t)SvUV(c), (mpfr_rnd_t)SvUV(round)); } else { mpfr_set_sj(t, (intmax_t)SvIV(c), (mpfr_rnd_t)SvUV(round)); } ret = mpfr_pow(*a, *b, t, (mpfr_rnd_t)SvUV(round)); mpfr_clear(t); return newSViv(ret); # endif #else if(SvUOK(c)) { return newSViv(mpfr_pow_ui(*a, *b, (unsigned long)SvUV(c), (mpfr_rnd_t)SvUV(round))); } return newSViv(mpfr_pow_si(*a, *b, (unsigned long)SvIV(c), (mpfr_rnd_t)SvUV(round))); #endif } croak("Arg provided to Rmpfr_pow_IV is not an IV"); } SV * Rmpfr_ui_pow_ui(pTHX_ mpfr_t * a, SV * b, SV * c, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_ui_pow_ui(*a, (unsigned long)SvUV(b), (unsigned long)SvUV(c), (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_ui_pow(pTHX_ mpfr_t * a, SV * b, mpfr_t * c, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_ui_pow(*a, (unsigned long)SvUV(b), *c, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_pow_si(pTHX_ mpfr_t * a, mpfr_t * b, SV * c, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_pow_si(*a, *b, (long)SvIV(c), (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_pow_sj(pTHX_ mpfr_t * a, mpfr_t * b, SV * c, SV * round) { #if MPFR_VERSION >= 262656 /* 4.2.0 */ return newSViv(mpfr_pow_sj(*a, *b, (intmax_t)SvIV(c), (mpfr_rnd_t)SvUV(round))); #else PERL_UNUSED_ARG4(a, b, c, round); croak("Rmpfr_pow_sj function not implemented until mpfr-4.2.0. (You have only version %s) ", MPFR_VERSION_STRING); #endif } SV * Rmpfr_pow(pTHX_ mpfr_t * a, mpfr_t * b, mpfr_t * c, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_pow(*a, *b, *c, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_powr(pTHX_ mpfr_t * a, mpfr_t * b, mpfr_t * c, SV * round) { #if MPFR_VERSION >= 262656 /* 4.2.0 */ return newSViv(mpfr_powr(*a, *b, *c, (mpfr_rnd_t)SvUV(round))); #else croak("Rmpfr_powr function not implemented until mpfr-4.2.0. (You have only version %s) ", MPFR_VERSION_STRING); #endif } SV * Rmpfr_pown(pTHX_ mpfr_t * a, mpfr_t * b, SV * c, SV * round) { #if MPFR_VERSION >= 262656 /* 4.2.0 */ return newSViv(mpfr_pown(*a, *b, (intmax_t)SvIV(c), (mpfr_rnd_t)SvUV(round))); #else PERL_UNUSED_ARG4(a, b, c, round); croak("Rmpfr_pown function not implemented until mpfr-4.2.0. (You have only version %s) ", MPFR_VERSION_STRING); #endif } SV * Rmpfr_compound_si(pTHX_ mpfr_t * a, mpfr_t * b, SV * c, SV * round) { #if MPFR_VERSION >= 262656 /* 4.2.0 */ return newSViv(mpfr_compound_si(*a, *b, (long)SvIV(c), (mpfr_rnd_t)SvUV(round))); #else PERL_UNUSED_ARG4(a, b, c, round); croak("Rmpfr_compound_si function not implemented until mpfr-4.2.0. (You have only version %s) ", MPFR_VERSION_STRING); #endif } SV * Rmpfr_compound(pTHX_ mpfr_t * a, mpfr_t * b, mpfr_t * c, SV * round) { #if MPFR_VERSION >= 262912 /* 4.3.0 */ return newSViv(mpfr_compound(*a, *b, *c, (mpfr_rnd_t)SvUV(round))); #else PERL_UNUSED_ARG4(a, b, c, round); croak("Rmpfr_compound function not implemented until mpfr-4.3.0. (You have only version %s) ", MPFR_VERSION_STRING); #endif } SV * Rmpfr_neg(pTHX_ mpfr_t * a, mpfr_t * b, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_neg(*a, *b, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_abs(pTHX_ mpfr_t * a, mpfr_t * b, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_abs(*a, *b, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_mul_2exp(pTHX_ mpfr_t * a, mpfr_t * b, SV * c, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_mul_2exp(*a, *b, (unsigned long)SvUV(c), (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_mul_2ui(pTHX_ mpfr_t * a, mpfr_t * b, SV * c, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_mul_2ui(*a, *b, (unsigned long)SvUV(c), (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_mul_2si(pTHX_ mpfr_t * a, mpfr_t * b, SV * c, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_mul_2si(*a, *b, (long)SvIV(c), (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_div_2exp(pTHX_ mpfr_t * a, mpfr_t * b, SV * c, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_div_2exp(*a, *b, (unsigned long)SvUV(c), (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_div_2ui(pTHX_ mpfr_t * a, mpfr_t * b, SV * c, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_div_2ui(*a, *b, (unsigned long)SvUV(c), (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_div_2si(pTHX_ mpfr_t * a, mpfr_t * b, SV * c, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_div_2si(*a, *b, (long)SvIV(c), (mpfr_rnd_t)SvUV(round))); } int Rmpfr_total_order_p(mpfr_t * a, mpfr_t * b) { #if defined(MPFR_VERSION) && MPFR_VERSION >= 262400 /* version 4.1.0 */ return mpfr_total_order_p(*a, *b); #else if(mpfr_nan_p(*a)) { if(mpfr_signbit(*a)) return 1; /* *a <= *b */ if(mpfr_nan_p(*b)) { if(mpfr_signbit(*b)) return 0; return 1; } return 0; } if(mpfr_nan_p(*b)) { if(mpfr_signbit(*b)) return 0; /* *a > *b */ return 1; } if(mpfr_zero_p(*a) && mpfr_zero_p(*b)) { if(!mpfr_signbit(*a) && mpfr_signbit(*b)) return 0; /* (*a, *b) is (+0, -0) */ return 1; /* (*a, *b) is either (-0, -0) or (-0, +0) or (+0, +0) */ } return mpfr_lessequal_p(*a, *b); #endif } int Rmpfr_cmp(mpfr_t * a, mpfr_t * b) { return mpfr_cmp(*a, *b); } int Rmpfr_cmpabs(mpfr_t * a, mpfr_t * b) { return mpfr_cmpabs(*a, *b); } int Rmpfr_cmpabs_ui(mpfr_t * a, unsigned long b) { #if defined(MPFR_VERSION) && MPFR_VERSION >= 262400 /* version 4.1.0 */ return mpfr_cmpabs_ui(*a, b); #else PERL_UNUSED_ARG2(a, b); croak("The Rmpfr_cmpabs_ui function requires mpfr-4.1.0"); #endif } int Rmpfr_cmp_ui(mpfr_t * a, unsigned long b) { return mpfr_cmp_ui(*a, b); } int Rmpfr_cmp_si(mpfr_t * a, long b) { return mpfr_cmp_si(*a, b); } int Rmpfr_cmp_uj(pTHX_ mpfr_t * a, UV b) { int ret; mpfr_t temp; mpfr_init2(temp, 64); mpfr_set_uj(temp, (uintmax_t)b, GMP_RNDN); ret = mpfr_cmp(*a, temp); mpfr_clear(temp); return ret; } int Rmpfr_cmp_sj(pTHX_ mpfr_t * a, IV b) { int ret; mpfr_t temp; mpfr_init2(temp, 64); mpfr_set_sj(temp, (intmax_t)b, GMP_RNDN); ret = mpfr_cmp(*a, temp); mpfr_clear(temp); return ret; } int Rmpfr_cmp_IV(pTHX_ mpfr_t *a, SV * b) { if(!SV_IS_IOK(b)) croak("Arg provided to Rmpfr_cmp_IV is not an IV"); #if defined(MATH_MPFR_NEED_LONG_LONG_INT) if(SvUOK(b)) { return Rmpfr_cmp_uj(aTHX_ a, SvUV(b)); } return Rmpfr_cmp_sj(aTHX_ a, SvIV(b)); #else if(SvUOK(b)) { return mpfr_cmp_ui(*a, SvUV(b)); } return mpfr_cmp_si(*a, SvIV(b)); #endif } int Rmpfr_cmp_d(mpfr_t * a, double b) { return mpfr_cmp_d(*a, b); } int Rmpfr_cmp_ld(pTHX_ mpfr_t * a, SV * b) { #if defined(USE_LONG_DOUBLE) || defined(USE_QUADMATH) return mpfr_cmp_ld(*a, (long double)SvNV(b)); #else PERL_UNUSED_ARG2(a, b); croak("Rmpfr_cmp_ld not implemented on this build of perl"); #endif } int Rmpfr_cmp_ui_2exp(pTHX_ mpfr_t * a, SV * b, SV * c) { return mpfr_cmp_ui_2exp(*a, (unsigned long)SvUV(b), (mpfr_exp_t)SvIV(c)); } int Rmpfr_cmp_si_2exp(pTHX_ mpfr_t * a, SV * b, SV * c) { return mpfr_cmp_si_2exp(*a, (long)SvIV(b), (mpfr_exp_t)SvIV(c)); } int Rmpfr_eq(mpfr_t * a, mpfr_t * b, unsigned long c) { return mpfr_eq(*a, *b, c); } int Rmpfr_nan_p(mpfr_t * p) { return mpfr_nan_p(*p); } int Rmpfr_inf_p(mpfr_t * p) { return mpfr_inf_p(*p); } int Rmpfr_number_p(mpfr_t * p) { return mpfr_number_p(*p); } void Rmpfr_reldiff(pTHX_ mpfr_t * a, mpfr_t * b, mpfr_t * c, SV * round) { CHECK_ROUNDING_VALUE mpfr_reldiff(*a, *b, *c, (mpfr_rnd_t)SvUV(round)); } int Rmpfr_sgn(mpfr_t * p) { return mpfr_sgn(*p); } int Rmpfr_greater_p(mpfr_t * a, mpfr_t * b) { return mpfr_greater_p(*a, *b); } int Rmpfr_greaterequal_p(mpfr_t * a, mpfr_t * b) { return mpfr_greaterequal_p(*a, *b); } int Rmpfr_less_p(mpfr_t * a, mpfr_t * b) { return mpfr_less_p(*a, *b); } int Rmpfr_lessequal_p(mpfr_t * a, mpfr_t * b) { return mpfr_lessequal_p(*a, *b); } int Rmpfr_lessgreater_p(mpfr_t * a, mpfr_t * b) { return mpfr_lessgreater_p(*a, *b); } int Rmpfr_equal_p(mpfr_t * a, mpfr_t * b) { return mpfr_equal_p(*a, *b); } int Rmpfr_unordered_p(mpfr_t * a, mpfr_t * b) { return mpfr_unordered_p(*a, *b); } SV * Rmpfr_sin_cos(pTHX_ mpfr_t * a, mpfr_t * b, mpfr_t * c, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_sin_cos(*a, *b, *c, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_sinh_cosh(pTHX_ mpfr_t * a, mpfr_t * b, mpfr_t * c, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_sinh_cosh(*a, *b, *c, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_sin(pTHX_ mpfr_t * a, mpfr_t * b, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_sin(*a, *b, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_sinu(pTHX_ mpfr_t *a, mpfr_t *b, unsigned long c, SV *round) { #if MPFR_VERSION >= 262656 return newSViv(mpfr_sinu(*a, *b, c, (mpfr_rnd_t)SvUV(round))); #else PERL_UNUSED_ARG4(a, b, c, round); croak("Rmpfr_sinu function not implemented until mpfr-4.2.0. (You have only version %s) ", MPFR_VERSION_STRING); #endif } SV * Rmpfr_sinpi(pTHX_ mpfr_t *a, mpfr_t *b, SV *round) { #if MPFR_VERSION >= 262656 return newSViv(mpfr_sinpi(*a, *b, (mpfr_rnd_t)SvUV(round))); #else PERL_UNUSED_ARG3(a, b, round); croak("Rmpfr_sinpi function not implemented until mpfr-4.2.0. (You have only version %s) ", MPFR_VERSION_STRING); #endif } SV * Rmpfr_cos(pTHX_ mpfr_t * a, mpfr_t * b, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_cos(*a, *b, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_cosu(pTHX_ mpfr_t *a, mpfr_t *b, unsigned long c, SV *round) { #if MPFR_VERSION >= 262656 return newSViv(mpfr_cosu(*a, *b, c, (mpfr_rnd_t)SvUV(round))); #else PERL_UNUSED_ARG4(a, b, c, round); croak("Rmpfr_cosu function not implemented until mpfr-4.2.0. (You have only version %s) ", MPFR_VERSION_STRING); #endif } SV * Rmpfr_cospi(pTHX_ mpfr_t *a, mpfr_t *b, SV *round) { #if MPFR_VERSION >= 262656 return newSViv(mpfr_cospi(*a, *b, (mpfr_rnd_t)SvUV(round))); #else PERL_UNUSED_ARG3(a, b, round); croak("Rmpfr_cospi function not implemented until mpfr-4.2.0. (You have only version %s) ", MPFR_VERSION_STRING); #endif } SV * Rmpfr_tan(pTHX_ mpfr_t * a, mpfr_t * b, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_tan(*a, *b, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_tanu(pTHX_ mpfr_t *a, mpfr_t *b, unsigned long c, SV *round) { #if MPFR_VERSION >= 262656 return newSViv(mpfr_tanu(*a, *b, c, (mpfr_rnd_t)SvUV(round))); #else PERL_UNUSED_ARG4(a, b, c, round); croak("Rmpfr_tanu function not implemented until mpfr-4.2.0. (You have only version %s) ", MPFR_VERSION_STRING); #endif } SV * Rmpfr_tanpi(pTHX_ mpfr_t *a, mpfr_t *b, SV *round) { #if MPFR_VERSION >= 262656 return newSViv(mpfr_tanpi(*a, *b, (mpfr_rnd_t)SvUV(round))); #else PERL_UNUSED_ARG3(a, b, round); croak("Rmpfr_tanpi function not implemented until mpfr-4.2.0. (You have only version %s) ", MPFR_VERSION_STRING); #endif } SV * Rmpfr_asin(pTHX_ mpfr_t * a, mpfr_t * b, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_asin(*a, *b, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_asinu(pTHX_ mpfr_t *a, mpfr_t *b, unsigned long c, SV *round) { #if MPFR_VERSION >= 262656 return newSViv(mpfr_asinu(*a, *b, c, (mpfr_rnd_t)SvUV(round))); #else PERL_UNUSED_ARG4(a, b, c, round); croak("Rmpfr_asinu function not implemented until mpfr-4.2.0. (You have only version %s) ", MPFR_VERSION_STRING); #endif } SV * Rmpfr_asinpi(pTHX_ mpfr_t *a, mpfr_t *b, SV *round) { #if MPFR_VERSION >= 262656 return newSViv(mpfr_asinpi(*a, *b, (mpfr_rnd_t)SvUV(round))); #else PERL_UNUSED_ARG3(a, b, round); croak("Rmpfr_asinpi function not implemented until mpfr-4.2.0. (You have only version %s) ", MPFR_VERSION_STRING); #endif } SV * Rmpfr_acos(pTHX_ mpfr_t * a, mpfr_t * b, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_acos(*a, *b, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_acosu(pTHX_ mpfr_t *a, mpfr_t *b, unsigned long c, SV *round) { #if MPFR_VERSION >= 262656 return newSViv(mpfr_acosu(*a, *b, c, (mpfr_rnd_t)SvUV(round))); #else PERL_UNUSED_ARG4(a, b, c, round); croak("Rmpfr_acosu function not implemented until mpfr-4.2.0. (You have only version %s) ", MPFR_VERSION_STRING); #endif } SV * Rmpfr_acospi(pTHX_ mpfr_t *a, mpfr_t *b, SV *round) { #if MPFR_VERSION >= 262656 return newSViv(mpfr_acospi(*a, *b, (mpfr_rnd_t)SvUV(round))); #else PERL_UNUSED_ARG3(a, b, round); croak("Rmpfr_acospi function not implemented until mpfr-4.2.0. (You have only version %s) ", MPFR_VERSION_STRING); #endif } SV * Rmpfr_atan(pTHX_ mpfr_t * a, mpfr_t * b, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_atan(*a, *b, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_atanu(pTHX_ mpfr_t *a, mpfr_t *b, unsigned long c, SV *round) { #if MPFR_VERSION >= 262656 return newSViv(mpfr_atanu(*a, *b, c, (mpfr_rnd_t)SvUV(round))); #else PERL_UNUSED_ARG4(a, b, c, round); croak("Rmpfr_atanu function not implemented until mpfr-4.2.0. (You have only version %s) ", MPFR_VERSION_STRING); #endif } SV * Rmpfr_atanpi(pTHX_ mpfr_t *a, mpfr_t *b, SV *round) { #if MPFR_VERSION >= 262656 return newSViv(mpfr_atanpi(*a, *b, (mpfr_rnd_t)SvUV(round))); #else PERL_UNUSED_ARG3(a, b, round); croak("Rmpfr_atanpi function not implemented until mpfr-4.2.0. (You have only version %s) ", MPFR_VERSION_STRING); #endif } SV * Rmpfr_sinh(pTHX_ mpfr_t * a, mpfr_t * b, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_sinh(*a, *b, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_cosh(pTHX_ mpfr_t * a, mpfr_t * b, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_cosh(*a, *b, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_tanh(pTHX_ mpfr_t * a, mpfr_t * b, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_tanh(*a, *b, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_asinh(pTHX_ mpfr_t * a, mpfr_t * b, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_asinh(*a, *b, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_acosh(pTHX_ mpfr_t * a, mpfr_t * b, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_acosh(*a, *b, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_atanh(pTHX_ mpfr_t * a, mpfr_t * b, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_atanh(*a, *b, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_fac_ui(pTHX_ mpfr_t * a, SV * b, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_fac_ui(*a, (unsigned long)SvUV(b), (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_log1p(pTHX_ mpfr_t * a, mpfr_t * b, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_log1p(*a, *b, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_expm1(pTHX_ mpfr_t * a, mpfr_t * b, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_expm1(*a, *b, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_exp2m1(pTHX_ mpfr_t * a, mpfr_t * b, SV * round) { #if MPFR_VERSION >= 262656 return newSViv(mpfr_exp2m1(*a, *b, (mpfr_rnd_t)SvUV(round))); #else PERL_UNUSED_ARG3(a, b, round); croak("Rmpfr_exp2m1 function not implemented until mpfr-4.2.0. (You have only version %s) ", MPFR_VERSION_STRING); #endif } SV * Rmpfr_exp10m1(pTHX_ mpfr_t * a, mpfr_t * b, SV * round) { #if MPFR_VERSION >= 262656 return newSViv(mpfr_exp10m1(*a, *b, (mpfr_rnd_t)SvUV(round))); #else PERL_UNUSED_ARG3(a, b, round); croak("Rmpfr_exp10m1 function not implemented until mpfr-4.2.0. (You have only version %s) ", MPFR_VERSION_STRING); #endif } SV * Rmpfr_log2(pTHX_ mpfr_t * a, mpfr_t * b, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_log2(*a, *b, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_log2p1(pTHX_ mpfr_t * a, mpfr_t * b, SV * round) { #if MPFR_VERSION >= 262656 return newSViv(mpfr_log2p1(*a, *b, (mpfr_rnd_t)SvUV(round))); #else PERL_UNUSED_ARG3(a, b, round); croak("Rmpfr_log2p1 function not implemented until mpfr-4.2.0. (You have only version %s) ", MPFR_VERSION_STRING); #endif } SV * Rmpfr_log10(pTHX_ mpfr_t * a, mpfr_t * b, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_log10(*a, *b, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_log10p1(pTHX_ mpfr_t * a, mpfr_t * b, SV * round) { #if MPFR_VERSION >= 262656 return newSViv(mpfr_log10p1(*a, *b, (mpfr_rnd_t)SvUV(round))); #else PERL_UNUSED_ARG3(a, b, round); croak("Rmpfr_log10p1 function not implemented until mpfr-4.2.0. (You have only version %s) ", MPFR_VERSION_STRING); #endif } SV * Rmpfr_fma(pTHX_ mpfr_t * a, mpfr_t * b, mpfr_t * c, mpfr_t * d, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_fma(*a, *b, *c, *d, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_fms(pTHX_ mpfr_t * a, mpfr_t * b, mpfr_t * c, mpfr_t * d, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_fms(*a, *b, *c, *d, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_agm(pTHX_ mpfr_t * a, mpfr_t * b, mpfr_t * c, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_agm(*a, *b, *c, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_hypot(pTHX_ mpfr_t * a, mpfr_t * b, mpfr_t * c, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_hypot(*a, *b, *c, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_const_log2(pTHX_ mpfr_t * p, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_const_log2(*p, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_const_pi(pTHX_ mpfr_t * p, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_const_pi(*p, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_const_euler(pTHX_ mpfr_t * p, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_const_euler(*p, (mpfr_rnd_t)SvUV(round))); } /* Removed in Math-MPFR-3.30. Should have been removed much earlier void Rmpfr_print_binary(mpfr_t * p) { mpfr_print_binary(*p); } */ SV * Rmpfr_rint(pTHX_ mpfr_t * a, mpfr_t * b, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_rint(*a, *b, (mpfr_rnd_t)SvUV(round))); } int Rmpfr_ceil(mpfr_t * a, mpfr_t * b) { return mpfr_ceil(*a, *b); } int Rmpfr_floor(mpfr_t * a, mpfr_t * b) { return mpfr_floor(*a, *b); } int Rmpfr_round(mpfr_t * a, mpfr_t * b) { return mpfr_round(*a, *b); } int Rmpfr_trunc(mpfr_t * a, mpfr_t * b) { return mpfr_trunc(*a, *b); } /* NO LONGER SUPPORTED - use Rmpfr_nextabove instead SV * Rmpfr_add_one_ulp(mpfr_t * p, SV * round) { return newSViv(mpfr_add_one_ulp(*p, (mpfr_rnd_t)SvUV(round))); } */ /* NO LONGER SUPPORTED - use Rmpfr_nextbelow instead SV * Rmpfr_sub_one_ulp(mpfr_t * p, SV * round) { return newSViv(mpfr_sub_one_ulp(*p, (mpfr_rnd_t)SvUV(round))); } */ SV * Rmpfr_can_round(pTHX_ mpfr_t * p, SV * err, SV * round1, SV * round2, SV * prec) { #if MPFR_VERSION_MAJOR < 3 if((mpfr_rnd_t)SvUV(round1) > 3 || (mpfr_rnd_t)SvUV(round2) > 3) { PERL_UNUSED_ARG5(p, err, round1, round2, prec); croak("Illegal rounding value supplied for this version (%s) of the mpfr library", MPFR_VERSION_STRING); } #endif return newSViv(mpfr_can_round(*p, (mpfr_exp_t)SvIV(err), SvUV(round1), SvUV(round2), (mpfr_prec_t)SvIV(prec))); } SV * Rmpfr_print_rnd_mode(pTHX_ SV * rnd) { const char * x = mpfr_print_rnd_mode((mpfr_rnd_t)SvIV(rnd)); if(x == NULL) return &PL_sv_undef; return newSVpv(x, 0); } SV * Rmpfr_get_emin(pTHX) { return newSViv(mpfr_get_emin()); } SV * Rmpfr_get_emax(pTHX) { return newSViv(mpfr_get_emax()); } int Rmpfr_set_emin(pTHX_ SV * e) { return mpfr_set_emin((mpfr_exp_t)SvIV(e)); } int Rmpfr_set_emax(pTHX_ SV * e) { return mpfr_set_emax((mpfr_exp_t)SvIV(e)); } SV * Rmpfr_check_range(pTHX_ mpfr_t * p, SV * t, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_check_range(*p, (int)SvIV(t), (mpfr_rnd_t)SvUV(round))); } void Rmpfr_clear_underflow(void) { mpfr_clear_underflow(); } void Rmpfr_clear_overflow(void) { mpfr_clear_overflow(); } void Rmpfr_clear_nanflag(void) { mpfr_clear_nanflag(); } void Rmpfr_clear_inexflag(void) { mpfr_clear_inexflag(); } void Rmpfr_clear_flags(void) { mpfr_clear_flags(); } int Rmpfr_underflow_p(void) { return mpfr_underflow_p(); } int Rmpfr_overflow_p(void) { return mpfr_overflow_p(); } int Rmpfr_nanflag_p(void) { return mpfr_nanflag_p(); } int Rmpfr_inexflag_p(void) { return mpfr_inexflag_p(); } SV * Rmpfr_log(pTHX_ mpfr_t * a, mpfr_t * b, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_log(*a, *b, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_exp(pTHX_ mpfr_t * a, mpfr_t * b, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_exp(*a, *b, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_exp2(pTHX_ mpfr_t * a, mpfr_t * b, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_exp2(*a, *b, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_exp10(pTHX_ mpfr_t * a, mpfr_t * b, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_exp10(*a, *b, (mpfr_rnd_t)SvUV(round))); } void Rmpfr_urandomb(pTHX_ SV * x, ...) { dXSARGS; unsigned long i, t; PERL_UNUSED_ARG(x); t = items; --t; for(i = 0; i < t; ++i) { mpfr_urandomb(*(INT2PTR(mpfr_t *, SvIVX(SvRV(ST(i))))), *(INT2PTR(gmp_randstate_t *, SvIVX(SvRV(ST(t)))))); } XSRETURN(0); } void Rmpfr_random2(pTHX_ mpfr_t * p, SV * s, SV * exp) { #if MPFR_VERSION_MAJOR > 2 PERL_UNUSED_ARG3(p, s, exp); croak("Rmpfr_random2 no longer implemented. Use Rmpfr_urandom or Rmpfr_urandomb"); #else mpfr_random2(*p, (int)SvIV(s), (mpfr_exp_t)SvIV(exp)); #endif } SV * _TRmpfr_out_str(pTHX_ FILE * stream, SV * base, SV * dig, mpfr_t * p, SV * round) { size_t ret; CHECK_ROUNDING_VALUE if( FAILS_CHECK_OUTPUT_BASE ) croak("2nd argument supplied to TRmpfr_out_str is out of allowable range" ); ret = mpfr_out_str(stream, (int)SvIV(base), (size_t)SvUV(dig), *p, (mpfr_rnd_t)SvUV(round)); fflush(stream); return newSVuv(ret); } SV * _Rmpfr_out_str(pTHX_ mpfr_t * p, SV * base, SV * dig, SV * round) { size_t ret; CHECK_ROUNDING_VALUE if( FAILS_CHECK_OUTPUT_BASE ) croak("2nd argument supplied to Rmpfr_out_str is out of allowable range" ); ret = mpfr_out_str(stdout, (int)SvIV(base), (size_t)SvUV(dig), *p, (mpfr_rnd_t)SvUV(round)); fflush(stdout); return newSVuv(ret); } SV * _TRmpfr_out_strS(pTHX_ FILE * stream, SV * base, SV * dig, mpfr_t * p, SV * round, SV * suff) { size_t ret; CHECK_ROUNDING_VALUE if( FAILS_CHECK_OUTPUT_BASE ) croak("2nd argument supplied to TRmpfr_out_str is out of allowable range" ); ret = mpfr_out_str(stream, (int)SvIV(base), (size_t)SvUV(dig), *p, (mpfr_rnd_t)SvUV(round)); fflush(stream); fprintf(stream, "%s", SvPV_nolen(suff)); fflush(stream); return newSVuv(ret); } SV * _TRmpfr_out_strP(pTHX_ SV * pre, FILE * stream, SV * base, SV * dig, mpfr_t * p, SV * round) { size_t ret; CHECK_ROUNDING_VALUE if( FAILS_CHECK_OUTPUT_BASE ) croak("3rd argument supplied to TRmpfr_out_str is out of allowable range" ); fprintf(stream, "%s", SvPV_nolen(pre)); fflush(stream); ret = mpfr_out_str(stream, (int)SvIV(base), (size_t)SvUV(dig), *p, (mpfr_rnd_t)SvUV(round)); fflush(stream); return newSVuv(ret); } SV * _TRmpfr_out_strPS(pTHX_ SV * pre, FILE * stream, SV * base, SV * dig, mpfr_t * p, SV * round, SV * suff) { size_t ret; CHECK_ROUNDING_VALUE if( FAILS_CHECK_OUTPUT_BASE ) croak("3rd argument supplied to TRmpfr_out_str is out of allowable range" ); fprintf(stream, "%s", SvPV_nolen(pre)); fflush(stream); ret = mpfr_out_str(stream, (int)SvIV(base), (size_t)SvUV(dig), *p, (mpfr_rnd_t)SvUV(round)); fflush(stream); fprintf(stream, "%s", SvPV_nolen(suff)); fflush(stream); return newSVuv(ret); } SV * _Rmpfr_out_strS(pTHX_ mpfr_t * p, SV * base, SV * dig, SV * round, SV * suff) { size_t ret; CHECK_ROUNDING_VALUE if( FAILS_CHECK_OUTPUT_BASE ) croak("2nd argument supplied to Rmpfr_out_str is out of allowable range" ); ret = mpfr_out_str(stdout, (int)SvIV(base), (size_t)SvUV(dig), *p, (mpfr_rnd_t)SvUV(round)); printf("%s", SvPV_nolen(suff)); fflush(stdout); return newSVuv(ret); } SV * _Rmpfr_out_strP(pTHX_ SV * pre, mpfr_t * p, SV * base, SV * dig, SV * round) { size_t ret; CHECK_ROUNDING_VALUE if( FAILS_CHECK_OUTPUT_BASE ) croak("3rd argument supplied to Rmpfr_out_str is out of allowable range" ); printf("%s", SvPV_nolen(pre)); ret = mpfr_out_str(stdout, (int)SvIV(base), (size_t)SvUV(dig), *p, (mpfr_rnd_t)SvUV(round)); fflush(stdout); return newSVuv(ret); } SV * _Rmpfr_out_strPS(pTHX_ SV * pre, mpfr_t * p, SV * base, SV * dig, SV * round, SV * suff) { size_t ret; CHECK_ROUNDING_VALUE if( FAILS_CHECK_OUTPUT_BASE ) croak("3rd argument supplied to Rmpfr_out_str is out of allowable range" ); printf("%s", SvPV_nolen(pre)); ret = mpfr_out_str(stdout, (int)SvIV(base), (size_t)SvUV(dig), *p, (mpfr_rnd_t)SvUV(round)); printf("%s", SvPV_nolen(suff)); fflush(stdout); return newSVuv(ret); } SV * TRmpfr_inp_str(pTHX_ mpfr_t * p, FILE * stream, SV * base, SV * round) { size_t ret; CHECK_ROUNDING_VALUE if( FAILS_CHECK_INPUT_BASE ) croak("3rd argument supplied to TRmpfr_inp_str is out of allowable range" ); ret = mpfr_inp_str(*p, stream, (int)SvIV(base), (mpfr_rnd_t)SvUV(round)); if(!ret) { nnum++; if(SvIV(get_sv("Math::MPFR::NNW", 0))) warn("input to TRmpfr_inp_str contains non-numeric characters"); } /* fflush(stream); */ return newSVuv(ret); } SV * Rmpfr_inp_str(pTHX_ mpfr_t * p, SV * base, SV * round) { size_t ret; CHECK_ROUNDING_VALUE if( FAILS_CHECK_INPUT_BASE ) croak("2nd argument supplied to Rmpfr_inp_str is out of allowable range" ); ret = mpfr_inp_str(*p, stdin, (int)SvIV(base), (mpfr_rnd_t)SvUV(round)); if(!ret) { nnum++; if(SvIV(get_sv("Math::MPFR::NNW", 0))) warn("input to Rmpfr_inp_str contains non-numeric characters"); } /* fflush(stdin); */ return newSVuv(ret); } SV * Rmpfr_gamma(pTHX_ mpfr_t * a, mpfr_t * b, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_gamma(*a, *b, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_zeta(pTHX_ mpfr_t * a, mpfr_t * b, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_zeta(*a, *b, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_zeta_ui(pTHX_ mpfr_t * a, SV * b, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_zeta_ui(*a, (unsigned long)SvUV(b), (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_erf(pTHX_ mpfr_t * a, mpfr_t * b, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_erf(*a, *b, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_frac(pTHX_ mpfr_t * a, mpfr_t * b, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_frac(*a, *b, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_remainder(pTHX_ mpfr_t * a, mpfr_t * b, mpfr_t * c, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_remainder(*a, *b, *c, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_modf(pTHX_ mpfr_t * a, mpfr_t * b, mpfr_t * c, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_modf(*a, *b, *c, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_fmod(pTHX_ mpfr_t * a, mpfr_t * b, mpfr_t * c, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_fmod(*a, *b, *c, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_fmod_ui(pTHX_ mpfr_t * a, mpfr_t * b, unsigned long c, SV * round) { #if MPFR_VERSION >= 262656 return newSViv(mpfr_fmod_ui(*a, *b, c, (mpfr_rnd_t)SvUV(round))); #else mpfr_t temp; int ret; CHECK_ROUNDING_VALUE mpfr_init2(temp, LONGSIZE * 8); mpfr_set_ui(temp, c, GMP_RNDN); ret = mpfr_fmod(*a, *b, temp, (mpfr_rnd_t)SvUV(round)); mpfr_clear(temp); return newSViv(ret); #endif } void Rmpfr_remquo(pTHX_ mpfr_t * a, mpfr_t * b, mpfr_t * c, SV * round) { dXSARGS; long ret, q; PERL_UNUSED_ARG(items); CHECK_ROUNDING_VALUE ret = mpfr_remquo(*a, &q, *b, *c, (mpfr_rnd_t)SvUV(round)); ST(0) = sv_2mortal(newSViv(q)); ST(1) = sv_2mortal(newSViv(ret)); XSRETURN(2); } int Rmpfr_integer_p(mpfr_t * p) { return mpfr_integer_p(*p); } void Rmpfr_nexttoward(mpfr_t * a, mpfr_t * b) { mpfr_nexttoward(*a, *b); } void Rmpfr_nextabove(mpfr_t * p) { mpfr_nextabove(*p); } void Rmpfr_nextbelow(mpfr_t * p) { mpfr_nextbelow(*p); } SV * Rmpfr_min(pTHX_ mpfr_t * a, mpfr_t * b, mpfr_t * c, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_min(*a, *b, *c, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_max(pTHX_ mpfr_t * a, mpfr_t * b, mpfr_t * c, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_max(*a, *b, *c, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_get_exp(pTHX_ mpfr_t * p) { return newSViv(mpfr_get_exp(*p)); } SV * Rmpfr_set_exp(pTHX_ mpfr_t * p, SV * exp) { return newSViv(mpfr_set_exp(*p, (mpfr_exp_t)SvIV(exp))); } int Rmpfr_signbit(mpfr_t * op) { return mpfr_signbit(*op); } SV * Rmpfr_setsign(pTHX_ mpfr_t * rop, mpfr_t * op, SV * sign, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_setsign(*rop, *op, SvIV(sign), (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_copysign(pTHX_ mpfr_t * rop, mpfr_t * op1, mpfr_t * op2, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_copysign(*rop, *op1, *op2, (mpfr_rnd_t)SvUV(round))); } SV * get_refcnt(pTHX_ SV * s) { return newSVuv(SvREFCNT(s)); } SV * get_package_name(pTHX_ SV * x) { if(sv_isobject(x)) return newSVpv(HvNAME(SvSTASH(SvRV(x))), 0); return newSViv(0); } void Rmpfr_dump(mpfr_t * a) { /* Once took a 'round' argument */ mpfr_dump(*a); } SV * gmp_v(pTHX) { #if __GNU_MP_VERSION >= 4 return newSVpv(gmp_version, 0); #else warn("From Math::MPFR::gmp_v(aTHX): 'gmp_version' is not implemented - returning '0'"); return newSVpv("0", 0); #endif } /* NEW in MPFR-2.1.0 */ SV * Rmpfr_set_ui_2exp(pTHX_ mpfr_t * a, SV * b, SV * c, SV * round) { return newSViv(mpfr_set_ui_2exp(*a, (unsigned long)SvUV(b), (mpfr_exp_t)SvIV(c), (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_set_si_2exp(pTHX_ mpfr_t * a, SV * b, SV * c, SV * round) { return newSViv(mpfr_set_si_2exp(*a, (long)SvIV(b), (mpfr_exp_t)SvIV(c), (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_set_uj_2exp(pTHX_ mpfr_t * a, SV * b, SV * c, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_set_uj_2exp(*a, (uintmax_t)SvUV(b), (uintmax_t)SvIV(c), (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_set_sj_2exp(pTHX_ mpfr_t * a, SV * b, SV * c, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_set_sj_2exp(*a, (intmax_t)SvIV(b), (intmax_t)SvIV(c), (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_get_z(pTHX_ mpz_t * a, mpfr_t * b, SV * round) { if(!mpfr_number_p(*b)) croak("In Rmpfr_get_z: Cannot coerce an 'Inf' or 'NaN' to a Math::GMPz object"); #if MPFR_VERSION_MAJOR < 3 CHECK_ROUNDING_VALUE mpfr_get_z(*a, *b, (mpfr_rnd_t)SvUV(round)); return &PL_sv_undef; #else PERL_UNUSED_ARG3(a, b, round); return newSViv(mpfr_get_z(*a, *b, (mpfr_rnd_t)SvUV(round))); #endif } SV * Rmpfr_si_sub(pTHX_ mpfr_t * a, SV * c, mpfr_t * b, SV * round) { CHECK_ROUNDING_VALUE DEAL_WITH_NANFLAG_BUG return newSViv(mpfr_si_sub(*a, (long)SvIV(c), *b, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_sub_si(pTHX_ mpfr_t * a, mpfr_t * b, SV * c, SV * round){ CHECK_ROUNDING_VALUE DEAL_WITH_NANFLAG_BUG return newSViv(mpfr_sub_si(*a, *b, (long)SvIV(c), (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_mul_si(pTHX_ mpfr_t * a, mpfr_t * b, SV * c, SV * round){ CHECK_ROUNDING_VALUE return newSViv(mpfr_mul_si(*a, *b, (long)SvIV(c), (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_si_div(pTHX_ mpfr_t * a, SV * b, mpfr_t * c, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_si_div(*a, (long)SvIV(b), *c, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_div_si(pTHX_ mpfr_t * a, mpfr_t * b, SV * c, SV * round){ CHECK_ROUNDING_VALUE return newSViv(mpfr_div_si(*a, *b, (long)SvIV(c), (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_sqr(pTHX_ mpfr_t * a, mpfr_t * b, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_sqr(*a, *b, (mpfr_rnd_t)SvUV(round))); } int Rmpfr_cmp_z(mpfr_t * a, mpz_t * b) { return mpfr_cmp_z(*a, *b); } int Rmpfr_cmp_q(mpfr_t * a, mpq_t * b) { return mpfr_cmp_q(*a, *b); } int fr_cmp_q_rounded(pTHX_ mpfr_t * a, mpq_t * b, SV * round) { CHECK_ROUNDING_VALUE mpfr_t temp; int ret; mpfr_init(temp); mpfr_set_q(temp, *b, (mpfr_rnd_t)SvUV(round)); ret = mpfr_cmp(*a, temp); mpfr_clear(temp); return ret; } int Rmpfr_cmp_f(mpfr_t * a, mpf_t * b) { return mpfr_cmp_f(*a, *b); } int Rmpfr_zero_p(mpfr_t * a) { return mpfr_zero_p(*a); } void Rmpfr_free_cache(void) { mpfr_free_cache(); } void Rmpfr_free_cache2(unsigned int way) { #if MPFR_VERSION_MAJOR >= 4 mpfr_free_cache2((mpfr_free_cache_t) way); #else PERL_UNUSED_ARG(way); croak("Rmpfr_free_cache2 not implemented with this mpfr version (%s) - need 4.0.0 or later", MPFR_VERSION_STRING); #endif } void Rmpfr_free_pool(void) { #if MPFR_VERSION_MAJOR >= 4 mpfr_free_pool(); #else croak("Rmpfr_free_pool not implemented with this mpfr version (%s) - need 4.0.0 or later", MPFR_VERSION_STRING); #endif } SV * Rmpfr_get_version(pTHX) { return newSVpv(mpfr_get_version(), 0); } SV * Rmpfr_get_patches(pTHX) { return newSVpv(mpfr_get_patches(), 0); } SV * Rmpfr_get_emin_min(pTHX) { return newSViv(mpfr_get_emin_min()); } SV * Rmpfr_get_emin_max(pTHX) { return newSViv(mpfr_get_emin_max()); } SV * Rmpfr_get_emax_min(pTHX) { return newSViv(mpfr_get_emax_min()); } SV * Rmpfr_get_emax_max(pTHX) { return newSViv(mpfr_get_emax_max()); } void Rmpfr_clear_erangeflag(void) { mpfr_clear_erangeflag(); } int Rmpfr_erangeflag_p(void) { return mpfr_erangeflag_p(); } SV * Rmpfr_rint_round(pTHX_ mpfr_t * a, mpfr_t * b, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_rint_round(*a, *b, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_rint_trunc(pTHX_ mpfr_t * a, mpfr_t * b, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_rint_trunc(*a, *b, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_rint_ceil(pTHX_ mpfr_t * a, mpfr_t * b, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_rint_ceil(*a, *b, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_rint_floor(pTHX_ mpfr_t * a, mpfr_t * b, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_rint_floor(*a, *b, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_get_ui(pTHX_ mpfr_t * a, SV * round) { CHECK_ROUNDING_VALUE return newSVuv(mpfr_get_ui(*a, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_get_si(pTHX_ mpfr_t * a, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_get_si(*a, (mpfr_rnd_t)SvUV(round))); } /* NOT to be made available if MATH_MPFR_NEED_LONG_LONG_INT is defined */ SV * Rmpfr_get_uj(pTHX_ mpfr_t * a, SV * round) { CHECK_ROUNDING_VALUE #ifdef MATH_MPFR_NEED_LONG_LONG_INT return newSVuv(mpfr_get_uj(*a, (mpfr_rnd_t)SvUV(round))); #else PERL_UNUSED_ARG2(a, round); croak ("Rmpfr_get_uj not implemented on this build of perl"); #endif } /* NOT to be made available if MATH_MPFR_NEED_LONG_LONG_INT is defined */ SV * Rmpfr_get_sj(pTHX_ mpfr_t * a, SV * round) { CHECK_ROUNDING_VALUE #ifdef MATH_MPFR_NEED_LONG_LONG_INT return newSViv(mpfr_get_sj(*a, (mpfr_rnd_t)SvUV(round))); #else PERL_UNUSED_ARG2(a, round); croak ("Rmpfr_get_sj not implemented on this build of perl"); #endif } SV * Rmpfr_get_IV(pTHX_ mpfr_t * x, SV * round) { CHECK_ROUNDING_VALUE /* FLAGS: * * This will set the erange flag if *x is NaN or if *x overflows the IV * * If the erangeflag does not get set, then the inexact flag will be set * * if *x is not an integer. */ #if defined MATH_MPFR_NEED_LONG_LONG_INT if(mpfr_fits_uintmax_p(*x, (mpfr_rnd_t)SvNV(round))) return newSVuv(mpfr_get_uj(*x, (mpfr_rnd_t)SvUV(round))); if(mpfr_fits_intmax_p(*x, (mpfr_rnd_t)SvNV(round))) return newSViv(mpfr_get_sj(*x, (mpfr_rnd_t)SvUV(round))); if(mpfr_sgn(*x) < 0) return newSViv(mpfr_get_sj(*x, (mpfr_rnd_t)SvUV(round))); /* returns IV_MIN */ return newSVuv(mpfr_get_uj(*x, (mpfr_rnd_t)SvUV(round))); /* returns UV_MAX, or * * 0 if *x is NaN */ #else if(mpfr_fits_ulong_p(*x, (mpfr_rnd_t)SvNV(round))) return newSVuv(mpfr_get_ui(*x, (mpfr_rnd_t)SvUV(round))); if(mpfr_fits_slong_p(*x, (mpfr_rnd_t)SvNV(round))) return newSViv(mpfr_get_si(*x, (mpfr_rnd_t)SvUV(round))); if(mpfr_sgn(*x) < 0) return newSViv(mpfr_get_si(*x, (mpfr_rnd_t)SvUV(round))); /* returns IV_MIN */ return newSVuv(mpfr_get_ui(*x, (mpfr_rnd_t)SvUV(round))); /* returns UV_MAX, or * * 0 if *x is NaN */ #endif } int Rmpfr_set_IV(pTHX_ mpfr_t * x, SV * sv, SV * round) { CHECK_ROUNDING_VALUE if(!SV_IS_IOK(sv)) croak("Arg provided to Rmpfr_set_IV is not an IV"); #if defined MATH_MPFR_NEED_LONG_LONG_INT if(SvUOK(sv)) return mpfr_set_uj(*x, SvUV(sv), (mpfr_rnd_t)SvNV(round)); return mpfr_set_sj(*x, SvIV(sv), (mpfr_rnd_t)SvNV(round)); #else if(SvUOK(sv)) return mpfr_set_ui(*x, SvUV(sv), (mpfr_rnd_t)SvNV(round)); return mpfr_set_si(*x, SvIV(sv), (mpfr_rnd_t)SvNV(round)); #endif } void Rmpfr_init_set_IV(pTHX_ SV * q, SV * round) { dXSARGS; mpfr_t * mpfr_t_obj; SV * obj_ref, * obj; int ret; PERL_UNUSED_ARG(items); CHECK_ROUNDING_VALUE NEW_MATH_MPFR_OBJECT("Math::MPFR",Rmpfr_init_set_IV) /* defined in math_mpfr_include.h */ mpfr_init(*mpfr_t_obj); sv_setiv(obj, INT2PTR(IV,mpfr_t_obj)); ret = Rmpfr_set_IV(aTHX_ mpfr_t_obj, q, round); SvREADONLY_on(obj); RETURN_STACK_2 /*defined in math_mpfr_include.h */ } void Rmpfr_init_set_IV_nobless(pTHX_ SV * q, SV * round) { dXSARGS; mpfr_t * mpfr_t_obj; SV * obj_ref, * obj; int ret; PERL_UNUSED_ARG(items); CHECK_ROUNDING_VALUE NEW_MATH_MPFR_OBJECT(NULL,Rmpfr_init_set_IV_nobless) /* defined in math_mpfr_include.h */ mpfr_init(*mpfr_t_obj); sv_setiv(obj, INT2PTR(IV,mpfr_t_obj)); ret = Rmpfr_set_IV(aTHX_ mpfr_t_obj, q, round); SvREADONLY_on(obj); RETURN_STACK_2 /*defined in math_mpfr_include.h */ } SV * Rmpfr_get_NV(pTHX_ mpfr_t * x, SV * round) { CHECK_ROUNDING_VALUE #if defined(CAN_PASS_FLOAT128) return newSVnv(mpfr_get_float128(*x, (mpfr_rnd_t)SvUV(round))); #elif defined(USE_QUADMATH) mpfr_t t; int i, c = 0; mpfr_prec_t exp, bits = 113; mpfr_rnd_t r = (mpfr_rnd_t)SvUV(round); char *out; float128 ret = 0.0Q, sign = 1.0Q; float128 add_on[113] = { 5192296858534827628530496329220096e0Q, 2596148429267413814265248164610048e0Q, 1298074214633706907132624082305024e0Q, 649037107316853453566312041152512e0Q, 324518553658426726783156020576256e0Q, 162259276829213363391578010288128e0Q, 81129638414606681695789005144064e0Q, 40564819207303340847894502572032e0Q, 20282409603651670423947251286016e0Q, 10141204801825835211973625643008e0Q, 5070602400912917605986812821504e0Q, 2535301200456458802993406410752e0Q, 1267650600228229401496703205376e0Q, 633825300114114700748351602688e0Q, 316912650057057350374175801344e0Q, 158456325028528675187087900672e0Q, 79228162514264337593543950336e0Q, 39614081257132168796771975168e0Q, 19807040628566084398385987584e0Q, 9903520314283042199192993792e0Q, 4951760157141521099596496896e0Q, 2475880078570760549798248448e0Q, 1237940039285380274899124224e0Q, 618970019642690137449562112e0Q, 309485009821345068724781056e0Q, 154742504910672534362390528e0Q, 77371252455336267181195264e0Q, 38685626227668133590597632e0Q, 19342813113834066795298816e0Q, 9671406556917033397649408e0Q, 4835703278458516698824704e0Q, 2417851639229258349412352e0Q, 1208925819614629174706176e0Q, 604462909807314587353088e0Q, 302231454903657293676544e0Q, 151115727451828646838272e0Q, 75557863725914323419136e0Q, 37778931862957161709568e0Q, 18889465931478580854784e0Q, 9444732965739290427392e0Q, 4722366482869645213696e0Q, 2361183241434822606848e0Q, 1180591620717411303424e0Q, 590295810358705651712e0Q, 295147905179352825856e0Q, 147573952589676412928e0Q, 73786976294838206464e0Q, 36893488147419103232e0Q, 18446744073709551616e0Q, 9223372036854775808e0Q, 4611686018427387904e0Q, 2305843009213693952e0Q, 1152921504606846976e0Q, 576460752303423488e0Q, 288230376151711744e0Q, 144115188075855872e0Q, 72057594037927936e0Q, 36028797018963968e0Q, 18014398509481984e0Q, 9007199254740992e0Q, 4503599627370496e0Q, 2251799813685248e0Q, 1125899906842624e0Q, 562949953421312e0Q, 281474976710656e0Q, 140737488355328e0Q, 70368744177664e0Q, 35184372088832e0Q, 17592186044416e0Q, 8796093022208e0Q, 4398046511104e0Q, 2199023255552e0Q, 1099511627776e0Q, 549755813888e0Q, 274877906944e0Q, 137438953472e0Q, 68719476736e0Q, 34359738368e0Q, 17179869184e0Q, 8589934592e0Q, 4294967296e0Q, 2147483648e0Q, 1073741824e0Q, 536870912e0Q, 268435456e0Q, 134217728e0Q, 67108864e0Q, 33554432e0Q, 16777216e0Q, 8388608e0Q, 4194304e0Q, 2097152e0Q, 1048576e0Q, 524288e0Q, 262144e0Q, 131072e0Q, 65536e0Q, 32768e0Q, 16384e0Q, 8192e0Q, 4096e0Q, 2048e0Q, 1024e0Q, 512e0Q, 256e0Q, 128e0Q, 64e0Q, 32e0Q, 16e0Q, 8e0Q, 4e0Q, 2e0Q, 1e0Q }; if(!mpfr_regular_p(*x)) return newSVnv((float128)mpfr_get_d(*x, GMP_RNDZ)); exp = mpfr_get_exp(*x); if(exp < -16381) bits = exp + 16494; if(bits <= 0) { mpfr_init2(t, 53); if(mpfr_sgn(*x) > 0) { /* positive */ mpfr_set_str(t, "0.1e-16494", 2, GMP_RNDZ); c = mpfr_cmp(*x, t); mpfr_clear(t); if(c <= 0) { if(r == GMP_RNDN || r == GMP_RNDD || r == GMP_RNDZ) return newSVnv(0.0Q); return newSVnv(0x1p-16494Q); } else { if(r == GMP_RNDN || r == GMP_RNDU || r == MPFR_RNDA) return newSVnv(0x1p-16494Q); return newSVnv(0.0Q); } } else { /* negative */ mpfr_set_str(t, "-0.1e-16494", 2, GMP_RNDZ); c = mpfr_cmp(*x, t); mpfr_clear(t); if(c >= 0) { if(r == GMP_RNDN || r == GMP_RNDU || r == GMP_RNDZ) return newSVnv(0.0Q); return newSVnv(-0x1p-16494Q); } if(c < 0) { if(r == GMP_RNDN || r == GMP_RNDD || r == MPFR_RNDA) return newSVnv(-0x1p-16494Q); return newSVnv(0.0Q); } } } else { mpfr_init2(t, bits); mpfr_set(t, *x, r); } Newxz(out, 115, char); if(out == NULL) croak("Failed to allocate memory in Rmpfr_get_NV function"); mpfr_get_str(out, &exp, 2, 113, t, (mpfr_rnd_t)SvUV(round)); mpfr_clear(t); if(out[0] == '-') { sign = -1.0Q; out++; c++; } else { if(out[0] == '+') { out++; c++; } } for(i = 0; i < bits; i++) { if(out[i] == '1') ret += add_on[i]; } if(c) out--; Safefree(out); c = exp < -16381 ? exp + 16381 : 0; /* function has already returned if exp < -16494 */ if(c) { /* powq(2.0Q, exp) will be zero - so do the calculation in 2 steps */ ret *= powq(2.0Q, c); exp -= c; /* exp += abs(c) */ } ret *= powq(2.0Q, exp - 113); return newSVnv(ret * sign); #elif defined(USE_LONG_DOUBLE) # if defined(LD_SUBNORMAL_BUG) if(mpfr_get_exp(*x) < -16381 && mpfr_regular_p(*x) && mpfr_get_exp(*x) >= -16445 ) { warn("\n mpfr_get_ld is buggy (subnormal values only)\n for this version (%s) of the MPFR library\n", MPFR_VERSION_STRING); croak(" Version 3.1.5 or later is required"); } return newSVnv(mpfr_get_ld(*x, (mpfr_rnd_t)SvUV(round))); # else return newSVnv(mpfr_get_ld(*x, (mpfr_rnd_t)SvUV(round))); # endif #else return newSVnv(mpfr_get_d(*x, (mpfr_rnd_t)SvUV(round))); #endif } SV * Rmpfr_fits_ulong_p(pTHX_ mpfr_t * a, SV * round) { CHECK_ROUNDING_VALUE #if defined(MPFR_VERSION) && MPFR_VERSION > NEG_ZERO_BUG return newSVuv(mpfr_fits_ulong_p(*a, (mpfr_rnd_t)SvUV(round))); #else if((mpfr_rnd_t)SvUV(round) < 3) { if((mpfr_rnd_t)SvUV(round) == 0) { if((mpfr_cmp_d(*a, -0.5) >= 0) && (mpfr_cmp_d(*a, 0.0) <= 0)) return newSVuv(1); } else { if((mpfr_cmp_d(*a, -1.0) > 0) && (mpfr_cmp_d(*a, 0.0) <= 0)) return newSVuv(1); } } return newSVuv(mpfr_fits_ulong_p(*a, (mpfr_rnd_t)SvUV(round))); #endif } SV * Rmpfr_fits_slong_p(pTHX_ mpfr_t * a, SV * round) { CHECK_ROUNDING_VALUE return newSVuv(mpfr_fits_slong_p(*a, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_fits_ushort_p(pTHX_ mpfr_t * a, SV * round) { CHECK_ROUNDING_VALUE #if defined(MPFR_VERSION) && MPFR_VERSION > NEG_ZERO_BUG return newSVuv(mpfr_fits_ushort_p(*a, (mpfr_rnd_t)SvUV(round))); #else if((mpfr_rnd_t)SvUV(round) < 3) { if((mpfr_rnd_t)SvUV(round) == 0) { if((mpfr_cmp_d(*a, -0.5) >= 0) && (mpfr_cmp_d(*a, 0.0) <= 0)) return newSVuv(1); } else { if((mpfr_cmp_d(*a, -1.0) > 0) && (mpfr_cmp_d(*a, 0.0) <= 0)) return newSVuv(1); } } return newSVuv(mpfr_fits_ushort_p(*a, (mpfr_rnd_t)SvUV(round))); #endif } SV * Rmpfr_fits_sshort_p(pTHX_ mpfr_t * a, SV * round) { CHECK_ROUNDING_VALUE return newSVuv(mpfr_fits_sshort_p(*a, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_fits_uint_p(pTHX_ mpfr_t * a, SV * round) { CHECK_ROUNDING_VALUE #if defined(MPFR_VERSION) && MPFR_VERSION > NEG_ZERO_BUG return newSVuv(mpfr_fits_uint_p(*a, (mpfr_rnd_t)SvUV(round))); #else if((mpfr_rnd_t)SvUV(round) < 3) { if((mpfr_rnd_t)SvUV(round) == 0) { if((mpfr_cmp_d(*a, -0.5) >= 0) && (mpfr_cmp_d(*a, 0.0) <= 0)) return newSVuv(1); } else { if((mpfr_cmp_d(*a, -1.0) > 0) && (mpfr_cmp_d(*a, 0.0) <= 0)) return newSVuv(1); } } return newSVuv(mpfr_fits_uint_p(*a, (mpfr_rnd_t)SvUV(round))); #endif } SV * Rmpfr_fits_sint_p(pTHX_ mpfr_t * a, SV * round) { CHECK_ROUNDING_VALUE return newSVuv(mpfr_fits_sint_p(*a, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_fits_uintmax_p(pTHX_ mpfr_t * a, SV * round) { CHECK_ROUNDING_VALUE #if defined(MPFR_VERSION) && MPFR_VERSION > NEG_ZERO_BUG return newSVuv(mpfr_fits_uintmax_p(*a, (mpfr_rnd_t)SvUV(round))); #else if(mpfr_zero_p(*a)) return newSVuv(1); if((mpfr_rnd_t)SvUV(round) < 3) { if((mpfr_rnd_t)SvUV(round) == 0) { if((mpfr_cmp_d(*a, -0.5) >= 0) && (mpfr_cmp_d(*a, 0.0) <= 0)) return newSVuv(1); } else { if((mpfr_cmp_d(*a, -1.0) > 0) && (mpfr_cmp_d(*a, 0.0) <= 0)) return newSVuv(1); } } return newSVuv(mpfr_fits_uintmax_p(*a, (mpfr_rnd_t)SvUV(round))); #endif } SV * Rmpfr_fits_intmax_p(pTHX_ mpfr_t * a, SV * round) { CHECK_ROUNDING_VALUE return newSVuv(mpfr_fits_intmax_p(*a, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_fits_IV_p(pTHX_ mpfr_t * x, SV * round) { CHECK_ROUNDING_VALUE #if defined(MATH_MPFR_NEED_LONG_LONG_INT) if(mpfr_fits_uintmax_p(*x, (mpfr_rnd_t)SvUV(round)) || mpfr_fits_intmax_p (*x, (mpfr_rnd_t)SvUV(round))) return newSViv(1); return newSViv(0); #else if(mpfr_fits_ulong_p(*x, (mpfr_rnd_t)SvUV(round)) || mpfr_fits_slong_p (*x, (mpfr_rnd_t)SvUV(round))) return newSViv(1); return newSViv(0); #endif } SV * Rmpfr_strtofr(pTHX_ mpfr_t * a, SV * str, SV * base, SV * round) { #ifdef _WIN32_BIZARRE_INFNAN int inf_or_nan; #endif CHECK_ROUNDING_VALUE if( FAILS_CHECK_INPUT_BASE ) croak("3rd argument supplied to Rmpfr_strtofr is out of allowable range"); #ifdef _WIN32_BIZARRE_INFNAN inf_or_nan = _win32_infnanstring(SvPV_nolen(str)); if(inf_or_nan) { if(inf_or_nan == 2) { mpfr_set_nan(*a); return newSViv(0); } mpfr_set_inf(*a, inf_or_nan); return newSViv(0); } else { return newSViv(mpfr_strtofr(*a, SvPV_nolen(str), NULL, (int)SvIV(base), (mpfr_rnd_t)SvUV(round))); } #else return newSViv(mpfr_strtofr(*a, SvPV_nolen(str), NULL, (int)SvIV(base), (mpfr_rnd_t)SvUV(round))); #endif } void Rmpfr_set_erangeflag(void) { mpfr_set_erangeflag(); } void Rmpfr_set_underflow(void) { mpfr_set_underflow(); } void Rmpfr_set_overflow(void) { mpfr_set_overflow(); } void Rmpfr_set_nanflag(void) { mpfr_set_nanflag(); } void Rmpfr_set_inexflag(void) { mpfr_set_inexflag(); } SV * Rmpfr_erfc(pTHX_ mpfr_t * a, mpfr_t * b, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_erfc(*a, *b, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_j0(pTHX_ mpfr_t * a, mpfr_t * b, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_j0(*a, *b, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_j1(pTHX_ mpfr_t * a, mpfr_t * b, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_j1(*a, *b, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_jn(pTHX_ mpfr_t * a, SV * n, mpfr_t * b, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_jn(*a, (long)SvIV(n), *b, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_y0(pTHX_ mpfr_t * a, mpfr_t * b, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_y0(*a, *b, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_y1(pTHX_ mpfr_t * a, mpfr_t * b, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_y1(*a, *b, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_yn(pTHX_ mpfr_t * a, SV * n, mpfr_t * b, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_yn(*a, (long)SvIV(n), *b, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_atan2(pTHX_ mpfr_t * a, mpfr_t * b, mpfr_t * c, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_atan2(*a, *b, *c, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_atan2u(pTHX_ mpfr_t *a, mpfr_t *b, mpfr_t *c, unsigned long d, SV *round) { #if MPFR_VERSION >= 262656 return newSViv(mpfr_atan2u(*a, *b, *c, d, (mpfr_rnd_t)SvUV(round))); #else PERL_UNUSED_ARG5(a, b, c, d, round); croak("Rmpfr_atan2u function not implemented until mpfr-4.2.0. (You have only version %s) ", MPFR_VERSION_STRING); #endif } SV * Rmpfr_atan2pi(pTHX_ mpfr_t *a, mpfr_t *b, mpfr_t *c, SV *round) { #if MPFR_VERSION >= 262656 return newSViv(mpfr_atan2pi(*a, *b, *c, (mpfr_rnd_t)SvUV(round))); #else PERL_UNUSED_ARG4(a, b, c, round); croak("Rmpfr_atan2pi function not implemented until mpfr-4.2.0. (You have only version %s) ", MPFR_VERSION_STRING); #endif } SV * Rmpfr_pow_z(pTHX_ mpfr_t * a, mpfr_t * b, mpz_t * c, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_pow_z(*a, *b, *c, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_subnormalize(pTHX_ mpfr_t * a, SV * b, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_subnormalize(*a, (int)SvIV(b), (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_const_catalan(pTHX_ mpfr_t * a, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_const_catalan(*a, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_sec(pTHX_ mpfr_t * a, mpfr_t * b, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_sec(*a, *b, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_csc(pTHX_ mpfr_t * a, mpfr_t * b, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_csc(*a, *b, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_cot(pTHX_ mpfr_t * a, mpfr_t * b, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_cot(*a, *b, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_root(pTHX_ mpfr_t * a, mpfr_t * b, SV * c, SV * round) { #if MPFR_VERSION_MAJOR >= 4 PERL_UNUSED_ARG4(a, b, c, round); croak("Rmpfr_root is deprecated, and now removed - use Rmpfr_rootn_ui instead"); #else CHECK_ROUNDING_VALUE return newSViv(mpfr_root(*a, *b, (unsigned long)SvUV(c), (mpfr_rnd_t)SvUV(round))); #endif } SV * Rmpfr_eint(pTHX_ mpfr_t * a, mpfr_t * b, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_eint(*a, *b, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_li2(pTHX_ mpfr_t * a, mpfr_t * b, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_li2(*a, *b, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_get_f(pTHX_ mpf_t * a, mpfr_t * b, SV * round) { CHECK_ROUNDING_VALUE if(!mpfr_number_p(*b)) croak("In Rmpfr_get_f: Cannot coerce an 'Inf' or 'NaN' to a Math::GMPf object"); return newSViv(mpfr_get_f(*a, *b, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_sech(pTHX_ mpfr_t * a, mpfr_t * b, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_sech(*a, *b, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_csch(pTHX_ mpfr_t * a, mpfr_t * b, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_csch(*a, *b, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_coth(pTHX_ mpfr_t * a, mpfr_t * b, SV * round) { CHECK_ROUNDING_VALUE return newSViv(mpfr_coth(*a, *b, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_lngamma(pTHX_ mpfr_t * a, mpfr_t * b, SV * round) { CHECK_ROUNDING_VALUE #if !defined(MPFR_VERSION) || (defined(MPFR_VERSION) && MPFR_VERSION <= LNGAMMA_BUG) if(!mpfr_nan_p(*b) && mpfr_sgn(*b) <= 0) { mpfr_set_inf(*a, 1); return newSViv(0); } #endif return newSViv(mpfr_lngamma(*a, *b, (mpfr_rnd_t)SvUV(round))); } void Rmpfr_lgamma(pTHX_ mpfr_t * a, mpfr_t * b, SV * round) { dXSARGS; int ret, signp; PERL_UNUSED_ARG(items); CHECK_ROUNDING_VALUE ret = mpfr_lgamma(*a, &signp, *b, (mpfr_rnd_t)SvUV(round)); ST(0) = sv_2mortal(newSViv(signp)); ST(1) = sv_2mortal(newSViv(ret)); XSRETURN(2); } SV * _MPFR_VERSION(pTHX) { #if defined(MPFR_VERSION) return newSVuv(MPFR_VERSION); #else return &PL_sv_undef; #endif } SV * _MPFR_VERSION_MAJOR(pTHX) { return newSVuv(MPFR_VERSION_MAJOR); } SV * _MPFR_VERSION_MINOR(pTHX) { return newSVuv(MPFR_VERSION_MINOR); } SV * _MPFR_VERSION_PATCHLEVEL(pTHX) { return newSVuv(MPFR_VERSION_PATCHLEVEL); } SV * _MPFR_VERSION_STRING(pTHX) { return newSVpv(MPFR_VERSION_STRING, 0); } SV * RMPFR_VERSION_NUM(pTHX_ SV * a, SV * b, SV * c) { return newSVuv(MPFR_VERSION_NUM((unsigned long)SvUV(a), (unsigned long)SvUV(b), (unsigned long)SvUV(c))); } SV * Rmpfr_sum(pTHX_ mpfr_t * rop, SV * avref, SV * len, SV * round) { mpfr_ptr *p; SV ** elem; int ret; unsigned long i, s = (unsigned long)SvUV(len); if(s > av_len((AV*)SvRV(avref)) + 1)croak("2nd last arg to Rmpfr_sum is greater than the size of the array"); CHECK_ROUNDING_VALUE Newx(p, s, mpfr_ptr); if(p == NULL) croak("Unable to allocate memory in Rmpfr_sum"); for(i = 0; i < s; ++i) { elem = av_fetch((AV*)SvRV(avref), i, 0); p[i] = *(INT2PTR(mpfr_t *, SvIVX(SvRV(*elem)))); } ret = mpfr_sum(*rop, p, s, (mpfr_rnd_t)SvUV(round)); Safefree(p); return newSViv(ret); } void _fr_to_q(mpq_t * q, mpfr_t * fr) { mpfr_exp_t exponent, denpow; char * str; size_t numlen; if(!mpfr_number_p(*fr)) { if(mpfr_nan_p(*fr)) croak ("In Math::MPFR::_fr_to_q, cannot coerce a NaN to a Math::GMPq value"); croak ("In Math::MPFR::_fr_to_q, cannot coerce an Inf to a Math::GMPq value"); } str = mpfr_get_str(NULL, &exponent, 2, 0, *fr, GMP_RNDN); mpz_set_str(mpq_numref(*q), str, 2); mpz_set_ui (mpq_denref(*q), 1); mpfr_free_str(str); numlen = mpz_sizeinbase(mpq_numref(*q), 2); denpow = (mpfr_exp_t)(numlen - exponent); if(denpow < 0) { mpz_mul_2exp(mpq_numref(*q), mpq_numref(*q), -denpow); } else { mpz_mul_2exp(mpq_denref(*q), mpq_denref(*q), denpow); } mpq_canonicalize(*q); } int Rmpfr_q_div(mpfr_t * rop, mpq_t * q, mpfr_t * fr, int round) { mpq_t t; int ret; /* Handle Inf, NaN and zero values of *fr */ if(!mpfr_regular_p(*fr)) { ret = mpfr_si_div(*rop, mpz_sgn(mpq_numref(*q)), *fr, (mpfr_rnd_t)round); return ret; } mpq_init(t); _fr_to_q(&t, fr); mpq_div(t, *q, t); ret = mpfr_set_q(*rop, t, (mpfr_rnd_t)round); mpq_clear(t); return ret; } int Rmpfr_z_div(mpfr_t * rop, mpz_t * z, mpfr_t * fr, int round) { mpq_t t, tz; int ret; /* Handle Inf, NaN and zero values of *fr */ if(!mpfr_regular_p(*fr)) { ret = mpfr_si_div(*rop, mpz_sgn(*z), *fr, (mpfr_rnd_t)round); return ret; } mpq_init(t); mpq_init(tz); mpq_set_z(tz, *z); _fr_to_q(&t, fr); mpq_div(t, tz, t); ret = mpfr_set_q(*rop, t, (mpfr_rnd_t)round); mpq_clear(t); mpq_clear(tz); return ret; } SV * overload_mul(pTHX_ SV * a, SV * b, SV * third) { mpfr_t * mpfr_t_obj, t; SV * obj_ref, * obj; int ret; PERL_UNUSED_ARG(third); #ifdef _WIN32_BIZARRE_INFNAN int inf_or_nan; #endif NEW_MATH_MPFR_OBJECT("Math::MPFR",overload_mul) /* defined in math_mpfr_include.h */ mpfr_init(*mpfr_t_obj); OBJ_READONLY_ON /*defined in math_mpfr_include.h */ #ifdef MATH_MPFR_NEED_LONG_LONG_INT if(SV_IS_IOK(b)) { mpfr_init2(t, (mpfr_prec_t)IVSIZE_BITS); if(SvUOK(b)) mpfr_set_uj(t, SvUVX(b), __gmpfr_default_rounding_mode); else mpfr_set_sj(t, SvIVX(b), __gmpfr_default_rounding_mode); mpfr_mul(*mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), t, __gmpfr_default_rounding_mode); mpfr_clear(t); return obj_ref; } #else if(SV_IS_IOK(b)) { if(SvUOK(b)) { mpfr_mul_ui(*mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), SvUVX(b), __gmpfr_default_rounding_mode); return obj_ref; } mpfr_mul_si(*mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), SvIVX(b), __gmpfr_default_rounding_mode); return obj_ref; } #endif #if defined(MPFR_PV_NV_BUG) if( (SV_IS_POK(b) && !SV_IS_NOK(b)) || (SV_IS_POK(b) && SV_IS_NOK(b) && SvIOKp(b)) ) { #else if(SV_IS_POK(b)) { #endif NOK_POK_DUALVAR_CHECK , "overload_mul");} #ifdef _WIN32_BIZARRE_INFNAN inf_or_nan = _win32_infnanstring(SvPV_nolen(b)); if(inf_or_nan) { if(inf_or_nan == 2) { mpfr_set_nan(*mpfr_t_obj); mpfr_set_nanflag(); return obj_ref; } mpfr_set_inf(*mpfr_t_obj, inf_or_nan); } else { ret = mpfr_set_str(*mpfr_t_obj, SvPV_nolen(b), 0, __gmpfr_default_rounding_mode); } #else ret = mpfr_set_str(*mpfr_t_obj, SvPV_nolen(b), 0, __gmpfr_default_rounding_mode); #endif NON_NUMERIC_CHAR_CHECK(b), "overload_mul subroutine");} mpfr_mul(*mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *mpfr_t_obj, __gmpfr_default_rounding_mode); return obj_ref; } if(SV_IS_NOK(b)) { #if defined(MPFR_PV_NV_BUG) NOK_POK_DUALVAR_CHECK , "overload_mul");} #endif #if defined(USE_QUADMATH) mpfr_init2(t, FLT128_MANT_DIG); Rmpfr_set_NV(aTHX_ &t, b, __gmpfr_default_rounding_mode); mpfr_mul(*mpfr_t_obj, t, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), __gmpfr_default_rounding_mode); mpfr_clear(t); return obj_ref; } #elif defined(USE_LONG_DOUBLE) mpfr_init2(t, REQUIRED_LDBL_MANT_DIG); mpfr_set_ld(t, (long double)SvNVX(b), __gmpfr_default_rounding_mode); mpfr_mul(*mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), t, __gmpfr_default_rounding_mode); mpfr_clear(t); return obj_ref; } #else mpfr_mul_d(*mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), (double)SvNVX(b), __gmpfr_default_rounding_mode); return obj_ref; } #endif if(sv_isobject(b)) { const char* h = HvNAME(SvSTASH(SvRV(b))); if(strEQ(h, "Math::MPFR")) { mpfr_mul(*mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(b)))), __gmpfr_default_rounding_mode); return obj_ref; } if(strEQ(h, "Math::GMPz") || strEQ(h, "Math::GMP")) { mpfr_mul_z(*mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpz_t * , SvIVX(SvRV(b)))), __gmpfr_default_rounding_mode); return obj_ref; } if(strEQ(h, "Math::GMPq")) { mpfr_mul_q(*mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpq_t * , SvIVX(SvRV(b)))), __gmpfr_default_rounding_mode); return obj_ref; } if(strEQ(h, "Math::GMPf")) { mpfr_init2(t, (mpfr_prec_t)mpf_get_prec(*(INT2PTR(mpf_t *, SvIVX(SvRV(b)))))); mpfr_set_f(t, *(INT2PTR(mpf_t *, SvIVX(SvRV(b)))), __gmpfr_default_rounding_mode); mpfr_mul(*mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), t, __gmpfr_default_rounding_mode); mpfr_clear(t); return obj_ref; } } croak("Invalid argument supplied to Math::MPFR::overload_mul"); } SV * overload_add(pTHX_ SV * a, SV * b, SV * third) { mpfr_t * mpfr_t_obj, t; SV * obj_ref, * obj; int ret; PERL_UNUSED_ARG(third); #ifdef _WIN32_BIZARRE_INFNAN int inf_or_nan; #endif NEW_MATH_MPFR_OBJECT("Math::MPFR",overload_add) /* defined in math_mpfr_include.h */ mpfr_init(*mpfr_t_obj); OBJ_READONLY_ON /*defined in math_mpfr_include.h */ #ifdef MATH_MPFR_NEED_LONG_LONG_INT if(SV_IS_IOK(b)) { mpfr_init2(t, (mpfr_prec_t)IVSIZE_BITS); if(SvUOK(b)) mpfr_set_uj(t, SvUVX(b), __gmpfr_default_rounding_mode); else mpfr_set_sj(t, SvIVX(b), __gmpfr_default_rounding_mode); mpfr_add(*mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), t, __gmpfr_default_rounding_mode); mpfr_clear(t); return obj_ref; } #else DEAL_WITH_NANFLAG_BUG_OVERLOADED if(SV_IS_IOK(b)) { if(SvUOK(b)) { mpfr_add_ui(*mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), SvUVX(b), __gmpfr_default_rounding_mode); return obj_ref; } mpfr_add_si(*mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), SvIVX(b), __gmpfr_default_rounding_mode); return obj_ref; } #endif #if defined(MPFR_PV_NV_BUG) if( (SV_IS_POK(b) && !SV_IS_NOK(b)) || (SV_IS_POK(b) && SV_IS_NOK(b) && SvIOKp(b)) ) { #else if(SV_IS_POK(b)) { #endif NOK_POK_DUALVAR_CHECK , "overload_add");} #ifdef _WIN32_BIZARRE_INFNAN inf_or_nan = _win32_infnanstring(SvPV_nolen(b)); if(inf_or_nan) { if(inf_or_nan == 2) { mpfr_set_nan(*mpfr_t_obj); mpfr_set_nanflag(); return obj_ref; } mpfr_set_inf(*mpfr_t_obj, inf_or_nan); } else { ret = mpfr_set_str(*mpfr_t_obj, SvPV_nolen(b), 0, __gmpfr_default_rounding_mode); } #else ret = mpfr_set_str(*mpfr_t_obj, SvPV_nolen(b), 0, __gmpfr_default_rounding_mode); #endif NON_NUMERIC_CHAR_CHECK(b), "overload_add subroutine");} mpfr_add(*mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *mpfr_t_obj, __gmpfr_default_rounding_mode); return obj_ref; } if(SV_IS_NOK(b)) { #if defined(MPFR_PV_NV_BUG) NOK_POK_DUALVAR_CHECK , "overload_add");} #endif #if defined(USE_QUADMATH) mpfr_init2(t, FLT128_MANT_DIG); Rmpfr_set_NV(aTHX_ &t, b, GMP_RNDN); mpfr_add(*mpfr_t_obj, t, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), __gmpfr_default_rounding_mode); mpfr_clear(t); return obj_ref; } #elif defined(USE_LONG_DOUBLE) mpfr_init2(t, REQUIRED_LDBL_MANT_DIG); mpfr_set_ld(t, (long double)SvNVX(b), __gmpfr_default_rounding_mode); mpfr_add(*mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), t, __gmpfr_default_rounding_mode); mpfr_clear(t); return obj_ref; } #else mpfr_add_d(*mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), (double)SvNVX(b), __gmpfr_default_rounding_mode); return obj_ref; } #endif if(sv_isobject(b)) { const char* h = HvNAME(SvSTASH(SvRV(b))); if(strEQ(h, "Math::MPFR")) { mpfr_add(*mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(b)))), __gmpfr_default_rounding_mode); return obj_ref; } if(strEQ(h, "Math::GMPz") || strEQ(h, "Math::GMP")) { mpfr_add_z(*mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpz_t * , SvIVX(SvRV(b)))), __gmpfr_default_rounding_mode); return obj_ref; } if(strEQ(h, "Math::GMPq")) { mpfr_add_q(*mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpq_t * , SvIVX(SvRV(b)))), __gmpfr_default_rounding_mode); return obj_ref; } if(strEQ(h, "Math::GMPf")) { mpfr_init2(t, (mpfr_prec_t)mpf_get_prec(*(INT2PTR(mpf_t *, SvIVX(SvRV(b)))))); mpfr_set_f(t, *(INT2PTR(mpf_t *, SvIVX(SvRV(b)))), __gmpfr_default_rounding_mode); mpfr_add(*mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), t, __gmpfr_default_rounding_mode); mpfr_clear(t); return obj_ref; } } croak("Invalid argument supplied to Math::MPFR::overload_add"); } SV * overload_sub(pTHX_ SV * a, SV * b, SV * third) { mpfr_t * mpfr_t_obj, t; SV * obj_ref, * obj; int ret; #ifdef _WIN32_BIZARRE_INFNAN int inf_or_nan; #endif NEW_MATH_MPFR_OBJECT("Math::MPFR",overload_sub) /* defined in math_mpfr_include.h */ mpfr_init(*mpfr_t_obj); OBJ_READONLY_ON /*defined in math_mpfr_include.h */ #ifdef MATH_MPFR_NEED_LONG_LONG_INT if(SV_IS_IOK(b)) { mpfr_init2(t, (mpfr_prec_t)IVSIZE_BITS); if(SvUOK(b)) mpfr_set_uj(t, SvUVX(b), __gmpfr_default_rounding_mode); else mpfr_set_sj(t, SvIVX(b), __gmpfr_default_rounding_mode); if(SWITCH_ARGS) mpfr_sub(*mpfr_t_obj, t, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), __gmpfr_default_rounding_mode); else mpfr_sub(*mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), t, __gmpfr_default_rounding_mode); mpfr_clear(t); return obj_ref; } #else DEAL_WITH_NANFLAG_BUG_OVERLOADED if(SV_IS_IOK(b)) { if(SvUOK(b)) { if(SWITCH_ARGS) mpfr_ui_sub(*mpfr_t_obj, SvUVX(b), *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), __gmpfr_default_rounding_mode); else mpfr_sub_ui(*mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), SvUVX(b), __gmpfr_default_rounding_mode); return obj_ref; } if(SWITCH_ARGS) mpfr_si_sub(*mpfr_t_obj, SvIVX(b), *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), __gmpfr_default_rounding_mode); else mpfr_sub_si(*mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), SvIVX(b), __gmpfr_default_rounding_mode); return obj_ref; } #endif #if defined(MPFR_PV_NV_BUG) if( (SV_IS_POK(b) && !SV_IS_NOK(b)) || (SV_IS_POK(b) && SV_IS_NOK(b) && SvIOKp(b)) ) { #else if(SV_IS_POK(b)) { #endif NOK_POK_DUALVAR_CHECK , "overload_sub");} #ifdef _WIN32_BIZARRE_INFNAN inf_or_nan = _win32_infnanstring(SvPV_nolen(b)); if(inf_or_nan) { if(inf_or_nan == 2) { mpfr_set_nan(*mpfr_t_obj); mpfr_set_nanflag(); return obj_ref; } mpfr_set_inf(*mpfr_t_obj, inf_or_nan); } else { ret = mpfr_set_str(*mpfr_t_obj, SvPV_nolen(b), 0, __gmpfr_default_rounding_mode); } #else ret = mpfr_set_str(*mpfr_t_obj, SvPV_nolen(b), 0, __gmpfr_default_rounding_mode); #endif NON_NUMERIC_CHAR_CHECK(b), "overload_sub subroutine");} if(SWITCH_ARGS) mpfr_sub(*mpfr_t_obj, *mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), __gmpfr_default_rounding_mode); else mpfr_sub(*mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *mpfr_t_obj, __gmpfr_default_rounding_mode); return obj_ref; } if(SV_IS_NOK(b)) { #if defined(MPFR_PV_NV_BUG) NOK_POK_DUALVAR_CHECK , "overload_sub");} #endif #if defined(USE_QUADMATH) mpfr_init2(t, FLT128_MANT_DIG); Rmpfr_set_NV(aTHX_ &t, b, GMP_RNDN); if(SWITCH_ARGS) mpfr_sub(*mpfr_t_obj, t, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), __gmpfr_default_rounding_mode); else mpfr_sub(*mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), t, __gmpfr_default_rounding_mode); mpfr_clear(t); return obj_ref; } #elif defined(USE_LONG_DOUBLE) mpfr_init2(t, REQUIRED_LDBL_MANT_DIG); mpfr_set_ld(t, (long double)SvNVX(b), __gmpfr_default_rounding_mode); if(SWITCH_ARGS) mpfr_sub(*mpfr_t_obj, t, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), __gmpfr_default_rounding_mode); else mpfr_sub(*mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), t, __gmpfr_default_rounding_mode); mpfr_clear(t); return obj_ref; } #else if(SWITCH_ARGS) mpfr_d_sub(*mpfr_t_obj, SvNVX(b), *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), __gmpfr_default_rounding_mode); else mpfr_sub_d(*mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), SvNVX(b), __gmpfr_default_rounding_mode); return obj_ref; } #endif if(sv_isobject(b)) { const char* h = HvNAME(SvSTASH(SvRV(b))); if(strEQ(h, "Math::MPFR")) { mpfr_sub(*mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(b)))), __gmpfr_default_rounding_mode); return obj_ref; } if(strEQ(h, "Math::GMPz") || strEQ(h, "Math::GMP")) { mpfr_sub_z(*mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpz_t * , SvIVX(SvRV(b)))), __gmpfr_default_rounding_mode); if(SWITCH_ARGS) mpfr_neg(*mpfr_t_obj, *mpfr_t_obj, GMP_RNDN); return obj_ref; } if(strEQ(h, "Math::GMPq")) { mpfr_sub_q(*mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpq_t * , SvIVX(SvRV(b)))), __gmpfr_default_rounding_mode); if(SWITCH_ARGS) mpfr_neg(*mpfr_t_obj, *mpfr_t_obj, GMP_RNDN); return obj_ref; } if(strEQ(h, "Math::GMPf")) { mpfr_init2(t, (mpfr_prec_t)mpf_get_prec(*(INT2PTR(mpf_t *, SvIVX(SvRV(b)))))); mpfr_set_f(t, *(INT2PTR(mpf_t *, SvIVX(SvRV(b)))), __gmpfr_default_rounding_mode); if(SWITCH_ARGS) mpfr_sub(*mpfr_t_obj, t, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), __gmpfr_default_rounding_mode); else mpfr_sub(*mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), t, __gmpfr_default_rounding_mode); mpfr_clear(t); return obj_ref; } } croak("Invalid argument supplied to Math::MPFR::overload_sub function"); } SV * overload_div(pTHX_ SV * a, SV * b, SV * third) { mpfr_t * mpfr_t_obj, t; SV * obj_ref, * obj; int ret; #ifdef _WIN32_BIZARRE_INFNAN int inf_or_nan; #endif NEW_MATH_MPFR_OBJECT("Math::MPFR",overload_div) /* defined in math_mpfr_include.h */ mpfr_init(*mpfr_t_obj); OBJ_READONLY_ON /*defined in math_mpfr_include.h */ #ifdef MATH_MPFR_NEED_LONG_LONG_INT if(SV_IS_IOK(b)) { mpfr_init2(t, (mpfr_prec_t)IVSIZE_BITS); if(SvUOK(b)) mpfr_set_uj(t, SvUVX(b), __gmpfr_default_rounding_mode); else mpfr_set_sj(t, SvIVX(b), __gmpfr_default_rounding_mode); if(SWITCH_ARGS) mpfr_div(*mpfr_t_obj, t, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), __gmpfr_default_rounding_mode); else mpfr_div(*mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), t, __gmpfr_default_rounding_mode); mpfr_clear(t); return obj_ref; } #else if(SV_IS_IOK(b)) { if(SvUOK(b)) { if(SWITCH_ARGS) mpfr_ui_div(*mpfr_t_obj, SvUVX(b), *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), __gmpfr_default_rounding_mode); else mpfr_div_ui(*mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), SvUVX(b), __gmpfr_default_rounding_mode); return obj_ref; } if(SWITCH_ARGS) mpfr_si_div(*mpfr_t_obj, SvIVX(b), *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), __gmpfr_default_rounding_mode); else mpfr_div_si(*mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), SvIVX(b), __gmpfr_default_rounding_mode); return obj_ref; } #endif #if defined(MPFR_PV_NV_BUG) if( (SV_IS_POK(b) && !SV_IS_NOK(b)) || (SV_IS_POK(b) && SV_IS_NOK(b) && SvIOKp(b)) ) { #else if(SV_IS_POK(b)) { #endif NOK_POK_DUALVAR_CHECK , "overload_div");} #ifdef _WIN32_BIZARRE_INFNAN inf_or_nan = _win32_infnanstring(SvPV_nolen(b)); if(inf_or_nan) { if(inf_or_nan == 2) { mpfr_set_nan(*mpfr_t_obj); mpfr_set_nanflag(); return obj_ref; } mpfr_set_inf(*mpfr_t_obj, inf_or_nan); } else { ret = mpfr_set_str(*mpfr_t_obj, SvPV_nolen(b), 0, __gmpfr_default_rounding_mode); } #else ret = mpfr_set_str(*mpfr_t_obj, SvPV_nolen(b), 0, __gmpfr_default_rounding_mode); #endif NON_NUMERIC_CHAR_CHECK(b), "overload_div subroutine");} if(SWITCH_ARGS) mpfr_div(*mpfr_t_obj, *mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), __gmpfr_default_rounding_mode); else mpfr_div(*mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *mpfr_t_obj, __gmpfr_default_rounding_mode); return obj_ref; } if(SV_IS_NOK(b)) { #if defined(MPFR_PV_NV_BUG) NOK_POK_DUALVAR_CHECK , "overload_div");} #endif #if defined(USE_QUADMATH) mpfr_init2(t, FLT128_MANT_DIG); Rmpfr_set_NV(aTHX_ &t, b, GMP_RNDN); if(SWITCH_ARGS) mpfr_div(*mpfr_t_obj, t, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), __gmpfr_default_rounding_mode); else mpfr_div(*mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), t, __gmpfr_default_rounding_mode); mpfr_clear(t); return obj_ref; } #elif defined(USE_LONG_DOUBLE) mpfr_init2(t, REQUIRED_LDBL_MANT_DIG); mpfr_set_ld(t, (long double)SvNVX(b), __gmpfr_default_rounding_mode); if(SWITCH_ARGS) mpfr_div(*mpfr_t_obj, t, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), __gmpfr_default_rounding_mode); else mpfr_div(*mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), t, __gmpfr_default_rounding_mode); mpfr_clear(t); return obj_ref; } #else if(SWITCH_ARGS) mpfr_d_div(*mpfr_t_obj, SvNVX(b), *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), __gmpfr_default_rounding_mode); else mpfr_div_d(*mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), SvNVX(b), __gmpfr_default_rounding_mode); return obj_ref; } #endif if(sv_isobject(b)) { const char* h = HvNAME(SvSTASH(SvRV(b))); if(strEQ(h, "Math::MPFR")) { mpfr_div(*mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(b)))), __gmpfr_default_rounding_mode); return obj_ref; } if(strEQ(h, "Math::GMPz") || strEQ(h, "Math::GMP")) { if(SWITCH_ARGS) { Rmpfr_z_div(mpfr_t_obj, INT2PTR(mpz_t * , SvIVX(SvRV(b))), INT2PTR(mpfr_t *, SvIVX(SvRV(a))), __gmpfr_default_rounding_mode); } else { mpfr_div_z(*mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpz_t * , SvIVX(SvRV(b)))), __gmpfr_default_rounding_mode); } return obj_ref; } if(strEQ(h, "Math::GMPq")) { if(SWITCH_ARGS) { Rmpfr_q_div(mpfr_t_obj, INT2PTR(mpq_t * , SvIVX(SvRV(b))), INT2PTR(mpfr_t *, SvIVX(SvRV(a))), __gmpfr_default_rounding_mode); } else { mpfr_div_q(*mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpq_t * , SvIVX(SvRV(b)))), __gmpfr_default_rounding_mode); } return obj_ref; } if(strEQ(h, "Math::GMPf")) { mpfr_init2(t, (mpfr_prec_t)mpf_get_prec(*(INT2PTR(mpf_t *, SvIVX(SvRV(b)))))); mpfr_set_f(t, *(INT2PTR(mpf_t *, SvIVX(SvRV(b)))), __gmpfr_default_rounding_mode); if(SWITCH_ARGS) mpfr_div(*mpfr_t_obj, t, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), __gmpfr_default_rounding_mode); else mpfr_div(*mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), t, __gmpfr_default_rounding_mode); mpfr_clear(t); return obj_ref; } } croak("Invalid argument supplied to Math::MPFR::overload_div function"); } SV * overload_copy(pTHX_ mpfr_t * p, SV * b, SV * third) { mpfr_t * mpfr_t_obj; SV * obj_ref, * obj; PERL_UNUSED_ARG2(b, third); NEW_MATH_MPFR_OBJECT("Math::MPFR",overload_copy) /* defined in math_mpfr_include.h */ mpfr_init2(*mpfr_t_obj, mpfr_get_prec(*p)); mpfr_set(*mpfr_t_obj, *p, __gmpfr_default_rounding_mode); OBJ_READONLY_ON /*defined in math_mpfr_include.h */ return obj_ref; } SV * overload_abs(pTHX_ mpfr_t * p, SV * b, SV * third) { mpfr_t * mpfr_t_obj; SV * obj_ref, * obj; PERL_UNUSED_ARG2(b, third); NEW_MATH_MPFR_OBJECT("Math::MPFR",overload_abs) /* defined in math_mpfr_include.h */ mpfr_init(*mpfr_t_obj); mpfr_abs(*mpfr_t_obj, *p, __gmpfr_default_rounding_mode); OBJ_READONLY_ON /*defined in math_mpfr_include.h */ return obj_ref; } SV * overload_gt(pTHX_ mpfr_t * a, SV * b, SV * third) { mpfr_t t; int ret; #ifdef _WIN32_BIZARRE_INFNAN int inf_or_nan; #endif if(mpfr_nan_p(*a)){ mpfr_set_erangeflag(); return newSVuv(0); } if(SV_IS_IOK(b)) { ret = Rmpfr_cmp_IV(aTHX_ a, b); if(SWITCH_ARGS) ret *= -1; if(ret > 0) return newSViv(1); return newSViv(0); } #if defined(MPFR_PV_NV_BUG) if( (SV_IS_POK(b) && !SV_IS_NOK(b)) || (SV_IS_POK(b) && SV_IS_NOK(b) && SvIOKp(b)) ) { #else if(SV_IS_POK(b)) { #endif NOK_POK_DUALVAR_CHECK , "overload_gt");} #ifdef _WIN32_BIZARRE_INFNAN inf_or_nan = _win32_infnanstring(SvPV_nolen(b)); if(inf_or_nan) { if(inf_or_nan != 2) { mpfr_init(t); mpfr_set_inf(t, inf_or_nan); } else { /* it's a NaN */ mpfr_set_erangeflag(); return newSViv(0); } } else { ret = mpfr_init_set_str(t, (char *)SvPV_nolen(b), 0, __gmpfr_default_rounding_mode); NON_NUMERIC_CHAR_CHECK(b), "overload_gt subroutine");} if(mpfr_nan_p(t)) { mpfr_clear(t); mpfr_set_erangeflag(); return newSViv(0); } } #else ret = mpfr_init_set_str(t, SvPV_nolen(b), 0, __gmpfr_default_rounding_mode); NON_NUMERIC_CHAR_CHECK(b), "overload_gt subroutine");} if(mpfr_nan_p(t)) { mpfr_clear(t); mpfr_set_erangeflag(); return newSViv(0); } #endif ret = mpfr_cmp(*a, t); mpfr_clear(t); if(SWITCH_ARGS) ret *= -1; if(ret > 0) return newSViv(1); return newSViv(0); } if(SV_IS_NOK(b)) { #if defined(MPFR_PV_NV_BUG) NOK_POK_DUALVAR_CHECK , "overload_gt");} #endif if(SvNVX(b) != SvNVX(b)) { /* it's a NaN */ mpfr_set_erangeflag(); return newSVuv(0); } ret = Rmpfr_cmp_NV(aTHX_ a, b); if(SWITCH_ARGS) ret *= -1; if(ret > 0) return newSViv(1); return newSViv(0); } if(sv_isobject(b)) { const char* h = HvNAME(SvSTASH(SvRV(b))); if(strEQ(h, "Math::MPFR")) { return newSVuv(mpfr_greater_p(*a, *(INT2PTR(mpfr_t *, SvIVX(SvRV(b)))))); } if(strEQ(h, "Math::GMPq")) { ret = mpfr_cmp_q(*a, *(INT2PTR(mpq_t *, SvIVX(SvRV(b))))); if(ret > 0) return newSViv(1); return newSViv(0); } if(strEQ(h, "Math::GMPz") || strEQ(h, "Math::GMP")) { ret = mpfr_cmp_z(*a, *(INT2PTR(mpz_t *, SvIVX(SvRV(b))))); if(ret > 0) return newSViv(1); return newSViv(0); } } croak("Invalid argument supplied to Math::MPFR::overload_gt"); } SV * overload_gte(pTHX_ mpfr_t * a, SV * b, SV * third) { mpfr_t t; int ret; #ifdef _WIN32_BIZARRE_INFNAN int inf_or_nan; #endif if(mpfr_nan_p(*a)){ mpfr_set_erangeflag(); return newSVuv(0); } if(SV_IS_IOK(b)) { ret = Rmpfr_cmp_IV(aTHX_ a, b); if(SWITCH_ARGS) ret *= -1; if(ret >= 0) return newSViv(1); return newSViv(0); } #if defined(MPFR_PV_NV_BUG) if( (SV_IS_POK(b) && !SV_IS_NOK(b)) || (SV_IS_POK(b) && SV_IS_NOK(b) && SvIOKp(b)) ) { #else if(SV_IS_POK(b)) { #endif NOK_POK_DUALVAR_CHECK , "overload_gte");} #ifdef _WIN32_BIZARRE_INFNAN inf_or_nan = _win32_infnanstring(SvPV_nolen(b)); if(inf_or_nan) { if(inf_or_nan != 2) { mpfr_init(t); mpfr_set_inf(t, inf_or_nan); } else { /* it's a NaN */ mpfr_set_erangeflag(); return newSViv(0); } } else { ret = mpfr_init_set_str(t, (char *)SvPV_nolen(b), 0, __gmpfr_default_rounding_mode); NON_NUMERIC_CHAR_CHECK(b), "overload_gte subroutine");} if(mpfr_nan_p(t)) { mpfr_clear(t); mpfr_set_erangeflag(); return newSViv(0); } } #else ret = mpfr_init_set_str(t, SvPV_nolen(b), 0, __gmpfr_default_rounding_mode); NON_NUMERIC_CHAR_CHECK(b), "overload_gte subroutine");} if(mpfr_nan_p(t)) { mpfr_clear(t); mpfr_set_erangeflag(); return newSViv(0); } #endif ret = mpfr_cmp(*a, t); mpfr_clear(t); if(SWITCH_ARGS) ret *= -1; if(ret >= 0) return newSViv(1); return newSViv(0); } if(SV_IS_NOK(b)) { #if defined(MPFR_PV_NV_BUG) NOK_POK_DUALVAR_CHECK , "overload_gte");} #endif if(SvNVX(b) != SvNVX(b)) { /* it's a NaN */ mpfr_set_erangeflag(); return newSVuv(0); } ret = Rmpfr_cmp_NV(aTHX_ a, b); if(SWITCH_ARGS) ret *= -1; if(ret >= 0) return newSViv(1); return newSViv(0); } if(sv_isobject(b)) { const char* h = HvNAME(SvSTASH(SvRV(b))); if(strEQ(h, "Math::MPFR")) { return newSVuv(mpfr_greaterequal_p(*a, *(INT2PTR(mpfr_t *, SvIVX(SvRV(b)))))); } if(strEQ(h, "Math::GMPq")) { ret = mpfr_cmp_q(*a, *(INT2PTR(mpq_t *, SvIVX(SvRV(b))))); if(ret >= 0) return newSViv(1); return newSViv(0); } if(strEQ(h, "Math::GMPz") || strEQ(h, "Math::GMP")) { ret = mpfr_cmp_z(*a, *(INT2PTR(mpz_t *, SvIVX(SvRV(b))))); if(ret >= 0) return newSViv(1); return newSViv(0); } } croak("Invalid argument supplied to Math::MPFR::overload_gte"); } SV * overload_lt(pTHX_ mpfr_t * a, SV * b, SV * third) { mpfr_t t; int ret; #ifdef _WIN32_BIZARRE_INFNAN int inf_or_nan; #endif if(mpfr_nan_p(*a)){ mpfr_set_erangeflag(); return newSVuv(0); } if(SV_IS_IOK(b)) { ret = Rmpfr_cmp_IV(aTHX_ a, b); if(SWITCH_ARGS) ret *= -1; if(ret < 0) return newSViv(1); return newSViv(0); } #if defined(MPFR_PV_NV_BUG) if( (SV_IS_POK(b) && !SV_IS_NOK(b)) || (SV_IS_POK(b) && SV_IS_NOK(b) && SvIOKp(b)) ) { #else if(SV_IS_POK(b)) { #endif NOK_POK_DUALVAR_CHECK , "overload_lt");} #ifdef _WIN32_BIZARRE_INFNAN inf_or_nan = _win32_infnanstring(SvPV_nolen(b)); if(inf_or_nan) { if(inf_or_nan != 2) { mpfr_init(t); mpfr_set_inf(t, inf_or_nan); } else { /* it's a NaN */ mpfr_set_erangeflag(); return newSViv(0); } } else { ret = mpfr_init_set_str(t, (char *)SvPV_nolen(b), 0, __gmpfr_default_rounding_mode); NON_NUMERIC_CHAR_CHECK(b), "overload_lt subroutine");} if(mpfr_nan_p(t)) { mpfr_clear(t); mpfr_set_erangeflag(); return newSViv(0); } } #else ret = mpfr_init_set_str(t, SvPV_nolen(b), 0, __gmpfr_default_rounding_mode); NON_NUMERIC_CHAR_CHECK(b), "overload_lt subroutine");} if(mpfr_nan_p(t)) { mpfr_clear(t); mpfr_set_erangeflag(); return newSViv(0); } #endif ret = mpfr_cmp(*a, t); mpfr_clear(t); if(SWITCH_ARGS) ret *= -1; if(ret < 0) return newSViv(1); return newSViv(0); } if(SV_IS_NOK(b)) { #if defined(MPFR_PV_NV_BUG) NOK_POK_DUALVAR_CHECK , "overload_lt");} #endif if(SvNVX(b) != SvNVX(b)) { /* it's a NaN */ mpfr_set_erangeflag(); return newSVuv(0); } ret = Rmpfr_cmp_NV(aTHX_ a, b); if(SWITCH_ARGS) ret *= -1; if(ret < 0) return newSViv(1); return newSViv(0); } if(sv_isobject(b)) { const char* h = HvNAME(SvSTASH(SvRV(b))); if(strEQ(h, "Math::MPFR")) { return newSVuv(mpfr_less_p(*a, *(INT2PTR(mpfr_t *, SvIVX(SvRV(b)))))); } if(strEQ(h, "Math::GMPq")) { ret = mpfr_cmp_q(*a, *(INT2PTR(mpq_t *, SvIVX(SvRV(b))))); if(ret < 0) return newSViv(1); return newSViv(0); } if(strEQ(h, "Math::GMPz") || strEQ(h, "Math::GMP")) { ret = mpfr_cmp_z(*a, *(INT2PTR(mpz_t *, SvIVX(SvRV(b))))); if(ret < 0) return newSViv(1); return newSViv(0); } } croak("Invalid argument supplied to Math::MPFR::overload_lt"); } SV * overload_lte(pTHX_ mpfr_t * a, SV * b, SV * third) { mpfr_t t; int ret; #ifdef _WIN32_BIZARRE_INFNAN int inf_or_nan; #endif if(mpfr_nan_p(*a)){ mpfr_set_erangeflag(); return newSVuv(0); } if(SV_IS_IOK(b)) { ret = Rmpfr_cmp_IV(aTHX_ a, b); if(SWITCH_ARGS) ret *= -1; if(ret <= 0) return newSViv(1); return newSViv(0); } #if defined(MPFR_PV_NV_BUG) if( (SV_IS_POK(b) && !SV_IS_NOK(b)) || (SV_IS_POK(b) && SV_IS_NOK(b) && SvIOKp(b)) ) { #else if(SV_IS_POK(b)) { #endif NOK_POK_DUALVAR_CHECK , "overload_lte(aTHX_ <=)");} #ifdef _WIN32_BIZARRE_INFNAN inf_or_nan = _win32_infnanstring(SvPV_nolen(b)); if(inf_or_nan) { if(inf_or_nan != 2) { mpfr_init(t); mpfr_set_inf(t, inf_or_nan); } else { /* it's a NaN */ mpfr_set_erangeflag(); return newSViv(0); } } else { ret = mpfr_init_set_str(t, (char *)SvPV_nolen(b), 0, __gmpfr_default_rounding_mode); NON_NUMERIC_CHAR_CHECK(b), "overload_lte subroutine");} if(mpfr_nan_p(t)) { mpfr_clear(t); mpfr_set_erangeflag(); return newSViv(0); } } #else ret = mpfr_init_set_str(t, SvPV_nolen(b), 0, __gmpfr_default_rounding_mode); NON_NUMERIC_CHAR_CHECK(b), "overload_lte subroutine");} if(mpfr_nan_p(t)) { mpfr_clear(t); mpfr_set_erangeflag(); return newSViv(0); } #endif ret = mpfr_cmp(*a, t); mpfr_clear(t); if(SWITCH_ARGS) ret *= -1; if(ret <= 0) return newSViv(1); return newSViv(0); } if(SV_IS_NOK(b)) { #if defined(MPFR_PV_NV_BUG) NOK_POK_DUALVAR_CHECK , "overload_lte(aTHX_ <=)");} #endif if(SvNVX(b) != SvNVX(b)) { /* it's a NaN */ mpfr_set_erangeflag(); return newSVuv(0); } ret = Rmpfr_cmp_NV(aTHX_ a, b); if(SWITCH_ARGS) ret *= -1; if(ret <= 0) return newSViv(1); return newSViv(0); } if(sv_isobject(b)) { const char* h = HvNAME(SvSTASH(SvRV(b))); if(strEQ(h, "Math::MPFR")) return newSVuv(mpfr_lessequal_p(*a, *(INT2PTR(mpfr_t *, SvIVX(SvRV(b)))))); if(strEQ(h, "Math::GMPq")) { ret = mpfr_cmp_q(*a, *(INT2PTR(mpq_t *, SvIVX(SvRV(b))))); if(ret <= 0) return newSViv(1); return newSViv(0); } if(strEQ(h, "Math::GMPz") || strEQ(h, "Math::GMP")) { ret = mpfr_cmp_z(*a, *(INT2PTR(mpz_t *, SvIVX(SvRV(b))))); if(ret <= 0) return newSViv(1); return newSViv(0); } } croak("Invalid argument supplied to Math::MPFR::overload_lte"); } SV * overload_spaceship(pTHX_ mpfr_t * a, SV * b, SV * third) { mpfr_t t; int ret; #ifdef _WIN32_BIZARRE_INFNAN int inf_or_nan; #endif if(mpfr_nan_p(*a)) { mpfr_set_erangeflag(); return &PL_sv_undef; } if(SV_IS_IOK(b)) { ret = Rmpfr_cmp_IV(aTHX_ a, b); if(SWITCH_ARGS) ret *= -1; if(ret < 0) return newSViv(-1); if(ret > 0) return newSViv(1); return newSViv(0); } #if defined(MPFR_PV_NV_BUG) if( (SV_IS_POK(b) && !SV_IS_NOK(b)) || (SV_IS_POK(b) && SV_IS_NOK(b) && SvIOKp(b)) ) { #else if(SV_IS_POK(b)) { #endif NOK_POK_DUALVAR_CHECK , "overload_spaceship");} #ifdef _WIN32_BIZARRE_INFNAN inf_or_nan = _win32_infnanstring(SvPV_nolen(b)); if(inf_or_nan) { if(inf_or_nan != 2) { mpfr_init(t); mpfr_set_inf(t, inf_or_nan); } else { /* it's a NaN */ mpfr_set_erangeflag(); return &PL_sv_undef; } } else { ret = mpfr_init_set_str(t, (char *)SvPV_nolen(b), 0, __gmpfr_default_rounding_mode); NON_NUMERIC_CHAR_CHECK(b), "overload_spaceship subroutine");} if(mpfr_nan_p(t)) { mpfr_clear(t); mpfr_set_erangeflag(); return &PL_sv_undef; } } #else ret = mpfr_init_set_str(t, SvPV_nolen(b), 0, __gmpfr_default_rounding_mode); NON_NUMERIC_CHAR_CHECK(b), "overload_spaceship subroutine");} if(mpfr_nan_p(t)) { mpfr_clear(t); mpfr_set_erangeflag(); return &PL_sv_undef; } #endif ret = mpfr_cmp(*a, t); mpfr_clear(t); if(SWITCH_ARGS) ret *= -1; if(ret < 0) return newSViv(-1); if(ret > 0) return newSViv(1); return newSViv(0); } if(SV_IS_NOK(b)) { #if defined(MPFR_PV_NV_BUG) NOK_POK_DUALVAR_CHECK , "overload_spaceship");} #endif if(SvNVX(b) != SvNVX(b)) { /* it's a NaN */ mpfr_set_erangeflag(); return &PL_sv_undef; } ret = Rmpfr_cmp_NV(aTHX_ a, b); if(SWITCH_ARGS) ret *= -1; if(ret < 0) return newSViv(-1); if(ret > 0) return newSViv(1); return newSViv(0); } if(sv_isobject(b)) { const char* h = HvNAME(SvSTASH(SvRV(b))); if(strEQ(h, "Math::MPFR")) { if( mpfr_nan_p( *(INT2PTR(mpfr_t *, SvIVX(SvRV(b))))) ) { mpfr_set_erangeflag(); return &PL_sv_undef; } return newSViv(mpfr_cmp(*a, *(INT2PTR(mpfr_t *, SvIVX(SvRV(b)))))); } if(strEQ(h, "Math::GMPq")) { return newSViv(mpfr_cmp_q(*a, *(INT2PTR(mpq_t *, SvIVX(SvRV(b)))))); } if(strEQ(h, "Math::GMPz") || strEQ(h, "Math::GMP")) { return newSViv(mpfr_cmp_z(*a, *(INT2PTR(mpz_t *, SvIVX(SvRV(b)))))); } } croak("Invalid argument supplied to Math::MPFR::overload_spaceship"); } SV * overload_equiv(pTHX_ mpfr_t * a, SV * b, SV * third) { mpfr_t t; int ret; #ifdef _WIN32_BIZARRE_INFNAN int inf_or_nan; #endif PERL_UNUSED_ARG(third); if(mpfr_nan_p(*a)){ mpfr_set_erangeflag(); return newSVuv(0); } if(SV_IS_IOK(b)) { ret = Rmpfr_cmp_IV(aTHX_ a, b); if(ret == 0) return newSViv(1); return newSViv(0); } #if defined(MPFR_PV_NV_BUG) if( (SV_IS_POK(b) && !SV_IS_NOK(b)) || (SV_IS_POK(b) && SV_IS_NOK(b) && SvIOKp(b)) ) { #else if(SV_IS_POK(b)) { #endif NOK_POK_DUALVAR_CHECK , "overload_equiv");} #ifdef _WIN32_BIZARRE_INFNAN inf_or_nan = _win32_infnanstring(SvPV_nolen(b)); if(inf_or_nan) { if(inf_or_nan != 2) { mpfr_init(t); mpfr_set_inf(t, inf_or_nan); } else { /* it's a NaN */ mpfr_set_erangeflag(); return newSViv(0); } } else { ret = mpfr_init_set_str(t, (char *)SvPV_nolen(b), 0, __gmpfr_default_rounding_mode); NON_NUMERIC_CHAR_CHECK(b), "overload_equiv subroutine");} if(mpfr_nan_p(t)) { mpfr_clear(t); mpfr_set_erangeflag(); return newSViv(0); } } #else ret = mpfr_init_set_str(t, (char *)SvPV_nolen(b), 0, __gmpfr_default_rounding_mode); NON_NUMERIC_CHAR_CHECK(b), "overload_equiv subroutine");} if(mpfr_nan_p(t)) { mpfr_clear(t); mpfr_set_erangeflag(); return newSViv(0); } #endif ret = mpfr_cmp(*a, t); mpfr_clear(t); if(ret == 0) return newSViv(1); return newSViv(0); } if(SV_IS_NOK(b)) { #if defined(MPFR_PV_NV_BUG) NOK_POK_DUALVAR_CHECK , "overload_equiv");} #endif if(SvNVX(b) != SvNVX(b)) { /* it's a NaN */ mpfr_set_erangeflag(); return newSVuv(0); } ret = Rmpfr_cmp_NV(aTHX_ a, b); if(ret == 0) return newSViv(1); return newSViv(0); } if(sv_isobject(b)) { const char* h = HvNAME(SvSTASH(SvRV(b))); if(strEQ(h, "Math::MPFR")) { return newSVuv(mpfr_equal_p(*a, *(INT2PTR(mpfr_t *, SvIVX(SvRV(b)))))); } if(strEQ(h, "Math::GMPq")) { if(mpfr_cmp_q(*a, *(INT2PTR(mpq_t *, SvIVX(SvRV(b)))))) return newSViv(0); return newSViv(1); } if(strEQ(h, "Math::GMPz") || strEQ(h, "Math::GMP")) { if(mpfr_cmp_z(*a, *(INT2PTR(mpz_t *, SvIVX(SvRV(b)))))) return newSViv(0); return newSViv(1); } } croak("Invalid argument supplied to Math::MPFR::overload_equiv"); } SV * overload_not_equiv(pTHX_ mpfr_t * a, SV * b, SV * third) { mpfr_t t; int ret; #ifdef _WIN32_BIZARRE_INFNAN int inf_or_nan; #endif PERL_UNUSED_ARG(third); if(mpfr_nan_p(*a)){ mpfr_set_erangeflag(); return newSVuv(1); } if(SV_IS_IOK(b)) { ret = Rmpfr_cmp_IV(aTHX_ a, b); if(ret != 0) return newSViv(1); return newSViv(0); } #if defined(MPFR_PV_NV_BUG) if( (SV_IS_POK(b) && !SV_IS_NOK(b)) || (SV_IS_POK(b) && SV_IS_NOK(b) && SvIOKp(b)) ) { #else if(SV_IS_POK(b)) { /*open IS_POK*/ #endif NOK_POK_DUALVAR_CHECK , "overload_not_equiv");} #ifdef _WIN32_BIZARRE_INFNAN inf_or_nan = _win32_infnanstring(SvPV_nolen(b)); if(inf_or_nan) { if(inf_or_nan != 2) { mpfr_init(t); mpfr_set_inf(t, inf_or_nan); } else { /* it's a NaN */ mpfr_set_erangeflag(); return newSViv(1); } } else { ret = mpfr_init_set_str(t, (char *)SvPV_nolen(b), 0, __gmpfr_default_rounding_mode); NON_NUMERIC_CHAR_CHECK(b), "overload_not_equiv subroutine");} if(mpfr_nan_p(t)) { mpfr_clear(t); mpfr_set_erangeflag(); return newSViv(1); } } #else ret = mpfr_init_set_str(t, (char *)SvPV_nolen(b), 0, __gmpfr_default_rounding_mode); NON_NUMERIC_CHAR_CHECK(b), "overload_not_equiv subroutine");} if(mpfr_nan_p(t)) { mpfr_clear(t); mpfr_set_erangeflag(); return newSViv(1); } #endif ret = mpfr_cmp(*a, t); mpfr_clear(t); if(ret != 0) return newSViv(1); return newSViv(0); } /*close IS_POK*/ if(SV_IS_NOK(b)) { #if defined(MPFR_PV_NV_BUG) NOK_POK_DUALVAR_CHECK , "overload_not_equiv");} #endif if(SvNVX(b) != SvNVX(b)) { /* it's a NaN */ mpfr_set_erangeflag(); return newSVuv(1); } ret = Rmpfr_cmp_NV(aTHX_ a, b); if(ret != 0) return newSViv(1); return newSViv(0); } if(sv_isobject(b)) { const char* h = HvNAME(SvSTASH(SvRV(b))); if(strEQ(h, "Math::MPFR")) { if(mpfr_equal_p(*a, *(INT2PTR(mpfr_t *, SvIVX(SvRV(b)))))) return newSViv(0); return newSViv(1); } if(strEQ(h, "Math::GMPq")) { if(mpfr_cmp_q(*a, *(INT2PTR(mpq_t *, SvIVX(SvRV(b)))))) return newSViv(1); return newSViv(0); } if(strEQ(h, "Math::GMPz") || strEQ(h, "Math::GMP")) { if(mpfr_cmp_z(*a, *(INT2PTR(mpz_t *, SvIVX(SvRV(b)))))) return newSViv(1); return newSViv(0); } } croak("Invalid argument supplied to Math::MPFR::overload_not_equiv"); } SV * overload_true(pTHX_ mpfr_t *a, SV *b, SV * third) { PERL_UNUSED_ARG2(b, third); if(mpfr_nan_p(*a)) return newSVuv(0); if(mpfr_cmp_ui(*a, 0)) return newSVuv(1); return newSVuv(0); } SV * overload_not(pTHX_ mpfr_t * a, SV * b, SV * third) { PERL_UNUSED_ARG2(b, third); if(mpfr_nan_p(*a)) return newSViv(1); if(mpfr_cmp_ui(*a, 0)) return newSViv(0); return newSViv(1); } SV * overload_sqrt(pTHX_ mpfr_t * p, SV * b, SV * third) { mpfr_t * mpfr_t_obj; SV * obj_ref, * obj; PERL_UNUSED_ARG2(b, third); NEW_MATH_MPFR_OBJECT("Math::MPFR",overload_sqrt) /* defined in math_mpfr_include.h */ mpfr_init(*mpfr_t_obj); /* No - this was wrong. If a negative value is supplied, a NaN should be returned instad */ /* if(mpfr_cmp_ui(*p, 0) < 0) croak("Negative value supplied as argument to overload_sqrt"); */ mpfr_sqrt(*mpfr_t_obj, *p, __gmpfr_default_rounding_mode); OBJ_READONLY_ON /*defined in math_mpfr_include.h */ return obj_ref; } SV * overload_pow(pTHX_ SV * p, SV * b, SV * third) { mpfr_t * mpfr_t_obj, t; SV * obj_ref, * obj; int ret; #ifdef _WIN32_BIZARRE_INFNAN int inf_or_nan; #endif NEW_MATH_MPFR_OBJECT("Math::MPFR",overload_pow) /* defined in math_mpfr_include.h */ mpfr_init(*mpfr_t_obj); OBJ_READONLY_ON /*defined in math_mpfr_include.h */ #ifdef MATH_MPFR_NEED_LONG_LONG_INT if(SV_IS_IOK(b)) { mpfr_init2(t, (mpfr_prec_t)IVSIZE_BITS); if(SvUOK(b)) mpfr_set_uj(t, SvUVX(b), __gmpfr_default_rounding_mode); else mpfr_set_sj(t, SvIVX(b), __gmpfr_default_rounding_mode); if(SWITCH_ARGS) mpfr_pow(*mpfr_t_obj, t, *(INT2PTR(mpfr_t *, SvIVX(SvRV(p)))), __gmpfr_default_rounding_mode); else mpfr_pow(*mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(p)))), t, __gmpfr_default_rounding_mode); mpfr_clear(t); return obj_ref; } #else if(SV_IS_IOK(b)) { if(SvUOK(b)) { if(SWITCH_ARGS) mpfr_ui_pow(*mpfr_t_obj, SvUVX(b), *(INT2PTR(mpfr_t *, SvIVX(SvRV(p)))), __gmpfr_default_rounding_mode); else mpfr_pow_ui(*mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(p)))), SvUVX(b), __gmpfr_default_rounding_mode); return obj_ref; } /* Need to do it this way as there's no mpfr_si_pow function */ if(SvIV(b) >= 0) { if(SWITCH_ARGS) mpfr_ui_pow(*mpfr_t_obj, SvUVX(b), *(INT2PTR(mpfr_t *, SvIVX(SvRV(p)))), __gmpfr_default_rounding_mode); else mpfr_pow_ui(*mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(p)))), SvUVX(b), __gmpfr_default_rounding_mode); return obj_ref; } if(NO_SWITCH_ARGS) { mpfr_pow_si(*mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(p)))), SvIV(b), __gmpfr_default_rounding_mode); return obj_ref; } } #endif #if defined(MPFR_PV_NV_BUG) if( (SV_IS_POK(b) && !SV_IS_NOK(b)) || (SV_IS_POK(b) && SV_IS_NOK(b) && SvIOKp(b)) ) { #else if(SV_IS_POK(b)) { #endif NOK_POK_DUALVAR_CHECK , "overload_pow");} #ifdef _WIN32_BIZARRE_INFNAN inf_or_nan = _win32_infnanstring(SvPV_nolen(b)); if(inf_or_nan) { if(inf_or_nan == 2) { mpfr_set_nan(*mpfr_t_obj); mpfr_set_nanflag(); return obj_ref; } mpfr_set_inf(*mpfr_t_obj, inf_or_nan); } else { ret = mpfr_set_str(*mpfr_t_obj, SvPV_nolen(b), 0, __gmpfr_default_rounding_mode); } #else ret = mpfr_set_str(*mpfr_t_obj, SvPV_nolen(b), 0, __gmpfr_default_rounding_mode); #endif NON_NUMERIC_CHAR_CHECK(b), "overload_pow subroutine");} if(SWITCH_ARGS) mpfr_pow(*mpfr_t_obj, *mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(p)))), __gmpfr_default_rounding_mode); else mpfr_pow(*mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(p)))), *mpfr_t_obj, __gmpfr_default_rounding_mode); return obj_ref; } if(SV_IS_NOK(b)) { #if defined(MPFR_PV_NV_BUG) NOK_POK_DUALVAR_CHECK , "overload_pow");} #endif #if defined(USE_QUADMATH) mpfr_init2(t, FLT128_MANT_DIG); Rmpfr_set_NV(aTHX_ &t, b, __gmpfr_default_rounding_mode); #elif defined(USE_LONG_DOUBLE) mpfr_init2(t, REQUIRED_LDBL_MANT_DIG); mpfr_set_ld(t, (long double)SvNVX(b), __gmpfr_default_rounding_mode); #else mpfr_init2(t, DBL_MANT_DIG); mpfr_set_d(t, (double)SvNVX(b), __gmpfr_default_rounding_mode); #endif if(SWITCH_ARGS) mpfr_pow(*mpfr_t_obj, t, *(INT2PTR(mpfr_t *, SvIVX(SvRV(p)))), __gmpfr_default_rounding_mode); else mpfr_pow(*mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(p)))), t, __gmpfr_default_rounding_mode); mpfr_clear(t); return obj_ref; } if(sv_isobject(b)) { const char* h = HvNAME(SvSTASH(SvRV(b))); if(strEQ(h, "Math::MPFR")) { mpfr_pow(*mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(p)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(b)))), __gmpfr_default_rounding_mode); return obj_ref; } if(strEQ(h, "Math::GMPz") || strEQ(h, "Math::GMP")) { if(SWITCH_ARGS) { mpfr_init2(t, (mpfr_prec_t)mpz_sizeinbase(*(INT2PTR(mpz_t *, SvIVX(SvRV(b)))), 2)); mpfr_set_z(t, *(INT2PTR(mpz_t *, SvIVX(SvRV(b)))), __gmpfr_default_rounding_mode); mpfr_pow(*mpfr_t_obj, t, *(INT2PTR(mpfr_t *, SvIVX(SvRV(p)))), __gmpfr_default_rounding_mode); mpfr_clear(t); } else mpfr_pow_z(*mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(p )))), *(INT2PTR(mpz_t * , SvIVX(SvRV(b)))), __gmpfr_default_rounding_mode); return obj_ref; } if(strEQ(h, "Math::GMPq")) { mpfr_set_q(*mpfr_t_obj, *(INT2PTR(mpq_t *, SvIVX(SvRV(b)))), __gmpfr_default_rounding_mode); if(SWITCH_ARGS) mpfr_pow(*mpfr_t_obj, *mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(p)))), __gmpfr_default_rounding_mode); else mpfr_pow(*mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(p)))), *mpfr_t_obj, __gmpfr_default_rounding_mode); return obj_ref; } if(strEQ(h, "Math::GMPf")) { mpfr_init2(t, (mpfr_prec_t)mpf_get_prec(*(INT2PTR(mpf_t *, SvIVX(SvRV(b)))))); mpfr_set_f(t, *(INT2PTR(mpf_t *, SvIVX(SvRV(b)))), __gmpfr_default_rounding_mode); if(SWITCH_ARGS) mpfr_pow(*mpfr_t_obj, t, *(INT2PTR(mpfr_t *, SvIVX(SvRV(p)))), __gmpfr_default_rounding_mode); else mpfr_pow(*mpfr_t_obj, *(INT2PTR(mpfr_t *, SvIVX(SvRV(p)))), t, __gmpfr_default_rounding_mode); mpfr_clear(t); return obj_ref; } } croak("Invalid argument supplied to Math::MPFR::overload_pow."); } SV * overload_log(pTHX_ mpfr_t * p, SV * b, SV * third) { mpfr_t * mpfr_t_obj; SV * obj_ref, * obj; PERL_UNUSED_ARG2(b, third); NEW_MATH_MPFR_OBJECT("Math::MPFR",overload_log) /* defined in math_mpfr_include.h */ mpfr_init(*mpfr_t_obj); mpfr_log(*mpfr_t_obj, *p, __gmpfr_default_rounding_mode); OBJ_READONLY_ON /*defined in math_mpfr_include.h */ return obj_ref; } SV * log_2(pTHX_ mpfr_t * p) { mpfr_t * mpfr_t_obj; SV * obj_ref, * obj; NEW_MATH_MPFR_OBJECT("Math::MPFR",log_2) /* defined in math_mpfr_include.h */ mpfr_init(*mpfr_t_obj); mpfr_log2(*mpfr_t_obj, *p, __gmpfr_default_rounding_mode); OBJ_READONLY_ON /*defined in math_mpfr_include.h */ return obj_ref; } SV * log_10(pTHX_ mpfr_t * p) { mpfr_t * mpfr_t_obj; SV * obj_ref, * obj; NEW_MATH_MPFR_OBJECT("Math::MPFR",log_10) /* defined in math_mpfr_include.h */ mpfr_init(*mpfr_t_obj); mpfr_log10(*mpfr_t_obj, *p, __gmpfr_default_rounding_mode); OBJ_READONLY_ON /*defined in math_mpfr_include.h */ return obj_ref; } SV * overload_exp(pTHX_ mpfr_t * p, SV * b, SV * third) { mpfr_t * mpfr_t_obj; SV * obj_ref, * obj; PERL_UNUSED_ARG2(b, third); NEW_MATH_MPFR_OBJECT("Math::MPFR",overload_exp) /* defined in math_mpfr_include.h */ mpfr_init(*mpfr_t_obj); mpfr_exp(*mpfr_t_obj, *p, __gmpfr_default_rounding_mode); OBJ_READONLY_ON /*defined in math_mpfr_include.h */; return obj_ref; } SV * overload_sin(pTHX_ mpfr_t * p, SV * b, SV * third) { mpfr_t * mpfr_t_obj; SV * obj_ref, * obj; PERL_UNUSED_ARG2(b, third); NEW_MATH_MPFR_OBJECT("Math::MPFR",overload_sin) /* defined in math_mpfr_include.h */ mpfr_init(*mpfr_t_obj); mpfr_sin(*mpfr_t_obj, *p, __gmpfr_default_rounding_mode); OBJ_READONLY_ON /*defined in math_mpfr_include.h */ return obj_ref; } SV * sind(pTHX_ mpfr_t * p) { #if MPFR_VERSION >= 262656 mpfr_t * mpfr_t_obj; SV * obj_ref, * obj; NEW_MATH_MPFR_OBJECT("Math::MPFR",sind) /* defined in math_mpfr_include.h */ mpfr_init(*mpfr_t_obj); mpfr_sinu(*mpfr_t_obj, *p, 360, __gmpfr_default_rounding_mode); OBJ_READONLY_ON /*defined in math_mpfr_include.h */ return obj_ref; #else PERL_UNUSED_ARG(p); croak("sind function requires mpfr-4.2.0. (You have only version %s) ", MPFR_VERSION_STRING); #endif } SV * overload_cos(pTHX_ mpfr_t * p, SV * b, SV * third) { mpfr_t * mpfr_t_obj; SV * obj_ref, * obj; PERL_UNUSED_ARG2(b, third); NEW_MATH_MPFR_OBJECT("Math::MPFR",overload_cos) /* defined in math_mpfr_include.h */ mpfr_init(*mpfr_t_obj); mpfr_cos(*mpfr_t_obj, *p, __gmpfr_default_rounding_mode); OBJ_READONLY_ON /*defined in math_mpfr_include.h */ return obj_ref; } SV * cosd(pTHX_ mpfr_t * p) { #if MPFR_VERSION >= 262656 mpfr_t * mpfr_t_obj; SV * obj_ref, * obj; NEW_MATH_MPFR_OBJECT("Math::MPFR",cosd) /* defined in math_mpfr_include.h */ mpfr_init(*mpfr_t_obj); mpfr_cosu(*mpfr_t_obj, *p, 360, __gmpfr_default_rounding_mode); OBJ_READONLY_ON /*defined in math_mpfr_include.h */ return obj_ref; #else PERL_UNUSED_ARG(p); croak("cosd function requires mpfr-4.2.0. (You have only version %s) ", MPFR_VERSION_STRING); #endif } SV * tangent(pTHX_ mpfr_t * p) { mpfr_t * mpfr_t_obj; SV * obj_ref, * obj; NEW_MATH_MPFR_OBJECT("Math::MPFR",tangent) /* defined in math_mpfr_include.h */ mpfr_init(*mpfr_t_obj); mpfr_tan(*mpfr_t_obj, *p, __gmpfr_default_rounding_mode); OBJ_READONLY_ON /*defined in math_mpfr_include.h */ return obj_ref; } SV * tand(pTHX_ mpfr_t * p) { #if MPFR_VERSION >= 262656 mpfr_t * mpfr_t_obj; SV * obj_ref, * obj; NEW_MATH_MPFR_OBJECT("Math::MPFR",tand) /* defined in math_mpfr_include.h */ mpfr_init(*mpfr_t_obj); mpfr_tanu(*mpfr_t_obj, *p, 360, __gmpfr_default_rounding_mode); OBJ_READONLY_ON /*defined in math_mpfr_include.h */ return obj_ref; #else PERL_UNUSED_ARG(p); croak("tand function requires mpfr-4.2.0. (You have only version %s) ", MPFR_VERSION_STRING); #endif } SV * overload_int(pTHX_ mpfr_t * p, SV * b, SV * third) { mpfr_t * mpfr_t_obj; SV * obj_ref, * obj; PERL_UNUSED_ARG2(b, third); NEW_MATH_MPFR_OBJECT("Math::MPFR",overload_int) /* defined in math_mpfr_include.h */ mpfr_init(*mpfr_t_obj); mpfr_trunc(*mpfr_t_obj, *p); OBJ_READONLY_ON /*defined in math_mpfr_include.h */ return obj_ref; } SV * overload_atan2(pTHX_ mpfr_t * a, SV * b, SV * third) { mpfr_t * mpfr_t_obj, t; SV * obj_ref, * obj; #ifdef _WIN32_BIZARRE_INFNAN int ret, inf_or_nan; #else int ret; #endif NEW_MATH_MPFR_OBJECT("Math::MPFR",overload_atan2) /* defined in math_mpfr_include.h */ mpfr_init(*mpfr_t_obj); #ifdef MATH_MPFR_NEED_LONG_LONG_INT if(SV_IS_IOK(b)) { mpfr_init2(t, (mpfr_prec_t)IVSIZE_BITS); if(SvUOK(b)) mpfr_set_uj(t, SvUVX(b), __gmpfr_default_rounding_mode); else mpfr_set_sj(t, SvIVX(b), __gmpfr_default_rounding_mode); if(SWITCH_ARGS){ mpfr_atan2(*mpfr_t_obj, t, *a, __gmpfr_default_rounding_mode); } else { mpfr_atan2(*mpfr_t_obj, *a, t, __gmpfr_default_rounding_mode); } mpfr_clear(t); OBJ_READONLY_ON /*defined in math_mpfr_include.h */ return obj_ref; } #else if(SV_IS_IOK(b)) { if(SvUOK(b)) { mpfr_init2(t, 8 * sizeof(long)); mpfr_set_ui(t, SvUVX(b), __gmpfr_default_rounding_mode); if(SWITCH_ARGS){ mpfr_atan2(*mpfr_t_obj, t, *a, __gmpfr_default_rounding_mode); } else { mpfr_atan2(*mpfr_t_obj, *a, t, __gmpfr_default_rounding_mode); } mpfr_clear(t); OBJ_READONLY_ON /*defined in math_mpfr_include.h */ return obj_ref; } mpfr_init2(t, 8 * sizeof(long)); mpfr_set_si(t, SvIVX(b), __gmpfr_default_rounding_mode); if(SWITCH_ARGS){ mpfr_atan2(*mpfr_t_obj, t, *a, __gmpfr_default_rounding_mode); } else { mpfr_atan2(*mpfr_t_obj, *a, t, __gmpfr_default_rounding_mode); } mpfr_clear(t); OBJ_READONLY_ON /*defined in math_mpfr_include.h */ return obj_ref; } #endif #if defined(MPFR_PV_NV_BUG) if( (SV_IS_POK(b) && !SV_IS_NOK(b)) || (SV_IS_POK(b) && SV_IS_NOK(b) && SvIOKp(b)) ) { #else if(SV_IS_POK(b)) { #endif NOK_POK_DUALVAR_CHECK , "overload_atan2");} #ifdef _WIN32_BIZARRE_INFNAN inf_or_nan = _win32_infnanstring(SvPV_nolen(b)); if(inf_or_nan) { if(inf_or_nan != 2) { mpfr_set_inf(*mpfr_t_obj, inf_or_nan); } /* else we want *mpfr_t_obj to be a NaN ... which it already is !! :-) */ } else { ret = mpfr_init_set_str(*mpfr_t_obj, (char *)SvPV_nolen(b), 0, __gmpfr_default_rounding_mode); } #else ret = mpfr_set_str(*mpfr_t_obj, SvPV_nolen(b), 0, __gmpfr_default_rounding_mode); #endif NON_NUMERIC_CHAR_CHECK(b), "overload_atan2");} if(SWITCH_ARGS){ mpfr_atan2(*mpfr_t_obj, *mpfr_t_obj, *a, __gmpfr_default_rounding_mode); } else { mpfr_atan2(*mpfr_t_obj, *a, *mpfr_t_obj, __gmpfr_default_rounding_mode); } OBJ_READONLY_ON /*defined in math_mpfr_include.h */ return obj_ref; } if(SV_IS_NOK(b)) { #if defined(MPFR_PV_NV_BUG) NOK_POK_DUALVAR_CHECK , "overload_atan2");} #endif #if defined(USE_QUADMATH) mpfr_init2(t, FLT128_MANT_DIG); Rmpfr_set_NV(aTHX_ &t, b, __gmpfr_default_rounding_mode); #elif defined(USE_LONG_DOUBLE) mpfr_init2(t, REQUIRED_LDBL_MANT_DIG); mpfr_set_ld(t, (long double)SvNVX(b), __gmpfr_default_rounding_mode); #else mpfr_init2(t, DBL_MANT_DIG); mpfr_set_d(t, (double)SvNVX(b), __gmpfr_default_rounding_mode); #endif if(SWITCH_ARGS){ mpfr_atan2(*mpfr_t_obj, t, *a, __gmpfr_default_rounding_mode); } else { mpfr_atan2(*mpfr_t_obj, *a, t, __gmpfr_default_rounding_mode); } mpfr_clear(t); OBJ_READONLY_ON /*defined in math_mpfr_include.h */ return obj_ref; } if(sv_isobject(b)) { const char* h = HvNAME(SvSTASH(SvRV(b))); if(strEQ(h, "Math::MPFR")) { mpfr_atan2(*mpfr_t_obj, *a, *(INT2PTR(mpfr_t *, SvIVX(SvRV(b)))), __gmpfr_default_rounding_mode); OBJ_READONLY_ON /*defined in math_mpfr_include.h */ return obj_ref; } } croak("Invalid argument supplied to Math::MPFR::overload_atan2 function"); } /* Finish typemapping */ SV * Rmpfr_randinit_default_nobless(pTHX) { gmp_randstate_t * state; SV * obj_ref, * obj; Newx(state, 1, gmp_randstate_t); if(state == NULL) croak("Failed to allocate memory in Rmpfr_randinit_default function"); obj_ref = newSV(0); obj = newSVrv(obj_ref, NULL); gmp_randinit_default(*state); sv_setiv(obj, INT2PTR(IV,state)); SvREADONLY_on(obj); return obj_ref; } SV * Rmpfr_randinit_mt_nobless(pTHX) { gmp_randstate_t * rand_obj; SV * obj_ref, * obj; Newx(rand_obj, 1, gmp_randstate_t); if(rand_obj == NULL) croak("Failed to allocate memory in Math::GMPz::Random::Rmpfr_randinit_mt function"); obj_ref = newSV(0); obj = newSVrv(obj_ref, NULL); gmp_randinit_mt(*rand_obj); sv_setiv(obj, INT2PTR(IV, rand_obj)); SvREADONLY_on(obj); return obj_ref; } SV * Rmpfr_randinit_lc_2exp_nobless(pTHX_ SV * a, SV * c, SV * m2exp ) { gmp_randstate_t * state; mpz_t aa; SV * obj_ref, * obj; Newx(state, 1, gmp_randstate_t); if(state == NULL) croak("Failed to allocate memory in Rmpfr_randinit_lc_2exp function"); obj_ref = newSV(0); obj = newSVrv(obj_ref, NULL); if(sv_isobject(a)) { const char* h = HvNAME(SvSTASH(SvRV(a))); if(strEQ(h, "Math::GMP") || strEQ(h, "GMP::Mpz") || strEQ(h, "Math::GMPz")) gmp_randinit_lc_2exp(*state, *(INT2PTR(mpz_t *, SvIVX(SvRV(a)))), (unsigned long)SvUV(c), (unsigned long)SvUV(m2exp)); else croak("First arg to Rmpfr_randinit_lc_2exp is of invalid type"); } else { if(!mpz_init_set_str(aa, SvPV_nolen(a), 0)) { gmp_randinit_lc_2exp(*state, aa, (unsigned long)SvUV(c), (unsigned long)SvUV(m2exp)); mpz_clear(aa); } else croak("Seedstring supplied to Rmpfr_randinit_lc_2exp is not a valid number"); } sv_setiv(obj, INT2PTR(IV,state)); SvREADONLY_on(obj); return obj_ref; } SV * Rmpfr_randinit_lc_2exp_size_nobless(pTHX_ SV * size) { gmp_randstate_t * state; SV * obj_ref, * obj; if(SvUV(size) > 128) croak("The argument supplied to Rmpfr_randinit_lc_2exp_size_nobless function is too large - ie greater than 128"); Newx(state, 1, gmp_randstate_t); if(state == NULL) croak("Failed to allocate memory in Rmpfr_randinit_lc_2exp_size_nobless function"); obj_ref = newSV(0); obj = newSVrv(obj_ref, NULL); if(gmp_randinit_lc_2exp_size(*state, (unsigned long)SvUV(size))) { sv_setiv(obj, INT2PTR(IV,state)); SvREADONLY_on(obj); return obj_ref; } croak("Rmpfr_randinit_lc_2exp_size_nobless function failed"); } void Rmpfr_randclear(pTHX_ SV * p) { gmp_randclear(*(INT2PTR(gmp_randstate_t *, SvIVX(SvRV(p))))); Safefree(INT2PTR(gmp_randstate_t *, SvIVX(SvRV(p)))); } void Rmpfr_randseed(pTHX_ SV * state, SV * seed) { mpz_t s; if(sv_isobject(seed)) { const char* h = HvNAME(SvSTASH(SvRV(seed))); if(strEQ(h, "Math::GMP") || strEQ(h, "GMP::Mpz") || strEQ(h, "Math::GMPz")) gmp_randseed(*(INT2PTR(gmp_randstate_t *, SvIVX(SvRV(state)))), *(INT2PTR(mpz_t *, SvIVX(SvRV(seed))))); else croak("2nd arg to Rmpfr_randseed is of invalid type"); } else { if(!mpz_init_set_str(s, SvPV_nolen(seed), 0)) { gmp_randseed(*(INT2PTR(gmp_randstate_t *, SvIVX(SvRV(state)))), s); mpz_clear(s); } else croak("Seedstring supplied to Rmpfr_randseed is not a valid number"); } } void Rmpfr_randseed_ui(pTHX_ SV * state, SV * seed) { gmp_randseed_ui(*(INT2PTR(gmp_randstate_t *, SvIVX(SvRV(state)))), (unsigned long)SvUV(seed)); } SV * overload_pow_eq(pTHX_ SV * p, SV * b, SV * third) { mpfr_t t; int ret; #ifdef _WIN32_BIZARRE_INFNAN int inf_or_nan; #endif PERL_UNUSED_ARG(third); SvREFCNT_inc(p); #ifdef MATH_MPFR_NEED_LONG_LONG_INT # if MPFR_VERSION >= 262656 /* have mpfr_pow_uj, mpfr_pow_sj */ if(SV_IS_IOK(b)) { if(SvUOK(b)) { mpfr_pow_uj(*(INT2PTR(mpfr_t *, SvIVX(SvRV(p)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(p)))), SvUVX(b), __gmpfr_default_rounding_mode); return p; } mpfr_pow_sj(*(INT2PTR(mpfr_t *, SvIVX(SvRV(p)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(p)))), SvIVX(b), __gmpfr_default_rounding_mode); return p; } # else if(SV_IS_IOK(b)) { mpfr_init2(t, (mpfr_prec_t)IVSIZE_BITS); if(SvUOK(b)) mpfr_set_uj(t, SvUVX(b), __gmpfr_default_rounding_mode); else mpfr_set_sj(t, SvIVX(b), __gmpfr_default_rounding_mode); mpfr_pow(*(INT2PTR(mpfr_t *, SvIVX(SvRV(p)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(p)))), t, __gmpfr_default_rounding_mode); mpfr_clear(t); return p; } # endif #else if(SV_IS_IOK(b)) { if(SvUOK(b)) { mpfr_pow_ui(*(INT2PTR(mpfr_t *, SvIVX(SvRV(p)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(p)))), SvUVX(b), __gmpfr_default_rounding_mode); return p; } mpfr_pow_si(*(INT2PTR(mpfr_t *, SvIVX(SvRV(p)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(p)))), SvIVX(b), __gmpfr_default_rounding_mode); return p; } #endif #if defined(MPFR_PV_NV_BUG) if( (SV_IS_POK(b) && !SV_IS_NOK(b)) || (SV_IS_POK(b) && SV_IS_NOK(b) && SvIOKp(b)) ) { #else if(SV_IS_POK(b)) { #endif NOK_POK_DUALVAR_CHECK , "overload_pow_eq");} #ifdef _WIN32_BIZARRE_INFNAN inf_or_nan = _win32_infnanstring(SvPV_nolen(b)); mpfr_init(t); if(inf_or_nan) { if(inf_or_nan == 2) { mpfr_set_nan(t); } else mpfr_set_inf(t, inf_or_nan); } else { ret = mpfr_set_str(t, SvPV_nolen(b), 0, __gmpfr_default_rounding_mode); } #else ret = mpfr_init_set_str(t, SvPV_nolen(b), 0, __gmpfr_default_rounding_mode); #endif NON_NUMERIC_CHAR_CHECK(b), "overload_pow_eq subroutine");} mpfr_pow(*(INT2PTR(mpfr_t *, SvIVX(SvRV(p)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(p)))), t, __gmpfr_default_rounding_mode); mpfr_clear(t); return p; } if(SV_IS_NOK(b)) { #if defined(MPFR_PV_NV_BUG) NOK_POK_DUALVAR_CHECK , "overload_pow_eq");} #endif #if defined(USE_QUADMATH) mpfr_init2(t, FLT128_MANT_DIG); Rmpfr_set_NV(aTHX_ &t, b, __gmpfr_default_rounding_mode); #elif defined(USE_LONG_DOUBLE) mpfr_init2(t, REQUIRED_LDBL_MANT_DIG); mpfr_set_ld(t, (long double)SvNVX(b), __gmpfr_default_rounding_mode); #else mpfr_init2(t, DBL_MANT_DIG); mpfr_set_d(t, (double)SvNVX(b), __gmpfr_default_rounding_mode); #endif mpfr_pow(*(INT2PTR(mpfr_t *, SvIVX(SvRV(p)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(p)))), t, __gmpfr_default_rounding_mode); mpfr_clear(t); return p; } if(sv_isobject(b)) { const char* h = HvNAME(SvSTASH(SvRV(b))); if(strEQ(h, "Math::MPFR")) { mpfr_pow(*(INT2PTR(mpfr_t *, SvIVX(SvRV(p)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(p)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(b)))), __gmpfr_default_rounding_mode); return p; } if(strEQ(h, "Math::GMPz") || strEQ(h, "Math::GMP")) { mpfr_pow_z(*(INT2PTR(mpfr_t *, SvIV(SvRV(p)))), *(INT2PTR(mpfr_t *, SvIV(SvRV(p)))), *(INT2PTR(mpz_t *, SvIVX(SvRV(b)))), __gmpfr_default_rounding_mode); return p; } if(strEQ(h, "Math::GMPf")) { mpfr_init2(t, (mpfr_prec_t)mpf_get_prec(*(INT2PTR(mpf_t *, SvIVX(SvRV(b)))))); mpfr_set_f(t, *(INT2PTR(mpf_t *, SvIVX(SvRV(b)))), __gmpfr_default_rounding_mode); mpfr_pow(*(INT2PTR(mpfr_t *, SvIVX(SvRV(p)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(p)))), t, __gmpfr_default_rounding_mode); mpfr_clear(t); return p; } if(strEQ(h, "Math::GMPq")) { mpfr_init(t); mpfr_set_q(t, *(INT2PTR(mpq_t *, SvIVX(SvRV(b)))), __gmpfr_default_rounding_mode); mpfr_pow(*(INT2PTR(mpfr_t *, SvIVX(SvRV(p)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(p)))), t, __gmpfr_default_rounding_mode); mpfr_clear(t); return p; } } SvREFCNT_dec(p); croak("Invalid argument supplied to Math::MPFR::overload_pow_eq."); } SV * overload_div_eq(pTHX_ SV * a, SV * b, SV * third) { mpfr_t t; int ret; #ifdef _WIN32_BIZARRE_INFNAN int inf_or_nan; #endif PERL_UNUSED_ARG(third); SvREFCNT_inc(a); #ifdef MATH_MPFR_NEED_LONG_LONG_INT if(SV_IS_IOK(b)) { mpfr_init2(t, (mpfr_prec_t)IVSIZE_BITS); if(SvUOK(b)) mpfr_set_uj(t, SvUVX(b), __gmpfr_default_rounding_mode); else mpfr_set_sj(t, SvIVX(b), __gmpfr_default_rounding_mode); mpfr_div(*(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), t, __gmpfr_default_rounding_mode); mpfr_clear(t); return a; } #else if(SV_IS_IOK(b)) { if(SvUOK(b)) { mpfr_div_ui(*(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), SvUVX(b), __gmpfr_default_rounding_mode); return a; } mpfr_div_si(*(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), SvIVX(b), __gmpfr_default_rounding_mode); return a; } #endif #if defined(MPFR_PV_NV_BUG) if( (SV_IS_POK(b) && !SV_IS_NOK(b)) || (SV_IS_POK(b) && SV_IS_NOK(b) && SvIOKp(b)) ) { #else if(SV_IS_POK(b)) { #endif NOK_POK_DUALVAR_CHECK , "overload_div_eq");} #ifdef _WIN32_BIZARRE_INFNAN inf_or_nan = _win32_infnanstring(SvPV_nolen(b)); mpfr_init(t); if(inf_or_nan) { if(inf_or_nan == 2) { mpfr_set_nan(t); } else mpfr_set_inf(t, inf_or_nan); } else { ret = mpfr_set_str(t, SvPV_nolen(b), 0, __gmpfr_default_rounding_mode); } #else ret = mpfr_init_set_str(t, SvPV_nolen(b), 0, __gmpfr_default_rounding_mode); #endif NON_NUMERIC_CHAR_CHECK(b), "overload_div_eq subroutine");} mpfr_div(*(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), t, __gmpfr_default_rounding_mode); mpfr_clear(t); return a; } if(SV_IS_NOK(b)) { #if defined(MPFR_PV_NV_BUG) NOK_POK_DUALVAR_CHECK , "overload_div_eq");} #endif #if defined(USE_QUADMATH) mpfr_init2(t, FLT128_MANT_DIG); Rmpfr_set_NV(aTHX_ &t, b, __gmpfr_default_rounding_mode); #elif defined(USE_LONG_DOUBLE) mpfr_init2(t, REQUIRED_LDBL_MANT_DIG); mpfr_set_ld(t, (long double)SvNVX(b), __gmpfr_default_rounding_mode); #else mpfr_init2(t, DBL_MANT_DIG); mpfr_set_d(t, (double)SvNVX(b), __gmpfr_default_rounding_mode); #endif mpfr_div(*(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), t, __gmpfr_default_rounding_mode); mpfr_clear(t); return a; } if(sv_isobject(b)) { const char* h = HvNAME(SvSTASH(SvRV(b))); if(strEQ(h, "Math::MPFR")) { mpfr_div(*(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(b)))), __gmpfr_default_rounding_mode); return a; } if(strEQ(h, "Math::GMPz") || strEQ(h, "Math::GMP")) { mpfr_div_z(*(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpz_t *, SvIVX(SvRV(b)))), __gmpfr_default_rounding_mode); return a; } if(strEQ(h, "Math::GMPf")) { mpfr_init2(t, (mpfr_prec_t)mpf_get_prec(*(INT2PTR(mpf_t *, SvIVX(SvRV(b)))))); mpfr_set_f(t, *(INT2PTR(mpf_t *, SvIVX(SvRV(b)))), __gmpfr_default_rounding_mode); mpfr_div(*(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), t, __gmpfr_default_rounding_mode); mpfr_clear(t); return a; } if(strEQ(h, "Math::GMPq")) { mpfr_div_q(*(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpq_t *, SvIVX(SvRV(b)))), __gmpfr_default_rounding_mode); return a; } } SvREFCNT_dec(a); croak("Invalid argument supplied to Math::MPFR::overload_div_eq function"); } SV * overload_sub_eq(pTHX_ SV * a, SV * b, SV * third) { mpfr_t t; int ret; #ifdef _WIN32_BIZARRE_INFNAN int inf_or_nan; #endif PERL_UNUSED_ARG(third); SvREFCNT_inc(a); #ifdef MATH_MPFR_NEED_LONG_LONG_INT if(SV_IS_IOK(b)) { mpfr_init2(t, (mpfr_prec_t)IVSIZE_BITS); if(SvUOK(b)) mpfr_set_uj(t, SvUVX(b), __gmpfr_default_rounding_mode); else mpfr_set_sj(t, SvIVX(b), __gmpfr_default_rounding_mode); mpfr_sub(*(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), t, __gmpfr_default_rounding_mode); mpfr_clear(t); return a; } #else DEAL_WITH_NANFLAG_BUG_OVERLOADED if(SV_IS_IOK(b)) { if(SvUOK(b)) { mpfr_sub_ui(*(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), SvUVX(b), __gmpfr_default_rounding_mode); return a; } mpfr_sub_si(*(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), SvIVX(b), __gmpfr_default_rounding_mode); return a; /* if(SvIV(b) >= 0) { mpfr_sub_ui(*(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), SvUVX(b), __gmpfr_default_rounding_mode); return a; } mpfr_add_ui(*(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), SvIVX(b) * -1, __gmpfr_default_rounding_mode); return a; */ } #endif #if defined(MPFR_PV_NV_BUG) if( (SV_IS_POK(b) && !SV_IS_NOK(b)) || (SV_IS_POK(b) && SV_IS_NOK(b) && SvIOKp(b)) ) { #else if(SV_IS_POK(b)) { #endif NOK_POK_DUALVAR_CHECK , "overload_sub_eq");} #ifdef _WIN32_BIZARRE_INFNAN inf_or_nan = _win32_infnanstring(SvPV_nolen(b)); mpfr_init(t); if(inf_or_nan) { if(inf_or_nan == 2) { mpfr_set_nan(t); } else mpfr_set_inf(t, inf_or_nan); } else { ret = mpfr_set_str(t, SvPV_nolen(b), 0, __gmpfr_default_rounding_mode); } #else ret = mpfr_init_set_str(t, SvPV_nolen(b), 0, __gmpfr_default_rounding_mode); #endif NON_NUMERIC_CHAR_CHECK(b), "overload_sub_eq subroutine");} mpfr_sub(*(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), t, __gmpfr_default_rounding_mode); mpfr_clear(t); return a; } if(SV_IS_NOK(b)) { #if defined(MPFR_PV_NV_BUG) NOK_POK_DUALVAR_CHECK , "overload_sub_eq");} #endif #if defined(USE_QUADMATH) mpfr_init2(t, FLT128_MANT_DIG); Rmpfr_set_NV(aTHX_ &t, b, __gmpfr_default_rounding_mode); #elif defined(USE_LONG_DOUBLE) mpfr_init2(t, REQUIRED_LDBL_MANT_DIG); mpfr_set_ld(t, (long double)SvNVX(b), __gmpfr_default_rounding_mode); #else mpfr_init2(t, DBL_MANT_DIG); mpfr_init_set_d(t, (double)SvNVX(b), __gmpfr_default_rounding_mode); #endif mpfr_sub(*(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), t, __gmpfr_default_rounding_mode); mpfr_clear(t); return a; } if(sv_isobject(b)) { const char* h = HvNAME(SvSTASH(SvRV(b))); if(strEQ(h, "Math::MPFR")) { mpfr_sub(*(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(b)))), __gmpfr_default_rounding_mode); return a; } if(strEQ(h, "Math::GMPz") || strEQ(h, "Math::GMP")) { mpfr_sub_z(*(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpz_t *, SvIVX(SvRV(b)))), __gmpfr_default_rounding_mode); return a; } if(strEQ(h, "Math::GMPf")) { mpfr_init2(t, (mpfr_prec_t)mpf_get_prec(*(INT2PTR(mpf_t *, SvIVX(SvRV(b)))))); mpfr_set_f(t, *(INT2PTR(mpf_t *, SvIVX(SvRV(b)))), __gmpfr_default_rounding_mode); mpfr_sub(*(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), t, __gmpfr_default_rounding_mode); mpfr_clear(t); return a; } if(strEQ(h, "Math::GMPq")) { mpfr_sub_q(*(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpq_t *, SvIVX(SvRV(b)))), __gmpfr_default_rounding_mode); return a; } } SvREFCNT_dec(a); croak("Invalid argument supplied to Math::MPFR::overload_sub_eq function"); } SV * overload_add_eq(pTHX_ SV * a, SV * b, SV * third) { mpfr_t t; int ret; #ifdef _WIN32_BIZARRE_INFNAN int inf_or_nan; #endif PERL_UNUSED_ARG(third); SvREFCNT_inc(a); #ifdef MATH_MPFR_NEED_LONG_LONG_INT if(SV_IS_IOK(b)) { mpfr_init2(t, (mpfr_prec_t)IVSIZE_BITS); if(SvUOK(b)) mpfr_set_uj(t, SvUVX(b), __gmpfr_default_rounding_mode); else mpfr_set_sj(t, SvIVX(b), __gmpfr_default_rounding_mode); mpfr_add(*(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), t, __gmpfr_default_rounding_mode); mpfr_clear(t); return a; } #else DEAL_WITH_NANFLAG_BUG_OVERLOADED if(SV_IS_IOK(b)) { if(SvUOK(b)) { mpfr_add_ui(*(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), SvUVX(b), __gmpfr_default_rounding_mode); return a; } mpfr_add_si(*(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), SvIVX(b), __gmpfr_default_rounding_mode); return a; } #endif #if defined(MPFR_PV_NV_BUG) if( (SV_IS_POK(b) && !SV_IS_NOK(b)) || (SV_IS_POK(b) && SV_IS_NOK(b) && SvIOKp(b)) ) { #else if(SV_IS_POK(b)) { #endif NOK_POK_DUALVAR_CHECK , "overload_add_eq(aTHX_ +=)");} #ifdef _WIN32_BIZARRE_INFNAN inf_or_nan = _win32_infnanstring(SvPV_nolen(b)); mpfr_init(t); if(inf_or_nan) { if(inf_or_nan == 2) { mpfr_set_nan(t); } else mpfr_set_inf(t, inf_or_nan); } else { ret = mpfr_set_str(t, SvPV_nolen(b), 0, __gmpfr_default_rounding_mode); } #else ret = mpfr_init_set_str(t, SvPV_nolen(b), 0, __gmpfr_default_rounding_mode); #endif NON_NUMERIC_CHAR_CHECK(b), "overload_add_eq subroutine");} mpfr_add(*(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), t, __gmpfr_default_rounding_mode); mpfr_clear(t); return a; } if(SV_IS_NOK(b)) { #if defined(MPFR_PV_NV_BUG) NOK_POK_DUALVAR_CHECK , "overload_add_eq(aTHX_ +=)");} #endif #if defined(USE_QUADMATH) mpfr_init2(t, FLT128_MANT_DIG); Rmpfr_set_NV(aTHX_ &t, b, __gmpfr_default_rounding_mode); #elif defined(USE_LONG_DOUBLE) mpfr_init2(t, REQUIRED_LDBL_MANT_DIG); mpfr_set_ld(t, (long double)SvNVX(b), __gmpfr_default_rounding_mode); #else mpfr_init2(t, DBL_MANT_DIG); mpfr_set_d(t, (double)SvNVX(b), __gmpfr_default_rounding_mode); #endif mpfr_add(*(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), t, __gmpfr_default_rounding_mode); mpfr_clear(t); return a; } if(sv_isobject(b)) { const char* h = HvNAME(SvSTASH(SvRV(b))); if(strEQ(h, "Math::MPFR")) { mpfr_add(*(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(b)))), __gmpfr_default_rounding_mode); return a; } if(strEQ(h, "Math::GMPz") || strEQ(h, "Math::GMP")) { mpfr_add_z(*(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpz_t *, SvIVX(SvRV(b)))), __gmpfr_default_rounding_mode); return a; } if(strEQ(h, "Math::GMPf")) { mpfr_init2(t, (mpfr_prec_t)mpf_get_prec(*(INT2PTR(mpf_t *, SvIVX(SvRV(b)))))); mpfr_set_f(t, *(INT2PTR(mpf_t *, SvIVX(SvRV(b)))), __gmpfr_default_rounding_mode); mpfr_add(*(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), t, __gmpfr_default_rounding_mode); mpfr_clear(t); return a; } if(strEQ(h, "Math::GMPq")) { mpfr_add_q(*(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpq_t *, SvIVX(SvRV(b)))), __gmpfr_default_rounding_mode); return a; } } SvREFCNT_dec(a); croak("Invalid argument supplied to Math::MPFR::overload_add_eq"); } SV * overload_mul_eq(pTHX_ SV * a, SV * b, SV * third) { mpfr_t t; int ret; #ifdef _WIN32_BIZARRE_INFNAN int inf_or_nan; #endif PERL_UNUSED_ARG(third); SvREFCNT_inc(a); #ifdef MATH_MPFR_NEED_LONG_LONG_INT if(SV_IS_IOK(b)) { mpfr_init2(t, (mpfr_prec_t)IVSIZE_BITS); if(SvUOK(b)) mpfr_set_uj(t, SvUVX(b), __gmpfr_default_rounding_mode); else mpfr_set_sj(t, SvIVX(b), __gmpfr_default_rounding_mode); mpfr_mul(*(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), t, __gmpfr_default_rounding_mode); mpfr_clear(t); return a; } #else if(SV_IS_IOK(b)) { if(SvUOK(b)) { mpfr_mul_ui(*(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), SvUVX(b), __gmpfr_default_rounding_mode); return a; } mpfr_mul_si(*(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), SvIVX(b), __gmpfr_default_rounding_mode); return a; } #endif #if defined(MPFR_PV_NV_BUG) if( (SV_IS_POK(b) && !SV_IS_NOK(b)) || (SV_IS_POK(b) && SV_IS_NOK(b) && SvIOKp(b)) ) { #else if(SV_IS_POK(b)) { #endif NOK_POK_DUALVAR_CHECK , "overload_mul_eq");} #ifdef _WIN32_BIZARRE_INFNAN inf_or_nan = _win32_infnanstring(SvPV_nolen(b)); mpfr_init(t); if(inf_or_nan) { if(inf_or_nan == 2) { mpfr_set_nan(t); } else mpfr_set_inf(t, inf_or_nan); } else { ret = mpfr_set_str(t, SvPV_nolen(b), 0, __gmpfr_default_rounding_mode); } #else ret = mpfr_init_set_str(t, SvPV_nolen(b), 0, __gmpfr_default_rounding_mode); #endif NON_NUMERIC_CHAR_CHECK(b), "overload_mul_eq subroutine");} mpfr_mul(*(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), t, __gmpfr_default_rounding_mode); mpfr_clear(t); return a; } if(SV_IS_NOK(b)) { #if defined(MPFR_PV_NV_BUG) NOK_POK_DUALVAR_CHECK , "overload_mul_eq");} #endif #if defined(USE_QUADMATH) mpfr_init2(t, FLT128_MANT_DIG); Rmpfr_set_NV(aTHX_ &t, b, __gmpfr_default_rounding_mode); #elif defined(USE_LONG_DOUBLE) mpfr_init2(t, REQUIRED_LDBL_MANT_DIG); mpfr_set_ld(t, (long double)SvNVX(b), __gmpfr_default_rounding_mode); #else mpfr_init2(t, DBL_MANT_DIG); mpfr_init_set_d(t, (double)SvNVX(b), __gmpfr_default_rounding_mode); #endif mpfr_mul(*(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), t, __gmpfr_default_rounding_mode); mpfr_clear(t); return a; } if(sv_isobject(b)) { const char* h = HvNAME(SvSTASH(SvRV(b))); if(strEQ(h, "Math::MPFR")) { mpfr_mul(*(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(b)))), __gmpfr_default_rounding_mode); return a; } if(strEQ(h, "Math::GMPz") || strEQ(h, "Math::GMP")) { mpfr_mul_z(*(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpz_t *, SvIVX(SvRV(b)))), __gmpfr_default_rounding_mode); return a; } if(strEQ(h, "Math::GMPf")) { mpfr_init2(t, (mpfr_prec_t)mpf_get_prec(*(INT2PTR(mpf_t *, SvIVX(SvRV(b)))))); mpfr_set_f(t, *(INT2PTR(mpf_t *, SvIVX(SvRV(b)))), __gmpfr_default_rounding_mode); mpfr_mul(*(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), t, __gmpfr_default_rounding_mode); mpfr_clear(t); return a; } if(strEQ(h, "Math::GMPq")) { mpfr_mul_q(*(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpq_t *, SvIVX(SvRV(b)))), __gmpfr_default_rounding_mode); return a; } } SvREFCNT_dec(a); croak("Invalid argument supplied to Math::MPFR::overload_mul_eq"); } SV * _itsa(pTHX_ SV * a) { if(SV_IS_IOK(a)) { if(SvUOK(a)) return newSVuv(1); return newSVuv(2); } if(SV_IS_POK(a)) { #if defined(MPFR_PV_NV_BUG) /* perl can set the POK flag when it should not */ if(SvNOK(a) && !SvIOKp(a)) return newSVuv(3); /* designate it as NV */ #endif return newSVuv(4); /* designate it as PV */ } if(SV_IS_NOK(a)) return newSVuv(3); if(sv_isobject(a)) { const char* h = HvNAME(SvSTASH(SvRV(a))); if(strEQ(h, "Math::MPFR")) return newSVuv(5); if(strEQ(h, "Math::GMPf")) return newSVuv(6); if(strEQ(h, "Math::GMPq")) return newSVuv(7); if(strEQ(h, "Math::GMPz")) return newSVuv(8); if(strEQ(h, "Math::GMP")) return newSVuv(9); } return newSVuv(0); } int _has_longlong(void) { #ifdef MATH_MPFR_NEED_LONG_LONG_INT return 1; #else return 0; #endif } int _has_longdouble(void) { #if defined(USE_LONG_DOUBLE) || defined(USE_QUADMATH) return 1; #else return 0; #endif } int _ivsize_bits(void) { int ret = 0; #ifdef IVSIZE_BITS ret = IVSIZE_BITS; #endif return ret; } SV * RMPFR_PREC_MAX(pTHX) { return newSViv(MPFR_PREC_MAX); } SV * RMPFR_PREC_MIN(pTHX) { return newSViv(MPFR_PREC_MIN); } SV * wrap_mpfr_printf(pTHX_ SV * a, SV * b) { int ret; if(sv_isobject(b)) { const char* h = HvNAME(SvSTASH(SvRV(b))); if(strEQ(h, "Math::MPFR")){ ret = mpfr_printf(SvPV_nolen(a), *(INT2PTR(mpfr_t *, SvIVX(SvRV(b))))); fflush(stdout); return newSViv(ret); } if(strEQ(h, "Math::MPFR::Prec")){ ret = mpfr_printf(SvPV_nolen(a), *(INT2PTR(mpfr_prec_t *, SvIVX(SvRV(b))))); fflush(stdout); return newSViv(ret); } if(strEQ(h, "Math::GMP") || strEQ(h, "Math::GMPz")){ ret = mpfr_printf(SvPV_nolen(a), *(INT2PTR(mpz_t *, SvIVX(SvRV(b))))); fflush(stdout); return newSViv(ret); } if(strEQ(h, "Math::GMPq")){ ret = mpfr_printf(SvPV_nolen(a), *(INT2PTR(mpq_t *, SvIVX(SvRV(b))))); fflush(stdout); return newSViv(ret); } if(strEQ(h, "Math::GMPf")){ ret = mpfr_printf(SvPV_nolen(a), *(INT2PTR(mpf_t *, SvIVX(SvRV(b))))); fflush(stdout); return newSViv(ret); } croak("Unrecognised object supplied as argument to Rmpfr_printf"); } if(SV_IS_IOK(b)) { if(SvUOK(b)) ret = mpfr_printf(SvPV_nolen(a), SvUVX(b)); else ret = mpfr_printf(SvPV_nolen(a), SvIVX(b)); fflush(stdout); return newSViv(ret); } if(SV_IS_POK(b)) { NOK_POK_DUALVAR_CHECK , "wrap_mpfr_printf");} ret = mpfr_printf(SvPV_nolen(a), SvPV_nolen(b)); fflush(stdout); return newSViv(ret); } if(SV_IS_NOK(b)) { ret = mpfr_printf(SvPV_nolen(a), SvNVX(b)); fflush(stdout); return newSViv(ret); } croak("Unrecognised type supplied as argument to Rmpfr_printf"); } SV * wrap_mpfr_fprintf(pTHX_ FILE * stream, SV * a, SV * b) { int ret; if(sv_isobject(b)) { const char* h = HvNAME(SvSTASH(SvRV(b))); if(strEQ(h, "Math::MPFR")) { ret = mpfr_fprintf(stream, SvPV_nolen(a), *(INT2PTR(mpfr_t *, SvIVX(SvRV(b))))); fflush(stream); return newSViv(ret); } if(strEQ(h, "Math::MPFR::Prec")) { ret = mpfr_fprintf(stream, SvPV_nolen(a), *(INT2PTR(mpfr_prec_t *, SvIVX(SvRV(b))))); fflush(stream); return newSViv(ret); } if(strEQ(h, "Math::GMPz") || strEQ(h, "Math::GMP")) { ret = mpfr_fprintf(stream, SvPV_nolen(a), *(INT2PTR(mpz_t *, SvIVX(SvRV(b))))); fflush(stream); return newSViv(ret); } if(strEQ(h, "Math::GMPq")) { ret = mpfr_fprintf(stream, SvPV_nolen(a), *(INT2PTR(mpq_t *, SvIVX(SvRV(b))))); fflush(stream); return newSViv(ret); } if(strEQ(h, "Math::GMPf")) { ret = mpfr_fprintf(stream, SvPV_nolen(a), *(INT2PTR(mpf_t *, SvIVX(SvRV(b))))); fflush(stream); return newSViv(ret); } croak("Unrecognised object supplied as argument to Rmpfr_fprintf"); } if(SV_IS_IOK(b)) { if(SvUOK(b)) ret = mpfr_fprintf(stream, SvPV_nolen(a), SvUVX(b)); else ret = mpfr_fprintf(stream, SvPV_nolen(a), SvIVX(b)); fflush(stream); return newSViv(ret); } if(SV_IS_POK(b)) { NOK_POK_DUALVAR_CHECK , "wrap_mpfr_fprintf");} ret = mpfr_fprintf(stream, SvPV_nolen(a), SvPV_nolen(b)); fflush(stream); return newSViv(ret); } if(SV_IS_NOK(b)) { ret = mpfr_fprintf(stream, SvPV_nolen(a), SvNVX(b)); fflush(stream); return newSViv(ret); } croak("Unrecognised type supplied as argument to Rmpfr_fprintf"); } SV * wrap_mpfr_sprintf(pTHX_ SV * s, SV * a, SV * b, int buflen) { int ret; char * stream; Newx(stream, buflen, char); if(sv_isobject(b)) { const char* h = HvNAME(SvSTASH(SvRV(b))); if(strEQ(h, "Math::MPFR")) { ret = mpfr_sprintf(stream, SvPV_nolen(a), *(INT2PTR(mpfr_t *, SvIVX(SvRV(b))))); sv_setpv(s, stream); Safefree(stream); return newSViv(ret); } if(strEQ(h, "Math::MPFR::Prec")) { ret = mpfr_sprintf(stream, SvPV_nolen(a), *(INT2PTR(mpfr_prec_t *, SvIVX(SvRV(b))))); sv_setpv(s, stream); Safefree(stream); return newSViv(ret); } if(strEQ(h, "Math::GMPz") || strEQ(h, "Math::GMP")) { ret = mpfr_sprintf(stream, SvPV_nolen(a), *(INT2PTR(mpz_t *, SvIVX(SvRV(b))))); sv_setpv(s, stream); Safefree(stream); return newSViv(ret); } if(strEQ(h, "Math::GMPq")) { ret = mpfr_sprintf(stream, SvPV_nolen(a), *(INT2PTR(mpq_t *, SvIVX(SvRV(b))))); sv_setpv(s, stream); Safefree(stream); return newSViv(ret); } if(strEQ(h, "Math::GMPf")) { ret = mpfr_sprintf(stream, SvPV_nolen(a), *(INT2PTR(mpf_t *, SvIVX(SvRV(b))))); sv_setpv(s, stream); Safefree(stream); return newSViv(ret); } Safefree(stream); /* in case the ensuing croak() occurs inside eval{} */ croak("Unrecognised object supplied as argument to Rmpfr_sprintf"); } if(SV_IS_IOK(b)) { if(SvUOK(b)) ret = mpfr_sprintf(stream, SvPV_nolen(a), SvUVX(b)); else ret = mpfr_sprintf(stream, SvPV_nolen(a), SvIVX(b)); sv_setpv(s, stream); Safefree(stream); return newSViv(ret); } if(SV_IS_POK(b)) { NOK_POK_DUALVAR_CHECK , "wrap_mpfr_sprintf");} ret = mpfr_sprintf(stream, SvPV_nolen(a), SvPV_nolen(b)); sv_setpv(s, stream); Safefree(stream); return newSViv(ret); } if(SV_IS_NOK(b)) { ret = mpfr_sprintf(stream, SvPV_nolen(a), SvNVX(b)); sv_setpv(s, stream); Safefree(stream); return newSViv(ret); } Safefree(stream); /* in case the ensuing croak() occurs inside eval{} */ croak("Unrecognised type supplied as argument to Rmpfr_sprintf"); } SV * wrap_mpfr_snprintf(pTHX_ SV * s, SV * bytes, SV * a, SV * b, int buflen) { int ret; char * stream; Newx(stream, buflen, char); if(sv_isobject(b)) { const char* h = HvNAME(SvSTASH(SvRV(b))); if(strEQ(h, "Math::MPFR")) { ret = mpfr_snprintf(stream, (size_t)SvUV(bytes), SvPV_nolen(a), *(INT2PTR(mpfr_t *, SvIVX(SvRV(b))))); sv_setpv(s, stream); Safefree(stream); return newSViv(ret); } if(strEQ(h, "Math::MPFR::Prec")) { ret = mpfr_snprintf(stream, (size_t)SvUV(bytes), SvPV_nolen(a), *(INT2PTR(mpfr_prec_t *, SvIVX(SvRV(b))))); sv_setpv(s, stream); Safefree(stream); return newSViv(ret); } if(strEQ(h, "Math::GMPz") || strEQ(h, "Math::GMP")) { ret = mpfr_snprintf(stream, (size_t)SvUV(bytes), SvPV_nolen(a), *(INT2PTR(mpz_t *, SvIVX(SvRV(b))))); sv_setpv(s, stream); Safefree(stream); return newSViv(ret); } if(strEQ(h, "Math::GMPq")) { ret = mpfr_snprintf(stream, (size_t)SvUV(bytes), SvPV_nolen(a), *(INT2PTR(mpq_t *, SvIVX(SvRV(b))))); sv_setpv(s, stream); Safefree(stream); return newSViv(ret); } if(strEQ(h, "Math::GMPf")) { ret = mpfr_snprintf(stream, (size_t)SvUV(bytes), SvPV_nolen(a), *(INT2PTR(mpf_t *, SvIVX(SvRV(b))))); sv_setpv(s, stream); Safefree(stream); return newSViv(ret); } Safefree(stream); /* in case the ensuing croak() occurs inside eval{} */ croak("Unrecognised object supplied as argument to Rmpfr_snprintf"); } if(SV_IS_IOK(b)) { if(SvUOK(b)) ret = mpfr_snprintf(stream, (size_t)SvUV(bytes), SvPV_nolen(a), SvUVX(b)); else ret = mpfr_snprintf(stream, (size_t)SvUV(bytes), SvPV_nolen(a), SvIVX(b)); sv_setpv(s, stream); Safefree(stream); return newSViv(ret); } if(SV_IS_POK(b)) { NOK_POK_DUALVAR_CHECK , "wrap_mpfr_snprintf");} ret = mpfr_snprintf(stream, (size_t)SvUV(bytes), SvPV_nolen(a), SvPV_nolen(b)); sv_setpv(s, stream); Safefree(stream); return newSViv(ret); } if(SV_IS_NOK(b)) { ret = mpfr_snprintf(stream, (size_t)SvUV(bytes), SvPV_nolen(a), SvNVX(b)); sv_setpv(s, stream); Safefree(stream); return newSViv(ret); } Safefree(stream); /* in case the ensuing croak() occurs inside eval{} */ croak("Unrecognised type supplied as argument to Rmpfr_snprintf"); } SV * wrap_mpfr_printf_rnd(pTHX_ SV * a, SV * round, SV * b) { int ret; if((mpfr_rnd_t)SvUV(round) > 4) croak("Invalid 2nd argument (rounding value) of %u passed to Rmpfr_printf", (mpfr_rnd_t)SvUV(round)); if(sv_isobject(b)) { const char* h = HvNAME(SvSTASH(SvRV(b))); if(strEQ(h, "Math::MPFR")){ ret = mpfr_printf(SvPV_nolen(a), (mpfr_rnd_t)SvUV(round), *(INT2PTR(mpfr_t *, SvIVX(SvRV(b))))); fflush(stdout); return newSViv(ret); } if(strEQ(h, "Math::MPFR::Prec")){ croak("You've provided both a rounding arg and a Math::MPFR::Prec object to Rmpfr_printf"); } croak("Unrecognised object supplied as argument to Rmpfr_printf"); } croak("In Rmpfr_printf: The rounding argument is specific to Math::MPFR objects"); } SV * wrap_mpfr_fprintf_rnd(pTHX_ FILE * stream, SV * a, SV * round, SV * b) { int ret; if((mpfr_rnd_t)SvUV(round) > 4) croak("Invalid 3rd argument (rounding value) of %u passed to Rmpfr_fprintf", (mpfr_rnd_t)SvUV(round)); if(sv_isobject(b)) { const char* h = HvNAME(SvSTASH(SvRV(b))); if(strEQ(h, "Math::MPFR")) { ret = mpfr_fprintf(stream, SvPV_nolen(a), (mpfr_rnd_t)SvUV(round), *(INT2PTR(mpfr_t *, SvIVX(SvRV(b))))); fflush(stream); return newSViv(ret); } if(strEQ(h, "Math::MPFR::Prec")) { croak("You've provided both a rounding arg and a Math::MPFR::Prec object to Rmpfr_fprintf"); } croak("Unrecognised object supplied as argument to Rmpfr_fprintf"); } croak("In Rmpfr_fprintf: The rounding argument is specific to Math::MPFR objects"); } SV * wrap_mpfr_sprintf_rnd(pTHX_ SV * s, SV * a, SV * round, SV * b, int buflen) { int ret; char * stream; Newx(stream, buflen, char); if((mpfr_rnd_t)SvUV(round) > 4) croak("Invalid 3rd argument (rounding value) of %u passed to Rmpfr_sprintf", (mpfr_rnd_t)SvUV(round)); if(sv_isobject(b)) { const char* h = HvNAME(SvSTASH(SvRV(b))); if(strEQ(h, "Math::MPFR")) { ret = mpfr_sprintf(stream, SvPV_nolen(a), (mpfr_rnd_t)SvUV(round), *(INT2PTR(mpfr_t *, SvIVX(SvRV(b))))); sv_setpv(s, stream); Safefree(stream); return newSViv(ret); } if(strEQ(h, "Math::MPFR::Prec")) { croak("You've provided both a rounding arg and a Math::MPFR::Prec object to Rmpfr_sprintf"); } croak("Unrecognised object supplied as argument to Rmpfr_sprintf"); } croak("In Rmpfr_sprintf: The rounding argument is specific to Math::MPFR objects"); } SV * wrap_mpfr_snprintf_rnd(pTHX_ SV * s, SV * bytes, SV * a, SV * round, SV * b, int buflen) { int ret; char * stream; Newx(stream, buflen, char); if((mpfr_rnd_t)SvUV(round) > 4) croak("Invalid 3rd argument (rounding value) of %u passed to Rmpfr_snprintf", (mpfr_rnd_t)SvUV(round)); if(sv_isobject(b)) { const char* h = HvNAME(SvSTASH(SvRV(b))); if(strEQ(h, "Math::MPFR")) { ret = mpfr_snprintf(stream, (size_t)SvUV(bytes), SvPV_nolen(a), (mpfr_rnd_t)SvUV(round), *(INT2PTR(mpfr_t *, SvIVX(SvRV(b))))); sv_setpv(s, stream); Safefree(stream); return newSViv(ret); } if(strEQ(h, "Math::MPFR::Prec")) { croak("You've provided both a rounding arg and a Math::MPFR::Prec object to Rmpfr_snprintf"); } croak("Unrecognised object supplied as argument to Rmpfr_snprintf"); } croak("In Rmpfr_snprintf: The rounding argument is specific to Math::MPFR objects"); } SV * Rmpfr_buildopt_tls_p(pTHX) { return newSViv(mpfr_buildopt_tls_p()); } SV * Rmpfr_buildopt_float16_p(pTHX) { #if MPFR_VERSION >= 262912 return newSViv(mpfr_buildopt_float16_p()); #else croak("'mpfr_buildopt_float16_p' not implemented until MPFR-4.3.0"); #endif } SV * Rmpfr_buildopt_decimal_p(pTHX) { return newSViv(mpfr_buildopt_decimal_p()); } SV * Rmpfr_regular_p(pTHX_ mpfr_t * a) { return newSViv(mpfr_regular_p(*a)); } void Rmpfr_set_zero(pTHX_ mpfr_t * a, SV * sign) { mpfr_set_zero(*a, (int)SvIV(sign)); } SV * Rmpfr_digamma(pTHX_ mpfr_t * rop, mpfr_t * op, SV * round) { return newSViv(mpfr_digamma(*rop, *op, (mpfr_rnd_t)SvIV(round))); } SV * Rmpfr_trigamma(pTHX_ mpfr_t * rop, mpfr_t * op, SV * round) { #if MPFR_VERSION >= 262912 return newSViv(mpfr_trigamma(*rop, *op, (mpfr_rnd_t)SvIV(round))); #else PERL_UNUSED_ARG3(rop, op, round); croak("Rmpfr_trigamma function not implemented until mpfr-4.3.0. (You have only version %s) ", MPFR_VERSION_STRING); #endif } SV * Rmpfr_ai(pTHX_ mpfr_t * rop, mpfr_t * op, SV * round) { return newSViv(mpfr_ai(*rop, *op, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_get_flt(pTHX_ mpfr_t * a, SV * round) { return newSVnv(mpfr_get_flt(*a, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_get_float16(pTHX_ mpfr_t * a, SV * round) { #if MPFR_VERSION >= MPFR_VERSION_NUM(4,3,0) # if defined(HAVE_FLOAT16) /* defined in Makefile.PL */ return newSVnv(mpfr_get_float16(*a, (mpfr_rnd_t)SvUV(round))); # else PERL_UNUSED_ARG2(a, round); croak("Perl interface to Rmpfr_get_float16 not available. The '_Float16' type was not recognized"); # endif #else PERL_UNUSED_ARG2(a, round); croak("Perl interface to Rmpfr_get_float16 not available for this version (%s) of the mpfr library. We need at least version 4.3.0", MPFR_VERSION_STRING); #endif } SV * Rmpfr_set_flt(pTHX_ mpfr_t * rop, SV * f, SV * round) { return newSViv(mpfr_set_flt(*rop, (float)SvNV(f), (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_set_float16(pTHX_ mpfr_t * rop, SV * f, SV * round) { #if MPFR_VERSION >= MPFR_VERSION_NUM(4,3,0) # if defined(HAVE_FLOAT16) /* defined in Makefile.PL */ return newSViv(mpfr_set_flt(*rop, (_Float16)SvNV(f), (mpfr_rnd_t)SvUV(round))); # else PERL_UNUSED_ARG3(rop, f, round); croak("Perl interface to Rmpfr_set_float16 not available. The '_Float16' type was not recognized"); # endif #else PERL_UNUSED_ARG3(rop, f, round); croak("Perl interface to Rmpfr_set_float16 not available for this version (%s) of the mpfr library. We need at least version 4.3.0", MPFR_VERSION_STRING); #endif } SV * Rmpfr_urandom(pTHX_ mpfr_t * rop, gmp_randstate_t* state, SV * round) { return newSViv(mpfr_urandom(*rop, *state, (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_set_z_2exp(pTHX_ mpfr_t * rop, mpz_t * op, SV * exp, SV * round) { return newSViv(mpfr_set_z_2exp(*rop, *op, (mpfr_exp_t)SvIV(exp), (mpfr_rnd_t)SvUV(round))); } SV * Rmpfr_buildopt_tune_case(pTHX) { #if (MPFR_VERSION_MAJOR == 3 && MPFR_VERSION_MINOR >= 1) || MPFR_VERSION_MAJOR > 3 return newSVpv(mpfr_buildopt_tune_case(), 0); #else croak("Rmpfr_buildopt_tune_case not implemented with this version of the mpfr library - we have %s but need at least 3.1.0", MPFR_VERSION_STRING); #endif } SV * Rmpfr_frexp(pTHX_ SV * exp, mpfr_t * rop, mpfr_t * op, SV * round) { #if (MPFR_VERSION_MAJOR == 3 && MPFR_VERSION_MINOR >= 1) || MPFR_VERSION_MAJOR > 3 mpfr_exp_t _exp; int ret; ret = mpfr_frexp(&_exp, *rop, *op, (mpfr_rnd_t)SvUV(round)); sv_setiv(exp, _exp); return newSViv(ret); #else croak("Rmpfr_frexp not implemented with this version of the mpfr library - we have %s but need at least 3.1.0", MPFR_VERSION_STRING); #endif } SV * Rmpfr_z_sub(pTHX_ mpfr_t * rop, mpz_t * op1, mpfr_t * op2, SV * round) { #if (MPFR_VERSION_MAJOR == 3 && MPFR_VERSION_MINOR >= 1) || MPFR_VERSION_MAJOR > 3 return newSViv(mpfr_z_sub(*rop, *op1, *op2, (mpfr_rnd_t)SvUV(round))); #else PERL_UNUSED_ARG4(rop,op1, op2, round); croak("Rmpfr_z_sub not implemented with this version of the mpfr library - we have %s but need at least 3.1.0", MPFR_VERSION_STRING); #endif } SV * Rmpfr_grandom(pTHX_ mpfr_t * rop1, mpfr_t * rop2, gmp_randstate_t * state, SV * round) { #if MPFR_VERSION_MAJOR >= 4 PERL_UNUSED_ARG4(rop1, rop2, state, round); croak("Rmpfr_grandom is deprecated, and now removed - use Rmpfr_nrandom instead"); #elif (MPFR_VERSION_MAJOR == 3 && MPFR_VERSION_MINOR >= 1) || MPFR_VERSION_MAJOR > 3 return newSViv(mpfr_grandom(*rop1, *rop2, *state, (mpfr_rnd_t)SvUV(round))); #else PERL_UNUSED_ARG4(rop1, rop2, state, round); croak("Rmpfr_grandom was not introduced until mpfr-3.1.0 and was then deprecated & replaced by Rmpfr_nrandom as of mpfr-4.0.0"); #endif } void Rmpfr_clear_divby0(pTHX) { #if (MPFR_VERSION_MAJOR == 3 && MPFR_VERSION_MINOR >= 1) || MPFR_VERSION_MAJOR > 3 mpfr_clear_divby0(); #else croak("Rmpfr_clear_divby0 not implemented with this version of the mpfr library - we have %s but need at least 3.1.0", MPFR_VERSION_STRING); #endif } void Rmpfr_set_divby0(pTHX) { #if (MPFR_VERSION_MAJOR == 3 && MPFR_VERSION_MINOR >= 1) || MPFR_VERSION_MAJOR > 3 mpfr_set_divby0(); #else croak("Rmpfr_set_divby0 not implemented with this version of the mpfr library - we have %s but need at least 3.1.0", MPFR_VERSION_STRING); #endif } SV * Rmpfr_divby0_p(pTHX) { #if (MPFR_VERSION_MAJOR == 3 && MPFR_VERSION_MINOR >= 1) || MPFR_VERSION_MAJOR > 3 return newSViv(mpfr_divby0_p()); #else croak("Rmpfr_divby0_p not implemented with this version of the mpfr library - we have %s but need at least 3.1.0", MPFR_VERSION_STRING); #endif } SV * Rmpfr_buildopt_gmpinternals_p(pTHX) { #if (MPFR_VERSION_MAJOR == 3 && MPFR_VERSION_MINOR >= 1) || MPFR_VERSION_MAJOR > 3 return newSViv(mpfr_buildopt_gmpinternals_p()); #else croak("Rmpfr_buildopt_gmpinternals_p not implemented with this version of the mpfr library - we have %s but need at least 3.1.0", MPFR_VERSION_STRING); #endif } SV * _get_xs_version(pTHX) { return newSVpv(XS_VERSION, 0); } void overload_inc(pTHX_ SV * a, SV * b, SV * third) { PERL_UNUSED_ARG2(b, third); DEAL_WITH_NANFLAG_BUG_OVERLOADED mpfr_add_ui(*(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), 1, __gmpfr_default_rounding_mode); } void overload_dec(pTHX_ SV * a, SV * b, SV * third) { PERL_UNUSED_ARG2(b, third); DEAL_WITH_NANFLAG_BUG_OVERLOADED mpfr_sub_ui(*(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), 1, __gmpfr_default_rounding_mode); } SV * _overload_lshift(pTHX_ mpfr_t * a, SV * b, SV * third) { /* b will be +ve ... otherwise overload_rshift would have been called. */ mpfr_t * mpfr_t_obj; SV * obj_ref, * obj; #if IVSIZE > LONGSIZE if( SvUV(b) > (unsigned long)SvUV(b) ) croak ("In Math::MPFR overloading of '<<' operator, the 'shift' operand overflows 'long int'"); #endif NEW_MATH_MPFR_OBJECT("Math::MPFR",overload_mul_2exp) /* defined in math_mpfr_include.h */ mpfr_init(*mpfr_t_obj); PERL_UNUSED_ARG(third); OBJ_READONLY_ON /*defined in math_mpfr_include.h */ mpfr_trunc(*mpfr_t_obj, *a); mpfr_mul_2ui(*mpfr_t_obj, *mpfr_t_obj, (unsigned long)SvUV(b), __gmpfr_default_rounding_mode); return obj_ref; } SV * _overload_rshift(pTHX_ mpfr_t * a, SV * b, SV * third) { /* b will be +ve ... otherwise overload_lshift would have been called. */ mpfr_t * mpfr_t_obj; SV * obj_ref, * obj; mpz_t z; #if IVSIZE > LONGSIZE if( SvUV(b) > (mp_bitcnt_t)SvUV(b) ) croak ("In Math::MPFR overloading of '>>' operator, the 'shift' operand overflows 'long int'"); #endif NEW_MATH_MPFR_OBJECT("Math::MPFR",overload_mul_2exp) /* defined in math_mpfr_include.h */ mpfr_init(*mpfr_t_obj); PERL_UNUSED_ARG(third); OBJ_READONLY_ON /*defined in math_mpfr_include.h */ if(!mpfr_number_p(*a)) { /* Is either an Inf or NaN */ if(mpfr_nan_p(*a)) return obj_ref; /* return NaN */ mpfr_set_inf(*mpfr_t_obj, mpfr_sgn(*a)); return obj_ref; /* Return appropriately signed Inf */ } mpz_init(z); mpfr_get_z(z, *a, GMP_RNDZ); /* Truncate *a */ mpz_div_2exp(z, z, (mp_bitcnt_t)SvUV(b)); mpfr_set_z(*mpfr_t_obj, z, __gmpfr_default_rounding_mode); mpz_clear(z); return obj_ref; } SV * _overload_lshift_eq(pTHX_ SV * a, SV * b, SV * third) { /* b will be +ve ... otherwise overload_rshift_eq would have been called. */ #if IVSIZE > LONGSIZE if( SvUV(b) > (unsigned long) SvUV(b) ) croak ("In Math::MPFR overloading of '<<=' operator, the 'shift' operand overflows 'long int'"); #endif SvREFCNT_inc(a); mpfr_trunc(*(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(a))))); mpfr_mul_2ui(*(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), (unsigned long)SvUV(b), __gmpfr_default_rounding_mode); return a; } SV * _overload_rshift_eq(pTHX_ SV * a, SV * b, SV * third) { /* b will be +ve ... otherwise overload_lshift_eq would have been called. */ mpz_t z; #if IVSIZE > LONGSIZE if( SvUV(b) > (mp_bitcnt_t) SvUV(b) ) croak ("In Math::MPFR overloading of '>>=' operator, the 'shift' operand overflows 'long int'"); #endif SvREFCNT_inc(a); if( mpfr_nan_p( *(INT2PTR(mpfr_t *, SvIVX(SvRV(a))))) || mpfr_inf_p( *(INT2PTR(mpfr_t *, SvIVX(SvRV(a))))) ) return a; mpz_init(z); mpfr_get_z(z, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), GMP_RNDZ); /* Truncate *a */ mpz_div_2exp(z, z, (mp_bitcnt_t)SvUV(b)); mpfr_set_z(*(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), z, __gmpfr_default_rounding_mode); mpz_clear(z); return a; } SV * _wrap_count(pTHX) { return newSVuv(PL_sv_count); } SV * Rmpfr_set_LD(pTHX_ mpfr_t * rop, SV * op, SV *rnd) { if(sv_isobject(op)) { const char* h = HvNAME(SvSTASH(SvRV(op))); if(strEQ(h, "Math::LongDouble")) { return newSViv(mpfr_set_ld(*rop, *(INT2PTR(long double *, SvIVX(SvRV(op)))), (mpfr_rnd_t)SvUV(rnd))); } croak("2nd arg (a %s object) supplied to Rmpfr_set_LD needs to be a Math::LongDouble object", HvNAME(SvSTASH(SvRV(op)))); } else croak("2nd arg (which needs to be a Math::LongDouble object) supplied to Rmpfr_set_LD is not an object"); } /* int mpfr_set_decimal64 (mpfr_t rop, _Decimal64 op, mpfr_rnd_t rnd) */ SV * Rmpfr_set_DECIMAL64(pTHX_ mpfr_t * rop, SV * op, SV * rnd) { #if (!defined(MPFR_VERSION) || (MPFR_VERSION= MPFR_VERSION_NUM(3,1,0) if( mpfr_buildopt_decimal_p() ) { warn("To make Rmpfr_set_DECIMAL64 available, rebuild Math::MPFR and pass \"D64=1\" as an arg to the Makefile.PL\n"); croak("See \"PASSING _Decimal64 & _Decimal128 VALUES\" in the Math::MPFR documentation"); } # endif croak("Both MPFR_WANT_DECIMAL_FLOATS and MPFR_WANT_DECIMAL64 need to have been defined when building Math::MPFR - see \"PASSING _Decimal64 & _Decimal128 VALUES\" in the Math::MPFR documentation"); #endif } /********************************************** **********************************************/ SV * Rmpfr_set_DECIMAL128(pTHX_ mpfr_t * rop, SV * op, SV * rnd) { #if (!defined(MPFR_VERSION) || (MPFR_VERSION= MPFR_VERSION_NUM(4,1,0) if( mpfr_buildopt_decimal_p() ) { warn("To make Rmpfr_set_DECIMAL128 available, rebuild Math::MPFR and pass \"D128=1\" as separate args to the Makefile.PL\n"); croak("See \"PASSING _Decimal64 & _Decimal128 VALUES\" in the Math::MPFR documentation"); } # endif croak("Both MPFR_WANT_DECIMAL_FLOATS and MPFR_WANT_DECIMAL128 need to have been defined when building Math::MPFR"); #endif } /********************************************** **********************************************/ void Rmpfr_get_LD(pTHX_ SV * rop, mpfr_t * op, SV * rnd) { if(sv_isobject(rop)) { const char* h = HvNAME(SvSTASH(SvRV(rop))); if(strEQ(h, "Math::LongDouble")) { *(INT2PTR(long double *, SvIVX(SvRV(rop)))) = mpfr_get_ld(*op, (mpfr_rnd_t)SvUV(rnd)); } else croak("1st arg (a %s object) supplied to Rmpfr_get_LD needs to be a Math::LongDouble object", HvNAME(SvSTASH(SvRV(rop)))); } else { PERL_UNUSED_ARG2(op, rnd); croak("1st arg (which needs to be a Math::LongDouble object) supplied to Rmpfr_get_LD is not an object"); } } /********************************************** **********************************************/ void Rmpfr_get_DECIMAL64(pTHX_ SV * rop, mpfr_t * op, SV * rnd) { #if (!defined(MPFR_VERSION) || (MPFR_VERSION= MPFR_VERSION_NUM(3,1,0) if( mpfr_buildopt_decimal_p() ) { warn("To make Rmpfr_get_DECIMAL64 available, rebuild Math::MPFR and pass \"D64=1\" as an arg to the Makefile.PL\n"); croak("See \"PASSING _Decimal64 & _Decimal128 VALUES\" in the Math::MPFR documentation"); } # endif croak("Both MPFR_WANT_DECIMAL_FLOATS and MPFR_WANT_DECIMAL64 need to have been defined when building Math::MPFR"); #endif } /********************************************** **********************************************/ void Rmpfr_get_DECIMAL128(pTHX_ SV * rop, mpfr_t * op, SV * rnd) { #if (!defined(MPFR_VERSION) || (MPFR_VERSION= MPFR_VERSION_NUM(4,1,0) if( mpfr_buildopt_decimal_p() ) { warn("To make Rmpfr_get_DECIMAL128 available, rebuild Math::MPFR and pass \"D128=1\" as an arg to the Makefile.PL\n"); croak("See \"PASSING _Decimal64 & _Decimal128 VALUES\" in the Math::MPFR documentation"); } # endif croak("Both MPFR_WANT_DECIMAL_FLOATS and MPFR_WANT_DECIMAL128 need to have been defined when building Math::MPFR"); #endif } /********************************************** **********************************************/ int _MPFR_WANT_DECIMAL_FLOATS(void) { #ifdef MPFR_WANT_DECIMAL_FLOATS return 1; #else return 0; #endif } int _MPFR_WANT_DECIMAL64(void) { #ifdef MPFR_WANT_DECIMAL64 return 1; #else return 0; #endif } int _MPFR_WANT_DECIMAL128(void) { #ifdef MPFR_WANT_DECIMAL128 return 1; #else return 0; #endif } int _MPFR_WANT_FLOAT128(void) { #ifdef MPFR_WANT_FLOAT128 return 1; #else return 0; #endif } SV * _max_base(pTHX) { return newSViv(62); } SV * _isobject(pTHX_ SV * x) { if(sv_isobject(x))return newSVuv(1); return newSVuv(0); } void _mp_sizes(void) { dTHX; dXSARGS; PERL_UNUSED_ARG(items); XPUSHs(sv_2mortal(newSVuv(sizeof(mpfr_exp_t)))); XPUSHs(sv_2mortal(newSVuv(sizeof(mpfr_prec_t)))); XPUSHs(sv_2mortal(newSVuv(sizeof(mpfr_rnd_t)))); XSRETURN(3); } SV * _ivsize(pTHX) { return newSVuv(sizeof(IV)); } SV * _nvsize(pTHX) { return newSVuv(sizeof(NV)); } SV * _FLT128_DIG(pTHX) { #ifdef FLT128_DIG return newSViv(FLT128_DIG); #else return &PL_sv_undef; #endif } SV * _LDBL_DIG(pTHX) { #ifdef LDBL_DIG return newSViv(LDBL_DIG); #else return &PL_sv_undef; #endif } SV * _DBL_DIG(pTHX) { #ifdef DBL_DIG return newSViv(DBL_DIG); #else return &PL_sv_undef; #endif } SV * _FLT128_MANT_DIG(pTHX) { #ifdef FLT128_MANT_DIG return newSViv(FLT128_MANT_DIG); #else return &PL_sv_undef; #endif } SV * _LDBL_MANT_DIG(pTHX) { #ifdef LDBL_MANT_DIG return newSViv(LDBL_MANT_DIG); #else return &PL_sv_undef; #endif } SV * _DBL_MANT_DIG(pTHX) { #ifdef DBL_MANT_DIG return newSViv(DBL_MANT_DIG); #else return &PL_sv_undef; #endif } /*/////////////////////////////////////////// ////////////////////////////////////////////*/ /* All randinit functions now moved to Math::MPFR::Random */ /* */ /*********************************************** ************************************************/ SV * Rmpfr_get_float128(pTHX_ mpfr_t * op, SV * rnd) { #ifdef CAN_PASS_FLOAT128 return newSVnv(mpfr_get_float128(*op, (mpfr_rnd_t)SvUV(rnd))); #else # if MPFR_VERSION_MAJOR >= 4 if(mpfr_buildopt_float128_p()) { warn("To make Rmpfr_get_float128 available, rebuild Math::MPFR and pass \"F128=1\" as an arg to the Makefile.PL\n"); croak("See \"PASSING __float128 VALUES\" in the Math::MPFR documentation"); } # endif PERL_UNUSED_ARG2(op, rnd); croak("Cannot use Rmpfr_get_float128 to return an NV - see \"PASSING __float128 VALUES\" in the Math::MPFR documentation"); #endif } void Rmpfr_get_FLOAT128(pTHX_ SV * rop, mpfr_t * op, SV * rnd) { #if (!defined(MPFR_VERSION) || (MPFR_VERSION < MPFR_VERSION_NUM(4,0,0))) croak("Perl interface to Rmpfr_get_FLOAT128 not available for this version (%s) of the mpfr library. We need at least version 4.0.0", MPFR_VERSION_STRING); #endif /* MPFR_WANT_FLOAT128 needs to have been defined prior to inclusion of mpfr.h - this is done by defining it at the 'Makefile.PL' step - see the Makefile.PL */ #ifdef MPFR_WANT_FLOAT128 if(sv_isobject(rop)) { const char* h = HvNAME(SvSTASH(SvRV(rop))); if(strEQ(h, "Math::Float128")) *(INT2PTR(float128 *, SvIVX(SvRV(rop)))) = mpfr_get_float128(*op, (mpfr_rnd_t)SvUV(rnd)); else croak("1st arg (a %s object) supplied to Rmpfr_get_FLOAT128 needs to be a Math::Float128 object", HvNAME(SvSTASH(SvRV(rop)))); } else croak("1st arg (which needs to be a Math::Float128 object) supplied to Rmpfr_get_FLOAT128 is not an object"); #else # if MPFR_VERSION_MAJOR >= 4 if(mpfr_buildopt_float128_p()) { warn("To make Rmpfr_get_FLOAT128 available, rebuild Math::MPFR and pass \"F128=1\" as an arg to the Makefile.PL\n"); croak("See \"PASSING __float128 VALUES\" in the Math::MPFR documentation"); } # endif croak("MPFR_WANT_FLOAT128 needs to have been defined when building Math::MPFR - - see \"PASSING __float128 VALUES\" in the Math::MPFR documentation"); #endif } SV * Rmpfr_set_FLOAT128(pTHX_ mpfr_t * rop, SV * op, SV * rnd) { #if (!defined(MPFR_VERSION) || (MPFR_VERSION < MPFR_VERSION_NUM(4,0,0))) PERL_UNUSED_ARG3(rop, op, rnd); croak("Perl interface to Rmpfr_set_FLOAT128 not available for this version (%s) of the mpfr library. We need at least version 4.0.0", MPFR_VERSION_STRING); #endif /* MPFR_WANT_FLOAT128 needs to have been defined prior to inclusion of mpfr.h - this is done by defining it at the 'Makefile.PL' step - see the Makefile.PL */ #ifdef MPFR_WANT_FLOAT128 if(sv_isobject(op)) { const char* h = HvNAME(SvSTASH(SvRV(op))); if(strEQ(h, "Math::Float128")) return newSViv(mpfr_set_float128(*rop, *(INT2PTR(float128 *, SvIVX(SvRV(op)))), (mpfr_rnd_t)SvUV(rnd))); croak("2nd arg (a %s object) supplied to Rmpfr_set_FLOAT128 needs to be a Math::Float128 object", HvNAME(SvSTASH(SvRV(op)))); } else croak("2nd arg (which needs to be a Math::Float128 object) supplied to Rmpfr_set_FLOAT128 is not an object"); #else # if MPFR_VERSION_MAJOR >= 4 if(mpfr_buildopt_float128_p()) { warn("To make Rmpfr_set_FLOAT128 available, rebuild Math::MPFR and pass \"F128=1\" as an arg to the Makefile.PL\n"); croak("See \"PASSING __float128 VALUES\" in the Math::MPFR documentation"); } # endif croak("MPFR_WANT_FLOAT128 needs to have been defined when building Math::MPFR - see \"PASSING __float128 VALUES\" in the Math::MPFR documentation"); #endif } SV * Rmpfr_set_float128(pTHX_ mpfr_t * rop, SV * q, SV * rnd) { #ifdef CAN_PASS_FLOAT128 return newSViv(mpfr_set_float128(*rop, (float128)SvNV(q), (mpfr_rnd_t)SvUV(rnd))); #else # if MPFR_VERSION_MAJOR >= 4 if(mpfr_buildopt_float128_p()) { warn("To make Rmpfr_set_float128 available, rebuild Math::MPFR and pass \"F128=1\" as an arg to the Makefile.PL\n"); croak("See \"PASSING __float128 VALUES\" in the Math::MPFR documentation"); } # endif PERL_UNUSED_ARG3(rop, q, rnd); croak("Cannot use Rmpfr_set_float128 to set an NV - see \"PASSING __float128 VALUES\" in the Math::MPFR documentation"); #endif } void Rmpfr_init_set_float128(pTHX_ SV * q, SV * round) { #ifdef CAN_PASS_FLOAT128 dXSARGS; mpfr_t * mpfr_t_obj; SV * obj_ref, * obj; int ret; PERL_UNUSED_ARG(items); CHECK_ROUNDING_VALUE NEW_MATH_MPFR_OBJECT("Math::MPFR",Rmpfr_init_set_float128) /* defined in math_mpfr_include.h */ mpfr_init(*mpfr_t_obj); sv_setiv(obj, INT2PTR(IV,mpfr_t_obj)); ret = mpfr_set_float128(*mpfr_t_obj, SvNV(q), (mpfr_rnd_t)SvUV(round)); SvREADONLY_on(obj); RETURN_STACK_2 /*defined in math_mpfr_include.h */ #else PERL_UNUSED_ARG2(q, round); croak("Cannot use Rmpfr_init_set_float128 to set an NV - see \"PASSING __float128 VALUES\" in the Math::MPFR documentation"); #endif } void Rmpfr_init_set_float128_nobless(pTHX_ SV * q, SV * round) { #ifdef CAN_PASS_FLOAT128 dXSARGS; mpfr_t * mpfr_t_obj; SV * obj_ref, * obj; int ret; PERL_UNUSED_ARG(items); CHECK_ROUNDING_VALUE NEW_MATH_MPFR_OBJECT("NULL",Rmpfr_init_set_float128_nobless) /* defined in math_mpfr_include.h */ mpfr_init(*mpfr_t_obj); sv_setiv(obj, INT2PTR(IV,mpfr_t_obj)); ret = mpfr_set_float128(*mpfr_t_obj, SvNV(q), (mpfr_rnd_t)SvUV(round)); SvREADONLY_on(obj); RETURN_STACK_2 /*defined in math_mpfr_include.h */ #else PERL_UNUSED_ARG2(q, round); croak("Cannot use Rmpfr_init_set_float128_nobless to set an NV - see \"PASSING __float128 VALUES\" in the Math::MPFR documentation"); #endif } SV * _is_readonly(pTHX_ SV * sv) { if SvREADONLY(sv) return newSVuv(1); return newSVuv(0); } void _readonly_on(pTHX_ SV * sv) { SvREADONLY_on(sv); } void _readonly_off(pTHX_ SV * sv) { SvREADONLY_off(sv); } /* Do not remove _can_pass_float128 - it's used by the Math::MPFI Makefile.PL */ int _can_pass_float128(void) { #ifdef CAN_PASS_FLOAT128 return 1; #else return 0; #endif } int _mpfr_want_float128(void) { #ifdef MPFR_WANT_FLOAT128 return 1; #else return 0; #endif } int nnumflag(void) { return nnum; } int nok_pokflag(void) { return nok_pok; } void clear_nnum(void) { nnum = 0; } void clear_nok_pok(void){ nok_pok = 0; } void set_nnum(int x) { nnum = x; } void set_nok_pok(int x) { nok_pok = x; } SV * _d_bytes(pTHX_ SV * str) { /* Assumes 64-bit double (53-bit precision mantissa) * * Assumes also that the arg is a PV. * * Assumptions are not checked because the function * * is private. * * Corrected to handle subnormal values in 4.02 */ mpfr_t temp; double d; mpfr_prec_t emin; SV * sv; #if !defined(MPFR_VERSION) || MPFR_VERSION <= 196869 /* avoid mpfr_subnormalize */ int signbit; mpfr_t temp2, DENORM_MIN; #else int inex; mpfr_prec_t emax; #endif mpfr_init2(temp, DBL_MANT_DIG); #if defined(MPFR_VERSION) && MPFR_VERSION > 196869 /* use mpfr_subnormalize */ emin = mpfr_get_emin(); emax = mpfr_get_emax(); mpfr_set_emin(-1073); mpfr_set_emax(1024); inex = mpfr_strtofr(temp, SvPV_nolen(str), NULL, 0, GMP_RNDN); mpfr_subnormalize(temp, inex, GMP_RNDN); mpfr_set_emin(emin); mpfr_set_emax(emax); d = mpfr_get_d(temp, GMP_RNDN); #else /* mpfr_strtofr can return incorrect inex in 3.1.5 and * * earlier - which renders mpfr_subnormalize unreliable */ mpfr_strtofr(temp, SvPV_nolen(str), NULL, 0, GMP_RNDN); emin = mpfr_get_exp(temp) + 1074; signbit = mpfr_signbit(temp) ? -1 : 1; if(emin <= 1) { if(emin < 0) { d = 0.0 *signbit; } else { if(emin == 0) { mpfr_init2(temp2, 2); mpfr_set_ui(temp2, 2, GMP_RNDN); mpfr_div_2ui(temp2, temp2, 1076, GMP_RNDN); mpfr_abs(temp, temp, GMP_RNDN); if(mpfr_cmp(temp, temp2) > 0) { mpfr_mul_2ui(temp2, temp2, 1, GMP_RNDN); d = mpfr_get_d(temp2, GMP_RNDN); mpfr_clear(temp2); } else { d = 0.0; } d *= signbit; } else { /* emin == 1 *//* Can't set precision to 1 with older versions of mpfr */ mpfr_abs(temp, temp, GMP_RNDN); mpfr_init2(temp2, 2); mpfr_init2(DENORM_MIN, 2); mpfr_set_ui(DENORM_MIN, 2, GMP_RNDN); mpfr_div_2ui(DENORM_MIN, DENORM_MIN, 1075, GMP_RNDN); mpfr_set(temp2, DENORM_MIN, GMP_RNDN); mpfr_div_ui(temp2, temp2, 2, GMP_RNDN); mpfr_add(temp2, temp2, DENORM_MIN, GMP_RNDN); if(mpfr_cmp(temp, temp2) >= 0) mpfr_mul_si(temp, DENORM_MIN, 2 * signbit, GMP_RNDN); else mpfr_mul_si(temp, temp, signbit, GMP_RNDN); mpfr_clear(temp2); mpfr_clear(DENORM_MIN); d = mpfr_get_d(temp, GMP_RNDN); } } } /* close "if(emin <= 1)" */ else { if(emin < 53) { mpfr_set_prec(temp, emin); mpfr_strtofr(temp, SvPV_nolen(str), NULL, 0, GMP_RNDN); } d = mpfr_get_d(temp, GMP_RNDN); } /* close "else" */ #endif mpfr_clear(temp); sv = NEWSV(0, 8); sv_setpvn(sv, (char *) &d, 8); return sv; } SV * _bytes_fr(pTHX_ mpfr_t * str, unsigned long bits) { /* Explicit Calls to mpfr_subnormalize() are unnecessary */ SV * sv; double msd, lsd; long double ld; mpfr_t temp; #ifdef MPFR_WANT_FLOAT128 float128 f128; #endif if(mpfr_get_prec(*str) != (mpfr_prec_t)bits) croak("Precision of 1st arg supplied to _bytes_fr != 2nd arg (%d)", (int)bits ); if(bits == 53) { msd = mpfr_get_d(*str, GMP_RNDN); sv = NEWSV(0, 8); sv_setpvn(sv, (char *) &msd, 8); return sv; } if(bits == 64) { # if LDBL_MANT_DIG != 64 croak("Byte structure of 10-byte long double not provided for this architecture"); # endif ld = mpfr_get_ld(*str, GMP_RNDN); sv = NEWSV(0, 10); sv_setpvn(sv, (char *) &ld, 10); return sv; } if(bits == 2098) { mpfr_init2(temp, 2098); mpfr_set(temp, *str, GMP_RNDN); /* Avoid altering the value held by *str */ msd = mpfr_get_d(temp, GMP_RNDN); if(msd == 0 || msd != msd || msd / msd != 1) { /* zero, nan or inf */ lsd = 0.0; } else { mpfr_sub_d(temp, temp, msd, GMP_RNDN); lsd = mpfr_get_d(temp, GMP_RNDN); } mpfr_clear(temp); sv = NEWSV(0, 16); /* Work around sneaky DoubleDouble gotcha */ if( (msd == DBL_MAX && lsd == pow(2.0, 970.0)) || (msd == -DBL_MAX && lsd == -(pow(2.0, 970.0))) ) { msd += lsd; /* set msd to infinity */ lsd = 0.0; /* set lsd to zero */ } # ifdef MPFR_HAVE_BENDIAN sv_setpvn(sv, (char *) &msd, 8); sv_catpvn(sv, (char *) &lsd, 8); # else sv_setpvn(sv, (char *) &lsd, 8); sv_catpvn(sv, (char *) &msd, 8); # endif return sv; } if(bits == 113) { # if !defined(MPFR_WANT_FLOAT128) && LDBL_MANT_DIG != 113 croak("Byte structure of 113-bit NV types not provided for this architecture and mpfr configuration"); #endif sv = NEWSV(0, 16); # if defined(MPFR_WANT_FLOAT128) f128 = mpfr_get_float128(*str, GMP_RNDN); sv_setpvn(sv, (char *) &f128, 16); return sv; # endif ld = mpfr_get_ld(*str, GMP_RNDN); sv_setpvn(sv, (char *) &ld, 16); return sv; } croak("Invalid value (%u) provided as 2nd argument to internal _bytes_fr XSub", (int)bits); } SV * _dd_bytes(pTHX_ SV * str) { /* Assumes 128-bit long double (106-bit precision mantissa) * * Assumes also that the arg is a PV. * * Assumptions are not checked because the function * * is private. */ mpfr_t temp; double msd, lsd; SV * sv; mpfr_init2(temp, 2098); mpfr_set_str(temp, SvPV_nolen(str), 0, GMP_RNDN); msd = mpfr_get_d(temp, GMP_RNDN); if(msd == 0 || msd != msd || msd / msd != 1) { /* zero, nan or inf */ lsd = 0.0; } else { mpfr_sub_d(temp, temp, msd, GMP_RNDN); lsd = mpfr_get_d(temp, GMP_RNDN); } mpfr_clear(temp); sv = NEWSV(0, 16); /* Work around sneaky DoubleDouble gotcha */ if( (msd == DBL_MAX && lsd == pow(2.0, 970.0)) || (msd == -DBL_MAX && lsd == -(pow(2.0, 970.0))) ) { msd += lsd; /* set msd to infinity */ lsd = 0.0; /* set lsd to zero */ } #ifdef MPFR_HAVE_BENDIAN sv_setpvn(sv, (char *) &msd, 8); sv_catpvn(sv, (char *) &lsd, 8); #else sv_setpvn(sv, (char *) &lsd, 8); sv_catpvn(sv, (char *) &msd, 8); #endif return sv; } SV * _ld_bytes(pTHX_ SV * str) { /* Assumes 10-byte long double (64-bit precision mantissa) * * 53-bit long doubles are handled by _d_bytes. * * 113-bit long doubles are handled by _f128_bytes - but * * only if LDBL_MANT_DIG == 113 or MPFR_WANT_FLOAT128 is * * is defined. * * Assumes also that the arg is a PV. * * Assumptions are not checked because the function * * is private and should have already been checked. * * Corrected to handle subnormal values in 4.02 */ #if LDBL_MANT_DIG != 64 croak("Byte structure of 10-byte long double not provided for this architecture"); #else mpfr_t temp; long double ld; mpfr_prec_t emin, emax; SV * sv; # if !defined(MPFR_VERSION) || MPFR_VERSION <= 196869 /* avoid mpfr_subnormalize */ int signbit; mpfr_t temp2, DENORM_MIN; # else int inex; # endif mpfr_init2(temp, 64); # if defined(MPFR_VERSION) && MPFR_VERSION > 196869 /* use mpfr_subnormalize */ emin = mpfr_get_emin(); emax = mpfr_get_emax(); mpfr_set_emin(-16444); mpfr_set_emax(16384); inex = mpfr_strtofr(temp, SvPV_nolen(str), NULL, 0, GMP_RNDN); mpfr_subnormalize(temp, inex, GMP_RNDN); mpfr_set_emin(emin); mpfr_set_emax(emax); ld = mpfr_get_ld(temp, GMP_RNDN); # else /* mpfr_strtofr can return incorrect inex in 3.1.5 and * * earlier - which renders mpfr_subnormalize unreliable */ mpfr_strtofr(temp, SvPV_nolen(str), NULL, 0, GMP_RNDN); emax = 16445; emin = mpfr_get_exp(temp) + 16445; /* mpfr_get_ld is buggy for extended precision subnormal * * values with 3.1.4 and earlier. Hence, croak when this * * condition exists (ie when LD_SUBNORMAL_BUG is dsefined.) */ # ifdef LD_SUBNORMAL_BUG if(mpfr_regular_p(temp) && emin >= 0 && emin < 64) { warn("\n mpfr_get_ld is buggy (subnormal values only)\n for this version (%s) of the MPFR library\n", MPFR_VERSION_STRING); croak(" Version 3.1.5 or later is required"); } # endif signbit = mpfr_signbit(temp) ? -1 : 1; if(emin <= 1) { if(emin < 0) { ld = 0.0L; ld *= signbit; } else { if(emin == 0) { mpfr_init2(temp2, 2); mpfr_set_ui(temp2, 2, GMP_RNDN); mpfr_div_2ui(temp2, temp2, emax + 2, GMP_RNDN); mpfr_abs(temp, temp, GMP_RNDN); if(mpfr_cmp(temp, temp2) > 0) { mpfr_mul_2ui(temp2, temp2, 1, GMP_RNDN); ld = mpfr_get_ld(temp2, GMP_RNDN); mpfr_clear(temp2); } else { ld = 0.0L; } ld *= signbit; } else { /* emin == 1 *//* Can't set precision to 1 with older versions of mpfr */ mpfr_abs(temp, temp, GMP_RNDN); mpfr_init2(temp2, 2); mpfr_init2(DENORM_MIN, 2); mpfr_set_ui(DENORM_MIN, 2, GMP_RNDN); mpfr_div_2ui(DENORM_MIN, DENORM_MIN, emax + 1, GMP_RNDN); mpfr_set(temp2, DENORM_MIN, GMP_RNDN); mpfr_div_ui(temp2, temp2, 2, GMP_RNDN); mpfr_add(temp2, temp2, DENORM_MIN, GMP_RNDN); if(mpfr_cmp(temp, temp2) >= 0) mpfr_mul_si(temp, DENORM_MIN, 2 * signbit, GMP_RNDN); else mpfr_mul_si(temp, temp, signbit, GMP_RNDN); mpfr_clear(temp2); mpfr_clear(DENORM_MIN); ld = mpfr_get_ld(temp, GMP_RNDN); } } } /* close "if(emin <= 1)" */ else { if(emin < 64) { mpfr_set_prec(temp, emin); mpfr_strtofr(temp, SvPV_nolen(str), NULL, 0, GMP_RNDN); } ld = mpfr_get_ld(temp, GMP_RNDN); } # endif mpfr_clear(temp); sv = NEWSV(0, 10); sv_setpvn(sv, (char *) &ld, 10); return sv; #endif } SV * _f128_bytes(pTHX_ SV * str) { /* Assumes 113-bit NV (either long double or __float128). * * Assumes also that the arg is a Math::MPFR object. * * Assumptions are not checked because the function * * is private and should have already been checked. * * Corrected to handle subnormal values in 4.02 */ #if !defined(MPFR_WANT_FLOAT128) && LDBL_MANT_DIG != 113 croak("Byte structure of 113-bit NV types not provided for this architecture and mpfr configuration"); #else mpfr_t temp; # if defined(MPFR_WANT_FLOAT128) float128 f128; # else long double f128; # endif mpfr_prec_t emin; SV * sv; # if !defined(MPFR_VERSION) || MPFR_VERSION <= 196869 /* avoid mpfr_subnormalize */ int signbit; mpfr_t temp2, DENORM_MIN; # else int inex; mpfr_prec_t emax; # endif mpfr_init2(temp, 113); # if defined(MPFR_VERSION) && MPFR_VERSION > 196869 /* use mpfr_subnormalize */ emin = mpfr_get_emin(); emax = mpfr_get_emax(); mpfr_set_emin(-16493); mpfr_set_emax(16384); inex = mpfr_strtofr(temp, SvPV_nolen(str), NULL, 0, GMP_RNDN); mpfr_subnormalize(temp, inex, GMP_RNDN); mpfr_set_emin(emin); mpfr_set_emax(emax); # if defined(MPFR_WANT_FLOAT128) f128 = mpfr_get_float128(temp, GMP_RNDN); # else f128 = mpfr_get_ld(temp, GMP_RNDN); # endif # else /* mpfr_strtofr can return incorrect inex in 3.1.5 and * * earlier - which renders mpfr_subnormalize unreliable */ mpfr_strtofr(temp, SvPV_nolen(str), NULL, 0, GMP_RNDN); emin = mpfr_get_exp(temp) + 16494; signbit = mpfr_signbit(temp) ? -1 : 1; if(emin < 1) { if(emin < 0) { ld = 0.0Q; ld *= signbit; } else { if(emin == 0) { mpfr_init2(temp2, 2); mpfr_set_ui(temp2, 2, GMP_RNDN); mpfr_div_2ui(temp2, temp2, 16496, GMP_RNDN); mpfr_abs(temp, temp, GMP_RNDN); if(mpfr_cmp(temp, temp2) > 0) { mpfr_mul_2ui(temp2, temp2, 1, GMP_RNDN); ld = mpfr_get_float128(temp2, GMP_RNDN); mpfr_clear(temp2); } else { ld = 0.0Q; } ld *= signbit; } else { /* emin == 1 *//* Can't set precision to 1 with older versions of mpfr */ mpfr_abs(temp, temp, GMP_RNDN); mpfr_init2(temp2, 2); mpfr_init2(DENORM_MIN, 2); mpfr_set_ui(DENORM_MIN, 2, GMP_RNDN); mpfr_div_2ui(DENORM_MIN, DENORM_MIN, 16495, GMP_RNDN); mpfr_set(temp2, DENORM_MIN, GMP_RNDN); mpfr_div_ui(temp2, temp2, 2, GMP_RNDN); mpfr_add(temp2, temp2, DENORM_MIN, GMP_RNDN); if(mpfr_cmp(temp, temp2) >= 0) mpfr_mul_si(temp, DENORM_MIN, 2 * signbit, GMP_RNDN); else mpfr_mul_si(temp, temp, signbit, GMP_RNDN); mpfr_clear(temp2); mpfr_clear(DENORM_MIN); f128 = mpfr_get_float128(temp, GMP_RNDN); } } } /* close "if(emin <= 1)" */ else { if(emin < 113) { mpfr_set_prec(temp, emin); mpfr_strtofr(temp, SvPV_nolen(str), NULL, 0, GMP_RNDN); } # if defined(MPFR_WANT_FLOAT128) f128 = mpfr_get_float128(temp, GMP_RNDN); # else f128 = mpfr_get_ld(temp, GMP_RNDN); # endif } /* close "else" */ # endif mpfr_clear(temp); sv = NEWSV(0, 16); sv_setpvn(sv, (char *) &f128, 16); return sv; #endif } int _required_ldbl_mant_dig(void) { return REQUIRED_LDBL_MANT_DIG; } SV * _GMP_LIMB_BITS(pTHX) { #ifdef GMP_LIMB_BITS return newSVuv(GMP_LIMB_BITS); #else return &PL_sv_undef; #endif } SV * _GMP_NAIL_BITS(pTHX) { #ifdef GMP_NAIL_BITS return newSVuv(GMP_NAIL_BITS); #else return &PL_sv_undef; #endif } /* New in 3.2.0 */ void Rmpfr_fmodquo(pTHX_ mpfr_t * a, mpfr_t * b, mpfr_t * c, SV * round) { #if defined(MPFR_VERSION) && MPFR_VERSION >= MPFR_VERSION_NUM(4,0,0) dXSARGS; long ret, q; PERL_UNUSED_ARG(items); ret = mpfr_fmodquo(*a, &q, *b, *c, (mpfr_rnd_t)SvUV(round)); ST(0) = sv_2mortal(newSViv(q)); ST(1) = sv_2mortal(newSViv(ret)); XSRETURN(2); #else PERL_UNUSED_ARG4(a, b, c, round); croak("Rmpfr_fmodquo not implemented - need at least mpfr-4.0.0, have only %s", MPFR_VERSION_STRING); #endif } int Rmpfr_fpif_export(pTHX_ FILE * stream, mpfr_t * op) { #if defined(MPFR_VERSION) && MPFR_VERSION >= MPFR_VERSION_NUM(4,0,0) int ret = mpfr_fpif_export(stream, *op); fflush(stream); return ret; #else croak("Rmpfr_fpif_export not implemented - need at least mpfr-4.0.0, have only %s", MPFR_VERSION_STRING); #endif } int Rmpfr_fpif_import(pTHX_ mpfr_t * op, FILE * stream) { #if defined(MPFR_VERSION) && MPFR_VERSION >= MPFR_VERSION_NUM(4,0,0) int ret = mpfr_fpif_import(*op, stream); fflush(stream); return ret; #else PERL_UNUSED_ARG2(op, stream); croak("Rmpfr_fpif_import not implemented - need at least mpfr-4.0.0, have only %s", MPFR_VERSION_STRING); #endif } void Rmpfr_flags_clear(unsigned int mask) { #if defined(MPFR_VERSION) && MPFR_VERSION >= MPFR_VERSION_NUM(4,0,0) mpfr_flags_clear((mpfr_flags_t) mask); #else PERL_UNUSED_ARG(mask); croak("Rmpfr_flags_clear not implemented - need at least mpfr-4.0.0, have only %s", MPFR_VERSION_STRING); #endif } void Rmpfr_flags_set(unsigned int mask) { #if defined(MPFR_VERSION) && MPFR_VERSION >= MPFR_VERSION_NUM(4,0,0) mpfr_flags_set((mpfr_flags_t) mask); #else PERL_UNUSED_ARG(mask); croak("Rmpfr_flags_set not implemented - need at least mpfr-4.0.0, have only %s", MPFR_VERSION_STRING); #endif } unsigned int Rmpfr_flags_test(unsigned int mask) { #if defined(MPFR_VERSION) && MPFR_VERSION >= MPFR_VERSION_NUM(4,0,0) mpfr_flags_t ret = mpfr_flags_test((mpfr_flags_t) mask); return (unsigned int)ret; #else PERL_UNUSED_ARG(mask); croak("Rmpfr_flags_test not implemented - need at least mpfr-4.0.0, have only %s", MPFR_VERSION_STRING); #endif } unsigned int Rmpfr_flags_save(void) { #if defined(MPFR_VERSION) && MPFR_VERSION >= MPFR_VERSION_NUM(4,0,0) mpfr_flags_t ret = mpfr_flags_save(); return (unsigned int)ret; #else croak("Rmpfr_flags_save not implemented - need at least mpfr-4.0.0, have only %s", MPFR_VERSION_STRING); #endif } void Rmpfr_flags_restore(unsigned int flags, unsigned int mask) { #if defined(MPFR_VERSION) && MPFR_VERSION >= MPFR_VERSION_NUM(4,0,0) mpfr_flags_restore((mpfr_flags_t) flags, (mpfr_flags_t) mask); #else PERL_UNUSED_ARG2(flags, mask); croak("Rmpfr_flags_restore not implemented - need at least mpfr-4.0.0, have only %s", MPFR_VERSION_STRING); #endif } int Rmpfr_rint_roundeven(mpfr_t * rop, mpfr_t * op, int round) { #if defined(MPFR_VERSION) && MPFR_VERSION >= MPFR_VERSION_NUM(4,0,0) return(mpfr_rint_roundeven(*rop, *op, (mpfr_rnd_t)round)); #else PERL_UNUSED_ARG3(rop, op, round); croak("Rmpfr_rint_roundeven not implemented - need at least mpfr-4.0.0, have only %s", MPFR_VERSION_STRING); #endif } int Rmpfr_roundeven(mpfr_t * rop, mpfr_t * op) { #if defined(MPFR_VERSION) && MPFR_VERSION >= MPFR_VERSION_NUM(4,0,0) return(mpfr_roundeven(*rop, *op)); #else PERL_UNUSED_ARG2(rop, op); croak("Rmpfr_roundeven not implemented - need at least mpfr-4.0.0, have only %s", MPFR_VERSION_STRING); #endif } int Rmpfr_nrandom(mpfr_t * rop, gmp_randstate_t * state, int round) { #if defined(MPFR_VERSION) && MPFR_VERSION >= MPFR_VERSION_NUM(4,0,0) return(mpfr_nrandom(*rop, *state, (mpfr_rnd_t)round)); #else PERL_UNUSED_ARG3(rop, state, round); croak("Rmpfr_nrandom not implemented - need at least mpfr-4.0.0, have only %s", MPFR_VERSION_STRING); #endif } int Rmpfr_erandom(mpfr_t * rop, gmp_randstate_t * state, int round) { #if defined(MPFR_VERSION) && MPFR_VERSION >= MPFR_VERSION_NUM(4,0,0) return(mpfr_erandom(*rop, *state, (mpfr_rnd_t)round)); #else PERL_UNUSED_ARG3(rop, state, round); croak("Rmpfr_erandom not implemented - need at least mpfr-4.0.0, have only %s", MPFR_VERSION_STRING); #endif } int Rmpfr_fmma(mpfr_t * rop, mpfr_t * op1, mpfr_t * op2, mpfr_t * op3, mpfr_t * op4, int round) { #if defined(MPFR_VERSION) && MPFR_VERSION >= MPFR_VERSION_NUM(4,0,0) return(mpfr_fmma(*rop, *op1, *op2, *op3, *op4, (mpfr_rnd_t)round)); #else PERL_UNUSED_ARG6(rop, op1, op2, op3, op4, round); croak("Rmpfr_fmma not implemented - need at least mpfr-4.0.0, have only %s", MPFR_VERSION_STRING); #endif } int Rmpfr_fmms(mpfr_t * rop, mpfr_t * op1, mpfr_t * op2, mpfr_t * op3, mpfr_t * op4, int round) { #if defined(MPFR_VERSION) && MPFR_VERSION >= MPFR_VERSION_NUM(4,0,0) return(mpfr_fmms(*rop, *op1, *op2, *op3, *op4, (mpfr_rnd_t)round)); #else PERL_UNUSED_ARG6(rop, op1, op2, op3, op4, round); croak("Rmpfr_fmms not implemented - need at least mpfr-4.0.0, have only %s", MPFR_VERSION_STRING); #endif } int Rmpfr_log_ui(mpfr_t * rop, unsigned long op, int round) { #if defined(MPFR_VERSION) && MPFR_VERSION >= MPFR_VERSION_NUM(4,0,0) return(mpfr_log_ui(*rop, op, (mpfr_rnd_t)round)); #else PERL_UNUSED_ARG3(rop, op, round); croak("Rmpfr_log_ui not implemented - need at least mpfr-4.0.0, have only %s", MPFR_VERSION_STRING); #endif } int Rmpfr_gamma_inc(mpfr_t * rop, mpfr_t * op1, mpfr_t * op2, int round) { #if defined(MPFR_VERSION) && MPFR_VERSION >= MPFR_VERSION_NUM(4,0,0) return(mpfr_gamma_inc(*rop, *op1, *op2, (mpfr_rnd_t)round)); #else PERL_UNUSED_ARG4(rop, op1, op2, round); croak("Rmpfr_gamma_inc not implemented - need at least mpfr-4.0.0, have only %s", MPFR_VERSION_STRING); #endif } int _have_IEEE_754_long_double(void) { #if defined(HAVE_IEEE_754_LONG_DOUBLE) return 1; #else return 0; #endif } int _have_extended_precision_long_double(void) { #if defined(HAVE_EXTENDED_PRECISION_LONG_DOUBLE) return 1; #else return 0; #endif } int nanflag_bug(void) { #if !defined(MPFR_VERSION) || (defined(MPFR_VERSION) && MPFR_VERSION <= NANFLAG_BUG) return 1; #else return 0; #endif } SV * Rmpfr_buildopt_float128_p(pTHX) { #if MPFR_VERSION_MAJOR >= 4 return newSViv(mpfr_buildopt_float128_p()); #else croak("Rmpfr_buildopt_float128_p not implemented with this version of the mpfr library - we have %s but need at least 4.0.0", MPFR_VERSION_STRING); #endif } SV * Rmpfr_buildopt_sharedcache_p(pTHX) { #if MPFR_VERSION_MAJOR >= 4 return newSViv(mpfr_buildopt_sharedcache_p()); #else croak("Rmpfr_buildopt_sharedcache_p not implemented with this version of the mpfr library - we have %s but need at least 4.0.0", MPFR_VERSION_STRING); #endif } int _nv_is_float128(void) { #if defined(USE_QUADMATH) return 1; #else return 0; #endif } int _SvNOK(pTHX_ SV * in) { if(SV_IS_NOK(in)) return 1; return 0; } int _SvPOK(pTHX_ SV * in) { if(SV_IS_POK(in)) return 1; return 0; } /* Expects to return either 0 or 1: */ int _get_bit(pTHX_ char * s, mpfr_prec_t p) { if(s[p] == '1') return 1; if(s[p] != '0') croak ("Invalid bit value in Math::MPFR::_get_bit"); return 0; } /* A function to return the least significant bit of the mantissa: */ SV * _lsb(pTHX_ mpfr_t * a) { char * buffer; mpfr_exp_t exponent; mpfr_prec_t p = mpfr_get_prec(*a); if(!mpfr_regular_p(*a)) { if(mpfr_nan_p(*a)) mpfr_set_nanflag(); return newSVuv(0); } Newxz(buffer, p + 2, char); if(buffer == NULL) croak("Failed to allocate memory in _lsb function"); mpfr_get_str(buffer, &exponent, 2, (size_t)p, *a, GMP_RNDN); if(!mpfr_signbit(*a)) p--; p = (mpfr_prec_t)_get_bit(aTHX_ buffer, p); Safefree(buffer); return newSVuv((UV)p); } int Rmpfr_rec_root(pTHX_ mpfr_t * rop, mpfr_t * op, unsigned long root, SV * round) { /* Originally supplied by Vincent Lefevre to mpfr mailing list. See https://sympa.inria.fr/sympa/arc/mpfr/2016-12/msg00032.html Sisyphus re-arranged it as an XSub and added handling of special cases (inf/nan/zero). Requires mpfr-3.1.0 or later. */ #if (MPFR_VERSION_MAJOR == 3 && MPFR_VERSION_MINOR >= 1) || MPFR_VERSION_MAJOR > 3 mpfr_prec_t p; mpfr_t t, u; int inex1, inex2 = -1, inex3= 1; CHECK_ROUNDING_VALUE if(root == 0) { mpfr_set_nan(*rop); mpfr_set_nanflag(); return 0; } /* At this point we know that "root" is greater than 0 */ if(mpfr_zero_p(*op)) { mpfr_set_divby0(); if(root % 2) { mpfr_set_inf(*rop, mpfr_signbit(*op) * -1); return 0; } mpfr_set_inf(*rop, 1); return 0; } /* and we now also know that op != 0 */ if(mpfr_signbit(*op) && root % 2 == 0) { mpfr_set_nan(*rop); mpfr_set_nanflag(); return 0; } /* All other special cases are handled correctly by the following code. This is all checked in t/Rmpfr_rec_root.t. (At least, that's the intention.) */ p = mpfr_get_prec(*rop); mpfr_init2(t, p); mpfr_init2(u, p); while( (inex2 != inex3 && inex2 * inex3 <= 0) || mpfr_cmp(*rop, u) ) { mpfr_set_prec(t, mpfr_get_prec(t) + 8); inex1 = mpfr_ui_div(t, 1, *op, GMP_RNDZ); # if defined(MPFR_VERSION) && MPFR_VERSION >= MPFR_VERSION_NUM(4,0,0) inex2 = mpfr_rootn_ui(*rop, t, root, (mpfr_rnd_t)SvUV(round)); # else inex2 = mpfr_root(*rop, t, root, (mpfr_rnd_t)SvUV(round)); # endif if(!inex1) return inex2; mpfr_nextabove(t); # if defined(MPFR_VERSION) && MPFR_VERSION >= MPFR_VERSION_NUM(4,0,0) inex3 = mpfr_rootn_ui(u, t, root, (mpfr_rnd_t)SvUV(round)); # else inex3 = mpfr_root(u, t, root, (mpfr_rnd_t)SvUV(round)); # endif } return inex2; #else PERL_UNUSED_ARG4(rop, op, root, round); croak("Rmpfr_set_divby0 not implemented with this version of the mpfr library - we have %s but need at least 3.1.0", MPFR_VERSION_STRING); #endif } int Rmpfr_beta(mpfr_t * rop, mpfr_t * op1, mpfr_t * op2, int round) { #if defined(MPFR_VERSION) && MPFR_VERSION >= MPFR_VERSION_NUM(4,0,0) return(mpfr_beta(*rop, *op1, *op2, (mpfr_rnd_t)round)); #else PERL_UNUSED_ARG4(rop, op1, op2, round); croak("Rmpfr_beta not implemented - need at least mpfr-4.0.0, have only %s", MPFR_VERSION_STRING); #endif } int Rmpfr_rootn_ui (mpfr_t * rop, mpfr_t * op, unsigned long k, int round) { #if defined(MPFR_VERSION) && MPFR_VERSION >= MPFR_VERSION_NUM(4,0,0) return(mpfr_rootn_ui(*rop, *op, k, (mpfr_rnd_t)round)); #else PERL_UNUSED_ARG4(rop, op, k, round); croak("Rmpfr_rec_root not implemented - need at least mpfr-4.0.0, have only %s", MPFR_VERSION_STRING); #endif } int _ld_subnormal_bug(void) { #if defined(LD_SUBNORMAL_BUG) return 1; #else return 0; #endif } /* * The atodouble function was written as a means to check that the atonv * function handles subnormal double-doubles correctly. * But it is readily available for any other purpose, too. * On a perl whose nvtype is double it should return the same value as atonv, * though atodouble is not as efficient as atonv. */ double atodouble(char * str) { #if defined(MPFR_VERSION) && MPFR_VERSION > 196869 mpfr_t workspace; mpfr_prec_t emin, emax; int inex; double d; mpfr_init2(workspace, 53); emin = mpfr_get_emin(); emax = mpfr_get_emax(); mpfr_set_emin(-1073); mpfr_set_emax(1024); inex = mpfr_strtofr(workspace, str, NULL, 0, GMP_RNDN); mpfr_subnormalize(workspace, inex, GMP_RNDN); mpfr_set_emin(emin); mpfr_set_emax(emax); d = mpfr_get_d(workspace, GMP_RNDN); mpfr_clear(workspace); return d; #else PERL_UNUSED_ARG(str); croak("The atodouble function requires mpfr-3.1.6 or later"); #endif } SV * atonv(pTHX_ SV * str) { #if defined(MPFR_VERSION) && MPFR_VERSION > 196869 mpfr_t workspace; # if NVSIZE == 8 || LDBL_MANT_DIG == 53 /* D */ mpfr_prec_t emin, emax; int inex; double ret; mpfr_init2(workspace, 53); emin = mpfr_get_emin(); emax = mpfr_get_emax(); mpfr_set_emin(-1073); mpfr_set_emax(1024); inex = mpfr_strtofr(workspace, SvPV_nolen(str), NULL, 0, GMP_RNDN); mpfr_subnormalize(workspace, inex, GMP_RNDN); mpfr_set_emin(emin); mpfr_set_emax(emax); ret = mpfr_get_d(workspace, GMP_RNDN); mpfr_clear(workspace); return newSVnv(ret); # endif /* close D */ # if defined(USE_LONG_DOUBLE) && LDBL_MANT_DIG != 53 /* LD */ # if REQUIRED_LDBL_MANT_DIG == 64 mpfr_prec_t emin, emax; int inex; long double ret; mpfr_init2(workspace, 64); emin = mpfr_get_emin(); emax = mpfr_get_emax(); mpfr_set_emin(-16444); mpfr_set_emax(16384); inex = mpfr_strtofr(workspace, SvPV_nolen(str), NULL, 0, GMP_RNDN); mpfr_subnormalize(workspace, inex, GMP_RNDN); mpfr_set_emin(emin); mpfr_set_emax(emax); ret = mpfr_get_ld(workspace, GMP_RNDN); mpfr_clear(workspace); return newSVnv(ret); # endif # if REQUIRED_LDBL_MANT_DIG == 113 mpfr_prec_t emin, emax; int inex; long double ret; mpfr_init2(workspace, 113); emin = mpfr_get_emin(); emax = mpfr_get_emax(); mpfr_set_emin(-16493); mpfr_set_emax(16384); inex = mpfr_strtofr(workspace, SvPV_nolen(str), NULL, 0, GMP_RNDN); mpfr_subnormalize(workspace, inex, GMP_RNDN); mpfr_set_emin(emin); mpfr_set_emax(emax); ret = mpfr_get_ld(workspace, GMP_RNDN); mpfr_clear(workspace); return newSVnv(ret); # endif # if REQUIRED_LDBL_MANT_DIG == 2098 mpfr_t dspace; double msd, lsd; /* 'most' and 'least' significant doubles */ mpfr_prec_t emin, emax; int inex; long double ret; mpfr_init2(workspace, 2098); mpfr_init2(dspace, 53); emin = mpfr_get_emin(); emax = mpfr_get_emax(); mpfr_set_emin(-1073); mpfr_set_emax(1024); inex = mpfr_strtofr(dspace, SvPV_nolen(str), NULL, 0, GMP_RNDN); mpfr_subnormalize(dspace, inex, GMP_RNDN); msd = mpfr_get_d(dspace, GMP_RNDN); if(!mpfr_regular_p(dspace)) { mpfr_clear(dspace); mpfr_set_emin(emin); /* restore to original value */ mpfr_set_emax(emax); /* restore to original value */ return newSVnv(msd); } mpfr_strtofr(workspace, SvPV_nolen(str), NULL, 0, GMP_RNDN); inex = mpfr_sub(dspace, workspace, dspace, GMP_RNDN); mpfr_subnormalize(dspace, inex, GMP_RNDN); lsd = mpfr_get_d(dspace, GMP_RNDN); mpfr_clear(dspace); mpfr_clear(workspace); mpfr_set_emin(emin); /* restore to original value */ mpfr_set_emax(emax); /* restore to original value */ return newSVnv((long double)msd + (long double)lsd); # endif # endif /* close LD */ # if defined(USE_QUADMATH) /* F128 */ # if defined(MPFR_WANT_FLOAT128) mpfr_prec_t emin, emax; int inex; __float128 ret; mpfr_init2(workspace, 113); emin = mpfr_get_emin(); emax = mpfr_get_emax(); mpfr_set_emin(-16493); mpfr_set_emax(16384); inex = mpfr_strtofr(workspace, SvPV_nolen(str), NULL, 0, GMP_RNDN); mpfr_subnormalize(workspace, inex, GMP_RNDN); mpfr_set_emin(emin); mpfr_set_emax(emax); ret = mpfr_get_float128(workspace, GMP_RNDN); mpfr_clear(workspace); return newSVnv(ret); # else croak("The atonv function is unavailable for this __float128 build of perl\n"); # endif # endif /* close F128 */ croak("The atonv function has encountered an unrecognized nvtype"); #else PERL_UNUSED_ARG(str); croak("The atonv function requires mpfr-3.1.6 or later"); #endif } /* close atonv */ SV * Rmpfr_get_str_ndigits_alt(pTHX_ int base, UV prec) { /* Can use this if mpfr version is less than 4.1.0. * * If mpfr version is at least 4.1.0, then the * * Math::MPFR test suite checks that this function * * produces the same results as Rmpfr_get_str_ndigits. */ UV m = 1; int inexflag; mpfr_t temp1, temp2; inexflag = mpfr_inexflag_p(); mpfr_init2(temp1, 128); mpfr_init2(temp2, 128); mpfr_set_ui(temp1, base, GMP_RNDN); mpfr_log2(temp2, temp1, GMP_RNDN); mpfr_trunc(temp1, temp2); if(mpfr_equal_p(temp1, temp2)) mpfr_ui_div(temp1, (unsigned long)(prec - 1), temp2, GMP_RNDN); else mpfr_ui_div(temp1, (unsigned long)prec, temp2, GMP_RNDN); mpfr_ceil(temp1, temp1); m += mpfr_get_ui(temp1, GMP_RNDN); mpfr_clear(temp1); mpfr_clear(temp2); /* Clear the inex flag if it * * was unset to begin with */ if(!inexflag) mpfr_clear_inexflag(); return newSVuv(m); } /* new in 4.1.0 (262400) */ SV * Rmpfr_get_str_ndigits(pTHX_ int base, SV * prec) { if(base < 2 || base > 62) croak("1st argument given to Rmpfr_get_str_ndigits must be in the range 2..62"); #if defined(MPFR_VERSION) && MPFR_VERSION >= 262400 /* version 4.1.0 */ # if MPFR_VERSION == 262400 int inexflag; size_t ret; inexflag = mpfr_inexflag_p(); ret = mpfr_get_str_ndigits(base, (mpfr_prec_t)SvUV(prec)); if(!inexflag) mpfr_clear_inexflag(); /* In case mpfr_get_str_ndigits changed it from * * unset to set. This was fixed after 4.1.0 */ return newSVuv(ret); # else return newSVuv(mpfr_get_str_ndigits(base, (mpfr_prec_t)SvUV(prec))); # endif #else return Rmpfr_get_str_ndigits_alt(aTHX_ base, SvUV(prec)); #endif } SV * Rmpfr_dot(pTHX_ mpfr_t * rop, SV * avref_A, SV * avref_B, SV * len, SV * round) { #if defined(MPFR_VERSION) && MPFR_VERSION >= 262400 /* version 4.1.0 */ mpfr_ptr *p_A, *p_B; SV ** elem; int ret; unsigned long i, s = (unsigned long)SvUV(len); if(s > av_len((AV*)SvRV(avref_A)) + 1 || s > av_len((AV*)SvRV(avref_B)) + 1) croak("2nd last arg to Rmpfr_dot is too large"); Newx(p_A, s, mpfr_ptr); if(p_A == NULL) croak("Unable to allocate memory for first array in Rmpfr_dot"); Newx(p_B, s, mpfr_ptr); if(p_B == NULL) croak("Unable to allocate memory for second array in Rmpfr_dot"); for(i = 0; i < s; ++i) { elem = av_fetch((AV*)SvRV(avref_A), i, 0); p_A[i] = *(INT2PTR(mpfr_t *, SvIVX(SvRV(*elem)))); } for(i = 0; i < s; ++i) { elem = av_fetch((AV*)SvRV(avref_B), i, 0); p_B[i] = *(INT2PTR(mpfr_t *, SvIVX(SvRV(*elem)))); } ret = mpfr_dot(*rop, p_A, p_B, s, (mpfr_rnd_t)SvUV(round)); Safefree(p_A); Safefree(p_B); return newSViv(ret); #else PERL_UNUSED_ARG5(rop, avref_A, avref_B, len, round); croak("The Rmpfr_dot function requires mpfr-4.1.0 or later"); #endif } /******************************************************** * Set exponent and precision for _nvtoa to utilize. * *******************************************************/ void _get_exp_and_bits(mpfr_exp_t * exp, int * bits, NV nv_in) { int subnormal_prec_adjustment = 0, tmp; void *nvptr = &nv_in; #if defined(USE_QUADMATH) || (defined(USE_LONG_DOUBLE) && REQUIRED_LDBL_MANT_DIG == 113) /* 113 bit prec */ int i = QIND_2; /* big endian: 2, little endian: 13 */ *exp = ((unsigned char *)nvptr)[QIND_0]; /* big endian: 0, little endian: 15 */ *exp <<= 8; tmp = ((unsigned char *)nvptr)[QIND_1]; /* big endian: 1, little endian: 14 */ *exp += tmp - 16382; if(*exp == -16382) { while(Q_CONDITION_1(i)) { /* big endian: (i <= 15) */ /* little endian: (i >= 0 ) */ tmp = ((unsigned char *)nvptr)[i]; if(tmp) { BITSEARCH_8 /* defined in math_mpfr_include.h */ break; } subnormal_prec_adjustment += 8; INC_OR_DEC(i); /* big endian: i++; */ /* little endian: i--; */ } /* close while loop */ } *exp -= subnormal_prec_adjustment - 1; *bits = 113 - subnormal_prec_adjustment; if(!subnormal_prec_adjustment) (*exp)--; #elif defined(USE_LONG_DOUBLE) /* 64 bit prec. (DoubleDouble builds don't call this function.) */ int i = LDIND_2; /* big endian: 2, little endian: 7 */ *exp = ((unsigned char *)nvptr)[LDIND_0]; /* big endian: 0, little endian: 9 */ *exp <<= 8; tmp = ((unsigned char *)nvptr)[LDIND_1]; /* big endian: 1, little endian: 8 */ *exp += tmp - 16382; if(*exp == -16382) { while(LD_CONDITION_1(i)) { /* big endian: (i <= 9) */ /* little endian: (i >= 0) */ tmp = ((unsigned char *)nvptr)[i]; if(tmp) { BITSEARCH_8 /* defined in math_mpfr_include.h */ break; } subnormal_prec_adjustment += 8; INC_OR_DEC(i); /* big endian: i++; */ /* little endian: i--; */ } /* close while loop */ } /* for both endians (64 bit) */ if(subnormal_prec_adjustment) subnormal_prec_adjustment--; *exp -= subnormal_prec_adjustment; *bits = 64 - subnormal_prec_adjustment; if(subnormal_prec_adjustment) (*exp)++; #else /* 53 bit prec */ int i = DIND_1; /* big endian: 1, little endian: 6 */ *exp = ((unsigned char *)nvptr)[DIND_0]; /* big endian: 0, little endian: 7 */ *exp <<= 4; tmp = ((unsigned char *)nvptr)[i]; *exp += (tmp >> 4) - 1022; if(*exp == -1022) { while(D_CONDITION_1(i)) { /* big endian: (i <= 7) */ /* little endan: (i >= 0) */ tmp = ((unsigned char *)nvptr)[i]; if(tmp) { if(i == 1) { BITSEARCH_4 /* defined in math_mpfr_include.h */ break; } else { BITSEARCH_8 /* defined in math_mpfr_include.h */ break; } } if(i == 1) subnormal_prec_adjustment += 4; else subnormal_prec_adjustment += 8; INC_OR_DEC(i); /* big endian: i++; */ /* little endian: i--; */ } } /* for both endians (53 bit) */ *exp -= subnormal_prec_adjustment - 1; *bits = 53 - subnormal_prec_adjustment; if(!subnormal_prec_adjustment) (*exp)--; #endif } /* _nvtoa function is adapted from p120 of "How to Print Floating-Point Numbers Accurately" */ /* by Guy L. Steele Jr and Jon L. White */ SV * _nvtoa(pTHX_ NV pnv) { int k = 0, k_index, lsb, skip = 0, sign = 0; int bits = NVSIZE_BITS, is_subnormal = 0, shift1, shift2, low, high, cmp, u; mpfr_exp_t e; /* Change to 'int' when mpfr dependency for doubledouble is removed */ NV nv; void *nvptr = &nv; SV * outsv; /* for returning inf/nan values */ #if NVSIZE == 8 char f[] = {'\0','\0','\0','\0','\0','\0','\0','\0','\0','\0','\0','\0','\0','\0','\0','\0'}; #elif defined(USE_LONG_DOUBLE) && REQUIRED_LDBL_MANT_DIG == 64 char f[] = {'\0','\0','\0','\0','\0','\0','\0','\0','\0','\0','\0','\0','\0','\0','\0','\0', '\0','\0','\0','\0'}; #else char f[] = {'\0','\0','\0','\0','\0','\0','\0','\0','\0','\0','\0','\0','\0','\0','\0','\0', '\0','\0','\0','\0','\0','\0','\0','\0','\0','\0','\0','\0','\0','\0','\0','\0'}; #endif mpz_t R, S, M_minus, M_plus, LHS, TMP; char * c = "0123456789abcdef"; char *out; nv = pnv; /* Don't fiddle with pnv - instead fiddle with a copy */ #if defined(USE_LONG_DOUBLE) && REQUIRED_LDBL_MANT_DIG == 2098 croak("_nvtoa function is unsuitable for DoubleDouble"); #else #if defined(MPFR_HAVE_BENDIAN) if(((unsigned char *)nvptr)[0] >= 128) { # if defined(USE_LONG_DOUBLE) && REQUIRED_LDBL_MANT_DIG == 2098 nv = -nv; # else ((unsigned char *)nvptr)[0] &= 127; # endif #elif NVSIZE == 8 if(((unsigned char *)nvptr)[7] >= 128) { ((unsigned char *)nvptr)[7] &= 127; #elif defined(USE_LONG_DOUBLE) && REQUIRED_LDBL_MANT_DIG == 64 if(((unsigned char *)nvptr)[9] >= 128) { ((unsigned char *)nvptr)[9] &= 127; #elif defined(USE_LONG_DOUBLE) && REQUIRED_LDBL_MANT_DIG == 2098 if(((unsigned char *)nvptr)[15] >= 128) { nv = -nv; #else if(((unsigned char *)nvptr)[15] >= 128) { ((unsigned char *)nvptr)[15] &= 127; #endif sign = 1; } if(nv == 0) { if(sign) return newSVpv("-0.0", 0); return newSVpv("0.0", 0); } if(nv != nv) { if(SvIV(get_sv("Math::MPFR::PERL_INFNAN", 0))) { outsv = SvREFCNT_inc(get_sv("Math::MPFR::nanvstr", 0)); return outsv; } return newSVpv("NaN", 0); } if(nv > MATH_MPFR_NV_MAX) { if(sign) { if(SvIV(get_sv("Math::MPFR::PERL_INFNAN", 0))) { outsv = SvREFCNT_inc(get_sv("Math::MPFR::ninfstr", 0)); return outsv; } return newSVpv("-Inf", 0); } if(SvIV(get_sv("Math::MPFR::PERL_INFNAN", 0))) { outsv = SvREFCNT_inc(get_sv("Math::MPFR::pinfstr", 0)); return outsv; } return newSVpv("Inf", 0); } mpz_init(R); mpz_init(S); mpz_init(M_plus); mpz_init(M_minus); mpz_init(LHS); mpz_init(TMP); /*********************************************************************************** * Set bits to the precision of the mantissa, including any implicit leading bit. * * If the value is subnormal, then bits will be set to the actual precision of the * * subnormal value. See the examples given a couple of lines below. * * Also set exp to the (binary) exponent. * * eg (for nvtype of double): * * if nv == 10000000000.0 (0x1.2a05f2p+33) then e == 34 and bits == 53 * * if nv == 1.125e-100 (0x1.f7f14c11fc5d6p-333) then e == -332 and bits == 53 * * if nv == 2 ** -1073 (0x1p-1073) then e == -1072 and bits == 2 * * if nv == 2 ** -1074 (0x1p-1074) then e == -1073 and bits == 1 * ***********************************************************************************/ _get_exp_and_bits( &e, &bits, nv); if(bits < NVSIZE_BITS) is_subnormal = 1; /* NVSIZE_BITS == precision of NV's mantissa */ /*************** * Assign to f * ***************/ if(bits == 1) { f[0] = c[1]; } else { #if defined(USE_QUADMATH) || (defined(USE_LONG_DOUBLE) && REQUIRED_LDBL_MANT_DIG == 113) /* 113 bit prec */ f[0] = is_subnormal ? c[0] : c[1]; k++; for(skip = QIND_2; Q_CONDITION_1(skip); INC_OR_DEC(skip)) { /* big endian: * skip=2;skip<=15;skip++ */ /* little endian: * skip=13;skip>=0;skip-- */ low = ((unsigned char *)nvptr)[skip]; f[k] = c[low >> 4]; f[k + 1] = c[low & 15]; k += 2; } #elif defined(USE_LONG_DOUBLE) /* 64 bit prec. This function not called forDoubleDoubles. */ for(skip = LDIND_2; LD_CONDITION_1(skip); INC_OR_DEC(skip)) { /* big endian: * * skip=2;skip<=9;skip++ */ /* little endian: * * skip=7;skip>=0;skip-- */ low = ((unsigned char *)nvptr)[skip]; f[k] = c[low >> 4]; f[k + 1] = c[low & 15]; k += 2; } #else /* 53 bit prec */ for(skip = DIND_1; D_CONDITION_1(skip); INC_OR_DEC(skip)) { /* big endian: * * skip=1;skip<=7;skip++ */ /* little endian: * * skip=6;skip>=0;skip-- */ low = ((unsigned char *)nvptr)[skip]; if(!k) { f[0] = is_subnormal ? c[0] : c[1]; f[1] = c[low & 15]; } else { f[k] = c[low >> 4]; f[k + 1] = c[low & 15]; } k += 2; } #endif } /******************************** * assignment to f is completed * ********************************/ #ifdef NVTOA_DEBUG warn(" f is %s\n exponent is %d\n precision is %d\n", f, (int)e, bits); /****************************************************************************** * eg (for nvtype of double): * * if nv == 10000000000.0 (0x1.2a05f2p+33) then f is 12a05f20000000 and * * e == 34, bits == 53. (Note that nv == 0x0.12a05f20000000p34) * * if nv == 1.125e-100 (0x1.f7f14c11fc5d6p-333) then f is 1f7f14c11fc5d6 and * * e == -332, bits == 53. (Note that nv == 0x0.1f7f14c11fc5d6p-333) * * if nv == 2 **-1073 (0x2p-1073) then f is 2 and e == -1072, bits == 2. * * (Note that nv == 0x0.2p-1072) * * if nv == 2 **-1074 (0x1p-1074) then f is 1 and e == -1073, bits == 1. * * (Note that nv == 0x0.1p-1073) * ******************************************************************************/ #endif mpz_set_str(R, f, 16); lsb = mpz_tstbit(R, 0); /* Set lsb to the value of R's least significant bit */ mpz_set(TMP, R); if(mpz_sgn(R) < 1) croak("Negative value in _nvtoa XSub is not allowed"); mpz_set_ui(S, 1); shift2 = e - bits; shift1 = shift2 > 0 ? shift2 : 0; mpz_mul_2exp(R, R, shift1); shift2 = shift1 ? 0 : -shift2; mpz_mul_2exp(S, S, shift2); mpz_set_ui(M_minus, 1); mpz_mul_2exp(M_minus, M_minus, shift1); mpz_set(M_plus, M_minus); /*************** start simple fixup **************/ if(!is_subnormal) { mpz_set_ui(LHS, 1); mpz_mul_2exp(LHS, LHS, bits - 1); if(!mpz_cmp(LHS, TMP)) { mpz_mul_2exp(M_plus, M_plus, 1); mpz_mul_2exp(R, R, 1); mpz_mul_2exp(S, S, 1); } } k = 0; /* used above, so we reset to zero */ skip = 0; /* used above, so we reset to zero */ mpz_cdiv_q_ui(LHS, S, 10); /* LHS = ceil(S / 10) */ if(mpz_cmp(LHS, R) > 0) { /* Set k to be close to, but not greater than, the number of * * decimal digits needed to represent the value of LHS. This * * reduces the number of times that we need to loop through the * * the next while{} loop. * * Note that 0x1.34413509f79ffp-2 is slightly less than log2(10). */ k = (int)floor(mpz_sizeinbase(LHS, 2) * 0x1.34413509f79ffp-2); if(k) k--; /* Do not decrement if k is zero */ mpz_ui_pow_ui(TMP, 10, k); k *= -1; #ifdef NVTOA_DEBUG warn(" k init: %d\n", k); #endif mpz_mul(R, R, TMP); mpz_mul(M_minus, M_minus, TMP); mpz_mul(M_plus, M_plus, TMP); } else { skip = 1; /* No need to enter the following while() loop */ } if(!skip) { while(1) { #ifdef NVTOA_DEBUG warn("In first loop\n"); #endif if(mpz_cmp(LHS, R) <= 0) break; k--; mpz_mul_ui(R, R, 10); mpz_mul_ui(M_minus, M_minus, 10); mpz_mul_ui(M_plus, M_plus, 10); } /* close first while loop */ #ifdef NVTOA_DEBUG warn(" k post 1st loop: %d\n", k); #endif } mpz_mul_2exp(LHS, R, 1); mpz_add(LHS, LHS, M_plus); mpz_mul_2exp(TMP, S, 1); if(mpz_cmp(LHS, TMP) >= 0) { #ifdef NVTOA_DEBUG gmp_printf("LHS: %Zd\nTMP: %Zd\n", LHS, TMP); #endif skip = 0; mpz_div(TMP, LHS, TMP); #ifdef NVTOA_DEBUG gmp_printf("TMP (= LHS / TMP): %Zd\n", TMP); #endif /* Set u to be close to, but not greater than, the number of * * decimal digits needed to represent the value of TMP. This * * reduces the number of times that we need to loop through the * * the next while{} loop. * * Note that 0x1.34413509f79ffp-2 is slightly less than log2(10). */ u = (int)floor(mpz_sizeinbase(TMP, 2) * 0x1.34413509f79ffp-2); /* if(u) u--; *//* Decrement not needed here, AFAIK. */ mpz_ui_pow_ui(TMP, 10, u); k += u; #ifdef NVTOA_DEBUG gmp_printf("TMP (= 10 ** %d): %Zd\n", u, TMP); warn(" u init: %d\n k set to: %d\n", u, k); #endif mpz_mul(S, S, TMP); } else { skip = 1; /* No need to enter the following while() loop */ } if(!skip) { while(1) { #ifdef NVTOA_DEBUG warn("In second loop\n"); #endif mpz_mul_2exp(TMP, S, 1); if(mpz_cmp(LHS, TMP) < 0) break; mpz_mul_ui(S, S, 10); k++; } /* close second while loop */ #ifdef NVTOA_DEBUG warn(" k post 2nd loop: %d\n", k); #endif } /*********************** finish simple fixup **********************/ k_index = -1; Newxz(out, (int)(12 + ceil(0.30103 * bits)), char); /* 1 + ceil(log(2) / log(10) * bits), but allow a few extra for exponent and sign */ if(out == NULL) croak("Failed to allocate memory for output string in _nvtoa XSub"); /* Each iteration of the following while() loop outputs, one at a time, the * * digits of the final mantissa - except for the final (least significant) * * digit Which is set following the termination of the loop. */ while(1) { k_index++; mpz_mul_ui(TMP, R, 10); mpz_fdiv_qr(LHS, R, TMP, S); u = mpz_get_ui(LHS); mpz_mul_ui(M_minus, M_minus, 10); mpz_mul_ui(M_plus, M_plus, 10); mpz_mul_2exp(LHS, R, 1); cmp = mpz_cmp(LHS, M_minus); if(!cmp && !lsb && !is_subnormal) { /* !lsb implies that f is even */ low = 1; } else { low = cmp < 0 ? 1 : 0; } mpz_mul_2exp(TMP, S, 1); mpz_sub(TMP, TMP, M_plus); cmp = mpz_cmp(LHS, TMP); if(!cmp && !lsb && !is_subnormal) { /* !lsb implies that f is even */ high = 1; } else { high = cmp > 0 ? 1 : 0; } if(low | high) break; out[k_index] = 48 + u; } /* close while loop */ /* Next we set the final digit, rounding up where appropriate */ if(low & high) { /* ( low && high) */ mpz_mul_2exp(LHS, R, 1); cmp = mpz_cmp(LHS, S); if (cmp > 0) out[k_index] = 49 + u; else if (cmp < 0) out[k_index] = 48 + u; else { /* (cmp == 0) */ if(u & 1) out[k_index] = 49 + u; else out[k_index] = 48 + u; } } else if(high) out[k_index] = 49 + u; /* (!low && high) */ else out[k_index] = 48 + u; /* ( low && !high) */ mpz_clear(R); mpz_clear(S); mpz_clear(M_plus); mpz_clear(M_minus); mpz_clear(LHS); mpz_clear(TMP); #ifdef NVTOA_DEBUG warn("nvtoa: %s %d %d\n", out, k, bits); #endif /******************************************************************************************* * eg (for nvtype of double): * * if nv == 10000000000.0, final string is set to 1, k == 11. Note that nv == 0.1e11 * * if nv == 1.125e-100, final string is set to 1125, k == -99. Note that nv == 0.1125e-99 * * if nv == 2 ** -1073, final string is set to 1, k == -322. Note that nv == 0.1e-322 * * if nv == 2 ** -1074, final string is set to 5, k == -323. Note that nv == 0.5e-323 * *******************************************************************************************/ /******************************* * Return the formatted result * *******************************/ /* printf("# nvtoa: %s %d\n", out, k); */ return _fmt_flt(aTHX_ out, k, sign, MATH_MPFR_MAX_DIG, 1); #endif /* defined(USE_LONG_DOUBLE) && REQUIRED_LDBL_MANT_DIG == 2098 ... from near the start */ } /**************************** * END nvtoa * ****************************/ /**************************** * BEGIN _mpfrtoa * ****************************/ /* _mpfrtoa is, like _nvtoa, adapted from p120 of * * "How to Print Floating-Point Numbers Accurately" * * by Guy L. Steele Jr and Jon L. White */ SV * _mpfrtoa(pTHX_ mpfr_t * pnv, int min_normal_prec) { int k = 0, k_index, lsb, skip = 0, sign = 0; int bits, shift1, shift2, low, high, cmp, u; mpfr_exp_t e; mpz_t R, S, M_plus, M_minus, LHS, TMP; char * f, *out; sign = mpfr_signbit(*pnv); if(!mpfr_regular_p(*pnv)) { if(mpfr_zero_p(*pnv)) { if(sign) return newSVpv("-0.0", 0); return newSVpv("0.0", 0); } if(mpfr_nan_p(*pnv)) { return newSVpv("NaN", 0); } /* Must be Inf */ if(sign) return newSVpv("-Inf", 0); return newSVpv("Inf", 0); } mpz_init(R); mpz_init(S); mpz_init(M_plus); mpz_init(M_minus); mpz_init(LHS); mpz_init(TMP); /*************** * Assign to f * ***************/ bits = mpfr_get_prec(*pnv); Newxz(f, bits + 8, char); if(f == NULL) croak("Failed to allocate memory for string buffer in _mpfrtoa XSub"); mpfr_get_str(f, &e, 2, bits, *pnv, GMP_RNDN); /******************************** * assignment to f is completed * ********************************/ #ifdef NVTOA_DEBUG warn(" f is %s\n exponent is %d\n precision is %d\n", f, (int)e, bits); #endif if(sign) f++; mpz_set_str(R, f, 2); if(sign) f--; Safefree(f); lsb = mpz_tstbit(R, 0); /* Set lsb to the value of R's least significant bit */ mpz_set(TMP, R); if(mpz_sgn(R) < 1) croak("Negative value in _mpfrtoa XSub is not allowed"); mpz_set_ui(S, 1); shift2 = e - bits; shift1 = shift2 > 0 ? shift2 : 0; mpz_mul_2exp(R, R, shift1); shift2 = shift1 ? 0 : -shift2; mpz_mul_2exp(S, S, shift2); mpz_set_ui(M_minus, 1); mpz_mul_2exp(M_minus, M_minus, shift1); mpz_set(M_plus, M_minus); /*************** start simple fixup **************/ if(bits >= min_normal_prec) { /*********************************************** AFAIK, the only time this block is entered is in Math::FakeDD:dd_repro(). If I can recollect why it's needed and/or work around it in dd_repro() then this block of code && the min_normal_prec argument will be removed. Math::MPFR::mpfrtoa() will thus revert to accepting only one argument. ***********************************************/ mpz_set_ui(LHS, 1); mpz_mul_2exp(LHS, LHS, bits - 1); if(!mpz_cmp(LHS, TMP)) { mpz_mul_2exp(M_plus, M_plus, 1); mpz_mul_2exp(R, R, 1); mpz_mul_2exp(S, S, 1); } } k = 0; /* used above, so we reset to zero */ skip = 0; /* used above, so we reset to zero */ mpz_cdiv_q_ui(LHS, S, 10); /* LHS = ceil(S / 10) */ if(mpz_cmp(LHS, R) > 0) { /* Set k to be close to, but not greater than, the number of * * decimal digits needed to represent the value of LHS. This * * reduces the number of times that we need to loop through the * * the next while{} loop. * * Note that 0x1.34413509f79ffp-2 is slightly less than log2(10). */ k = (int)floor(mpz_sizeinbase(LHS, 2) * 0x1.34413509f79ffp-2); if(k) k--; /* Do not decrement if k is zero */ mpz_ui_pow_ui(TMP, 10, k); k *= -1; #ifdef NVTOA_DEBUG warn(" k init: %d\n", k); #endif mpz_mul(R, R, TMP); mpz_mul(M_minus, M_minus, TMP); mpz_mul(M_plus, M_plus, TMP); } else { skip = 1; /* No need to enter the following while() loop */ } if(!skip) { while(1) { if(mpz_cmp(LHS, R) <= 0) break; k--; mpz_mul_ui(R, R, 10); mpz_mul_ui(M_minus, M_minus, 10); mpz_mul_ui(M_plus, M_plus, 10); } /* close first while loop */ #ifdef NVTOA_DEBUG warn(" k post 1st loop: %d\n", k); #endif } mpz_mul_2exp(LHS, R, 1); mpz_add(LHS, LHS, M_plus); mpz_mul_2exp(TMP, S, 1); if(mpz_cmp(LHS, TMP) >= 0) { skip = 0; mpz_div(TMP, LHS, TMP); /* Set u to be close to, but not greater than, the number of * * decimal digits needed to represent the value of TMP. This * * reduces the number of times that we need to loop through the * * the next while{} loop. * * Note that 0x1.34413509f79ffp-2 is slightly less than log2(10). */ u = (int)floor(mpz_sizeinbase(TMP, 2) * 0x1.34413509f79ffp-2); /* if(u) u--; *//* Decrement not needed here, AFAIK. */ mpz_ui_pow_ui(TMP, 10, u); k += u; #ifdef NVTOA_DEBUG warn(" u init: %d\n k set to: %d\n", u, k); #endif mpz_mul(S, S, TMP); } else { skip = 1; /* No need to enter the following while() loop */ } if(!skip) { while(1) { mpz_mul_2exp(TMP, S, 1); if(mpz_cmp(LHS, TMP) < 0) break; mpz_mul_ui(S, S, 10); k++; } /* close second while loop */ #ifdef NVTOA_DEBUG warn(" k post 2nd loop: %d\n", k); #endif } /*********************** finish simple fixup **********************/ k_index = -1; Newxz(out, (int)(12 + ceil(0.30103 * bits)), char); /* 1 + ceil(log(2) / log(10) * bits), but * * allow a few extra for exponent and sign */ if(out == NULL) croak("Failed to allocate memory for output string in _mpfrtoa XSub"); /* Each iteration of the following while() loop outputs, one at a time, the * * digits of the final mantissa - except for the final (least significant) * * digit Which is set following the termination of the loop. */ while(1) { k_index++; mpz_mul_ui(TMP, R, 10); mpz_fdiv_qr(LHS, R, TMP, S); u = mpz_get_ui(LHS); mpz_mul_ui(M_minus, M_minus, 10); mpz_mul_ui(M_plus, M_plus, 10); mpz_mul_2exp(LHS, R, 1); cmp = mpz_cmp(LHS, M_minus); if(!cmp && !lsb) { /* !lsb implies that f is even */ low = 1; } else { low = cmp < 0 ? 1 : 0; } mpz_mul_2exp(TMP, S, 1); mpz_sub(TMP, TMP, M_plus); cmp = mpz_cmp(LHS, TMP); if(!cmp && !lsb) { /* !lsb implies that f is even */ high = 1; } else { high = cmp > 0 ? 1 : 0; } if(low | high) break; out[k_index] = 48 + u; } /* close while loop */ /* Next we set the final digit, rounding up where appropriate */ if(low & high) { /* ( low && high) */ mpz_mul_2exp(LHS, R, 1); cmp = mpz_cmp(LHS, S); if (cmp > 0) out[k_index] = 49 + u; else if (cmp < 0) out[k_index] = 48 + u; else { /* (cmp == 0) */ if(u & 1) out[k_index] = 49 + u; else out[k_index] = 48 + u; } } else if(high) out[k_index] = 49 + u; /* (!low && high) */ else out[k_index] = 48 + u; /* ( low && !high) */ mpz_clear(R); mpz_clear(S); mpz_clear(M_plus); mpz_clear(M_minus); mpz_clear(LHS); mpz_clear(TMP); #ifdef NVTOA_DEBUG warn(" final string: %s\n k = %d\n", out, k); #endif /********************* * Return the formatted the result * *********************/ return _fmt_flt(aTHX_ out, k, sign, (int)ceil(0x1.34413509f79ffp-2 * mpfr_get_prec(*pnv)) + 1, 1); } /**************************** * END _mpfrtoa * ****************************/ /**************************** * BEGIN doubletoa * ****************************/ void set_fallback_flag(pTHX) { dSP; PUSHMARK(SP); call_pv("Math::MPFR::perl_set_fallback_flag", G_DISCARD|G_NOARGS); } SV * doubletoa(pTHX_ SV * sv, ...) { /* calls functions contained in grisu3.c */ #if NVSIZE == 8 dXSARGS; double v = SvNV(sv); int d_exp, len, success, sign = 1; uint64_t u64; char dst [] = {'\0', '\0', '\0', '\0', '\0', '\0', '\0', '\0', '\0', '\0', '\0', '\0', '\0', '\0', '\0', '\0', '\0', '\0', '\0', '\0', '\0', '\0', '\0', '\0', '\0', '\0'}; char *s2 = dst; int fallback = items > 1 ? 0 : 1; /* A true value for sign implies that nvtoa() will be used * * if grisu3() fails to produce a result. Else sprintf() * * will be used when grisu3() fails. See pod documentation. */ #ifdef DTOA_ASSERT if(!dst) croak("dst does not hold a true value"); /* assert(dst); */ #endif if(v < 0) { v = -v; sign = -1; } u64 = CAST_U64(v); /* Prehandle NaNs */ if((u64 << 1) > 0xFFE0000000000000ULL) { sprintf(dst, "NaN"); return newSVpv(dst, 0); } /* Prehandle zero. */ if(v == 0) { if(u64) *s2++ = '-'; *s2++ = '0'; *s2++ = '.'; *s2++ = '0'; *s2 = '\0'; return newSVpv(dst, 0); } /* Prehandle infinity. */ if(u64 == D64_EXP_MASK) { if(sign < 0) *s2++ = '-'; *s2++ = 'I'; *s2++ = 'n'; *s2++ = 'f'; *s2 = '\0'; return newSVpv(dst, 0); } success = grisu3(v, s2, &len, &d_exp); /* If grisu3 was not able to convert the number to a string, then use either nvtoa or sprintf. */ /* Both are accurate - and sprintf is quicker than nvtoa. However, unlike nvtoa, sprintf will */ /* sometimes deliver more digits than are necessary. */ if(!success) { #if defined FALLBACK_NOTIFY set_fallback_flag(aTHX); #endif if(fallback) { return _nvtoa(aTHX_ v * sign); } sprintf(s2, "%.16e", (v * sign)); return newSVpv(dst, 0); } /* We have an integer string of form "151324135" and a base-10 exponent for that number. */ /* Now, we just need to format it ... */ /* printf("# doubletoa: %s %d\n", dst, d_exp + strlen(dst)); */ return _fmt_flt(aTHX_ dst, (int)(d_exp + strlen(dst)), sign < 0 ? 1 : 0, MATH_MPFR_MAX_DIG, 0); #else PERL_UNUSED_ARG(sv); croak("The doubletoa function is unavailable - it requires that $Config{nvsize} == 8"); #endif } /**************************** * END doubletoa * ****************************/ int _fallback_notify(void) { #if defined(FALLBACK_NOTIFY) return 1; #else return 0; #endif } SV * _numtoa(pTHX_ SV * in) { char buffer[IVSIZE * 3]; if(!SvOK(in) || SvUOK(in)) { sprintf(buffer, "%" UVuf, SvUV(in)); return newSVpv(buffer, 0); } if(SV_IS_IOK(in)) { sprintf(buffer, "%" IVdf, SvIV(in)); return newSVpv(buffer, 0); } if(SV_IS_NOK(in)) { return _nvtoa(aTHX_ SvNV(in)); } croak("Not a numeric argument given to _numtoa function"); } void decimalize(pTHX_ SV * a, ...) { dXSARGS; mpfr_prec_t prec, i; mpfr_exp_t exp, high_exp, low_exp = 0; char * buff; char * dec_buff; int is_neg = 0; double digits = 0; double div = 0x1.a934f0979a371p+1; /* log2(10) */ double mul = 0x1.65df657b04301p-1; /* log10(5) */ if(!mpfr_regular_p(*(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))))) { if(items > 1) { ST(0) = sv_2mortal(newSViv(0)); XSRETURN(1); } Newxz(buff, 8, char); mpfr_sprintf(buff, "%Rg", *(INT2PTR(mpfr_t *, SvIVX(SvRV(a))))); ST(0) = MORTALIZED_PV(buff); /* defined in math_mpfr_include.h */ Safefree(buff); XSRETURN(1); } prec = mpfr_get_prec(*(INT2PTR(mpfr_t *, SvIVX(SvRV(a))))); #if 262146 > MPFR_VERSION if(prec < 2) croak("Precision of 1 not allowed in decimalize function until mpfr-4.0.2"); #endif Newxz(buff, prec + 2, char); mpfr_get_str(buff, &exp, 2, prec, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), GMP_RNDN); /* The decimal point is implicitly located at the very * * beginning of the string. Therefore, the power of 2 * * to which the highest set bit is raised is exp - 1 */ high_exp = exp - 1; if(high_exp >= prec - 1) low_exp = 0; /* No need to locate the lowest set bit */ else { /* We do need to locate the lowest set bit */ if(buff[0] == '-') { buff++; is_neg = -1; } /* The power to which the lowest set bit is raised is * * calculated in the following for{} loop: */ for(i = prec - 1; i >= 0; i--) { if(buff[i] == '1') { low_exp = high_exp - i; break; } } if(is_neg) buff--; } Safefree(buff); /* Next determine the number of decimal digits that are needed to * * exactly express the function's argument in base 10 */ if(low_exp >= 0) { /* Both low_exp and high_exp are >= 0. * * The number of digits is calculated solely from high_exp. * * We add on "1" to allow for cases where the value of high_exp * * does not alone determine how many siginificant digits are * * required - eg the value 2 ** 13 (8192) requires 4 decimal * * digits, but if the second highest bit is also set, then 5 * * decimal digits are needed because (2**13) + (2**12) == 12288 */ digits = 1 + ceil( high_exp / div ); } else if(high_exp < 0) { /* Both low_exp and high_exp are < 0 */ digits = ceil( -low_exp * mul ) + ceil( -low_exp / div ) - floor( -high_exp / div ); } else { /* low_exp < 0, high_exp >= 0 * * Add 1, as in the above if{} block */ digits = 1 + ceil( high_exp / div ) + ceil( -low_exp * mul ) + floor( -low_exp / div ); } if(digits > INT_MAX - 30) croak("Too many digits (%.0f) requested in decimalize function", digits); if(items > 1) { ST(0) = sv_2mortal(newSViv((IV)digits)); XSRETURN(1); } Newxz(dec_buff, (int)digits + 30, char); /* allow for a 20-digit exponent, a radix point, * * a leading '-', an 'e-', a terminating NULL, * * and a saftety net of 5 bytes (== 30, total) */ if(dec_buff == NULL) croak("Unable to allocate %.0f bytes of memory in decimalize function", digits + 30.0); mpfr_sprintf(dec_buff, "%.*Rg", (int)digits, *(INT2PTR(mpfr_t *, SvIVX(SvRV(a))))); ST(0) = MORTALIZED_PV(dec_buff); /* defined in math_mpfr_include.h */ Safefree(dec_buff); XSRETURN(1); } int IOK_flag(SV * sv) { if(SvUOK(sv)) return 2; if(SvIOK(sv)) return 1; return 0; } int POK_flag(SV * sv) { if(SvPOK(sv)) return 1; return 0; } int NOK_flag(SV * sv) { if(SvNOK(sv)) return 1; return 0; } int _sis_perl_version(void) { return SIS_PERL_VERSION; } int _has_pv_nv_bug(void) { #if defined(MPFR_PV_NV_BUG) return 1; #else return 0; #endif } int _sizeof_exp(void) { return sizeof(mpfr_exp_t); } int _sizeof_prec(void) { return sizeof(mpfr_prec_t); } int _has_bizarre_infnan(void) { #if defined(_WIN32_BIZARRE_INFNAN) return 1; #else return 0; #endif } SV * _gmp_cflags(pTHX) { #if defined(__GMP_CFLAGS) return newSVpv(__GMP_CFLAGS, 0); #else return &PL_sv_undef; #endif } SV * _gmp_cc(pTHX) { #if defined(__GMP_CC) return newSVpv(__GMP_CC, 0); #else return &PL_sv_undef; #endif } int _have_float16(void) { #if defined(HAVE_FLOAT16) /* defined in Makefile.PL */ return 1; #else return 0; #endif } /********************************************/ /********************************************/ SV * _gmp_printf_nv(pTHX_ SV * a, SV * b) { int ret; if(SV_IS_NOK(b)) { ret = gmp_printf(SvPV_nolen(a), SvNVX(b)); fflush(stdout); return newSViv(ret); } croak("Unrecognised type supplied as argument to _gmp_printf_nv"); } SV * _gmp_fprintf_nv(pTHX_ FILE * stream, SV * a, SV * b) { int ret; if(SV_IS_NOK(b)) { ret = gmp_fprintf(stream, SvPV_nolen(a), SvNVX(b)); fflush(stream); return newSViv(ret); } croak("Unrecognised type supplied as argument to _gmp_fprintf_nv"); } SV * _gmp_sprintf_nv(pTHX_ SV * s, SV * a, SV * b, int buflen) { int ret; char * stream; Newx(stream, buflen, char); if(SV_IS_NOK(b)) { ret = gmp_sprintf(stream, SvPV_nolen(a), SvNVX(b)); sv_setpv(s, stream); Safefree(stream); return newSViv(ret); } Safefree(stream); /* In case the ensuing croak() is encased in an eval{} block */ croak("Unrecognised type supplied as argument to _gmp_sprintf_nv"); } SV * _gmp_snprintf_nv(pTHX_ SV * s, SV * bytes, SV * a, SV * b, int buflen) { int ret; char * stream; Newx(stream, buflen, char); if(SV_IS_NOK(b)) { ret = gmp_snprintf(stream, (size_t)SvUV(bytes), SvPV_nolen(a), SvNVX(b)); sv_setpv(s, stream); Safefree(stream); return newSViv(ret); } Safefree(stream); /* In case the ensuing croak() is encased in an eval{} block */ croak("Unrecognised type supplied as argument to _gmp_snprintf_nv"); } int _looks_like_number(pTHX_ SV * in) { if(looks_like_number(in)) return 1; return 0; } SV * _overload_fmod (pTHX_ mpfr_t * a, mpfr_t *b, SV * third) { mpfr_t * mpfr_t_obj; SV * obj_ref, * obj; NEW_MATH_MPFR_OBJECT("Math::MPFR", _overload_fmod) /* defined in math_mpfr_include.h */ mpfr_init(*mpfr_t_obj); OBJ_READONLY_ON /*defined in math_mpfr_include.h */ if(SWITCH_ARGS) mpfr_fmod(*mpfr_t_obj, *b, *a, __gmpfr_default_rounding_mode); else mpfr_fmod(*mpfr_t_obj, *a, *b, __gmpfr_default_rounding_mode); return obj_ref; } SV * _overload_fmod_eq (pTHX_ SV * a, mpfr_t *b, SV * third) { PERL_UNUSED_ARG(third); SvREFCNT_inc(a); mpfr_fmod(*(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *(INT2PTR(mpfr_t *, SvIVX(SvRV(a)))), *b, __gmpfr_default_rounding_mode); return a; } MODULE = Math::MPFR PACKAGE = Math::MPFR PROTOTYPES: DISABLE int NNW_val () CODE: RETVAL = NNW_val (aTHX); OUTPUT: RETVAL int NOK_POK_val () CODE: RETVAL = NOK_POK_val (aTHX); OUTPUT: RETVAL int _win32_infnanstring (s) char * s SV * _fmt_flt (out, k, sign, max_decimal_prec, sf) char * out int k int sign int max_decimal_prec int sf CODE: RETVAL = _fmt_flt (aTHX_ out, k, sign, max_decimal_prec, sf); OUTPUT: RETVAL void Rmpfr_set_default_rounding_mode (round) SV * round PPCODE: Rmpfr_set_default_rounding_mode(aTHX_ round); XSRETURN_EMPTY; /* return empty stack */ unsigned long Rmpfr_get_default_rounding_mode () SV * Rmpfr_prec_round (p, prec, round) mpfr_t * p SV * prec SV * round CODE: RETVAL = Rmpfr_prec_round (aTHX_ p, prec, round); OUTPUT: RETVAL void DESTROY (p) mpfr_t * p PPCODE: DESTROY(aTHX_ p); XSRETURN_EMPTY; /* return empty stack */ void Rmpfr_clear (p) mpfr_t * p PPCODE: Rmpfr_clear(aTHX_ p); XSRETURN_EMPTY; /* return empty stack */ void Rmpfr_clear_mpfr (p) mpfr_t * p PPCODE: Rmpfr_clear_mpfr(p); XSRETURN_EMPTY; /* return empty stack */ void Rmpfr_clear_ptr (p) mpfr_t * p PPCODE: Rmpfr_clear_ptr(aTHX_ p); XSRETURN_EMPTY; /* return empty stack */ void Rmpfr_clears (p, ...) SV * p PPCODE: PL_markstack_ptr++; Rmpfr_clears(aTHX_ p); XSRETURN_EMPTY; /* return empty stack */ SV * Rmpfr_init () CODE: RETVAL = Rmpfr_init (aTHX); OUTPUT: RETVAL SV * Rmpfr_init2 (prec) SV * prec CODE: RETVAL = Rmpfr_init2 (aTHX_ prec); OUTPUT: RETVAL SV * Rmpfr_init_nobless () CODE: RETVAL = Rmpfr_init_nobless (aTHX); OUTPUT: RETVAL SV * Rmpfr_init2_nobless (prec) SV * prec CODE: RETVAL = Rmpfr_init2_nobless (aTHX_ prec); OUTPUT: RETVAL void Rmpfr_init_set (q, round) mpfr_t * q SV * round PPCODE: PL_markstack_ptr++; Rmpfr_init_set(aTHX_ q, round); return; void Rmpfr_init_set_ui (q, round) SV * q SV * round PPCODE: PL_markstack_ptr++; Rmpfr_init_set_ui(aTHX_ q, round); return; void Rmpfr_init_set_si (q, round) SV * q SV * round PPCODE: PL_markstack_ptr++; Rmpfr_init_set_si(aTHX_ q, round); return; void Rmpfr_init_set_d (q, round) SV * q SV * round PPCODE: PL_markstack_ptr++; Rmpfr_init_set_d(aTHX_ q, round); return; void Rmpfr_init_set_ld (q, round) SV * q SV * round PPCODE: PL_markstack_ptr++; Rmpfr_init_set_ld(aTHX_ q, round); return; void Rmpfr_init_set_f (q, round) mpf_t * q SV * round PPCODE: PL_markstack_ptr++; Rmpfr_init_set_f(aTHX_ q, round); return; void Rmpfr_init_set_z (q, round) mpz_t * q SV * round PPCODE: PL_markstack_ptr++; Rmpfr_init_set_z(aTHX_ q, round); return; void Rmpfr_init_set_q (q, round) mpq_t * q SV * round PPCODE: PL_markstack_ptr++; Rmpfr_init_set_q(aTHX_ q, round); return; void Rmpfr_init_set_str (q, base, round) SV * q SV * base SV * round PPCODE: PL_markstack_ptr++; Rmpfr_init_set_str(aTHX_ q, base, round); return; void Rmpfr_init_set_nobless (q, round) mpfr_t * q SV * round PPCODE: PL_markstack_ptr++; Rmpfr_init_set_nobless(aTHX_ q, round); return; void Rmpfr_init_set_ui_nobless (q, round) SV * q SV * round PPCODE: PL_markstack_ptr++; Rmpfr_init_set_ui_nobless(aTHX_ q, round); return; void Rmpfr_init_set_si_nobless (q, round) SV * q SV * round PPCODE: PL_markstack_ptr++; Rmpfr_init_set_si_nobless(aTHX_ q, round); return; void Rmpfr_init_set_d_nobless (q, round) SV * q SV * round PPCODE: PL_markstack_ptr++; Rmpfr_init_set_d_nobless(aTHX_ q, round); return; void Rmpfr_init_set_ld_nobless (q, round) SV * q SV * round PPCODE: PL_markstack_ptr++; Rmpfr_init_set_ld_nobless(aTHX_ q, round); return; void Rmpfr_init_set_f_nobless (q, round) mpf_t * q SV * round PPCODE: PL_markstack_ptr++; Rmpfr_init_set_f_nobless(aTHX_ q, round); return; void Rmpfr_init_set_z_nobless (q, round) mpz_t * q SV * round PPCODE: PL_markstack_ptr++; Rmpfr_init_set_z_nobless(aTHX_ q, round); return; void Rmpfr_init_set_q_nobless (q, round) mpq_t * q SV * round PPCODE: PL_markstack_ptr++; Rmpfr_init_set_q_nobless(aTHX_ q, round); return; void Rmpfr_init_set_str_nobless (q, base, round) SV * q SV * base SV * round PPCODE: PL_markstack_ptr++; Rmpfr_init_set_str_nobless(aTHX_ q, base, round); return; void Rmpfr_deref2 (p, base, n_digits, round) mpfr_t * p SV * base SV * n_digits SV * round PPCODE: PL_markstack_ptr++; Rmpfr_deref2(aTHX_ p, base, n_digits, round); return; void Rmpfr_set_default_prec (prec) SV * prec PPCODE: Rmpfr_set_default_prec(aTHX_ prec); XSRETURN_EMPTY; /* return empty stack */ SV * Rmpfr_get_default_prec () CODE: RETVAL = Rmpfr_get_default_prec (aTHX); OUTPUT: RETVAL SV * Rmpfr_min_prec (x) mpfr_t * x CODE: RETVAL = Rmpfr_min_prec (aTHX_ x); OUTPUT: RETVAL void Rmpfr_set_prec (p, prec) mpfr_t * p SV * prec PPCODE: Rmpfr_set_prec(aTHX_ p, prec); XSRETURN_EMPTY; /* return empty stack */ void Rmpfr_set_prec_raw (p, prec) mpfr_t * p SV * prec PPCODE: Rmpfr_set_prec_raw(aTHX_ p, prec); XSRETURN_EMPTY; /* return empty stack */ SV * Rmpfr_get_prec (p) mpfr_t * p CODE: RETVAL = Rmpfr_get_prec (aTHX_ p); OUTPUT: RETVAL SV * Rmpfr_set (p, q, round) mpfr_t * p mpfr_t * q SV * round CODE: RETVAL = Rmpfr_set (aTHX_ p, q, round); OUTPUT: RETVAL SV * Rmpfr_set_ui (p, q, round) mpfr_t * p SV * q SV * round CODE: RETVAL = Rmpfr_set_ui (aTHX_ p, q, round); OUTPUT: RETVAL SV * Rmpfr_set_si (p, q, round) mpfr_t * p SV * q SV * round CODE: RETVAL = Rmpfr_set_si (aTHX_ p, q, round); OUTPUT: RETVAL SV * Rmpfr_set_uj (p, q, round) mpfr_t * p SV * q SV * round CODE: RETVAL = Rmpfr_set_uj (aTHX_ p, q, round); OUTPUT: RETVAL SV * Rmpfr_set_sj (p, q, round) mpfr_t * p SV * q SV * round CODE: RETVAL = Rmpfr_set_sj (aTHX_ p, q, round); OUTPUT: RETVAL int Rmpfr_set_NV (p, q, round) mpfr_t * p SV * q unsigned int round CODE: RETVAL = Rmpfr_set_NV (aTHX_ p, q, round); OUTPUT: RETVAL void Rmpfr_init_set_NV (q, round) SV * q SV * round PPCODE: PL_markstack_ptr++; Rmpfr_init_set_NV(aTHX_ q, round); return; void Rmpfr_init_set_NV_nobless (q, round) SV * q SV * round PPCODE: PL_markstack_ptr++; Rmpfr_init_set_NV_nobless(aTHX_ q, round); return; int Rmpfr_cmp_float128 (a, b) mpfr_t * a SV * b CODE: RETVAL = Rmpfr_cmp_float128 (aTHX_ a, b); OUTPUT: RETVAL int Rmpfr_cmp_NV (a, b) mpfr_t * a SV * b CODE: RETVAL = Rmpfr_cmp_NV (aTHX_ a, b); OUTPUT: RETVAL SV * Rmpfr_set_ld (p, q, round) mpfr_t * p SV * q SV * round CODE: RETVAL = Rmpfr_set_ld (aTHX_ p, q, round); OUTPUT: RETVAL SV * Rmpfr_set_d (p, q, round) mpfr_t * p SV * q SV * round CODE: RETVAL = Rmpfr_set_d (aTHX_ p, q, round); OUTPUT: RETVAL SV * Rmpfr_set_z (p, q, round) mpfr_t * p mpz_t * q SV * round CODE: RETVAL = Rmpfr_set_z (aTHX_ p, q, round); OUTPUT: RETVAL SV * Rmpfr_set_q (p, q, round) mpfr_t * p mpq_t * q SV * round CODE: RETVAL = Rmpfr_set_q (aTHX_ p, q, round); OUTPUT: RETVAL SV * Rmpfr_set_f (p, q, round) mpfr_t * p mpf_t * q SV * round CODE: RETVAL = Rmpfr_set_f (aTHX_ p, q, round); OUTPUT: RETVAL int Rmpfr_set_str (p, num, base, round) mpfr_t * p SV * num SV * base SV * round CODE: RETVAL = Rmpfr_set_str (aTHX_ p, num, base, round); OUTPUT: RETVAL void Rmpfr_set_inf (p, sign) mpfr_t * p int sign PPCODE: Rmpfr_set_inf(p, sign); XSRETURN_EMPTY; /* return empty stack */ void Rmpfr_set_nan (p) mpfr_t * p PPCODE: Rmpfr_set_nan(p); XSRETURN_EMPTY; /* return empty stack */ void Rmpfr_swap (p, q) mpfr_t * p mpfr_t * q PPCODE: Rmpfr_swap(p, q); XSRETURN_EMPTY; /* return empty stack */ SV * Rmpfr_get_d (p, round) mpfr_t * p SV * round CODE: RETVAL = Rmpfr_get_d (aTHX_ p, round); OUTPUT: RETVAL SV * Rmpfr_get_d_2exp (exp, p, round) SV * exp mpfr_t * p SV * round CODE: RETVAL = Rmpfr_get_d_2exp (aTHX_ exp, p, round); OUTPUT: RETVAL SV * Rmpfr_get_ld_2exp (exp, p, round) SV * exp mpfr_t * p SV * round CODE: RETVAL = Rmpfr_get_ld_2exp (aTHX_ exp, p, round); OUTPUT: RETVAL SV * Rmpfr_get_ld (p, round) mpfr_t * p SV * round CODE: RETVAL = Rmpfr_get_ld (aTHX_ p, round); OUTPUT: RETVAL double Rmpfr_get_d1 (p) mpfr_t * p SV * Rmpfr_get_z_2exp (z, p) mpz_t * z mpfr_t * p CODE: RETVAL = Rmpfr_get_z_2exp (aTHX_ z, p); OUTPUT: RETVAL SV * Rmpfr_add (a, b, c, round) mpfr_t * a mpfr_t * b mpfr_t * c SV * round CODE: RETVAL = Rmpfr_add (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_add_ui (a, b, c, round) mpfr_t * a mpfr_t * b SV * c SV * round CODE: RETVAL = Rmpfr_add_ui (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_add_d (a, b, c, round) mpfr_t * a mpfr_t * b SV * c SV * round CODE: RETVAL = Rmpfr_add_d (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_add_si (a, b, c, round) mpfr_t * a mpfr_t * b SV * c SV * round CODE: RETVAL = Rmpfr_add_si (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_add_z (a, b, c, round) mpfr_t * a mpfr_t * b mpz_t * c SV * round CODE: RETVAL = Rmpfr_add_z (aTHX_ a, b, c, round); OUTPUT: RETVAL void Rmpfr_get_q (a, b) mpq_t * a mpfr_t * b PPCODE: Rmpfr_get_q(a, b); XSRETURN_EMPTY; /* return empty stack */ SV * Rmpfr_add_q (a, b, c, round) mpfr_t * a mpfr_t * b mpq_t * c SV * round CODE: RETVAL = Rmpfr_add_q (aTHX_ a, b, c, round); OUTPUT: RETVAL void q_add_fr (a, b, c) mpq_t * a mpq_t * b mpfr_t * c PPCODE: q_add_fr(a, b, c); XSRETURN_EMPTY; /* return empty stack */ SV * Rmpfr_sub (a, b, c, round) mpfr_t * a mpfr_t * b mpfr_t * c SV * round CODE: RETVAL = Rmpfr_sub (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_sub_ui (a, b, c, round) mpfr_t * a mpfr_t * b SV * c SV * round CODE: RETVAL = Rmpfr_sub_ui (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_sub_d (a, b, c, round) mpfr_t * a mpfr_t * b SV * c SV * round CODE: RETVAL = Rmpfr_sub_d (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_sub_z (a, b, c, round) mpfr_t * a mpfr_t * b mpz_t * c SV * round CODE: RETVAL = Rmpfr_sub_z (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_sub_q (a, b, c, round) mpfr_t * a mpfr_t * b mpq_t * c SV * round CODE: RETVAL = Rmpfr_sub_q (aTHX_ a, b, c, round); OUTPUT: RETVAL void q_sub_fr (a, b, c) mpq_t * a mpq_t * b mpfr_t * c PPCODE: q_sub_fr(a, b, c); XSRETURN_EMPTY; /* return empty stack */ SV * Rmpfr_ui_sub (a, b, c, round) mpfr_t * a SV * b mpfr_t * c SV * round CODE: RETVAL = Rmpfr_ui_sub (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_d_sub (a, b, c, round) mpfr_t * a SV * b mpfr_t * c SV * round CODE: RETVAL = Rmpfr_d_sub (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_mul (a, b, c, round) mpfr_t * a mpfr_t * b mpfr_t * c SV * round CODE: RETVAL = Rmpfr_mul (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_mul_ui (a, b, c, round) mpfr_t * a mpfr_t * b SV * c SV * round CODE: RETVAL = Rmpfr_mul_ui (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_mul_d (a, b, c, round) mpfr_t * a mpfr_t * b SV * c SV * round CODE: RETVAL = Rmpfr_mul_d (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_mul_z (a, b, c, round) mpfr_t * a mpfr_t * b mpz_t * c SV * round CODE: RETVAL = Rmpfr_mul_z (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_mul_q (a, b, c, round) mpfr_t * a mpfr_t * b mpq_t * c SV * round CODE: RETVAL = Rmpfr_mul_q (aTHX_ a, b, c, round); OUTPUT: RETVAL void q_mul_fr (a, b, c) mpq_t * a mpq_t * b mpfr_t * c PPCODE: q_mul_fr(a, b, c); XSRETURN_EMPTY; /* return empty stack */ SV * Rmpfr_dim (rop, op1, op2, round) mpfr_t * rop mpfr_t * op1 mpfr_t * op2 SV * round CODE: RETVAL = Rmpfr_dim (aTHX_ rop, op1, op2, round); OUTPUT: RETVAL SV * Rmpfr_div (a, b, c, round) mpfr_t * a mpfr_t * b mpfr_t * c SV * round CODE: RETVAL = Rmpfr_div (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_div_ui (a, b, c, round) mpfr_t * a mpfr_t * b SV * c SV * round CODE: RETVAL = Rmpfr_div_ui (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_div_d (a, b, c, round) mpfr_t * a mpfr_t * b SV * c SV * round CODE: RETVAL = Rmpfr_div_d (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_div_z (a, b, c, round) mpfr_t * a mpfr_t * b mpz_t * c SV * round CODE: RETVAL = Rmpfr_div_z (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_div_q (a, b, c, round) mpfr_t * a mpfr_t * b mpq_t * c SV * round CODE: RETVAL = Rmpfr_div_q (aTHX_ a, b, c, round); OUTPUT: RETVAL void q_div_fr (a, b, c) mpq_t * a mpq_t * b mpfr_t * c PPCODE: q_div_fr(a, b, c); XSRETURN_EMPTY; /* return empty stack */ void q_fmod_fr (a, b, c) mpq_t * a mpq_t * b mpfr_t * c PREINIT: I32* temp; PPCODE: temp = PL_markstack_ptr++; q_fmod_fr(a, b, c); if (PL_markstack_ptr != temp) { /* truly void, because dXSARGS not invoked */ PL_markstack_ptr = temp; XSRETURN_EMPTY; /* return empty stack */ } /* must have used dXSARGS; list context implied */ return; SV * Rmpfr_ui_div (a, b, c, round) mpfr_t * a SV * b mpfr_t * c SV * round CODE: RETVAL = Rmpfr_ui_div (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_d_div (a, b, c, round) mpfr_t * a SV * b mpfr_t * c SV * round CODE: RETVAL = Rmpfr_d_div (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_sqrt (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_sqrt (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_rec_sqrt (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_rec_sqrt (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_cbrt (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_cbrt (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_sqrt_ui (a, b, round) mpfr_t * a SV * b SV * round CODE: RETVAL = Rmpfr_sqrt_ui (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_pow_ui (a, b, c, round) mpfr_t * a mpfr_t * b SV * c SV * round CODE: RETVAL = Rmpfr_pow_ui (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_pow_uj (a, b, c, round) mpfr_t * a mpfr_t * b SV * c SV * round CODE: RETVAL = Rmpfr_pow_uj (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_pow_IV (a, b, c, round) mpfr_t * a mpfr_t * b SV * c SV * round CODE: RETVAL = Rmpfr_pow_IV (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_ui_pow_ui (a, b, c, round) mpfr_t * a SV * b SV * c SV * round CODE: RETVAL = Rmpfr_ui_pow_ui (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_ui_pow (a, b, c, round) mpfr_t * a SV * b mpfr_t * c SV * round CODE: RETVAL = Rmpfr_ui_pow (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_pow_si (a, b, c, round) mpfr_t * a mpfr_t * b SV * c SV * round CODE: RETVAL = Rmpfr_pow_si (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_pow_sj (a, b, c, round) mpfr_t * a mpfr_t * b SV * c SV * round CODE: RETVAL = Rmpfr_pow_sj (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_pow (a, b, c, round) mpfr_t * a mpfr_t * b mpfr_t * c SV * round CODE: RETVAL = Rmpfr_pow (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_powr (a, b, c, round) mpfr_t * a mpfr_t * b mpfr_t * c SV * round CODE: RETVAL = Rmpfr_powr (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_pown (a, b, c, round) mpfr_t * a mpfr_t * b SV * c SV * round CODE: RETVAL = Rmpfr_pown (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_compound_si (a, b, c, round) mpfr_t * a mpfr_t * b SV * c SV * round CODE: RETVAL = Rmpfr_compound_si (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_compound (a, b, c, round) mpfr_t * a mpfr_t * b mpfr_t * c SV * round CODE: RETVAL = Rmpfr_compound (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_neg (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_neg (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_abs (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_abs (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_mul_2exp (a, b, c, round) mpfr_t * a mpfr_t * b SV * c SV * round CODE: RETVAL = Rmpfr_mul_2exp (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_mul_2ui (a, b, c, round) mpfr_t * a mpfr_t * b SV * c SV * round CODE: RETVAL = Rmpfr_mul_2ui (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_mul_2si (a, b, c, round) mpfr_t * a mpfr_t * b SV * c SV * round CODE: RETVAL = Rmpfr_mul_2si (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_div_2exp (a, b, c, round) mpfr_t * a mpfr_t * b SV * c SV * round CODE: RETVAL = Rmpfr_div_2exp (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_div_2ui (a, b, c, round) mpfr_t * a mpfr_t * b SV * c SV * round CODE: RETVAL = Rmpfr_div_2ui (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_div_2si (a, b, c, round) mpfr_t * a mpfr_t * b SV * c SV * round CODE: RETVAL = Rmpfr_div_2si (aTHX_ a, b, c, round); OUTPUT: RETVAL int Rmpfr_total_order_p (a, b) mpfr_t * a mpfr_t * b int Rmpfr_cmp (a, b) mpfr_t * a mpfr_t * b int Rmpfr_cmpabs (a, b) mpfr_t * a mpfr_t * b int Rmpfr_cmpabs_ui (a, b) mpfr_t * a unsigned long b int Rmpfr_cmp_ui (a, b) mpfr_t * a unsigned long b int Rmpfr_cmp_si (a, b) mpfr_t * a long b int Rmpfr_cmp_uj (a, b) mpfr_t * a UV b CODE: RETVAL = Rmpfr_cmp_uj (aTHX_ a, b); OUTPUT: RETVAL int Rmpfr_cmp_sj (a, b) mpfr_t * a IV b CODE: RETVAL = Rmpfr_cmp_sj (aTHX_ a, b); OUTPUT: RETVAL int Rmpfr_cmp_IV (a, b) mpfr_t * a SV * b CODE: RETVAL = Rmpfr_cmp_IV (aTHX_ a, b); OUTPUT: RETVAL int Rmpfr_cmp_d (a, b) mpfr_t * a double b int Rmpfr_cmp_ld (a, b) mpfr_t * a SV * b CODE: RETVAL = Rmpfr_cmp_ld (aTHX_ a, b); OUTPUT: RETVAL int Rmpfr_cmp_ui_2exp (a, b, c) mpfr_t * a SV * b SV * c CODE: RETVAL = Rmpfr_cmp_ui_2exp (aTHX_ a, b, c); OUTPUT: RETVAL int Rmpfr_cmp_si_2exp (a, b, c) mpfr_t * a SV * b SV * c CODE: RETVAL = Rmpfr_cmp_si_2exp (aTHX_ a, b, c); OUTPUT: RETVAL int Rmpfr_eq (a, b, c) mpfr_t * a mpfr_t * b unsigned long c int Rmpfr_nan_p (p) mpfr_t * p int Rmpfr_inf_p (p) mpfr_t * p int Rmpfr_number_p (p) mpfr_t * p void Rmpfr_reldiff (a, b, c, round) mpfr_t * a mpfr_t * b mpfr_t * c SV * round PPCODE: Rmpfr_reldiff(aTHX_ a, b, c, round); XSRETURN_EMPTY; /* return empty stack */ int Rmpfr_sgn (p) mpfr_t * p int Rmpfr_greater_p (a, b) mpfr_t * a mpfr_t * b int Rmpfr_greaterequal_p (a, b) mpfr_t * a mpfr_t * b int Rmpfr_less_p (a, b) mpfr_t * a mpfr_t * b int Rmpfr_lessequal_p (a, b) mpfr_t * a mpfr_t * b int Rmpfr_lessgreater_p (a, b) mpfr_t * a mpfr_t * b int Rmpfr_equal_p (a, b) mpfr_t * a mpfr_t * b int Rmpfr_unordered_p (a, b) mpfr_t * a mpfr_t * b SV * Rmpfr_sin_cos (a, b, c, round) mpfr_t * a mpfr_t * b mpfr_t * c SV * round CODE: RETVAL = Rmpfr_sin_cos (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_sinh_cosh (a, b, c, round) mpfr_t * a mpfr_t * b mpfr_t * c SV * round CODE: RETVAL = Rmpfr_sinh_cosh (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_sin (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_sin (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_sinu (a, b, c, round) mpfr_t * a mpfr_t * b unsigned long c SV * round CODE: RETVAL = Rmpfr_sinu (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_sinpi (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_sinpi (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_cos (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_cos (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_cosu (a, b, c, round) mpfr_t * a mpfr_t * b unsigned long c SV * round CODE: RETVAL = Rmpfr_cosu (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_cospi (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_cospi (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_tan (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_tan (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_tanu (a, b, c, round) mpfr_t * a mpfr_t * b unsigned long c SV * round CODE: RETVAL = Rmpfr_tanu (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_tanpi (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_tanpi (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_asin (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_asin (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_asinu (a, b, c, round) mpfr_t * a mpfr_t * b unsigned long c SV * round CODE: RETVAL = Rmpfr_asinu (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_asinpi (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_asinpi (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_acos (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_acos (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_acosu (a, b, c, round) mpfr_t * a mpfr_t * b unsigned long c SV * round CODE: RETVAL = Rmpfr_acosu (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_acospi (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_acospi (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_atan (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_atan (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_atanu (a, b, c, round) mpfr_t * a mpfr_t * b unsigned long c SV * round CODE: RETVAL = Rmpfr_atanu (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_atanpi (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_atanpi (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_sinh (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_sinh (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_cosh (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_cosh (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_tanh (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_tanh (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_asinh (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_asinh (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_acosh (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_acosh (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_atanh (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_atanh (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_fac_ui (a, b, round) mpfr_t * a SV * b SV * round CODE: RETVAL = Rmpfr_fac_ui (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_log1p (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_log1p (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_expm1 (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_expm1 (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_exp2m1 (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_exp2m1 (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_exp10m1 (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_exp10m1 (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_log2 (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_log2 (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_log2p1 (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_log2p1 (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_log10 (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_log10 (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_log10p1 (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_log10p1 (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_fma (a, b, c, d, round) mpfr_t * a mpfr_t * b mpfr_t * c mpfr_t * d SV * round CODE: RETVAL = Rmpfr_fma (aTHX_ a, b, c, d, round); OUTPUT: RETVAL SV * Rmpfr_fms (a, b, c, d, round) mpfr_t * a mpfr_t * b mpfr_t * c mpfr_t * d SV * round CODE: RETVAL = Rmpfr_fms (aTHX_ a, b, c, d, round); OUTPUT: RETVAL SV * Rmpfr_agm (a, b, c, round) mpfr_t * a mpfr_t * b mpfr_t * c SV * round CODE: RETVAL = Rmpfr_agm (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_hypot (a, b, c, round) mpfr_t * a mpfr_t * b mpfr_t * c SV * round CODE: RETVAL = Rmpfr_hypot (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_const_log2 (p, round) mpfr_t * p SV * round CODE: RETVAL = Rmpfr_const_log2 (aTHX_ p, round); OUTPUT: RETVAL SV * Rmpfr_const_pi (p, round) mpfr_t * p SV * round CODE: RETVAL = Rmpfr_const_pi (aTHX_ p, round); OUTPUT: RETVAL SV * Rmpfr_const_euler (p, round) mpfr_t * p SV * round CODE: RETVAL = Rmpfr_const_euler (aTHX_ p, round); OUTPUT: RETVAL SV * Rmpfr_rint (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_rint (aTHX_ a, b, round); OUTPUT: RETVAL int Rmpfr_ceil (a, b) mpfr_t * a mpfr_t * b int Rmpfr_floor (a, b) mpfr_t * a mpfr_t * b int Rmpfr_round (a, b) mpfr_t * a mpfr_t * b int Rmpfr_trunc (a, b) mpfr_t * a mpfr_t * b SV * Rmpfr_can_round (p, err, round1, round2, prec) mpfr_t * p SV * err SV * round1 SV * round2 SV * prec CODE: RETVAL = Rmpfr_can_round (aTHX_ p, err, round1, round2, prec); OUTPUT: RETVAL SV * Rmpfr_print_rnd_mode (rnd) SV * rnd CODE: RETVAL = Rmpfr_print_rnd_mode (aTHX_ rnd); OUTPUT: RETVAL SV * Rmpfr_get_emin () CODE: RETVAL = Rmpfr_get_emin (aTHX); OUTPUT: RETVAL SV * Rmpfr_get_emax () CODE: RETVAL = Rmpfr_get_emax (aTHX); OUTPUT: RETVAL int Rmpfr_set_emin (e) SV * e CODE: RETVAL = Rmpfr_set_emin (aTHX_ e); OUTPUT: RETVAL int Rmpfr_set_emax (e) SV * e CODE: RETVAL = Rmpfr_set_emax (aTHX_ e); OUTPUT: RETVAL SV * Rmpfr_check_range (p, t, round) mpfr_t * p SV * t SV * round CODE: RETVAL = Rmpfr_check_range (aTHX_ p, t, round); OUTPUT: RETVAL void Rmpfr_clear_underflow () PPCODE: Rmpfr_clear_underflow(); XSRETURN_EMPTY; /* return empty stack */ void Rmpfr_clear_overflow () PPCODE: Rmpfr_clear_overflow(); XSRETURN_EMPTY; /* return empty stack */ void Rmpfr_clear_nanflag () PPCODE: Rmpfr_clear_nanflag(); XSRETURN_EMPTY; /* return empty stack */ void Rmpfr_clear_inexflag () PPCODE: Rmpfr_clear_inexflag(); XSRETURN_EMPTY; /* return empty stack */ void Rmpfr_clear_flags () PPCODE: Rmpfr_clear_flags(); XSRETURN_EMPTY; /* return empty stack */ int Rmpfr_underflow_p () int Rmpfr_overflow_p () int Rmpfr_nanflag_p () int Rmpfr_inexflag_p () SV * Rmpfr_log (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_log (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_exp (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_exp (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_exp2 (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_exp2 (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_exp10 (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_exp10 (aTHX_ a, b, round); OUTPUT: RETVAL void Rmpfr_urandomb (x, ...) SV * x PPCODE: PL_markstack_ptr++; Rmpfr_urandomb(aTHX_ x); XSRETURN_EMPTY; /* return empty stack */ void Rmpfr_random2 (p, s, exp) mpfr_t * p SV * s SV * exp PPCODE: Rmpfr_random2(aTHX_ p, s, exp); XSRETURN_EMPTY; /* return empty stack */ SV * _TRmpfr_out_str (stream, base, dig, p, round) FILE * stream SV * base SV * dig mpfr_t * p SV * round CODE: RETVAL = _TRmpfr_out_str (aTHX_ stream, base, dig, p, round); OUTPUT: RETVAL SV * _Rmpfr_out_str (p, base, dig, round) mpfr_t * p SV * base SV * dig SV * round CODE: RETVAL = _Rmpfr_out_str (aTHX_ p, base, dig, round); OUTPUT: RETVAL SV * _TRmpfr_out_strS (stream, base, dig, p, round, suff) FILE * stream SV * base SV * dig mpfr_t * p SV * round SV * suff CODE: RETVAL = _TRmpfr_out_strS (aTHX_ stream, base, dig, p, round, suff); OUTPUT: RETVAL SV * _TRmpfr_out_strP (pre, stream, base, dig, p, round) SV * pre FILE * stream SV * base SV * dig mpfr_t * p SV * round CODE: RETVAL = _TRmpfr_out_strP (aTHX_ pre, stream, base, dig, p, round); OUTPUT: RETVAL SV * _TRmpfr_out_strPS (pre, stream, base, dig, p, round, suff) SV * pre FILE * stream SV * base SV * dig mpfr_t * p SV * round SV * suff CODE: RETVAL = _TRmpfr_out_strPS (aTHX_ pre, stream, base, dig, p, round, suff); OUTPUT: RETVAL SV * _Rmpfr_out_strS (p, base, dig, round, suff) mpfr_t * p SV * base SV * dig SV * round SV * suff CODE: RETVAL = _Rmpfr_out_strS (aTHX_ p, base, dig, round, suff); OUTPUT: RETVAL SV * _Rmpfr_out_strP (pre, p, base, dig, round) SV * pre mpfr_t * p SV * base SV * dig SV * round CODE: RETVAL = _Rmpfr_out_strP (aTHX_ pre, p, base, dig, round); OUTPUT: RETVAL SV * _Rmpfr_out_strPS (pre, p, base, dig, round, suff) SV * pre mpfr_t * p SV * base SV * dig SV * round SV * suff CODE: RETVAL = _Rmpfr_out_strPS (aTHX_ pre, p, base, dig, round, suff); OUTPUT: RETVAL SV * TRmpfr_inp_str (p, stream, base, round) mpfr_t * p FILE * stream SV * base SV * round CODE: RETVAL = TRmpfr_inp_str (aTHX_ p, stream, base, round); OUTPUT: RETVAL SV * Rmpfr_inp_str (p, base, round) mpfr_t * p SV * base SV * round CODE: RETVAL = Rmpfr_inp_str (aTHX_ p, base, round); OUTPUT: RETVAL SV * Rmpfr_gamma (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_gamma (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_zeta (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_zeta (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_zeta_ui (a, b, round) mpfr_t * a SV * b SV * round CODE: RETVAL = Rmpfr_zeta_ui (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_erf (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_erf (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_frac (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_frac (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_remainder (a, b, c, round) mpfr_t * a mpfr_t * b mpfr_t * c SV * round CODE: RETVAL = Rmpfr_remainder (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_modf (a, b, c, round) mpfr_t * a mpfr_t * b mpfr_t * c SV * round CODE: RETVAL = Rmpfr_modf (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_fmod (a, b, c, round) mpfr_t * a mpfr_t * b mpfr_t * c SV * round CODE: RETVAL = Rmpfr_fmod (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_fmod_ui (a, b, c, round) mpfr_t * a mpfr_t * b unsigned long c SV * round CODE: RETVAL = Rmpfr_fmod_ui (aTHX_ a, b, c, round); OUTPUT: RETVAL void Rmpfr_remquo (a, b, c, round) mpfr_t * a mpfr_t * b mpfr_t * c SV * round PPCODE: PL_markstack_ptr++; Rmpfr_remquo(aTHX_ a, b, c, round); return; int Rmpfr_integer_p (p) mpfr_t * p void Rmpfr_nexttoward (a, b) mpfr_t * a mpfr_t * b PPCODE: Rmpfr_nexttoward(a, b); XSRETURN_EMPTY; /* return empty stack */ void Rmpfr_nextabove (p) mpfr_t * p PPCODE: Rmpfr_nextabove(p); XSRETURN_EMPTY; /* return empty stack */ void Rmpfr_nextbelow (p) mpfr_t * p PPCODE: Rmpfr_nextbelow(p); XSRETURN_EMPTY; /* return empty stack */ SV * Rmpfr_min (a, b, c, round) mpfr_t * a mpfr_t * b mpfr_t * c SV * round CODE: RETVAL = Rmpfr_min (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_max (a, b, c, round) mpfr_t * a mpfr_t * b mpfr_t * c SV * round CODE: RETVAL = Rmpfr_max (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_get_exp (p) mpfr_t * p CODE: RETVAL = Rmpfr_get_exp (aTHX_ p); OUTPUT: RETVAL SV * Rmpfr_set_exp (p, exp) mpfr_t * p SV * exp CODE: RETVAL = Rmpfr_set_exp (aTHX_ p, exp); OUTPUT: RETVAL int Rmpfr_signbit (op) mpfr_t * op SV * Rmpfr_setsign (rop, op, sign, round) mpfr_t * rop mpfr_t * op SV * sign SV * round CODE: RETVAL = Rmpfr_setsign (aTHX_ rop, op, sign, round); OUTPUT: RETVAL SV * Rmpfr_copysign (rop, op1, op2, round) mpfr_t * rop mpfr_t * op1 mpfr_t * op2 SV * round CODE: RETVAL = Rmpfr_copysign (aTHX_ rop, op1, op2, round); OUTPUT: RETVAL SV * get_refcnt (s) SV * s CODE: RETVAL = get_refcnt (aTHX_ s); OUTPUT: RETVAL SV * get_package_name (x) SV * x CODE: RETVAL = get_package_name (aTHX_ x); OUTPUT: RETVAL void Rmpfr_dump (a) mpfr_t * a PPCODE: Rmpfr_dump(a); XSRETURN_EMPTY; /* return empty stack */ SV * gmp_v () CODE: RETVAL = gmp_v (aTHX); OUTPUT: RETVAL SV * Rmpfr_set_ui_2exp (a, b, c, round) mpfr_t * a SV * b SV * c SV * round CODE: RETVAL = Rmpfr_set_ui_2exp (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_set_si_2exp (a, b, c, round) mpfr_t * a SV * b SV * c SV * round CODE: RETVAL = Rmpfr_set_si_2exp (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_set_uj_2exp (a, b, c, round) mpfr_t * a SV * b SV * c SV * round CODE: RETVAL = Rmpfr_set_uj_2exp (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_set_sj_2exp (a, b, c, round) mpfr_t * a SV * b SV * c SV * round CODE: RETVAL = Rmpfr_set_sj_2exp (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_get_z (a, b, round) mpz_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_get_z (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_si_sub (a, c, b, round) mpfr_t * a SV * c mpfr_t * b SV * round CODE: RETVAL = Rmpfr_si_sub (aTHX_ a, c, b, round); OUTPUT: RETVAL SV * Rmpfr_sub_si (a, b, c, round) mpfr_t * a mpfr_t * b SV * c SV * round CODE: RETVAL = Rmpfr_sub_si (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_mul_si (a, b, c, round) mpfr_t * a mpfr_t * b SV * c SV * round CODE: RETVAL = Rmpfr_mul_si (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_si_div (a, b, c, round) mpfr_t * a SV * b mpfr_t * c SV * round CODE: RETVAL = Rmpfr_si_div (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_div_si (a, b, c, round) mpfr_t * a mpfr_t * b SV * c SV * round CODE: RETVAL = Rmpfr_div_si (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_sqr (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_sqr (aTHX_ a, b, round); OUTPUT: RETVAL int Rmpfr_cmp_z (a, b) mpfr_t * a mpz_t * b int Rmpfr_cmp_q (a, b) mpfr_t * a mpq_t * b int fr_cmp_q_rounded (a, b, round) mpfr_t * a mpq_t * b SV * round CODE: RETVAL = fr_cmp_q_rounded (aTHX_ a, b, round); OUTPUT: RETVAL int Rmpfr_cmp_f (a, b) mpfr_t * a mpf_t * b int Rmpfr_zero_p (a) mpfr_t * a void Rmpfr_free_cache () PPCODE: Rmpfr_free_cache(); XSRETURN_EMPTY; /* return empty stack */ void Rmpfr_free_cache2 (way) unsigned int way PPCODE: Rmpfr_free_cache2(way); XSRETURN_EMPTY; /* return empty stack */ void Rmpfr_free_pool () PPCODE: Rmpfr_free_pool(); XSRETURN_EMPTY; /* return empty stack */ SV * Rmpfr_get_version () CODE: RETVAL = Rmpfr_get_version (aTHX); OUTPUT: RETVAL SV * Rmpfr_get_patches () CODE: RETVAL = Rmpfr_get_patches (aTHX); OUTPUT: RETVAL SV * Rmpfr_get_emin_min () CODE: RETVAL = Rmpfr_get_emin_min (aTHX); OUTPUT: RETVAL SV * Rmpfr_get_emin_max () CODE: RETVAL = Rmpfr_get_emin_max (aTHX); OUTPUT: RETVAL SV * Rmpfr_get_emax_min () CODE: RETVAL = Rmpfr_get_emax_min (aTHX); OUTPUT: RETVAL SV * Rmpfr_get_emax_max () CODE: RETVAL = Rmpfr_get_emax_max (aTHX); OUTPUT: RETVAL void Rmpfr_clear_erangeflag () PPCODE: Rmpfr_clear_erangeflag(); XSRETURN_EMPTY; /* return empty stack */ int Rmpfr_erangeflag_p () SV * Rmpfr_rint_round (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_rint_round (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_rint_trunc (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_rint_trunc (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_rint_ceil (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_rint_ceil (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_rint_floor (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_rint_floor (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_get_ui (a, round) mpfr_t * a SV * round CODE: RETVAL = Rmpfr_get_ui (aTHX_ a, round); OUTPUT: RETVAL SV * Rmpfr_get_si (a, round) mpfr_t * a SV * round CODE: RETVAL = Rmpfr_get_si (aTHX_ a, round); OUTPUT: RETVAL SV * Rmpfr_get_uj (a, round) mpfr_t * a SV * round CODE: RETVAL = Rmpfr_get_uj (aTHX_ a, round); OUTPUT: RETVAL SV * Rmpfr_get_sj (a, round) mpfr_t * a SV * round CODE: RETVAL = Rmpfr_get_sj (aTHX_ a, round); OUTPUT: RETVAL SV * Rmpfr_get_IV (x, round) mpfr_t * x SV * round CODE: RETVAL = Rmpfr_get_IV (aTHX_ x, round); OUTPUT: RETVAL int Rmpfr_set_IV (x, sv, round) mpfr_t * x SV * sv SV * round CODE: RETVAL = Rmpfr_set_IV (aTHX_ x, sv, round); OUTPUT: RETVAL void Rmpfr_init_set_IV (q, round) SV * q SV * round PPCODE: PL_markstack_ptr++; Rmpfr_init_set_IV(aTHX_ q, round); return; void Rmpfr_init_set_IV_nobless (q, round) SV * q SV * round PPCODE: PL_markstack_ptr++; Rmpfr_init_set_IV_nobless(aTHX_ q, round); return; SV * Rmpfr_get_NV (x, round) mpfr_t * x SV * round CODE: RETVAL = Rmpfr_get_NV (aTHX_ x, round); OUTPUT: RETVAL SV * Rmpfr_fits_ulong_p (a, round) mpfr_t * a SV * round CODE: RETVAL = Rmpfr_fits_ulong_p (aTHX_ a, round); OUTPUT: RETVAL SV * Rmpfr_fits_slong_p (a, round) mpfr_t * a SV * round CODE: RETVAL = Rmpfr_fits_slong_p (aTHX_ a, round); OUTPUT: RETVAL SV * Rmpfr_fits_ushort_p (a, round) mpfr_t * a SV * round CODE: RETVAL = Rmpfr_fits_ushort_p (aTHX_ a, round); OUTPUT: RETVAL SV * Rmpfr_fits_sshort_p (a, round) mpfr_t * a SV * round CODE: RETVAL = Rmpfr_fits_sshort_p (aTHX_ a, round); OUTPUT: RETVAL SV * Rmpfr_fits_uint_p (a, round) mpfr_t * a SV * round CODE: RETVAL = Rmpfr_fits_uint_p (aTHX_ a, round); OUTPUT: RETVAL SV * Rmpfr_fits_sint_p (a, round) mpfr_t * a SV * round CODE: RETVAL = Rmpfr_fits_sint_p (aTHX_ a, round); OUTPUT: RETVAL SV * Rmpfr_fits_uintmax_p (a, round) mpfr_t * a SV * round CODE: RETVAL = Rmpfr_fits_uintmax_p (aTHX_ a, round); OUTPUT: RETVAL SV * Rmpfr_fits_intmax_p (a, round) mpfr_t * a SV * round CODE: RETVAL = Rmpfr_fits_intmax_p (aTHX_ a, round); OUTPUT: RETVAL SV * Rmpfr_fits_IV_p (x, round) mpfr_t * x SV * round CODE: RETVAL = Rmpfr_fits_IV_p (aTHX_ x, round); OUTPUT: RETVAL SV * Rmpfr_strtofr (a, str, base, round) mpfr_t * a SV * str SV * base SV * round CODE: RETVAL = Rmpfr_strtofr (aTHX_ a, str, base, round); OUTPUT: RETVAL void Rmpfr_set_erangeflag () PPCODE: Rmpfr_set_erangeflag(); XSRETURN_EMPTY; /* return empty stack */ void Rmpfr_set_underflow () PPCODE: Rmpfr_set_underflow(); XSRETURN_EMPTY; /* return empty stack */ void Rmpfr_set_overflow () PPCODE: Rmpfr_set_overflow(); XSRETURN_EMPTY; /* return empty stack */ void Rmpfr_set_nanflag () PPCODE: Rmpfr_set_nanflag(); XSRETURN_EMPTY; /* return empty stack */ void Rmpfr_set_inexflag () PPCODE: Rmpfr_set_inexflag(); XSRETURN_EMPTY; /* return empty stack */ SV * Rmpfr_erfc (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_erfc (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_j0 (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_j0 (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_j1 (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_j1 (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_jn (a, n, b, round) mpfr_t * a SV * n mpfr_t * b SV * round CODE: RETVAL = Rmpfr_jn (aTHX_ a, n, b, round); OUTPUT: RETVAL SV * Rmpfr_y0 (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_y0 (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_y1 (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_y1 (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_yn (a, n, b, round) mpfr_t * a SV * n mpfr_t * b SV * round CODE: RETVAL = Rmpfr_yn (aTHX_ a, n, b, round); OUTPUT: RETVAL SV * Rmpfr_atan2 (a, b, c, round) mpfr_t * a mpfr_t * b mpfr_t * c SV * round CODE: RETVAL = Rmpfr_atan2 (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_atan2u (a, b, c, d, round) mpfr_t * a mpfr_t * b mpfr_t * c unsigned long d SV * round CODE: RETVAL = Rmpfr_atan2u (aTHX_ a, b, c, d, round); OUTPUT: RETVAL SV * Rmpfr_atan2pi (a, b, c, round) mpfr_t * a mpfr_t * b mpfr_t * c SV * round CODE: RETVAL = Rmpfr_atan2pi (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_pow_z (a, b, c, round) mpfr_t * a mpfr_t * b mpz_t * c SV * round CODE: RETVAL = Rmpfr_pow_z (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_subnormalize (a, b, round) mpfr_t * a SV * b SV * round CODE: RETVAL = Rmpfr_subnormalize (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_const_catalan (a, round) mpfr_t * a SV * round CODE: RETVAL = Rmpfr_const_catalan (aTHX_ a, round); OUTPUT: RETVAL SV * Rmpfr_sec (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_sec (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_csc (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_csc (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_cot (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_cot (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_root (a, b, c, round) mpfr_t * a mpfr_t * b SV * c SV * round CODE: RETVAL = Rmpfr_root (aTHX_ a, b, c, round); OUTPUT: RETVAL SV * Rmpfr_eint (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_eint (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_li2 (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_li2 (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_get_f (a, b, round) mpf_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_get_f (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_sech (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_sech (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_csch (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_csch (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_coth (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_coth (aTHX_ a, b, round); OUTPUT: RETVAL SV * Rmpfr_lngamma (a, b, round) mpfr_t * a mpfr_t * b SV * round CODE: RETVAL = Rmpfr_lngamma (aTHX_ a, b, round); OUTPUT: RETVAL void Rmpfr_lgamma (a, b, round) mpfr_t * a mpfr_t * b SV * round PPCODE: PL_markstack_ptr++; Rmpfr_lgamma(aTHX_ a, b, round); return; SV * _MPFR_VERSION () CODE: RETVAL = _MPFR_VERSION (aTHX); OUTPUT: RETVAL SV * _MPFR_VERSION_MAJOR () CODE: RETVAL = _MPFR_VERSION_MAJOR (aTHX); OUTPUT: RETVAL SV * _MPFR_VERSION_MINOR () CODE: RETVAL = _MPFR_VERSION_MINOR (aTHX); OUTPUT: RETVAL SV * _MPFR_VERSION_PATCHLEVEL () CODE: RETVAL = _MPFR_VERSION_PATCHLEVEL (aTHX); OUTPUT: RETVAL SV * _MPFR_VERSION_STRING () CODE: RETVAL = _MPFR_VERSION_STRING (aTHX); OUTPUT: RETVAL SV * RMPFR_VERSION_NUM (a, b, c) SV * a SV * b SV * c CODE: RETVAL = RMPFR_VERSION_NUM (aTHX_ a, b, c); OUTPUT: RETVAL SV * Rmpfr_sum (rop, avref, len, round) mpfr_t * rop SV * avref SV * len SV * round CODE: RETVAL = Rmpfr_sum (aTHX_ rop, avref, len, round); OUTPUT: RETVAL void _fr_to_q (q, fr) mpq_t * q mpfr_t * fr PPCODE: _fr_to_q(q, fr); XSRETURN_EMPTY; /* return empty stack */ int Rmpfr_q_div (rop, q, fr, round) mpfr_t * rop mpq_t * q mpfr_t * fr int round int Rmpfr_z_div (rop, z, fr, round) mpfr_t * rop mpz_t * z mpfr_t * fr int round SV * overload_mul (a, b, third) SV * a SV * b SV * third CODE: RETVAL = overload_mul (aTHX_ a, b, third); OUTPUT: RETVAL SV * overload_add (a, b, third) SV * a SV * b SV * third CODE: RETVAL = overload_add (aTHX_ a, b, third); OUTPUT: RETVAL SV * overload_sub (a, b, third) SV * a SV * b SV * third CODE: RETVAL = overload_sub (aTHX_ a, b, third); OUTPUT: RETVAL SV * overload_div (a, b, third) SV * a SV * b SV * third CODE: RETVAL = overload_div (aTHX_ a, b, third); OUTPUT: RETVAL SV * overload_copy (p, b, third) mpfr_t * p SV * b SV * third CODE: RETVAL = overload_copy (aTHX_ p, b, third); OUTPUT: RETVAL SV * overload_abs (p, b, third) mpfr_t * p SV * b SV * third CODE: RETVAL = overload_abs (aTHX_ p, b, third); OUTPUT: RETVAL SV * overload_gt (a, b, third) mpfr_t * a SV * b SV * third CODE: RETVAL = overload_gt (aTHX_ a, b, third); OUTPUT: RETVAL SV * overload_gte (a, b, third) mpfr_t * a SV * b SV * third CODE: RETVAL = overload_gte (aTHX_ a, b, third); OUTPUT: RETVAL SV * overload_lt (a, b, third) mpfr_t * a SV * b SV * third CODE: RETVAL = overload_lt (aTHX_ a, b, third); OUTPUT: RETVAL SV * overload_lte (a, b, third) mpfr_t * a SV * b SV * third CODE: RETVAL = overload_lte (aTHX_ a, b, third); OUTPUT: RETVAL SV * overload_spaceship (a, b, third) mpfr_t * a SV * b SV * third CODE: RETVAL = overload_spaceship (aTHX_ a, b, third); OUTPUT: RETVAL SV * overload_equiv (a, b, third) mpfr_t * a SV * b SV * third CODE: RETVAL = overload_equiv (aTHX_ a, b, third); OUTPUT: RETVAL SV * overload_not_equiv (a, b, third) mpfr_t * a SV * b SV * third CODE: RETVAL = overload_not_equiv (aTHX_ a, b, third); OUTPUT: RETVAL SV * overload_true (a, b, third) mpfr_t * a SV * b SV * third CODE: RETVAL = overload_true (aTHX_ a, b, third); OUTPUT: RETVAL SV * overload_not (a, b, third) mpfr_t * a SV * b SV * third CODE: RETVAL = overload_not (aTHX_ a, b, third); OUTPUT: RETVAL SV * overload_sqrt (p, b, third) mpfr_t * p SV * b SV * third CODE: RETVAL = overload_sqrt (aTHX_ p, b, third); OUTPUT: RETVAL SV * overload_pow (p, b, third) SV * p SV * b SV * third CODE: RETVAL = overload_pow (aTHX_ p, b, third); OUTPUT: RETVAL SV * overload_log (p, b, third) mpfr_t * p SV * b SV * third CODE: RETVAL = overload_log (aTHX_ p, b, third); OUTPUT: RETVAL SV * log_2 (p) mpfr_t * p CODE: RETVAL = log_2 (aTHX_ p); OUTPUT: RETVAL SV * log_10 (p) mpfr_t * p CODE: RETVAL = log_10 (aTHX_ p); OUTPUT: RETVAL SV * overload_exp (p, b, third) mpfr_t * p SV * b SV * third CODE: RETVAL = overload_exp (aTHX_ p, b, third); OUTPUT: RETVAL SV * overload_sin (p, b, third) mpfr_t * p SV * b SV * third CODE: RETVAL = overload_sin (aTHX_ p, b, third); OUTPUT: RETVAL SV * sind (p) mpfr_t * p CODE: RETVAL = sind (aTHX_ p); OUTPUT: RETVAL SV * overload_cos (p, b, third) mpfr_t * p SV * b SV * third CODE: RETVAL = overload_cos (aTHX_ p, b, third); OUTPUT: RETVAL SV * cosd (p) mpfr_t * p CODE: RETVAL = cosd (aTHX_ p); OUTPUT: RETVAL SV * tangent (p) mpfr_t * p CODE: RETVAL = tangent (aTHX_ p); OUTPUT: RETVAL SV * tand (p) mpfr_t * p CODE: RETVAL = tand (aTHX_ p); OUTPUT: RETVAL SV * overload_int (p, b, third) mpfr_t * p SV * b SV * third CODE: RETVAL = overload_int (aTHX_ p, b, third); OUTPUT: RETVAL SV * overload_atan2 (a, b, third) mpfr_t * a SV * b SV * third CODE: RETVAL = overload_atan2 (aTHX_ a, b, third); OUTPUT: RETVAL SV * Rmpfr_randinit_default_nobless () CODE: RETVAL = Rmpfr_randinit_default_nobless (aTHX); OUTPUT: RETVAL SV * Rmpfr_randinit_mt_nobless () CODE: RETVAL = Rmpfr_randinit_mt_nobless (aTHX); OUTPUT: RETVAL SV * Rmpfr_randinit_lc_2exp_nobless (a, c, m2exp) SV * a SV * c SV * m2exp CODE: RETVAL = Rmpfr_randinit_lc_2exp_nobless (aTHX_ a, c, m2exp); OUTPUT: RETVAL SV * Rmpfr_randinit_lc_2exp_size_nobless (size) SV * size CODE: RETVAL = Rmpfr_randinit_lc_2exp_size_nobless (aTHX_ size); OUTPUT: RETVAL void Rmpfr_randclear (p) SV * p PPCODE: Rmpfr_randclear(aTHX_ p); XSRETURN_EMPTY; /* return empty stack */ void Rmpfr_randseed (state, seed) SV * state SV * seed PPCODE: Rmpfr_randseed(aTHX_ state, seed); XSRETURN_EMPTY; /* return empty stack */ void Rmpfr_randseed_ui (state, seed) SV * state SV * seed PPCODE: Rmpfr_randseed_ui(aTHX_ state, seed); XSRETURN_EMPTY; /* return empty stack */ SV * overload_pow_eq (p, b, third) SV * p SV * b SV * third CODE: RETVAL = overload_pow_eq (aTHX_ p, b, third); OUTPUT: RETVAL SV * overload_div_eq (a, b, third) SV * a SV * b SV * third CODE: RETVAL = overload_div_eq (aTHX_ a, b, third); OUTPUT: RETVAL SV * overload_sub_eq (a, b, third) SV * a SV * b SV * third CODE: RETVAL = overload_sub_eq (aTHX_ a, b, third); OUTPUT: RETVAL SV * overload_add_eq (a, b, third) SV * a SV * b SV * third CODE: RETVAL = overload_add_eq (aTHX_ a, b, third); OUTPUT: RETVAL SV * overload_mul_eq (a, b, third) SV * a SV * b SV * third CODE: RETVAL = overload_mul_eq (aTHX_ a, b, third); OUTPUT: RETVAL SV * _itsa (a) SV * a CODE: RETVAL = _itsa (aTHX_ a); OUTPUT: RETVAL int _has_longlong () int _has_longdouble () int _ivsize_bits () PROTOTYPES: ENABLE SV * RMPFR_PREC_MAX () CODE: RETVAL = RMPFR_PREC_MAX (aTHX); OUTPUT: RETVAL SV * RMPFR_PREC_MIN () CODE: RETVAL = RMPFR_PREC_MIN (aTHX); OUTPUT: RETVAL PROTOTYPES: DISABLE SV * wrap_mpfr_printf (a, b) SV * a SV * b CODE: RETVAL = wrap_mpfr_printf (aTHX_ a, b); OUTPUT: RETVAL SV * wrap_mpfr_fprintf (stream, a, b) FILE * stream SV * a SV * b CODE: RETVAL = wrap_mpfr_fprintf (aTHX_ stream, a, b); OUTPUT: RETVAL SV * wrap_mpfr_sprintf (s, a, b, buflen) SV * s SV * a SV * b int buflen CODE: RETVAL = wrap_mpfr_sprintf (aTHX_ s, a, b, buflen); OUTPUT: RETVAL SV * wrap_mpfr_snprintf (s, bytes, a, b, buflen) SV * s SV * bytes SV * a SV * b int buflen CODE: RETVAL = wrap_mpfr_snprintf (aTHX_ s, bytes, a, b, buflen); OUTPUT: RETVAL SV * wrap_mpfr_printf_rnd (a, round, b) SV * a SV * round SV * b CODE: RETVAL = wrap_mpfr_printf_rnd (aTHX_ a, round, b); OUTPUT: RETVAL SV * wrap_mpfr_fprintf_rnd (stream, a, round, b) FILE * stream SV * a SV * round SV * b CODE: RETVAL = wrap_mpfr_fprintf_rnd (aTHX_ stream, a, round, b); OUTPUT: RETVAL SV * wrap_mpfr_sprintf_rnd (s, a, round, b, buflen) SV * s SV * a SV * round SV * b int buflen CODE: RETVAL = wrap_mpfr_sprintf_rnd (aTHX_ s, a, round, b, buflen); OUTPUT: RETVAL SV * wrap_mpfr_snprintf_rnd (s, bytes, a, round, b, buflen) SV * s SV * bytes SV * a SV * round SV * b int buflen CODE: RETVAL = wrap_mpfr_snprintf_rnd (aTHX_ s, bytes, a, round, b, buflen); OUTPUT: RETVAL SV * Rmpfr_buildopt_tls_p () CODE: RETVAL = Rmpfr_buildopt_tls_p (aTHX); OUTPUT: RETVAL SV * Rmpfr_buildopt_float16_p () CODE: RETVAL = Rmpfr_buildopt_float16_p (aTHX); OUTPUT: RETVAL SV * Rmpfr_buildopt_decimal_p () CODE: RETVAL = Rmpfr_buildopt_decimal_p (aTHX); OUTPUT: RETVAL SV * Rmpfr_regular_p (a) mpfr_t * a CODE: RETVAL = Rmpfr_regular_p (aTHX_ a); OUTPUT: RETVAL void Rmpfr_set_zero (a, sign) mpfr_t * a SV * sign PPCODE: Rmpfr_set_zero(aTHX_ a, sign); XSRETURN_EMPTY; /* return empty stack */ SV * Rmpfr_digamma (rop, op, round) mpfr_t * rop mpfr_t * op SV * round CODE: RETVAL = Rmpfr_digamma (aTHX_ rop, op, round); OUTPUT: RETVAL SV * Rmpfr_trigamma (rop, op, round) mpfr_t * rop mpfr_t * op SV * round CODE: RETVAL = Rmpfr_trigamma (aTHX_ rop, op, round); OUTPUT: RETVAL SV * Rmpfr_ai (rop, op, round) mpfr_t * rop mpfr_t * op SV * round CODE: RETVAL = Rmpfr_ai (aTHX_ rop, op, round); OUTPUT: RETVAL SV * Rmpfr_get_flt (a, round) mpfr_t * a SV * round CODE: RETVAL = Rmpfr_get_flt (aTHX_ a, round); OUTPUT: RETVAL SV * Rmpfr_get_float16 (a, round) mpfr_t * a SV * round CODE: RETVAL = Rmpfr_get_float16 (aTHX_ a, round); OUTPUT: RETVAL SV * Rmpfr_set_flt (rop, f, round) mpfr_t * rop SV * f SV * round CODE: RETVAL = Rmpfr_set_flt (aTHX_ rop, f, round); OUTPUT: RETVAL SV * Rmpfr_set_float16 (rop, f, round) mpfr_t * rop SV * f SV * round CODE: RETVAL = Rmpfr_set_float16 (aTHX_ rop, f, round); OUTPUT: RETVAL SV * Rmpfr_urandom (rop, state, round) mpfr_t * rop gmp_randstate_t * state SV * round CODE: RETVAL = Rmpfr_urandom (aTHX_ rop, state, round); OUTPUT: RETVAL SV * Rmpfr_set_z_2exp (rop, op, exp, round) mpfr_t * rop mpz_t * op SV * exp SV * round CODE: RETVAL = Rmpfr_set_z_2exp (aTHX_ rop, op, exp, round); OUTPUT: RETVAL SV * Rmpfr_buildopt_tune_case () CODE: RETVAL = Rmpfr_buildopt_tune_case (aTHX); OUTPUT: RETVAL SV * Rmpfr_frexp (exp, rop, op, round) SV * exp mpfr_t * rop mpfr_t * op SV * round CODE: RETVAL = Rmpfr_frexp (aTHX_ exp, rop, op, round); OUTPUT: RETVAL SV * Rmpfr_z_sub (rop, op1, op2, round) mpfr_t * rop mpz_t * op1 mpfr_t * op2 SV * round CODE: RETVAL = Rmpfr_z_sub (aTHX_ rop, op1, op2, round); OUTPUT: RETVAL SV * Rmpfr_grandom (rop1, rop2, state, round) mpfr_t * rop1 mpfr_t * rop2 gmp_randstate_t * state SV * round CODE: RETVAL = Rmpfr_grandom (aTHX_ rop1, rop2, state, round); OUTPUT: RETVAL void Rmpfr_clear_divby0 () PPCODE: Rmpfr_clear_divby0(aTHX); XSRETURN_EMPTY; /* return empty stack */ void Rmpfr_set_divby0 () PPCODE: Rmpfr_set_divby0(aTHX); XSRETURN_EMPTY; /* return empty stack */ SV * Rmpfr_divby0_p () CODE: RETVAL = Rmpfr_divby0_p (aTHX); OUTPUT: RETVAL SV * Rmpfr_buildopt_gmpinternals_p () CODE: RETVAL = Rmpfr_buildopt_gmpinternals_p (aTHX); OUTPUT: RETVAL SV * _get_xs_version () CODE: RETVAL = _get_xs_version (aTHX); OUTPUT: RETVAL void overload_inc (a, b, third) SV * a SV * b SV * third PPCODE: overload_inc(aTHX_ a, b, third); XSRETURN_EMPTY; /* return empty stack */ void overload_dec (a, b, third) SV * a SV * b SV * third PPCODE: overload_dec(aTHX_ a, b, third); XSRETURN_EMPTY; /* return empty stack */ SV * _overload_lshift (a, b, third) mpfr_t * a SV * b SV * third CODE: RETVAL = _overload_lshift (aTHX_ a, b, third); OUTPUT: RETVAL SV * _overload_rshift (a, b, third) mpfr_t * a SV * b SV * third CODE: RETVAL = _overload_rshift (aTHX_ a, b, third); OUTPUT: RETVAL SV * _overload_lshift_eq (a, b, third) SV * a SV * b SV * third CODE: RETVAL = _overload_lshift_eq (aTHX_ a, b, third); OUTPUT: RETVAL SV * _overload_rshift_eq (a, b, third) SV * a SV * b SV * third CODE: RETVAL = _overload_rshift_eq (aTHX_ a, b, third); OUTPUT: RETVAL SV * _wrap_count () CODE: RETVAL = _wrap_count (aTHX); OUTPUT: RETVAL SV * Rmpfr_set_LD (rop, op, rnd) mpfr_t * rop SV * op SV * rnd CODE: RETVAL = Rmpfr_set_LD (aTHX_ rop, op, rnd); OUTPUT: RETVAL SV * Rmpfr_set_DECIMAL64 (rop, op, rnd) mpfr_t * rop SV * op SV * rnd CODE: RETVAL = Rmpfr_set_DECIMAL64 (aTHX_ rop, op, rnd); OUTPUT: RETVAL SV * Rmpfr_set_DECIMAL128 (rop, op, rnd) mpfr_t * rop SV * op SV * rnd CODE: RETVAL = Rmpfr_set_DECIMAL128 (aTHX_ rop, op, rnd); OUTPUT: RETVAL void Rmpfr_get_LD (rop, op, rnd) SV * rop mpfr_t * op SV * rnd PPCODE: Rmpfr_get_LD(aTHX_ rop, op, rnd); XSRETURN_EMPTY; /* return empty stack */ void Rmpfr_get_DECIMAL64 (rop, op, rnd) SV * rop mpfr_t * op SV * rnd PPCODE: Rmpfr_get_DECIMAL64(aTHX_ rop, op, rnd); XSRETURN_EMPTY; /* return empty stack */ void Rmpfr_get_DECIMAL128 (rop, op, rnd) SV * rop mpfr_t * op SV * rnd PPCODE: Rmpfr_get_DECIMAL128(aTHX_ rop, op, rnd); XSRETURN_EMPTY; /* return empty stack */ int _MPFR_WANT_DECIMAL_FLOATS () int _MPFR_WANT_DECIMAL64 () int _MPFR_WANT_DECIMAL128 () int _MPFR_WANT_FLOAT128 () SV * _max_base () CODE: RETVAL = _max_base (aTHX); OUTPUT: RETVAL SV * _isobject (x) SV * x CODE: RETVAL = _isobject (aTHX_ x); OUTPUT: RETVAL void _mp_sizes () PPCODE: PL_markstack_ptr++; _mp_sizes(); return; SV * _ivsize () CODE: RETVAL = _ivsize (aTHX); OUTPUT: RETVAL SV * _nvsize () CODE: RETVAL = _nvsize (aTHX); OUTPUT: RETVAL SV * _FLT128_DIG () CODE: RETVAL = _FLT128_DIG (aTHX); OUTPUT: RETVAL SV * _LDBL_DIG () CODE: RETVAL = _LDBL_DIG (aTHX); OUTPUT: RETVAL SV * _DBL_DIG () CODE: RETVAL = _DBL_DIG (aTHX); OUTPUT: RETVAL SV * _FLT128_MANT_DIG () CODE: RETVAL = _FLT128_MANT_DIG (aTHX); OUTPUT: RETVAL SV * _LDBL_MANT_DIG () CODE: RETVAL = _LDBL_MANT_DIG (aTHX); OUTPUT: RETVAL SV * _DBL_MANT_DIG () CODE: RETVAL = _DBL_MANT_DIG (aTHX); OUTPUT: RETVAL SV * Rmpfr_get_float128 (op, rnd) mpfr_t * op SV * rnd CODE: RETVAL = Rmpfr_get_float128 (aTHX_ op, rnd); OUTPUT: RETVAL void Rmpfr_get_FLOAT128 (rop, op, rnd) SV * rop mpfr_t * op SV * rnd PPCODE: Rmpfr_get_FLOAT128(aTHX_ rop, op, rnd); XSRETURN_EMPTY; /* return empty stack */ SV * Rmpfr_set_FLOAT128 (rop, op, rnd) mpfr_t * rop SV * op SV * rnd CODE: RETVAL = Rmpfr_set_FLOAT128 (aTHX_ rop, op, rnd); OUTPUT: RETVAL SV * Rmpfr_set_float128 (rop, q, rnd) mpfr_t * rop SV * q SV * rnd CODE: RETVAL = Rmpfr_set_float128 (aTHX_ rop, q, rnd); OUTPUT: RETVAL void Rmpfr_init_set_float128 (q, round) SV * q SV * round PPCODE: PL_markstack_ptr++; Rmpfr_init_set_float128(aTHX_ q, round); return; void Rmpfr_init_set_float128_nobless (q, round) SV * q SV * round PPCODE: PL_markstack_ptr++; Rmpfr_init_set_float128_nobless(aTHX_ q, round); return; SV * _is_readonly (sv) SV * sv CODE: RETVAL = _is_readonly (aTHX_ sv); OUTPUT: RETVAL void _readonly_on (sv) SV * sv PPCODE: _readonly_on(aTHX_ sv); XSRETURN_EMPTY; /* return empty stack */ void _readonly_off (sv) SV * sv PPCODE: _readonly_off(aTHX_ sv); XSRETURN_EMPTY; /* return empty stack */ int _can_pass_float128 () int _mpfr_want_float128 () int nnumflag () int nok_pokflag () void clear_nnum () PPCODE: clear_nnum(); XSRETURN_EMPTY; /* return empty stack */ void clear_nok_pok () PPCODE: clear_nok_pok(); XSRETURN_EMPTY; /* return empty stack */ void set_nnum (x) int x PPCODE: set_nnum(x); XSRETURN_EMPTY; /* return empty stack */ void set_nok_pok (x) int x PPCODE: set_nok_pok(x); XSRETURN_EMPTY; /* return empty stack */ SV * _d_bytes (str) SV * str CODE: RETVAL = _d_bytes (aTHX_ str); OUTPUT: RETVAL SV * _bytes_fr (str, bits) mpfr_t * str unsigned long bits CODE: RETVAL = _bytes_fr (aTHX_ str, bits); OUTPUT: RETVAL SV * _dd_bytes (str) SV * str CODE: RETVAL = _dd_bytes (aTHX_ str); OUTPUT: RETVAL SV * _ld_bytes (str) SV * str CODE: RETVAL = _ld_bytes (aTHX_ str); OUTPUT: RETVAL SV * _f128_bytes (str) SV * str CODE: RETVAL = _f128_bytes (aTHX_ str); OUTPUT: RETVAL int _required_ldbl_mant_dig () SV * _GMP_LIMB_BITS () CODE: RETVAL = _GMP_LIMB_BITS (aTHX); OUTPUT: RETVAL SV * _GMP_NAIL_BITS () CODE: RETVAL = _GMP_NAIL_BITS (aTHX); OUTPUT: RETVAL void Rmpfr_fmodquo (a, b, c, round) mpfr_t * a mpfr_t * b mpfr_t * c SV * round PPCODE: PL_markstack_ptr++; Rmpfr_fmodquo(aTHX_ a, b, c, round); return; int Rmpfr_fpif_export (stream, op) FILE * stream mpfr_t * op CODE: RETVAL = Rmpfr_fpif_export (aTHX_ stream, op); OUTPUT: RETVAL int Rmpfr_fpif_import (op, stream) mpfr_t * op FILE * stream CODE: RETVAL = Rmpfr_fpif_import (aTHX_ op, stream); OUTPUT: RETVAL void Rmpfr_flags_clear (mask) unsigned int mask PPCODE: Rmpfr_flags_clear(mask); XSRETURN_EMPTY; /* return empty stack */ void Rmpfr_flags_set (mask) unsigned int mask PPCODE: Rmpfr_flags_set(mask); XSRETURN_EMPTY; /* return empty stack */ unsigned int Rmpfr_flags_test (mask) unsigned int mask unsigned int Rmpfr_flags_save () void Rmpfr_flags_restore (flags, mask) unsigned int flags unsigned int mask PPCODE: Rmpfr_flags_restore(flags, mask); XSRETURN_EMPTY; /* return empty stack */ int Rmpfr_rint_roundeven (rop, op, round) mpfr_t * rop mpfr_t * op int round int Rmpfr_roundeven (rop, op) mpfr_t * rop mpfr_t * op int Rmpfr_nrandom (rop, state, round) mpfr_t * rop gmp_randstate_t * state int round int Rmpfr_erandom (rop, state, round) mpfr_t * rop gmp_randstate_t * state int round int Rmpfr_fmma (rop, op1, op2, op3, op4, round) mpfr_t * rop mpfr_t * op1 mpfr_t * op2 mpfr_t * op3 mpfr_t * op4 int round int Rmpfr_fmms (rop, op1, op2, op3, op4, round) mpfr_t * rop mpfr_t * op1 mpfr_t * op2 mpfr_t * op3 mpfr_t * op4 int round int Rmpfr_log_ui (rop, op, round) mpfr_t * rop unsigned long op int round int Rmpfr_gamma_inc (rop, op1, op2, round) mpfr_t * rop mpfr_t * op1 mpfr_t * op2 int round int _have_IEEE_754_long_double () int _have_extended_precision_long_double () int nanflag_bug () SV * Rmpfr_buildopt_float128_p () CODE: RETVAL = Rmpfr_buildopt_float128_p (aTHX); OUTPUT: RETVAL SV * Rmpfr_buildopt_sharedcache_p () CODE: RETVAL = Rmpfr_buildopt_sharedcache_p (aTHX); OUTPUT: RETVAL int _nv_is_float128 () int _SvNOK (in) SV * in CODE: RETVAL = _SvNOK (aTHX_ in); OUTPUT: RETVAL int _SvPOK (in) SV * in CODE: RETVAL = _SvPOK (aTHX_ in); OUTPUT: RETVAL SV * _lsb (a) mpfr_t * a CODE: RETVAL = _lsb (aTHX_ a); OUTPUT: RETVAL int Rmpfr_rec_root (rop, op, root, round) mpfr_t * rop mpfr_t * op unsigned long root SV * round CODE: RETVAL = Rmpfr_rec_root (aTHX_ rop, op, root, round); OUTPUT: RETVAL int Rmpfr_beta (rop, op1, op2, round) mpfr_t * rop mpfr_t * op1 mpfr_t * op2 int round int Rmpfr_rootn_ui (rop, op, k, round) mpfr_t * rop mpfr_t * op unsigned long k int round int _ld_subnormal_bug () double atodouble (str) char * str SV * atonv (str) SV * str CODE: RETVAL = atonv (aTHX_ str); OUTPUT: RETVAL SV * Rmpfr_get_str_ndigits_alt (base, prec) int base UV prec CODE: RETVAL = Rmpfr_get_str_ndigits_alt (aTHX_ base, prec); OUTPUT: RETVAL SV * Rmpfr_get_str_ndigits (base, prec) int base SV * prec CODE: RETVAL = Rmpfr_get_str_ndigits (aTHX_ base, prec); OUTPUT: RETVAL SV * Rmpfr_dot (rop, avref_A, avref_B, len, round) mpfr_t * rop SV * avref_A SV * avref_B SV * len SV * round CODE: RETVAL = Rmpfr_dot (aTHX_ rop, avref_A, avref_B, len, round); OUTPUT: RETVAL SV * _nvtoa (pnv) NV pnv CODE: RETVAL = _nvtoa (aTHX_ pnv); OUTPUT: RETVAL SV * _mpfrtoa (pnv, min_normal_prec) mpfr_t * pnv int min_normal_prec CODE: RETVAL = _mpfrtoa (aTHX_ pnv, min_normal_prec); OUTPUT: RETVAL void set_fallback_flag () PPCODE: PL_markstack_ptr++; set_fallback_flag(aTHX); XSRETURN_EMPTY; /* return empty stack */ SV * doubletoa (sv, ...) SV * sv CODE: PL_markstack_ptr++; RETVAL = doubletoa(aTHX_ sv); OUTPUT: RETVAL int _fallback_notify () SV * _numtoa (in) SV * in CODE: RETVAL = _numtoa (aTHX_ in); OUTPUT: RETVAL void decimalize (a, ...) SV * a PPCODE: PL_markstack_ptr++; decimalize(aTHX_ a); return; int IOK_flag (sv) SV * sv int POK_flag (sv) SV * sv int NOK_flag (sv) SV * sv int _sis_perl_version () int _has_pv_nv_bug () int _sizeof_exp () int _sizeof_prec () int _has_bizarre_infnan () SV * _gmp_cflags () CODE: RETVAL = _gmp_cflags (aTHX); OUTPUT: RETVAL SV * _gmp_cc () CODE: RETVAL = _gmp_cc (aTHX); OUTPUT: RETVAL int _have_float16 () SV * _gmp_printf_nv (a, b) SV * a SV * b CODE: RETVAL = _gmp_printf_nv (aTHX_ a, b); OUTPUT: RETVAL SV * _gmp_fprintf_nv (stream, a, b) FILE * stream SV * a SV * b CODE: RETVAL = _gmp_fprintf_nv (aTHX_ stream, a, b); OUTPUT: RETVAL SV * _gmp_sprintf_nv (s, a, b, buflen) SV * s SV * a SV * b int buflen CODE: RETVAL = _gmp_sprintf_nv (aTHX_ s, a, b, buflen); OUTPUT: RETVAL SV * _gmp_snprintf_nv (s, bytes, a, b, buflen) SV * s SV * bytes SV * a SV * b int buflen CODE: RETVAL = _gmp_snprintf_nv (aTHX_ s, bytes, a, b, buflen); OUTPUT: RETVAL int _looks_like_number (in) SV * in CODE: RETVAL = _looks_like_number (aTHX_ in); OUTPUT: RETVAL SV * _overload_fmod (a, b, third) mpfr_t * a mpfr_t * b SV * third CODE: RETVAL = _overload_fmod (aTHX_ a, b, third); OUTPUT: RETVAL SV * _overload_fmod_eq (a, b, third) SV * a mpfr_t * b SV * third CODE: RETVAL = _overload_fmod_eq (aTHX_ a, b, third); OUTPUT: RETVAL Math-MPFR-4.38/Prec/0000755060175106010010000000000014766136501012562 5ustar OwnerNoneMath-MPFR-4.38/Prec/Makefile.PL0000755060175106010010000000046314765756127014555 0ustar OwnerNoneuse strict; use warnings; use ExtUtils::MakeMaker; our $LIBS; my %options = %{ { 'NAME' => 'Math::MPFR::Prec', 'LIBS' => $LIBS, 'INC' => $INC, 'VERSION_FROM' => 'Prec.pm' } }; WriteMakefile(%options); # Remove the Makefile dependency. Causes problems on a few systems. # sub MY::makefile { '' } Math-MPFR-4.38/Prec/Prec.pm0000755060175106010010000000114614765756127014031 0ustar OwnerNone## This file generated by InlineX::C2XS (version 0.24) using Inline::C (version 0.73) # For an explanation of the existence of this module and the one (prec_cast) function # that it provides, see the FORMATTED OUTPUT section of MPFR.pm's pod. package Math::MPFR::Prec; use strict; use warnings; require Exporter; *import = \&Exporter::import; require DynaLoader; our $VERSION = '4.38'; #$VERSION = eval $VERSION; Math::MPFR::Prec->DynaLoader::bootstrap($VERSION); @Math::MPFR::Prec::EXPORT = (); @Math::MPFR::Prec::EXPORT_OK = (); sub dl_load_flags {0} # Prevent DynaLoader from complaining and croaking 1; Math-MPFR-4.38/Prec/Prec.xs0000755060175106010010000000226714765756127014054 0ustar OwnerNone #ifdef __MINGW32__ #ifndef __USE_MINGW_ANSI_STDIO #define __USE_MINGW_ANSI_STDIO 1 #endif #endif #define PERL_NO_GET_CONTEXT 1 #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "../math_mpfr_include.h" #ifdef OLDPERL #define SvUOK SvIsUV #endif #ifndef Newx # define Newx(v,n,t) New(0,v,n,t) #endif #ifndef mp_prec_t #define mp_prec_t mpfr_prec_t #endif SV * prec_cast(pTHX_ SV * iv) { mp_prec_t * p; SV * obj_ref, * obj; if(!SvIOK(iv)) croak("Arg supplied to Math::MPFR::Prec::prec_cast must be an IV/UV"); Newx(p, 1, mp_prec_t); if(p == NULL) croak("Failed to allocate memory in Math::MPFR::Prec::prec_cast function"); obj_ref = newSV(0); obj = newSVrv(obj_ref, "Math::MPFR::Prec"); *p = (mp_prec_t)SvUVX(iv); sv_setiv(obj, INT2PTR(IV,p)); SvREADONLY_on(obj); return obj_ref; } void DESTROY(pTHX_ SV * rop) { Safefree(INT2PTR(mp_prec_t *, SvIVX(SvRV(rop)))); } MODULE = Math::MPFR::Prec PACKAGE = Math::MPFR::Prec PROTOTYPES: DISABLE SV * prec_cast (iv) SV * iv CODE: RETVAL = prec_cast (aTHX_ iv); OUTPUT: RETVAL void DESTROY (rop) SV * rop PPCODE: DESTROY(aTHX_ rop); XSRETURN_EMPTY; /* return empty stack */ Math-MPFR-4.38/Random/0000755060175106010010000000000014766136501013111 5ustar OwnerNoneMath-MPFR-4.38/Random/Makefile.PL0000755060175106010010000000075314765756127015106 0ustar OwnerNoneuse strict; use warnings; use ExtUtils::MakeMaker; our $LIBS; our $DEFS; $DEFS .= " -DWIN32_FMT_BUG_IGNORE" if $ENV{WIN32_FMT_BUG_IGNORE}; my %options = %{ { 'TYPEMAPS' => [], 'NAME' => 'Math::MPFR::Random', 'LIBS' => $LIBS, 'INC' => $INC, 'DEFINE' => $DEFS, 'VERSION_FROM' => 'Random.pm', 'clean' => { FILES => '*.exe' }, } }; WriteMakefile(%options); # Remove the Makefile dependency. Causes problems on a few systems. # sub MY::makefile { '' } Math-MPFR-4.38/Random/Random.pm0000755060175106010010000000261514765756127014711 0ustar OwnerNone## This file generated by InlineX::C2XS (version 0.24) using Inline::C (version 0.73) package Math::MPFR::Random; use strict; use warnings; require Exporter; *import = \&Exporter::import; require DynaLoader; our $VERSION = '4.38'; #$VERSION = eval $VERSION; Math::MPFR::Random->DynaLoader::bootstrap($VERSION); @Math::MPFR::Random::EXPORT = (); @Math::MPFR::Random::EXPORT_OK = (); sub dl_load_flags {0} # Prevent DynaLoader from complaining and croaking sub _issue_19550 { # https://github.com/Perl/perl5/issues/19550 my $inf = 999 ** (999 ** 999); my $discard = "$inf"; my $inf_copy = $inf; # Using Math::MPFR::Random::_is_NOK_and_POK(): return 1 if(!_is_NOK_and_POK($inf) && _is_NOK_and_POK($inf_copy)); return 0; } sub _buggy { return 0 unless $^O =~ /MSWin/; if(_win32_fmt_bug_ignore()) { warn("This Math::MPFR build was instructed to ignore the WIN32_FMT_BUG, if present"); return 0; } return 0 if _win32_formatting_ok(); return 1; } sub _win32_formatting_ok { # Duplicated in MPFR.pm # Return 1 if either __GMP_CC or __GMP_CFLAGS # include the string '-D__USE_MINGW_ANSI_STDIO'. # Else return 0. my $cc = _gmp_cc(); # __GMP_CC my $cflags = _gmp_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; } 1; Math-MPFR-4.38/Random/Random.xs0000755060175106010010000001200514765756127014721 0ustar OwnerNone #ifdef __MINGW32__ #ifndef __USE_MINGW_ANSI_STDIO #define __USE_MINGW_ANSI_STDIO 1 #endif #endif #define PERL_NO_GET_CONTEXT 1 #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "../math_mpfr_include.h" /* #ifdef _MSC_VER #pragma warning(disable:4700 4715 4716) #endif */ #ifdef OLDPERL #define SvUOK SvIsUV #endif #ifndef Newx # define Newx(v,n,t) New(0,v,n,t) #endif #ifndef Newxz # define Newxz(v,n,t) Newz(0,v,n,t) #endif /* May one day be removed from mpfr.h */ #ifndef mp_rnd_t # define mp_rnd_t mpfr_rnd_t #endif #ifndef mp_prec_t # define mp_prec_t mpfr_prec_t #endif #ifndef __gmpfr_default_rounding_mode #define __gmpfr_default_rounding_mode mpfr_get_default_rounding_mode() #endif SV * Rmpfr_randinit_default(pTHX) { gmp_randstate_t * state; SV * obj_ref, * obj; Newx(state, 1, gmp_randstate_t); if(state == NULL) croak("Failed to allocate memory in Rmpfr_randinit_default function"); obj_ref = newSV(0); obj = newSVrv(obj_ref, "Math::MPFR::Random"); gmp_randinit_default(*state); sv_setiv(obj, INT2PTR(IV,state)); SvREADONLY_on(obj); return obj_ref; } SV * Rmpfr_randinit_mt(pTHX) { gmp_randstate_t * rand_obj; SV * obj_ref, * obj; Newx(rand_obj, 1, gmp_randstate_t); if(rand_obj == NULL) croak("Failed to allocate memory in Math::MPFR::Random::Rmpfr_randinit_mt function"); obj_ref = newSV(0); obj = newSVrv(obj_ref, "Math::MPFR::Random"); gmp_randinit_mt(*rand_obj); sv_setiv(obj, INT2PTR(IV, rand_obj)); SvREADONLY_on(obj); return obj_ref; } SV * Rmpfr_randinit_lc_2exp(pTHX_ SV * a, SV * c, SV * m2exp ) { gmp_randstate_t * state; mpz_t aa; SV * obj_ref, * obj; Newx(state, 1, gmp_randstate_t); if(state == NULL) croak("Failed to allocate memory in Rmpfr_randinit_lc_2exp function"); obj_ref = newSV(0); obj = newSVrv(obj_ref, "Math::MPFR::Random"); if(sv_isobject(a)) { const char* h = HvNAME(SvSTASH(SvRV(a))); if(strEQ(h, "Math::GMP") || strEQ(h, "GMP::Mpz") || strEQ(h, "Math::GMPz")) gmp_randinit_lc_2exp(*state, *(INT2PTR(mpz_t *, SvIVX(SvRV(a)))), (unsigned long)SvUV(c), (unsigned long)SvUV(m2exp)); else croak("First arg to Rmpfr_randinit_lc_2exp is of invalid type"); } else { if(!mpz_init_set_str(aa, SvPV_nolen(a), 0)) { gmp_randinit_lc_2exp(*state, aa, (unsigned long)SvUV(c), (unsigned long)SvUV(m2exp)); mpz_clear(aa); } else croak("Seedstring supplied to Rmpfr_randinit_lc_2exp is not a valid number"); } sv_setiv(obj, INT2PTR(IV,state)); SvREADONLY_on(obj); return obj_ref; } SV * Rmpfr_randinit_lc_2exp_size(pTHX_ SV * size) { gmp_randstate_t * state; SV * obj_ref, * obj; if(SvUV(size) > 128) croak("The argument supplied to Rmpfr_randinit_lc_2exp_size function is too large - ie greater than 128"); Newx(state, 1, gmp_randstate_t); if(state == NULL) croak("Failed to allocate memory in Rmpfr_randinit_lc_2exp_size function"); obj_ref = newSV(0); obj = newSVrv(obj_ref, "Math::MPFR::Random"); if(gmp_randinit_lc_2exp_size(*state, (unsigned long)SvUV(size))) { sv_setiv(obj, INT2PTR(IV,state)); SvREADONLY_on(obj); return obj_ref; } croak("Rmpfr_randinit_lc_2exp_size function failed"); } /* Provide a duplicate of Math::MPFR::_MPFR_VERSION. * * This allows MPFR.pm to determine the value of * * MPFR_VERSION at compile time. */ SV * _MPFR_VERSION(pTHX) { #if defined(MPFR_VERSION) return newSVuv(MPFR_VERSION); #else return &PL_sv_undef; #endif } /* Provide a duplicate of Math::MPFR::_has_pv_nv_bug. * * This allows MPFR.pm to determine the value of * * the constant MPFR_PV_NV_BUG at compile time. */ int _has_pv_nv_bug(void) { #if defined(MPFR_PV_NV_BUG) return 1; #else return 0; #endif } void DESTROY(gmp_randstate_t * p) { gmp_randclear(*p); Safefree(p); } int _is_NOK_and_POK(SV * in) { if(SvNOK(in) && SvPOK(in)) return 1; return 0; } int _win32_fmt_bug_ignore(void) { #if defined(WIN32_FMT_BUG_IGNORE) return 1; #else return 0; #endif } SV * _gmp_cflags(pTHX) { #if defined(__GMP_CFLAGS) return newSVpv(__GMP_CFLAGS, 0); #else return &PL_sv_undef; #endif } SV * _gmp_cc(pTHX) { #if defined(__GMP_CC) return newSVpv(__GMP_CC, 0); #else return &PL_sv_undef; #endif } MODULE = Math::MPFR::Random PACKAGE = Math::MPFR::Random PROTOTYPES: DISABLE SV * Rmpfr_randinit_default () CODE: RETVAL = Rmpfr_randinit_default (aTHX); OUTPUT: RETVAL SV * Rmpfr_randinit_mt () CODE: RETVAL = Rmpfr_randinit_mt (aTHX); OUTPUT: RETVAL SV * Rmpfr_randinit_lc_2exp (a, c, m2exp) SV * a SV * c SV * m2exp CODE: RETVAL = Rmpfr_randinit_lc_2exp (aTHX_ a, c, m2exp); OUTPUT: RETVAL SV * Rmpfr_randinit_lc_2exp_size (size) SV * size CODE: RETVAL = Rmpfr_randinit_lc_2exp_size (aTHX_ size); OUTPUT: RETVAL SV * _MPFR_VERSION () CODE: RETVAL = _MPFR_VERSION (aTHX); OUTPUT: RETVAL int _has_pv_nv_bug () int _is_NOK_and_POK (in) SV * in int _win32_fmt_bug_ignore () SV * _gmp_cflags () CODE: RETVAL = _gmp_cflags (aTHX); OUTPUT: RETVAL SV * _gmp_cc () CODE: RETVAL = _gmp_cc (aTHX); OUTPUT: RETVAL Math-MPFR-4.38/README0000755060175106010010000002511514765756127012573 0ustar OwnerNoneThis module wraps the MPFR library functions. The MPFR library is a C library for multiple-precision floating-point computations with exact rounding (also called correct rounding). It is based on the GMP multiple-precision C library. The main goal of MPFR is to provide a library for multiple-precision floating-point computation which is both efficient and has a well-defined semantics. It copies the good ideas from the ANSI/IEEE-754 standard for double-precision floating-point arithmetic (53-bit mantissa). It also offers a wide range of trig, log, and other functions, and constants. MPFR, like GMP, is free. It is distributed under the GNU Lesser General Public License (GNU Lesser GPL). Because this module wraps the MPFR functions, it requires that both the GMP C library and the MPFR C library have been installed. For the GMP library see: https://gmplib.org For the MPFR library see: https://www.mpfr.org Minimum required version of gmp is gmp-4.2.0. Minimum required version of mpfr is mpfr-3.0.0. You'll get errors if you try to build Math::MPFR against an insufficiently recent version of the mpfr library. Some features of Math::MPFR require later versions of the gmp and mpfr libraries. If the versions are not sufficiently recent, then those features will not be available. To build this module you need perl 5.6.0 or later. I'm not sure of all the requirements to get it to build with earlier versions of perl, but it's definite that the XS code relating to operator overloading will not compile with perl versions prior to 5.6. Build in the usual way: perl Makefile.PL make make test make install make realclean (must be run before re-building.) When building this module, the GMP and MPFR libraries will need to be accessible. If those files are in a location where your compiler does not find them by default, then instead of running 'perl Makefile.PL', you'll need to run: perl Makefile.pl INC="-I/path/to/gmp_includes -I/path/to/mpfr_includes" LIBS="-L/path/to/mpfr_lib -lmpfr -L/path/to/gmp_lib -lgmp" Other commandline args you may want to provide to 'perl Makefile.PL' are D64=1 (for _Decimal64 support), D128=1 (for _Decimal128 support) and F128=1 (for __float128 support). See the Decimal64/128 and Float128 sections (below). There are also some commandline args that provide some debugging of nvtoa() and doubletoa(). See the Debug section below. ======== Checklib ======== During the running of the Makefile.PL a check is run to ensure that the gmp and mpfr libraries can be found when needed. This check can be skipped by: a) providing CHECK=0 as a Makefile.PL commmand line argument or b) by uncommenting the line (about line 19) that begins with: #$checklib = 0; ================================== 64-bit-int and long double support ================================== If your perl's Config reports that 'ivsize' is greater than or equal to 8 && 'ivtype' is not 'long', then Math::MPFR will, by default, be built with access to the Rmpfr_*_uj and Rmpfr_*_sj functions. Else, access to those functions is, by default, denied. Similarly, if your perl's Config reports that 'nvsize' is greater than 8 then Math::MPFR will be built with access to the Rmpfr_*_ld functions. I am contactable by email at sisyphus at(@) cpan dot (.) org. =================================== Decimal64 and Decimal128 conversion =================================== The functions Rmpfr_set_DECIMAL64 and Rmpfr_get_DECIMAL64 allow conversion between Math::Decimal64 (_Decimal64) and Math::MPFR (mpfr_t) objects. For this feature to be available you firstly need a compiler that has the _Decimal64 data type. You'll also need to have a recent version of the mpfr library that has been built with _Decimal64 support (ie that was configured with '--enable-decimal-float'). This should all be detected and enabled automatically whenever these conditions are met. To utilise mpfr's _Decimal64 functionality you also need to install Math::Decimal64. If you wish you can avoid _Decimal64 support by providing D64=0 as an argument to the Makefile.PL - ie run 'perl Makefile.PL D64=0'; You can ensure _Decimal64 support by providing the argument D64=1. Note that forcing 'D64=1' will not work unless the conditions mentioned earlier in this section are met. The above holds true also for the Math::Decimal128 and the _Decimal128 type. Just replace all occurrences of "64" with "128". ========================================================= Conversion between Math::Float128 and Math::MPFR objects ========================================================= If 'perl -V:nvtype' reports __float128, see also the section 'Conversion between __float128 NV and Math::MPFR objects', below. This section deals only with conversion between Math::Float128 and Math::MPFR objects - and if your nvtype is __float128 there's probably nothing to be gained by calling on Math::Float128. The functions Rmpfr_set_FLOAT128 and Rmpfr_get_FLOAT128 allow conversion between Math::Float128 (__float128) and Math::MPFR (mpfr_t) objects. For this feature to be available you firstly need a compiler that has the __float128 data type. You'll also need to have a recent version (4.0.0 or later) of the mpfr library that has been built with __float128 support (ie that was configured with'--enable-float128'). This should all be detected and enabled automatically whenever these conditions are met. To utilise mpfr's __float128 functionality in this way you also need to install Math::Float128. If you wish you can avoid Math::Float128 support by providing F128=0 as an argument to the Makefile.PL - ie run 'perl Makefile.PL F128=0'; You can ensure Math::Float128 support by providing the argument F128=1. You can aternatively override the automated procedure by uncommenting one of a number of lines of code near the start of the Makefile.PL. (The comments in the Makefile.PL are a clear statement of what's required for this.) Note that forcing inclusion of Math::Float128 support will not work unless the conditions mentioned earlier in this section are met. ========================================================== Conversion between Math::LongDouble and Math::MPFR objects ========================================================== There are 2 functions provided for conversion between Math::LongDouble and Math::MPFR objects: Rmpfr_set_LD (assign the value of a Math::LongDouble object to a Math::MPFR object) Rmpfr_get_LD (assign the value of a Math::MPFR object to a Math::Long Double object) If your perl's nvtype is long double, just use Rmpfr_set_ld and Rmpfr_get_ld instead. Math::LongDouble provides 'long double' support for perls whose nvtype is other than 'long double'. ======================================================= Conversion between __float128 NV and Math::MPFR objects ======================================================= To determine your nvtype, run 'perl -V:nvtype'. As of perl-5.21.4 it is possible to build perl with an nvtype of __float128. This is achieved by specifying -Dusequadmath as a Configure arg .... but, it will not work for all architectures and compilers. If $Config{nvtype} specifies '__float128' && if your mpfr library (need 4.0.0 or later) was built with --enable-float128 then you can pass your __float128 NV values to and from Math::MPFR using the Rmpfr_set_float128() and Rmpfr_get_float128() functions. And the overloaded operations will also accept the __float128 NV arguments as one would want. This should all be detected and enabled automatically whenever these conditions are met. NOTE: Even if the mpfr library was not built with __float128 support and the conditions are therefore not met, you can still pass and receive __float128 values to/from Math::MPFR by instead using the functions Rmpfr_get_NV and Rmpfr_set_NV - but that happens only if your nvtype is __float128. If you wish you can avoid __float128 support by providing F128=0 as an argument to the Makefile.PL - ie run 'perl Makefile.PL F128=0'; You can ensure __float128 support by providing the argument F128=1. Note that forcing inclusion of __float128 support will not work unless the conditions mentioned earlier in this section are met. ===== Debug ===== If the Makefile.PL is given an argument that matches /NVTOA_DEBUG/i then intermediate values in nvtoa() will be printed to STDERR. In general, this will produce unwelcome clutter, but the option to build Math::MPFR with -DNVTOA_DEBUG is there, if it's ever useful. If the Makefile.PL is given an argument that matches /DTOA_ASSERT/i then some assertion checks are run at various points in doubletoa(). If the assertion fails, then the program croaks with the relevant diagnostic message. When doubletoa() fails to determine the value of $nv, and falls back to returning sprintf("%.16e", $nv), then the default behaviour is to increase $Math::MPFR::doubletoa_fallback by 1. If you wish to ignore such events, simply provide the Makefie.PL with the argument FB=0 . See the doubletoa() documentation in MPFR.pod. =============================== MS WINDOWS (Visual Studio 2019) =============================== I don't know how to build the gmp and mpfr libraries using Visual Studio 2019, so when building this module with Visual Studio 2019 I build against gmp and mpfr libraries that were built using MinGW-w64. Building with Visual Studio 2019 against *dynamic* gmp/mpfr libraries that were built using a MinGW-w64 compiler is not recommended, as strange results can then arise when calling mpfr functions that take a FILE* argument. If building with Visual Studio 2019 against static gmp/mpfr libs that were built using a MinGW-w64 compiler I first make a copy of the gmp and mpfr libraries (libgmp.a and libmpfr.a) along with copies of the following MinGW-w64 library files: libgcc.a libgcc_s.a libmingwex.a libmingw32.a For each of the 6 copied files, I leave the filename unchanged (though the "lib" at the begining of the name is optional), and change the file extension to ".lib". In making those copies, I've left them in the same directory as the original, but I assume (untested) that the copies could be moved to any location of your choice. Then build this module by cd'ing to the top level Math::MPFR source folder and running: perl Makefile.PL CHECK=0 INC="-IC:/path/to/gmp_header" LIBS="-LC:/path/to/libgcc -lgcc -LC:/path/to/libgcc_s -lgcc_s -LC:/path/to/standard_libs -lmingwex -lmingw32 -LC:/path/to/libgmp -lmpfr -lgmp" nmake test nmake install NOTES The given example "perl Makefile.PL ..." command assumes: 1) that both mpfr.h and gmp.h are in C:/path/to/gmp_header; 2) that libmingwex and libmingw32 libraries are in the same location; 3) that libmpfr.lib and libgmp.lib are in C:/path/to/libgmp. Modify as necessary. Math-MPFR-4.38/t/0000755060175106010010000000000014766136501012134 5ustar OwnerNoneMath-MPFR-4.38/t/anomaly.t0000755060175106010010000000406314765756127014002 0ustar OwnerNone # Here we check that a (somewhat anomalous) behaviour that can # arise when strings are involved in overloaded comparisons with # Math::MPFR objects ('==', '!=', '<', '>', '<=', '>=' and '<=>') # is as expected. # Some of these tests require Math::GMPz. use strict; use warnings; use Math::MPFR; use Config; use Test::More; my $have_mpz = 0; eval {require Math::GMPz;}; $have_mpz++ unless $@; if($Config{ivsize} == 8) { my $f = Math::MPFR->new(2 ** 64); # 0x1p+63 my $i = ~0; # == 18446744073709551615, 1 less than 2 ** 64 cmp_ok($f, '>', $i, '2**64 > 18446744073709551615 (IV)'); # $i is evaluated to its full (64-bit) precision. cmp_ok($f, '==', "$i", '2**64 == "18446744073709551615" (PV)'); # "$i" is rounded to 53-bit precision. if($have_mpz) { # In order to have the string "$i" evaluated to its full 64-bit precision: cmp_ok($f, '>', Math::GMPz->new("$i"), '2**64 > "18446744073709551615" (mpz)'); } } if($Config{nvsize} > 8) { my $f = Math::MPFR->new(2 ** 63); # 9.223372036854775808e18 my $s = sprintf "%.20e", (2 ** 63) + 1; # 9.223372036854775809e18 cmp_ok( $f, '==', $s, '2**63 == (2**63)+1 - RHS is PV'); # $s, (POK): treated as PV if($Config{ivsize} < 8) { cmp_ok($f, '<', $s + 0, '2**63 < (2**63)+1 - RHS is NV'); # '$s + 0', (NOK): treated as NV cmp_ok($f, '==', $s, '2**63 == (2**63)+1 - RHS is again PV'); # $s, (now POK and NOK): treated as PV } else { cmp_ok($f, '<', $s + 0, '2**63 < (2**63)+1 - RHS is IV'); # '$s + 0', (IOK): treated as IV cmp_ok($f, '<', $s, '2**63 < (2**63)+1 - RHS is still IV'); # $s, (now POK and IOK): treated as IV } } my $f = Math::MPFR->new(2 ** 70); # 1180591620717411303424 my $s = '1180591620717411303423'; # 1 less than 2 ** 70; cmp_ok($f, '==', $s, '2**70 == (2**70)-1 - RHS is PV'); # Value of $s is rounded to 53-bit precision. if($have_mpz) { # $s is evaluated to its full (70-bit) precision: cmp_ok($f, '>', Math::GMPz->new($s), '2**70 > (2**70)-1 - RHS is mpz'); } done_testing(); Math-MPFR-4.38/t/anytoa.t0000755060175106010010000004303314765756127013635 0ustar OwnerNoneuse strict; use warnings; use Math::MPFR qw(:mpfr); use Test::More; use Config; my ($op, $op2, $res); # Create an inf portably: my $kludge = Math::MPFR->new(); Rmpfr_set_inf($kludge, 1); # +inf my $inf = Rmpfr_get_NV($kludge, MPFR_RNDN); # %bounds is a copy of %emax_emin, declared in anytoa() my %bounds = (53 => [1024, -1073, -1022 ], 64 => [16384, -16444, -16382], 2098 => [1024], 113 => [16384, -16493, -16382], ); my @exp_53 = ('1.4142135623730951', '0.13999999999999999', '0.1', '5e-324', '8.7001827429576e-311', '2.8481815407166473e-306', '2.0', '0.0', '0.0'); my @nexp_53 = map { "-" . $_} @exp_53; my @exp_64 = ('1.4142135623730950488', '0.14', '0.1', '4.940656458412465442e-324', '8.700182742957616492e-311', '2.8481815407166473465e-306', '2.0', '1.223126e-4943', '1.3771174474187147233e-4928'); my @nexp_64 = map { "-" . $_} @exp_64; my @exp_113 = ('1.414213562373095048801688724209698', '0.13999999999999999999999999999999999', '0.1', '4.940656458412465441765687928682214e-324', '8.700182742957616491956667080939156e-311', '2.8481815407166473465204174448562866e-306', '2.0', '1.22312599818982326042266e-4943', '1.3771174474187147232911910237982503e-4928'); my @nexp_113 = map { "-" . $_} @exp_113; my @exp_2098 = ('1.4142135623730950488016887242097', '0.14', '0.1', '5e-324', '8.7001827429576e-311', '2.8481815407166473e-306', '2.0000000000000000000000000000000000000000000000000000000000006223015277861142', '0.0', '0.0'); my @nexp_2098 = map { "-" . $_} @exp_2098; my %expected = ( '53' => \@exp_53, '64' => \@exp_64, '113' => \@exp_113, '2098' => \@exp_2098, ); my %nexpected = ( '53' => \@nexp_53, '64' => \@nexp_64, '113' => \@nexp_113, '2098' => \@nexp_2098, ); my $emax = Rmpfr_get_emax(); my $emin = Rmpfr_get_emin(); for my $bits(53, 64, 113, 2098) { $op = Rmpfr_init2($bits); $op2 = Rmpfr_init2($bits); Rmpfr_set_default_prec($bits); Rmpfr_set_ui($op, 2, MPFR_RNDN); $op **= 0.5; $res = anytoa($op); cmp_ok($res, '==', $op, "1: \$res == \$op") unless $bits == 2098; cmp_ok(Rmpfr_get_emax(), '==', $emax, "1: emax was reset correctly"); cmp_ok(Rmpfr_get_emin(), '==', $emin, "1: emin was reset correctly"); cmp_ok($res, 'eq', $expected{$bits}->[0], "$res eq $expected{$bits}->[0]"); # Check that we "pass the round trip" if($bits == 2098) { cmp_ok($res, 'eq', anytoa(Math::MPFR->new($res)), "\$res eq anytoa(Math::MPFR->new(\$res))"); # Also check for expected inequalities: cmp_ok($op, '!=', Math::MPFR->new($res), "\$op != Math::MPFR->new(\$res)"); } else { cmp_ok($res, 'eq', mpfrtoa($op), "$res eq mpfrtoa($op)"); cmp_ok($res, 'eq', mpfrtoa(Math::MPFR->new($res)), "\$res eq mpfrtoa(Math::MPFR->new($res))"); } Rmpfr_neg($op, $op, MPFR_RNDN); $res = anytoa($op); cmp_ok($res, '==', $op, "2: \$res == \$op") unless $bits == 2098; cmp_ok(Rmpfr_get_emax(), '==', $emax, "2: emax was reset correctly"); cmp_ok(Rmpfr_get_emin(), '==', $emin, "2: emin was reset correctly"); cmp_ok($res, 'eq', $nexpected{$bits}->[0], "$res eq $nexpected{$bits}->[0]"); # Check that we "pass the round trip" if($bits == 2098) { cmp_ok($res, 'eq', anytoa(Math::MPFR->new($res)), "\$res eq anytoa(Math::MPFR->new(\$res))"); # Also check for expected inequalities: cmp_ok($op, '!=', Math::MPFR->new($res), "\$op != Math::MPFR->new(\$res)"); } else { cmp_ok($res, 'eq', mpfrtoa($op), "$res eq mpfrtoa($op)"); cmp_ok($res, 'eq', mpfrtoa(Math::MPFR->new($res)), "\$res eq mpfrtoa(Math::MPFR->new($res))"); } Rmpfr_strtofr($op, '1.4', 10, MPFR_RNDN); $op /= 10; $res = anytoa($op); cmp_ok($res, '==', $op, "3: \$res == \$op") unless $bits == 2098; cmp_ok(Rmpfr_get_emax(), '==', $emax, "3: emax was reset correctly"); cmp_ok(Rmpfr_get_emin(), '==', $emin, "3: emin was reset correctly"); cmp_ok($res, 'eq', $expected{$bits}->[1], "$res eq $expected{$bits}->[1]"); # Check that we "pass the round trip" if($bits == 2098) { cmp_ok($res, 'eq', anytoa(Math::MPFR->new($res)), "\$res eq anytoa(Math::MPFR->new(\$res))"); } else { cmp_ok($res, 'eq', mpfrtoa($op), "$res eq mpfrtoa($op)"); cmp_ok($res, 'eq', mpfrtoa(Math::MPFR->new($res)), "\$res eq mpfrtoa(Math::MPFR->new($res))"); } Rmpfr_neg($op, $op, MPFR_RNDN); $res = anytoa($op); cmp_ok($res, '==', $op, "4: \$res == \$op") unless $bits == 2098; cmp_ok(Rmpfr_get_emax(), '==', $emax, "4: emax was reset correctly"); cmp_ok(Rmpfr_get_emin(), '==', $emin, "4: emin was reset correctly"); cmp_ok($res, 'eq', $nexpected{$bits}->[1], "$res eq $nexpected{$bits}->[1]"); # Check that we "pass the round trip" if($bits == 2098) { cmp_ok($res, 'eq', anytoa(Math::MPFR->new($res)), "\$res eq anytoa(Math::MPFR->new(\$res))"); } else { cmp_ok($res, 'eq', mpfrtoa($op), "$res eq mpfrtoa($op)"); cmp_ok($res, 'eq', mpfrtoa(Math::MPFR->new($res)), "\$res eq mpfrtoa(Math::MPFR->new($res))"); } Rmpfr_strtofr($op, '0.1', 10, MPFR_RNDN); $res = anytoa($op); cmp_ok($res, '==', $op, "5: \$res == \$op") unless $bits == 2098; cmp_ok(Rmpfr_get_emax(), '==', $emax, "5: emax was reset correctly"); cmp_ok(Rmpfr_get_emin(), '==', $emin, "5: emin was reset correctly"); cmp_ok($res, 'eq', $expected{$bits}->[2], "$res eq $expected{$bits}->[2]"); # Check that we "pass the round trip" if($bits == 2098) { cmp_ok($res, 'eq', anytoa(Math::MPFR->new($res)), "\$res eq anytoa(Math::MPFR->new(\$res))"); } else { cmp_ok($res, 'eq', mpfrtoa($op), "$res eq mpfrtoa($op)"); cmp_ok($res, 'eq', mpfrtoa(Math::MPFR->new($res)), "\$res eq mpfrtoa(Math::MPFR->new($res))"); } Rmpfr_neg($op, $op, MPFR_RNDN); $res = anytoa($op); cmp_ok($res, '==', $op, "6: \$res == \$op") unless $bits == 2098; cmp_ok(Rmpfr_get_emax(), '==', $emax, "6: emax was reset correctly"); cmp_ok(Rmpfr_get_emin(), '==', $emin, "6: emin was reset correctly"); cmp_ok($res, 'eq', $nexpected{$bits}->[2], "$res eq $nexpected{$bits}->[2]"); # Check that we "pass the round trip" if($bits == 2098) { cmp_ok($res, 'eq', anytoa(Math::MPFR->new($res)), "\$res eq anytoa(Math::MPFR->new(\$res))"); } else { cmp_ok($res, 'eq', mpfrtoa($op), "$res eq mpfrtoa($op)"); cmp_ok($res, 'eq', mpfrtoa(Math::MPFR->new($res)), "\$res eq mpfrtoa(Math::MPFR->new($res))"); } if( MPFR_VERSION() >= 262146 && $bits == 53 ) { # The mpfr library does not properly support 1-bit precision until 4.0.2 # Also, cater for older perls that don't set subnormals correctly. Rmpfr_set($kludge, Math::MPFR->new(2) ** -1074, MPFR_RNDN); Rmpfr_set_d($op, Rmpfr_get_d($kludge, MPFR_RNDN), MPFR_RNDN); $res = anytoa($op); cmp_ok(Rmpfr_get_emax(), '==', $emax, "7: emax was reset correctly"); cmp_ok(Rmpfr_get_emin(), '==', $emin, "7: emin was reset correctly"); cmp_ok($res, 'eq', $expected{$bits}->[3], "$res eq $expected{$bits}->[3]"); Rmpfr_neg($op, $op, MPFR_RNDN); $res = anytoa($op); cmp_ok(Rmpfr_get_emax(), '==', $emax, "8: emax was reset correctly"); cmp_ok(Rmpfr_get_emin(), '==', $emin, "8: emin was reset correctly"); cmp_ok($res, 'eq', $nexpected{$bits}->[3], "$res eq $nexpected{$bits}->[3]"); } # Deal with 2 more subnormals that might be mis-assigned by older perls Rmpfr_set($op, (Math::MPFR->new(2) ** -1030) + (Math::MPFR->new(2) ** -1040), MPFR_RNDN); $res = anytoa($op); cmp_ok(Rmpfr_get_emax(), '==', $emax, "9: emax was reset correctly"); cmp_ok(Rmpfr_get_emin(), '==', $emin, "9: emin was reset correctly"); cmp_ok($res, 'eq', $expected{$bits}->[4], "$res eq $expected{$bits}->[4]"); # Check that we "pass the round trip" if($bits == 2098 || $bits == 53) { cmp_ok($res, 'eq', anytoa(Math::MPFR->new($res)), "\$res eq anytoa(Math::MPFR->new(\$res))"); # Also check for expected inequalities: cmp_ok($op, '!=', Math::MPFR->new($res), "\$op != Math::MPFR->new(\$res)"); } else { cmp_ok($res, 'eq', mpfrtoa($op), "$res eq mpfrtoa($op)"); cmp_ok($res, 'eq', mpfrtoa(Math::MPFR->new($res)), "\$res eq mpfrtoa(Math::MPFR->new($res))"); } Rmpfr_neg($op, $op, MPFR_RNDN); $res = anytoa($op); cmp_ok(Rmpfr_get_emax(), '==', $emax, "10: emax was reset correctly"); cmp_ok(Rmpfr_get_emin(), '==', $emin, "10: emin was reset correctly"); cmp_ok($res, 'eq', $nexpected{$bits}->[4], "$res eq $nexpected{$bits}->[4]"); # Check that we "pass the round trip" if($bits == 2098 || $bits == 53) { cmp_ok($res, 'eq', anytoa(Math::MPFR->new($res)), "\$res eq anytoa(Math::MPFR->new(\$res))"); # Also check for expected inequalities: cmp_ok($op, '!=', Math::MPFR->new($res), "\$op != Math::MPFR->new(\$res)"); } else { cmp_ok($res, 'eq', mpfrtoa($op), "$res eq mpfrtoa($op)"); cmp_ok($res, 'eq', mpfrtoa(Math::MPFR->new($res)), "\$res eq mpfrtoa(Math::MPFR->new($res))"); } Rmpfr_neg($op, $op, MPFR_RNDN); # Revert to +ve value. Rmpfr_add_d($op, $op, 2 ** -1015, MPFR_RNDN); $res = anytoa($op); cmp_ok($res, '==', $op, "11: \$res == \$op") unless $bits == 2098; cmp_ok(Rmpfr_get_emax(), '==', $emax, "11: emax was reset correctly"); cmp_ok(Rmpfr_get_emin(), '==', $emin, "11: emin was reset correctly"); cmp_ok($res, 'eq', $expected{$bits}->[5], "$res eq $expected{$bits}->[5]"); # Check that we "pass the round trip" if($bits == 2098) { cmp_ok($res, 'eq', anytoa(Math::MPFR->new($res)), "\$res eq anytoa(Math::MPFR->new(\$res))"); # Also check for expected inequalities: cmp_ok($op, '!=', Math::MPFR->new($res), "\$op != Math::MPFR->new(\$res)"); } else { cmp_ok($res, 'eq', mpfrtoa($op), "$res eq mpfrtoa($op)"); cmp_ok($res, 'eq', mpfrtoa(Math::MPFR->new($res)), "\$res eq mpfrtoa(Math::MPFR->new($res))"); } Rmpfr_neg($op, $op, MPFR_RNDN); $res = anytoa($op); cmp_ok($res, '==', $op, "12: \$res == \$op") unless $bits == 2098; cmp_ok(Rmpfr_get_emax(), '==', $emax, "12: emax was reset correctly"); cmp_ok(Rmpfr_get_emin(), '==', $emin, "12: emin was reset correctly"); cmp_ok($res, 'eq', $nexpected{$bits}->[5], "$res eq $nexpected{$bits}->[5]"); # Check that we "pass the round trip" if($bits == 2098) { cmp_ok($res, 'eq', anytoa(Math::MPFR->new($res)), "\$res eq anytoa(Math::MPFR->new(\$res))"); # Also check for expected inequalities: cmp_ok($op, '!=', Math::MPFR->new($res), "\$op != Math::MPFR->new(\$res)"); } else { cmp_ok($res, 'eq', mpfrtoa($op), "$res eq mpfrtoa($op)"); cmp_ok($res, 'eq', mpfrtoa(Math::MPFR->new($res)), "\$res eq mpfrtoa(Math::MPFR->new($res))"); } Rmpfr_set_ui($op, 2, MPFR_RNDN); Rmpfr_add_d($op, $op, 2 ** -200, MPFR_RNDN); $res = anytoa($op); cmp_ok($res, '==', $op, "13: \$res == \$op") unless $bits == 2098; cmp_ok(Rmpfr_get_emax(), '==', $emax, "13: emax was reset correctly"); cmp_ok(Rmpfr_get_emin(), '==', $emin, "13: emin was reset correctly"); cmp_ok($res, 'eq', $expected{$bits}->[6], "$res eq $expected{$bits}->[6]"); # Check that we "pass the round trip" if($bits == 2098) { cmp_ok($res, 'eq', anytoa(Math::MPFR->new($res)), "\$res eq anytoa(Math::MPFR->new(\$res))"); # Also check for expected inequalities: cmp_ok($op, '!=', Math::MPFR->new($res), "\$op != Math::MPFR->new(\$res)"); } else { cmp_ok($res, 'eq', mpfrtoa($op), "$res eq mpfrtoa($op)"); cmp_ok($res, 'eq', mpfrtoa(Math::MPFR->new($res)), "\$res eq mpfrtoa(Math::MPFR->new($res))"); } Rmpfr_neg($op, $op, MPFR_RNDN); $res = anytoa($op); cmp_ok($res, '==', $op, "14: \$res == \$op") unless $bits == 2098; cmp_ok(Rmpfr_get_emax(), '==', $emax, "14: emax was reset correctly"); cmp_ok(Rmpfr_get_emin(), '==', $emin, "14: emin was reset correctly"); cmp_ok($res, 'eq', $nexpected{$bits}->[6], "$res eq $nexpected{$bits}->[6]"); # Check that we "pass the round trip" if($bits == 2098) { cmp_ok($res, 'eq', anytoa(Math::MPFR->new($res)), "\$res eq anytoa(Math::MPFR->new(\$res))"); # Also check for expected inequalities: cmp_ok($op, '!=', Math::MPFR->new($res), "\$op != Math::MPFR->new(\$res)"); } else { cmp_ok($res, 'eq', mpfrtoa($op), "$res eq mpfrtoa($op)"); cmp_ok($res, 'eq', mpfrtoa(Math::MPFR->new($res)), "\$res eq mpfrtoa(Math::MPFR->new($res))"); } Rmpfr_set_ui($op, 2, MPFR_RNDN); $op **= -16420; $res = anytoa($op); cmp_ok(Rmpfr_get_emax(), '==', $emax, "15: emax was reset correctly"); cmp_ok(Rmpfr_get_emin(), '==', $emin, "15: emin was reset correctly"); cmp_ok($res, 'eq', $expected{$bits}->[7], "$res eq $expected{$bits}->[7]"); Rmpfr_neg($op, $op, MPFR_RNDN); $res = anytoa($op); cmp_ok(Rmpfr_get_emax(), '==', $emax, "16: emax was reset correctly"); cmp_ok(Rmpfr_get_emin(), '==', $emin, "16: emin was reset correctly"); cmp_ok($res, 'eq', $nexpected{$bits}->[7], "$res eq $nexpected{$bits}->[7]"); Rmpfr_neg($op, $op, MPFR_RNDN); # Revert to +ve value. Rmpfr_set_ui($op2, 2, MPFR_RNDN); $op2 **= -16370; Rmpfr_add($op, $op, $op2, MPFR_RNDN); $res = anytoa($op); cmp_ok(Rmpfr_get_emax(), '==', $emax, "17: emax was reset correctly"); cmp_ok(Rmpfr_get_emin(), '==', $emin, "17: emin was reset correctly"); cmp_ok($res, 'eq', $expected{$bits}->[8], "$res eq $expected{$bits}->[8]"); Rmpfr_neg($op, $op, MPFR_RNDN); $res = anytoa($op); cmp_ok(Rmpfr_get_emax(), '==', $emax, "18: emax was reset correctly"); cmp_ok(Rmpfr_get_emin(), '==', $emin, "18: emin was reset correctly"); cmp_ok($res, 'eq', $nexpected{$bits}->[8], "$res eq $nexpected{$bits}->[8]"); Rmpfr_set_ui($op, 2, MPFR_RNDN); $op **= -16420; $res = anytoa($op); cmp_ok(Rmpfr_get_emax(), '==', $emax, "19: emax was reset correctly"); cmp_ok(Rmpfr_get_emin(), '==', $emin, "19: emin was reset correctly"); cmp_ok($res, 'eq', $expected{$bits}->[7], "$res eq $expected{$bits}->[7]"); Rmpfr_neg($op, $op, MPFR_RNDN); $res = anytoa($op); cmp_ok(Rmpfr_get_emax(), '==', $emax, "20: emax was reset correctly"); cmp_ok(Rmpfr_get_emin(), '==', $emin, "20: emin was reset correctly"); cmp_ok($res, 'eq', $nexpected{$bits}->[7], "$res eq $nexpected{$bits}->[7]"); Rmpfr_set_ui($op, 2, MPFR_RNDN); $op **= ($bounds{$bits}->[0]) - 1; $res = anytoa($op); cmp_ok($res, '==', $op, "21: \$res == \$op") unless $bits == 2098; cmp_ok(Rmpfr_get_emax(), '==', $emax, "21: emax was reset correctly"); cmp_ok(Rmpfr_get_emin(), '==', $emin, "21: emin was reset correctly"); # $res will evaluate to Inf when nvtype is double or double or double-double. # So we need to establish that $res is not 'Inf' - which we do by # evaluating Math::MPFR->new($res), which should be finite and positive. cmp_ok(Math::MPFR->new($res), '>', 0, "$res > 0"); cmp_ok(Math::MPFR->new($res), '<', $inf, "$res < Inf"); Rmpfr_neg($op, $op, MPFR_RNDN); $res = anytoa($op); cmp_ok($res, '==', $op, "22: \$res == \$op") unless $bits == 2098; cmp_ok(Rmpfr_get_emax(), '==', $emax, "22: emax was reset correctly"); cmp_ok(Rmpfr_get_emin(), '==', $emin, "22: emin was reset correctly"); # $res will evaluate to -Inf when nvtype is double or double or double-double. # So we need to establish that $res is not '-Inf' - which we do by # evaluating Math::MPFR->new($res), which should be finite and negative. cmp_ok(Math::MPFR->new($res), '<', 0, "$res < 0"); cmp_ok(Math::MPFR->new($res), '>', -$inf, "$res > -Inf"); Rmpfr_set_ui($op, 2, MPFR_RNDN); $op **= $bounds{$bits}->[0]; $res = anytoa($op); cmp_ok(Rmpfr_get_emax(), '==', $emax, "23: emax was reset correctly"); cmp_ok(Rmpfr_get_emin(), '==', $emin, "23: emin was reset correctly"); # Evaluate Math::MPFR->new($res) to ensure that $res really is '+Inf'. cmp_ok(Math::MPFR->new($res), '==', $inf, "$res is positive and infinite"); Rmpfr_neg($op, $op, MPFR_RNDN); $res = anytoa($op); cmp_ok(Rmpfr_get_emax(), '==', $emax, "24: emax was reset correctly"); cmp_ok(Rmpfr_get_emin(), '==', $emin, "24: emin was reset correctly"); cmp_ok(Math::MPFR->new($res), '==', -$inf, "$res is negative and infinite"); Rmpfr_set_nan($op); $res = anytoa($op); cmp_ok(Rmpfr_get_emax(), '==', $emax, "25: emax was reset correctly"); cmp_ok(Rmpfr_get_emin(), '==', $emin, "25: emin was reset correctly"); like($res, qr/nan/i, "$res is NaN"); Rmpfr_neg($op, $op, MPFR_RNDN); $res = anytoa($op); cmp_ok(Rmpfr_get_emax(), '==', $emax, "26: emax was reset correctly"); cmp_ok(Rmpfr_get_emin(), '==', $emin, "26: emin was reset correctly"); like($res, qr/nan/i, "$res is still NaN"); eval { anytoa(16); }; cmp_ok(Rmpfr_get_emax(), '==', $emax, "27: emax was reset correctly"); cmp_ok(Rmpfr_get_emin(), '==', $emin, "27: emin was reset correctly"); like($@, qr/^1st argument given to anytoa/, "dies if 1st arg is not a Math::MPFR object"); eval { anytoa(Math::MPFR->new(0), 128); }; cmp_ok(Rmpfr_get_emax(), '==', $emax, "28: emax was reset correctly"); cmp_ok(Rmpfr_get_emin(), '==', $emin, "28: emin was reset correctly"); like($@, qr/^anytoa\(\) now takes only one argument/, "dies if 2nd arg is supplied"); my $current_prec = Rmpfr_get_default_prec(); Rmpfr_set_default_prec(60); eval { anytoa(Math::MPFR->new(0), 0); }; cmp_ok(Rmpfr_get_emax(), '==', $emax, "28: emax was reset correctly"); cmp_ok(Rmpfr_get_emin(), '==', $emin, "28: emin was reset correctly"); like($@, qr/^anytoa\(\) now takes only one argument/, "dies if 2nd arg is 0"); eval { anytoa(Math::MPFR->new(0)); }; cmp_ok(Rmpfr_get_emax(), '==', $emax, "28: emax was reset correctly"); cmp_ok(Rmpfr_get_emin(), '==', $emin, "28: emin was reset correctly"); like($@, qr/^Precision of arg given to anytoa/, "dies on invalid prec"); Rmpfr_set_default_prec($current_prec); } done_testing(); Math-MPFR-4.38/t/atonum.t0000755060175106010010000000201214765756127013635 0ustar OwnerNone use strict; use warnings; use Math::MPFR qw(:mpfr); use Test::More; if(196869 >= MPFR_VERSION) { eval {atonum("1.3");}; like ($@, qr/atonv is not available with this version/, '$@ reports unavailability of atonum'); done_testing(); } else { my @in = (~0, ~0 - 1, ~0 - 10000, ~0 >> 1, (~0 >> 1) * -1, 1e6, -1e6); for my $n (@in) { cmp_ok(atonum("$n"), 'eq', "$n", "atonum(\"$n\") eq \"$n\""); cmp_ok(atonum("$n"), '==', $n , "atonum(\"$n\") == $n"); } my $fr = Math::MPFR->new(); my $nan = Rmpfr_get_NV($fr, MPFR_RNDN); Rmpfr_set_inf($fr, 0); my $pinf = Rmpfr_get_NV($fr, MPFR_RNDN); my $ninf = $pinf * -1; my $pzero = 0.0; my $nzero = $pzero * -1.0; @in = ($pinf, $ninf, $nan, $pzero, $nzero, sqrt(2), 1 / 10, 1.3e-200, -1.3e-200, 2 ** 200, -(2 ** 200)); for my $n (@in) { cmp_ok(atonum("$n"), 'eq', atonv("$n"), "atonum(\"$n\") eq atonv(\"$n\")"); next if $n != $n; cmp_ok(atonum("$n"), '==', atonv("$n"), "atonum(\"$n\") == atonv(\"$n\")"); } done_testing(); } Math-MPFR-4.38/t/atonv.t0000755060175106010010000001040414765756127013465 0ustar OwnerNoneuse strict; use warnings; use Math::MPFR qw(:mpfr); my $t = 3; print "1..$t\n"; my($have_atonv, $mpfr_has_float128); eval{$mpfr_has_float128 = Rmpfr_buildopt_float128_p()}; $mpfr_has_float128 = 0 if $@; # else it's whatever Rmpfr_buildopt_float128_p() returned $have_atonv = MPFR_VERSION <= 196869 ? 0 : 1; if($have_atonv) { my($nv1, $nv2, $nv3, $double); if($Config::Config{nvtype} eq 'double' || ($Config::Config{nvtype} eq 'long double' && ($Config::Config{nvsize} == 8 || Math::MPFR::_required_ldbl_mant_dig() == 2098))) { $double = atodouble('0b0.100001e-1074'); $nv1 = atonv('0b0.100001e-1074'); $nv2 = atonv('4.96e-324'); $nv3 = atonv('0x0.84p-1074'); if($nv1 == $nv2 && $double == $nv2 && $nv2 == $nv3 && $nv1 > 0) {print "ok 1\n"} else { warn "\n \$double: $double\n \$nv1: $nv1\n \$nv2: $nv2\n \$nv3: $nv3\n"; print "not ok 1\n"; } print "ok 2\n"; # Original test removed } elsif($Config::Config{nvtype} eq 'long double' && length(sqrt(2.1)) < 25) { # Exclude IEEE 754 long double # from this branch. $nv1 = atonv('0b0.100001e-16445'); $nv2 = atonv('3.6452e-4951'); $nv3 = atonv('0x0.84p-16445'); if($nv1 == $nv2 && $nv2 == $nv3 && $nv1 > 0) {print "ok 1\n"} else { warn "\n \$nv1: $nv1\n \$nv2: $nv2\n \$nv3: $nv3\n"; print "not ok 1\n"; } # Let's now check to see whether failures reported at: # http://www.cpantesters.org/cpan/report/d6a27d3c-2a0d-11e9-bf31-80c71e9d5857 and # http://www.cpantesters.org/cpan/report/f8c159e0-2a0f-11e9-bf31-80c71e9d5857 # might represent a bug in atonv(). if(Math::MPFR::_required_ldbl_mant_dig() == 64) { my $ok = 1; my $nv = atonv('97646e-4945'); unless(sprintf("%.19e", $nv) eq '9.7645999998519452098e-4941') { warn "97646e-4945: Expected 9.7645999998519452098e-4941 Got ", sprintf("%.19e", $nv), "\n"; $ok = 0; } $nv = atonv('7286408931649326e-4956'); unless(sprintf("%.19e", $nv) eq '7.2864089317595630535e-4941') { warn "7286408931649326e-4956: Expected 7.2864089317595630535e-4941 Got ", sprintf("%.19e", $nv), "\n"; $ok = 0; } if($ok) { print "ok 2\n"; } else { print "not ok 2\n"; } } else { print "ok 2\n"; # Original test removed } } elsif($Config::Config{nvtype} eq '__float128' || $Config::Config{nvtype} eq 'long double') { # If nvtype is "long double" it will be the IEEE 754 long double, as the other kinds of # long double have already been tested in one of the preceding branches. # For nvtype of "__float128" we also need to verify that $mpfr_has_float128 is TRUE. if($mpfr_has_float128 || $Config::Config{nvtype} eq 'long double') { $nv1 = atonv('0b0.100001e-16494'); $nv2 = atonv('6.5e-4966'); $nv3 = atonv('0x0.84p-16494'); if($nv1 == $nv2 && $nv2 == $nv3 && $nv1 > 0) {print "ok 1\n"} else { warn "\n \$nv1: $nv1\n \$nv2: $nv2\n"; print "not ok 1\n"; } print "ok 2\n"; # Original test removed } else { # The nvtype can be only "__float128". eval { $nv1 = atonv('0b0.100001e-16494') }; if($@ =~ /^The atonv function is unavailable for this __float128 build/) { print "ok 1\n"; } else { warn "\$\@: $@\n"; print "not ok 1\n"; } if(Math::MPFR::_MPFR_WANT_FLOAT128()) { # MPFR_WANT_FLOAT128 should be not defined if mpfr # library does not support libquadmath types warn "Serious inconsistency regarding mpfr library's quadmath support\n"; print "not ok 2\n"; } else { print "ok2\n"; } } } else { warn "\n Unrecognized nvtype in atonv.t\n"; print "not ok 1\nnot ok 2\n"; } $nv1 = atonv('0.625'); if($nv1 == 5 / 8) { print "ok 3\n"} else { warn "\n $nv1 != ", 5 / 8, "\n"; print "not ok 3\n"; } } else { eval{atonv('1234.5');}; if($@ =~ /^The atonv function requires mpfr\-3\.1\.6 or later/) {print "ok 1\n"} else { warn "\n \$\@: $@\n"; print "not ok 1\n"; } warn "\n Skipping tests 2 to $t - nothing else to check\n"; print "ok $_\n" for 2 .. $t; } Math-MPFR-4.38/t/base_conversion.t0000755060175106010010000000757514765756127015534 0ustar OwnerNoneuse strict; use warnings; use Test::More tests => 37; use Math::MPFR qw(:mpfr); # The relationship between mpfr_inter_prec() and mpfr_max_orig_len() that # is present in the first 24 tests, does not always hold true. See tests # 25..36 for example. # However, that relationship should always hold true if $in[0] >= $in[2] # (ie if old base >= new base), as tested in test 37. my @in = (2, 53, 10, 17); cmp_ok(mpfr_min_inter_prec($in[0], $in[1], $in[2]), '==', $in[3], 'test 1'); cmp_ok(mpfr_max_orig_len ($in[0], $in[2], $in[3]), '==', $in[1], 'test 2'); @in = (10, 15, 2, 51); cmp_ok(mpfr_min_inter_prec($in[0], $in[1], $in[2]), '==', $in[3], 'test 3'); cmp_ok(mpfr_max_orig_len ($in[0], $in[2], $in[3]), '==', $in[1], 'test 4'); @in = (10, 16, 2, 55); cmp_ok(mpfr_min_inter_prec($in[0], $in[1], $in[2]), '==', $in[3], 'test 5'); cmp_ok(mpfr_max_orig_len ($in[0], $in[2], $in[3]), '==', $in[1], 'test 6'); @in = (2, 56, 16, 14); cmp_ok(mpfr_min_inter_prec($in[0], $in[1], $in[2]), '==', $in[3], 'test 7'); cmp_ok(mpfr_max_orig_len ($in[0], $in[2], $in[3]), '==', $in[1], 'test 8'); @in = (32, 1, 16, 2); cmp_ok(mpfr_min_inter_prec($in[0], $in[1], $in[2]), '==', $in[3], 'test 9'); cmp_ok(mpfr_max_orig_len ($in[0], $in[2], $in[3]), '==', $in[1], 'test 10'); @in = (32, 2, 16, 3); cmp_ok(mpfr_min_inter_prec($in[0], $in[1], $in[2]), '==', $in[3], 'test 11'); cmp_ok(mpfr_max_orig_len ($in[0], $in[2], $in[3]), '==', $in[1], 'test 12'); @in = (32, 4, 16, 5); cmp_ok(mpfr_min_inter_prec($in[0], $in[1], $in[2]), '==', $in[3], 'test 13'); cmp_ok(mpfr_max_orig_len ($in[0], $in[2], $in[3]), '==', $in[1], 'test 14'); @in = (32, 5, 16, 7); cmp_ok(mpfr_min_inter_prec($in[0], $in[1], $in[2]), '==', $in[3], 'test 15'); cmp_ok(mpfr_max_orig_len ($in[0], $in[2], $in[3]), '==', $in[1], 'test 16'); @in = (8, 15, 10, 15); cmp_ok(mpfr_min_inter_prec($in[0], $in[1], $in[2]), '==', $in[3], 'test 17'); cmp_ok(mpfr_max_orig_len ($in[0], $in[2], $in[3]), '==', $in[1], 'test 18'); @in = (8, 16, 10, 16); cmp_ok(mpfr_min_inter_prec($in[0], $in[1], $in[2]), '==', $in[3], 'test 19'); cmp_ok(mpfr_max_orig_len ($in[0], $in[2], $in[3]), '==', $in[1], 'test 20'); @in = (10, 15, 2, 51); cmp_ok(mpfr_min_inter_prec($in[0], $in[1], $in[2]), '==', $in[3], 'test 21'); cmp_ok(mpfr_max_orig_len ($in[0], $in[2], $in[3]), '==', $in[1], 'test 22'); @in = (8, 21, 10, 20); cmp_ok(mpfr_min_inter_prec($in[0], $in[1], $in[2]), '==', $in[3], 'test 23'); cmp_ok(mpfr_max_orig_len ($in[0], $in[2], $in[3]), '==', $in[1], 'test 24'); @in = (2, 80, 10, 26); cmp_ok(mpfr_min_inter_prec($in[0], $in[1], $in[2]), '==', $in[3], 'test 25'); cmp_ok(mpfr_max_orig_len ($in[0], $in[2], $in[3]), '!=', $in[1], 'test 26'); # $in[1] == 80 cmp_ok(mpfr_max_orig_len ($in[0], $in[2], $in[3]), '==', 83, 'test 27'); @in = (8, 20, 10, 20); cmp_ok(mpfr_min_inter_prec($in[0], $in[1], $in[2]), '==', $in[3], 'test 28'); cmp_ok(mpfr_max_orig_len ($in[0], $in[2], $in[3]), '!=', $in[1], 'test 29'); # $in[1] == 20 cmp_ok(mpfr_max_orig_len ($in[0], $in[2], $in[3]), '==', 21, 'test 30'); @in = (8, 14, 32, 9); cmp_ok(mpfr_min_inter_prec($in[0], $in[1], $in[2]), '==', $in[3], 'test 31'); cmp_ok(mpfr_max_orig_len ($in[0], $in[2], $in[3]), '!=', $in[1], 'test 32'); # $in[1] == 14 cmp_ok(mpfr_max_orig_len ($in[0], $in[2], $in[3]), '==', 15, 'test 33'); @in = (2, 19, 16, 5); cmp_ok(mpfr_min_inter_prec($in[0], $in[1], $in[2]), '==', $in[3], 'test 34'); cmp_ok(mpfr_max_orig_len ($in[0], $in[2], $in[3]), '!=', $in[1], 'test 35'); # $in[1] == 19 cmp_ok(mpfr_max_orig_len ($in[0], $in[2], $in[3]), '==', 20, 'test 36'); my $ok = 1; for(1 .. 1000) { @in = (2 + int(rand(63)), 1 + int(rand(1000)), 2 + int(rand(63))); $in[3] = mpfr_min_inter_prec($in[0], $in[1], $in[2]); my $x = mpfr_max_orig_len($in[0], $in[2], $in[3]); if($x != $in[1] && $in[0] >= $in[2]) { warn "$x: @in\n"; $ok = 0; } } cmp_ok($ok, '==', 1, 'test 37'); Math-MPFR-4.38/t/bessel.t0000755060175106010010000000315714765756127013622 0ustar OwnerNoneuse warnings; use strict; use Math::MPFR qw(:mpfr); print "1..1\n"; print "# Using Math::MPFR version ", $Math::MPFR::VERSION, "\n"; print "# Using mpfr library version ", MPFR_VERSION_STRING, "\n"; print "# Using gmp library version ", Math::MPFR::gmp_v(), "\n"; Rmpfr_set_default_prec(100); my($val, $discard) = Rmpfr_init_set_ui(2934, GMP_RNDN); my $ret = Rmpfr_init(); my $nan = Rmpfr_init(); my $neg = Math::MPFR->new(-1); my $zero = Math::MPFR->new(0); my $inf = Math::MPFR->new(); Rmpfr_set_inf($inf, 1); my $ok = ''; Rmpfr_j0($ret, $val, GMP_RNDN); if($ret > 0.007545752435 && $ret < 0.007545752437) {$ok .= 'a'} Rmpfr_j1($ret, $val, GMP_RNDN); if($ret > -0.012649475954 && $ret < -0.012649475952) {$ok .= 'b'} Rmpfr_jn($ret, 200, $val, GMP_RNDN); if($ret > 0.012963999661 && $ret < 0.012963999663) {$ok .= 'c'} Rmpfr_y0($ret, $val, GMP_RNDN); if($ret > -0.012650761686 && $ret < -0.012650761684) {$ok .= 'd'} Rmpfr_y1($ret, $val, GMP_RNDN); if($ret > -0.007547908437 && $ret < -0.007547908435) {$ok .= 'e'} Rmpfr_yn($ret, 200, $val, GMP_RNDN); if($ret > -0.007029988802 && $ret < -0.0070299888) {$ok .= 'f'} Rmpfr_j0($ret, $nan, GMP_RNDN); if(Rmpfr_nan_p($ret)) {$ok .= 'g'} Rmpfr_j1($ret, $inf, GMP_RNDN); if(!$ret) {$ok .= 'h'} Rmpfr_j1($ret, $zero, GMP_RNDN); if(!$ret) {$ok .= 'i'} Rmpfr_y1($ret, $nan, GMP_RNDN); if(Rmpfr_nan_p($ret)) {$ok .= 'j'} Rmpfr_y0($ret, $neg, GMP_RNDN); if(Rmpfr_nan_p($ret)) {$ok .= 'k'} Rmpfr_y0($ret, $inf, GMP_RNDN); if(!$ret) {$ok .= 'l'} Rmpfr_y1($ret, $zero, GMP_RNDN); if(Rmpfr_inf_p($ret)) {$ok .= 'm'} if($ok eq 'abcdefghijklm') {print "ok 1\n"} else {print "not ok 1 $ok\n"} Math-MPFR-4.38/t/buildopt.t0000755060175106010010000000243314765756127014163 0ustar OwnerNoneuse warnings; use strict; use Math::MPFR qw(:mpfr); print "1..4\n"; print "# Using Math::MPFR version ", $Math::MPFR::VERSION, "\n"; print "# Using mpfr library version ", MPFR_VERSION_STRING, "\n"; print "# Using gmp library version ", Math::MPFR::gmp_v(), "\n"; if(MPFR_VERSION_MAJOR >= 3) { if(defined(Rmpfr_buildopt_tls_p())) {print "ok 1\n"} else {print "not ok 1\n"} if(defined(Rmpfr_buildopt_decimal_p())) {print "ok 2\n"} else {print "not ok 2\n"} } else { eval{Rmpfr_buildopt_tls_p();}; if($@ =~ /Rmpfr_buildopt_tls_p not implemented/) {print "ok 1\n"} else {print "not ok 1\n"} eval{Rmpfr_buildopt_decimal_p();}; if($@ =~ /Rmpfr_buildopt_decimal_p not implemented/) {print "ok 2\n"} else {print "not ok 2\n"} } if((MPFR_VERSION_MAJOR == 3 && MPFR_VERSION_MINOR >= 1) || MPFR_VERSION_MAJOR > 3) { if(defined(Rmpfr_buildopt_tune_case())) {print "ok 3\n"} else {print "not ok 3\n"} if(defined(Rmpfr_buildopt_gmpinternals_p())) {print "ok 4\n"} else {print "not ok 4\n"} } else { eval{Rmpfr_buildopt_tune_case();}; if($@ =~ /Rmpfr_buildopt_tune_case not implemented/) {print "ok 3\n"} else {print "not ok 3\n"} eval{Rmpfr_buildopt_gmpinternals_p();}; if($@ =~ /Rmpfr_buildopt_gmpinternals_p not implemented/) {print "ok 4\n"} else {print "not ok 4\n"} } Math-MPFR-4.38/t/bytes.t0000755060175106010010000001532514765756127013473 0ustar OwnerNoneuse warnings; use strict; use Config; use Math::MPFR qw(:mpfr); print "# Using Math::MPFR version ", $Math::MPFR::VERSION, "\n"; print "# Using mpfr library version ", MPFR_VERSION_STRING, "\n"; print "# Using gmp library version ", Math::MPFR::gmp_v(), "\n"; warn "\nbyteorder: ", $Config{byteorder}, "\n"; my $kind; my %ldkind = ( -1 => 'unknown', 0 => 'double', 1 => '"IEEE" 754 128-bit little endian', 2 => '"IEEE" 754 128-bit big endian', 3 => 'x86 80-bit little endian', 4 => 'x86 80-bit big endian', 5 => 'double-double 128-bit little endian', 6 => 'double-double 128-bit big endian', ); if(defined $Config{longdblkind}) { $kind = $Config{longdblkind}; warn "longdblkind: $kind: $ldkind{$kind}\n"; } else { warn "\$Config{longdblkind} not defined for this build of perl $]\n"; } warn "HAVE_IEEE_754_LONG_DOUBLE is ", Math::MPFR::_have_IEEE_754_long_double(), "\n"; warn "HAVE_EXTENDED_PRECISION_LONG_DOUBLE is ", Math::MPFR::_have_extended_precision_long_double(), "\n"; print "1..19\n"; my $arb = 40; Rmpfr_set_default_prec($arb); my $hex_53 = Math::MPFR::bytes('2.3', 53); if($hex_53 eq '4002666666666666') { print "ok 1\n" } else { warn "expected: 4002666666666666\ngot : $hex_53\n"; print "not ok 1\n"; } my $hex_64; eval { $hex_64 = Math::MPFR::bytes('2.3', 64);}; if($@) { if($@ =~/^Byte structure of 10-byte long double not provided/ && !Math::MPFR::_have_extended_precision_long_double()) { print "ok 2\n" } else { warn "\$\@: $@"; print "not ok 2\n"; } } else { if($hex_64 eq '40009333333333333333') { print "ok 2\n" } else { warn "expected: 40009333333333333333\ngot : $hex_64\n"; print "not ok 2\n"; } } my $hex_2098 = Math::MPFR::bytes('1e+127', 2098); if($hex_2098 eq '5a4d8ba7f519c84f56e7fd1f28f89c56') { print "ok 3\n" } else { warn "expected: 5a4d8ba7f519c84f56e7fd1f28f89c56\ngot : $hex_2098\n"; print "not ok 3\n"; } my $hex_113; eval { $hex_113 = Math::MPFR::bytes('2.3', 113);}; if($@) { if($@ =~/^Byte structure of 113-bit NV types not provided/ && !Math::MPFR::_have_IEEE_754_long_double() && !Math::MPFR::_MPFR_WANT_FLOAT128()) { print "ok 4\n" } else { warn "\$\@: $@"; print "not ok 4\n"; } } else { if($hex_113 eq '40002666666666666666666666666666') { print "ok 4\n" } else { warn "expected: 40002666666666666666666666666666\ngot : $hex_113\n"; print "not ok 4\n"; } } eval { $hex_53 = Math::MPFR::bytes(2.3, 53);}; if($@ =~ /^1st arg to Math::MPFR::bytes must be either/) { print "ok 5\n" } else { warn "\$\@: $@"; print "not ok 5\n"; } eval { $hex_53 = Math::MPFR::bytes('2.3', 52);}; if($@ =~ /^2nd argument given to Math::MPFR::bytes is neither/) { print "ok 6\n" } else { warn "\$\@: $@"; print "not ok 6\n"; } my $hex_53_fr = Rmpfr_init2(53); my $hex_64_fr = Rmpfr_init2(64); my $hex_2098_fr = Rmpfr_init2(2098); my $hex_2098_fr2 = Rmpfr_init2(2098); my $hex_2098_fr3 = Rmpfr_init2(2098); my $hex_113_fr = Rmpfr_init2(113); my $longstring = '0b0.11111111111111111111111111111111111111111111111111111011111111111111111111111111111111111111111111111111111100E1024'; Rmpfr_strtofr($hex_53_fr, '2.3', 10, MPFR_RNDN); Rmpfr_strtofr($hex_64_fr, '2.3', 10, MPFR_RNDN); Rmpfr_strtofr($hex_2098_fr, '1e+127', 10, MPFR_RNDN); Rmpfr_strtofr($hex_2098_fr2, $longstring, 0, MPFR_RNDN); Rmpfr_strtofr($hex_2098_fr3, "-$longstring", 0, MPFR_RNDN); Rmpfr_strtofr($hex_113_fr, '2.3', 10, MPFR_RNDN); $hex_53 = Math::MPFR::bytes($hex_53_fr, 53); if($hex_53 eq '4002666666666666') { print "ok 7\n" } else { warn "expected: 4002666666666666\ngot : $hex_53\n"; print "not ok 7\n"; } eval { $hex_64 = Math::MPFR::bytes($hex_64_fr, 64);}; if($@) { if($@ =~/^Byte structure of 10-byte long double not provided/ && !Math::MPFR::_have_extended_precision_long_double()) { print "ok 8\n" } else { warn "\$\@: $@"; print "not ok 8\n"; } } else { if($hex_64 eq '40009333333333333333') { print "ok 8\n" } else { warn "expected: 40009333333333333333\ngot : $hex_64\n"; print "not ok 8\n"; } } $hex_2098 = Math::MPFR::bytes($hex_2098_fr, 2098); if($hex_2098 eq '5a4d8ba7f519c84f56e7fd1f28f89c56') { print "ok 9\n" } else { warn "expected: 5a4d8ba7f519c84f56e7fd1f28f89c56\ngot : $hex_2098\n"; print "not ok 9\n"; } eval { $hex_113 = Math::MPFR::bytes($hex_113_fr, 113);}; if($@) { if($@ =~/^Byte structure of 113-bit NV types not provided/ && !Math::MPFR::_have_IEEE_754_long_double() && !Math::MPFR::_MPFR_WANT_FLOAT128()) { print "ok 10\n" } else { warn "\$\@: $@"; print "not ok 10\n"; } } else { if($hex_113 eq '40002666666666666666666666666666') { print "ok 10\n" } else { warn "expected: 40002666666666666666666666666666\ngot : $hex_113\n"; print "not ok 10\n"; } } eval { $hex_53 = Math::MPFR::bytes(Math::MPFR->new(2.3), 53);}; if($@ =~ /^Precision of 1st arg supplied/) { print "ok 11\n" } else { warn "\$\@: $@"; print "not ok 11\n"; } eval { $hex_64 = Math::MPFR::bytes(Math::MPFR->new(2.3), 64);}; if($@ =~ /^Precision of 1st arg supplied/ || $@ =~ /^Byte structure of/) { print "ok 12\n" } else { warn "\$\@: $@"; print "not ok 12\n"; } eval { $hex_2098 = Math::MPFR::bytes(Math::MPFR->new(2.3), 2098);}; if($@ =~ /^Precision of 1st arg supplied/) { print "ok 13\n" } else { warn "\$\@: $@"; print "not ok 13\n"; } eval { $hex_113 = Math::MPFR::bytes(Math::MPFR->new(2.3), 113);}; if($@ =~ /^Precision of 1st arg supplied/ || $@ =~ /^Byte structure of/) { print "ok 14\n" } else { warn "\$\@: $@"; print "not ok 14\n"; } if(Rmpfr_get_default_prec() == $arb) { print "ok 15\n" } else { warn "\nexpected: 40\ngot : $arb\n"; print "not ok 15\n"; } # 4 specific examples that were once failing: $hex_2098 = Math::MPFR::bytes($hex_2098_fr2, 2098); if($hex_2098 eq '7ff00000000000000000000000000000') { print "ok 16\n" } else { warn "expected: 7ff00000000000000000000000000000\ngot : $hex_2098\n"; print "not ok 16\n"; } $hex_2098 = Math::MPFR::bytes($hex_2098_fr3, 2098); if($hex_2098 eq 'fff00000000000000000000000000000') { print "ok 17\n" } else { warn "expected: fff00000000000000000000000000000\ngot : $hex_2098\n"; print "not ok 17\n"; } $hex_2098 = Math::MPFR::bytes($longstring, 2098); if($hex_2098 eq '7ff00000000000000000000000000000') { print "ok 18\n" } else { warn "expected: 7ff00000000000000000000000000000\ngot : $hex_2098\n"; print "not ok 18\n"; } $hex_2098 = Math::MPFR::bytes("-$longstring", 2098); if($hex_2098 eq 'fff00000000000000000000000000000') { print "ok 19\n" } else { warn "expected: fff00000000000000000000000000000\ngot : $hex_2098\n"; print "not ok 19\n"; } ########################################################################################################### Math-MPFR-4.38/t/cmp_uj_sj.t0000755060175106010010000000537114765756127014316 0ustar OwnerNoneuse strict; use warnings; use Math::MPFR qw(:mpfr); use Config; use Test::More; if(Math::MPFR::_has_longlong()) { # MATH_MPFR_NEED_LONG_LONG_INT is defined # Note: The Math::MPFR objects have 54-bit precision. my $fr1 = Math::MPFR->new(2 ** 64); my $fr2 = Math::MPFR->new(2 ** 63); my $uv = Math::MPFR->new(~0); cmp_ok(Rmpfr_cmp ( $fr1, $uv ), '==', 0, "Math::MPFR->new(2 ** 64) == Math::MPFR->new(~0)"); cmp_ok(Rmpfr_cmp_uj( $fr1, ~0 ), '>', 0, "Math::MPFR->new(2 ** 64) > ~0"); cmp_ok(Rmpfr_cmp_IV( $fr1, ~0 ), '>', 0, "Rmpfr_cmp_IV and Rmpfr_cmp_uj are the same"); my $iv = Math::MPFR->new(~0 >> 1); cmp_ok(Rmpfr_cmp ( $fr2, $iv ), '==', 0, "Math::MPFR->new(2 ** 63) == Math::MPFR->new(~0 >> 1)"); cmp_ok(Rmpfr_cmp_sj( $fr2, ~0 >> 1 ), '>', 0, "Math::MPFR->new(2 ** 63) > ~0 >> 1"); cmp_ok(Rmpfr_cmp_IV( $fr2, ~0 >> 1 ), '>', 0, "Rmpfr_cmp_IV and Rmpfr_cmp_sj are the same"); } else { cmp_ok( Rmpfr_cmp_uj(Math::MPFR->new(~0), ~0), '==', Rmpfr_cmp_ui(Math::MPFR->new(~0), ~0), "Rmpfr_cmp_uj and Rmpfr_cmp_ui agree" ); my $s_max = (~0) >> 1; $s_max *= -1; print "\$s_max: $s_max\n"; cmp_ok( Rmpfr_cmp_sj(Math::MPFR->new($s_max), $s_max), '==', Rmpfr_cmp_si(Math::MPFR->new($s_max), $s_max), "Rmpfr_cmp_sj and Rmpfr_cmp_si agree" ); if($Config{ivsize} == 8) { my $fr1 = Math::MPFR->new(2 ** 64); my $fr2 = Math::MPFR->new(2 ** 63); my $uv = Math::MPFR->new(~0); cmp_ok(Rmpfr_cmp ( $fr1, $uv ), '==', 0, "Math::MPFR->new(2 ** 64) == Math::MPFR->new(~0)"); cmp_ok(Rmpfr_cmp_ui( $fr1, ~0 ), '>', 0, "Math::MPFR->new(2 ** 64) > ~0"); cmp_ok(Rmpfr_cmp_IV( $fr1, ~0 ), '>', 0, "Rmpfr_cmp_IV and Rmpfr_cmp_ui are the same"); my $iv = Math::MPFR->new(~0 >> 1); cmp_ok(Rmpfr_cmp ( $fr2, $iv ), '==', 0, "Math::MPFR->new(2 ** 63) == Math::MPFR->new(~0 >> 1)"); cmp_ok(Rmpfr_cmp_si( $fr2, ~0 >> 1 ), '>', 0, "Math::MPFR->new(2 ** 63) > ~0 >> 1"); cmp_ok(Rmpfr_cmp_IV( $fr2, ~0 >> 1 ), '>', 0, "Rmpfr_cmp_IV and Rmpfr_cmp_si are the same"); } else { my $fr1 = Math::MPFR->new(2 ** 32); my $fr2 = Math::MPFR->new(2 ** 31); my $uv = Math::MPFR->new(~0); cmp_ok(Rmpfr_cmp ( $fr1, $uv ), '>', 0, "Math::MPFR->new(2 ** 32) > Math::MPFR->new(~0)"); cmp_ok(Rmpfr_cmp_ui( $fr1, ~0 ), '>', 0, "Math::MPFR->new(2 ** 32) > ~0"); cmp_ok(Rmpfr_cmp_IV( $fr1, ~0 ), '>', 0, "Rmpfr_cmp_IV and Rmpfr_cmp_ui are the same"); my $iv = Math::MPFR->new(~0 >> 1); cmp_ok(Rmpfr_cmp ( $fr2, $iv ), '>', 0, "Math::MPFR->new(2 ** 31) > Math::MPFR->new(~0 >> 1)"); cmp_ok(Rmpfr_cmp_si( $fr2, ~0 >> 1 ), '>', 0, "Math::MPFR->new(2 ** 31) > ~0 >> 1"); cmp_ok(Rmpfr_cmp_IV( $fr2, ~0 >> 1 ), '>', 0, "Rmpfr_cmp_IV and Rmpfr_cmp_si are the same"); } } done_testing(); Math-MPFR-4.38/t/compound.t0000755060175106010010000000447514765756127014175 0ustar OwnerNone # Test script for: # mpfr_compound_si - new in 4.2.0 # mpfr_compound - new in 4.3.0 use strict; use warnings; use Math::MPFR qw(:mpfr); use Test::More; my $rop = Math::MPFR->new(); warn "MPFR_VERSION: ", MPFR_VERSION, "\n"; warn "MPFR_VERSION_STRING: ", MPFR_VERSION_STRING, "\n"; if(MPFR_VERSION >= 262656) { my $inex = Rmpfr_compound_si($rop, Math::MPFR->new(5), 3, MPFR_RNDN); cmp_ok($rop, '==', 216, "Rmpfr_compound_si: 6 ** 3 == 216"); $inex = Rmpfr_compound_si($rop, Math::MPFR->new(-1.001), 3, MPFR_RNDN); cmp_ok(Rmpfr_nan_p($rop), '!=', 0, "Rmpfr_compound_si: -1.001 ** 3 is NaN"); $inex = Rmpfr_compound_si($rop, Math::MPFR->new(), 0, MPFR_RNDN); cmp_ok($rop, '==', 1, "Rmpfr_compound_si: NaN ** 0 is 1"); $inex = Rmpfr_compound_si($rop, Math::MPFR->new(-1), -1, MPFR_RNDN); cmp_ok((Rmpfr_inf_p($rop) && ($rop > 0)), '!=', 0, "Rmpfr_compound_si: -1 ** a negative power is +Inf"); $inex = Rmpfr_compound_si($rop, Math::MPFR->new(-1), 1, MPFR_RNDN); cmp_ok((Rmpfr_zero_p($rop) && !Rmpfr_signbit($rop)), '!=', 0, "Rmpfr_compound_si: -1 ** a positive power is +0"); } else { eval {Rmpfr_compound_si($rop, Math::MPFR->new(5), 0, MPFR_RNDN);}; like($@, qr/^Rmpfr_compound_si function not implemented/, "Rmpfr_compound_si requires mpfr-4.2.0"); } if(MPFR_VERSION >= 262912) { my $inex = Rmpfr_compound($rop, Math::MPFR->new(5), Math::MPFR->new(3), MPFR_RNDN); cmp_ok($rop, '==', 216, "Rmpfr_compound: 6 ** 3 == 216"); $inex = Rmpfr_compound($rop, Math::MPFR->new(-1.001), Math::MPFR->new(3), MPFR_RNDN); cmp_ok(Rmpfr_nan_p($rop), '!=', 0, "Rmpfr_compound: -1.001 ** 3 is NaN"); $inex = Rmpfr_compound($rop, Math::MPFR->new(), Math::MPFR->new(0), MPFR_RNDN); cmp_ok($rop, '==', 1, "Rmpfr_compound: NaN ** 0 is 1"); $inex = Rmpfr_compound($rop, Math::MPFR->new(-1), Math::MPFR->new(-2.5), MPFR_RNDN); cmp_ok((Rmpfr_inf_p($rop) && ($rop > 0)), '!=', 0, "Rmpfr_compound: -1 ** a negative power is +Inf"); $inex = Rmpfr_compound($rop, Math::MPFR->new(-1), Math::MPFR->new(2.5), MPFR_RNDN); cmp_ok((Rmpfr_zero_p($rop) && !Rmpfr_signbit($rop)), '!=', 0, "Rmpfr_compound: -1 ** a positive power is +0"); } else { eval {Rmpfr_compound($rop, Math::MPFR->new(5), Math::MPFR->new(0), MPFR_RNDN);}; like($@, qr/^Rmpfr_compound function not implemented/, "Rmpfr_compound requires mpfr-4.3.0"); } done_testing(); Math-MPFR-4.38/t/constants.t0000755060175106010010000000636314765756127014363 0ustar OwnerNoneuse warnings; use strict; use Math::MPFR qw(:mpfr); print "1..21\n"; print "# Using Math::MPFR version ", $Math::MPFR::VERSION, "\n"; print "# Using mpfr library version ", MPFR_VERSION_STRING, "\n"; print "# Using gmp library version ", Math::MPFR::gmp_v(), "\n"; my $version = RMPFR_VERSION_NUM(MPFR_VERSION_MAJOR, MPFR_VERSION_MINOR, MPFR_VERSION_PATCHLEVEL); if($version == MPFR_VERSION) {print "ok 1\n"} else { print "not ok 1 $version ", MPFR_VERSION, "\n"; } if(MPFR_VERSION_MAJOR >= 2) {print "ok 2\n"} else {print "not ok 2 MPFR_VERSION_MAJOR is ", MPFR_VERSION_MAJOR, "\n"} if(MPFR_VERSION_MINOR >= 2 || MPFR_VERSION_MAJOR >= 3) {print "ok 3\n"} else {print "not ok 3 MPFR_VERSION_MINOR is ", MPFR_VERSION_MINOR, " MPFR_VERSION_MAJOR is ", MPFR_VERSION_MAJOR, "\n"} if(MPFR_VERSION_PATCHLEVEL >= 0) {print "ok 4\n"} else {print "not ok 4 MPFR_VERSION_PATCHLEVEL is ", MPFR_VERSION_PATCHLEVEL, "\n"} my $v = Rmpfr_get_version(); if($v eq MPFR_VERSION_STRING) {print "ok 5\n"} else {print "not ok 5 $v is not the same as ", MPFR_VERSION_STRING, "\n"} eval{my $patches = Rmpfr_get_patches();}; if(!$@) {print "ok 6\n"} else {print "not ok 6 $@\n"} # We now check that all of the "constants" (actually subroutines) listed # in MPFR.pm in 'use subs' are parsed as intended. my $arb = 3; if(MPFR_VERSION < MPFR_VERSION + $arb) {print "ok 7\n"} else {print "not ok 7\n"} if(MPFR_VERSION_MAJOR < MPFR_VERSION_MAJOR + $arb) {print "ok 8\n"} else {print "not ok 8\n"} if(MPFR_VERSION_MINOR < MPFR_VERSION_MINOR + $arb) {print "ok 9\n"} else {print "not ok 9\n"} if(MPFR_VERSION_PATCHLEVEL < MPFR_VERSION_PATCHLEVEL + $arb) {print "ok 10\n"} else {print "not ok 10\n"} { no warnings 'numeric'; if(MPFR_VERSION_STRING < MPFR_VERSION_STRING + $arb) {print "ok 11\n"} else {print "not ok 11\n"} } if(RMPFR_PREC_MIN < RMPFR_PREC_MIN + $arb) {print "ok 12\n"} else {print "not ok 12\n"} if(RMPFR_PREC_MAX < RMPFR_PREC_MAX + $arb) {print "ok 13\n"} else {print "not ok 13\n"} if(MPFR_DBL_DIG < MPFR_DBL_DIG + $arb) {print "ok 14\n"} else {print "not ok 14\n"} if(MPFR_LDBL_DIG < MPFR_LDBL_DIG + $arb) {print "ok 15\n"} else {print "not ok 15\n"} { no warnings 'uninitialized'; if(MPFR_FLT128_DIG < MPFR_FLT128_DIG + $arb) {print "ok 16\n"} else {print "not ok 16\n"} } if(Math::MPFR::GMP_LIMB_BITS < Math::MPFR::GMP_LIMB_BITS + $arb) {print "ok 17\n"} else {print "not ok 17\n"} if(Math::MPFR::GMP_NAIL_BITS < Math::MPFR::GMP_NAIL_BITS + $arb) {print "ok 18\n"} else {print "not ok 18\n"} eval{my $p = MPFR_DBL_DIG;}; if(!$@) { if(defined(MPFR_DBL_DIG)) { warn "\nFYI:\n DBL_DIG = ", MPFR_DBL_DIG, "\n"; } else { warn "\nFYI:\n DBL_DIG not defined\n"; } print "ok 19\n"; } else { warn "\$\@: $@"; print "not ok 19\n"; } eval{my $lp = MPFR_LDBL_DIG;}; if(!$@) { if(defined(MPFR_LDBL_DIG)) { warn "\nFYI:\n LDBL_DIG = ", MPFR_LDBL_DIG, "\n"; } else { warn "\nFYI:\n LDBL_DIG not defined\n"; } print "ok 20\n"; } else { warn "\$\@: $@"; print "not ok 20\n"; } eval{my $f128p = MPFR_FLT128_DIG;}; if(!$@) { if(defined(MPFR_FLT128_DIG)) { warn "\nFYI:\n FLT128_DIG = ", MPFR_FLT128_DIG, "\n"; } else { warn "\nFYI:\n FLT128_DIG not defined\n"; } print "ok 21\n"; } else { warn "\$\@: $@"; print "not ok 21\n"; } Math-MPFR-4.38/t/cross_class_mpq.t0000755060175106010010000000355414765756127015541 0ustar OwnerNone# Do: $mpfr_rop = $mpfr * $mpq; # Do: q_mul_fr ($mpq_rop, $mpq, $mpfr); Rmpfr_set_q($mpfr_from_q, $mpq_rop, default_rounding_mode()); # Check that $mpfr_rop == $mpfr_from_q, as documrntation implies (I think) # # Also: # Do: q_fmod_fr($mpq_rop, $mpq, $mpfr); # Do: Rmpfr_get_q($q_from_mpfr, $mpfr); # Check that $mpq_rop == $mpq % $q_from_mpfr; # LHS was assigned using only Math::MPFR functionality. # RHS is calcualted using Math::GMPq overloading of '%' operator (fmod). use strict; use warnings; use Math::MPFR qw(:mpfr); use Test::More; eval {require Math::GMPq;}; if($@) { cmp_ok(1, '==', 1); warn "Skipping all tests - could not load Math::GMPq"; done_testing(); exit 0; } if($Math::GMPq::VERSION < 0.61) { is(1, 1); warn "Skipping all tests - we need Math-GMPq-0.61 or later, but have only version $Math::GMPq::VERSION"; done_testing(); exit 0; } my $mpfr = Math::MPFR->new(22222.22); my $mpfr_from_q = Math::MPFR->new(); my $mpq_rop = Math::GMPq->new(); for(1..100) { my $num = 10 + int(rand(10000)); my $den = 100 + int(rand(1000)); my $q1 = "$num/$den"; my $q2 = "$den/$num"; for my $s($q1, $q2) { my $mpq = Math::GMPq->new($s); $mpq *= -1 unless $_ % 3; my $mpfr_rop = $mpfr * $mpq; q_mul_fr($mpq_rop, $mpq, $mpfr); Rmpfr_set_q($mpfr_from_q, $mpq_rop, MPFR_RNDN); cmp_ok($mpfr_from_q, '==', $mpfr_rop, "values match for 22222.22 * $mpq"); } } Rmpfr_set_d($mpfr, 2.22, MPFR_RNDN); my $q_from_mpfr = Math::GMPq->new(); Rmpfr_get_q($q_from_mpfr, $mpfr); for(1..100) { my $num = 10 + int(rand(10000)); my $den = 100 + int(rand(1000)); my $q1 = "$num/$den"; my $q2 = "$den/$num"; for my $s($q1, $q2) { my $mpq = Math::GMPq->new($s); $mpq *= -1 unless $_ % 3; q_fmod_fr($mpq_rop, $mpq, $mpfr); cmp_ok($mpq % $q_from_mpfr, '==', $mpq_rop, "values match for $mpq % 2.22"); } } done_testing(); Math-MPFR-4.38/t/D64_LD.t0000755060175106010010000000572114765756127013260 0ustar OwnerNoneuse warnings; use strict; use Math::MPFR qw (:mpfr); unless(Math::MPFR::_MPFR_WANT_DECIMAL64()) { print "1..1\n"; warn "\n Skipping all tests - Math::MPFR not built with MPFR_WANT_DECIMAL64 defined\n"; print "ok 1\n"; exit 0; } my $t = 3; print "1..$t\n"; my $why; my $keep_printing = 1; eval {require Math::Decimal64; Math::Decimal64->import (qw(:all));}; if($@) {$why = "Couldn't load Math::Decimal64\n"} else {$why = "Math::MPFR not built for _Decimal64\n" unless Math::MPFR::_MPFR_WANT_DECIMAL64()} eval {require Math::LongDouble; Math::LongDouble->import (qw(:all));}; if($@) {$why .= "Couldn't load Math::LongDouble\n"} unless($why) { my $d64_1 = Math::Decimal64->new(0); my $d64_2 = Math::Decimal64->new(0); my $ld = ZeroLD(1); my $ok = 1; my $round = 0;# MPFR_RNDN my $mant_dig = Math::MPFR::_LDBL_MANT_DIG(); # expected to be either 64 or 106 Rmpfr_set_default_prec($mant_dig); # If $mant_dig == 106, I assume the long double is "double-double" - which doesn't # accommodate the full exponent range of the Decimal64 type. my $rand_limit = $mant_dig == 106 ? 292 : 399; for my $it (1..100000) { my $digits = 1 + int(rand(16)); # Don't exceed max precision for this test. #Rmpfr_set_default_prec(53 + int(rand(100))); my $man_sign = $it % 2 ? '-' : ''; my $exp_sign = $it % 3 ? 1 : -1; my $man = $man_sign . get_man($digits); my $exp = int(rand($rand_limit)) * $exp_sign; #next if $exp + $digits > 385; my $fr_arg = $man . '@' . $exp; my $d64_check = Math::Decimal64->new($man, $exp); my $fr = Math::MPFR->new($fr_arg, 10); Rmpfr_get_DECIMAL64($d64_1, $fr, $round); Rmpfr_get_LD($ld, $fr, $round); LDtoD64($d64_2, $ld); unless($d64_2 == $d64_1) { if($keep_printing < 6) { warn "$digits $exp\n$fr_arg\n $fr\n"; warn "\$d64_check: $d64_check\n\$d64_1: $d64_1\n\$d64_2: $d64_2\n\$ld: $ld\n\n"; $ok = 0; } $keep_printing++; } } if($ok) {print "ok 1\n"} else {print "not ok 1\n"} $ok = 1; for(3 .. 70) { my $eps = Math::Decimal64->new(1, -398); my $eps_ret = NVtoD64(2.5); my $eps_fr = Rmpfr_init2($_); Rmpfr_set_DECIMAL64($eps_fr, $eps, MPFR_RNDN); Rmpfr_get_DECIMAL64($eps_ret, $eps_fr, MPFR_RNDN); unless($eps_ret == $eps) { warn "\nMPFR precision: ", Rmpfr_get_prec($eps_fr), "\n"; warn "\$eps: $eps\n\$eps_ret: $eps_ret\n"; $ok = 0; } } if($ok) {print "ok 2\n"} else {print "not ok 2\n"} Rmpfr_set_default_prec($mant_dig); my $root = Math::MPFR->new(2.0); Rmpfr_sqrt($root, $root, MPFR_RNDN); my $ld_root = sqrt(Math::LongDouble->new(2.0)); Rmpfr_get_LD($ld, $root, MPFR_RNDN); if($ld == $ld_root) {print "ok 3\n"} else { warn "\n\$ld: $ld\n\$ld_root: $ld_root\n"; print "not ok 3\n"; } } else { warn "\nSkipping all tests\n"; warn $why; for (1 .. $t) {print "ok $_\n"} } sub get_man { my $ret = ''; for(1 .. $_[0]) {$ret .= int(rand(10))} return $ret; } Math-MPFR-4.38/t/decimal128_conv.t0000755060175106010010000001373614765756127015227 0ustar OwnerNoneuse warnings; use strict; use Math::MPFR qw(:mpfr); unless(Math::MPFR::_MPFR_WANT_DECIMAL128()) { print "1..1\n"; warn "\n Skipping all tests - Math::MPFR not built with MPFR_WANT_DECIMAL_FLOATS defined\n"; print "ok 1\n"; exit 0; } my $t = 21; print "1..$t\n"; eval {require Math::Decimal128; Math::Decimal128->import (qw(:all));}; my $why; if($@) { $why = "Couldn't load Math::Decimal128\n"; warn "\n Skipping all tests: $why: $@\n"; print "ok $_\n" for 1..$t; exit 0; } my $proceed = Math::MPFR::_MPFR_WANT_DECIMAL128(); if($proceed) { Rmpfr_set_default_prec(114); # Using complementary Rounding Modes needs prec of 114. my $ok = 1; my $it; for $it(1 .. 10000) { my $nv = rand(1024) / (1 + rand(1024)); #$ $larg_1 and $larg_2 will be complementary Rounding modes. my $larg_1 = int(rand(5)); my $larg_2 = $larg_1 ? 5 - $larg_1 : $larg_1; my $d128_1 = NVtoD128($nv); my $fr_1 = Math::MPFR->new(); Rmpfr_set_DECIMAL128($fr_1, $d128_1, $larg_1); my $d128_2 = NVtoD128(0); Rmpfr_get_DECIMAL128($d128_2, $fr_1, $larg_2); unless($d128_1 == $d128_2) { $ok = 0; warn "$it: $d128_1 != $d128_2\n $larg_1 : $larg_2\n\n"; } } if($ok) {print "ok 1\n"} else {print "not ok 1\n"} $ok = 1; Rmpfr_set_default_prec(114); for $it(1 .. 10000) { my $nv = rand(1024) / (1 + rand(1024)); my $d128_1 = NVtoD128($nv); my $fr_1 = Math::MPFR->new(); Rmpfr_set_DECIMAL128($fr_1, $d128_1, 0); my $d128_2 = NVtoD128(0); Rmpfr_get_DECIMAL128($d128_2, $fr_1, 0); unless($d128_1 == $d128_2) { $ok = 0; warn "$it: $d128_1 != $d128_2\n"; } } if($ok) {print "ok 2\n"} else {print "not ok 2\n"} my $nanD128 = NaND128(); my $pinfD128 = InfD128(1); my $ninfD128 = InfD128(-1); my $zeroD128 = ZeroD128(1); my $nzeroD128 = ZeroD128(-1); my $rop = Math::Decimal128->new(); my $fr = Math::MPFR->new(); Rmpfr_set_DECIMAL128($fr, $nanD128, MPFR_RNDN); Rmpfr_get_DECIMAL128($rop, $fr, MPFR_RNDN); if(is_NaND128($rop)) {print "ok 3\n"} else { warn "\$rop: $rop\n"; print "not ok 3\n"; } Rmpfr_set_DECIMAL128($fr, $pinfD128, MPFR_RNDN); Rmpfr_get_DECIMAL128($rop, $fr, MPFR_RNDN); if(is_InfD128($rop) > 0) {print "ok 4\n"} else { warn "\$rop: $rop\n"; print "not ok 4\n"; } Rmpfr_set_DECIMAL128($fr, $ninfD128, MPFR_RNDN); Rmpfr_get_DECIMAL128($rop, $fr, MPFR_RNDN); if(is_InfD128($rop) < 0) {print "ok 5\n"} else { warn "\$rop: $rop\n"; print "not ok 5\n"; } Rmpfr_set_DECIMAL128($fr, $zeroD128, MPFR_RNDN); Rmpfr_get_DECIMAL128($rop, $fr, MPFR_RNDN); if(is_ZeroD128($rop) > 0) {print "ok 6\n"} else { warn "\$rop: $rop\n"; print "not ok 6\n"; } Rmpfr_set_DECIMAL128($fr, $nzeroD128, MPFR_RNDN); Rmpfr_get_DECIMAL128($rop, $fr, MPFR_RNDN); if(is_ZeroD128($rop) < 0) {print "ok 7\n"} else { warn "\$rop: $rop\n"; print "not ok 7\n"; } my $bigpos = Math::MPFR->new('1@6145'); my $bigneg = $bigpos * -1; Rmpfr_get_DECIMAL128($rop, $bigpos, MPFR_RNDN); if(is_InfD128($rop) > 0) {print "ok 8\n"} else { warn "\n\$rop: $rop\n"; print "not ok 8\n"; } Rmpfr_get_DECIMAL128($rop, $bigneg, MPFR_RNDN); if(is_InfD128($rop) < 0) {print "ok 9\n"} else { warn "\n\$rop: $rop\n"; print "not ok 9\n"; } Rmpfr_get_DECIMAL128($rop, $bigpos, MPFR_RNDZ); if($rop == Math::Decimal128->new('9999999999999999999999999999999999', '6111')) {print "ok 10\n"} else { warn "\n\$rop: $rop\n"; print "not ok 10\n"; } if($rop == Math::Decimal128->new('9999999999999999999999999999999999', '6111')) {print "ok 11\n"} else { warn "\n\$rop: $rop\n"; print "not ok 11\n"; } if($rop == Math::Decimal128::DEC128_MAX()) {print "ok 12\n"} else { warn "\n\$rop: $rop\n"; print "not ok 12\n"; } my $littlepos = Math::MPFR->new('1@-6177'); my $littleneg = $littlepos * -1; Rmpfr_get_DECIMAL128($rop, $littlepos, MPFR_RNDZ); if(is_ZeroD128($rop) > 0) {print "ok 13\n"} else { warn "\n\$rop: $rop\n"; print "not ok 13\n"; } Rmpfr_get_DECIMAL128($rop, $littleneg, MPFR_RNDZ); if(is_ZeroD128($rop) < 0) {print "ok 14\n"} else { warn "\n\$rop: $rop\n"; print "not ok 14\n"; } Rmpfr_get_DECIMAL128($rop, $littlepos, MPFR_RNDA); if($rop == Math::Decimal128->new(1, -6176)) {print "ok 15\n"} else { warn "\n\$rop: $rop\n"; print "not ok 15\n"; } Rmpfr_get_DECIMAL128($rop, $littleneg, MPFR_RNDA); if($rop == Math::Decimal128->new(-1, -6176)) {print "ok 16\n"} else { warn "\n\$rop: $rop\n"; print "not ok 16\n"; } if($rop == Math::Decimal128::DEC128_MIN() * Math::Decimal128::UnityD128(-1)) {print "ok 17\n"} else { warn "\n\$rop: $rop\n"; print "not ok 17\n"; } my $fr_d128 = Rmpfr_init2(114); my $d128_1 = MEtoD128('1', -298); my $d128_2 = Math::Decimal128->new(); Rmpfr_set_DECIMAL128($fr_d128, $d128_1, MPFR_RNDN); Rmpfr_get_DECIMAL128($d128_2, $fr_d128, MPFR_RNDN); if($d128_1 == $d128_2) {print "ok 18\n"} else { warn "\n $d128_1: $d128_1\n \$d128_2: $d128_2\n"; print "not ok 18\n"; } $d128_1 = NVtoD128(1e-298); Rmpfr_set_DECIMAL128($fr_d128, $d128_1, MPFR_RNDN); Rmpfr_get_DECIMAL128($d128_2, $fr_d128, MPFR_RNDN); if($d128_1 == $d128_2) {print "ok 19\n"} else { warn "\n $d128_1: $d128_1\n \$d128_2: $d128_2\n"; print "not ok 19\n"; } $d128_1 = MEtoD128('1', -360); Rmpfr_set_DECIMAL128($fr_d128, $d128_1, MPFR_RNDN); Rmpfr_get_DECIMAL128($d128_2, $fr_d128, MPFR_RNDN); if($d128_1 == $d128_2) {print "ok 20\n"} else { warn "\n $d128_1: $d128_1\n \$d128_2: $d128_2\n"; print "not ok 20\n"; } $d128_1 = NVtoD128(1e-360); Rmpfr_set_DECIMAL128($fr_d128, $d128_1, MPFR_RNDN); Rmpfr_get_DECIMAL128($d128_2, $fr_d128, MPFR_RNDN); if($d128_1 == $d128_2) {print "ok 21\n"} else { warn "\n $d128_1: $d128_1\n \$d128_2: $d128_2\n"; print "not ok 21\n"; } } else { warn "Skipping all tests - Math::MPFR not built for Decimal128 support"; print "ok $_\n" for 1..$t; } Math-MPFR-4.38/t/decimal64_conv.t0000755060175106010010000001344114765756127015137 0ustar OwnerNoneuse warnings; use strict; use Math::MPFR qw(:mpfr); unless(Math::MPFR::_MPFR_WANT_DECIMAL64()) { print "1..1\n"; warn "\n Skipping all tests - Math::MPFR not built with MPFR_WANT_DECIMAL_FLOATS defined\n"; print "ok 1\n"; exit 0; } my $t = 21; print "1..$t\n"; eval {require Math::Decimal64; Math::Decimal64->import (qw(:all));}; my $why; if($@) { $why = "Couldn't load Math::Decimal64\n"; warn "\n Skipping all tests: $why: $@\n"; print "ok $_\n" for 1..$t; exit 0; } my $proceed = Math::MPFR::_MPFR_WANT_DECIMAL64(); if($proceed) { Rmpfr_set_default_prec(55); # Using complementary Rounding Modes needs prec of 55. my $ok = 1; my $it; for $it(1 .. 10000) { my $nv = rand(1024) / (1 + rand(1024)); #$ $larg_1 and $larg_2 will be complementary Rounding modes. my $larg_1 = int(rand(5)); my $larg_2 = $larg_1 ? 5 - $larg_1 : $larg_1; my $d64_1 = NVtoD64($nv); my $fr_1 = Math::MPFR->new(); Rmpfr_set_DECIMAL64($fr_1, $d64_1, $larg_1); my $d64_2 = NVtoD64(0); Rmpfr_get_DECIMAL64($d64_2, $fr_1, $larg_2); unless($d64_1 == $d64_2) { $ok = 0; warn "$it: $d64_1 != $d64_2\n $larg_1 : $larg_2\n\n"; } } if($ok) {print "ok 1\n"} else {print "not ok 1\n"} $ok = 1; Rmpfr_set_default_prec(55); for $it(1 .. 10000) { my $nv = rand(1024) / (1 + rand(1024)); my $d64_1 = NVtoD64($nv); my $fr_1 = Math::MPFR->new(); Rmpfr_set_DECIMAL64($fr_1, $d64_1, 0); my $d64_2 = NVtoD64(0); Rmpfr_get_DECIMAL64($d64_2, $fr_1, 0); unless($d64_1 == $d64_2) { $ok = 0; warn "$it: $d64_1 != $d64_2\n"; } } if($ok) {print "ok 2\n"} else {print "not ok 2\n"} my $nanD64 = NaND64(); my $pinfD64 = InfD64(1); my $ninfD64 = InfD64(-1); my $zeroD64 = ZeroD64(1); my $nzeroD64 = ZeroD64(-1); my $rop = Math::Decimal64->new(); my $fr = Math::MPFR->new(); Rmpfr_set_DECIMAL64($fr, $nanD64, MPFR_RNDN); Rmpfr_get_DECIMAL64($rop, $fr, MPFR_RNDN); if(is_NaND64($rop)) {print "ok 3\n"} else { warn "\$rop: $rop\n"; print "not ok 3\n"; } Rmpfr_set_DECIMAL64($fr, $pinfD64, MPFR_RNDN); Rmpfr_get_DECIMAL64($rop, $fr, MPFR_RNDN); if(is_InfD64($rop) > 0) {print "ok 4\n"} else { warn "\$rop: $rop\n"; print "not ok 4\n"; } Rmpfr_set_DECIMAL64($fr, $ninfD64, MPFR_RNDN); Rmpfr_get_DECIMAL64($rop, $fr, MPFR_RNDN); if(is_InfD64($rop) < 0) {print "ok 5\n"} else { warn "\$rop: $rop\n"; print "not ok 5\n"; } Rmpfr_set_DECIMAL64($fr, $zeroD64, MPFR_RNDN); Rmpfr_get_DECIMAL64($rop, $fr, MPFR_RNDN); if(is_ZeroD64($rop) > 0) {print "ok 6\n"} else { warn "\$rop: $rop\n"; print "not ok 6\n"; } Rmpfr_set_DECIMAL64($fr, $nzeroD64, MPFR_RNDN); Rmpfr_get_DECIMAL64($rop, $fr, MPFR_RNDN); if(is_ZeroD64($rop) < 0) {print "ok 7\n"} else { warn "\$rop: $rop\n"; print "not ok 7\n"; } my $bigpos = Math::MPFR->new('1@385'); my $bigneg = $bigpos * -1; Rmpfr_get_DECIMAL64($rop, $bigpos, MPFR_RNDN); if(is_InfD64($rop) > 0) {print "ok 8\n"} else { warn "\n\$rop: $rop\n"; print "not ok 8\n"; } Rmpfr_get_DECIMAL64($rop, $bigneg, MPFR_RNDN); if(is_InfD64($rop) < 0) {print "ok 9\n"} else { warn "\n\$rop: $rop\n"; print "not ok 9\n"; } Rmpfr_get_DECIMAL64($rop, $bigpos, MPFR_RNDZ); if($rop == Math::Decimal64->new('9999999999999999','369')) {print "ok 10\n"} else { warn "\n\$rop: $rop\n"; print "not ok 10\n"; } if($rop == Math::Decimal64->new('9999999999999999','369')) {print "ok 11\n"} else { warn "\n\$rop: $rop\n"; print "not ok 11\n"; } if($rop == Math::Decimal64::DEC64_MAX()) {print "ok 12\n"} else { warn "\n\$rop: $rop\n"; print "not ok 12\n"; } my $littlepos = Math::MPFR->new('1@-399'); my $littleneg = $littlepos * -1; Rmpfr_get_DECIMAL64($rop, $littlepos, MPFR_RNDZ); if(is_ZeroD64($rop) > 0) {print "ok 13\n"} else { warn "\n\$rop: $rop\n"; print "not ok 13\n"; } Rmpfr_get_DECIMAL64($rop, $littleneg, MPFR_RNDZ); if(is_ZeroD64($rop) < 0) {print "ok 14\n"} else { warn "\n\$rop: $rop\n"; print "not ok 14\n"; } Rmpfr_get_DECIMAL64($rop, $littlepos, MPFR_RNDA); if($rop == Math::Decimal64->new(1, -398)) {print "ok 15\n"} else { warn "\n\$rop: $rop\n"; print "not ok 15\n"; } Rmpfr_get_DECIMAL64($rop, $littleneg, MPFR_RNDA); if($rop == Math::Decimal64->new(-1, -398)) {print "ok 16\n"} else { warn "\n\$rop: $rop\n"; print "not ok 16\n"; } if($rop == Math::Decimal64::DEC64_MIN() * Math::Decimal64::UnityD64(-1)) {print "ok 17\n"} else { warn "\n\$rop: $rop\n"; print "not ok 17\n"; } my $fr_d64 = Rmpfr_init2(55); my $d64_1 = MEtoD64('1', -298); my $d64_2 = Math::Decimal64->new(); Rmpfr_set_DECIMAL64($fr_d64, $d64_1, MPFR_RNDN); Rmpfr_get_DECIMAL64($d64_2, $fr_d64, MPFR_RNDN); if($d64_1 == $d64_2) {print "ok 18\n"} else { warn "\n $d64_1: $d64_1\n \$d64_2: $d64_2\n"; print "not ok 18\n"; } $d64_1 = NVtoD64(1e-298); Rmpfr_set_DECIMAL64($fr_d64, $d64_1, MPFR_RNDN); Rmpfr_get_DECIMAL64($d64_2, $fr_d64, MPFR_RNDN); if($d64_1 == $d64_2) {print "ok 19\n"} else { warn "\n $d64_1: $d64_1\n \$d64_2: $d64_2\n"; print "not ok 19\n"; } $d64_1 = MEtoD64('1', -360); Rmpfr_set_DECIMAL64($fr_d64, $d64_1, MPFR_RNDN); Rmpfr_get_DECIMAL64($d64_2, $fr_d64, MPFR_RNDN); if($d64_1 == $d64_2) {print "ok 20\n"} else { warn "\n $d64_1: $d64_1\n \$d64_2: $d64_2\n"; print "not ok 20\n"; } $d64_1 = NVtoD64(1e-360); Rmpfr_set_DECIMAL64($fr_d64, $d64_1, MPFR_RNDN); Rmpfr_get_DECIMAL64($d64_2, $fr_d64, MPFR_RNDN); if($d64_1 == $d64_2) {print "ok 21\n"} else { warn "\n $d64_1: $d64_1\n \$d64_2: $d64_2\n"; print "not ok 21\n"; } } else { warn "Skipping all tests - Math::MPFR not built for Decimal64 support"; print "ok $_\n" for 1..$t; } Math-MPFR-4.38/t/decimalize.t0000755060175106010010000002117514765756127014453 0ustar OwnerNoneuse strict; use warnings; use Math::MPFR qw(:mpfr); use Config; use Test::More; # For version 3 and earlier, minimum precision is 2. # With version 4 and later of mpfr, minimum precision is 1. # However, mpfr-4.0.0 and 4.0.1 are buggy when precision is 1, # so we have the decimalize() function disallow precision of 1 # if the mpfr library version is less than 4.0.2. my $prec_correction = 0; $prec_correction++ if 262146 > MPFR_VERSION; # earlier than 4.0.2 if(Math::MPFR::MPFR_3_1_6_OR_LATER) { like( decimalize(Math::MPFR->new()), '/^nan$/i', 'NaN decimalizes as expected'); if('inf' + 0 == 0) { # Can happen with older perls on MS Win32 like( decimalize(Math::MPFR->new(99 ** (99 ** 99))), '/^inf$/i', 'Inf decimalizes as expected'); like( decimalize(Math::MPFR->new(-(99 ** (99 ** 99)))), '/^\-inf$/i', '-Inf decimalizes as expected'); } else { like( decimalize(Math::MPFR->new('inf' + 0)), '/^inf$/i', 'Inf decimalizes as expected'); like( decimalize(Math::MPFR->new('-inf' + 0)), '/^\-inf$/i', '-Inf decimalizes as expected'); } cmp_ok( decimalize(Math::MPFR->new(0)), 'eq', '0', '0 decimalizes as expected'); cmp_ok( decimalize(Math::MPFR->new('-0')), 'eq', '-0', '-0 decimalizes as expected'); cmp_ok( decimalize(Math::MPFR->new('0.1')), 'eq', '0.1000000000000000055511151231257827021181583404541015625', '0.1 decimalizes as expected'); cmp_ok(check_exact_decimal(decimalize(Math::MPFR->new('1.7976931348623157e+308')), Math::MPFR->new('1.7976931348623157e+308')), '==', 1, 'DBL_MAX decimalizes as expected'); cmp_ok(check_exact_decimal(decimalize(Math::MPFR->new('-1.7976931348623157e+308')), Math::MPFR->new('-1.7976931348623157e+308')), '==', 1, '-DBL_MAX decimalizes as expected'); cmp_ok(check_exact_decimal(decimalize(Math::MPFR->new('1' x 51, 2)), Math::MPFR->new('1' x 51, 2)), '==', 1, '2251799813685247.0 decimalizes as expected'); cmp_ok(check_exact_decimal(decimalize(Math::MPFR->new('-' . ('1' x 51), 2)), Math::MPFR->new('-' . ('1' x 51), 2)), '==', 1, '-2251799813685247.0 decimalizes as expected'); cmp_ok(check_exact_decimal(decimalize(Math::MPFR->new('1' x 52, 2)), Math::MPFR->new('1' x 52, 2)), '==', 1, '4.503599627370495e15 decimalizes as expected'); cmp_ok(check_exact_decimal(decimalize(Math::MPFR->new('-' . ('1' x 52), 2)), Math::MPFR->new('-' . ('1' x 52), 2)), '==', 1, '-4.503599627370495e15 decimalizes as expected'); cmp_ok(check_exact_decimal(decimalize(Math::MPFR->new('1' x 53, 2)), Math::MPFR->new('1' x 53, 2)), '==', 1, '9.007199254740991e15 decimalizes as expected'); cmp_ok(check_exact_decimal(decimalize(Math::MPFR->new('-' . ('1' x 53), 2)), Math::MPFR->new('-' . ('1' x 53), 2)), '==', 1, '-9.007199254740991e15 decimalizes as expected'); cmp_ok(check_exact_decimal(decimalize(Math::MPFR->new('1' x 54, 2)), Math::MPFR->new('1' x 54, 2)), '==', 1, '1.8014398509481984e16 decimalizes as expected'); cmp_ok(check_exact_decimal(decimalize(Math::MPFR->new('-' . ('1' x 54), 2)), Math::MPFR->new('-' . ('1' x 54), 2)), '==', 1, '-1.8014398509481984e16 decimalizes as expected'); cmp_ok(check_exact_decimal(decimalize(Math::MPFR->new('1' x 55, 2)), Math::MPFR->new('1' x 55, 2)), '==', 1, '3.6028797018963968e16 decimalizes as expected'); cmp_ok(check_exact_decimal(decimalize(Math::MPFR->new('-' . ('1' x 55), 2)), Math::MPFR->new('-' . ('1' x 55), 2)), '==', 1, '-3.6028797018963968e16 decimalizes as expected'); cmp_ok(check_exact_decimal(decimalize(Math::MPFR->new(('1' x 53) . '0', 2)), Math::MPFR->new(('1' x 53) . '0', 2)), '==', 1, '3.6028797018963964e16 decimalizes as expected'); cmp_ok(check_exact_decimal(decimalize(Math::MPFR->new('-' . ('1' x 53) . '0', 2)), Math::MPFR->new('-' . ('1' x 53) . '0', 2)), '==', 1, '-3.6028797018963964e16 decimalizes as expected'); my $rand_max = 500; $rand_max = 5000 if $Config{nvsize} > 8; for my $v (1 .. 1290) { my $exp = $v < 900 ? int(rand(25)) : int(rand($rand_max)); $exp = -$exp if $v % 3; my $x = 1 + int(rand(99000)); my $z = 5 - length($x); my $s1 = '0.' . ('0' x $z) . "${x}e${exp}"; my $s2 = int(rand(500)) . "." . ('0' x $z) . "${x}e${exp}"; my $s3 = '1' . ('0' x $z) . "${x}e${exp}"; unless($v % 5) { for my $string($s1, $s2, $s3) { $string = '-' . $string } } my $prec; $prec = $v < 10 ? $v : 1 + int(rand(200)); eval {Rmpfr_set_default_prec($prec);}; if($prec_correction && $prec == 1 && 262144 > MPFR_VERSION) { like( $@, qr/^Precision must be set to at least 2/, "precision of 1 is forbidden" ); next; } my $op1 = Math::MPFR->new($s1); my $op2 = Math::MPFR->new($s2); my $op3 = Math::MPFR->new($s3); my $str1; eval{ $str1 = decimalize($op1); }; if($prec_correction && $prec == 1 && 262146 > MPFR_VERSION) { like( $@, qr/^Precision of 1 not allowed/, "precision of 1 is forbidden" ); next; } my $str2 = decimalize($op2); my $str3 = decimalize($op3); cmp_ok(check_exact_decimal($str1, $op1), '==', 1, "'$s1', at precision $prec, decimalized as expected"); cmp_ok(check_exact_decimal($str2, $op2), '==', 1, "'$s2', at precision $prec, decimalized as expected"); cmp_ok(check_exact_decimal($str3, $op3), '==', 1, "'$s3', at precision $prec, decimalized as expected"); my $len1 = significand_length($str1); my $len1_c = decimalize($op1, undef); # return length as calculated inside decimalize() cmp_ok($len1_c, '>=', $len1, "$str1: calculated length >= no. of significant digits"); cmp_ok($len1_c - $len1, '<=', 1, "$str1: calculated length - no. of significant digits <= 1"); my $len2 = significand_length($str2); my $len2_c = decimalize($op2, undef); # return length as calculated inside decimalize() cmp_ok($len2_c, '>=', $len2, "$str2: calculated length >= no. of significant digits"); cmp_ok($len2_c - $len2, '<=', 1, "$str2: calculated length - no. of significant digits <= 1"); my $len3 = significand_length($str3); my $len3_c = decimalize($op3, undef); # return length as calculated inside decimalize() cmp_ok($len3_c, '>=', $len3, "$str3: calculated length >= no. of significant digits"); cmp_ok($len3_c - $len3, '<=', 1, "$str3: calculated length - no. of significant digits <= 1"); } cmp_ok(decimalize(Math::MPFR->new(0), undef), '==', 0, "Zero has 0 significand digits"); my $irregular = Math::MPFR->new(); cmp_ok(decimalize($irregular, undef), '==', 0, "NaN has 0 significand digits"); Rmpfr_set_inf($irregular, 1); cmp_ok(decimalize($irregular, undef), '==', 0, "Inf has 0 significand digits"); Rmpfr_set_inf($irregular, -1); cmp_ok(decimalize($irregular, undef), '==', 0, "-Inf has 0 significand digits"); Rmpfr_set_zero($irregular, 1); cmp_ok(decimalize($irregular, undef), '==', 0, "Zero has 0 significand digits"); Rmpfr_set_zero($irregular, -1); cmp_ok(decimalize($irregular, undef), '==', 0, "-0 has 0 significand digits"); } else { warn " Unable to validate decimalize() results.\n"; warn " check_exact_decimal() requires mpfr-3.1.6 or later.\n"; warn " Math::MPFR was built against mpfr-", MPFR_VERSION_STRING, "."; eval { check_exact_decimal(decimalize(Math::MPFR->new(23.2))) }; ok( $@ =~ m/Math::MPFR was built against mpfr\-/, '$@ set as expected' ); } done_testing(); sub significand_length { my $s = shift; $s =~ s/^\-//; # remove leading '-' $s =~ s/\.// ; # remove radix point $s =~ s/^0+//; # remove leading zeroes return length( (split /e/i, $s)[0] ); } Math-MPFR-4.38/t/div_by_zero.t0000755060175106010010000001074214765756127014656 0ustar OwnerNoneuse warnings; use strict; use Math::MPFR qw(:mpfr); print "1..3\n"; print "# Using Math::MPFR version ", $Math::MPFR::VERSION, "\n"; print "# Using mpfr library version ", MPFR_VERSION_STRING, "\n"; print "# Using gmp library version ", Math::MPFR::gmp_v(), "\n"; my $ok; my($have_mpz, $have_mpq, $have_gmp) = (0, 0, 0); eval{require Math::GMPz;}; unless($@) {$have_mpz = 1} eval{require Math::GMPq;}; unless($@) {$have_mpq = 1} eval{require Math::GMP;}; unless($@) {$have_gmp = 1} my($q_zero, $z_zero); # Rmpfr_div # Rmpfr_div_d Rmpfr_div_q Rmpfr_div_si Rmpfr_div_ui Rmpfr_div_z # Rmpfr_si_div Rmpfr_ui_div Rmpfr_d_div my $unity = Math::MPFR->new(1); my $rop = Math::MPFR->new(); my $fr_zero = Math::MPFR->new(0); if($have_gmp) {$z_zero = Math::GMP->new(0)} if($have_mpz && !$have_gmp) {$z_zero = Math::GMPz->new(0)} if($have_mpq) {$q_zero = Math::GMPq->new(0)} if((MPFR_VERSION_MAJOR == 3 && MPFR_VERSION_MINOR >= 1) || MPFR_VERSION_MAJOR > 3) { unless(Rmpfr_divby0_p()) {$ok .= 'a'} Rmpfr_set_divby0(); if(Rmpfr_divby0_p()) {$ok .= 'b'} Rmpfr_clear_divby0(); unless(Rmpfr_divby0_p()) {$ok .= 'c'} Rmpfr_set_divby0(); if(Rmpfr_divby0_p()) {$ok .= 'd'} Rmpfr_clear_flags(); unless(Rmpfr_divby0_p()) {$ok .= 'e'} if($ok eq 'abcde') {print "ok 1\n"} else { warn "1: \$ok: $ok\n"; print "not ok 1\n"; } $ok = ''; Rmpfr_div($rop, $unity, $fr_zero, GMP_RNDN); if(Rmpfr_divby0_p()) {$ok .= 'a'} Rmpfr_clear_divby0(); unless(Rmpfr_divby0_p()) {$ok .= 'b'} if($have_gmp || $have_mpz) { Rmpfr_div_z($rop, $unity, $z_zero, GMP_RNDN); if(Rmpfr_divby0_p()) {$ok .= 'c'} Rmpfr_clear_divby0(); unless(Rmpfr_divby0_p()) {$ok .= 'd'} } else { warn "Skipping tests 2c and 2d - no Math::GMP or Math::GMPz\n"; $ok .= 'cd'; } if($have_mpq) { Rmpfr_div_q($rop, $unity, $q_zero, GMP_RNDN); if(Rmpfr_divby0_p()) {$ok .= 'e'} Rmpfr_clear_divby0(); unless(Rmpfr_divby0_p()) {$ok .= 'f'} } else { warn "Skipping tests 2e and 2f - no Math::GMPq\n"; $ok .= 'ef'; } Rmpfr_div_ui($rop, $unity, 0, GMP_RNDN); if(Rmpfr_divby0_p()) {$ok .= 'g'} Rmpfr_clear_divby0(); unless(Rmpfr_divby0_p()) {$ok .= 'h'} Rmpfr_div_si($rop, $unity, 0, GMP_RNDN); if(Rmpfr_divby0_p()) {$ok .= 'i'} Rmpfr_clear_divby0(); unless(Rmpfr_divby0_p()) {$ok .= 'j'} Rmpfr_div_d($rop, $unity, 0.0, GMP_RNDN); if(Rmpfr_divby0_p()) {$ok .= 'k'} Rmpfr_clear_divby0(); unless(Rmpfr_divby0_p()) {$ok .= 'l'} Rmpfr_ui_div($rop, 15, $fr_zero, GMP_RNDN); if(Rmpfr_divby0_p()) {$ok .= 'm'} Rmpfr_clear_divby0(); unless(Rmpfr_divby0_p()) {$ok .= 'n'} Rmpfr_si_div($rop, -23, $fr_zero, GMP_RNDN); if(Rmpfr_divby0_p()) {$ok .= 'o'} Rmpfr_clear_divby0(); unless(Rmpfr_divby0_p()) {$ok .= 'p'} Rmpfr_d_div($rop, 12.34, $fr_zero, GMP_RNDN); if(Rmpfr_divby0_p()) {$ok .= 'q'} Rmpfr_clear_divby0(); unless(Rmpfr_divby0_p()) {$ok .= 'r'} if($ok eq 'abcdefghijklmnopqr') {print "ok 2\n"} else { warn "2: \$ok: $ok\n"; print "not ok 2\n"; } $ok = ''; $rop = $unity / $fr_zero; if(Rmpfr_divby0_p()) {$ok .= 'a'} Rmpfr_clear_divby0(); unless(Rmpfr_divby0_p()) {$ok .= 'b'} $rop = $unity / 0; if(Rmpfr_divby0_p()) {$ok .= 'c'} Rmpfr_clear_divby0(); unless(Rmpfr_divby0_p()) {$ok .= 'd'} $rop = $unity / 0.0; if(Rmpfr_divby0_p()) {$ok .= 'e'} Rmpfr_clear_divby0(); unless(Rmpfr_divby0_p()) {$ok .= 'f'} $rop = $unity / '0.0'; if(Rmpfr_divby0_p()) {$ok .= 'g'} Rmpfr_clear_divby0(); unless(Rmpfr_divby0_p()) {$ok .= 'h'} $rop = 1 / $fr_zero; if(Rmpfr_divby0_p()) {$ok .= 'i'} Rmpfr_clear_divby0(); unless(Rmpfr_divby0_p()) {$ok .= 'j'} $rop = -1 / $fr_zero; if(Rmpfr_divby0_p()) {$ok .= 'k'} Rmpfr_clear_divby0(); unless(Rmpfr_divby0_p()) {$ok .= 'l'} $rop = 12.34 / $fr_zero; if(Rmpfr_divby0_p()) {$ok .= 'm'} Rmpfr_clear_divby0(); unless(Rmpfr_divby0_p()) {$ok .= 'n'} $rop = '12.34' / $fr_zero; if(Rmpfr_divby0_p()) {$ok .= 'o'} Rmpfr_clear_divby0(); unless(Rmpfr_divby0_p()) {$ok .= 'p'} if($ok eq 'abcdefghijklmnop') {print "ok 3\n"} else { warn "3: \$ok: $ok\n"; print "not ok 3\n"; } } else { eval{Rmpfr_set_divby0();}; if($@ =~ /Rmpfr_set_divby0 not implemented/) {print "ok 1\n"} else {print "not ok 1\n"} eval{Rmpfr_clear_divby0();}; if($@ =~ /Rmpfr_clear_divby0 not implemented/) {print "ok 2\n"} else {print "not ok 2\n"} eval{Rmpfr_divby0_p();}; if($@ =~ /Rmpfr_divby0_p not implemented/) {print "ok 3\n"} else {print "not ok 3\n"} } Math-MPFR-4.38/t/DoubleDouble.t0000755060175106010010000003417414765756127014715 0ustar OwnerNoneuse warnings; use strict; use Math::MPFR qw(:mpfr); #use Math::NV qw(:all); my $test_nv1 = 1.0; my $test_nv2 = $test_nv1 + (2 ** -1000); if($test_nv2 > $test_nv1 && Math::MPFR::_has_longdouble()) { my $t = 266; print "1..$t\n"; Rmpfr_set_default_prec(2098); my $nv = (2 ** 100) + (2 ** -1060) + (2 ** -1068) + (2 ** -1074); my $fr = Math::MPFR->new($nv); if($nv == $fr) {print "ok 1\n"} else { warn "\n\$nv: $nv\n\$fr: $fr\n"; print "not ok 1\n"; } if($fr > 2 ** 100) { print "ok 2\n"} else {print "not ok 2\n"} if(!Rmpfr_cmp_ld($fr, $nv)) {print "ok 3\n"} else { warn "\n\$nv: $nv\n\$fr: $fr\n"; print "not ok 3\n"; } my $nv_redone = Rmpfr_get_ld($fr, MPFR_RNDN); if($nv_redone == $nv) { print "ok 4\n"; } else { warn "\n\$nv: $nv\n\$nv_redone: $nv_redone\n"; print "not ok 4\n"; } my $nv_redone2 = Rmpfr_get_NV($fr, MPFR_RNDN); if($nv_redone2 == $nv) { print "ok 5\n"; } else { warn "\n\$nv: $nv\n\$nv_redone: $nv_redone\n"; print "not ok 5\n"; } my $fr2 = Math::MPFR->new($nv + (2 ** 100)); if(Rmpfr_cmp_ld($fr2, $nv) > 0) {print "ok 6\n"} else { warn "\n\$fr: $fr\n\$fr2: $fr2\n"; print "not ok 6\n"; } my $set_test = Rmpfr_init(); my $ret = Rmpfr_set_ld($set_test, $nv, MPFR_RNDN); if(!$ret) {print "ok 7\n"} else { warn "\n\$ret: $ret\n"; print "not ok 7\n"; } my @variants = (1,2,3,4); $t = 7; # Tests 8-11 follow: ################################# for my $v(@variants) { my($ok, $count) = (1, 0); $t++; my @curr; @curr = ('-', '-') if $v == 1; @curr = ('+', '-') if $v == 2; @curr = ('-', '+') if $v == 3; @curr = ('+', '+') if $v == 4; ################################# for my $exp(0..10, 20, 30, 280 .. 308) { for my $digits(1..31) { my $str = $curr[0] . random_select($digits) . 'e' . $curr[1] . "$exp"; my $nv = $str * 1.0; my $fr = Math::MPFR->new(); my $tern = Rmpfr_set_ld($fr, $nv, MPFR_RNDN); #print "$nv "; if($tern) { warn "\n$str: $str \$tern: $tern\n" unless $count > 5; $ok = 0; $count++; } if($nv != $fr) { warn "\n$str: $str \$nv: $nv \$fr: $fr\n" unless $count > 5; $ok = 0; $count++; } my $nv_redone = Rmpfr_get_ld($fr, MPFR_RNDN); if($nv != $nv_redone) { warn "\n$str: $str \$nv: $nv \$nv_redone: $nv_redone\n" unless $count > 5; $ok = 0; $count++; } } } if($ok) {print "ok $t\n"} else {print "not ok $t\n"} } ################################# for my $v(@variants) { my($ok, $count) = (1, 0); $t++; my @curr; @curr = ('-', '-') if $v == 1; @curr = ('+', '-') if $v == 2; @curr = ('-', '+') if $v == 3; @curr = ('+', '+') if $v == 4; ################################# for my $exp(0..10, 20, 30, 280 .. 308) { for my $digits(1..31) { my $str = $curr[0] . '0.' . random_select($digits) . 'e' . $curr[1] . "$exp"; my $nv = $str * 1.0; my $fr = Math::MPFR->new(); my $tern = Rmpfr_set_ld($fr, $nv, MPFR_RNDN); if($tern) { warn "\n$str: $str \$tern: $tern\n" unless $count > 5; $ok = 0; $count++; } if($nv != $fr) { warn "\n$str: $str \$nv: $nv \$fr: $fr\n" unless $count > 5; $ok = 0; $count++; } my $nv_redone = Rmpfr_get_ld($fr, MPFR_RNDN); if($nv != $nv_redone) { warn "\n$str: $str \$nv: $nv \$nv_redone: $nv_redone\n" unless $count > 5; $ok = 0; $count++; } } } if($ok) {print "ok $t\n"} else {print "not ok $t\n"} } Rmpfr_set_default_prec(106); $t = 16; for(-305 .. -293) { my $str = "1e$_"; my $f1 = Math::MPFR->new($str); my $nv = $str * 1.0; #my $nv = nv($str); my $f2 = Math::MPFR->new($nv); if($f1 != $f2) {print "ok $t\n"} else { warn "\n$str: \$f1 == \$f2\n"; Rmpfr_dump($f1); Rmpfr_dump($f2); print "not ok $t\n"; } $t++; if($f1 != $nv) {print "ok $t\n"} else { warn "\n$str: \$f1 == \$nv\n"; print "not ok $t\n"; } $t++; if($f2 == $nv) {print "ok $t\n"} else { warn "\n$str: \$f2 != $nv\n"; print "not ok $t\n"; } $t++; my $n1 = Rmpfr_get_ld($f1, MPFR_RNDN); my $n2 = Rmpfr_get_ld($f2, MPFR_RNDN); if($n1 == $nv) {print "ok $t\n"} else { $n1 > $nv ? warn "\n$str: \$n1 is greater than \$nv\n" : warn "\n$str: \$n1 is less than \$nv\n"; print "not ok $t\n"; } $t++; if($n2 == $nv) {print "ok $t\n"} else { $n2 > $nv ? warn "\n$str: \$n2 is greater than \$nv\n" : warn "\n$str: \$n2 is less than \$nv\n"; print "not ok $t\n"; } $t++; } #Rmpfr_dump($f1); #Rmpfr_dump($f2); Rmpfr_set_default_prec(2098); $t--; # Otherwise we don't run a test 81 # Tests 81-88 follow for my $exp(298 .. 304) { $t++; my $ok = 1; my $str = '0.0000000009' . "e-$exp"; my $nv = $str * 1.0; my $fr = Math::MPFR->new(); my $tern = Rmpfr_set_ld($fr, $nv, MPFR_RNDN); if($tern) { warn "\n$str: Rmpfr_set_ld returned true\n"; $ok = 0; } if($fr != $nv) { warn "\n$str: \$fr != \$nv\n"; $ok = 0; } my $nv_redone = Rmpfr_get_ld($fr, MPFR_RNDN); if($nv != $nv_redone) { warn "\n$str: \$nv != \$nv_redone\n"; $ok = 0; } if($ok) {print "ok $t\n"} else {print "not ok $t\n"} } # Tests 89-95 follow: Rmpfr_set_default_prec(106); for my $exp(298 .. 304) { $t++; my $ok = 1; my $str = '0.0000000009' . "e-$exp"; my $nv = $str * 1.0; my $fr = Math::MPFR->new($nv); my $nv_redone = Rmpfr_get_ld($fr, MPFR_RNDN); if($nv != $nv_redone) { warn "\n$str: \$nv != \$nv_redone\n"; $ok = 0; } if($ok) {print "ok $t\n"} else {print "not ok $t\n"} } my($nv1, $nv2, $nv3, $nv4) = (2 ** 1023, 2 ** 1000, 2 ** - 1074, 2 ** -1054); @variants = (1, 2, 3, 4); # Tests 96-99 follow: ################################# for my $v(@variants) { my($ok, $count) = (1, 0); $t++; my @curr; @curr = ('-1', '-1') if $v == 4; @curr = ('+1', '-1') if $v == 2; @curr = ('-1', '+1') if $v == 3; @curr = ('+1', '+1') if $v == 1; ################################# my $nv = ($nv2 + ($nv1 * $curr[0])) + ($nv4 + ($nv3 * $curr[1])); my $fr = Rmpfr_init(); my $tern = Rmpfr_set_ld($fr, $nv, MPFR_RNDN); if(!$tern) { warn "\n@curr: Rmpfr_set_ld returned 0\n"; $ok = 0; } if($fr == $nv) { warn "\n@curr: \$fr == $nv\n"; $ok = 0; } my $nv_redone = Rmpfr_get_ld($fr, MPFR_RNDN); if($nv == $nv_redone) { warn "\n@curr: NV's match"; $ok = 0; } if($ok) {print "ok $t\n"} else {print "not ok $t\n"} ############################# } # Close "for(@variants)" loop ############################# # Tests 100-103 follow: ################################# for my $v(@variants) { my($ok, $count) = (1, 0); $t++; my @curr; @curr = ('-1', '-1') if $v == 4; @curr = ('+1', '-1') if $v == 2; @curr = ('-1', '+1') if $v == 3; @curr = ('+1', '+1') if $v == 1; ################################# my $nv = ($nv2 + ($nv1 * $curr[0])) - ($nv4 + ($nv3 * $curr[1])); my $fr = Rmpfr_init(); my $tern = Rmpfr_set_ld($fr, $nv, MPFR_RNDN); if(!$tern) { warn "\n@curr: Rmpfr_set_ld returned 0\n"; $ok = 0; } if($fr == $nv) { warn "\n@curr: \$fr == $nv\n"; $ok = 0; } my $nv_redone = Rmpfr_get_ld($fr, MPFR_RNDN); if($nv == $nv_redone) { warn "\n@curr: NV's match"; $ok = 0; } if($ok) {print "ok $t\n"} else {print "not ok $t\n"} ############################# } # Close "for(@variants)" loop ############################# my @case1 = ('9007199254740991.01', '9007199254740991.04', '9007199254740991.05', '9007199254740991.06', '9007199254740991.09', '9007199254740991.02', '9007199254740991.03', '9007199254740991.07', '9007199254740991.08', '9007199254740991.11', '9007199254740991.14', '9007199254740991.15', '9007199254740991.16', '9007199254740991.10', '9007199254740991.12', '9007199254740991.13', '9007199254740991.17', '9007199254740991.19', '9007199254740991.41', '9007199254740991.44', '9007199254740991.45', '9007199254740991.46', '9007199254740991.40', '9007199254740991.42', '9007199254740991.43', '9007199254740991.48', '9007199254740991.49', '9007199254740991.4999999', '9007199254740991.50', '9007199254740991.51', '9007199254740991.55', '9007199254740991.56', '9007199254740991.52', '9007199254740991.53', '9007199254740991.57', '9007199254740991.58', '9007199254740991.59', '9007199254740991.61', '9007199254740991.64', '9007199254740991.65', '9007199254740991.66', '9007199254740991.69', '9007199254740991.91', '9007199254740991.94', '9007199254740991.95', '9007199254740991.96', '9007199254740991.90', '9007199254740991.94999999', '9007199254740991.92', '9007199254740991.93', '9007199254740991.99', ); my @case2 = ('9007199254740990.01', '9007199254740990.04', '9007199254740990.05', '9007199254740990.06', '9007199254740990.09', '9007199254740990.11', '9007199254740990.14', '9007199254740990.15', '9007199254740990.16', '9007199254740990.19', '9007199254740990.41', '9007199254740990.44', '9007199254740990.45', '9007199254740990.46', '9007199254740990.49', '9007199254740990.50', '9007199254740990.51', '9007199254740990.55', '9007199254740990.56', '9007199254740990.59', '9007199254740990.61', '9007199254740990.64', '9007199254740990.65', '9007199254740990.66', '9007199254740990.69', '9007199254740990.91', '9007199254740990.94', '9007199254740990.95', '9007199254740990.96', '9007199254740990.99', ); my @case3 = ('4503599627370495.01', '4503599627370495.04', '4503599627370495.05', '4503599627370495.06', '4503599627370495.09', '4503599627370495.11', '4503599627370495.14', '4503599627370495.15', '4503599627370495.16', '4503599627370495.19', '4503599627370495.41', '4503599627370495.44', '4503599627370495.45', '4503599627370495.46', '4503599627370495.49', '4503599627370495.50', '4503599627370495.51', '4503599627370495.55', '4503599627370495.56', '4503599627370495.59', '4503599627370495.61', '4503599627370495.64', '4503599627370495.65', '4503599627370495.66', '4503599627370495.69', '4503599627370495.91', '4503599627370495.94', '4503599627370495.95', '4503599627370495.96', '4503599627370495.99', ); Rmpfr_set_default_prec(2098); # Tests 104-214 follow for my $str (@case1, @case2, @case3) { $t++; my $ok = 1; my $nv = $str + 0; my $fr = Rmpfr_init(); my $tern = Rmpfr_set_ld($fr, $nv, MPFR_RNDN); if($tern) { warn "\n$str: Rmpfr_set_ld returned $tern\n"; $ok = 0; } if($fr != $nv) { warn "\n$str: \$fr != \$nv\n"; $ok = 0; } my $nv_redone = Rmpfr_get_NV($fr, MPFR_RNDN); if($nv != $nv_redone) { warn "\n$str: \$nv != \$nv_redone\n"; $ok = 0; } if($ok) {print "ok $t\n"} else {print "not ok $t\n"} } # For double-doubles less than 2**-1021, 53-bits of precision and 2098 bits of precision should # both store the same value. my $fr_53 = Rmpfr_init2(53); my $fr_53_next = Rmpfr_init2(53); Rmpfr_set_ld($fr_53, 0.0, MPFR_RNDN); Rmpfr_set_ld($fr_53_next, 0.0, MPFR_RNDN); my $fr_2098 = Math::MPFR->new(); my $fr_2098_next = Math::MPFR->new(0); my $ld_53_next = 0; my $ld_2098_next = 0; # Tests 215-267 follow: for(-1074 .. -1022) { $t++; my $ok = 1; my $tern = Rmpfr_set_ld($fr_53, 2 ** $_, MPFR_RNDN); if($tern) { warn "\n$_: Rmpfr_set_ld to 53 bits returned true\n"; $ok = 0; } $tern = Rmpfr_set_ld($fr_2098, 2 ** $_, MPFR_RNDN); if($tern) { warn "\n$_: Rmpfr_set_ld to 53 bits returned true\n"; $ok = 0; } if($fr_53 != $fr_2098) { warn "\n$_: \$fr_53 and \$fr_2098 are not equal\n"; $ok = 0; } $fr_53_next += $fr_53; unless($fr_53_next > $fr_2098_next && $fr_2098_next < $fr_53_next) { warn "\n$_: \$fr_53_next/\$fr_2098_next anomaly\n"; $ok = 0; } unless($fr_53_next > $ld_53_next && $ld_53_next < $fr_53_next) { warn "\n$_: \$fr_53_next/\$ld_53_next anomaly\n"; $ok = 0; } #Rmpfr_add($fr_53_next, $fr_53_next, $fr_53, MPFR_RNDN); $fr_2098_next += $fr_2098; #Rmpfr_add($fr_2098_next, $fr_2098_next, $fr_2098, MPFR_RNDN); if($fr_53_next != $fr_2098_next) { warn "\n$_: \$fr_53_next and \$fr_2098_next are not equal\n"; $ok = 0; } #Rmpfr_dump($fr_53_next); #Rmpfr_dump($fr_2098_next); #exit 0; my $ld_53 = Rmpfr_get_ld($fr_53, MPFR_RNDN); if($ld_53 != $fr_53) { warn "\n$_: \$ld_53 != \$fr_53\n"; $ok = 0; } my $ld_2098 = Rmpfr_get_ld($fr_2098, MPFR_RNDN); if($ld_2098 != $fr_2098) { warn "\n$_: \$ld_2098 != \$fr_2098\n"; $ok = 0; } $ld_53_next += $ld_53; $ld_2098_next += $ld_2098; if($ld_53_next != $ld_2098_next) { warn "\n$_: \$ld_53_next != \$ld_2098_next\n"; $ok = 0; } if($ld_53_next != $fr_53_next) { warn "\n$_: \$ld_53_next != \$fr_53_next\n"; $ok = 0; } if($fr_2098_next != $ld_2098_next) { warn "\n$_: \$fr_2098_next != \$ld_2098_next\n"; $ok = 0; } if($ok) {print "ok $t\n"} else {print "not ok $t\n"} } ############## ############## } else { print "1..1\n"; warn "\nSkipping all tests - not a Double-Double build\n"; print "ok 1\n"; } ############################# ############################# sub random_select { my $ret = ''; for(1 .. $_[0]) { $ret .= int(rand(10)); } return $ret; } Math-MPFR-4.38/t/DoubleDouble2.t0000755060175106010010000000226514765756127014773 0ustar OwnerNoneuse warnings; use strict; use Config; use Math::MPFR qw(:mpfr); my $test_nv1 = 1.0; my $test_nv2 = $test_nv1 + (2 ** -1000); if($test_nv2 > $test_nv1 && Math::MPFR::_has_longdouble()) { print "1..3\n"; my $fr = Rmpfr_init2(106); Rmpfr_set_ld($fr, $test_nv2, MPFR_RNDN); if($fr == $test_nv2) {print "not ok 1\n"} else {print "ok 1\n"} my $check = Rmpfr_get_ld($fr, MPFR_RNDN); if($check == $test_nv2) {print "not ok 2\n"} else {print "ok 2\n"} if(Math::MPFR::_required_ldbl_mant_dig() == 2098) {print "ok 3\n"} else { warn "\n expected 2098, got ", Math::MPFR::_required_ldbl_mant_dig(), "\n"; print "not ok 3\n"; } } else { print "1..1\n"; warn "\nnot a Double-Double build.\nLDBL_MANT_DIG is ", Math::MPFR::_required_ldbl_mant_dig() == 2098 ? 106 : Math::MPFR::_required_ldbl_mant_dig() , "\n"; if(Math::MPFR::_required_ldbl_mant_dig() == 64 || Math::MPFR::_required_ldbl_mant_dig() == 2098 || Math::MPFR::_required_ldbl_mant_dig() == 113 || Math::MPFR::_required_ldbl_mant_dig() == 53 ) {print "ok 1\n"} else { warn "\n expected 2098, 64 or 53 - got ", Math::MPFR::_required_ldbl_mant_dig(), "\n"; print "not ok 1\n"; } } Math-MPFR-4.38/t/doubletoa.t0000755060175106010010000001063014765756127014315 0ustar OwnerNoneuse strict; use warnings; use Math::MPFR qw(:mpfr); use Config; if($Config{nvsize} != 8) { print "1..2\n"; if(Math::MPFR::_fallback_notify()) { print "not ok 1\n"} else {print "ok 1\n"} eval {my $x = doubletoa(42.0) }; if($@ =~ /^The doubletoa function is unavailable/) { print "ok 2\n" } else { warn "\$\@: $@\n"; print "not ok 2\n"; } } elsif(MPFR_VERSION() <= 196869) { print "1..1\n"; warn "\nSkipping all tests - they require mpfr-3.1.6 or later\n"; print "ok 1\n"; } else { print "1..11\n"; my $ok = 1; my $fb = Math::MPFR::_fallback_notify(); my $fb_tracker = 0; my ($count, $mismatch_count) = (0, 0); for my $iteration(1..1000) { last unless $ok; for my $exp(-326 .. 325) { $count++; my $str = rand(100); if($str !~ /e/) { $str .= (int(rand(10)) . int(rand(10)) . "e$exp") } $str = '-' . $str unless $iteration % 3; if($fb) { $fb_tracker = $Math::MPFR::doubletoa_fallback } my $v = $str + 0; my $s1 = doubletoa($v, "S"); my $s2 = nvtoa($v); if($s1 ne $s2) { #print "$str $s1 $s2\n"; $mismatch_count++; my $s1_alt = doubletoa($v); if($fb && $Math::MPFR::doubletoa_fallback - $fb_tracker != 2) { $ok = 0; warn "\nfallback anomaly with $str: $s1 ($s1_alt) $s2\n"; last; } my ($check1, $check2, $check3) = ( ($s1 eq $s1_alt), (atonv($s1) != atonv($s1_alt)), (atonv($s1) != atonv($s2)) ); if($check1 || $check2 || $check3) { $ok = 0; warn "\nmismatch for $str: $s1 ($s1_alt) $s2\n"; last; } } } } # print "Fallback: $Math::MPFR::doubletoa_fallback Mismatch: $mismatch_count\n"; if($ok) { print "ok 1\n" } else { print "not ok 1\n" } if($fb) { if($count > 10000) { if($Math::MPFR::doubletoa_fallback > 10 && $count / $Math::MPFR::doubletoa_fallback > 50) { print "ok 2\n"; } else { warn "\n Total Count: $count\nFallback count: $Math::MPFR::doubletoa_fallback\n"; print "not ok 2\n"; } } else { warn "\n Skipping test 2 - didn't test enough values\n"; print "ok 2\n"; } } else { if($Math::MPFR::doubletoa_fallback) { print "not ok 2\n" } else { print "ok 2\n" } } if(doubletoa(atodouble('8e94')) eq '8e+94') { print "ok 3\n" } else { warn "\nexpected: '8e+94'\ngot : '", doubletoa(atodouble('8e+94')), "'\n"; print "not ok 3\n"; } if(doubletoa(atodouble('-8e94')) eq '-8e+94') { print "ok 4\n" } else { warn "\nexpected: '-8e+94'\ngot : '", doubletoa(atodouble('-8e+94')), "'\n"; print "not ok 4\n"; } if(doubletoa(atodouble('80e94')) eq '8e+95') { print "ok 5\n" } else { warn "\nexpected: '8e+95'\ngot : '", doubletoa(atodouble('80e+94')), "'\n"; print "not ok 5\n"; } if(doubletoa(atodouble('81e94')) eq '8.1e+95') { print "ok 6\n" } else { warn "\nexpected: '8.1e+95'\ngot : '", doubletoa(atodouble('81e+94')), "'\n"; print "not ok 6\n"; } if(doubletoa(atodouble('8000000e94')) eq '8e+100') { print "ok 7\n" } else { warn "\nexpected: '8e+100'\ngot : '", doubletoa(atodouble('8000000e+94')), "'\n"; print "not ok 7\n"; } # 1e+23 is one of the values that Grisu3 cannot handle. my $d = atodouble('1e+23'); my $dtoa = doubletoa($d); # fall back to dragon if($dtoa eq '1e+23') { print "ok 8\n" } else { warn "\nexpected: '1e+23'\ngot : '", $dtoa, "'\n"; print "not ok 8\n"; } $dtoa = doubletoa($d, ''); # fall back to sprintf("%.17g", $d) if($dtoa eq '9.9999999999999992e+22' || $dtoa eq '9.9999999999999992e+022') { print "ok 9\n" } else { warn "\nexpected: '9.9999999999999992e+22 or 9.9999999999999992e+022'\ngot : '", $dtoa, "'\n"; print "not ok 9\n"; } $dtoa = doubletoa(0.0); if($dtoa eq '0.0') { print "ok 10\n" } else { warn "\nexpected: '0.0'\ngot : '", $dtoa, "'\n"; print "not ok 10\n"; } my $z = Math::MPFR->new(0); Rmpfr_neg($z, $z, MPFR_RNDN); # $z is -0.0 my $negzero = Rmpfr_get_NV($z, MPFR_RNDN); $dtoa = doubletoa($negzero); if($dtoa eq '-0.0') { print "ok 11\n" } else { warn "\nexpected: '-0.0'\ngot : '", $dtoa, "'\n"; print "not ok 11\n"; } } __END__ Math-MPFR-4.38/t/exceptions.t0000755060175106010010000000254114765756127014522 0ustar OwnerNoneuse strict; use warnings; use Math::MPFR qw(:mpfr); print "1..7\n"; print "# Using Math::MPFR version ", $Math::MPFR::VERSION, "\n"; print "# Using mpfr library version ", MPFR_VERSION_STRING, "\n"; print "# Using gmp library version ", Math::MPFR::gmp_v(), "\n"; my $x = Rmpfr_init(); my $y = Rmpfr_init(); if(Rmpfr_underflow_p() || Rmpfr_overflow_p() || Rmpfr_inexflag_p() || Rmpfr_nanflag_p() || Rmpfr_erangeflag_p()) {print "not ok 1\n"} else {print "ok 1\n"} Rmpfr_add($y, $y, $y, GMP_RNDN); if(Rmpfr_nanflag_p()) {print "ok 2\n"} else {print "not ok 2\n"} Rmpfr_set_ui($x, 2, GMP_RNDN); Rmpfr_cos($x, $x, GMP_RNDN); if(Rmpfr_inexflag_p()) {print "ok 3\n"} else {print "not ok 3\n"} Rmpfr_set_ui($x, 1, GMP_RNDN); Rmpfr_mul_2exp($x, $x, 1024, GMP_RNDN); Rmpfr_get_ui($x, GMP_RNDN); if(Rmpfr_erangeflag_p()) {print "ok 4\n"} else {print "not ok 4\n"} Rmpfr_set_emin(-1020); Rmpfr_set_emax(1020); Rmpfr_set_ui($x, 1, GMP_RNDN); Rmpfr_mul_2exp($x, $x, 1025, GMP_RNDN); if(Rmpfr_overflow_p()) {print "ok 5\n"} else {print "not ok 5\n"} Rmpfr_set_ui($x, 1, GMP_RNDN); Rmpfr_div_2exp($x, $x, 1025, GMP_RNDN); if(Rmpfr_underflow_p()) {print "ok 6\n"} else {print "not ok 6\n"} Rmpfr_clear_flags(); if(Rmpfr_underflow_p() || Rmpfr_overflow_p() || Rmpfr_inexflag_p() || Rmpfr_nanflag_p() || Rmpfr_erangeflag_p()) {print "not ok 7\n"} else {print "ok 7\n"} Math-MPFR-4.38/t/faithful_rounding.t0000755060175106010010000000432314765756127016050 0ustar OwnerNone# MPFR_RNDF (faithful) rounding should provide the same result # as either MPFR_RNDU rounding (up) or MPFR_RNDD rounding (down). # We check this. use strict; use warnings; use Test::More; use Math::MPFR qw(:mpfr); if( MPFR_VERSION_MAJOR() < 4) { warn " Skipping - these tests require mpfr-4.0.0\n or later, but we have only mpfr-", MPFR_VERSION_STRING(), "\n"; ok('1' eq '1', "dummy test"); done_testing(); exit 0; } for my $p(40, 50, 53, 55, 60) { my $rop1 = Rmpfr_init2($p); # $p-bit precision my $rop2 = Rmpfr_init2($p); # $p-bit precision my $rop3 = Rmpfr_init2($p); # $p-bit precision for my $its (1 .. 100) { my $f = Math::MPFR->new(rand(256)); # 53-bit precision my $c = Math::MPFR->new(rand(1024)); # 53-bit precision $f *= -1 if $its % 2; $c *= -1 unless $its % 7; Rmpfr_add($rop1, $f, $c, MPFR_RNDF); Rmpfr_add($rop2, $f, $c, MPFR_RNDU); Rmpfr_add($rop3, $f, $c, MPFR_RNDD); cmp_ok( check_it($rop1, $rop2, $rop3), '==', 1, "prec $p: $f + $c"); Rmpfr_sub($rop1, $f, $c, MPFR_RNDF); Rmpfr_sub($rop2, $f, $c, MPFR_RNDU); Rmpfr_sub($rop3, $f, $c, MPFR_RNDD); cmp_ok( check_it($rop1, $rop2, $rop3), '==', 1, "prec $p: $f - $c"); Rmpfr_mul($rop1, $f, $c, MPFR_RNDF); Rmpfr_mul($rop2, $f, $c, MPFR_RNDU); Rmpfr_mul($rop3, $f, $c, MPFR_RNDD); cmp_ok( check_it($rop1, $rop2, $rop3), '==', 1, "prec $p: $f * $c"); Rmpfr_div($rop1, $f, $c, MPFR_RNDF); Rmpfr_div($rop2, $f, $c, MPFR_RNDU); Rmpfr_div($rop3, $f, $c, MPFR_RNDD); cmp_ok( check_it($rop1, $rop2, $rop3), '==', 1, "prec $p: $f / $c"); Rmpfr_sqr($rop1, $c, MPFR_RNDF); Rmpfr_sqr($rop2, $c, MPFR_RNDU); Rmpfr_sqr($rop3, $c, MPFR_RNDD); cmp_ok( check_it($rop1, $rop2, $rop3), '==', 1, "prec $p: $c ** 2"); Rmpfr_sqrt($rop1, $c, MPFR_RNDF); Rmpfr_sqrt($rop2, $c, MPFR_RNDU); Rmpfr_sqrt($rop3, $c, MPFR_RNDD); if($c < 0) { cmp_ok( Rmpfr_nan_p($rop1), '!=', 0, "prec $p: sqrt($c)"); } else { cmp_ok( check_it($rop1, $rop2, $rop3), '==', 1, "prec $p: sqrt($c)"); } } } done_testing(); sub check_it { my($rop1, $rop2, $rop3) = (shift, shift, shift); return 1 if $rop1 == $rop2; return 1 if $rop1 == $rop3; return 0; } Math-MPFR-4.38/t/flags.t0000755060175106010010000001531514765756127013440 0ustar OwnerNoneuse warnings; use strict; use Math::MPFR qw(:mpfr); my $tests = 41; print "1..$tests\n"; print "# Using Math::MPFR version ", $Math::MPFR::VERSION, "\n"; print "# Using mpfr library version ", MPFR_VERSION_STRING, "\n"; print "# Using gmp library version ", Math::MPFR::gmp_v(), "\n"; my $ok = ''; Rmpfr_set_overflow(); if(Rmpfr_overflow_p()) {$ok .= 'a'} Rmpfr_clear_overflow(); if(!Rmpfr_overflow_p()) {$ok .= 'b'} Rmpfr_set_underflow(); if(Rmpfr_underflow_p()) {$ok .= 'c'} Rmpfr_clear_underflow(); if(!Rmpfr_underflow_p()) {$ok .= 'd'} Rmpfr_set_inexflag(); if(Rmpfr_inexflag_p()) {$ok .= 'e'} Rmpfr_clear_inexflag(); if(!Rmpfr_inexflag_p()) {$ok .= 'f'} Rmpfr_set_erangeflag(); if(Rmpfr_erangeflag_p()) {$ok .= 'g'} Rmpfr_clear_erangeflag(); if(!Rmpfr_erangeflag_p()) {$ok .= 'h'} Rmpfr_set_nanflag(); if(Rmpfr_nanflag_p()) {$ok .= 'i'} Rmpfr_clear_nanflag(); if(!Rmpfr_nanflag_p()) {$ok .= 'j'} if($ok eq 'abcdefghij') {print "ok 1\n"} else {print "not ok 1\n"} my $zero = Math::MPFR->new(0); my $inf = Math::MPFR->new(1); $ok = ''; $inf /= $zero; Rmpfr_clear_overflow(); if(!Rmpfr_overflow_p()) {$ok .= 'a'} Rmpfr_check_range($inf, 123, GMP_RNDN); if(Rmpfr_overflow_p()) {$ok .= 'b'} $inf *= -1; Rmpfr_clear_overflow(); if(!Rmpfr_overflow_p()) {$ok .= 'c'} Rmpfr_check_range($inf, 123, GMP_RNDN); if(Rmpfr_overflow_p()) {$ok .= 'd'} if($ok eq 'abcd') {print "ok 2\n"} else {print "not ok 2 $ok\n"} # Check the nanflag setting for some specific functions (which were buggy # up to and including 3.1.4) my $nan = Math::MPFR->new(); Rmpfr_clear_nanflag(); Rmpfr_add_ui($nan, $nan, ~0, MPFR_RNDN); if(Rmpfr_nanflag_p()) { print "ok 3\n"; Rmpfr_clear_nanflag(); } else { print "not ok 3\n"; } Rmpfr_add_si($nan, $nan, -1, MPFR_RNDN); if(Rmpfr_nanflag_p()) { print "ok 4\n"; Rmpfr_clear_nanflag(); } else { print "not ok 4\n"; } Rmpfr_sub_ui($nan, $nan, ~0, MPFR_RNDN); if(Rmpfr_nanflag_p()) { print "ok 5\n"; Rmpfr_clear_nanflag(); } else { print "not ok 5\n"; } Rmpfr_sub_si($nan, $nan, -1, MPFR_RNDN); if(Rmpfr_nanflag_p()) { print "ok 6\n"; Rmpfr_clear_nanflag(); } else { print "not ok 6\n"; } Rmpfr_ui_sub($nan, ~0, $nan, MPFR_RNDN); # OK if(Rmpfr_nanflag_p()) { print "ok 7\n"; Rmpfr_clear_nanflag(); } else { print "not ok 7\n"; } Rmpfr_si_sub($nan, -1, $nan, MPFR_RNDN); if(Rmpfr_nanflag_p()) { print "ok 8\n"; Rmpfr_clear_nanflag(); } else { print "not ok 8\n"; } $nan = $nan + ~0; if(Rmpfr_nanflag_p()) { print "ok 9\n"; Rmpfr_clear_nanflag(); } else { print "not ok 9\n"; } $nan = ~0 + $nan; if(Rmpfr_nanflag_p()) { print "ok 10\n"; Rmpfr_clear_nanflag(); } else { print "not ok 10\n"; } $nan += ~0; if(Rmpfr_nanflag_p()) { print "ok 11\n"; Rmpfr_clear_nanflag(); } else { print "not ok 11\n"; } $nan = $nan + -2; if(Rmpfr_nanflag_p()) { print "ok 12\n"; Rmpfr_clear_nanflag(); } else { print "not ok 12\n"; } $nan = -3 + $nan; if(Rmpfr_nanflag_p()) { print "ok 13\n"; Rmpfr_clear_nanflag(); } else { print "not ok 13\n"; } $nan += -5; if(Rmpfr_nanflag_p()) { print "ok 14\n"; Rmpfr_clear_nanflag(); } else { print "not ok 14\n"; } ################### $nan = $nan - ~0; if(Rmpfr_nanflag_p()) { print "ok 15\n"; Rmpfr_clear_nanflag(); } else { print "not ok 15\n"; } $nan = ~0 - $nan; # OK if(Rmpfr_nanflag_p()) { print "ok 16\n"; Rmpfr_clear_nanflag(); } else { print "not ok 16\n"; } $nan -= ~0; if(Rmpfr_nanflag_p()) { print "ok 17\n"; Rmpfr_clear_nanflag(); } else { print "not ok 17\n"; } $nan = $nan - 2; if(Rmpfr_nanflag_p()) { print "ok 18\n"; Rmpfr_clear_nanflag(); } else { print "not ok 18\n"; } $nan = -3 - $nan; if(Rmpfr_nanflag_p()) { print "ok 19\n"; Rmpfr_clear_nanflag(); } else { print "not ok 19\n"; } $nan -= 5; if(Rmpfr_nanflag_p()) { print "ok 20\n"; Rmpfr_clear_nanflag(); } else { print "not ok 20\n"; } ################### eval{require Math::GMPz;}; if(!$@) { my $z = Math::GMPz->new(123); Rmpfr_add_z($nan, $nan, $z, MPFR_RNDN); if(Rmpfr_nanflag_p()) { print "ok 21\n"; Rmpfr_clear_nanflag(); } else { print "not ok 21\n"; } Rmpfr_sub_z($nan, $nan, $z, MPFR_RNDN); if(Rmpfr_nanflag_p()) { print "ok 22\n"; Rmpfr_clear_nanflag(); } else { print "not ok 22\n"; } eval {Rmpfr_z_sub($nan, $z, $nan, MPFR_RNDN)}; # OK if($@) { if($@ =~ /Rmpfr_z_sub not implemented with this version of the mpfr library/) { warn "\nSkipping test 23 - Rmpfr_z_sub not implemented\n"; print "ok 23\n"; } else { warn "\n\$\@: $@\n"; print "not ok 23\n"; } } elsif(Rmpfr_nanflag_p()) { print "ok 23\n"; Rmpfr_clear_nanflag(); } else { print "not ok 23\n"; } $nan = $nan + $z; if(Rmpfr_nanflag_p()) { print "ok 24\n"; Rmpfr_clear_nanflag(); } else { print "not ok 24\n"; } $nan = $z + $nan; if(Rmpfr_nanflag_p()) { print "ok 25\n"; Rmpfr_clear_nanflag(); } else { print "not ok 25\n"; } $nan += $z; if(Rmpfr_nanflag_p()) { print "ok 26\n"; Rmpfr_clear_nanflag(); } else { print "not ok 26\n"; } $nan = $nan - $z; if(Rmpfr_nanflag_p()) { print "ok 27\n"; Rmpfr_clear_nanflag(); } else { print "not ok 27\n"; } $nan = $z - $nan; # OK if(Rmpfr_nanflag_p()) { print "ok 28\n"; Rmpfr_clear_nanflag(); } else { print "not ok 28\n"; } $nan -= $z; if(Rmpfr_nanflag_p()) { print "ok 29\n"; Rmpfr_clear_nanflag(); } else { print "not ok 29\n"; } } else { warn "\nSkipping tests 21 .. $tests - couldn't load Math::GMPZ:\n\$\@: $@\n"; for(21 .. 29) {print "ok $_\n"}; } my $fr_nan = Math::MPFR->new(); my $sv_nan = Rmpfr_get_NV($fr_nan, MPFR_RNDN); Rmpfr_clear_erangeflag(); if( Math::MPFR->new(6) == $sv_nan) { print "not ok 30\n" } else { print "ok 30\n" } if(Rmpfr_erangeflag_p()) { print "ok 31\n" } else { print "not ok 31\n" } Rmpfr_clear_erangeflag(); if( Math::MPFR->new(6) != $sv_nan) { print "ok 32\n" } else { print "not ok 32\n" } if(Rmpfr_erangeflag_p()) { print "ok 33\n" } else { print "not ok 33\n" } Rmpfr_clear_erangeflag(); if( $fr_nan == 6) { print "not ok 34\n" } else { print "ok 34\n" } if(Rmpfr_erangeflag_p()) { print "ok 35\n" } else { print "not ok 35\n" } Rmpfr_clear_erangeflag(); if( $fr_nan != 6) { print "ok 36\n" } else { print "not ok 36\n" } if(Rmpfr_erangeflag_p()) { print "ok 37\n" } else { print "not ok 37\n" } Rmpfr_clear_erangeflag(); if( $fr_nan == 6.1) { print "not ok 38\n" } else { print "ok 38\n" } if(Rmpfr_erangeflag_p()) { print "ok 39\n" } else { print "not ok 39\n" } Rmpfr_clear_erangeflag(); if( $fr_nan != 6.1) { print "ok 40\n" } else { print "not ok 40\n" } if(Rmpfr_erangeflag_p()) { print "ok 41\n" } else { print "not ok 41\n" } Math-MPFR-4.38/t/float128_conv.t0000755060175106010010000003116114765756127014726 0ustar OwnerNoneuse warnings; use strict; use Math::MPFR qw(:mpfr); use Config; my $t = 21; print "1..$t\n"; my $why; my $proceed = Math::MPFR::_MPFR_WANT_FLOAT128(); unless($proceed) { #################################################### if($Config{nvtype} eq '__float128') { Rmpfr_set_default_prec(114); my $ok = 1; my $it; for $it(1 .. 10000) { my $nv = rand(1024) / (1 + rand(1024)); #$ $larg_1 and $larg_2 will be complementary Rounding modes. my $larg_1 = int(rand(5)); my $larg_2 = $larg_1 ? 5 - $larg_1 : $larg_1; my $f128_1 = $nv; my $fr_1 = Math::MPFR->new(); Rmpfr_set_NV($fr_1, $f128_1, $larg_1); my $f128_2 = Rmpfr_get_NV($fr_1, $larg_2); unless($f128_1 == $f128_2) { $ok = 0; warn "$it: $f128_1 != $f128_2\n $larg_1 : $larg_2\n\n"; } } if($ok) {print "ok 1\n"} else {print "not ok 1\n"} $ok = 1; Rmpfr_set_default_prec(115); for $it(1 .. 10000) { my $nv = rand(1024) / (1 + rand(1024)); my $f128_1 = $nv; my $fr_1 = Math::MPFR->new(); Rmpfr_set_NV($fr_1, $f128_1, 0); my $f128_2 = Rmpfr_get_NV($fr_1, 0); unless($f128_1 == $f128_2) { $ok = 0; warn "$it: $f128_1 != $f128_2\n"; } } if($ok) {print "ok 2\n"} else {print "not ok 2\n"} my $nan = Rmpfr_get_NV(Math::MPFR->new(), MPFR_RNDN); my $pinf = 999 ** (999 ** 999); my $ninf = $pinf * -1.0; my $zero = 0.0; my $nzero = -1.0 / $pinf; my $fr = Math::MPFR->new(); Rmpfr_set_NV($fr, $nan, MPFR_RNDN); my $rop = Rmpfr_get_NV($fr, MPFR_RNDN); if($rop != $rop) {print "ok 3\n"} else { warn "\$rop: $rop\n"; print "not ok 3\n"; } Rmpfr_set_NV($fr, $pinf, MPFR_RNDN); $rop = Rmpfr_get_NV($fr, MPFR_RNDN); if($rop != 0.0 && $rop > 0.0 && $rop / $rop != 1.0) {print "ok 4\n"} else { warn "\$rop: $rop\n"; print "not ok 4\n"; } Rmpfr_set_NV($fr, $ninf, MPFR_RNDN); $rop = Rmpfr_get_NV($fr, MPFR_RNDN); if($rop != 0.0 && $rop < 0.0 && $rop / $rop != 1.0) {print "ok 5\n"} else { warn "\$rop: $rop\n"; print "not ok 5\n"; } Rmpfr_set_NV($fr, $zero, MPFR_RNDN); $rop = Rmpfr_get_NV($fr, MPFR_RNDN); if($rop == 0 && substr("$rop", 0, 1) ne '-') {print "ok 6\n"} else { warn "\$rop: $rop\n"; print "not ok 6\n"; } Rmpfr_set_NV($fr, $nzero, MPFR_RNDN); $rop = Rmpfr_get_NV($fr, MPFR_RNDN); if($rop == 0 && substr(sprintf("%e", $rop), 0, 1) eq '-') {print "ok 7\n"} else { warn "\nExpected -0\nGot: ", sprintf("%e", $rop), "\n"; if($rop == 0) { warn "Problem with signed zero - not registering a failure for this\n"; print "ok 7\n"; } else {print "not ok 7\n"} } my $bigpos = Math::MPFR->new('1.4e4932'); my $bigneg = $bigpos * -1; $rop = Rmpfr_get_NV($bigpos, MPFR_RNDN); if($rop != 0.0 && $rop > 0.0 && $rop / $rop != 1.0) {print "ok 8\n"} else { warn "\n\$rop: $rop\n"; print "not ok 8\n"; } $rop = Rmpfr_get_NV($bigneg, MPFR_RNDN); if($rop != 0.0 && $rop < 0.0 && $rop / $rop != 1.0) {print "ok 9\n"} else { warn "\n\$rop: $rop\n"; print "not ok 9\n"; } $rop = Rmpfr_get_NV(Math::MPFR->new('1.18973149535723176508575932662800702e4932'), MPFR_RNDZ); if($rop == '1.18973149535723176508575932662800702e4932') {print "ok 10\n"} else { warn "\n\$rop: $rop\n"; print "not ok 10\n"; } if(-$rop == '-1.18973149535723176508575932662800702e4932') {print "ok 11\n"} else { warn "\n\$rop: $rop\n"; print "not ok 11\n"; } print "ok 12\n"; my $littlepos = Math::MPFR->new('7e-4967'); my $littleneg = $littlepos * -1; $rop = Rmpfr_get_NV($littlepos, MPFR_RNDZ); if($rop == 0.0) {print "ok 13\n"} else { warn "\n\$rop: $rop\n"; print "not ok 13\n"; } $rop = Rmpfr_get_NV($littleneg, MPFR_RNDZ); if($rop == 0) {print "ok 14\n"} else { warn "\n\$rop: $rop\n"; print "not ok 14\n"; } # Any +ve non-zero value (no matter how small) will be rounded to a non-zero value under RNDA. # Values anywhere between zero and the minimum subnormal value (as is the case here) will be # rounded to that minimum subnormal value (6.47517511943802511092443895822764655e-4966) $rop = Rmpfr_get_NV($littlepos, MPFR_RNDA); if($rop == 6.475175119438025110924438958227646552e-4966) {print "ok 15\n"} else { warn "\n\$rop: $rop\n"; print "not ok 15\n"; } # Any -ve non-zero value (no matter how close to zero) will be rounded to a non-zero value under RNDA. # Values anywhere between zero and the negated minimum subnormal value (as is the case here) will be # be rounded to that negated minimum subnormal value (-6.47517511943802511092443895822764655e-4966) $rop = Rmpfr_get_NV($littleneg, MPFR_RNDA); if($rop == -6.475175119438025110924438958227646552e-4966) {print "ok 16\n"} else { warn "\n\$rop: $rop\n"; print "not ok 16\n"; } print "ok 17\n"; my $fr_F128 = Rmpfr_init2(115); my $f128_1 = 1e-298; Rmpfr_set_NV($fr_F128, $f128_1, MPFR_RNDN); my $f128_2 = Rmpfr_get_NV($fr_F128, MPFR_RNDN); if($f128_1 == $f128_2) {print "ok 18\n"} else { warn "\n $f128_1: $f128_1\n \$f128_2: $f128_2\n"; print "not ok 18\n"; } print "ok 19\n"; $f128_1 = 1e-360; Rmpfr_set_NV($fr_F128, $f128_1, MPFR_RNDN); $f128_2 = Rmpfr_get_NV($fr_F128, MPFR_RNDN); if($f128_1 == $f128_2) {print "ok 20\n"} else { warn "\n $f128_1: $f128_1\n \$f128_2: $f128_2\n"; print "not ok 20\n"; } print "ok 21\n"; } #################################################### else { $why = "__float128 tests not applicable to this build of perl\n"; warn "\n Skipping all tests: $why"; print "ok $_\n" for 1..$t; exit 0; } } else { eval {require Math::Float128; Math::Float128->import (qw(:all));}; if($@) { $why = "Couldn't load Math::Float128\n"; warn "\n Skipping all tests: $why: $@\n"; print "ok $_\n" for 1..$t; exit 0; } if(196866 >= MPFR_VERSION) { $why = "No float128 support with this version of the mpfr library\n"; warn "\n Skipping all tests: $why"; print "ok $_\n" for 1..$t; exit 0; } if($proceed) { Rmpfr_set_default_prec(114); my $ok = 1; my $it; for $it(1 .. 10000) { my $nv = rand(1024) / (1 + rand(1024)); #$ $larg_1 and $larg_2 will be complementary Rounding modes. my $larg_1 = int(rand(5)); my $larg_2 = $larg_1 ? 5 - $larg_1 : $larg_1; my $f128_1 = NVtoF128($nv); my $fr_1 = Math::MPFR->new(); Rmpfr_set_FLOAT128($fr_1, $f128_1, $larg_1); my $f128_2 = NVtoF128(0); Rmpfr_get_FLOAT128($f128_2, $fr_1, $larg_2); unless($f128_1 == $f128_2) { $ok = 0; warn "$it: $f128_1 != $f128_2\n $larg_1 : $larg_2\n\n"; } } if($ok) {print "ok 1\n"} else {print "not ok 1\n"} $ok = 1; Rmpfr_set_default_prec(115); for $it(1 .. 10000) { my $nv = rand(1024) / (1 + rand(1024)); my $f128_1 = NVtoF128($nv); my $fr_1 = Math::MPFR->new(); Rmpfr_set_FLOAT128($fr_1, $f128_1, 0); my $f128_2 = NVtoF128(0); Rmpfr_get_FLOAT128($f128_2, $fr_1, 0); unless($f128_1 == $f128_2) { $ok = 0; warn "$it: $f128_1 != $f128_2\n"; } } if($ok) {print "ok 2\n"} else {print "not ok 2\n"} my $nanF128 = NaNF128(); my $pinfF128 = InfF128(1); my $ninfF128 = InfF128(-1); my $zeroF128 = ZeroF128(1); my $nzeroF128 = ZeroF128(-1); my $rop = Math::Float128->new(); my $fr = Math::MPFR->new(); Rmpfr_set_FLOAT128($fr, $nanF128, MPFR_RNDN); Rmpfr_get_FLOAT128($rop, $fr, MPFR_RNDN); if(is_NaNF128($rop)) {print "ok 3\n"} else { warn "\$rop: $rop\n"; print "not ok 3\n"; } Rmpfr_set_FLOAT128($fr, $pinfF128, MPFR_RNDN); Rmpfr_get_FLOAT128($rop, $fr, MPFR_RNDN); if(is_InfF128($rop) > 0) {print "ok 4\n"} else { warn "\$rop: $rop\n"; print "not ok 4\n"; } Rmpfr_set_FLOAT128($fr, $ninfF128, MPFR_RNDN); Rmpfr_get_FLOAT128($rop, $fr, MPFR_RNDN); if(is_InfF128($rop) < 0) {print "ok 5\n"} else { warn "\$rop: $rop\n"; print "not ok 5\n"; } Rmpfr_set_FLOAT128($fr, $zeroF128, MPFR_RNDN); Rmpfr_get_FLOAT128($rop, $fr, MPFR_RNDN); if(is_ZeroF128($rop) > 0) {print "ok 6\n"} else { warn "\$rop: $rop\n"; print "not ok 6\n"; } Rmpfr_set_FLOAT128($fr, $nzeroF128, MPFR_RNDN); Rmpfr_get_FLOAT128($rop, $fr, MPFR_RNDN); if(is_ZeroF128($rop) < 0) {print "ok 7\n"} else { warn "\$rop: $rop\n"; print "not ok 7\n"; } my $bigpos = Math::MPFR->new('1.4e4932'); my $bigneg = $bigpos * -1; Rmpfr_get_FLOAT128($rop, $bigpos, MPFR_RNDN); if(is_InfF128($rop) > 0) {print "ok 8\n"} else { warn "\n\$rop: $rop\n"; print "not ok 8\n"; } Rmpfr_get_FLOAT128($rop, $bigneg, MPFR_RNDN); if(is_InfF128($rop) < 0) {print "ok 9\n"} else { warn "\n\$rop: $rop\n"; print "not ok 9\n"; } Rmpfr_get_FLOAT128($rop, Math::MPFR->new('1.18973149535723176508575932662800702e4932'), MPFR_RNDZ); if($rop == Math::Float128->new('1.18973149535723176508575932662800702e4932')) {print "ok 10\n"} else { warn "\n\$rop: $rop\n"; print "not ok 10\n"; } if(-$rop == Math::Float128->new('-1.18973149535723176508575932662800702e4932')) {print "ok 11\n"} else { warn "\n\$rop: $rop\n"; print "not ok 11\n"; } if($rop == Math::Float128::FLT128_MAX()) {print "ok 12\n"} else { warn "\n\$rop: $rop\n"; print "not ok 12\n"; } my $littlepos = Math::MPFR->new('7e-4967'); my $littleneg = $littlepos * -1; Rmpfr_get_FLOAT128($rop, $littlepos, MPFR_RNDZ); if(is_ZeroF128($rop) > 0) {print "ok 13\n"} else { warn "\n\$rop: $rop\n"; print "not ok 13\n"; } Rmpfr_get_FLOAT128($rop, $littleneg, MPFR_RNDZ); if(is_ZeroF128($rop) < 0) {print "ok 14\n"} else { warn "\n\$rop: $rop\n"; print "not ok 14\n"; } # Any +ve non-zero value (no matter how small) will be rounded to a non-zero value under RNDA. # Values anywhere between zero and the minimum subnormal value (as is the case here) will be # rounded to that minimum subnormal value (6.47517511943802511092443895822764655e-4966) Rmpfr_get_FLOAT128($rop, $littlepos, MPFR_RNDA); if(!is_ZeroF128($rop)) {print "ok 15\n"} else { warn "\n\$rop: $rop\n"; print "not ok 15\n"; } # Any -ve non-zero value (no matter how close to zero) will be rounded to a non-zero value under RNDA. # Values anywhere between zero and the negated minimum subnormal value (as is the case here) will be # be rounded to that negated minimum subnormal value (-6.47517511943802511092443895822764655e-4966) Rmpfr_get_FLOAT128($rop, $littleneg, MPFR_RNDA); if(!is_ZeroF128($rop)) {print "ok 16\n"} else { warn "\n\$rop: $rop\n"; print "not ok 16\n"; } Rmpfr_get_FLOAT128($rop, Math::MPFR->new('6.475175119438025110924438958227646552e-4966'), MPFR_RNDN); if($rop == Math::Float128::FLT128_DENORM_MIN()) {print "ok 17\n"} else { warn "\n\$rop: $rop\n"; print "not ok 17\n"; } my $fr_F128 = Rmpfr_init2(115); my $f128_1 = STRtoF128('1e-298'); my $f128_2 = Math::Float128->new(); Rmpfr_set_FLOAT128($fr_F128, $f128_1, MPFR_RNDN); Rmpfr_get_FLOAT128($f128_2, $fr_F128, MPFR_RNDN); if($f128_1 == $f128_2) {print "ok 18\n"} else { warn "\n $f128_1: $f128_1\n \$f128_2: $f128_2\n"; print "not ok 18\n"; } $f128_1 = NVtoF128(1e-298); Rmpfr_set_FLOAT128($fr_F128, $f128_1, MPFR_RNDN); Rmpfr_get_FLOAT128($f128_2, $fr_F128, MPFR_RNDN); if($f128_1 == $f128_2) {print "ok 19\n"} else { warn "\n $f128_1: $f128_1\n \$f128_2: $f128_2\n"; print "not ok 19\n"; } $f128_1 = STRtoF128('1e-360'); Rmpfr_set_FLOAT128($fr_F128, $f128_1, MPFR_RNDN); Rmpfr_get_FLOAT128($f128_2, $fr_F128, MPFR_RNDN); if($f128_1 == $f128_2) {print "ok 20\n"} else { warn "\n $f128_1: $f128_1\n \$f128_2: $f128_2\n"; print "not ok 20\n"; } $f128_1 = NVtoF128(1e-360); Rmpfr_set_FLOAT128($fr_F128, $f128_1, MPFR_RNDN); Rmpfr_get_FLOAT128($f128_2, $fr_F128, MPFR_RNDN); if($f128_1 == $f128_2) {print "ok 21\n"} else { warn "\n $f128_1: $f128_1\n \$f128_2: $f128_2\n"; print "not ok 21\n"; } } else { warn "Skipping all tests - Math::MPFR not built for Float128 support"; print "ok $_\n" for 1..$t; } } Math-MPFR-4.38/t/float128_subnormal.t0000755060175106010010000002373314765756127015771 0ustar OwnerNone use warnings; use strict; use Math::MPFR qw(:mpfr); use Config; if($Config{nvtype} ne '__float128') { warn "\n skipping all tests - nvtype is not __float128\n"; print "1..1\n"; print "ok 1\n"; exit 0; } print "1..50\n"; my $str = '0.1e-16494'; my $op = Rmpfr_init2(64); my $pmin_op = Math::MPFR->new('0.1e-16493', 2); my $z_op = Math::MPFR->new(0); my $z = 0.0; my $pmin = 6.475175119438025110924438958227646552e-4966; my $ret; Rmpfr_set_str($op, $str, 2, MPFR_RNDZ); $ret = Rmpfr_get_NV($op, MPFR_RNDA); if($ret == $pmin_op && $ret == $pmin) {print "ok 1\n"} else { warn "\n\$ret: $ret\n\$pmin: $pmin\n\$pmin_op: $pmin_op\n"; print "not ok 1\n"; } $ret = Rmpfr_get_NV($op, MPFR_RNDN); if($ret == $z && $ret == $z_op) {print "ok 2\n"} else { warn "\n\$ret: $ret\n\$z: $z\n\$z_op: $z_op\n"; print "not ok 2\n"; } $ret = Rmpfr_get_NV($op, MPFR_RNDD); if($ret == $z && $ret == $z_op) {print "ok 3\n"} else { warn "\n\$ret: $ret\n\$z: $z\n\$z_op: $z_op\n"; print "not ok 3\n"; } $ret = Rmpfr_get_NV($op, MPFR_RNDU); if($ret == $pmin_op && $ret == $pmin) {print "ok 4\n"} else { warn "\n\$ret: $ret\n\$pmin: $pmin\n\$pmin_op: $pmin_op\n"; print "not ok 4\n"; } $ret = Rmpfr_get_NV($op, MPFR_RNDZ); if($ret == $z && $ret == $z_op) {print "ok 5\n"} else { warn "\n\$ret: $ret\n\$z: $z\n\$z_op: $z_op\n"; print "not ok 5\n"; } ############################### $op *= -1; $ret = Rmpfr_get_NV($op, MPFR_RNDA); if($ret == -$pmin_op && $ret == -$pmin) {print "ok 6\n"} else { warn "\n\$ret: $ret\n\$pmin: $pmin\n\$pmin_op: $pmin_op\n"; print "not ok 6\n"; } $ret = Rmpfr_get_NV($op, MPFR_RNDN); if($ret == $z && $ret == $z_op) {print "ok 7\n"} else { warn "\n\$ret: $ret\n\$z: $z\n\$z_op: $z_op\n"; print "not ok 7\n"; } $ret = Rmpfr_get_NV($op, MPFR_RNDU); if($ret == $z && $ret == $z_op) {print "ok 8\n"} else { warn "\n\$ret: $ret\n\$z: $z\n\$z_op: $z_op\n"; print "not ok 8\n"; } $ret = Rmpfr_get_NV($op, MPFR_RNDD); if($ret == -$pmin_op && $ret == -$pmin) {print "ok 9\n"} else { warn "\n\$ret: $ret\n\$pmin: $pmin\n\$pmin_op: $pmin_op\n"; print "not ok 9\n"; } $ret = Rmpfr_get_NV($op, MPFR_RNDZ); if($ret == $z && $ret == $z_op) {print "ok 10\n"} else { warn "\n\$ret: $ret\n\$z: $z\n\$z_op: $z_op\n"; print "not ok 10\n"; } ############################### ############################### $str = '0.11e-16494'; Rmpfr_set_str($op, $str, 2, MPFR_RNDZ); $ret = Rmpfr_get_NV($op, MPFR_RNDA); if($ret == $pmin_op && $ret == $pmin) {print "ok 11\n"} else { warn "\n\$ret: $ret\n\$pmin: $pmin\n\$pmin_op: $pmin_op\n"; print "not ok 11\n"; } $ret = Rmpfr_get_NV($op, MPFR_RNDN); if($ret == $pmin_op && $ret == $pmin) {print "ok 12\n"} else { warn "\n\$ret: $ret\n\$pmin: $pmin\n\$pmin_op: $pmin_op\n"; print "not ok 12\n"; } $ret = Rmpfr_get_NV($op, MPFR_RNDD); if($ret == $z && $ret == $z_op) {print "ok 13\n"} else { warn "\n\$ret: $ret\n\$z: $z\n\$z_op: $z_op\n"; print "not ok 13\n"; } $ret = Rmpfr_get_NV($op, MPFR_RNDU); if($ret == $pmin_op && $ret == $pmin) {print "ok 14\n"} else { warn "\n\$ret: $ret\n\$pmin: $pmin\n\$pmin_op: $pmin_op\n"; print "not ok 14\n"; } $ret = Rmpfr_get_NV($op, MPFR_RNDZ); if($ret == $z && $ret == $z_op) {print "ok 15\n"} else { warn "\n\$ret: $ret\n\$z: $z\n\$z_op: $z_op\n"; print "not ok 15\n"; } ############################### $op *= -1; $ret = Rmpfr_get_NV($op, MPFR_RNDA); if($ret == -$pmin_op && $ret == -$pmin) {print "ok 16\n"} else { warn "\n\$ret: $ret\n\$pmin: $pmin\n\$pmin_op: $pmin_op\n"; print "not ok 16\n"; } $ret = Rmpfr_get_NV($op, MPFR_RNDN); if($ret == -$pmin_op && $ret == -$pmin) {print "ok 17\n"} else { warn "\n\$ret: $ret\n\$pmin: $pmin\n\$pmin_op: $pmin_op\n"; print "not ok 17\n"; } $ret = Rmpfr_get_NV($op, MPFR_RNDU); if($ret == $z && $ret == $z_op) {print "ok 18\n"} else { warn "\n\$ret: $ret\n\$z: $z\n\$z_op: $z_op\n"; print "not ok 18\n"; } $ret = Rmpfr_get_NV($op, MPFR_RNDD); if($ret == -$pmin_op && $ret == -$pmin) {print "ok 19\n"} else { warn "\n\$ret: $ret\n\$pmin: $pmin\n\$pmin_op: $pmin_op\n"; print "not ok 19\n"; } $ret = Rmpfr_get_NV($op, MPFR_RNDZ); if($ret == $z && $ret == $z_op) {print "ok 20\n"} else { warn "\n\$ret: $ret\n\$z: $z\n\$z_op: $z_op\n"; print "not ok 20\n"; } ############################### ############################### $str = '0.101e-16494'; Rmpfr_set_str($op, $str, 2, MPFR_RNDZ); $ret = Rmpfr_get_NV($op, MPFR_RNDA); if($ret == $pmin_op && $ret == $pmin) {print "ok 21\n"} else { warn "\n\$ret: $ret\n\$pmin: $pmin\n\$pmin_op: $pmin_op\n"; print "not ok 21\n"; } $ret = Rmpfr_get_NV($op, MPFR_RNDN); if($ret == $pmin_op && $ret == $pmin) {print "ok 22\n"} else { warn "\n\$ret: $ret\n\$pmin: $pmin\n\$pmin_op: $pmin_op\n"; print "not ok 22\n"; } $ret = Rmpfr_get_NV($op, MPFR_RNDD); if($ret == $z && $ret == $z_op) {print "ok 23\n"} else { warn "\n\$ret: $ret\n\$z: $z\n\$z_op: $z_op\n"; print "not ok 23\n"; } $ret = Rmpfr_get_NV($op, MPFR_RNDU); if($ret == $pmin_op && $ret == $pmin) {print "ok 24\n"} else { warn "\n\$ret: $ret\n\$pmin: $pmin\n\$pmin_op: $pmin_op\n"; print "not ok 24\n"; } $ret = Rmpfr_get_NV($op, MPFR_RNDZ); if($ret == $z && $ret == $z_op) {print "ok 25\n"} else { warn "\n\$ret: $ret\n\$z: $z\n\$z_op: $z_op\n"; print "not ok 25\n"; } ############################### $op *= -1; $ret = Rmpfr_get_NV($op, MPFR_RNDA); if($ret == -$pmin_op && $ret == -$pmin) {print "ok 26\n"} else { warn "\n\$ret: $ret\n\$pmin: $pmin\n\$pmin_op: $pmin_op\n"; print "not ok 26\n"; } $ret = Rmpfr_get_NV($op, MPFR_RNDN); if($ret == -$pmin_op && $ret == -$pmin) {print "ok 27\n"} else { warn "\n\$ret: $ret\n\$pmin: $pmin\n\$pmin_op: $pmin_op\n"; print "not ok 27\n"; } $ret = Rmpfr_get_NV($op, MPFR_RNDU); if($ret == $z && $ret == $z_op) {print "ok 28\n"} else { warn "\n\$ret: $ret\n\$z: $z\n\$z_op: $z_op\n"; print "not ok 28\n"; } $ret = Rmpfr_get_NV($op, MPFR_RNDD); if($ret == -$pmin_op && $ret == -$pmin) {print "ok 29\n"} else { warn "\n\$ret: $ret\n\$pmin: $pmin\n\$pmin_op: $pmin_op\n"; print "not ok 29\n"; } $ret = Rmpfr_get_NV($op, MPFR_RNDZ); if($ret == $z && $ret == $z_op) {print "ok 30\n"} else { warn "\n\$ret: $ret\n\$z: $z\n\$z_op: $z_op\n"; print "not ok 30\n"; } ############################### ############################### $str = '0.1e-16500'; Rmpfr_set_str($op, $str, 2, MPFR_RNDZ); $ret = Rmpfr_get_NV($op, MPFR_RNDA); if($ret == $pmin_op && $ret == $pmin) {print "ok 31\n"} else { warn "\n\$ret: $ret\n\$pmin: $pmin\n\$pmin_op: $pmin_op\n"; print "not ok 31\n"; } $ret = Rmpfr_get_NV($op, MPFR_RNDN); if($ret == $z && $ret == $z_op) {print "ok 32\n"} else { warn "\n\$ret: $ret\n\$z: $z\n\$z_op: $z_op\n"; print "not ok 32\n"; } $ret = Rmpfr_get_NV($op, MPFR_RNDD); if($ret == $z && $ret == $z_op) {print "ok 33\n"} else { warn "\n\$ret: $ret\n\$z: $z\n\$z_op: $z_op\n"; print "not ok 33\n"; } $ret = Rmpfr_get_NV($op, MPFR_RNDU); if($ret == $pmin_op && $ret == $pmin) {print "ok 34\n"} else { warn "\n\$ret: $ret\n\$pmin: $pmin\n\$pmin_op: $pmin_op\n"; print "not ok 34\n"; } $ret = Rmpfr_get_NV($op, MPFR_RNDZ); if($ret == $z && $ret == $z_op) {print "ok 35\n"} else { warn "\n\$ret: $ret\n\$z: $z\n\$z_op: $z_op\n"; print "not ok 35\n"; } ############################### $str = '-0.1e-16500'; Rmpfr_set_str($op, $str, 2, MPFR_RNDZ); $ret = Rmpfr_get_NV($op, MPFR_RNDA); if($ret == -$pmin_op && $ret == -$pmin) {print "ok 36\n"} else { warn "\n\$ret: $ret\n\$pmin: $pmin\n\$pmin_op: $pmin_op\n"; print "not ok 36\n"; } $ret = Rmpfr_get_NV($op, MPFR_RNDN); if($ret == $z && $ret == $z_op) {print "ok 37\n"} else { warn "\n\$ret: $ret\n\$z: $z\n\$z_op: $z_op\n"; print "not ok 37\n"; } $ret = Rmpfr_get_NV($op, MPFR_RNDU); if($ret == $z && $ret == $z_op) {print "ok 38\n"} else { warn "\n\$ret: $ret\n\$z: $z\n\$z_op: $z_op\n"; print "not ok 38\n"; } $ret = Rmpfr_get_NV($op, MPFR_RNDD); if($ret == -$pmin_op && $ret == -$pmin) {print "ok 39\n"} else { warn "\n\$ret: $ret\n\$pmin: $pmin\n\$pmin_op: $pmin_op\n"; print "not ok 39\n"; } $ret = Rmpfr_get_NV($op, MPFR_RNDZ); if($ret == $z && $ret == $z_op) {print "ok 40\n"} else { warn "\n\$ret: $ret\n\$z: $z\n\$z_op: $z_op\n"; print "not ok 40\n"; } ############################### ############################### $str = '0.111e-16492'; Rmpfr_set_str($op, $str, 2, MPFR_RNDZ); $ret = Rmpfr_get_NV($op, MPFR_RNDA); if($ret == $pmin_op * 4.0 && $ret == $pmin * 4.0) {print "ok 41\n"} else { warn "\n\$ret: $ret\n"; print "not ok 41\n"; } $ret = Rmpfr_get_NV($op, MPFR_RNDN); if($ret == $pmin_op * 4.0 && $ret == $pmin * 4.0) {print "ok 42\n"} else { warn "\n\$ret: $ret\n"; print "not ok 42\n"; } $ret = Rmpfr_get_NV($op, MPFR_RNDD); if($ret == $pmin_op * 3.0 && $ret == $pmin * 3.0) {print "ok 43\n"} else { warn "\n\$ret: $ret\n"; print "not ok 43\n"; } $ret = Rmpfr_get_NV($op, MPFR_RNDU); if($ret == $pmin_op * 4.0 && $ret == $pmin * 4.0) {print "ok 44\n"} else { warn "\n\$ret: $ret\n"; print "not ok 44\n"; } $ret = Rmpfr_get_NV($op, MPFR_RNDZ); if($ret == $pmin_op * 3.0 && $ret == $pmin * 3.0) {print "ok 45\n"} else { warn "\n\$ret: $ret\n"; print "not ok 45\n"; } ############################### $op *= -1; $ret = Rmpfr_get_NV($op, MPFR_RNDA); if($ret == -$pmin_op * 4.0 && $ret == -$pmin * 4.0) {print "ok 46\n"} else { warn "\n\$ret: $ret\n"; print "not ok 46\n"; } $ret = Rmpfr_get_NV($op, MPFR_RNDN); if($ret == -$pmin_op * 4.0 && $ret == -$pmin * 4.0) {print "ok 47\n"} else { warn "\n\$ret: $ret\n"; print "not ok 47\n"; } $ret = Rmpfr_get_NV($op, MPFR_RNDU); if($ret == -$pmin_op * 3.0 && $ret == -$pmin * 3.0) {print "ok 48\n"} else { warn "\n\$ret: $ret\n"; print "not ok 48\n"; } $ret = Rmpfr_get_NV($op, MPFR_RNDD); if($ret == -$pmin_op * 4.0 && $ret == -$pmin * 4.0) {print "ok 49\n"} else { warn "\n\$ret: $ret\n"; print "not ok 49\n"; } $ret = Rmpfr_get_NV($op, MPFR_RNDZ); if($ret == -$pmin_op * 3.0 && $ret == -$pmin * 3.0) {print "ok 50\n"} else { warn "\n\$ret: $ret\n"; print "not ok 50\n"; } ############################### ############################### Math-MPFR-4.38/t/get_IV.t0000755060175106010010000000112314765756127013511 0ustar OwnerNoneuse strict; use warnings; use Math::MPFR qw(:mpfr); use Test::More; my $iv = ~0; my $f = Rmpfr_init2(64); Rmpfr_set_IV($f, $iv, MPFR_RNDN); cmp_ok($f, '==', ~0, "~0 assigned correctly in Rmpfr_set_IV()"); cmp_ok($f, '>', 0, "\$f > 0"); cmp_ok(Rmpfr_get_IV($f, MPFR_RNDN), '==', ~0, "Rmpfr_get_IV successfully retrieves ~0"); $iv = -1; Rmpfr_set_IV($f, $iv, MPFR_RNDN); cmp_ok($f, '==', -1, "-1 assigned correctly in Rmpfr_set_IV()"); cmp_ok($f, '<', 0, "\$f is now less than zero"); cmp_ok(Rmpfr_get_IV($f, MPFR_RNDN), '==', -1, "Rmpfr_get_IV successfully retrieves -1"); done_testing(); Math-MPFR-4.38/t/get_NV.t0000755060175106010010000000413714765756127013526 0ustar OwnerNoneuse strict; use warnings; use Math::MPFR qw(:mpfr); my $inf = 999**(999**999); my $nan = $inf / $inf; my $real = -93.0176; if($nan == $nan) { warn "\nSkippping all tests - buggy inf and/or nan implementation on this perl\n"; print "1..1\n"; print "ok 1\n"; exit 0; } print "1..10\n"; Rmpfr_set_default_prec(200); my $check = Rmpfr_get_NV(Math::MPFR->new($inf), MPFR_RNDN); if($check == $inf) {print "ok 1\n"} else { warn "\n Expected $inf, Got $check\n"; print "not ok 1\n"; } $check = Rmpfr_get_NV(Math::MPFR->new($nan), MPFR_RNDN); if($check != $check) {print "ok 2\n"} else { warn "\n Expected NaN, Got $check\n"; print "not ok 2\n"; } $check = Rmpfr_get_NV(Math::MPFR->new($real), MPFR_RNDN); if($check == $real) {print "ok 3\n"} else { warn "\n Expected $real, Got $check\n"; print "not ok 3\n"; } $check = Rmpfr_get_NV(Math::MPFR->new('-1.2e4932'), MPFR_RNDN); if($check == $check && $check != 0 && $check / $check !=1 && $check == ($inf * -1)) {print "ok 4\n"} else { warn "\n Expected -Inf, Got $check\n"; print "not ok 4\n"; } $check = Rmpfr_get_NV(Math::MPFR->new(-2.627e123), MPFR_RNDN); if($check == -2.627e123) {print "ok 5\n"} else { warn "\n Expected -2.627e123, Got $check\n"; print "not ok 5\n"; } $check = Rmpfr_get_NV(Math::MPFR->new(-2.627e-123), MPFR_RNDN); if($check == -2.627e-123) {print "ok 6\n"} else { warn "\n Expected -2.627e-123, Got $check\n"; print "not ok 6\n"; } $check = Rmpfr_get_NV(Math::MPFR->new(2.627e123), MPFR_RNDN); if($check == 2.627e123) {print "ok 7\n"} else { warn "\n Expected 2.627e123, Got $check\n"; print "not ok 7\n"; } $check = Rmpfr_get_NV(Math::MPFR->new(2.627e-123), MPFR_RNDN); if($check == 2.627e-123) {print "ok 8\n"} else { warn "\n Expected 2.627e-123, Got $check\n"; print "not ok 8\n"; } $check = Rmpfr_get_NV(Math::MPFR->new('-6.2e-4967'), MPFR_RNDN); if($check == 0.0) {print "ok 9\n"} else { warn "\n Expected zero, Got $check\n"; print "not ok 9\n"; } $check = Rmpfr_get_NV(Math::MPFR->new(), MPFR_RNDN); if($check != $check) {print "ok 10\n"} else { warn "\n Expected NaN, Got $check\n"; print "not ok 10\n"; } Math-MPFR-4.38/t/grandom.t0000755060175106010010000000362714765756127013776 0ustar OwnerNoneuse warnings; use strict; use Math::MPFR qw(:mpfr); print "1..1\n"; print "# Using Math::MPFR version ", $Math::MPFR::VERSION, "\n"; print "# Using mpfr library version ", MPFR_VERSION_STRING, "\n"; print "# Using gmp library version ", Math::MPFR::gmp_v(), "\n"; my $rop1 = Math::MPFR->new(); my $rop2 = Math::MPFR->new(); my $state1 = Rmpfr_randinit_default(); my $state2 = Rmpfr_randinit_lc_2exp('123456789123456789', 98765432123456789, 50); my $state3 = Rmpfr_randinit_lc_2exp_size(100); my $state4 = Rmpfr_randinit_mt(); Rmpfr_randseed($state1, '2345678909876543210'); Rmpfr_randseed($state2, '3456789098765432123'); Rmpfr_randseed_ui($state3, 12345678909); my $ok = ''; if(MPFR_VERSION_MAJOR == 3 && MPFR_VERSION_MINOR >= 1) { Rmpfr_grandom($rop1, $rop2, $state1, GMP_RNDN); if($rop1 && $rop2 && $rop1 != $rop2 && !Rmpfr_nan_p($rop1) && !Rmpfr_nan_p($rop2)) {$ok .= 'a'} #print "$rop1 $rop2\n"; Rmpfr_grandom($rop1, $rop2, $state2, GMP_RNDN); if($rop1 && $rop2 && $rop1 != $rop2 && !Rmpfr_nan_p($rop1) && !Rmpfr_nan_p($rop2)) {$ok .= 'b'} #print "$rop1 $rop2\n"; Rmpfr_grandom($rop1, $rop2, $state3, GMP_RNDN); if($rop1 && $rop2 && $rop1 != $rop2 && !Rmpfr_nan_p($rop1) && !Rmpfr_nan_p($rop2)) {$ok .= 'c'} #print "$rop1 $rop2\n"; Rmpfr_grandom($rop1, $rop2, $state4, GMP_RNDN); if($rop1 && $rop2 && $rop1 != $rop2 && !Rmpfr_nan_p($rop1) && !Rmpfr_nan_p($rop2)) {$ok .= 'd'} #print "$rop1 $rop2\n"; if($ok eq 'abcd') {print "ok 1\n"} else { warn "1: \$ok: $ok\n"; print "not ok 1\n"; } } else { eval{Rmpfr_grandom($rop1, $rop2, $state1, GMP_RNDN);}; if(MPFR_VERSION_MAJOR > 3) { if($@ =~ /Rmpfr_grandom is deprecated/) {print "ok 1\n"} else { warn "\$\@: $@"; print "not ok 1\n"; } } else { if($@ =~ /Rmpfr_grandom was not introduced/) {print "ok 1\n"} else { warn "\$\@: $@"; print "not ok 1\n"; } } } Math-MPFR-4.38/t/hex_fmt.t0000755060175106010010000001550214765756127013774 0ustar OwnerNone# Test mpfr's sprintf() and snprintf() functions with "%a" formatting. # I assume that Rmpfr_printf() and Rmpfr_fprintf() will handle this formatting # in exactly the same way. Tests involving Rmpfr_printf() and Rmpfr_fprintf() # will be added if evidence contrary to my assumption arises. # I think that trailing mantissa zeros are frowned upon, but these tests will # accept them. # On windows, gmp_sprintf() presents the trailing zeroes. # # Also we test nv2mpfr() as that sub is used by Rmpfr_*printf in these tests # if WIN32_FMT_BUG is set. In such instances, 'Rmpfr_printf("%a", $nv)' will # be replaced by "Rmpfr_printf("%Ra", nv2mpfr($nv)' - and similarly for the # other Rmpfr_*printf() functions. use strict; use warnings; use Config; use Math::MPFR qw(:mpfr); use Test::More; my $nv = 1.0078125; # 0x1.02p+0 my $obj = Math::MPFR->new($nv); my $buflen = 16; my ($buf, $ret); # 0x1.02p+0 == 0x2.04p-1 == 0x4.08p-2 == 0x8.1p-3; # Allow for any one of them to appear at any time. # In the sprintf tests: # "%a%: ^0x1\.02(0+)?p\+0$|^0x2\.04(0+)?p\-1$|^0x4\.08(0+)?p\-2$|^0x8\.1(0+)?p\-3$ # "%A": ^0X1\.02(0+)?P\+0$|^0X2\.04(0+)?P\-1$|^0X4\.08(0+)?P\-2$|^0X8\.1(0+)?P\-3$ #In the snprintf tests: # "%a": ^0x1\.0$|^0x2\.0$|^0x4\.0$|^0x8\.1$ # "%A": ^0X1\.0$|^0X2\.0$|^0X4\.0$|^0X8\.1$ ### nv2mpfr tests my $s = '1.3'; my $nv2mpfr = 1.3; my $op = Math::MPFR->new(1.3); cmp_ok(nv2mpfr($nv2mpfr), '==', $nv2mpfr, "equivalence holds for all NV precisions"); if($Config{nvsize} == 8) { cmp_ok(nv2mpfr($s), '==', $s, "string equivalence holds for 'double' precision"); cmp_ok(nv2mpfr($op), '==', $op, "mpfr object equivalence holds for 'double' precision"); } else { cmp_ok(nv2mpfr($s), '!=', $s, "no string equivalence for non 'double' precision"); cmp_ok(nv2mpfr($op), '==', $op, "no mpfr object equivalence for non 'double' precision"); } ### sprintf tests on NV if($Config{nvtype} eq 'double') { # "%a"/"%A" formatting of an NV is not expected to work # unless $Config{nvtype} is 'double'. $ret = Rmpfr_sprintf($buf, "%a", $nv, 16); like($buf, qr/^0x1.02(0+)?p\+0$|^0x2\.04p\-1$|^0x4\.08p\-2$|^0x8\.1p\-3$/, "\"%a\" (mpfr) formatting of NV as expected"); cmp_ok($ret, '==', length($buf), "\"%a\" (mpfr) formatting of NV returned correct value"); $ret = Rmpfr_sprintf($buf, "%A", $nv, 16); like($buf, qr/^0X1.02(0+)?P\+0$|^0X2\.04P\-1$|^0X4\.08P\-2$|^0X8\.1P\-3$/, "\"%A\" (mpfr) formatting of NV as expected"); cmp_ok($ret, '==', length($buf), "\"%A\" (mpfr) formatting of NV returned correct value"); } if($Config{nvtype} eq 'long double') { # "%La"/"%LA" formatting of an NV is not expected to work # unless $Config{nvtype} is 'long double'. $ret = Rmpfr_sprintf($buf, "%La", $nv, 16); like($buf, qr/^0x1\.02(0+)?p\+0$|^0x2\.04(0+)?p\-1$|^0x4\.08(0+)?p\-2$|^0x8\.1(0+)?p\-3$/, "\"%La\" formatting of NV as expected"); cmp_ok($ret, '==', length($buf), "\"%La\" formatting of NV returned correct value"); $ret = Rmpfr_sprintf($buf, "%LA", $nv, 16); like($buf, qr/^0X1\.02(0+)?P\+0$|^0X2\.04(0+)?P\-1$|^0X4\.08(0+)?P\-2$|^0X8\.1(0+)?P\-3$/, "\"%LA\" formatting of NV as expected"); cmp_ok($ret, '==', length($buf), "\"%LA\" formatting of NV returned correct value"); } ### sprintf tests on MPFR object $ret = Rmpfr_sprintf($buf, "%Ra", $obj, 16); cmp_ok($buf, 'eq', '0x1.02p+0', "\"%a\" formatting of MPFR object as expected"); cmp_ok($ret, '==', length($buf), "\"%a\" formatting of MPFR object returned correct value"); $ret = Rmpfr_sprintf($buf, "%RA", $obj, 16); cmp_ok($buf, 'eq', '0X1.02P+0', "\"%A\" formatting of MPFR object as expected"); cmp_ok($ret, '==', length($buf), "\"%A\" formatting of MPFR object returned correct value"); ################################################################ ################################################################ ### snprintf tests on NV if($Config{nvtype} eq 'double') { # "%a"/"%A" formatting of an NV is not expected to work # unless $Config{nvtype} is 'double'. $ret = Rmpfr_snprintf($buf, 6, "%a", $nv, 16); like($buf, qr/^0x1\.0$|^0x2\.0$|^0x4\.0$|^0x8\.1$/, "\"%a\" (snprintf) formatting of NV as expected"); my $expectation = 9; $expectation = 8 if $buf =~ /^0x8/i; cmp_ok($ret, '==', $expectation, "\"%a\" (snprintf) formatting of NV returned correct value"); $ret = Rmpfr_snprintf($buf, 6, "%A", $nv, 16); like($buf, qr/^0X1\.0$|^0X2\.0$|^0X4\.0$|^0X8\.1$/, "\"%A\" (snprintf) formatting of NV as expected"); $expectation = 9; $expectation = 8 if $buf =~ /^0x8/i; cmp_ok($ret, '==', $expectation, "\"%A\" (snprintf) formatting of NV returned correct value"); } if($Config{nvtype} eq 'long double') { # "%La"/"%LA" formatting of an NV is not expected to work # unless $Config{nvtype} is 'long double'. my $returned = 9; $ret = Rmpfr_snprintf($buf, 6, "%La", $nv, 16); like($buf, qr/^0x1\.0$|^0x2\.0$|^0x4\.0$|^0x8\.1$/, "\"%La\" (mpfr snprintf) formatting of NV as expected"); $returned = 8 if $buf =~ /0x8/i; cmp_ok($ret, '==', $returned, "\"%La\" (mpfr snprintf) formatting of NV returned correct value"); $ret = Rmpfr_snprintf($buf, 6, "%LA", $nv, 16); like($buf, qr/^0X1\.0$|^0X2\.0$|^0X4\.0$|^0X8\.1$/, "\"%LA\" (mpfr snprintf) formatting of NV as expected"); cmp_ok($ret, '==', $returned, "\"%LA\" (snprintf) formatting of NV returned correct value"); } ### snprintf tests on MPFR object $ret = Rmpfr_snprintf($buf, 6, "%Ra", $obj, 16); cmp_ok($buf, 'eq', '0x1.0', "\"%a\" (snprintf) formatting of MPFR object as expected"); cmp_ok($ret, '==', 9, "\"%a\" (snprintf) formatting of MPFR object returned correct value"); $ret = Rmpfr_snprintf($buf, 6, "%RA", $obj, 16); cmp_ok($buf, 'eq', '0X1.0', "\"%A\" (snprintf) formatting of MPFR object as expected"); cmp_ok($ret, '==', 9, "\"%A\" (snprintf) formatting of MPFR object returned correct value"); ################################################################ ################################################################ # "%a" formatting error tests unless($Config{nvtype} eq 'double') { eval { Rmpfr_sprintf($buf, " %%A %a %% ", $nv, 16) }; like($@, qr/"%a" formatting applies only to doubles/, '"%a" formatting allowed only for doubles'); eval { Rmpfr_sprintf($buf, " %%a %A %% ", $nv, 16) }; like($@, qr/"%A" formatting applies only to doubles/, '"%A" formatting allowed only for doubles'); } unless($Config{nvtype} eq 'long double') { eval { Rmpfr_sprintf($buf, " %%LA %La %% ", $nv, 16) }; like($@, qr/"%La" formatting applies only to long doubles/, '"%La" formatting allowed only for long doubles'); eval { Rmpfr_sprintf($buf, " %%La %LA %% ", $nv, 16) }; like($@, qr/"%LA" formatting applies only to long doubles/, '"%LA" formatting allowed only for long doubles'); } eval { Rmpfr_sprintf($buf, " %%a %A %% ", Math::MPFR->new($nv), 16) }; like($@, qr/"%A" formatting applies only to NVs/, '"%A" formatting disallowed for Math::MPFR objects'); done_testing(); Math-MPFR-4.38/t/infnan_str.t0000755060175106010010000000441314765756127014502 0ustar OwnerNoneuse strict; use warnings; use Math::MPFR qw(:mpfr); # $Math::MPFR::PERL_INFNAN is initially set to 0. #use Test2::V0; use Test::More; *_refcnt = \&Math::MPFR::get_refcnt; my($pinfcount, $ninfcount, $nanvcount) = (_refcnt($Math::MPFR::pinfstr), _refcnt($Math::MPFR::ninfstr), _refcnt($Math::MPFR::nanvstr)); cmp_ok($pinfcount, '==', 1, '$Math::MPFR::pinfstr refcount is 1'); cmp_ok($ninfcount, '==', 1, '$Math::MPFR::ninfstr refcount is 1'); cmp_ok($nanvcount, '==', 1, '$Math::MPFR::nanvstr refcount is 1'); my $nv = 1e5000; cmp_ok(nvtoa ($nv), 'eq', 'Inf', 'nvtoa : +inf stringifies as per default'); cmp_ok(numtoa($nv), 'eq', 'Inf', 'numtoa: +inf stringifies as per default'); $nv *= -1; cmp_ok(nvtoa ($nv), 'eq', '-Inf', 'nvtoa : inf stringifies as per default'); cmp_ok(numtoa($nv), 'eq', '-Inf', 'numtoa: -inf stringifies as per default'); $nv /= $nv; cmp_ok(nvtoa ($nv), 'eq', 'NaN', 'nvtoa : nan stringifies as per default'); cmp_ok(numtoa($nv), 'eq', 'NaN', 'numtoa: nan stringifies as per default'); $Math::MPFR::PERL_INFNAN = 1; $nv = 1e5000; cmp_ok(nvtoa($nv), 'eq', $Math::MPFR::pinfstr, '+inf stringifies as per perl'); cmp_ok(_refcnt($Math::MPFR::pinfstr), '==', $pinfcount, '1: $pinfcount ok'); $nv *= -1; cmp_ok(nvtoa($nv), 'eq', $Math::MPFR::ninfstr, '-inf stringifies as per perl'); cmp_ok(_refcnt($Math::MPFR::ninfstr), '==', $ninfcount, '1: $ninfcount ok'); $nv /= $nv; cmp_ok(nvtoa($nv), 'eq', $Math::MPFR::nanvstr, 'nan stringifies as per perl'); cmp_ok(_refcnt($Math::MPFR::nanvstr), '==', $nanvcount, '1: $nanvcount ok'); my($x, $y, $z) = (\$Math::MPFR::pinfstr, \$Math::MPFR::ninfstr, \$Math::MPFR::nanvstr); cmp_ok(_refcnt($Math::MPFR::pinfstr), '==', 2, '$Math::MPFR::pinfstr refcount is 2'); cmp_ok(_refcnt($Math::MPFR::ninfstr), '==', 2, '$Math::MPFR::ninfstr refcount is 2'); cmp_ok(_refcnt($Math::MPFR::nanvstr), '==', 2, '$Math::MPFR::nanvstr refcount is 2'); my $s = nvtoa($nv); cmp_ok($s, 'eq', $Math::MPFR::nanvstr, "\$s is '$Math::MPFR::nanvstr'"); cmp_ok(_refcnt($Math::MPFR::nanvstr), '==', 2, '$Math::MPFR::nanvstr refcount is still 2'); $z = 'hello world'; cmp_ok(_refcnt($Math::MPFR::nanvstr), '==', 1, '$Math::MPFR::nanvstr refcount is back to 1'); done_testing(); __END__ Math-MPFR-4.38/t/inits.t0000755060175106010010000000152014765756127013463 0ustar OwnerNoneuse warnings; use strict; use Math::MPFR ':mpfr'; print "1..5\n"; print "# Using Math::MPFR version ", $Math::MPFR::VERSION, "\n"; print "# Using mpfr library version ", MPFR_VERSION_STRING, "\n"; print "# Using gmp library version ", Math::MPFR::gmp_v(), "\n"; my @mpfr1 = Rmpfr_inits(17); if(scalar(@mpfr1) == 17) {print "ok 1\n"} else {print "not ok 1 ", scalar(@mpfr1), "\n"} my $ok = 1; for(@mpfr1) {$ok = 0 if !Rmpfr_nan_p($_) } if($ok) {print "ok 2\n"} else {print "not ok 2 $ok\n"} my @mpfr2 = Rmpfr_inits2(101, 17); if(scalar(@mpfr1) == 17) {print "ok 3\n"} else {print "not ok 3 ", scalar(@mpfr1), "\n"} $ok = 1; for(@mpfr2) {$ok = 0 if !Rmpfr_nan_p($_) } if($ok) {print "ok 4\n"} else {print "not ok 4 $ok\n"} $ok = 1; for(@mpfr2) {$ok = 0 if Rmpfr_get_prec($_) != 101 } if($ok) {print "ok 5\n"} else {print "not ok 5 $ok\n"} Math-MPFR-4.38/t/integer_string.t0000755060175106010010000000260314765756127015363 0ustar OwnerNoneuse warnings; use strict; use Math::MPFR qw(:mpfr); print "1..1\n"; print "# Using Math::MPFR version ", $Math::MPFR::VERSION, "\n"; print "# Using mpfr library version ", MPFR_VERSION_STRING, "\n"; print "# Using gmp library version ", Math::MPFR::gmp_v(), "\n"; my $ok = ''; my $nan = Math::MPFR->new(); $ok .= 'a' if lc(Rmpfr_integer_string($nan, 10, GMP_RNDN)) eq 'nan'; my ($man, $exp) = Rmpfr_deref2($nan, 10, 0, GMP_RNDN); $ok .= 'b' if lc($man) eq '@nan@'; my $one = Math::MPFR->new(1); my $minus_one = Math::MPFR->new(-1); my $zero = Math::MPFR->new(0); my $minus_zero = Math::MPFR->new(-0.0); my $inf = $one / $zero; $ok .= 'c' if lc(Rmpfr_integer_string($inf, 10, GMP_RNDN)) eq 'inf'; $inf = $minus_one / $minus_zero; $ok .= 'd' if lc(Rmpfr_integer_string($inf, 10, GMP_RNDN)) eq 'inf'; $inf = $one / $minus_zero; $ok .= 'e' if lc(Rmpfr_integer_string($inf, 10, GMP_RNDN)) eq '-inf'; $inf = $minus_one / $zero; $ok .= 'f' if lc(Rmpfr_integer_string($inf, 10, GMP_RNDN)) eq '-inf'; $ok .= 'g' if Rmpfr_integer_string($zero, 10, GMP_RNDN) eq '0'; $ok .= 'h' if Rmpfr_integer_string($minus_zero, 10, GMP_RNDN) eq '-0'; my $minus_zero2 = Math::MPFR->new(-0); $ok .= 'i' if Rmpfr_integer_string($minus_zero2, 10, GMP_RNDN) eq '0'; $ok .= 'j' if lc(Rmpfr_integer_string($zero / $minus_zero, 10, GMP_RNDN)) eq 'nan'; if($ok eq 'abcdefghij') {print "ok 1\n"} else {print "not ok 1 $ok\n"} Math-MPFR-4.38/t/lngamma_bug.t0000755060175106010010000000211514765756127014607 0ustar OwnerNone# This file so named because it tests the fixing of a bug that had lngamma(-0) evaluate to # NaN (instead of the correct value of +Inf). # The bug was present in mpfr up to (and including) version 3.1.2. use warnings; use strict; use Math::MPFR qw(:mpfr); print "1..4\n"; print "# Using Math::MPFR version ", $Math::MPFR::VERSION, "\n"; print "# Using mpfr library version ", MPFR_VERSION_STRING, "\n"; print "# Using gmp library version ", Math::MPFR::gmp_v(), "\n"; my $z = Math::MPFR->new(0); my $neg = Math::MPFR->new(-3); my $lng = Math::MPFR->new(); $z *= -1; if(Rmpfr_signbit($z)) {print "ok 1\n"} else { warn "\$z: $z\n"; print "not ok 1\n"; } Rmpfr_lngamma($lng, $z, MPFR_RNDN); if(Rmpfr_inf_p($lng) && $lng > 0) {print "ok 2\n"} else { warn "\$lng: $lng\n"; print "not ok 2\n"; } Rmpfr_lngamma($lng, $neg, MPFR_RNDN); if(Rmpfr_inf_p($lng) && $lng > 0) {print "ok 3\n"} else { warn "\$lng: $lng\n"; print "not ok 3\n"; } Rmpfr_lgamma($lng, $neg, MPFR_RNDN); if(Rmpfr_inf_p($lng) && $lng > 0) {print "ok 4\n"} else { warn "\$lng: $lng\n"; print "not ok 4\n"; } Math-MPFR-4.38/t/LongDouble.t0000755060175106010010000000642014765756127014373 0ustar OwnerNone# Rewrite to just test that Rmpfr_get_LD is retrieving the Math::LongDouble value correctly. # Skip the test suite entirely if $Config{longdblkind} is not defined, or if nvsize is 8. use warnings; use strict; use Config; use Math::MPFR qw(:mpfr); use Test::More; eval {require Math::LongDouble;}; if($@) { warn "Skipping all tests - Math::LongDouble not found\n"; cmp_ok(1, '==', 1, 'dummy test'); done_testing(); exit 0; } elsif($Math::LongDouble::VERSION < 0.20) { warn "Skipping all tests as Math::LongDouble is too old - update to at least version 0.20\n"; cmp_ok(1, '==', 1, 'dummy test'); done_testing(); exit 0; } elsif(!defined $Config{longdblkind} ) { warn "Skipping all tests - \$Config{longdblkind} is not defined\n"; cmp_ok(1, '==', 1, 'dummy test'); done_testing(); exit 0; } elsif($Config{longdblkind} < 0 ) { warn "Skipping all tests - unknown type of long double\n"; cmp_ok(1, '==', 1, 'dummy test'); done_testing(); exit 0; } elsif($Config{longdblkind} == 0 ) { warn "Skipping all tests - long double is actually double\n"; cmp_ok(1, '==', 1, 'dummy test'); done_testing(); exit 0; } my $ldblk = $Config{longdblkind}; warn "\nLDBLKIND: $ldblk\n"; my $prec = 64; $prec = 113 if($ldblk == 1 || $ldblk == 2); $prec = 2098 if $ldblk > 4; Rmpfr_set_default_prec($prec); my $op1 = Math::MPFR->new(1) / 10; my $op2 = Math::MPFR->new('1.4') / 10; my $rop1 = Math::MPFR->new(); my $rop2 = Math::MPFR->new(); my $ld1 = Math::LongDouble->new(); my $ld2 = Math::LongDouble->new(); Rmpfr_get_LD($ld1, $op1, MPFR_RNDN); Rmpfr_get_LD($ld2, $op2, MPFR_RNDN); my $inex1 = Rmpfr_set_LD($rop1, $ld1, MPFR_RNDN); my $inex2 = Rmpfr_set_LD($rop2, $ld2, MPFR_RNDN); cmp_ok($inex1, '==', 0, "inex1 is 0"); cmp_ok($inex2, '==', 0, "inex2 is 0"); if($prec == 64) { my($ld1_str, $ld2_str) = ("$ld1", "$ld2"); $ld1_str =~ s/\-(0+)?1$/-1/; # standardize format $ld2_str =~ s/\-(0+)?1$/-1/; # standardize_format cmp_ok($ld1_str, 'eq', '1.00000000000000000001e-1', "0.1 renders correctly"); cmp_ok($ld2_str, 'eq', '1.40000000000000000001e-1', "1.4/10 renders correctly"); cmp_ok($op1, '==', $rop1, "0.1 does the round trip"); cmp_ok($op2, '==', $rop2, "1.4/10 does the round trip"); } if($prec == 113) { my($ld1_str, $ld2_str) = ("$ld1", "$ld2"); $ld1_str =~ s/\-(0+)?1$/-1/; # standardize format $ld2_str =~ s/\-(0+)?1$/-1/; # standardize_format cmp_ok($ld1_str, 'eq', '1.00000000000000000000000000000000005e-1', "0.1 renders correctly"); cmp_ok($ld2_str, 'eq', '1.39999999999999991118215802998747672e-1', "1.4/10 renders correctly"); cmp_ok($op1, '==', $rop1, "0.1 does the round trip"); cmp_ok($op2, '==', $rop2, "1.4/10 does the round trip"); } if($prec == 2098) { my($ld1_str, $ld2_str) = ("$ld1", "$ld2"); $ld1_str =~ s/\-(0+)?2$/-2/; # standardize format $ld2_str =~ s/\-(0+)?1$/-1/; # standardize_format cmp_ok($ld1_str, '==', '9.99999999999999999999999999999996918512088980422635110435291864116290339037362855378887616097927093505859375e-2', "0.1 renders correctly"); cmp_ok($ld2_str, '==', '1.400000000000000000000000000000004930380657631323783823303533017413935457540219431393779814243316650390625e-1', "1.4/10 renders correctly"); cmp_ok($op1, '==', $rop1, "0.1 does the round trip"); cmp_ok($op2, '==', $rop2, "1.4/10 does the round trip"); } done_testing(); __END__ Math-MPFR-4.38/t/mpfrtoa.t0000755060175106010010000000740614765756127014016 0ustar OwnerNoneuse strict; use warnings; use Math::MPFR qw(:mpfr); use Test::More; if( MPFR_VERSION_MAJOR() < 4) { warn " Skipping - these tests require mpfr-4.0.0\n or later, but we have only mpfr-", MPFR_VERSION_STRING(), "\n"; ok('1' eq '1', "dummy test"); done_testing(); exit 0; } my @in = ('15400000000000000.0', '1.54e+16', '1107610000000000000.0', '1.10761e+18', '13687000000000000.0', '1.3687e+16', '16800000000000000000.0','1.68e+19', '11443200000000000000000000000.0', '1.14432e+28', '0.0', '-0.0', 'NaN', '-NaN', 'Inf', '-Inf', '0.1', '0.3', nvtoa(atonv('1.4') / 10)); Rmpfr_set_default_prec($Math::MPFR::NV_properties{bits}); if( $Math::MPFR::NV_properties{bits} == 2098 ) { warn "Skipping tests that are not written for DoubleDouble nvtype. (TODO.)\n" } else { push @in, ('128702000000000000000000000000000.0', '1.28702e+32'); } for(@in) { my $rop = Math::MPFR->new($_); my $nv = Rmpfr_get_NV($rop, MPFR_RNDN); my $s1 = mpfrtoa($rop); my $s2 = nvtoa(atonv($_)); cmp_ok($s1, 'eq', $s2, "mpfrtoa() and nvtoa() agree for $_"); ok(dragon_test( $rop) == 15, "$_ passes dragontest (MPFR)"); # $s1 ok(dragon_test( $nv ) == 15, "$_ passes dragon test (NV)"); # $s2 } ############################################################################## # Check that mpfrtoa(Math::MPFR::object) eq nvtoa(NV) eq Math::Ryu::nv2s(NV) # # whenever: # # a) the value of the Math::MPFR object and the NV are identical # # && # # b) the precision of the Math::MPFR object matches the precision of the NV. # # Math::MPFR precision has already been set such that b) is satisfied. # # The Math::Ryu::nv2s() check is dependent upon Math::Ryu being available. # ############################################################################## my $have_ryu = 0; eval{require Math::Ryu;}; $have_ryu = 1 if(!$@ && $Math::Ryu::VERSION >= 1.05); for(1 .. 100) { if($Math::MPFR::NV_properties{bits} == 2098) { warn "Skipping additional tests also inapplicable to DoubleDouble nvtype. (TODO.)\n"; last; } my($e, $n, $digits, $s); $e = int(rand(256)); $digits = int(Rmpfr_get_default_prec() * 0.3); $n .= int(rand(10)) for 1..$digits; $e *= -1 if $_ % 3; $s = "1.${n}e${e}"; if($_ & 1) { $s = '-' . $s; } my $f = Math::MPFR->new($s); my $nv = Rmpfr_get_NV($f, MPFR_RNDN); my $s1 = mpfrtoa($f); my $s2 = nvtoa($nv); cmp_ok($s1, 'eq', $s2, "mpfrtoa() and nvtoa() agree for $s"); ok(dragon_test( $f ) == 15, "$s passes dragon test (MPFR)"); # $s1 ok(dragon_test( $nv) == 15, "$s passes dragon test (NV)"); # $s2 if($have_ryu) { my $s3 = Math::Ryu::nv2s($nv); cmp_ok($s1, 'eq', $s3, "mpfrtoa() and Math::Ryu agree for $s"); } } ########################################################################### # Next we test that, for various values at various precisions (that don't # # match any NV precisions), the result provided by mpfrtoa() is correct. # ########################################################################### for my $prec( 20000, 2000, 200, 96, 21, 5 ) { Rmpfr_set_default_prec( $prec ); for( 1 .. 100, '0.1', '0.10000000000000001', '0.3', nvtoa(1.4 / 10) ) { my($e, $n, $digits, $s); unless( $_ =~ /\./ ) { $e = int(rand(2048)); $digits = int( Rmpfr_get_default_prec() / 5 ); $n .= int(rand( 10 )) for 1..$digits; $e *= -1 if $_ % 3; $s = "1${n}e${e}"; } else {$s = "$_"} my $sign = 0; if( $_ & 1 ) { $s = '-' . $s; $sign = 1; } my $f = Math::MPFR->new( $s ); my $dec = mpfrtoa( $f ); ok(dragon_test($f) == 15, "$s passes dragon test (NV)"); } } done_testing; Math-MPFR-4.38/t/mpfrtoa_precisions.t0000755060175106010010000000551414765756127016252 0ustar OwnerNone# Examine the effect that different precisions have on mpfrtoa() output. use strict; use warnings; use Math::MPFR qw(:mpfr); use Test::More; # Default precision is 53 bits. my $min_allowed_prec = RMPFR_PREC_MIN; # Older mpfr libraries set the minimum to 2 bits. my $f1; if($min_allowed_prec == 1) { $f1 = Rmpfr_init2(1); Rmpfr_set_IV($f1, 2, MPFR_RNDN); } my $f10 = Rmpfr_init2(10); Rmpfr_set_IV($f10, 2, MPFR_RNDN); my $f40 = Rmpfr_init2(40); Rmpfr_set_IV($f40, 2, MPFR_RNDN); my $f53 = Rmpfr_init2(53); Rmpfr_set_IV($f53, 2, MPFR_RNDN); my $f64 = Rmpfr_init2(64); Rmpfr_set_IV($f64, 2, MPFR_RNDN); my $f113 = Rmpfr_init2(113); Rmpfr_set_IV($f113, 2, MPFR_RNDN); my $power = -1074; if($min_allowed_prec == 1) { $f1 **= $power; # $f1 is a 1-bit precision representation of 2 ** $power } $f10 **= $power; # $f1 is a 1-bit precision representation of 2 ** $power $f40 **= $power; # $f1 is a 1-bit precision representation of 2 ** $power $f53 **= $power; # $f53 is a 53-bit precision representation of 2 ** $power $f64 **= $power; # $f1 is a 1-bit precision representation of 2 ** $power $f113 **= $power; # $f1 is a 1-bit precision representation of 2 ** $power #print mpfrtoa($_) . "\n" for ($f1, $f10, $f40, $f53, $f64, $f113); # All 6 values are equivalent as they both have a # binary mantissa of "1" and an exponent of $power: if($min_allowed_prec == 1) { cmp_ok($f113, '==', $f1, '$f113 == $f1'); cmp_ok($f64 , '==', $f1, '$f64 == $f1'); cmp_ok($f53 , '==', $f1, '$f53 == $f1'); cmp_ok($f40 , '==', $f1, '$f40 == $f1'); cmp_ok($f10 , '==', $f1, '$f10 == $f1'); } else { cmp_ok($f113, '==', $f10, '$f113 == $f10'); cmp_ok($f64 , '==', $f10, '$f64 == $f10'); cmp_ok($f53 , '==', $f10, '$f53 == $f10'); cmp_ok($f40 , '==', $f10, '$f40 == $f10'); } # However, mpfrtoa() reports different strings for all 6 values: if($min_allowed_prec == 1) { cmp_ok(mpfrtoa($f1), 'eq', '5e-324', '$f1 eq 5e-324'); } cmp_ok(mpfrtoa($f10), 'eq', '4.94e-324', '$f10 eq 4.94e-324'); cmp_ok(mpfrtoa($f40), 'eq', '4.940656458412e-324', '$f40 eq 4.940656458412e-324'); cmp_ok(mpfrtoa($f53), 'eq', '4.9406564584124654e-324', '$f53 eq 4.9406564584124654e-324'); cmp_ok(mpfrtoa($f64), 'eq', '4.940656458412465442e-324', '$f64 eq 4.940656458412465442e-324'); cmp_ok(mpfrtoa($f113), 'eq', '4.940656458412465441765687928682214e-324', '$f113 eq 4.940656458412465441765687928682214e-324'); if(196870 <= MPFR_VERSION) { my @input = ($f10, $f40, $f53, $f64, $f113); unshift(@input, $f1) if $min_allowed_prec == 1; for my $in( @input) { cmp_ok(dragon_test($in), '==', 15, "$in passes dragon_test"); } } else { warn "Skipping dragon_test() checks - mpfr-3.1.6 (or later) required\n"; } done_testing(); Math-MPFR-4.38/t/MPFR_RND.t0000755060175106010010000001233114765756127013606 0ustar OwnerNoneuse warnings; use strict; use Math::MPFR qw(:mpfr); print "1..20\n"; print "# Using Math::MPFR version ", $Math::MPFR::VERSION, "\n"; print "# Using mpfr library version ", MPFR_VERSION_STRING, "\n"; print "# Using gmp library version ", Math::MPFR::gmp_v(), "\n"; if(GMP_RNDN == MPFR_RNDN) {print "ok 1\n"} else { warn "GMP_RNDN: ", GMP_RNDN, " MPFR_RNDN: ", MPFR_RNDN, "\n"; print "not ok 1\n"; } if(GMP_RNDZ == MPFR_RNDZ) {print "ok 2\n"} else { warn "GMP_RNDZ: ", GMP_RNDZ, " MPFR_RNDZ: ", MPFR_RNDZ, "\n"; print "not ok 2\n"; } if(GMP_RNDU == MPFR_RNDU) {print "ok 3\n"} else { warn "GMP_RNDU: ", GMP_RNDU, " MPFR_RNDU: ", MPFR_RNDU, "\n"; print "not ok 3\n"; } if(GMP_RNDD == MPFR_RNDD) {print "ok 4\n"} else { warn "GMP_RNDD: ", GMP_RNDD, " MPFR_RNDD: ", MPFR_RNDD, "\n"; print "not ok 4\n"; } if(MPFR_RNDA == 4) {print "ok 5\n"} else { warn "MPFR_RNDA: ", MPFR_RNDA, "\n"; print "not ok 5\n"; } if(MPFR_VERSION_MAJOR >= 3) { my ($mpfr, $dis) = Rmpfr_init_set_ui(12345, MPFR_RNDA); if($mpfr == 12345) {print "ok 6\n"} else { warn "\$mpfr: $mpfr\n"; print "not ok 6\n"; } } else { eval {my ($mpfr, $dis) = Rmpfr_init_set_ui(12345, MPFR_RNDA);}; if($@ =~ /Illegal rounding value supplied/) {print "ok 6\n"} else { warn "\$\@: $@\n"; print "not ok 6\n"; } } if(Rmpfr_print_rnd_mode(MPFR_RNDD) eq 'MPFR_RNDD' || Rmpfr_print_rnd_mode(MPFR_RNDD) eq 'GMP_RNDD') {print "ok 7\n"} else { warn "\nExpected 'MPFR_RNDD' or 'GMP_RNDD'\nGot '", Rmpfr_print_rnd_mode(MPFR_RNDD), "'\n"; print "not ok 7\n"; } if(Rmpfr_print_rnd_mode(MPFR_RNDU) eq 'MPFR_RNDU' || Rmpfr_print_rnd_mode(MPFR_RNDU) eq 'GMP_RNDU') {print "ok 8\n"} else { warn "\nExpected 'MPFR_RNDU' or 'GMP_RNDU'\nGot '", Rmpfr_print_rnd_mode(MPFR_RNDU), "'\n"; print "not ok 8\n"; } if(Rmpfr_print_rnd_mode(MPFR_RNDN) eq 'MPFR_RNDN' || Rmpfr_print_rnd_mode(MPFR_RNDN) eq 'GMP_RNDN') {print "ok 9\n"} else { warn "\nExpected 'MPFR_RNDN' or 'GMP_RNDN'\nGot '", Rmpfr_print_rnd_mode(MPFR_RNDN), "'\n"; print "not ok 9\n"; } if(Rmpfr_print_rnd_mode(MPFR_RNDZ) eq 'MPFR_RNDZ' || Rmpfr_print_rnd_mode(MPFR_RNDZ) eq 'GMP_RNDZ') {print "ok 10\n"} else { warn "\nExpected 'MPFR_RNDZ' or 'GMP_RNDZ'\nGot '", Rmpfr_print_rnd_mode(MPFR_RNDZ), "'\n"; print "not ok 10\n"; } if(!defined(Rmpfr_print_rnd_mode(100))) {print "ok 11\n"} else { warn "\nExpected 'undef'\nGot '", Rmpfr_print_rnd_mode(100), "'\n"; print "not ok 11\n"; } if(Rmpfr_print_rnd_mode(GMP_RNDD) eq 'MPFR_RNDD' || Rmpfr_print_rnd_mode(GMP_RNDD) eq 'GMP_RNDD') {print "ok 12\n"} else { warn "\nExpected 'MPFR_RNDD' or 'GMP_RNDD'\nGot '", Rmpfr_print_rnd_mode(GMP_RNDD), "'\n"; print "not ok 12\n"; } if(Rmpfr_print_rnd_mode(GMP_RNDU) eq 'MPFR_RNDU' || Rmpfr_print_rnd_mode(GMP_RNDU) eq 'GMP_RNDU') {print "ok 13\n"} else { warn "\nExpected 'MPFR_RNDU' or 'GMP_RNDU'\nGot '", Rmpfr_print_rnd_mode(GMP_RNDU), "'\n"; print "not ok 13\n"; } if(Rmpfr_print_rnd_mode(GMP_RNDN) eq 'MPFR_RNDN' || Rmpfr_print_rnd_mode(GMP_RNDN) eq 'GMP_RNDN') {print "ok 14\n"} else { warn "\nExpected 'MPFR_RNDN' or 'GMP_RNDN'\nGot '", Rmpfr_print_rnd_mode(GMP_RNDN), "'\n"; print "not ok 14\n"; } if(Rmpfr_print_rnd_mode(GMP_RNDZ) eq 'MPFR_RNDZ' || Rmpfr_print_rnd_mode(GMP_RNDZ) eq 'GMP_RNDZ') {print "ok 15\n"} else { warn "\nExpected 'MPFR_RNDZ' or 'GMP_RNDZ'\nGot '", Rmpfr_print_rnd_mode(GMP_RNDZ), "'\n"; print "not ok 15\n"; } if(3 <= MPFR_VERSION_MAJOR) { if(Rmpfr_print_rnd_mode(MPFR_RNDA) eq 'MPFR_RNDA') {print "ok 16\n"} else { warn "\nExpected 'MPFR_RNDA'\nGot '", Rmpfr_print_rnd_mode(MPFR_RNDA), "'\n"; print "not ok 16\n"; } } else { if(!defined(Rmpfr_print_rnd_mode(MPFR_RNDA))) {print "ok 16\n"} else { warn "\nExpected 'undef'\nGot '", Rmpfr_print_rnd_mode(MPFR_RNDA), "'\n"; print "not ok 16\n"; } } if(MPFR_RNDF == 5) {print "ok 17\n"} else { warn "\n Expected 5, got ", MPFR_RNDF, "\n"; print "not ok 17\n"; } if(MPFR_VERSION_MAJOR >= 4) { my $op1 = Math::MPFR->new('17.7'); my $op2 = Math::MPFR->new('9.9'); my $ropu = Math::MPFR->new(); my $ropf = Math::MPFR->new(); my $ropd = Math::MPFR->new(); my $inex1 = Rmpfr_mul($ropu, $op1, $op2, MPFR_RNDU); my $inex2 = Rmpfr_mul($ropd, $op1, $op2, MPFR_RNDD); if($inex1 && $inex2) {print "ok 18\n"} else { warn "\n \$inex1: $inex1, \$inex2: $inex2\n"; print "not ok 18\n"; } Rmpfr_mul($ropf, $op1, $op2, MPFR_RNDF); if($ropf == $ropu || $ropf == $ropd) {print "ok 19\n"} else { warn "\n \$ropu: $ropu\n \$ropf: $ropf\n \$ropd: $ropd\n"; print "not ok 19\n"; } Rmpfr_set_default_rounding_mode(MPFR_RNDF); my $check = $op1 * $op2; if($check == $ropu || $check == $ropd) {print "ok 20\n"} else { warn "\n \$ropu: $ropu\n \$check: $check\n \$ropd: $ropd\n"; print "not ok 20\n"; } # Restore original default rounding mode Rmpfr_set_default_rounding_mode(MPFR_RNDN); } else { my $ropf = Math::MPFR->new(); eval {Rmpfr_mul($ropf, Math::MPFR->new('17.7'), Math::MPFR->new('9.9'), MPFR_RNDF)}; if($@ =~ /^Illegal rounding value supplied for this version/) {print "ok 18\n"} else { warn "\n\$\@: $@"; print "not ok 18\n"; } warn "\n Skipping tests 19 and 20 - requires mpfr-4.0.0 or later\n"; for(19..20) {print "ok $_\n"} } Math-MPFR-4.38/t/nan_cmp.t0000755060175106010010000001453214765756127013757 0ustar OwnerNoneuse strict; use warnings; use Math::MPFR qw(:mpfr); #use Devel::Peek; print "1..8\n"; print "# Using Math::MPFR version ", $Math::MPFR::VERSION, "\n"; print "# Using mpfr library version ", MPFR_VERSION_STRING, "\n"; print "# Using gmp library version ", Math::MPFR::gmp_v(), "\n"; my $nan = Math::MPFR->new(); my $pnan = Rmpfr_get_d($nan, GMP_RNDN); my $zero = Math::MPFR->new(0); my $one = Math::MPFR->new(1); my $negtwo = -$one; $negtwo --; my $postwo = $one + 1; my $posinf = $one / $zero; my $neginf = -$posinf; my $temp = Math::MPFR->new(); Rmpfr_clear_erangeflag(); my $ok = ''; if($nan == $zero || $nan == 0 || $zero / $zero == 0) {$ok .= 'A'} if(Rmpfr_erangeflag_p()) {$ok .= '&'} Rmpfr_clear_erangeflag(); if($nan < $zero || $nan < 0 || $zero / $zero < 0) {$ok .= 'B'} if(Rmpfr_erangeflag_p()) {$ok .= '*'} Rmpfr_clear_erangeflag(); if($nan <= $zero || $nan <= 0 || $zero / $zero <= 0) {$ok .= 'C'} if(Rmpfr_erangeflag_p()) {$ok .= '('} Rmpfr_clear_erangeflag(); if($nan > $zero || $nan > 0 || $zero / $zero > 0) {$ok .= 'D'} if(Rmpfr_erangeflag_p()) {$ok .= ')'} Rmpfr_clear_erangeflag(); if($nan >= $zero || $nan >= 0 || $zero / $zero >= 0) {$ok .= 'E'} if(Rmpfr_erangeflag_p()) {$ok .= '_'} Rmpfr_clear_erangeflag(); $ok .= $nan <=> $zero ? 'G' : 'a'; if(Rmpfr_erangeflag_p()) {$ok .= 'b'} Rmpfr_clear_erangeflag(); if(Rmpfr_erangeflag_p()) {$ok .= 'H'} $ok .= $nan <=> 0 ? 'I' : 'c'; if(Rmpfr_erangeflag_p()) {$ok .= 'd'} Rmpfr_clear_erangeflag(); if(Rmpfr_erangeflag_p()) {$ok .= 'J'} ########################### $ok .= $nan <=> $one ? 'K' : 'e'; if(Rmpfr_erangeflag_p()) {$ok .= 'f'} Rmpfr_clear_erangeflag(); if(Rmpfr_erangeflag_p()) {$ok .= 'L'} $ok .= $nan <=> 1 ? 'M' : 'g'; if(Rmpfr_erangeflag_p()) {$ok .= 'h'} Rmpfr_clear_erangeflag(); if(Rmpfr_erangeflag_p()) {$ok .= 'N'} if($nan == $one || $nan == 1) {$ok .= 'O'} if($nan < $one || $nan < 1) {$ok .= 'P'} if($nan <= $one || $nan <= 1) {$ok .= 'Q'} if($nan < $one || $nan < 1) {$ok .= 'R'} if($nan <= $one || $nan <= 1) {$ok .= 'S'} if($nan == $nan) {$ok .= 'T'} if($nan < $nan) {$ok .= 'U'} if($nan <= $nan) {$ok .= 'V'} if($nan < $nan) {$ok .= 'W'} if($nan <= $nan) {$ok .= 'X'} $ok .= $zero / $zero <=> 1 ? 'Y' : 'i'; $ok .= Rmpfr_nan_p($zero / $zero) ? 'j' : 'Z'; Rmpfr_clear_erangeflag(); $ok .= defined($nan <=> 0) ? '`' : 'k'; $ok .= Rmpfr_erangeflag_p() ? 'l' : '~'; Rmpfr_clear_erangeflag(); if($ok eq '&*()_abcdefghijkl') {print "ok 1\n"} else { warn "1: $ok\n"; print "not ok 1\n"; } $ok = ''; if($nan != $zero) {$ok .= 'a'} if($nan != 0) {$ok .= 'b'} if($nan != $one) {$ok .= 'c'} if($nan != 1) {$ok .= 'd'} if(!$nan) {$ok .= 'e'} if($nan) {$ok .= 'A'} if(Rmpfr_erangeflag_p()) {$ok .= 'f'} if($ok eq 'abcdef') {print "ok 2\n"} else { warn "2: $ok\n"; print "not ok 2\n"; } my $nan2 = Math::MPFR->new('nan'); if(Rmpfr_nan_p($nan2)) {print "ok 3\n"} else {print "not ok 3 $nan2\n"} if((1 ** $nan) == 1) {print "ok 4\n"} else {print "not ok 4 ", 1 ** $nan, "\n"} if(Rmpfr_nan_p(2 ** $nan)) {print "ok 5\n"} else {print "not ok 5", 2 ** $nan, "\n"} $ok = ''; if(Rmpfr_nan_p($posinf / $posinf)) {$ok .= 'a'} else {warn "a: ", $posinf / $posinf, "\n"} if(Rmpfr_nan_p($posinf / $neginf)) {$ok .= 'b'} else {warn "b: ", $posinf / $neginf, "\n"} if(Rmpfr_nan_p($neginf / $posinf)) {$ok .= 'c'} else {warn "c: ", $neginf / $posinf, "\n"} if(Rmpfr_nan_p($neginf / $neginf)) {$ok .= 'd'} else {warn "d: ", $neginf / $neginf, "\n"} if(Rmpfr_nan_p($zero * $posinf)) {$ok .= 'e'} else {warn "e: ", $zero * $posinf, "\n"} if(Rmpfr_nan_p($zero * $neginf)) {$ok .= 'f'} else {warn "f: ", $zero * $neginf, "\n"} if(Rmpfr_nan_p($neginf + $posinf)) {$ok .= 'g'} else {warn "g: ", $neginf + $posinf, "\n"} if(Rmpfr_nan_p($neginf - $neginf)) {$ok .= 'h'} else {warn "h: ", $neginf - $neginf, "\n"} if(Rmpfr_nan_p($posinf - $posinf)) {$ok .= 'i'} else {warn "i: ", $posinf - $posinf, "\n"} if(Rmpfr_nan_p(sqrt($negtwo))) {$ok .= 'j'} else {warn "j: ", sqrt($negtwo), "\n"} if(Rmpfr_nan_p(log($negtwo))) {$ok .= 'k'} else {warn "k: ", log($negtwo), "\n"} Rmpfr_log2($temp, $negtwo, GMP_RNDN); if(Rmpfr_nan_p($temp)) {$ok .= 'l'} else {warn "l: ", $temp, "\n"} Rmpfr_log10($temp, $negtwo, GMP_RNDN); if(Rmpfr_nan_p($temp)) {$ok .= 'm'} else {warn "m: ", $temp, "\n"} Rmpfr_acos($temp, $negtwo, GMP_RNDN); if(Rmpfr_nan_p($temp)) {$ok .= 'n'} else {warn "n: ", $temp, "\n"} Rmpfr_asin($temp, $negtwo, GMP_RNDN); if(Rmpfr_nan_p($temp)) {$ok .= 'o'} else {warn "o: ", $temp, "\n"} Rmpfr_acos($temp, $postwo, GMP_RNDN); if(Rmpfr_nan_p($temp)) {$ok .= 'p'} else {warn "p: ", $temp, "\n"} Rmpfr_asin($temp, $postwo, GMP_RNDN); if(Rmpfr_nan_p($temp)) {$ok .= 'q'} else {warn "q: ", $temp, "\n"} if($nan ** 0 == 1) {$ok .= 'r'} else {warn "r: ", $nan ** 0, "\n"} if($ok eq 'abcdefghijklmnopqr') {print "ok 6\n"} else {print "not ok 6 $ok\n"} $ok = ''; Rmpfr_clear_erangeflag(); $ok .= $zero < $pnan ? 'A' : 'a'; $ok .= Rmpfr_erangeflag_p() ? 'b' : 'B'; Rmpfr_clear_erangeflag(); $ok .= $zero <= $pnan ? 'C' : 'c'; $ok .= Rmpfr_erangeflag_p() ? 'd' : 'D'; Rmpfr_clear_erangeflag(); $ok .= $zero > $pnan ? 'E' : 'e'; $ok .= Rmpfr_erangeflag_p() ? 'f' : 'F'; Rmpfr_clear_erangeflag(); $ok .= $zero >= $pnan ? 'G' : 'g'; $ok .= Rmpfr_erangeflag_p() ? 'h' : 'H'; Rmpfr_clear_erangeflag(); $ok .= $zero == $pnan ? 'I' : 'i'; $ok .= Rmpfr_erangeflag_p() ? 'j' : 'J'; Rmpfr_clear_erangeflag(); $ok .= $zero != $pnan ? 'k' : 'K'; $ok .= Rmpfr_erangeflag_p() ? 'l' : 'L'; Rmpfr_clear_erangeflag(); $ok .= defined($zero <=> $pnan) ? 'M' : 'm'; $ok .= Rmpfr_erangeflag_p() ? 'n' : 'N'; Rmpfr_clear_erangeflag(); if($ok eq 'abcdefghijklmn') {print "ok 7\n"} else { warn "7: $ok\n"; print "not ok 7\n"; } $ok = ''; my $pinf = 999 ** (999 ** 999); $ok .= Rmpfr_cmp_NV($nan, $pinf) == 0 ? 'a' : 'A'; $ok .= Rmpfr_erangeflag_p() ? 'b' : 'B'; Rmpfr_clear_erangeflag(); $ok .= Rmpfr_cmp_NV($nan, $pinf * -1) == 0 ? 'c' : 'C'; $ok .= Rmpfr_erangeflag_p() ? 'd' : 'D'; Rmpfr_clear_erangeflag(); $ok .= Rmpfr_cmp_NV($nan, 0.0) == 0 ? 'e' : 'E'; $ok .= Rmpfr_erangeflag_p() ? 'f' : 'F'; Rmpfr_clear_erangeflag(); $ok .= Rmpfr_cmp_NV($nan, 1.0) == 0 ? 'g' : 'G'; $ok .= Rmpfr_erangeflag_p() ? 'h' : 'H'; Rmpfr_clear_erangeflag(); $ok .= Rmpfr_cmp_NV($nan, -1.0) == 0 ? 'i' : 'I'; $ok .= Rmpfr_erangeflag_p() ? 'j' : 'J'; Rmpfr_clear_erangeflag(); if($ok eq 'abcdefghij') {print "ok 8\n"} else { warn "8: $ok\n"; print "not ok 8\n"; } Math-MPFR-4.38/t/native_float128.t0000755060175106010010000000427214765756127015252 0ustar OwnerNoneuse strict; use warnings; use Config; use Math::MPFR qw(:mpfr); # __float128 sqrt(3.0) = 1.73205080756887729352744634150587232 (36 decimal digits). my $t = 2; print "1..$t\n"; if(Math::MPFR::_can_pass_float128()) { warn "\n Can pass __float128 using Rmpfr_get_float128 and Rmpfr_set_float128\n"; Rmpfr_set_default_prec(113); my $frac = 3.0; # For me, both C and perl miscalculates sqrt(2.0), so we'll # sweep that one under the carpet and check using sqrt(3.0), # which seems to be calculated correctly. my $fr = Math::MPFR->new($frac); $fr **= 0.5; if($fr == sqrt($frac)) {print "ok 1\n"} else { my $check = sprintf "%a", Rmpfr_get_float128($fr, MPFR_RNDN); warn "\n Expected $check\n Got ", sprintf "%a\n", sqrt($frac); print "not ok 1\n"; } Rmpfr_set_float128($fr, 1.73205080756887729352744634150587232, MPFR_RNDN); if($fr == Math::MPFR->new('1.73205080756887729352744634150587232')) {print "ok 2\n"} else { my $check = sprintf "%a", Rmpfr_get_float128($fr, MPFR_RNDN); warn "\n Expected 1.73205080756887729352744634150587232\nGot $fr\n"; print "not ok 2\n"; } } elsif($Config{nvtype} eq '__float128') { warn "\n Can pass __float128 using Rmpfr_get_NV and Rmpfr_set_NV\n"; Rmpfr_set_default_prec(113); my $frac = 3.0; # For me, both C and perl miscalculates sqrt(2.0), so we'll # sweep that one under the carpet and check using sqrt(3.0), # which seems to be calculated correctly. my $fr = Math::MPFR->new($frac); $fr **= 0.5; if($fr == sqrt($frac)) {print "ok 1\n"} else { my $check = sprintf "%a", Rmpfr_get_NV($fr, MPFR_RNDN); warn "\n Expected $check\n Got ", sprintf "%a\n", sqrt($frac); print "not ok 1\n"; } Rmpfr_set_NV($fr, 1.73205080756887729352744634150587232, MPFR_RNDN); if($fr == Math::MPFR->new('1.73205080756887729352744634150587232')) {print "ok 2\n"} else { my $check = sprintf "%a", Rmpfr_get_float128($fr, MPFR_RNDN); warn "\n Expected 1.73205080756887729352744634150587232\nGot $fr\n"; print "not ok 2\n"; } } else { warn "\n Skipping all tests - nvtype is $Config{nvtype}\n"; for(1 .. $t) {print "ok $_\n"} } Math-MPFR-4.38/t/neg_zero_bug.t0000755060175106010010000001500214765756127015002 0ustar OwnerNone# This file so named because it tests the fixing of a bug with -0 and mpfr_fits_u*_p(). # The bug was present in mpfr up to (and including) version 3.1.2. use warnings; use strict; use Math::MPFR qw(:mpfr); print "1..7\n"; print "# Using Math::MPFR version ", $Math::MPFR::VERSION, "\n"; print "# Using mpfr library version ", MPFR_VERSION_STRING, "\n"; print "# Using gmp library version ", Math::MPFR::gmp_v(), "\n"; Rmpfr_set_default_prec(150); my($ok, $count) = (0, 24); my @vals = ( Math::MPFR->new(-0.99999), Math::MPFR->new(-0.50001), Math::MPFR->new(-0.5), Math::MPFR->new(-0.4999999), Math::MPFR->new(-0.000001), Math::MPFR->new(0.0), ); $vals[5] *= -1.0; my @rnds = (0 .. 3); unless(3 > MPFR_VERSION_MAJOR) { $count += 6; push @rnds, 4; } for my $r(@rnds) { for my $v(@vals) { if($r == MPFR_RNDN) { if($v >= -0.5) { if(Rmpfr_fits_ushort_p($v, $r)) {$ok++} else { warn "$r : $v : ", Rmpfr_fits_ushort_p($v, $r), "\n"} } else { if(!Rmpfr_fits_ushort_p($v, $r)) {$ok++} else { warn "$r : $v : ", Rmpfr_fits_ushort_p($v, $r), "\n"} } } elsif($r == MPFR_RNDZ || $r == MPFR_RNDU) { if(Rmpfr_fits_ushort_p($v, $r)) {$ok++} else { warn "$r : $v : ", Rmpfr_fits_ushort_p($v, $r), "\n"} } else { if($v == 0) { if(Rmpfr_fits_ushort_p($v, $r)) {$ok++} else { warn "$r : $v : ", Rmpfr_fits_ushort_p($v, $r), "\n"} } else { if(!Rmpfr_fits_ushort_p($v, $r)) {$ok++} else { warn "$r : $v : ", Rmpfr_fits_ushort_p($v, $r), "\n"} } } } } if($ok == $count) {print "ok 1\n"} else { warn "\n\$ok: $ok\n\$count: $count\n"; print "not ok 1\n"; } $ok = 0; for my $r(@rnds) { for my $v(@vals) { if($r == MPFR_RNDN) { if($v >= -0.5) { if(Rmpfr_fits_uint_p($v, $r)) {$ok++} else { warn "$r : $v : ", Rmpfr_fits_uint_p($v, $r), "\n"} } else { if(!Rmpfr_fits_uint_p($v, $r)) {$ok++} else { warn "$r : $v : ", Rmpfr_fits_uint_p($v, $r), "\n"} } } elsif($r == MPFR_RNDZ || $r == MPFR_RNDU) { if(Rmpfr_fits_uint_p($v, $r)) {$ok++} else { warn "$r : $v : ", Rmpfr_fits_uint_p($v, $r), "\n"} } else { if($v == 0) { if(Rmpfr_fits_uint_p($v, $r)) {$ok++} else { warn "$r : $v : ", Rmpfr_fits_uint_p($v, $r), "\n"} } else { if(!Rmpfr_fits_uint_p($v, $r)) {$ok++} else { warn "$r : $v : ", Rmpfr_fits_uint_p($v, $r), "\n"} } } } } if($ok == $count) {print "ok 2\n"} else { warn "\n\$ok: $ok\n\$count: $count\n"; print "not ok 2\n"; } $ok = 0; for my $r(@rnds) { for my $v(@vals) { if($r == MPFR_RNDN) { if($v >= -0.5) { if(Rmpfr_fits_ulong_p($v, $r)) {$ok++} else { warn "$r : $v : ", Rmpfr_fits_ulong_p($v, $r), "\n"} } else { if(!Rmpfr_fits_ulong_p($v, $r)) {$ok++} else { warn "$r : $v : ", Rmpfr_fits_ulong_p($v, $r), "\n"} } } elsif($r == MPFR_RNDZ || $r == MPFR_RNDU) { if(Rmpfr_fits_ulong_p($v, $r)) {$ok++} else { warn "$r : $v : ", Rmpfr_fits_ulong_p($v, $r), "\n"} } else { if($v == 0) { if(Rmpfr_fits_ulong_p($v, $r)) {$ok++} else { warn "$r : $v : ", Rmpfr_fits_ulong_p($v, $r), "\n"} } else { if(!Rmpfr_fits_ulong_p($v, $r)) {$ok++} else { warn "$r : $v : ", Rmpfr_fits_ulong_p($v, $r), "\n"} } } } } if($ok == $count) {print "ok 3\n"} else { warn "\n\$ok: $ok\n\$count: $count\n"; print "not ok 3\n"; } $ok = 0; for my $r(@rnds) { for my $v(@vals) { if($r == MPFR_RNDN) { if($v >= -0.5) { if(Rmpfr_fits_uintmax_p($v, $r)) {$ok++} else { warn "$r : $v : ", Rmpfr_fits_uintmax_p($v, $r), "\n"} } else { if(!Rmpfr_fits_uintmax_p($v, $r)) {$ok++} else { warn "$r : $v : ", Rmpfr_fits_uintmax_p($v, $r), "\n"} } } elsif($r == MPFR_RNDZ || $r == MPFR_RNDU) { if(Rmpfr_fits_uintmax_p($v, $r)) {$ok++} else { warn "$r : $v : ", Rmpfr_fits_uintmax_p($v, $r), "\n"} } else { if($v == 0) { if(Rmpfr_fits_uintmax_p($v, $r)) {$ok++} else { warn "$r : $v : ", Rmpfr_fits_uintmax_p($v, $r), "\n"} } else { if(!Rmpfr_fits_uintmax_p($v, $r)) {$ok++} else { warn "$r : $v : ", Rmpfr_fits_uintmax_p($v, $r), "\n"} } } } } if($ok == $count) {print "ok 4\n"} else { warn "\n\$ok: $ok\n\$count: $count\n"; print "not ok 4\n"; } $ok = 0; for my $r(@rnds) { for my $v(@vals) { if(Rmpfr_fits_sshort_p($v, $r)) {$ok++} else { warn "sshort: $r : $v : ", Rmpfr_fits_sshort_p($v, $r), "\n"} if(Rmpfr_fits_sint_p($v, $r)) {$ok++} else { warn "sint: $r : $v : ", Rmpfr_fits_sint_p($v, $r), "\n"} if(Rmpfr_fits_slong_p($v, $r)) {$ok++} else { warn "slong: $r : $v : ", Rmpfr_fits_slong_p($v, $r), "\n"} if(Rmpfr_fits_intmax_p($v, $r)) {$ok++} else { warn "intmax: $r : $v : ", Rmpfr_fits_intmax_p($v, $r), "\n"} if(Rmpfr_fits_IV_p($v, $r)) {$ok++} else { warn "IV: $r : $v : ", Rmpfr_fits_IV_p($v, $r), "\n"} } } if($ok == $count * 5) {print "ok 5\n"} else { warn "\n\$ok: $ok\n\$count: $count\n"; print "not ok 5\n"; } my $fr1 = Math::MPFR->new(-1.0); my $fr2 = Math::MPFR->new(0.6); $ok = 1; for my $r(@rnds) { if(Rmpfr_fits_ushort_p($fr1, $r)) { warn "ushort: $fr1: $r: ", Rmpfr_fits_ushort_p($fr1, $r), "\n"; $ok = 0; } if(Rmpfr_fits_uint_p($fr1, $r)) { warn "uint: $fr1: $r: ", Rmpfr_fits_uint_p($fr1, $r), "\n"; $ok = 0; } if(Rmpfr_fits_ulong_p($fr1, $r)) { warn "ulong: $fr1: $r: ", Rmpfr_fits_ulong_p($fr1, $r), "\n"; $ok = 0; } if(Rmpfr_fits_uintmax_p($fr1, $r)) { warn "uintmax: $fr1: $r: ", Rmpfr_fits_uintmax_p($fr1, $r), "\n"; $ok = 0; } } if($ok){print "ok 6\n"} else {print "not ok 6\n"} $ok = 1; for my $r(@rnds) { if(!Rmpfr_fits_ushort_p($fr2, $r)) { warn "ushort: $fr2: $r: ", Rmpfr_fits_ushort_p($fr2, $r), "\n"; $ok = 0; } if(!Rmpfr_fits_uint_p($fr2, $r)) { warn "uint: $fr2: $r: ", Rmpfr_fits_uint_p($fr2, $r), "\n"; $ok = 0; } if(!Rmpfr_fits_ulong_p($fr2, $r)) { warn "ulong: $fr2: $r: ", Rmpfr_fits_ulong_p($fr2, $r), "\n"; $ok = 0; } if(!Rmpfr_fits_uintmax_p($fr2, $r)) { warn "uintmax: $fr2: $r: ", Rmpfr_fits_uintmax_p($fr2, $r), "\n"; $ok = 0; } if(!Rmpfr_fits_IV_p($fr2, $r)) { warn "IV: $fr2: $r: ", Rmpfr_fits_UV_p($fr2, $r), "\n"; $ok = 0; } } if($ok){print "ok 7\n"} else {print "not ok 7\n"} Math-MPFR-4.38/t/new.t0000755060175106010010000001345114765756127013134 0ustar OwnerNoneuse warnings; use strict; use Math::MPFR qw(:mpfr); use Math::BigInt; use Config; print "1..9\n"; print "# Using Math::MPFR version ", $Math::MPFR::VERSION, "\n"; print "# Using mpfr library version ", MPFR_VERSION_STRING, "\n"; print "# Using gmp library version ", Math::MPFR::gmp_v(), "\n"; my $ui = 123569; my $si = -19907; my $d = -1.625; my $str = '-119.125'; my $ok = ''; my $f00 = new Math::MPFR(); if(Rmpfr_nan_p($f00)) {$ok = 'a'} Rmpfr_set_ui($f00, $ui, Rmpfr_get_default_rounding_mode()); if($f00 == $ui) {$ok .= 'b'} my $f01 = new Math::MPFR($ui); if($f01 == $ui) {$ok .= 'c'} my $f02 = new Math::MPFR($si); if($f02 == $si) {$ok .= 'd'} my $f03 = new Math::MPFR($d); if($f03 == $d) {$ok .= 'e'} my $f04 = new Math::MPFR($str); if($f04 == $str) {$ok .= 'f'} my $f05 = new Math::MPFR($str, 10); if($f05 == $str) {$ok .= 'g'} my $f06 = new Math::MPFR($d); if($f06 == $d) {$ok .= 'h'} if($ok eq 'abcdefgh') {print "ok 1\n"} else { warn "\$ok: $ok\n"; print "not ok 1\n"; } ############################# $ok = ''; my $f10 = Math::MPFR::new(); if(Rmpfr_nan_p($f10)) {$ok = 'a'} Rmpfr_set_ui($f10, $ui, Rmpfr_get_default_rounding_mode()); if($f10 == $ui) {$ok .= 'b'} my $f11 = Math::MPFR::new($ui); if($f11 == $ui) {$ok .= 'c'} my $f12 = Math::MPFR::new($si); if($f12 == $si) {$ok .= 'd'} my $f13 = Math::MPFR::new($d); if($f13 == $d) {$ok .= 'e'} my $f14 = Math::MPFR::new($str); if($f14 == $str) {$ok .= 'f'} my $f15 = Math::MPFR::new($str, 10); if($f15 == $str) {$ok .= 'g'} my $f16 = Math::MPFR::new($d); if($f16 == $d) {$ok .= 'h'} if($ok eq 'abcdefgh') {print "ok 2\n"} else { warn "\$ok: $ok\n"; print "not ok 2\n"; } ################################ $ok = ''; my $f20 = Math::MPFR->new(); if(Rmpfr_nan_p($f20)) {$ok = 'a'} else {warn "3a: $f20\n"} Rmpfr_set_ui($f20, $ui, Rmpfr_get_default_rounding_mode()); if($f20 == $ui) {$ok .= 'b'} else {warn "3b: $f20\n"} my $f21 = Math::MPFR->new($ui); if($f21 == $ui) {$ok .= 'c'} else {warn "3c: $f21\n"} my $f22 = Math::MPFR->new($si); if($f22 == $si) {$ok .= 'd'} else {warn "3d: $f22\n"} my $f23 = Math::MPFR->new($d); if($f23 == $d) {$ok .= 'e'} else {warn "3e: $f23\n"} my $f24 = Math::MPFR->new($str); if($f24 == $str) {$ok .= 'f'} else {warn "3f: $f24\n"} my $f25 = Math::MPFR->new($str, 10); if($f25 == $str) {$ok .= 'g'} else {warn "3g: $f25\n"} my $f26 = Math::MPFR->new($d); if($f26 == $d) {$ok .= 'h'} else {warn "3h: $f26\n"} Rmpfr_set_default_prec(100); my $f27 = Math::MPFR->new(36028797018964023); my $f28 = Math::MPFR->new('36028797018964023'); if(Math::MPFR::_has_longlong() || $Config{ivsize} >= 8) { if($f27 == $f28) {$ok .= 'i'} else {warn "== : $f27 $f28\n"} } else { if(Math::MPFR::_has_longdouble()) { if($f27 == $f28) {$ok .= 'i'} else {warn "== : $f27 $f28\n"} } else { if($f27 != $f28) {$ok .= 'i'} else {warn "!= : $f27 $f28\n"} } } if($ok eq 'abcdefghi') {print "ok 3\n"} else { warn "\$ok: $ok\n"; print "not ok 3\n"; } ############################# my $bi = Math::BigInt->new(123456789); $ok = ''; eval{my $f30 = Math::MPFR->new(17, 12);}; if($@ =~ /Too many arguments supplied to new\(\) \- expected only one/) {$ok = 'a'} eval{my $f31 = Math::MPFR::new(17, 12);}; if($@ =~ /Too many arguments supplied to new\(\) \- expected only one/) {$ok .= 'b'} eval{my $f32 = Math::MPFR->new($str, 12, 7);}; if($@ =~ /Too many arguments supplied to new\(\)/) {$ok .= 'c'} eval{my $f33 = Math::MPFR::new($str, 12, 7);}; if($@ =~ /Too many arguments supplied to new\(\) \- expected no more than two/) {$ok .= 'd'} eval{my $f34 = Math::MPFR->new($bi);}; if($@ =~ /Inappropriate argument/) {$ok .= 'e'} eval{my $f35 = Math::MPFR::new($bi);}; if($@ =~ /Inappropriate argument/) {$ok .= 'f'} eval{my $f36 = Math::MPFR->new("17", 42);}; if($@) { warn "\$\@: $@\n" } else {$ok .= 'g'} eval{my $f37 = Math::MPFR->new("17", 1);}; if($@ =~ /2nd argument supplied to Rmpfr_init_set str/) {$ok .= 'h' } eval{my $f38 = Math::MPFR->new("17", 0);}; if($@) { warn "\$\@: $@\n" } else {$ok .= 'i' } eval{my $f39 = Math::MPFR->new("17", -4);}; if($@ =~ /2nd argument supplied to Rmpfr_init_set str/) {$ok .= 'j' } if($ok eq 'abcdefghij') {print "ok 4\n"} else { warn "\$ok: $ok\n"; print "not ok 4\n"; } ############################### $ok = ''; my($gmpf, $gmpq, $gmpz, $gmp) = (0, 0, 0, 0); eval{require Math::GMPf;}; if(!$@) {$gmpf = 1} eval{require Math::GMPq;}; if(!$@) {$gmpq = 1} eval{require Math::GMPz;}; if(!$@) {$gmpz = 1} eval{require Math::GMP;}; if(!$@) {$gmp = 1} if($gmpf) { my $x = Math::GMPf::new(125.5); my $y = Math::MPFR::new($x); my $z = Math::MPFR->new($x); if($y == $z && $z == 125.5) {print "ok 5\n"} else { warn "\$y: $y\n\$z: $z\n"; print "not ok 5\n"; } } else { warn "Skipping test 5 - no Math::GMPf\n"; print "ok 5\n"; } if($gmpq) { my $x = Math::GMPq::new('251/2'); my $y = Math::MPFR::new($x); my $z = Math::MPFR->new($x); if($y == $z && $z == 125.5) {print "ok 6\n"} else { warn "\$y: $y\n\$z: $z\n"; print "not ok 6\n"; } } else { warn "Skipping test 6 - no Math::GMPq\n"; print "ok 6\n"; } if($gmpz) { my $x = Math::GMPz::new(125.5); my $y = Math::MPFR::new($x); my $z = Math::MPFR->new($x); if($y == $z && $z == 125) {print "ok 7\n"} else { warn "\$y: $y\n\$z: $z\n"; print "not ok 7\n"; } } else { warn "Skipping test 7 - no Math::GMPz\n"; print "ok 7\n"; } if($gmp) { my $x = Math::GMP->new(125); my $y = Math::MPFR::new($x); my $z = Math::MPFR->new($x); if($y == $z && $z == 125) {print "ok 8\n"} else { warn "\$y: $y\n\$z: $z\n"; print "not ok 8\n"; } } else { warn "Skipping test 8 - no Math::GMP\n"; print "ok 8\n"; } my $x = Math::MPFR::new(12345.5); my $y = Math::MPFR::new($x); my $z = Math::MPFR->new($x); if($y == $z && $z == 12345.5) {print "ok 9\n"} else { warn "\$y: $y\n\$z: $z\n"; print "not ok 9\n"; } Math-MPFR-4.38/t/new_in_4.0.0.t0000755060175106010010000003133014765756127014335 0ustar OwnerNone ################################################################# # NOTE: Not everything that's new in mpfr-4.0.0 is tested here. # # eg: MPFR_RNDF rounding and the new freeing of caches/pools # # are tested elsewhere in the test suite. # ################################################################# use warnings; use strict; use Math::MPFR qw(:mpfr); print "1..36\n"; my $have_new = 1; my @ret; my $ret; if(!defined(MPFR_VERSION) || 262144 > MPFR_VERSION) {$have_new = 0} # mpfr version is pre 3.2.0 my $x = Math::MPFR->new(200); my $y = Math::MPFR->new(17); my $rop = Math::MPFR->new(); my $rop1 = Math::MPFR->new(); my $rop2 = Math::MPFR->new(); eval {@ret = Rmpfr_fmodquo($rop, $x, $y, MPFR_RNDA);}; if($have_new) { if($rop == 13 && $ret[0] == 11 && $ret[1] == 0) {print "ok 1\n"} else { warn "\nExpected 13, 11, and 0\nGot $rop, $ret[0] and $ret[1]\n"; print "not ok 1\n"; } } else { if($@ =~ /^Rmpfr_fmodquo not implemented \- need at least mpfr\-4\.0\.0/) {print "ok 1\n"} else { warn "\n\$\@:\n$@\n"; print "not ok 1\n"; } } my $float = Rmpfr_init2(2500); Rmpfr_set_NV($float, 0.1, MPFR_RNDN); $float /= 117; my($wr, $rd); # filehandles my $write = open $wr, '>', 'fpif.txt'; warn "Couldn't open export file for writing: $!" unless $write; ############################################### unless($ENV{SISYPHUS_SKIP}) { # Because of the way I (sisyphus) build this module with MS # Visual Studio, XSubs that take a filehandle as an argument # may not work. It therefore suits my purposes to be able to # avoid calling (and testing) those particular XSubs if($write) { binmode($wr); eval {$ret = Rmpfr_fpif_export($wr, $float);}; if($@) { if($@ =~ /^Rmpfr_fpif_export not implemented \- need at least mpfr\-4\.0\.0/) {print "ok 2\n"} else { warn "\n\$\@:\n$@\n"; print "not ok 2\n"; } } else { if($ret == 0) {print "ok 2\n"} else { warn "\nRmpfr_fpif_export failed\n"; print "not ok 2\n"; } } close $wr or warn "Could not close export file: $!"; } else { warn "\n Skipping test 2: export file not created\n"; print "ok 2\n"; } my $retrieve = Rmpfr_init2(2500); my $read = open $rd, '<', 'fpif.txt'; warn "Couldn't open export file for reading: $!" unless $read; if($read) { binmode($rd); eval {$ret = Rmpfr_fpif_import($retrieve, $rd);}; if($@) { if($@ =~ /^Rmpfr_fpif_import not implemented \- need at least mpfr\-4\.0\.0/) {print "ok 3\n"} else { warn "\n\$\@:\n$@\n"; print "not ok 3\n"; } } else { if($ret == 0 && $retrieve == $float) {print "ok 3\n"} else { warn "\n3: Got $ret and $retrieve\n"; print "not ok 3\n"; } } close $rd or warn "Could not close export file: $!"; } else { warn "\n Skipping test 3: import file not readable\n"; print "ok 3\n"; } } else { warn "skipping tests 2 and 3 - \$ENV{SISYPHUS_SKIP} is set\n"; print "ok 2\n"; print "ok 3\n"; } ####################################################### if($have_new) { Rmpfr_clear_underflow(); Rmpfr_clear_overflow(); Rmpfr_clear_divby0(); Rmpfr_clear_nanflag(); Rmpfr_clear_inexflag(); Rmpfr_clear_erangeflag(); ###################### Rmpfr_set_underflow(); if(Rmpfr_underflow_p()) {print "ok 4\n"} else { warn "\nBug in at least one of Rmpfr_set_underflow() and Rmpfr_underflow_p()\n"; print "not ok 4\n"; } Rmpfr_flags_clear(MPFR_FLAGS_UNDERFLOW); if(Rmpfr_underflow_p()) { print "not ok 5\n"; } else {print "ok 5\n"} ###################### ###################### Rmpfr_set_overflow(); if(Rmpfr_overflow_p()) {print "ok 6\n"} else { warn "\nBug in at least one of Rmpfr_set_overflow() and Rmpfr_overflow_p()\n"; print "not ok 6\n"; } Rmpfr_flags_clear(MPFR_FLAGS_OVERFLOW); if(Rmpfr_overflow_p()) { print "not ok 7\n"; } else {print "ok 7\n"} ###################### ###################### Rmpfr_set_nanflag(); if(Rmpfr_nanflag_p()) {print "ok 8\n"} else { warn "\nBug in at least one of Rmpfr_set_nanflag() and Rmpfr_nanflag_p()\n"; print "not ok 8\n"; } Rmpfr_flags_clear(MPFR_FLAGS_NAN); if(Rmpfr_nanflag_p()) { print "not ok 9\n"; } else {print "ok 9\n"} ###################### ###################### Rmpfr_set_inexflag(); if(Rmpfr_inexflag_p()) {print "ok 10\n"} else { warn "\nBug in at least one of Rmpfr_set_inexflag() and Rmpfr_inexflag_p()\n"; print "not ok 10\n"; } Rmpfr_flags_clear(MPFR_FLAGS_INEXACT); if(Rmpfr_inexflag_p()) { print "not ok 11\n"; } else {print "ok 11\n"} ###################### ###################### Rmpfr_set_erangeflag(); if(Rmpfr_erangeflag_p()) {print "ok 12\n"} else { warn "\nBug in at least one of Rmpfr_set_erangeflag() and Rmpfr_erangeflag_p()\n"; print "not ok 12\n"; } Rmpfr_flags_clear(MPFR_FLAGS_ERANGE); if(Rmpfr_erangeflag_p()) { print "not ok 13\n"; } else {print "ok 13\n"} ###################### ###################### Rmpfr_set_divby0(); if(Rmpfr_divby0_p()) {print "ok 14\n"} else { warn "\nBug in at least one of Rmpfr_set_divby0() and Rmpfr_divby0_p()\n"; print "not ok 14\n"; } Rmpfr_flags_clear(MPFR_FLAGS_DIVBY0); if(Rmpfr_divby0_p()) { print "not ok 15\n"; } else {print "ok 15\n"} ###################### ###################### Rmpfr_set_divby0(); if(Rmpfr_divby0_p()) {print "ok 16\n"} else { warn "\nBug in at least one of Rmpfr_set_divby0() and Rmpfr_divby0_p()\n"; print "not ok 16\n"; } Rmpfr_flags_clear(MPFR_FLAGS_NAN); if(Rmpfr_divby0_p()) { # should have been untouched print "ok 17\n"; } else {print "not ok 17\n"} ###################### ###################### Rmpfr_set_divby0(); if(Rmpfr_divby0_p()) {print "ok 18\n"} else { warn "\nBug in at least one of Rmpfr_set_divby0() and Rmpfr_divby0_p()\n"; print "not ok 18\n"; } Rmpfr_flags_clear(MPFR_FLAGS_ALL); if(Rmpfr_divby0_p()) { print "not ok 19\n"; } else {print "ok 19\n"} ###################### ###################### Rmpfr_set_divby0(); Rmpfr_set_nanflag(); my $mask = Rmpfr_flags_save(); if($mask == 36) {print "ok 20\n"} else { warn "\n Expected 36\nGot $mask\n"; print "not ok 20\n"; } my $check = Rmpfr_flags_test(MPFR_FLAGS_ALL); if($check == 36) {print "ok 21\n"} else { warn "\nExpected 36\nGot $check\n"; print "not ok 21\n"; } Rmpfr_flags_set(24); $mask = Rmpfr_flags_save(); if($mask == 60) {print "ok 22\n"} else { warn "\nExpected 60\nGot $mask\n"; print "not ok 22\n"; } Rmpfr_flags_restore(3, $mask); # print Rmpfr_flags_save(), "\n"; if(Rmpfr_flags_save() == 0) {print "ok 23\n"} else { warn "\nExpected 0\nGot ", Rmpfr_flags_save(), "\n"; print "not ok 23\n"; } } else { eval{Rmpfr_flags_clear(1) ;}; if($@ =~ /^Rmpfr_flags_clear not implemented \- need at least mpfr\-4\.0\.0/) {print "ok 4\n"} else { warn "\n\$\@:\n$@\n"; print "not ok 4\n"; } eval{Rmpfr_flags_set(1) ;}; if($@ =~ /^Rmpfr_flags_set not implemented \- need at least mpfr\-4\.0\.0/) {print "ok 5\n"} else { warn "\n\$\@:\n$@\n"; print "not ok 5\n"; } eval{Rmpfr_flags_test(1) ;}; if($@ =~ /^Rmpfr_flags_test not implemented \- need at least mpfr\-4\.0\.0/) {print "ok 6\n"} else { warn "\n\$\@:\n$@\n"; print "not ok 6\n"; } eval{Rmpfr_flags_save() ;}; if($@ =~ /^Rmpfr_flags_save not implemented \- need at least mpfr\-4\.0\.0/) {print "ok 7\n"} else { warn "\n\$\@:\n$@\n"; print "not ok 7\n"; } eval{Rmpfr_flags_restore(2, 1);}; if($@ =~ /^Rmpfr_flags_restore not implemented \- need at least mpfr\-4\.0\.0/) {print "ok 8\n"} else { warn "\n\$\@:\n$@\n"; print "not ok 8\n"; } warn "\n Skipping tests 9 to 23 for this version of the mpfr library\n"; print "ok $_\n" for 9 .. 23; } $x += 0.5; # 200.5 eval {Rmpfr_rint_roundeven($rop, $x, MPFR_RNDN);}; if($have_new) { if($rop == 200) {print "ok 24\n"} else { warn "\nExpected 200\nGot $rop\n"; print "not ok 24\n"; } } else { if($@ =~ /^Rmpfr_rint_roundeven not implemented \- need at least mpfr\-4\.0\.0/) {print "ok 24\n"} else { warn "\n\$\@:\n$@\n"; print "not ok 24\n"; } } $x += 1.0; # 201.5 eval {Rmpfr_rint_roundeven($rop, $x, MPFR_RNDN);}; if($have_new) { if($rop == 202) {print "ok 25\n"} else { warn "\nExpected 202\nGot $rop\n"; print "not ok 25\n"; } } else { if($@ =~ /^Rmpfr_rint_roundeven not implemented \- need at least mpfr\-4\.0\.0/) {print "ok 25\n"} else { warn "\n\$\@:\n$@\n"; print "not ok 25\n"; } } eval {Rmpfr_roundeven($rop, $x);}; if($have_new) { if($rop == 202) {print "ok 26\n"} else { warn "\nExpected 202\nGot $rop\n"; print "not ok 26\n"; } } else { if($@ =~ /^Rmpfr_roundeven not implemented \- need at least mpfr\-4\.0\.0/) {print "ok 26\n"} else { warn "\n\$\@:\n$@\n"; print "not ok 26\n"; } } $x += 1.0; # 202.5 eval {Rmpfr_roundeven($rop, $x);}; if($have_new) { if($rop == 202) {print "ok 27\n"} else { warn "\nExpected 202\nGot $rop\n"; print "not ok 27\n"; } } else { if($@ =~ /^Rmpfr_roundeven not implemented \- need at least mpfr\-4\.0\.0/) {print "ok 27\n"} else { warn "\n\$\@:\n$@\n"; print "not ok 27\n"; } } my $state = Rmpfr_randinit_mt(); if($have_new) { Rmpfr_nrandom($rop, $state, MPFR_RNDN); Rmpfr_nrandom($rop2, $state, MPFR_RNDN); if($rop != $rop2) {print "ok 28\n"} else {print "not ok 28\n"} } else { eval {Rmpfr_nrandom($rop, $state, MPFR_RNDN);}; if($@ =~ /^Rmpfr_nrandom not implemented \- need at least mpfr\-4\.0\.0/) {print "ok 28\n"} else { warn "\n\$\@:\n$@\n"; print "not ok 28\n"; } } if($have_new) { Rmpfr_erandom($rop, $state, MPFR_RNDN); Rmpfr_erandom($rop2, $state, MPFR_RNDN); if($rop != $rop2) {print "ok 29\n"} else {print "not ok 29\n"} } else { eval {Rmpfr_erandom($rop, $state, MPFR_RNDN);}; if($@ =~ /^Rmpfr_erandom not implemented \- need at least mpfr\-4\.0\.0/) {print "ok 29\n"} else { warn "\n\$\@:\n$@\n"; print "not ok 29\n"; } } my $op1 = Math::MPFR->new(10); my $op2 = Math::MPFR->new(15); my $op3 = Math::MPFR->new(10); my $op4 = Math::MPFR->new(14); eval {Rmpfr_fmma($rop, $op1, $op2, $op3, $op4, MPFR_RNDN);}; if($have_new) { if($rop == 290) {print "ok 30\n"} else { warn "\nExpected 190\nGot $rop\n"; print "not ok 30\n"; } } else { if($@ =~ /^Rmpfr_fmma not implemented \- need at least mpfr\-4\.0\.0/) {print "ok 30\n"} else { warn "\n\$\@:\n$@\n"; print "not ok 30\n"; } } eval {Rmpfr_fmms($rop, $op1, $op2, $op3, $op4, MPFR_RNDN);}; if($have_new) { if($rop == 10) {print "ok 31\n"} else { warn "\nExpected 10\nGot $rop\n"; print "not ok 31\n"; } } else { if($@ =~ /^Rmpfr_fmms not implemented \- need at least mpfr\-4\.0\.0/) {print "ok 31\n"} else { warn "\n\$\@:\n$@\n"; print "not ok 31\n"; } } eval {Rmpfr_log_ui($rop, $op1, MPFR_RNDN);}; if($have_new) { if($rop > 2.302585 && $rop < 2.3025851) {print "ok 32\n"} else { warn "\nExpected approx 2.3025851\nGot $rop\n"; print "not ok 32\n"; } } else { if($@ =~ /^Rmpfr_log_ui not implemented \- need at least mpfr\-4\.0\.0/) {print "ok 32\n"} else { warn "\n\$\@:\n$@\n"; print "not ok 32\n"; } } eval {Rmpfr_gamma_inc($rop, Math::MPFR->new(-1), Math::MPFR->new(0), MPFR_RNDN);}; if($have_new) { if(Rmpfr_nan_p($rop)) {print "ok 33\n"} else { warn "\nExpected NaN\nGot $rop\n"; print "not ok 33\n"; } } else { if($@ =~ /^Rmpfr_gamma_inc not implemented \- need at least mpfr\-4\.0\.0/) {print "ok 33\n"} else { warn "\n\$\@:\n$@\n"; print "not ok 33\n"; } } if($have_new) { my $inex1 = Rmpfr_beta($rop1, Math::MPFR->new(21), Math::MPFR->new(31), MPFR_RNDN); my $inex2 = Rmpfr_beta($rop2, Math::MPFR->new(31), Math::MPFR->new(21), MPFR_RNDN); if($inex1 == $inex2) {print "ok 34\n"} else { warn "\n \$inex1: $inex1\n\ $inex2: $inex2\n"; print "not ok 34\n"; } if($rop1 == $rop2) {print "ok 35\n"} else { warn "\n \$rop1: $rop1\n\ $rop2: $rop2\n"; print "not ok 35\n"; } Rmpfr_beta($rop1, Math::MPFR->new(5), Math::MPFR->new(6), MPFR_RNDN); if($rop1 = Math::MPFR->new(24) / Math::MPFR->new(30240)) {print "ok 36\n"} else { warn "\n Expected ", Math::MPFR->new(24) / Math::MPFR->new(30240), "\n Got: $rop1\n"; print "not ok 36\n"; } } else { eval{Rmpfr_beta($rop2, Math::MPFR->new(31), Math::MPFR->new(21), MPFR_RNDN);}; if($@ =~ /^Rmpfr_beta not implemented \- need at least mpfr\-4\.0\.0/) {print "ok 34\n"} else { warn "\n\$\@:\n$@\n"; print "not ok 34\n"; } warn "\n Skipping tests 35 & 36 - nothing to test\n"; print "ok 35\n"; print "ok 36\n"; } Math-MPFR-4.38/t/new_in_4.1.0.t0000755060175106010010000001025114765756127014335 0ustar OwnerNone use warnings; use strict; use Math::MPFR qw(:mpfr); use POSIX; print "1..10\n"; my $have_new = 1; my ($inex, $p, $ret, $ok); my $rop = Math::MPFR->new(); if(!defined(MPFR_VERSION) || 262400 > MPFR_VERSION) {$have_new = 0} # mpfr version is pre 4.1.0 my @op1 = (Math::MPFR->new(200), Math::MPFR->new(-3), Math::MPFR->new(1001)); my @op2 = (Math::MPFR->new(5), Math::MPFR->new(30), Math::MPFR->new(90)); eval { $inex = Rmpfr_dot($rop, \@op1, \@op2, scalar(@op2), MPFR_RNDN) }; if($have_new) { if($rop == 91000) {print "ok 1\n"} else { warn "\nExpected 91000\nGot $rop\n"; print "not ok 1\n"; } if($inex == 0) {print "ok 2\n"} else { warn "\nExpected inex == 0\nGot inex == $inex\n"; print "not ok 2\n"; } push(@op1, 1); eval{ $inex = Rmpfr_dot($rop, \@op1, \@op2, scalar(@op2) + 1, MPFR_RNDN) }; if($@ =~ /^2nd last arg to Rmpfr_dot is too large/) {print "ok 3\n"} else { warn "\n \$\@:\n$@\n"; print "not ok 3\n"; } } else { if($@ =~ /^The Rmpfr_dot function requires mpfr\-4\.1\.0/) {print "ok 1\n"} else { warn "\n\$\@:\n $@\n"; print "not ok 1\n"; } warn "\n Skipping tests 2 & 3 - we don't have mpfr-4.1.0 or later\n"; print "ok 2\nok 3\n"; } # Math::MPFR provides its own implementation of Rmpfr_get_str_ndigits, # namely Rmpfr_get_str_ndigits_alt, when built against a pre-4.1.0 version # of the MPFR library. eval { $p = Rmpfr_get_str_ndigits(63, 100) }; if($@) { if($@ =~ /^1st argument given to Rmpfr_get_str_ndigits must be in the range 2\.\.62/) { print "ok 4\n"; } else { warn "\n\$\@: $@\n"; print "not ok 4\n"; } } else { print "not ok 4\n" } $ok = 1; for my $base(2..62) { for my $prec(1 .. 1000) { $p = Rmpfr_get_str_ndigits($base, $prec); my $expected = Rmpfr_get_str_ndigits_alt($base, $prec);; if($expected != $p) { warn "for base $base, prec $prec bits: $expected != $p\n"; $ok = 0; } } } if($ok) { print "ok 5\n" } else { print "not ok 5\n" } # Math::MPFR provides its own implementation of Rmpfr_total_order_p # when built against a pre-4.1.0 version of the MPFR library. $ok = 1; my $pnan = Math::MPFR->new(); # NaN my $nnan = Math::MPFR->new(); Rmpfr_setsign($nnan, $pnan, 1, MPFR_RNDN); # -NaN my $pinf = Math::MPFR->new(1) / 0; # Inf my $ninf = Math::MPFR->new(); Rmpfr_setsign($ninf, $pinf, 1, MPFR_RNDN); # -Inf my $preal = Math::MPFR->new(2); # 2 my $nreal = Math::MPFR->new(-2); # -2 my $pzero = Math::MPFR->new(0); # 0 my $nzero = Math::MPFR->new(-0.0); # - 0 Rmpfr_clear_erangeflag(); for([$nnan, $ninf], [$ninf, $nreal], [$nreal, $nzero], [$nzero, $pzero], [$pzero, $preal], [$preal, $pinf], [$pinf, $pnan], [$nnan, $pnan]) { my @x = @{$_}; if(!Rmpfr_total_order_p($x[0], $x[1])) { warn "$x[0] is not less than or equal to $x[1]\n"; $ok = 0; } if(Rmpfr_total_order_p($x[1], $x[0])) { warn "$x[1] <= $x[0]\n"; $ok = 0; } } for([$nnan, $nnan], [$pnan, $pnan], [$nzero, $nzero], [$pzero, $pzero]) { my @x = @{$_}; if(!Rmpfr_total_order_p($x[0], $x[1])) { warn "$x[0] != $x[1]\n"; $ok = 0; } if(!Rmpfr_total_order_p($x[1], $x[0])) { warn "$x[1] is not less than or equal to $x[0]\n"; $ok = 0; } } if($ok) { print "ok 6\n" } else { print "not ok 6\n" } # Rmpfr_total_order_p() should not set erangeflag if(Rmpfr_erangeflag_p) { Rmpfr_clear_erangeflag(); print "not ok 7\n"; } else { print "ok 7\n" } eval { $ret = Rmpfr_cmpabs_ui($nreal, 1) }; if($have_new) { if($ret > 0) { print "ok 8\n" } else { warn "$ret <= 0\n"; print "not ok 8\n"; } Rmpfr_clear_erangeflag(); $ret = Rmpfr_cmpabs_ui($nnan, 1); if($ret == 0) { print "ok 9\n" } else { warn "$ret != 0\n"; print "not ok 9\n"; } if(Rmpfr_erangeflag_p()) { Rmpfr_clear_erangeflag; print "ok 10\n"; } else { warn "erangeflag not set\n"; print "not ok 10\n"; } } else { if($@ =~ /^The Rmpfr_cmpabs_ui function requires mpfr\-4\.1\.0/) { print "ok 8\n" } else { warn "\$\@: $@\n"; print "not ok 8\n"; } warn "\n Skipping tests 9 & 10 - we don't have mpfr-4.1.0 or later\n"; print "ok 9\n"; print "ok 10\n"; } Math-MPFR-4.38/t/new_pow_log_exp.t0000755060175106010010000001006214765756127015531 0ustar OwnerNone # Here we test the new pow() functions that were added in mpfr-4.2.0: # Rmpfr_powr, Rmpfr_log2p1, Rmpfr_log10p1' Rmpfr_compound_si, Rmpfr_exp2m1, # Rmpfr_exp10m1, Rmpfr_pown, Rmpfr_pow_uj and Rmpfr_pow_sj. use strict; use warnings; use Config; use Test::More; use Math::MPFR qw(:mpfr); my $has_420 = 0; $has_420++ if MPFR_VERSION() >= 262656; # mpfr-4.2.0 or later my $iv_is_longlong = Math::MPFR::_has_longlong(); # my $pi = Math::MPFR->new('3.1415926535897931'); my $rop1 = Math::MPFR->new(); my $rop2 = Math::MPFR->new(); my $op = Math::MPFR->new('0.999999999'); my $op2 = Math::MPFR->new(7); if($has_420) { my $rop_check = exp($op2 * log($op)); Rmpfr_powr($rop1, $op, $op2, MPFR_RNDN); cmp_ok( abs($rop_check - $rop1), '==', 0, "Rmpfr_powr is in range ($rop1 | $rop_check)" ); $rop_check = ($op + 1) ** -7; Rmpfr_compound_si($rop1, $op, -7, MPFR_RNDN); cmp_ok( abs($rop_check - $rop1), '<', 1e-17, "Rmpfr_compound_si is in range ($rop1 | $rop_check)" ); Rmpfr_log2($rop2, $op + 1, MPFR_RNDN); Rmpfr_log2p1 ($rop1, $op, MPFR_RNDN); cmp_ok( abs($rop2 - $rop1), '==', 0, "Rmpfr_log2p1 is in range ($rop1 | $rop2)" ); Rmpfr_log10($rop2, $op + 1, MPFR_RNDN); Rmpfr_log10p1 ($rop1, $op, MPFR_RNDN); cmp_ok( abs($rop2 - $rop1), '==', 0, "Rmpfr_log10p1 is in range ($rop1 | $rop2)" ); $rop_check = (2 ** Math::MPFR->new(6)) - 1; Rmpfr_exp2m1 ($rop1, Math::MPFR->new(6), MPFR_RNDN); cmp_ok( abs($rop_check - $rop1), '==', 0, "Rmpfr_exp2m1 is in range ($rop1 | $rop_check)" ); $rop_check = (10 ** Math::MPFR->new(5)) - 1; Rmpfr_exp10m1 ($rop1, Math::MPFR->new(5), MPFR_RNDN); cmp_ok( abs($rop_check - $rop1), '==', 0, "Rmpfr_exp10m1 is in range ($rop1 | $rop_check)" ); $rop_check = $op ** 7; Rmpfr_pow_uj($rop1, $op, 7, MPFR_RNDN); cmp_ok($rop_check, '==', $rop1, 'Rmpfr_pow_uj is ok'); $rop_check = $op ** -7; Rmpfr_pow_sj($rop1, $op, -7, MPFR_RNDN); cmp_ok($rop_check, '==', $rop1, 'Rmpfr_pow_sj is ok'); Rmpfr_pown($rop2, $op, -7, MPFR_RNDN); cmp_ok($rop2, '==', $rop1, 'Rmpfr_pown is ok'); } else { eval { Rmpfr_powr($rop2, $op, $op, MPFR_RNDN); }; like ( $@, qr/^Rmpfr_powr function not implemented until/, 'Rmpfr_powr not implemented' ); eval { Rmpfr_pow_uj($rop1, $op, 7, MPFR_RNDN); }; like ( $@, qr/^Rmpfr_pow_uj function not implemented until/, 'Rmpfr_pow_uj not implemented' ); eval { Rmpfr_pow_sj($rop1, $op, -7, MPFR_RNDN); }; like ( $@, qr/^Rmpfr_pow_sj function not implemented until/, 'Rmpfr_pow_sj not implemented' ); eval { Rmpfr_pown($rop2, $op, -7, MPFR_RNDN); }; like ( $@, qr/^Rmpfr_pown function not implemented until/, 'Rmpfr_pown not implemented' ); eval { Rmpfr_compound_si($rop1, $op, 7, MPFR_RNDN); }; like ( $@, qr/^Rmpfr_compound_si function not implemented until/, 'Rmpfr_compound_si not implemented' ); eval { Rmpfr_log2p1($rop1, $op, MPFR_RNDN); }; like ( $@, qr/^Rmpfr_log2p1 function not implemented until/, 'Rmpfr_log2p1 not implemented' ); eval { Rmpfr_log10p1($rop1, $op, MPFR_RNDN); }; like ( $@, qr/^Rmpfr_log10p1 function not implemented until/, 'Rmpfr_log10p1 not implemented' ); eval { Rmpfr_exp2m1($rop1, $op, MPFR_RNDN); }; like ( $@, qr/^Rmpfr_exp2m1 function not implemented until/, 'Rmpfr_exp2m1 not implemented' ); eval { Rmpfr_exp10m1($rop1, $op, MPFR_RNDN); }; like ( $@, qr/^Rmpfr_exp10m1 function not implemented until/, 'Rmpfr_exp10m1 not implemented' ); } my $inex1 = Rmpfr_pow_IV($rop1, Math::MPFR->new(2), -11, MPFR_RNDN); my $inex2 = Rmpfr_pow_si($rop2, Math::MPFR->new(2), -11, MPFR_RNDN); cmp_ok( $rop1, '==', $rop2, "Rmpfr_pow_IV and Rmpfr_pow_si calculate same result" ); cmp_ok( $inex1, '==', 0, "Rmpfr_pow_IV returns 0" ); cmp_ok( $inex2, '==', 0, "Rmpfr_pow_si returns 0" ); $inex1 = Rmpfr_pow_IV($rop1, Math::MPFR->new(2), 11, MPFR_RNDN); $inex2 = Rmpfr_pow_ui($rop2, Math::MPFR->new(2), 11, MPFR_RNDN); cmp_ok( $rop1, '==', $rop2, "Rmpfr_pow_IV and Rmpfr_pow_ui calculate same result" ); cmp_ok( $inex1, '==', 0, "Rmpfr_pow_IV returns 0" ); cmp_ok( $inex2, '==', 0, "Rmpfr_pow_ui returns 0" ); done_testing(); Math-MPFR-4.38/t/NOK_and_POK.t0000755060175106010010000001344514765756127014330 0ustar OwnerNoneuse strict; use warnings; use Math::MPFR qw(:mpfr); print "1..28\n"; my $n = '98765' x 1000; my $r = '98765' x 1000; my $z; my $check = 0; # $Math::MPFR::NOK_POK = 1; # Uncomment to view warnings. if(Math::MPFR::nok_pokflag() == $check) {print "ok 1\n"} else { warn "\n", Math::MPFR::nok_pokflag(), " != $check\n"; print "not ok 1\n"; } adj($n, \$check, 1); # Should do nothing if($n > 0) { # sets NV slot to inf, and turns on the NOK flag adj($n, \$check, 1); $z = Math::MPFR->new($n); } if(Math::MPFR::nok_pokflag() == $check) {print "ok 2\n"} else { warn "\n", Math::MPFR::nok_pokflag(), " != $check\n"; print "not ok 2\n"; } if($z == $r) {print "ok 3\n"} else { warn "$z != $r\n"; print "not ok 3\n"; } if(Math::MPFR::nok_pokflag() == $check) {print "ok 4\n"} # No change as $r is not a dualvar. else { warn "\n", Math::MPFR::nok_pokflag(), " != $check\n"; print "not ok 4\n"; } my $inf = 999**(999**999); # value is inf, NOK flag is set. my $nan = $inf / $inf; # value is nan, NOK flag is set. my $discard = eval{"$inf"}; # POK flag is now also set for $inf (mostly) $discard = eval{"$nan"}; # POK flag is now also set for $nan (mostly) adj($inf, \$check, 1); $check++ if Math::MPFR::ISSUE_19550; $z = Math::MPFR->new($inf); if(Math::MPFR::nok_pokflag() == $check) {print "ok 5\n"} else { warn "\n", Math::MPFR::nok_pokflag(), " != $check\n"; print "not ok 5\n"; } if(Rmpfr_inf_p($z)) {print "ok 6\n"} else { warn "\n Expected inf\n Got $z\n"; print "not ok 6\n"; } adj($inf, \$check, 1); if($z == $inf) {print "ok 7\n"} else { warn "$z != inf\n"; print "not ok 7\n"; } if(Math::MPFR::nok_pokflag() == $check) {print "ok 8\n"} else { warn "\n", Math::MPFR::nok_pokflag(), " != $check\n"; print "not ok 8\n"; } adj($nan, \$check, 1); $check++ if Math::MPFR::ISSUE_19550; my $z2 = Math::MPFR->new($nan); if(Math::MPFR::nok_pokflag() == $check) {print "ok 9\n"} else { warn "\n", Math::MPFR::nok_pokflag(), " != $check\n"; print "not ok 9\n"; } if(Rmpfr_nan_p($z2)) {print "ok 10\n"} else { warn "\n Expected nan\n Got $z2\n"; print "not ok 10\n"; } my $fr = Math::MPFR->new(10); adj($n, \$check, 1); my $ret = ($fr > $n); if(Math::MPFR::nok_pokflag() == $check) {print "ok 11\n"} else { warn "\n", Math::MPFR::nok_pokflag(), " != $check\n"; print "not ok 11\n"; } adj($inf, \$check, 1); $ret = ($fr < $inf); if(Math::MPFR::nok_pokflag() == $check) {print "ok 12\n"} else { warn "\n", Math::MPFR::nok_pokflag(), " != $check\n"; print "not ok 12\n"; } adj($inf, \$check, 1); $ret = ($fr >= $inf); if(Math::MPFR::nok_pokflag() == $check) {print "ok 13\n"} else { warn "\n", Math::MPFR::nok_pokflag(), " != $check\n"; print "not ok 13\n"; } adj($inf, \$check, 1); $ret = ($fr <= $inf); if(Math::MPFR::nok_pokflag() == $check) {print "ok 14\n"} else { warn "\n", Math::MPFR::nok_pokflag(), " != $check\n"; print "not ok 14\n"; } adj($inf, \$check, 1); $ret = ($fr <=> $inf); if(Math::MPFR::nok_pokflag() == $check) {print "ok 15\n"} else { warn "\n", Math::MPFR::nok_pokflag(), " != $check\n"; print "not ok 15\n"; } adj($inf, \$check, 1); $ret = $fr * $inf; if(Math::MPFR::nok_pokflag() == $check) {print "ok 16\n"} else { warn "\n", Math::MPFR::nok_pokflag(), " != $check\n"; print "not ok 16\n"; } adj($inf, \$check, 1); $ret = $fr + $inf; if(Math::MPFR::nok_pokflag() == $check) {print "ok 17\n"} else { warn "\n", Math::MPFR::nok_pokflag(), " != $check\n"; print "not ok 17\n"; } adj($inf, \$check, 1); $ret = $fr - $inf; if(Math::MPFR::nok_pokflag() == $check) {print "ok 18\n"} else { warn "\n", Math::MPFR::nok_pokflag(), " != $check\n"; print "not ok 18\n"; } adj($inf, \$check, 1); $ret = $fr / $inf; if(Math::MPFR::nok_pokflag() == $check) {print "ok 19\n"} else { warn "\n", Math::MPFR::nok_pokflag(), " != $check\n"; print "not ok 19\n"; } adj($inf, \$check, 1); $ret = $inf ** $fr; if(Math::MPFR::nok_pokflag() == $check) {print "ok 20\n"} else { warn "\n", Math::MPFR::nok_pokflag(), " != $check\n"; print "not ok 20\n"; } adj($inf, \$check, 1); $fr *= $inf; if(Math::MPFR::nok_pokflag() == $check) {print "ok 21\n"} else { warn "\n", Math::MPFR::nok_pokflag(), " != $check\n"; print "not ok 21\n"; } adj($inf, \$check, 1); $fr += $inf; if(Math::MPFR::nok_pokflag() == $check) {print "ok 22\n"} else { warn "\n", Math::MPFR::nok_pokflag(), " != $check\n"; print "not ok 22\n"; } adj($inf, \$check, 1); $fr -= $inf; if(Math::MPFR::nok_pokflag() == $check) {print "ok 23\n"} else { warn "\n", Math::MPFR::nok_pokflag(), " != $check\n"; print "not ok 23\n"; } adj($inf, \$check, 1); $fr /= $inf; if(Math::MPFR::nok_pokflag() == $check) {print "ok 24\n"} else { warn "\n", Math::MPFR::nok_pokflag(), " != $check\n"; print "not ok 24\n"; } adj($inf, \$check, 1); $inf **= Math::MPFR->new(1); if(Math::MPFR::nok_pokflag() == $check) {print "ok 25\n"} else { warn "\n", Math::MPFR::nok_pokflag(), " != $check\n"; print "not ok 25\n"; } adj($n, \$check, 1); $ret = ($z != $n); if(Math::MPFR::nok_pokflag() == $check) {print "ok 26\n"} else { warn "\n", Math::MPFR::nok_pokflag(), " != $check\n"; print "not ok 26\n"; } my $nv = 1.3; my $s = "$nv"; # $nv should be POK && NOK if MPFR_PV_NV_BUG is 1 # Else (ie MPFR_PV_NV_BUG is 0) $nv should be NOK only. $z = Math::MPFR->new($nv); $check++ if MPFR_PV_NV_BUG; if(Math::MPFR::nok_pokflag() == $check) {print "ok 27\n"} else { warn "\n", Math::MPFR::nok_pokflag(), " != $check\n"; print "not ok 27\n"; } if(Math::MPFR::ISSUE_19550) { if($] < 5.035010) { warn "ISSUE_19550 unexpectedly set\n"; print "not ok 28\n"; } else { warn "ISSUE_19550 set\n"; print "ok 28\n"; } } else { warn "ISSUE_19550 not set\n"; print "ok 28\n"; } ######## sub adj { if(Math::MPFR::_SvNOK($_[0]) && Math::MPFR::_SvPOK($_[0])) { ${$_[1]} += $_[2]; } } Math-MPFR-4.38/t/not_zero.t0000755060175106010010000000776514765756127014215 0ustar OwnerNone# Just some additional tests to check that ~0, unsigned and signed longs are # are being handled as expected. use warnings; use strict; use Math::MPFR qw(:mpfr); use Config; print"1..6\n"; print "# Using Math::MPFR version ", $Math::MPFR::VERSION, "\n"; print "# Using mpfr library version ", MPFR_VERSION_STRING, "\n"; print "# Using gmp library version ", Math::MPFR::gmp_v(), "\n"; Rmpfr_set_default_prec(65); my $n = ~0; my $mpfr1 = Math::MPFR::new($n); my $mpfr2 = Math::MPFR->new($n); my ($mpfr3, $info3) = Rmpfr_init_set_ui($n, GMP_RNDN); my ($mpfr4, $info4) = Rmpfr_init_set_si($n, GMP_RNDN); if($mpfr4 == -1) {print "ok 1\n"} else {print "not ok 1\n"} if($mpfr1 == $n && $mpfr2 == $n ) {print "ok 2\n"} else {print "not ok 2\n"} if(Math::MPFR::_has_longlong() && $Config::Config{longsize} == 4) { if($mpfr3 != $n) {print "ok 3 A\n"} else {print "not ok 3 A $mpfr3 == $n\n"} } else { if($n == $mpfr3) {print "ok 3 B \n"} else {print "not ok 3 B $mpfr3 != $n\n"} } my $ok = ''; # Check the overloaded operators. # But skip these tests 4a to 4h (as they fail) if # $] < 5.007 and perl was built with -Duse64bitint # but without -Duselongdouble if(!($] < 5.007 && !Math::MPFR::_has_longdouble() && Math::MPFR::_has_longlong())) { if($mpfr1 - 1 == $n - 1) {$ok .= 'a'} else {warn "4a: ", $mpfr1 - 1, " != ", $n - 1} $mpfr1 -= 1; if($mpfr1 == $n - 1) {$ok .= 'b'} else {warn "4b: ", $mpfr1, " != ", $n - 1} $mpfr1 = $mpfr1 / 2; if($mpfr1 == ($n - 1) / 2) {$ok .= 'c'} else { my $t = ($n - 1) / 2; warn "4c: ", $mpfr1, " != ", $t; } $mpfr1 = $mpfr1 * 2; if($mpfr1 == $n - 1) {$ok .= 'd'} else {warn "4d: ", $mpfr1, " != ", $n - 1} $mpfr1 /= 2; if($mpfr1 == ($n - 1) / 2) {$ok .= 'e'} else { my $t = ($n - 1) / 2; warn "4e: ", $mpfr1 - 1, " != ", $t; } $mpfr1 *= 2; if($mpfr1 == $n - 1) {$ok .= 'f'} else {warn "4f: ", $mpfr1, " != ", $n - 1} if($mpfr1 + 1 == $n) {$ok .= 'g'} else {warn "4g: ", $mpfr1 + 1, " != ", $n} $mpfr1 += 1; if($mpfr1 == $n) {$ok .= 'h'} else {warn "4h: ", $mpfr1, " != ", $n} } else { warn "Skipping tests 4a to 4h as they fail on perl 5.6\nbuilt with -Duse64bitint but without -Duselongdouble\n"; $ok = 'abcdefgh'; } #my $bits = Math::MPFR::_has_longlong() ? 32 : 16; my $bits = $Config{ivsize} > 4 ? 32 : 16; if($mpfr1 ** 0.5 < 2 ** $bits && $mpfr1 ** 0.5 > (2 ** $bits) - 1 ) {$ok .= 'i'} $mpfr1 **= 0.5; if($mpfr1 < 2 ** $bits && $mpfr1 > (2 ** $bits) - 1) {$ok .= 'j'} if($ok eq 'abcdefghij') {print "ok 4\n"} else {print "not ok 4 $ok\n"} if(Math::MPFR::_has_longlong()) { my $ul; if($Config::Config{cc} eq 'cl') { $ul = Rmpfr_integer_string($mpfr2, 10, GMP_RNDN); } else {$ul = Rmpfr_get_uj($mpfr2, GMP_RNDN)} if($ul == $n) {print "ok 5\n"} else {print "not ok 5 $ul != $n\n"} } else { warn "Skipping test 5 - no 'long long' support\n"; print "ok 5\n"; } $ok = ''; Rmpfr_set_str($mpfr1, ~0, 10, GMP_RNDN); my $string = Rmpfr_integer_string($mpfr1, 10, GMP_RNDN); if($string == ~0) {$ok .= 'a'} else {print "$string != ", ~0, "\n"} $mpfr1 += 0.25; $string = Rmpfr_integer_string($mpfr1, 10, GMP_RNDN); if($string == ~0) {$ok .= 'b'} else {print "$string != ", ~0, "\n"} if(Math::MPFR::_has_longdouble()) { Rmpfr_set_ld($mpfr1, (~0 - 1) / -2, GMP_RNDN); } elsif(Math::MPFR::_has_longlong()){ if(Math::MPFR::_has_longlong()) { Rmpfr_set_sj($mpfr1, (~0 - 1) / -2, GMP_RNDN); } else {Rmpfr_set_str($mpfr1, (~0 - 1) / -2, 10, GMP_RNDN)} } elsif($Config{ivsize} >= 8) { # Not a 'long long'; must be a 'long' Rmpfr_set_si($mpfr1, (~0 - 1) / -2, GMP_RNDN); } else { Rmpfr_set_d($mpfr1, (~0 - 1) / -2, GMP_RNDN); } $string = Rmpfr_integer_string($mpfr1, 10, GMP_RNDN); if($string == (~0 - 1) / -2) {$ok .= 'c'} else {print "$string != ", (~0 - 1) / -2, "\n"} $mpfr1 -= 0.25; $string = Rmpfr_integer_string($mpfr1, 10, GMP_RNDN); if($string == (~0 - 1) / -2) {$ok .= 'd'} else {print "$string != ", (~0 - 1) / -2, "\n"} if($ok eq 'abcd') {print "ok 6\n"} else {print "not ok 6 $ok \n"} Math-MPFR-4.38/t/numtoa.t0000755060175106010010000000224714765756127013647 0ustar OwnerNone use strict; use warnings; use Config; use Math::MPFR qw(:mpfr); my $dd = 0; $dd = 1 if(2 ** 100 + 2 ** -100 > 2 ** 100); # NV is DoubleDouble use Test::More tests => 6; if($Config{ivsize} == 8) { cmp_ok( numtoa(~0), 'eq', '18446744073709551615', 'handles UV_MAX correctly' ); } else { cmp_ok( numtoa(~0), 'eq', '4294967295', 'handles UV_MAX correctly' ); } my $uv = ~0 - 100000000; if($Config{ivsize} == 8) { cmp_ok( numtoa($uv), 'eq', '18446744073609551615', 'handles UVs correctly' ); } else { cmp_ok( numtoa($uv), 'eq', '4194967295', 'handles UVs correctly' ); } my $iv_min = -(~0 >> 1); if($Config{ivsize} == 8) { cmp_ok( numtoa($iv_min), 'eq', '-9223372036854775807', 'handles IV_MIN correctly' ); } else { cmp_ok( numtoa($iv_min), 'eq', '-2147483647', 'handles IV_MIN correctly' ); } cmp_ok( numtoa(-17), 'eq', '-17', 'handles IVs correctly' ); my $f = 0.1 / 10; my $f_correct = '0.01'; $f_correct = '0.00999999999999999999999999999999996' if $dd; # NV is DoubleDouble cmp_ok( numtoa($f), 'eq', $f_correct, 'handles NVs correctly' ); eval { numtoa('hello world'); }; like ( $@, qr/Not a numeric argument given to _numtoa function/, 'dies correctly' ); Math-MPFR-4.38/t/nvtoa.t0000755060175106010010000003773614765756127013506 0ustar OwnerNoneuse strict; use warnings; use Math::MPFR qw(:mpfr); use Config; use Test::More; if(MPFR_VERSION_MAJOR < 3 || (MPFR_VERSION_MAJOR() == 3 && MPFR_VERSION_PATCHLEVEL < 6)) { plan skip_all => "nvtoa.t utilizes Math::MPFR functionality that requires mpfr-3.1.6\n"; } else { plan tests => 8; my $todo = 0; # Some systems provide sqrtl() but not powl() for their -Duselongdouble builds unless(sqrt(2.0) == 2 ** 0.5) { warn "\nPoorly configured system\n"; $todo = 1; } my $ok = 1; my $p = $Math::MPFR::NV_properties{max_dig} - 1; my $min_pow = $Math::MPFR::NV_properties{min_pow}; my $zero = 0.0; my $nzero = Rmpfr_get_NV(Math::MPFR->new('-0'), MPFR_RNDN); my $inf = 1e4950; my $ninf = $inf * -1; my $nan = Rmpfr_get_NV(Math::MPFR->new(), MPFR_RNDN); my $mpfr_root2 = Rmpfr_init2($Math::MPFR::NV_properties{bits}); Rmpfr_set_ui($mpfr_root2, 2, MPFR_RNDN); Rmpfr_sqrt($mpfr_root2, $mpfr_root2, MPFR_RNDN); my $root2 = Rmpfr_get_NV($mpfr_root2, MPFR_RNDN); my $temp1 = Rmpfr_init2($Math::MPFR::NV_properties{bits}); my $temp2 = Rmpfr_init2($Math::MPFR::NV_properties{bits}); Rmpfr_set_ui($temp1, 1, MPFR_RNDN); Rmpfr_set_ui($temp2, 1, MPFR_RNDN); my $div2exp = -$Math::MPFR::NV_properties{min_pow}; # min_pow is -ve. Rmpfr_div_2exp($temp1, $temp1, $div2exp, MPFR_RNDN); Rmpfr_div_2exp($temp2, $temp2, $div2exp - 1, MPFR_RNDN); Rmpfr_add($temp2, $temp2, $temp1, MPFR_RNDN); my $denorm1 = Rmpfr_get_NV($temp1, MPFR_RNDN); my $denorm2 = Rmpfr_get_NV($temp2, MPFR_RNDN); my @in = ( 0.1 / 10, 1.4 / 10, 2 ** ($Math::MPFR::NV_properties{bits} - 1), atonv('6284685476686e5'), atonv('4501259036604e6'), atonv('1411252895572e-5'), atonv('9.047014579199e-57'), atonv('91630634264070293e0'), atonv('25922126328248069e0'), $denorm1, -$denorm1, $root2, $denorm2, sqrt 3.0, atonv('2385059e-341'), atonv('-2385059e-341'), atonv('1e-9'), atonv('-7373243991138e5'), atonv('63433232978e-332')); # @py3 is 'doubles' - can't be used to check 'long double' and '__float128' builds of perl. my @py3 = ('0.01', '0.13999999999999999', '4503599627370496.0', '6.284685476686e+17', '4.501259036604e+18', '14112528.95572', '9.047014579199e-57', '9.163063426407029e+16', '2.5922126328248068e+16', '5e-324', '-5e-324', '1.4142135623730951', '1.5e-323', '1.7320508075688772', '0.0', '-0.0', '1e-09', '-7.373243991138e+17', '6.3e-322'); ############################################### ################## 53 BIT ##################### if($Math::MPFR::NV_properties{bits} == 53) { cmp_ok( nvtoa(sqrt(2.0)), '==', sqrt(2.0), 'nvtoa(sqrt 2) == sqrt 2' ); cmp_ok( nvtoa($zero), 'eq', '0.0', 'nvtoa(0) eq 0.0' ); SKIP: { skip "Ignoring that this perl doesn't accommodate signed zero", 1 if (nvtoa($nzero) ne '-0.0' && $nzero == 0 && $] < 5.01); cmp_ok( nvtoa($nzero), 'eq', '-0.0', 'nvtoa(-0) eq -0.0' ); }; cmp_ok( nvtoa($inf), 'eq', 'Inf', 'nvtoa(Inf) eq Inf'); cmp_ok( nvtoa($ninf), 'eq', '-Inf', 'nvtoa(-Inf) eq -Inf'); cmp_ok( nvtoa($nan), 'eq', 'NaN', 'nvtoa(NaN) eq NaN'); my $t1 = Rmpfr_init2($Math::MPFR::NV_properties{bits}); my $t2 = Rmpfr_init2($Math::MPFR::NV_properties{bits}); my $orig_emin = Rmpfr_get_emin(); my $orig_emax = Rmpfr_get_emax(); for(@in) { if(abs($_) >= $Math::MPFR::NV_properties{normal_min}) { Rmpfr_strtofr($t1, nvtoa($_), 10, MPFR_RNDN); eval {Rmpfr_set_NV($t2, $_, MPFR_RNDN);}; # in case NV flag is unset if($@) {Rmpfr_strtofr($t2, $_, 10, MPFR_RNDN)} if($t1 != $t2) { $ok = 0; warn "$t1 != $t2\n"; } } else { # We need to subnormalize the mpfr objects. my $s = nvtoa($_); Rmpfr_set_emin($Math::MPFR::NV_properties{emin}); #(-1073); Rmpfr_set_emax($Math::MPFR::NV_properties{emax}); #(1024); my $inex = Rmpfr_strtofr($t1, $s, 10, MPFR_RNDN); Rmpfr_subnormalize($t1, $inex, MPFR_RNDN); # Rmpfr_set_NV will croak if 2nd arg does not have the NV flag set # and some older perls might not set that flag - in which case # we can fall back to Rmpfr_strtofr. eval {$inex = Rmpfr_set_NV($t2, $_, MPFR_RNDN);}; if($@) { $inex = Rmpfr_strtofr($t2, $_, 10, MPFR_RNDN) } Rmpfr_subnormalize($t2, $inex, MPFR_RNDN); if($t1 != $t2) { $ok = 0; warn "$t1 != $t2\n\n"; } Rmpfr_set_emin($orig_emin); Rmpfr_set_emax($orig_emax); } } ok($ok == 1, 'test 7'); $ok = 1; for(my $i = 0; $i < @in; $i++) { my $t = nvtoa($in[$i]); #if($t =~ /e\-0\d\d$/i) {$t =~ s/e\-0/e-/i} # I think this would be incorrect if($t ne $py3[$i]) { unless($in[$i] == 0 && $py3[$i] eq '-0.0' && $] < 5.01) { $ok = 0; warn "$t ne $py3[$i]\n"; } else { warn "Ignoring that this perl doesn't accommodate signed zero\n"; } } } ok($ok == 1, 'test 8'); $ok = 1; } ############################################### ################## 64 BIT ##################### elsif($Math::MPFR::NV_properties{bits} == 64) { cmp_ok( nvtoa(sqrt(2.0)), '==', sqrt(2.0), 'nvtoa(sqrt 2) == sqrt 2' ); cmp_ok( nvtoa($zero), 'eq', '0.0', 'nvtoa(0) eq 0.0' ); SKIP: { skip "Ignoring that this perl doesn't accommodate signed zero", 1 if (nvtoa($nzero) ne '-0.0' && $nzero == 0 && $] < 5.01); cmp_ok( nvtoa($nzero), 'eq', '-0.0', 'nvtoa(-0) eq -0.0' ); }; cmp_ok( nvtoa($inf), 'eq', 'Inf', 'nvtoa(Inf) eq Inf'); cmp_ok( nvtoa($ninf), 'eq', '-Inf', 'nvtoa(-Inf) eq -Inf'); cmp_ok( nvtoa($nan), 'eq', 'NaN', 'nvtoa(NaN) eq NaN'); my $t1 = Rmpfr_init2($Math::MPFR::NV_properties{bits}); my $t2 = Rmpfr_init2($Math::MPFR::NV_properties{bits}); my $orig_emin = Rmpfr_get_emin(); my $orig_emax = Rmpfr_get_emax(); my $pad = Rmpfr_init2(64); Rmpfr_set_si($pad, 2, MPFR_RNDN); Rmpfr_pow_si($pad, $pad, $Math::MPFR::NV_properties{min_pow}, MPFR_RNDN); my $denorm_min = Rmpfr_get_NV($pad, MPFR_RNDN); my $cumulative = Rmpfr_init2(64); Rmpfr_set_si($pad, 2, MPFR_RNDN); Rmpfr_pow_si($pad, $pad, $Math::MPFR::NV_properties{min_pow} + 3, MPFR_RNDN); Rmpfr_set($cumulative, $pad, MPFR_RNDN); Rmpfr_set_si($pad, 2, MPFR_RNDN); Rmpfr_pow_si($pad, $pad, $Math::MPFR::NV_properties{min_pow} + 13, MPFR_RNDN); Rmpfr_add($cumulative, $cumulative, $pad, MPFR_RNDN); Rmpfr_set_si($pad, 2, MPFR_RNDN); Rmpfr_pow_si($pad, $pad, $Math::MPFR::NV_properties{min_pow} + 33, MPFR_RNDN); Rmpfr_add($cumulative, $cumulative, $pad, MPFR_RNDN); my $denormalized = Rmpfr_get_NV($cumulative, MPFR_RNDN); push @in, $denorm_min, $denormalized, sqrt(2.0), atonv('97646e-4945'), atonv('7286408931649326e-4956'); for(@in) { if(abs($_) >= $Math::MPFR::NV_properties{normal_min}) { Rmpfr_strtofr($t1, nvtoa($_), 10, MPFR_RNDN); eval {Rmpfr_set_NV($t2, $_, MPFR_RNDN);}; # in case NV flag is unset if($@) {Rmpfr_strtofr($t2, $_, 10, MPFR_RNDN)} if($t1 != $t2) { $ok = 0; warn "$t1 != $t2\n"; } } else { # We need to subnormalize the mpfr objects. my $s = nvtoa($_); Rmpfr_set_emin($Math::MPFR::NV_properties{emin}); #(-16444); Rmpfr_set_emax($Math::MPFR::NV_properties{emax}); #(16384); my $inex = Rmpfr_strtofr($t1, $s, 10, MPFR_RNDN); Rmpfr_subnormalize($t1, $inex, MPFR_RNDN); $inex = Rmpfr_set_NV($t2, $_, MPFR_RNDN); Rmpfr_subnormalize($t2, $inex, MPFR_RNDN); if($t1 != $t2) { $ok = 0; warn "$t1 != $t2\n"; } Rmpfr_set_emin($orig_emin); Rmpfr_set_emax($orig_emax); } } if($todo) { TODO: { local $TODO = "Tests don't yet accommodate this inferior -Duselongdouble implementation"; ok($ok == 1, 'test 7'); }; } else { ok($ok == 1, 'test 7'); } $ok = 1; my @correct = qw(0.01 0.14 9223372036854775808.0 628468547668600000.0 4501259036604000000.0 14112528.95572 9.047014579199e-57 91630634264070293.0 25922126328248069.0 4e-4951 -4e-4951 1.4142135623730950488 1e-4950 1.7320508075688772936 2.385059e-335 -2.385059e-335 1e-09 -737324399113800000.0 6.3433232978e-322 4e-4951 3.1312055444e-4941 1.4142135623730950488 9.7646e-4941 7.2864089318e-4941); for(my $i = 0; $i < @in; $i++) { my $t = nvtoa($in[$i]); if($t ne $correct[$i]) { unless($in[$i] == 0 && $correct[$i] eq '-0.0' && $] < 5.01) { $ok = 0; warn "$t ne $correct[$i]\n"; } else { warn "Ignoring that this perl doesn't accommodate signed zero\n"; } } } if($todo) { TODO: { local $TODO = "Tests don't yet accommodate this inferior -Duselongdouble implementation"; ok($ok == 1, 'test 8'); }; } else { ok($ok == 1, 'test 8'); } $ok = 1; } ############################################### ################## 113 BIT #################### elsif($Math::MPFR::NV_properties{bits} == 113) { cmp_ok( nvtoa(sqrt(2.0)), '==', sqrt(2.0), 'nvtoa(sqrt 2) == sqrt 2' ); cmp_ok( nvtoa($zero), 'eq', '0.0', 'nvtoa(0) eq 0.0' ); cmp_ok( nvtoa($nzero), 'eq', '-0.0', 'nvtoa(-0) eq -0.0' ); cmp_ok( nvtoa($inf), 'eq', 'Inf', 'nvtoa(Inf) eq Inf'); cmp_ok( nvtoa($ninf), 'eq', '-Inf', 'nvtoa(-Inf) eq -Inf'); cmp_ok( nvtoa($nan), 'eq', 'NaN', 'nvtoa(NaN) eq NaN'); my $t1 = Rmpfr_init2($Math::MPFR::NV_properties{bits}); my $t2 = Rmpfr_init2($Math::MPFR::NV_properties{bits}); my $orig_emin = Rmpfr_get_emin(); my $orig_emax = Rmpfr_get_emax(); push @in, 2 ** $Math::MPFR::NV_properties{min_pow}, 2 ** ($Math::MPFR::NV_properties{min_pow} + 3) + 2 ** ($Math::MPFR::NV_properties{min_pow} + 13) + 2 ** ($Math::MPFR::NV_properties{min_pow} + 33); for(@in) { if(abs($_) >= $Math::MPFR::NV_properties{normal_min}) { Rmpfr_strtofr($t1, nvtoa($_), 10, MPFR_RNDN); Rmpfr_set_NV($t2, $_, MPFR_RNDN); if($t1 != $t2) { $ok = 0; warn "$t1 != $t2\n"; } } else { # We need to subnormalize the mpfr objects. my $s = nvtoa($_); Rmpfr_set_emin($Math::MPFR::NV_properties{emin}); #(-16493); Rmpfr_set_emax($Math::MPFR::NV_properties{emax}); #(16384); my $inex = Rmpfr_strtofr($t1, $s, 10, MPFR_RNDN); Rmpfr_subnormalize($t1, $inex, MPFR_RNDN); $inex = Rmpfr_set_NV($t2, $_, MPFR_RNDN); Rmpfr_subnormalize($t2, $inex, MPFR_RNDN); if($t1 != $t2) { $ok = 0; warn "$t1 != $t2\n"; } Rmpfr_set_emin($orig_emin); Rmpfr_set_emax($orig_emax); } } ok($ok == 1, 'test 7'); $ok = 1; # __float128 builds of perl will evaluate sqrt(2.0) to be 1.4142135623730950488016887242096982, # which is wrong by 1 ULP. Here we use the correct value of 1.414213562373095048801688724209698, # as determined by mpfr. # Such miscalculations seem to be quite common with gcc's __float128 arithmetic, though # strings are always assigned accurately (afaik). my @correct = qw(0.01 0.13999999999999999999999999999999999 5192296858534827628530496329220096.0 628468547668600000.0 4501259036604000000.0 14112528.95572 9.047014579199e-57 91630634264070293.0 25922126328248069.0 6e-4966 -6e-4966 1.414213562373095048801688724209698 2e-4965 1.7320508075688772935274463415058723 2.385059e-335 -2.385059e-335 1e-09 -737324399113800000.0 6.3433232978e-322 6e-4966 5.5621383844e-4956); for(my $i = 0; $i < @in; $i++) { my $t = nvtoa($in[$i]); if($t ne $correct[$i]) { $ok = 0; warn "$t ne $correct[$i]\n"; } } ok($ok == 1, 'test 8'); $ok = 1; } ############################################### ################## 2098 BIT ################### elsif($Math::MPFR::NV_properties{bits} == 2098) { cmp_ok( nvtoa(sqrt(2.0)), '==', sqrt(2.0), 'nvtoa(sqrt 2) == sqrt 2' ); cmp_ok( nvtoa($zero), 'eq', '0.0', 'nvtoa(0) eq 0.0' ); SKIP: { skip "Ignoring that this perl doesn't accommodate signed zero", 1 if (nvtoa($nzero) ne '-0.0' && $nzero == 0 && $] < 5.01); cmp_ok( nvtoa($nzero), 'eq', '-0.0', 'nvtoa(-0) eq -0.0' ); }; cmp_ok( nvtoa($inf), 'eq', 'Inf', 'nvtoa(Inf) eq Inf'); cmp_ok( nvtoa($ninf), 'eq', '-Inf', 'nvtoa(-Inf) eq -Inf'); cmp_ok( nvtoa($nan), 'eq', 'NaN', 'nvtoa(NaN) eq NaN'); my $t1 = Rmpfr_init2($Math::MPFR::NV_properties{bits}); my $t2 = Rmpfr_init2($Math::MPFR::NV_properties{bits}); my $orig_emin = Rmpfr_get_emin(); my $orig_emax = Rmpfr_get_emax(); unshift @in, 2 ** 52, 8 + 2 ** - 100, 8 - 2 ** -100; push @in, 2 ** $Math::MPFR::NV_properties{min_pow}, 2 ** ($Math::MPFR::NV_properties{min_pow} + 3) + 2 ** ($Math::MPFR::NV_properties{min_pow} + 13) + 2 ** ($Math::MPFR::NV_properties{min_pow} + 33); for(@in) { if(abs($_) >= $Math::MPFR::NV_properties{normal_min}) { Rmpfr_strtofr($t1, nvtoa($_), 10, MPFR_RNDN); Rmpfr_set_NV($t2, $_, MPFR_RNDN); my $ld1 = Rmpfr_get_NV($t1, MPFR_RNDN); my $ld2 = Rmpfr_get_NV($t2, MPFR_RNDN); if($ld1 != $ld2) { $ok = 0; warn "$_\n", scalar(reverse(unpack "h*", (pack "F<", $ld1))), " ne ", scalar(reverse(unpack "h*", (pack "F<", $ld2))), "\n\n"; } } else { # We need to subnormalize the mpfr objects. my $s = nvtoa($_); Rmpfr_set_emin($Math::MPFR::NV_properties{emin}); #(-16493); Rmpfr_set_emax($Math::MPFR::NV_properties{emin}); #(16384); my $inex = Rmpfr_strtofr($t1, $s, 10, MPFR_RNDN); Rmpfr_subnormalize($t1, $inex, MPFR_RNDN); $inex = Rmpfr_set_NV($t2, $_, MPFR_RNDN); Rmpfr_subnormalize($t2, $inex, MPFR_RNDN); if($t1 != $t2) { $ok = 0; warn "$t1 != $t2\n"; } Rmpfr_set_emin($orig_emin); Rmpfr_set_emax($orig_emax); } } ok($ok == 1, 'test 7'); $ok = 1; my @correct = ('4503599627370496.0', '8.0000000000000000000000000000007888609052210118', '7.9999999999999999999999999999992111390947789882', '0.00999999999999999999999999999999996', '0.14', 'Inf', '628468547668600000.0', '4501259036604000000.0', '14112528.95572', '9.047014579199e-57', '91630634264070293.0', '25922126328248069.0', '5e-324', '-5e-324', '1.4142135623730950488016887242097', '1.5e-323', '1.73205080756887729352744634150586', '0.0', '-0.0', '1e-09', '-737324399113800000.0', '6.3e-322', '5e-324', '4.2439956333e-314'); for(my $i = 0; $i < @in; $i++) { my $t = nvtoa($in[$i]); if($t ne $correct[$i]) { $ok = 0; warn "$t ne $correct[$i]\n"; } } ok($ok == 1, 'test 8'); $ok = 1; } else { plan skip_all => 'Unknown nvtype'; } } ############################################### ############## NONE OF THE ABOVE ############## __END__ for(@in) { my $for_python = sprintf("%.${p}e", $_); my $py = `python3 -c \"print($for_python)\"`; chomp $py; push @py3, $py; } print join "', ", @py3; Math-MPFR-4.38/t/nvtoa2.t0000755060175106010010000001240214765756127013547 0ustar OwnerNone# Additional nvtoa() testing. use strict; use warnings; use Math::MPFR qw(:mpfr); use Config; use Test::More; # We'll check a list of 10000 randomly derived NV values. # The mantissa of each NV will be between 1 and $MAX_DIG decimal digits. # Neither the first nor last mantissa digit will be zero # The exponent will be in the range -$MAX_POW..$MAX_POW # Exponents will alternate between -ve and +ve # Every third mantissa will be negative. # We call dragon_test() to check that nvtoa() has returned the correct value. # # In this script we test the correctness of nvtoa() differently, depending upon # whether perl is prone to mis-assignment of values, or not. # # For perls whose NV is the "Double-Double" long double or for perls running on Cygwin, perl # is prone to mis-assignment and $reliable is set to false, irrespective of the value of $]. # # All perl's whose nvtype is __float128 (except those running on Cygwin) assign correctly and # $reliable is set to true for them, irrespective of the value of $] ... except that on MS # Windows and (apparently) at least one instance of i686 linux (see # http://www.cpantesters.org/cpan/report/11de736c-0cd6-11ec-aef5-c3a30c210c3d), assignment of # subnormal values (within a specific range) might be unreliable. (This script checks to see # if these subnormal values will assign correctly, and then responds appropriately.) # # For all other builds of perl, $reliable will be set to true if and only if: # 1) $] >= 5.03 && $Config{nvtype} eq 'double' && defined($Config{d_strtod}) # OR # 2) $] >= 5.03 && $Config{nvtype} eq 'long double' && defined($Config{d_strtold}) # # $reliable is set to false for all remaining perls that have not been specified above. # # If $reliable is true, we simply assign the values using perl - otherwise we assign them # using Math::MPFR's atonv() function, which is also deemed reliable. unless(Math::MPFR::MPFR_3_1_6_OR_LATER) { plan skip_all => "nvtoa2.t utilizes Math::MPFR functionality that requires mpfr-3.1.6\n"; exit 0; } my $MAX_DIG; my $MAX_POW; my $ok = 1; if ($Math::MPFR::NV_properties{bits} == 53) { $MAX_DIG = 17; $MAX_POW = 350; } elsif($Math::MPFR::NV_properties{bits} == 64) { $MAX_DIG = 21; $MAX_POW = 5000; } elsif($Math::MPFR::NV_properties{bits} == 113) { $MAX_DIG = 36; $MAX_POW = 5000; } else { $MAX_DIG = 34; # NV is Double-Double $MAX_POW = 350; } my $reliable = 0; my $subnormal_issue = 0; # See comments at the beginning of this script if($Config{nvtype} eq '__float128') { # See https://gcc.gnu.org/bugzilla/show_bug.cgi?id=94756 for details # regarding this issue with subnormals. # This is NOT an mpfr library issue - it's a perl issue (or, more # accurately, a bug in the toolset that has built perl). my $prec = Rmpfr_get_default_prec(); # The subnormal NV 1e-4941 is an 81-bit value Rmpfr_set_default_prec(81); my $t1 = Math::MPFR->new('1e-4941'); # $t1 will be assigned correct value Rmpfr_set_default_prec(113); my $t2 = Math::MPFR->new( 1e-4941 ); # $t2 will be assigned correct value # unless the subnormal issue is present # in this build of perl. $subnormal_issue = 1 if $t1 != $t2; Rmpfr_set_default_prec($prec); } if( $^O !~/cygwin/i && ( $Config{nvtype} eq '__float128' || ($] > 5.029005 && $Config{nvtype} eq 'double' && defined($Config{d_strtod})) || ($] > 5.029005 && $Config{nvtype} eq 'long double' && defined($Config{d_strtold}) && $MAX_DIG != 34) ) ) { if( $subnormal_issue ) { warn "\n Using perl for string to NV assignment ... unless the NV's\n", " absolute value is in the range:\n", " 0x1p-16414 .. 0x1.ffffffffffffffffffffp-16414\n", " or\n", " 0x1.00000318p-16446 .. 0x1.ffffffffffffp-16446\n", " See https://gcc.gnu.org/bugzilla/show_bug.cgi?id=94756\n"; } else { warn "Using perl for string to NV assignment. (Perl deemed reliable)\n"; } $reliable = 1; } else { warn "Avoiding perl for string to NV assignment. (Perl is UNRELIABLE)\n"; } my $count = 10000; while(1) { $count--; last if $count < 0; my $mantissa_sign = $count % 3 ? '' : '-'; my $mantissa = 1 + int(rand(9)); my $exponent = int(rand($MAX_POW)); # Skew the exponent towards the more usual values that are typically used. # nvtoa() calculations are relatively expensive on long double and __float128 # builds for NVs whose exponents are a long way from zero. $exponent = int(rand(10)) if ($exponent > 50 && $exponent < $MAX_POW / 1.5); $exponent = '-' . $exponent if ($count & 1); my $len = int(rand($MAX_DIG)); while(length($mantissa) < $len) { $mantissa .= int(rand(10)) } $mantissa .= 1 +int(rand(9)) if $len; my $str = $mantissa_sign . $mantissa . 'e' . $exponent; ok(dragon_test(atonv($str)) == 15, "$str passes dragon test (NV)"); } done_testing(); __END__ Math-MPFR-4.38/t/nvtoa3.t0000755060175106010010000000404714765756127013556 0ustar OwnerNone# Add various tests here as they come to mind. use strict; use warnings; use Math::MPFR qw(:mpfr); use Config; use Test::More; if($] < 5.03 && $Config{nvtype} ne '__float128') { plan skip_all => "Perl's string to NV assignment is unreliable\n"; } else { plan tests => 11; my $m = 9.007199254740991e15; # 2 ** 53 cmp_ok(nvtoa(2 ** 105), '==', 2 ** 105, "nvtoa(2 ** 105) == 2 ** 105"); cmp_ok(nvtoa(2 ** 106), '==', 2 ** 106, "nvtoa(2 ** 106) == 2 ** 106"); cmp_ok(nvtoa($m * (2 ** 53)), '==', $m * (2 ** 53), "nvtoa($m*(2**53)) == $m*(2**53)"); cmp_ok(nvtoa($m * (2 ** 54)), '==', $m * (2 ** 54), "nvtoa($m*(2**54)) == $m*(2**54)"); cmp_ok(nvtoa(2 ** 120), '==', 2 ** 120, "nvtoa(2 ** 120) == 2 ** 120"); cmp_ok(nvtoa(29 * (2 ** 1001)), '==', 29 * (2 ** 1001), "nvtoa(29 * (2 ** 1001)) == 29 * (2 ** 1001)"); cmp_ok(nvtoa(1.7976931348623157e+308), '==', 1.7976931348623157e+308, "nvtoa(DBL_MAX) == DBL_MAX"); cmp_ok(nvtoa(123456789012345.0), '==', 123456789012345.0, "nvtoa(123456789012345.0) == 123456789012345.0"); cmp_ok(nvtoa(1.0 / 10.0), 'eq', '0.1', "nvtoa(1.0 / 10.0) eq '0.1'"); if($Config{nvsize} > 8 && $Config{nvtype} eq 'long double' && Math::MPFR::_required_ldbl_mant_dig() != 113) { cmp_ok(nvtoa(1.4 / 10), 'eq', '0.14', "nvtoa(1.4 / 10) eq '0.14'" ); if(Math::MPFR::_required_ldbl_mant_dig() == 2098) { # DoubleDouble cmp_ok(nvtoa(1.4 / 100), 'ne', '0.014', "nvtoa(1.4 / 10) ne '0.014'"); # 0.014000...0013 } else { # 64-bit precision NV cmp_ok(nvtoa(1.4 / 100), 'eq', '0.014', "nvtoa(1.4 / 10) eq '0.014'"); } } else { cmp_ok(nvtoa(1.4 / 10), 'ne', '0.14', "nvtoa(1.4 / 10) ne '0.14'" ); # 0.13999...99 if($Config{nvtype} eq '__float128' || ($Config{nvsize} > 8 && $Config{nvtype} eq 'long double')) { # 113-bit precision NV cmp_ok(nvtoa(1.4 / 100), 'eq', '0.014', "nvtoa(1.4 / 100) eq '0.014'"); } else { # 53-bit precision NV cmp_ok(nvtoa(1.4 / 100), 'ne', '0.014', "nvtoa(1.4 / 100) ne '0.014'"); # 0.013999...99 } } } Math-MPFR-4.38/t/nvtoa_dd.t0000755060175106010010000002054314765756127014141 0ustar OwnerNone# This test script was written for the DoubleDouble NV type. # But I figure we might as well run it, no matter what NV we have. # However, there can be an issue with the SvNOK flag on old perls, # so we avoid anything older than perl-5.12. BEGIN { if($] < 5.012 ) { print "1..1\n"; print "ok 1\n"; warn "Skipping tests because perl-$] is buggy\n"; exit 0; } }; use strict; use warnings; use Math::MPFR qw(:mpfr); use Test::More; unless(Math::MPFR::MPFR_3_1_6_OR_LATER) { plan skip_all => "nvtoa.t utilizes Math::MPFR functionality that requires mpfr-3.1.6\n"; exit 0; } for(-1075..1024) { my $nv = 2 ** $_; cmp_ok(dragon_test($nv), '==', 15, "2 ** $_"); # nvtoa($nv) cmp_ok(dragon_test(-$nv), '==', 15, "-(2 ** $_)"); # nvtoa(-$nv) } my @pows = (50, 100, 150, 200, 250, 300, 350, 400, 450, 500, 550, 600, 650, 700, 750, 800, 850, 900, 950, 1000); die "wrong sized array" unless @pows == 20; my $ret = (2** -1020) + (2 ** -1021); cmp_ok(dragon_test($ret), '==', 15, "(2** -1020) + (2 ** -1021)"); $ret = (2** -1021) + (2 ** -1064); cmp_ok(dragon_test($ret), '==', 15, "(2** -1021) + (2 ** -1064)"); $ret = (2** -1020) - (2 ** -1021); cmp_ok(dragon_test($ret), '==', 15, "(2** -1020) - (2 ** -1021)"); $ret = (2** -1021) - (2 ** -1064); cmp_ok(dragon_test($ret), '==', 15, "(2** -1021) - (2 ** -1064)"); # Failed test '[2 11] / [12 9] repro ok' # at t/sparse.t line 64. # got: [3.054936363499605e-151 4.9406564584124654e-324] # expected: [3.054936363499605e-151 0.0] my @in0 = qw(2 11); my @in1 = qw(12 9); $ret = my_assign(\@in0, \@in1, '/'); cmp_ok(dragon_test($ret), '==', 15, "@in0 / @in1"); @in0 = qw(2 -17); @in1 = qw(9 -17); $ret = my_assign(\@in0, \@in1, '/'); cmp_ok(dragon_test($ret), '==', 15, "@in0 / @in1"); # Failed test '[3 3] - [3 10] repro ok' # at t/sparse.t line 69. # got: [6.223015277861142e-61 -2.713328551617527e-166] # expected: [6.223015277861142e-61 -2.7133285516175262e-166] @in0 = qw(3 3); @in1 = qw(3 10); $ret = my_assign(\@in0, \@in1, '-'); cmp_ok(dragon_test($ret), '==', 15, "@in0 - @in1"); # Failed test '[13 -1] * [1 -7] repro ok' # at t/sparse.t line 54. # got: [6.668014432879854e+240 -2.0370359763344865e+90] # expected: [6.668014432879854e+240 -2.037035976334486e+90] @in0 = qw(13 -1); @in1 = qw(1 -7); $ret = my_assign(\@in0, \@in1, '*'); cmp_ok(dragon_test($ret), '==', 15, "@in0 * @in1"); # Failed test '[14 1] - [11 4] repro ok' # at t/sparse.t line 69. # got: [5.922386521532856e+225 -4.1495155688809925e+180] # expected: [5.922386521532856e+225 -4.149515568880993e+180] @in0 = qw(14 1); @in1 = qw(11 4); $ret = my_assign(\@in0, \@in1, '-'); cmp_ok(dragon_test($ret), '==', 15, "@in0 - @in1"); # Failed test '[17 -16] + [11 -2] repro ok' # at t/sparse.t line 59. # got: [8.452712498170644e+270 4.1495155688809925e+180] # expected: [8.452712498170644e+270 4.149515568880993e+180] @in0 = qw(17 -16); @in1 = qw(11 -2); $ret = my_assign(\@in0, \@in1, '+'); cmp_ok(dragon_test($ret), '==', 15, "@in0 + @in1"); # Failed test '[1 8] * [0 11] repro ok' # at t/sparse.t line 54. # got: [1.42724769270596e+45 3.872591914849318e-121] # expected: [1.42724769270596e+45 3.8725919148493183e-121] @in0 = qw(1 8); @in1 = qw(0 11); $ret = my_assign(\@in0, \@in1, '*'); cmp_ok(dragon_test($ret), '==', 15, "@in0 * @in1"); # Failed test '[8 -18] / [13 -1] repro ok' # at t/sparse.t line 64. # got: [5.527148e-76 -1.9501547226722595e-92] # expected: [5.527147875260445e-76 8.289046058458095e-317] @in0 = qw(8 -18); @in1 = qw(13 -1); $ret = my_assign(\@in0, \@in1, '/'); cmp_ok(dragon_test($ret), '==', 15, "@in0 / @in1"); # [3 13] / [14 9] @in0 = qw(3 13); @in1 = qw(14 9); $ret = my_assign(\@in0, \@in1, '/'); cmp_ok(dragon_test($ret), '==', 15, "@in0 / @in1"); # [13 -8] + [12 -6] @in0 = qw(13 -8); @in1 = qw(12 -6); $ret = my_assign(\@in0, \@in1, '+'); cmp_ok(dragon_test($ret), '==', 15, "@in0 + @in1"); # 0.66029111258694e-111 fails chop test. $ret = atonv('0.66029111258694e-111'); cmp_ok(dragon_test($ret), '==', 15, "0.66029111258694e-111"); # 0.876771194648327e219 fails chop test $ret = atonv('0.876771194648327e219'); cmp_ok(dragon_test($ret), '==', 15, "0.876771194648327e219"); # Failed test 'chop test ok for [11 -14]' # at t/sparse.t line 90. # '[4.149515568880993e+180 -1.688508503057271e-226]' # < # '[4.149515568880993e+180 -1.688508503057271e-226]' @in0 = qw(11 -14); $ret = (2 ** $pows[11]) - (2 ** -$pows[14]); cmp_ok(dragon_test($ret), '==', 15, "(2 ** $pows[11]) - (2 ** -$pows[14])"); $ret = atonv(2 ** 550) + nvtoa(2 ** -300); cmp_ok(dragon_test($ret), '==', 15, "(2 ** 550) + (2 ** -300)"); $ret = atonv(2 ** 1000); cmp_ok(dragon_test($ret), '==', 15, "(2 ** 1000)"); $ret = atonv(2 ** -550) + nvtoa(2 ** -552) + nvtoa(2 ** -600); cmp_ok(dragon_test($ret), '==', 15, "(2 ** -550) + (2 ** -552)"); $ret = atonv(2 ** 550) - nvtoa(2 ** -300); cmp_ok(dragon_test($ret), '==', 15, "(2 ** 550) - (2 ** -300)"); $ret = atonv(2 ** -550); cmp_ok(dragon_test($ret), '==', 15, "(2 ** -550)"); # [0x1p+950 -0x1p+800] $ret = atonv(2 ** 950) - nvtoa(2 ** 800); cmp_ok(dragon_test($ret), '==', 15, "(2 ** 950) - (2 ** 800)"); # [0x1p+900 -0x1p+750] $ret = atonv(2 ** 900) - nvtoa(2 ** 750); cmp_ok(dragon_test($ret), '==', 15, "(2**900) - (2** 50)"); #[0x1p-550 -0x1p-1050] $ret = atonv(2 ** -550) - nvtoa(2 ** -1050); cmp_ok(dragon_test($ret), '==', 15, "(2**-550) - (2**-1050)"); #[-0x1p+950 0x1p+800] $ret = atonv(-(2 ** 950)) + nvtoa(2 ** 800); cmp_ok(dragon_test($ret), '==', 15, "-(2**950) + (2**800)"); $ret = atonv(2 ** 700) + nvtoa(2 ** 650) - nvtoa(2 **-350); cmp_ok(dragon_test($ret), '==', 15, "(2**700) + (2**650) - (2**-350)"); # [-0x1.ffffffffffff8p+849 0x1p-350] $ret = atonv(2 ** 800) - nvtoa(2 ** 850) - nvtoa(2 **-350); cmp_ok(dragon_test($ret), '==', 15, "(2**800) - (2**850) - (2**-350)"); #[0x1p+200 0x1p-549] $ret = atonv(2 ** 200) + nvtoa(2 ** -549); cmp_ok(dragon_test($ret), '==', 15, "(2 ** 950) - (2 ** 800)"); my(@big, @little); my @p = @pows; for(0..19) { push(@big, 2 ** $p[$_]); push(@little, 2 ** -($p[$_])); } for(0..19) { my $xb = int(rand(20)); my $xl = int(rand(20)); my $yb = int(rand(20)); my $yl = int(rand(20)); my $ub = int(rand(20)); my $ul = int(rand(20)); my $vb = int(rand(20)); my $vl = int(rand(20)); my $x = atonv( $big[$xb] ) + atonv( $little[$xl] ); $x += ( atonv($big[$xb] ) / 2 ** (int(rand(30))) ) + ( atonv($little[$xl]) * 2 ** (int(rand(30))) ); my $y = atonv( $big[$yb] ) + atonv( $little[$yl] ); my $u = atonv( $big[$ub] ) - atonv( $little[$ul] ); $u += ( atonv($big[$xb] ) / 2 ** (int(rand(30))) ) - ( atonv($little[$xl]) * 2 ** (int(rand(30))) ); my $v = atonv( $big[$vb] ) - atonv( $little[$vl] ); sparse_test($x, $y); sparse_test($u, $v); sparse_test($x, $v); sparse_test($u, $y); sparse_test($x, $u); sparse_test($y, $v); } ############################################################## ############################################################## ############################################################## done_testing(); sub my_assign { my @p = (50, 100, 150, 200, 250, 300, 350, 400, 450, 500, 550, 600, 650, 700, 750, 800, 850, 900, 950, 1000); die "wrong sized array" unless @p == 20; my($xb, $xl) = @{$_[0]}; my($yb, $yl) = @{$_[1]}; my $x = $xl =~ /\-/ ? (2 **$p[$xb]) - (2** -( $p[-$xl]) ) : (2 **$p[$xb]) + (2** -( $p[$xl ]) ); my $y = $yl =~ /\-/ ? (2 **$p[$yb]) - (2** -( $p[-$yl]) ) : (2 **$p[$yb]) + (2** -( $p[$yl ]) ); my $op = $_[2]; return $x * $y if($op eq '*') ; return $x + $y if($op eq '+') ; return $x / $y if($op eq '/') ; return $x - $y if($op eq '-') ; die "Error in my_assign();" } sub sparse_test { my ($op1, $op2) = (shift, shift); cmp_ok(dragon_test($op1), '==', 15, "X" . unpack("H*", pack("F>", $op1))); cmp_ok(dragon_test($op2), '==', 15, "X" . unpack("H*", pack("F>", $op2))); my $mul = $op1 * $op2; cmp_ok(dragon_test($mul), '==', 15, "X" . unpack("H*", pack("F>", $mul))); my $add = $op1 + $op2; cmp_ok(dragon_test($add), '==', 15, "X" . unpack("H*", pack("F>", $add))); my $div = $op1 / $op2; cmp_ok(dragon_test($div), '==', 15, "X" . unpack("H*", pack("F>", $div))); my $sub = $op1 - $op2; cmp_ok(dragon_test($sub), '==', 15, "X" . unpack("H*", pack("F>", $sub))); } Math-MPFR-4.38/t/nvtoa_subnormal.t0000755060175106010010000000611114765756127015547 0ustar OwnerNone # More checks on nvtoa's handling of subnormal values use strict; use warnings; use Math::MPFR qw(:mpfr); use Config; use Test::More; if(196869 < MPFR_VERSION) { my($bits, $pow, $str); if($Config{nvsize} == 8) { # nvtype is either double or 8-byte long double $bits = 53; $pow = -1074; } elsif($Config{nvtype} eq '__float128') { $bits = 113; $pow = -16494; } else { $bits = Math::MPFR::_required_ldbl_mant_dig(); if($bits == 2098) { # nvtype is IBM DoubleDouble $bits = 53; $pow = -1074; } elsif($bits == 64 ) { $pow = -16445 } elsif($bits == 113) { $pow = -16494 } else { die "Unknown nvtype" } } # Note that 2 ** $pow is the smallest positive (non-zero) value # that can be represented by the particular nvtype. if(2 ** $pow != 0) { $pow--; $bits++; my($val, $last_val) = (0, 0); for my $b(1 .. $bits) { next unless $b % 10; # Set every 10th to zero - just for some additional complexity $val = $last_val + (2 ** ($b + $pow)); $str = nvtoa($val); cmp_ok(atonv($str), '==', $val, "$b: atonv($str) == $val"); cmp_ok(atonv($str), '>', $last_val, "$b: atonv($str) > $last_val"); cmp_ok($str, 'eq', doubletoa($val), "$b: $str eq doubletoa($val)") if $Config{nvsize} == 8; other_checks($str, $val, $b); $last_val = $val; } } else { warn "\nSkipping all tests - this perl thinks that 2 ** $pow == 0\n"; ok(1, "This perl is garbage"); # provide a test } done_testing(); } else { eval {atonv('1.3');}; like( $@, qr/^The atonv function requires mpfr\-3\.1\.6 or later/, '$@ reports that atonv is unavailable'); done_testing(); } sub other_checks { # check that $str is the shortest accurate representation of $val my($str, $val, $b) = (shift, shift, shift); my($newstr1, $newstr2, $skip) = ('', '', 0); # Replace the final digit of the significand with '0' and check # that the resultant value (in $newstr1) is less than $val. # Also, having removed the final digit of the original significand, # increment that value by 1 ULP, and check the resultant value (in # $newstr2) is greater than $val. # For this exercise all of the strings are of the # form significand . "e" . exponent. my @s = split /e/i, $str; $newstr1 = $s[0]; chop $newstr1; $newstr2 = $newstr1; $skip = 1 unless length($newstr2); $newstr1 .= '0' . 'e' . $s[1]; $newstr2 = plus_one_ulp($newstr2); $newstr2 .= 'e' . $s[1]; cmp_ok(atonv($newstr1), '<', $val, "$b: atonv($newstr1) < $val"); cmp_ok(atonv($newstr2), '>', $val, "$b: atonv($newstr2) > $val") unless $skip; } sub plus_one_ulp { my($ret, $pos) = (shift, 0); my $len = length($ret); for(1 .. $len) { if(substr($ret, -$_, 1) eq '.') { $pos = -$_; substr($ret, $pos, 1, ''); last; } } $ret++; # Don't insert a '.' if the string that was given to this sub: # a) did not include a '.'; # OR # b) terminated with a '.'. substr($ret, length($ret) + $pos + 1, 0, '.') if $pos < -1; return $ret; } Math-MPFR-4.38/t/NV_overloading.t0000755060175106010010000004275014765756127015263 0ustar OwnerNone# Mainly want to test that: # inf and nan are handled correctly when passed to overloaded subs (including when they're passed as strings) # valid floating point NV's are handled correctly when passed to overloaded subs # invalid floating point values are a fatal error when passed as a string use strict; use warnings; use Math::MPFR qw(:mpfr); print "1..119\n"; my $inf = 999 ** (999 ** 999); my $ninf = $inf * -1; my $nan = $inf / $inf; my $strinf = 999 ** (999 ** 999); my $strninf = $strinf * -1; my $strnan = $strinf / $strinf; my ($ret, $x); $ret = Math::MPFR->new(10) * $inf; if($ret > 0 && Rmpfr_inf_p($ret)) {print "ok 1\n"} else { warn "\n Expected '\@Inf\@'\n Got $ret\n"; print "not ok 1\n"; } $ret = Math::MPFR->new(10) * "$strinf"; if($ret > 0 && Rmpfr_inf_p($ret)) {print "ok 2\n"} else { warn "\n Expected '\@Inf\@'\n Got $ret\n"; print "not ok 2\n"; } $ret = Math::MPFR->new(10) * $nan; if(Rmpfr_nan_p($ret)) {print "ok 3\n"} else { warn "\n Expected '\@NaN\@'\n Got $ret\n"; print "not ok 3\n"; } $ret = Math::MPFR->new(10) * "$strnan"; if(Rmpfr_nan_p($ret)) {print "ok 4\n"} else { warn "\n Expected '\@NaN\@'\n Got $ret\n"; print "not ok 4\n"; } $ret = Math::MPFR->new(10) * "61.2"; if($ret == 612) {print "ok 5\n"} else { warn "\n Expected '612'\n Got $ret\n"; print "not ok 5\n"; } if(Math::MPFR->new(10) * 61.2 == 612) { print "ok 6\n"; } else { warn "\n Expected:\n 612\n Got: ", Math::MPFR->new(10) * 61.2, "\n"; print "not ok 6\n"; } $ret = Math::MPFR->new(10) + $inf; if($ret > 0 && Rmpfr_inf_p($ret)) {print "ok 7\n"} else { warn "\n Expected '\@Inf\@'\n Got $ret\n"; print "not ok 7\n"; } $ret = Math::MPFR->new(10) + "$strinf"; if($ret > 0 && Rmpfr_inf_p($ret)) {print "ok 8\n"} else { warn "\n Expected '\@Inf\@'\n Got $ret\n"; print "not ok 8\n"; } $ret = Math::MPFR->new(10) + $nan; if(Rmpfr_nan_p($ret)) {print "ok 9\n"} else { warn "\n Expected '\@NaN\@'\n Got $ret\n"; print "not ok 9\n"; } $ret = Math::MPFR->new(10) + "$strnan"; if(Rmpfr_nan_p($ret)) {print "ok 10\n"} else { warn "\n Expected '\@NaN\@'\n Got $ret\n"; print "not ok 10\n"; } eval{$ret = Math::MPFR->new(10) + "61.2"}; if($ret > 71.19999999 && $ret < 71.20000001) {print "ok 11\n"} else { warn "\n Expected approx 71.2\n Got ", Math::MPFR->new(10) + "61.2", "\n"; print "not ok 11\n"; } if(Math::MPFR->new(10) + 61.2 == '71.2') { print "ok 12\n"; } else { warn "\n Expected: 71.2\n Got: ", Math::MPFR->new(10) + 61.2, "\n"; print "not ok 12\n"; } $ret = Math::MPFR->new(10) / $inf; if($ret == 0 && !Rmpfr_signbit($ret)) {print "ok 13\n"} else { warn "\n Expected 0\n Got $ret\n"; print "not ok 13\n"; } $ret = Math::MPFR->new(10) / "$strinf"; if($ret == 0 && !Rmpfr_signbit($ret)) {print "ok 14\n"} else { warn "\n Expected 0\n Got $ret\n"; print "not ok 14\n"; } $ret = Math::MPFR->new(10) / $nan; if(Rmpfr_nan_p($ret)) {print "ok 15\n"} else { warn "\n Expected '\@NaN\@'\n Got $ret\n"; print "not ok 15\n"; } $ret = Math::MPFR->new(10) / "$strnan"; if(Rmpfr_nan_p($ret)) {print "ok 16\n"} else { warn "\n Expected '\@NaN\@'\n Got $ret\n"; print "not ok 16\n"; } $ret = Math::MPFR->new(10) / "61.2"; if($ret > 0.1633986928104575 && $ret < 0.16339869281045754) {print "ok 17\n"} else { warn "\n 17: Got $ret\n"; print "not ok 17\n"; } if(Math::MPFR->new(10) / 61.2 > '0.1633986928104575' && Math::MPFR->new(10) / 61.2 < '0.16339869281045754') { print "ok 18\n"; } else { warn "\n 18: Got: ", Math::MPFR->new(10) / 61.2, "\n"; print "not ok 18\n"; } $ret = Math::MPFR->new(10) - $inf; if($ret < 0 && Rmpfr_inf_p($ret)) {print "ok 19\n"} else { warn "\n Expected '\@Inf\@'\n Got $ret\n"; print "not ok 19\n"; } $ret = Math::MPFR->new(10) - "$strinf"; if($ret < 0 && Rmpfr_inf_p($ret)) {print "ok 20\n"} else { warn "\n Expected '\@Inf\@'\n Got $ret\n"; print "not ok 20\n"; } $ret = Math::MPFR->new(10) - $nan; if(Rmpfr_nan_p($ret)) {print "ok 21\n"} else { warn "\n Expected '\@NaN\@'\n Got $ret\n"; print "not ok 21\n"; } $ret = Math::MPFR->new(10) - "$strnan"; if(Rmpfr_nan_p($ret)) {print "ok 22\n"} else { warn "\n Expected '\@NaN\@'\n Got $ret\n"; print "not ok 22\n"; } $ret = Math::MPFR->new(10) - "61.2"; if($ret > -51.20000001 && $ret < -51.19999999) {print "ok 23\n"} else { warn "\n 23: Got $ret\n"; print "not ok 23\n"; } if(Math::MPFR->new(10) - 61.2 == '-51.2') { print "ok 24\n"; } else { warn "\n 24: Got $ret\n"; print "not ok 24\n"; } $ret = Math::MPFR->new(10); $ret *= $inf; if($ret > 0 && Rmpfr_inf_p($ret)) {print "ok 25\n"} else { warn "\n Expected '\@Inf\@'\n Got $ret\n"; print "not ok 25\n"; } $ret *= "$strinf"; if($ret > 0 && Rmpfr_inf_p($ret)) {print "ok 26\n"} else { warn "\n Expected '\@Inf\@'\n Got $ret\n"; print "not ok 26\n"; } $ret *= $nan; if(Rmpfr_nan_p($ret)) {print "ok 27\n"} else { warn "\n Expected '\@NaN\@'\n Got $ret\n"; print "not ok 27\n"; } $ret *= "$strnan"; if(Rmpfr_nan_p($ret)) {print "ok 28\n"} else { warn "\n Expected '\@NaN\@'\n Got $ret\n"; print "not ok 28\n"; } Rmpfr_set_ui($ret, 10, MPFR_RNDN); $ret *= "61.2"; if($ret == 612) {print "ok 29\n"} else { warn "\n 29: Got $ret\n"; print "not ok 29\n"; } Rmpfr_set_ui($ret, 10, MPFR_RNDN); $ret *= 61.2; if($ret == '612') {print "ok 30\n"} else { warn "\n Expected:\n 612\nGot: $ret\n"; print "not ok 30\n"; } $ret += $inf; if($ret > 0 && Rmpfr_inf_p($ret)) {print "ok 31\n"} else { warn "\n Expected '\@Inf\@'\n Got $ret\n"; print "not ok 31\n"; } $ret += "$strinf"; if($ret > 0 && Rmpfr_inf_p($ret)) {print "ok 32\n"} else { warn "\n Expected '\@Inf\@'\n Got $ret\n"; print "not ok 32\n"; } $ret += $nan; if(Rmpfr_nan_p($ret)) {print "ok 33\n"} else { warn "\n Expected '\@NaN\@'\n Got $ret\n"; print "not ok 33\n"; } $ret += "$strnan"; if(Rmpfr_nan_p($ret)) {print "ok 34\n"} else { warn "\n Expected '\@NaN\@'\n Got $ret\n"; print "not ok 34\n"; } Rmpfr_set_ui($ret, 10, MPFR_RNDN); $ret += "61.2"; if($ret > 71.19999999 && $ret < 71.20000001) {print "ok 35\n"} else { warn "\n Expected approx 71.2\n Got $ret\n"; print "not ok 35\n"; } Rmpfr_set_ui($ret, 10, MPFR_RNDN); $ret += 61.2; if($ret == '71.2') {print "ok 36\n"} else { warn "\n Expected 71.2\n Got $ret\n"; print "not ok 36\n"; } $ret -= $inf; if($ret < 0 && Rmpfr_inf_p($ret)) {print "ok 37\n"} else { warn "\n Expected '\@Inf\@'\n Got $ret\n"; print "not ok 37\n"; } $ret -= "$strinf"; if($ret < 0 && Rmpfr_inf_p($ret)) {print "ok 38\n"} else { warn "\n Expected '\@Inf\@'\n Got $ret\n"; print "not ok 38\n"; } $ret -= $nan; if(Rmpfr_nan_p($ret)) {print "ok 39\n"} else { warn "\n Expected '\@NaN\@'\n Got $ret\n"; print "not ok 39\n"; } $ret -= "$strnan"; if(Rmpfr_nan_p($ret)) {print "ok 40\n"} else { warn "\n Expected '\@NaN\@'\n Got $ret\n"; print "not ok 40\n"; } Rmpfr_set_ui($ret, 10, MPFR_RNDN); $ret -= "61.2"; if($ret > -51.20000001 && $ret < -51.19999999) {print "ok 41\n"} else { warn "\n Expected -51.2\n Got $ret\n"; print "not ok 41\n"; } Rmpfr_set_ui($ret, 10, MPFR_RNDN); $ret -= 61.2; if($ret == '-51.2') {print "ok 42\n"} else { warn "\n Expected: -51.2\n Got: $ret\n"; print "not ok 42\n"; } $ret /= $inf; if(Rmpfr_zero_p($ret) && Rmpfr_signbit($ret)) {print "ok 43\n"} else { warn "\n Expected -0\n Got $ret\n"; print "not ok 43\n"; } eval{$ret /= "$strinf"}; if(Rmpfr_zero_p($ret) && Rmpfr_signbit($ret)) {print "ok 44\n"} else { warn "\n Expected -0\n Got $ret\n"; print "not ok 44\n"; } $ret /= $nan; if(Rmpfr_nan_p($ret)) {print "ok 45\n"} else { warn "\n Expected '\@NaN\@'\n Got $ret\n"; print "not ok 45\n"; } $ret /= "$strnan"; if(Rmpfr_nan_p($ret)) {print "ok 46\n"} else { warn "\n Expected '\@NaN\@'\n Got $ret\n"; print "not ok 46\n"; } Rmpfr_set_ui($ret, 10, MPFR_RNDN); $ret /= "61.2"; if($ret > 0.1633986928104575 && $ret < 0.16339869281045754) {print "ok 47\n"} else { warn "\n 17: Got $ret\n"; print "not ok 47\n"; } Rmpfr_set_ui($ret, 10, MPFR_RNDN); $ret /= 61.2; if($ret > '0.1633986928104575' && $ret < '0.16339869281045754') {print "ok 48\n"} else { warn "\n 17: Got $ret\n"; print "not ok 48\n"; } if(Math::MPFR->new(10) == $inf ) { warn "\n 10 == $inf\n"; print "not ok 49\n"; } else {print "ok 49\n"} if(Math::MPFR->new(10) == $ninf ) { warn "\n 10 == $ninf\n"; print "not ok 50\n"; } else {print "ok 50\n"} if("$strinf" =~ /^inf/i || $^O =~ /MSWin/) { if(Math::MPFR->new(10) == "$strinf") { warn "\n 10 == infinity\n"; print "not ok 51\n"; } else {print "ok 51\n"} } else { $x = (Math::MPFR->new(10) == "$strinf"); if(!$x) {print "ok 51\n"} else { warn "\n 10 == inf\n"; print "not ok 51\n"; } } $x = (Math::MPFR->new(10) == $nan ); if(!$x) {print "ok 52\n"} else { warn "\n 10 == nan\n"; print "not ok 52\n"; } $x = (Math::MPFR->new(10) == "$strnan"); if(!$x) {print "ok 53\n"} else { warn "\n 10 == nan\n"; print "not ok 53\n"; } $x = (Math::MPFR->new(10) == "61.2"); if(!$x) {print "ok 54\n"} else { warn "\n 10 == nan\n"; print "not ok 54\n"; } my $dec = 10.0; if(Math::MPFR->new(10) == $dec) {print "ok 55\n"} else { warn "\n ", Math::MPFR->new(10), " != $dec\n"; print "not ok 55\n"; } if(Math::MPFR->new(10) != $inf ) {print "ok 56\n"} else { warn "\n 10 == $inf\n"; print "not ok 56\n"; } if(Math::MPFR->new(10) != $ninf ) {print "ok 57\n"} else { warn "\n 10 == $ninf\n"; print "not ok 57\n"; } if("$strinf" =~ /^inf/i || $^O =~ /MSWin/) { if(Math::MPFR->new(10) != "$strinf") {print "ok 58\n"} else { warn "\n 10 == infinity\n"; print "not ok 58\n"; } } else { eval{$x = (Math::MPFR->new(10) != "$strinf")}; if($@ =~ /Invalid string supplied to Math::MPFR::overload_not_equiv/) {print "ok 58\n"} else { warn "\n\$\@: $@\n"; print "not ok 58\n"; } } $x = (Math::MPFR->new(10) != $nan ); if($x) {print "ok 59\n"} else { warn "\n 10 == NaN\n"; print "not ok 59\n"; } $x = (Math::MPFR->new(10) != "$strnan"); if($x) {print "ok 60\n"} else { warn "\n 10 == NaN\n"; print "not ok 60\n"; } $x = (Math::MPFR->new(10) != "61.2"); if($x) {print "ok 61\n"} else { warn "\n 10 == 61.2\n"; print "not ok 61\n"; } $dec += 0.9;; if(Math::MPFR->new(10) != $dec) {print "ok 62\n"} else { warn "\n ", Math::MPFR->new(10), " == $dec\n"; print "not ok 62\n"; } if(Math::MPFR->new(10) < $inf ) {print "ok 63\n"} else { warn "\n 10 >= $inf\n"; print "not ok 63\n"; } if(Math::MPFR->new(10) < $ninf ) { warn "\n10 < $ninf\n"; print "not ok 64\n"; } else {print "ok 64\n"} if(Math::MPFR->new(10) < "$strinf") {print "ok 65\n"} else { warn "\n 10 >= $strinf\n"; print "not ok 65\n"; } $x = (Math::MPFR->new(10) < $nan ); if(!$x) {print "ok 66\n"} else { warn "\n 10 < NaN\n"; print "not ok 66\n"; } $x = (Math::MPFR->new(10) < "$strnan"); if(!$x) {print "ok 67\n"} else { warn "\n 10 < NaN\n"; print "not ok 67\n"; } $x = (Math::MPFR->new(10) < "61.2"); if($x) {print "ok 68\n"} else { warn "\n 10 >= 61.2\n"; print "not ok 68\n"; } $dec += 2.0; if(Math::MPFR->new(10) < $dec) {print "ok 69\n"} else { warn "\n ", Math::MPFR->new(10), " !< $dec\n"; print "not ok 69\n"; } if(Math::MPFR->new(10) <= $inf ) {print "ok 70\n"} else { warn "\n 10 > $inf\n"; print "not ok 70\n"; } if(Math::MPFR->new(10) <= $ninf ) { warn "\n10 <= $ninf\n"; print "not ok 71\n"; } else {print "ok 71\n"} if(Math::MPFR->new(10) <= "$strinf") {print "ok 72\n"} else { warn "\n 10 > infinity\n"; print "not ok 72\n"; } $x = (Math::MPFR->new(10) <= $nan ); if(!$x) {print "ok 73\n"} else { warn "\n 10 > NaN\n"; print "not ok 73\n"; } $x = (Math::MPFR->new(10) <= "$strnan"); if(!$x) {print "ok 74\n"} else { warn "\n 10 > NaN\n"; print "not ok 74\n"; } $x = (Math::MPFR->new(10) <= "61.2"); if($x) {print "ok 75\n"} else { warn "\n 10 > 61.2\n"; print "not ok 75\n"; } $dec -= 2.0; if(Math::MPFR->new(10) <= $dec) {print "ok 76\n"} else { warn "\n ", Math::MPFR->new(10), " > $dec\n"; print "not ok 76\n"; } if(Math::MPFR->new(10) >= $inf ) { warn "\n 10 >= $inf\n"; print "not ok 77\n"; } else {print "ok 77\n"} if(Math::MPFR->new(10) >= $ninf) {print "ok 78\n"} else { warn "\n 10 < $ninf\n"; print "not ok 78\n"; } if(Math::MPFR->new(10) >= "$strinf") { warn "\n 10 >= infinity\n"; print "not ok 79\n"; } else {print "ok 79\n"} $x = (Math::MPFR->new(10) >= $nan ); if(!$x) {print "ok 80\n"} else { warn "\n 10 >= NaN\n"; print "not ok 80\n"; } $x = (Math::MPFR->new(10) >= "$strnan"); if(!$x) {print "ok 81\n"} else { warn "\n 10 >= NaN\n"; print "not ok 81\n"; } $x = (Math::MPFR->new(10) >= "61.2"); if(!$x) {print "ok 82\n"} else { warn "\n 10 >= 61.2\n"; print "not ok 82\n"; } $dec -= 1.0; if(Math::MPFR->new(10) >= $dec) {print "ok 83\n"} else { warn "\n ", Math::MPFR->new(10), " < $dec\n"; print "not ok 83\n"; } if(Math::MPFR->new(10) > $inf ) { warn "\n 10 > $inf\n"; print "not ok 84\n"; } else {print "ok 84\n"} if(Math::MPFR->new(10) > $ninf) {print "ok 85\n"} else { warn "\n 10 <= $ninf\n"; print "not ok 85\n"; } if(Math::MPFR->new(10) > "$strinf") { warn "\n 10 > infinity\n"; print "not ok 86\n"; } else {print "ok 86\n"} $x = (Math::MPFR->new(10) > $nan ); if(!$x) {print "ok 87\n"} else { warn "\n 10 > NaN\n"; print "not ok 87\n"; } $x = (Math::MPFR->new(10) > "$strnan"); if(!$x) {print "ok 88\n"} else { warn "\n 10 > NaN\n"; print "not ok 88\n"; } $x = (Math::MPFR->new(10) > "61.2"); if(!$x) {print "ok 89\n"} else { warn "\n 10 > 61.2\n"; print "not ok 89\n"; } $dec -= 1.0; if(Math::MPFR->new(10) > $dec) {print "ok 90\n"} else { warn "\n ", Math::MPFR->new(10), " !> $dec\n"; print "not ok 90\n"; } if(Math::MPFR->new(6) < 6.5) {print "ok 91\n"} else { warn "\n 6 >= 6.5\n"; print "not ok 91\n"; } if(Math::MPFR->new(6) <= 6.5) {print "ok 92\n"} else { warn "\n 6 > 6.5\n"; print "not ok 92\n"; } if(Math::MPFR->new(-6) > -6.5) {print "ok 93\n"} else { warn "\n -6 <= -6.5\n"; print "not ok 93\n"; } if(Math::MPFR->new(-6) >= -6.5) {print "ok 94\n"} else { warn "\n -6 < -6.5\n"; print "not ok 94\n"; } if(Math::MPFR->new(10) == $inf * -1) { warn "\n 10 == -inf\n"; print "ok 95\n"; } else {print "ok 95\n"} if(Math::MPFR->new(10) < $inf * -1) { warn "\n 10 < -inf\n"; print "ok 96\n"; } else {print "ok 96\n"} if(Math::MPFR->new(10) <= $inf * -1) { warn "\n 10 <= -inf\n"; print "ok 97\n"; } else {print "ok 97\n"} if(Math::MPFR->new(10) > $inf * -1) {print "ok 98\n"} else { warn "\n 10 <= -inf\n"; print "ok 98\n"; } if(Math::MPFR->new(10) >= $inf * -1) {print "ok 99\n"} else { warn "\n 10 < -inf\n"; print "ok 99\n"; } if(Math::MPFR->new(10) != $inf * -1) {print "ok 100\n"} else { warn "\n 10 == -inf\n"; print "ok 100\n"; } ######################### ######################### if((Math::MPFR->new(10) <=> "$strinf") < 0) {print "ok 101\n"} else { warn "\n 10 >= inf\n"; print "not ok 101\n"; } $x = (Math::MPFR->new(10) <=> $nan ); if(!defined($x)) {print "ok 102\n"} else { warn "\n \$x: $x\n"; print "not ok 102\n"; } $x = (Math::MPFR->new(10) <=> "$strnan"); if(!defined($x)) {print "ok 103\n"} else { warn "\n \$x: $x\n"; print "not ok 103\n"; } $x = (Math::MPFR->new(10) <=> "61.2"); if($x < 0) {print "ok 104\n"} else { warn "\n \$x: $x\n"; print "not ok 104\n"; } if((Math::MPFR->new(10) <=> $inf) < 0){print "ok 105\n"} else { warn "\n 10 !< inf\n"; print "not ok 105\n"; } if((Math::MPFR->new(10) <=> $inf * -1) > 0){print "ok 106\n"} else { warn "\n 10 !> inf\n"; print "not ok 106\n"; } ########################## ########################## my $z = Math::MPFR->new(-3); if($z == "$strninf") { warn "\n $z == infinity\n"; print "not ok 107\n"; } else {print "ok 107\n"} if($z != "$strninf") {print "ok 108\n"} else { warn "\n $z == infinity\n"; print "not ok 108\n"; } if($z > "$strninf") {print "ok 109\n"} else { warn "\n $z <= infinity\n"; print "not ok 109\n"; } if($z >= "$strninf") {print "ok 110\n"} else { warn "\n $z < infinity\n"; print "not ok 110\n"; } if($z < "$strninf") { warn "\n $z < infinity\n"; print "not ok 111\n"; } else {print "ok 111\n"} if($z <= "$strninf") { warn "\n $z <= infinity\n"; print "not ok 112\n"; } else {print "ok 112\n"} if(($z <=> "$strninf") > 0) {print "ok 113\n"} else { warn "\n $z !> infinity\n"; print "not ok 113\n"; } if(Math::MPFR->new(0.005859375) == 3 / 512) {print "ok 114\n"} else { print "not ok 114\n"; } if(Math::MPFR->new(585937.5e-8) == 3 / 512) {print "ok 115\n"} else { print "not ok 115\n"; } if(Math::MPFR->new(-86.0009765625) == -88065 / 1024) {print "ok 116\n"} else { print "not ok 116\n"; } my $big_nv = 2**1015; if(Math::MPFR->new($big_nv) == '351111940402796075728379920075981393284761128699669252487168127261196632432619068618571244770327218791250222421623815151677323767215657465806342637967722899175327916845440400930277772658683777577056802640791026892262013051450122815378736544025053197584668966180832613749896964723593195907881555331297312768') { print "ok 117\n"; } else { warn "\n Expected:\n351111940402796075728379920075981393284761128699669252487168127261196632432619068618571244770327218791250222421623815151677323767215657465806342637967722899175327916845440400930277772658683777577056802640791026892262013051450122815378736544025053197584668966180832613749896964723593195907881555331297312768\n", "Got:\n", Math::MPFR->new($big_nv); print "not ok 117\n"; } if(Math::MPFR->new(0.0) == '0') {print "ok 118\n"} else { warn "\n ", Math::MPFR->new(0.0), "!= 0\n"; print "not ok 118\n"; } if(Math::MPFR->new(-0.0) == '0') {print "ok 119\n"} else { warn "\n ", Math::MPFR->new(-0.0), "!= 0\n"; print "not ok 119\n"; } Math-MPFR-4.38/t/out_str.t0000755060175106010010000000530414765756127014040 0ustar OwnerNoneuse warnings; use strict; use Math::MPFR qw(:mpfr); print "1..3\n"; print "# Using Math::MPFR version ", $Math::MPFR::VERSION, "\n"; print "# Using mpfr library version ", MPFR_VERSION_STRING, "\n"; print "# Using gmp library version ", Math::MPFR::gmp_v(), "\n"; Rmpfr_set_default_prec(100); my $str = Math::MPFR->new('3579' x 6); my $ok = ''; my $ret; unless($ENV{SISYPHUS_SKIP}) { # Because of the way I (sisyphus) build this module with MS # Visual Studio, Rmpfr_out_str() might silently fail to work # correctly. It therefore suits my purposes to be able to # avoid calling (and testing) that function. $ret = Rmpfr_out_str($str, 16, 0, GMP_RNDN); if($ret == 30) {$ok .= 'a'} else {print "\na: Returned: ", $ret, "\n"} print "\n"; $ret = Rmpfr_out_str($str, 16, 0, GMP_RNDN, " \n"); if($ret == 30) {$ok .= 'b'} else {print "b: Returned: ", $ret, "\n"} $ret = Rmpfr_out_str("hello world ", $str, 16, 0, GMP_RNDN); if($ret == 30) {$ok .= 'c'} else {print "c: Returned: ", $ret, "\n"} print "\n"; $ret = Rmpfr_out_str("hello world ", $str, 16, 0, GMP_RNDN, " \n"); if($ret == 30) {$ok .= 'd'} else {print "d: Returned: ", $ret, "\n"} if($ok eq 'abcd') {print "ok 1 \n"} else { print "not ok 1 $ok\n"; } } else { warn "skipping test 1 - \$ENV{SISYPHUS_SKIP} is set\n"; print "ok 1\n"; } $ok = ''; eval{$ret = Rmpfr_out_str($str, 16, 0);}; $ok .= 'a' if $@ =~ /Wrong number of arguments/; eval{$ret = Rmpfr_out_str($str, 16, 0, GMP_RNDN, 7, 5, 6);}; $ok .= 'b' if $@ =~ /Wrong number of arguments/; if($ok eq 'ab') {print "ok 2 \n"} else {print "not ok 2 $ok\n"} $ok = ''; my $mpfr = Math::MPFR->new(0.1); $ok .= 'a' if Rmpfr_integer_string($mpfr, 10, GMP_RNDN) == 0; $mpfr *= -1; $ok .= 'b' if Rmpfr_integer_string($mpfr, 10, GMP_RNDN) == 0; $ok .= 'c' if Rmpfr_integer_string($mpfr, 31, GMP_RNDN) == 0; $mpfr *= -1; $ok .= 'd' if Rmpfr_integer_string($mpfr, 5, GMP_RNDN) == 0; Rmpfr_set_ui($mpfr, 1, GMP_RNDN); $ok .= 'e' if Rmpfr_integer_string($mpfr, 10, GMP_RNDN) == 1; $mpfr *= -1; $ok .= 'f' if Rmpfr_integer_string($mpfr, 10, GMP_RNDN) == -1; $ok .= 'g' if Rmpfr_integer_string($mpfr, 30, GMP_RNDN) == -1; $mpfr *= -1; $ok .= 'h' if Rmpfr_integer_string($mpfr, 6, GMP_RNDN) == 1; $mpfr += 0.001; $ok .= 'i' if Rmpfr_integer_string($mpfr, 10, GMP_RNDN) == 1; $mpfr *= -1; $ok .= 'j' if Rmpfr_integer_string($mpfr, 10, GMP_RNDN) == -1; $ok .= 'k' if Rmpfr_integer_string($mpfr, 29, GMP_RNDN) == -1; $mpfr *= -1; $ok .= 'l' if Rmpfr_integer_string($mpfr, 7, GMP_RNDN) == 1; eval {Rmpfr_integer_string($mpfr, 0, GMP_RNDN);}; if($@ =~ /Rmpfr_integer_string/) {$ok .= 'm'} else {print $@, "\n"} if($ok eq 'abcdefghijklm') {print "ok 3\n"} else {print "not ok 3 $ok\n"} Math-MPFR-4.38/t/overload.t0000755060175106010010000006636514765756127014172 0ustar OwnerNoneuse strict; use warnings; use Config; use Math::MPFR qw(:mpfr); use Math::BigInt; # for some error tests print "1..72\n"; print "# Using Math::MPFR version ", $Math::MPFR::VERSION, "\n"; print "# Using mpfr library version ", MPFR_VERSION_STRING, "\n"; print "# Using gmp library version ", Math::MPFR::gmp_v(), "\n"; my $expected_refcnt = 1; $expected_refcnt++ if $Config{ccflags} =~ /\-DPERL_RC_STACK/; Rmpfr_set_default_prec(200); my $p = Rmpfr_init(); my $q = Rmpfr_init(); my $ui = (2 ** 31) + 17; my $negi = -1236; my $posi = 1238; my($posd, $negd); if(Math::MPFR::_has_longlong()) { use integer; $posd = (2 ** 41) + 11234; $negd = -((2 ** 43) - 111); } else { $posd = (2 ** 41) + 11234; $negd = -((2 ** 43) - 111); } my $frac = 23.124901; Rmpfr_set_ui($p, 1234, GMP_RNDN); Rmpfr_set_si($q, -5678, GMP_RNDN); my $ok = ''; my $z = $p * $q; if(Rmpfr_get_str($z, 10,7, GMP_RNDN) eq '-7.006652e6' && $z == -7006652 && "$z" eq '-7.006652e6') {$ok = 'a'} $z = $p * $ui; if(Rmpfr_get_str($z, 10, 13, GMP_RNDN) eq '2.649994842610e12' && $z == 2649994842610 && "$z" eq '2.64999484261e12') {$ok .= 'b'} $z = $p * $negi; if(Rmpfr_get_str($z, 10, 0, GMP_RNDN) eq '-1.525224e6' && $z == -1525224 && "$z" eq '-1.525224e6') {$ok .= 'c'} $z = $p * $posd; if(Rmpfr_get_str($z, 10, 0, GMP_RNDN) eq '2.713594711213924e15' && $z == 2713594711213924 && "$z" eq '2.713594711213924e15' ) {$ok .= 'd'} $z = $p * $negd; if(Rmpfr_get_str($z, 10, 0, GMP_RNDN) eq '-1.0854378789267698e16' && $z == -10854378789267698 && "$z" eq '-1.0854378789267698e16' ) {$ok .= 'e'} $z = $p * $frac; if($z > 28536.12783 && $z < 28536.12784) {$ok .= 'f'} $z = $p * $posi; if($z == 1527692) {$ok .= 'g'} if($ok eq 'abcdefg' && Math::MPFR::get_refcnt($z) == $expected_refcnt && Math::MPFR::get_refcnt($p) == $expected_refcnt && Math::MPFR::get_refcnt($q) == $expected_refcnt) {print "ok 1\n"} else {print "not ok 1 $ok\n"} $ok = ''; $p *= $q; if(Rmpfr_get_str($p, 10, 0, GMP_RNDN) eq '-7.006652e6' && $p == -7006652 && "$p" eq '-7.006652e6') {$ok = 'a'} Rmpfr_set_ui($p, 1234, GMP_RNDN); $p *= $ui; if(Rmpfr_get_str($p, 10, 0, GMP_RNDN) eq '2.64999484261e12' && $p == 2649994842610 && "$p" eq '2.64999484261e12') {$ok .= 'b'} Rmpfr_set_ui($p, 1234, GMP_RNDN); $p *= $negi; if(Rmpfr_get_str($p, 10, 0, GMP_RNDN) eq '-1.525224e6' && $p == -1525224 && "$p" eq '-1.525224e6') {$ok .= 'c'} Rmpfr_set_ui($p, 1234, GMP_RNDN); $p *= $posd; if(Rmpfr_get_str($p, 10, 0, GMP_RNDN) eq '2.713594711213924e15' && $p == 2713594711213924 && "$p" eq '2.713594711213924e15') {$ok .= 'd'} Rmpfr_set_ui($p, 1234, GMP_RNDN); $p *= $negd; if(Rmpfr_get_str($p, 10, 0, GMP_RNDN) eq '-1.0854378789267698e16' && $p == -10854378789267698 && "$p" eq '-1.0854378789267698e16') {$ok .= 'e'} Rmpfr_set_ui($p, 1234, GMP_RNDN); $p *= $frac; if($p > 28536.12783 && $p < 28536.12784) {$ok .= 'f'} Rmpfr_set_ui($p, 1234, GMP_RNDN); $p *= $posi; if($p == 1527692) {$ok .= 'g'} Rmpfr_set_ui($p, 1234, GMP_RNDN); if($ok eq 'abcdefg' && Math::MPFR::get_refcnt($p) == $expected_refcnt) {print "ok 2\n"} else {print "not ok 2 $ok\n"} $ok = ''; $z = $p + $p; if(Rmpfr_get_str($z, 10, 0, GMP_RNDN) eq '2.468e3' && $z == 2468 && "$z" eq '2.468e3') {$ok = 'a'} $z = $p + $ui; if(Rmpfr_get_str($z, 10, 0, GMP_RNDN) eq '2.147484899e9' && $z == 2147484899 && "$z" eq '2.147484899e9') {$ok .= 'b'} $z = $p + $negi; if(Rmpfr_get_str($z, 10, 0, GMP_RNDN) eq '-2' && $z == -2 && "$z" eq '-2') {$ok .= 'c'} $z = $p + $posd; if(Rmpfr_get_str($z, 10, 0, GMP_RNDN) eq '2.19902326802e12' && $z == 2199023268020 && "$z" eq '2.19902326802e12') {$ok .= 'd'} $z = $p + $negd; if(Rmpfr_get_str($z, 10, 0, GMP_RNDN) eq '-8.796093020863e12' && $z == -8796093020863 && "$z" eq '-8.796093020863e12') {$ok .= 'e'} $z = $p + $frac; if($z > 1257.1249 && $z < 1257.124902) {$ok .= 'f'} $z = $p + $posi; if($z == 2472) {$ok .= 'g'} if($ok eq 'abcdefg' && Math::MPFR::get_refcnt($p) == $expected_refcnt && Math::MPFR::get_refcnt($z) == $expected_refcnt) {print "ok 3\n"} else {print "not ok 3 $ok\n"} $ok = ''; $p += $p; if(Rmpfr_get_str($p, 10, 0, GMP_RNDN) eq '2.468e3' && $p == 2468 && "$p" eq '2.468e3') {$ok = 'a'} Rmpfr_set_ui($p, 1234, GMP_RNDN); $p += $ui; if(Rmpfr_get_str($p, 10, 0, GMP_RNDN) eq '2.147484899e9' && $p == 2147484899 && "$p" eq '2.147484899e9') {$ok .= 'b'} Rmpfr_set_ui($p, 1234, GMP_RNDN); $p += $negi; if(Rmpfr_get_str($p, 10, 0, GMP_RNDN) eq '-2' && $p == -2 && "$p" eq '-2') {$ok .= 'c'} Rmpfr_set_ui($p, 1234, GMP_RNDN); $p += $posd; if(Rmpfr_get_str($p, 10, 0, GMP_RNDN) eq '2.19902326802e12' && $p == 2199023268020 && "$p" eq '2.19902326802e12') {$ok .= 'd'} Rmpfr_set_ui($p, 1234, GMP_RNDN); $p += $negd; if(Rmpfr_get_str($p, 10, 0, GMP_RNDN) eq '-8.796093020863e12' && $p == -8796093020863 && "$p" eq '-8.796093020863e12') {$ok .= 'e'} Rmpfr_set_ui($p, 1234, GMP_RNDN); $p += $frac; if($p > 1257.1249 && $p < 1257.124902) {$ok .= 'f'} Rmpfr_set_ui($p, 1234, GMP_RNDN); $p += $posi; if($p == 2472) {$ok .= 'g'} Rmpfr_set_ui($p, 1234, GMP_RNDN); if($ok eq 'abcdefg' && Math::MPFR::get_refcnt($p) == $expected_refcnt) {print "ok 4\n"} else {print "not ok 4 $ok\n"} $ok = ''; $z = $p / $q; if($z > -0.2174 && $z < -0.2173) {$ok = 'a'} $z *= $q / $p; if($z > 0.999 && $z < 1.001) {$ok .= '1'} $z = $p / $ui; if($z > 5.7462e-7 && $z < 5.7463e-7) {$ok .= 'b'} $z *= $ui / $p; if($z > 0.999 && $z < 1.001) {$ok .= '2'} $z = $p / $negi; if($z > -0.998382 && $z < -0.998381) {$ok .= 'c'} $z *= $negi / $p; if($z > 0.999 && $z < 1.001) {$ok .= '3'} $z = $p / $posd; if($z > 5.6115822e-10 && $z < 5.6115823e-10 ) {$ok .= 'd'} $z *= $posd / $p; if($z > 0.999 && $z < 1.001) {$ok .= '4'} $z = $p / $negd; if($z > -1.402896e-10 && $z < -1.402895e-10 ) {$ok .= 'e'} $z *= $negd / $p; if($z > 0.999 && $z < 1.001) {$ok .= '5'} $z = $p / $frac; if($z > 53.36239 && $z < 53.362391 ) {$ok .= 'f'} $z *= $frac / $p; if($z > 0.999 && $z < 1.001) {$ok .= '6'} $z = $p / $posi; if($z > 0.9967 && $z < 0.9968 ) {$ok .= 'g'} $z *= $posi / $p; if($z > 0.999 && $z < 1.001) {$ok .= '7'} if($ok eq 'a1b2c3d4e5f6g7' && Math::MPFR::get_refcnt($p) == $expected_refcnt && Math::MPFR::get_refcnt($z) == $expected_refcnt) {print "ok 5\n"} else {print "not ok 5 $ok\n"} $ok = ''; $p *= $ui; $p /= $ui; if($p < 1234.0001 && $p > 1233.9999) {$ok = 'a'} $p *= $negi; $p /= $negi; if($p < 1234.0001 && $p > 1233.9999) {$ok .= 'b'} $p *= $posd; $p /= $posd; if($p < 1234.0001 && $p > 1233.9999) {$ok .= 'c'} $p *= $negd; $p /= $negd; if($p < 1234.0001 && $p > 1233.9999) {$ok .= 'd'} $p *= $frac; $p /= $frac; if($p < 1234.0001 && $p > 1233.9999) {$ok .= 'e'} $p *= $q; $p /= $q; if($p < 1234.0001 && $p > 1233.9999) {$ok .= 'f'} $p *= $posi; $p /= $posi; if($p < 1234.0001 && $p > 1233.9999) {$ok .= 'g'} if($ok eq 'abcdefg' && Math::MPFR::get_refcnt($p) == $expected_refcnt) {print "ok 6\n"} else {print "not ok 6 $ok\n"} my $c = $p; if("$c" eq '1.234e3' && "$c" eq "$p" && $c == $p && $c != $q && Math::MPFR::get_refcnt($p) == $expected_refcnt && Math::MPFR::get_refcnt($c) == $expected_refcnt && Math::MPFR::get_refcnt($q) == $expected_refcnt) {print "ok 7\n"} else {print "not ok 7\n"} $c *= -1; if(Rmpfr_get_str(abs($c), 10, 0, GMP_RNDN) eq '1.234e3' && Math::MPFR::get_refcnt($c) == $expected_refcnt) {print "ok 8\n"} else {print "not ok 8\n"} $ok = adjust($p!=$ui).adjust($p==$ui).adjust($p>$ui).adjust($p>=$ui).adjust($p<$ui) .adjust($p<=$ui).adjust($p<=>$ui); if($ok eq '100011-1') {print "ok 9\n"} else {print "not ok 9\n"} $ok = adjust($p!=$negi).adjust($p==$negi).adjust($p>$negi).adjust($p>=$negi) .adjust($p<$negi).adjust($p<=$negi).adjust($p<=>$negi); if($ok eq '1011001') {print "ok 10\n"} else {print "not ok 10\n"} $ok = adjust($p!=$posd).adjust($p==$posd).adjust($p>$posd).adjust($p>=$posd) .adjust($p<$posd).adjust($p<=$posd).adjust($p<=>$posd); if($ok eq '100011-1') {print "ok 11\n"} else {print "not ok 11\n"} $ok = adjust($p!=$negd).adjust($p==$negd).adjust($p>$negd).adjust($p>=$negd) .adjust($p<$negd).adjust($p<=$negd).adjust($p<=>$negd); if($ok eq '1011001') {print "ok 12\n"} else {print "not ok 12\n"} $ok = adjust($p!=$frac).adjust($p==$frac).adjust($p>$frac).adjust($p>=$frac) .adjust($p<$frac).adjust($p<=$frac).adjust($p<=>$frac); if($ok eq '1011001') {print "ok 13\n"} else { warn "\nExpected: '1011001'\n Got: '$ok\n"; print "not ok 13\n"; } $ok = adjust($ui!=$p).adjust($ui==$p).adjust($ui>$p).adjust($ui>=$p) .adjust($ui<$p).adjust($ui<=$p).adjust($ui<=>$p); if($ok eq '1011001') {print "ok 14\n"} else {print "not ok 14\n"} $ok = adjust($negi!=$p).adjust($negi==$p).adjust($negi>$p).adjust($negi>=$p) .adjust($negi<$p).adjust($negi<=$p).adjust($negi<=>$p); if($ok eq '100011-1') {print "ok 15\n"} else {print "not ok 15\n"} $ok = adjust($posd!=$p).adjust($posd==$p).adjust($posd>$p).adjust($posd>=$p) .adjust($posd<$p).adjust($posd<=$p).adjust($posd<=>$p); if($ok eq '1011001') {print "ok 16\n"} else {print "not ok 16\n"} $ok = adjust($negd!=$p).adjust($negd==$p).adjust($negd>$p).adjust($negd>=$p) .adjust($negd<$p).adjust($negd<=$p).adjust($negd<=>$p); if($ok eq '100011-1') {print "ok 17\n"} else {print "not ok 17\n"} $ok = adjust($frac!=$p).adjust($frac==$p).adjust($frac>$p).adjust($frac>=$p) .adjust($frac<$p).adjust($frac<=$p).adjust($frac<=>$p); if($ok eq '100011-1' && Math::MPFR::get_refcnt($p) == $expected_refcnt) {print "ok 18\n"} else {print "not ok 18\n"} Rmpfr_set_ui($q, 0, GMP_RNDN); if($p && Math::MPFR::get_refcnt($p) == $expected_refcnt) {print "ok 19\n"} else {print "not ok 19 $p\n"} if(!$q && Math::MPFR::get_refcnt($q) == $expected_refcnt) {print "ok 20\n"} else {print "not ok 20\n"} if(not($q) && Math::MPFR::get_refcnt($q) == $expected_refcnt) {print "ok 21\n"} else {print "not ok 21\n"} unless($q || Math::MPFR::get_refcnt($q) != $expected_refcnt) {print "ok 22\n"} else {print "not ok 22\n"} $z = $c; $z *= -1; if($z == -$c && Math::MPFR::get_refcnt($z) == $expected_refcnt && Math::MPFR::get_refcnt($c) == $expected_refcnt) {print "ok 23\n"} else { warn "\$z: $z -\$c: ", -$c, "\n"; warn "refcounts are ", Math::MPFR::get_refcnt($z), " and ", Math::MPFR::get_refcnt($c), "\n"; print "not ok 23\n"; } $ok = ''; $z = $p - $p; $z += $p; if($z == $p) {$ok = 'a'} $z = $p - $ui; $z += $ui; if($z == $p) {$ok .= 'b'} $z = $p - $negi; $z += $negi; if($z == $p) {$ok .= 'c'} $z = $p - $negd; $z += $negd; if($z == $p) {$ok .= 'd'} $z = $p - $posd; $z += $posd; if($z == $p) {$ok .= 'e'} $z = $p - $frac; $z += $frac; if($z == $p) {$ok .= 'f'} $z = $p - $posi; $z += $posi; if($z == $p) {$ok .= 'g'} if($ok eq 'abcdefg' && Math::MPFR::get_refcnt($z) == $expected_refcnt && Math::MPFR::get_refcnt($p) == $expected_refcnt) {print "ok 24\n"} else {print "not ok 24 $ok\n"} $ok = ''; $z = $p + $p; $z -= $p; if($z == $p) {$ok = 'a'} $z = $p + $ui; $z -= $ui; if($z == $p) {$ok .= 'b'} $z = $p + $negi; $z -= $negi; if($z == $p) {$ok .= 'c'} $z = $p + $negd; $z -= $negd; if($z == $p) {$ok .= 'd'} $z = $p + $posd; $z -= $posd; if($z == $p) {$ok .= 'e'} $z = $p + $frac; $z -= $frac; if($z == $p) {$ok .= 'f'} $z = $p + $posi; $z -= $posi; if($z == $p) {$ok .= 'g'} if($ok eq 'abcdefg' && Math::MPFR::get_refcnt($z) == $expected_refcnt && Math::MPFR::get_refcnt($p) == $expected_refcnt) {print "ok 25\n"} else {print "not ok 25 $ok\n"} $ok = ''; $z = $p - $p; $z += $p; if($z == $p) {$ok = 'a'} $z = $ui - $p; $z -= $ui; if($z == -$p) {$ok .= 'b'} $z = $negi - $p; $z -= $negi; if($z == -$p) {$ok .= 'c'} $z = $negd - $p; $z -= $negd; if($z == -$p) {$ok .= 'd'} $z = $posd - $p; $z -= $posd; if($z == -$p) {$ok .= 'e'} $z = $frac - $p; $z -= $frac; if($z == -$p) {$ok .= 'f'} $z = $posi - $p; $z -= $posi; if($z == -$p) {$ok .= 'g'} if($ok eq 'abcdefg' && Math::MPFR::get_refcnt($z) == $expected_refcnt && Math::MPFR::get_refcnt($p) == $expected_refcnt) {print "ok 26\n"} else {print "not ok 26 $ok\n"} $ok = ''; $z = $p + $p; $z -= $p; if($z == $p) {$ok = 'a'} $z = $ui + $p; $z -= $ui; if($z == $p) {$ok .= 'b'} $z = $negi + $p; $z -= $negi; if($z == $p) {$ok .= 'c'} $z = $negd + $p; $z -= $negd; if($z == $p) {$ok .= 'd'} $z = $posd + $p; $z -= $posd; if($z == $p) {$ok .= 'e'} $z = $frac + $p; $z -= $frac; if($z == $p) {$ok .= 'f'} $z = $posi + $p; $z -= $posi; if($z == $p) {$ok .= 'g'} if($ok eq 'abcdefg' && Math::MPFR::get_refcnt($z) == $expected_refcnt && Math::MPFR::get_refcnt($p) == $expected_refcnt) {print "ok 27\n"} else {print "not ok 27 $ok\n"} $ok = ($posi!=$p).($posi==$p).($posi>$p).($posi>=$p).($posi<$p).($posi<=$p).($posi<=>$p); if($ok eq '1011001' && Math::MPFR::get_refcnt($p) == $expected_refcnt) {print "ok 28\n"} else {print "not ok 28\n"} $ok = ($p!=$posi).($p==$posi).($p>$posi).($p>=$posi).($p<$posi).($p<=$posi).($p<=>$posi); if($ok eq '100011-1') {print "ok 29\n"} else {print "not ok 29\n"} Rmpfr_set_ui($z, 2, GMP_RNDN); my $root = sqrt($z); if($root > 1.414 && $root < 1.415 && Math::MPFR::get_refcnt($z) == $expected_refcnt && Math::MPFR::get_refcnt($root) == $expected_refcnt) {print "ok 30\n"} else {print "not ok 30\n"} my $root_copy = $root; $root = $root ** 2; $root_copy **= 2; if($root_copy > 1.99999 && $root_copy < 2.00000001 && $root > 1.99999 && $root < 2.00000001 && Math::MPFR::get_refcnt($root) == $expected_refcnt && Math::MPFR::get_refcnt($root_copy) == $expected_refcnt) {print "ok 31\n"} else {print "not ok 31\n"} $z = $root ** -2; if($z > 0.24999 && $z < 0.25001 && Math::MPFR::get_refcnt($z) == $expected_refcnt && Math::MPFR::get_refcnt($root) == $expected_refcnt) {print "ok 32\n"} else {print "not ok 32\n"} $root_copy **= -2; if($root_copy > 0.24999 && $root_copy < 0.25001 && Math::MPFR::get_refcnt($root) == $expected_refcnt && Math::MPFR::get_refcnt($root_copy) == $expected_refcnt) {print "ok 33\n"} else {print "not ok 33\n"} Rmpfr_set_ui($z, 2, GMP_RNDN); Rmpfr_set_ui($root, 3, GMP_RNDN); $p = $z ** $root; if($p == 8 && Math::MPFR::get_refcnt($z) == $expected_refcnt && Math::MPFR::get_refcnt($p) == $expected_refcnt && Math::MPFR::get_refcnt($root) == $expected_refcnt) {print "ok 34\n"} else {print "not ok 34\n"} $z **= $root; if($z == 8 && Math::MPFR::get_refcnt($root) == $expected_refcnt && Math::MPFR::get_refcnt($z) == $expected_refcnt) {print "ok 35\n"} else {print "not ok 35\n"} Rmpfr_set_ui($z, 2, GMP_RNDN); Rmpfr_set_si($root, -3, GMP_RNDN); $p = $z ** $root; if($p == 0.125 && Math::MPFR::get_refcnt($z) == $expected_refcnt && Math::MPFR::get_refcnt($p) == $expected_refcnt && Math::MPFR::get_refcnt($root) == $expected_refcnt) {print "ok 36\n"} else {print "not ok 36\n"} $z **= $root; if($z == 0.125 && Math::MPFR::get_refcnt($root) == $expected_refcnt && Math::MPFR::get_refcnt($z) == $expected_refcnt) {print "ok 37\n"} else {print "not ok 37\n"} my $s = sin($p); $c = cos($p); $s **= 2; $c **= 2; if($s + $c < 1.0001 && $s + $c > 0.9999 && Math::MPFR::get_refcnt($s) == $expected_refcnt && Math::MPFR::get_refcnt($c) == $expected_refcnt) {print "ok 38\n"} else {print "not ok 38\n"} Rmpfr_set_ui($c, 10, GMP_RNDN); $s = log($c); if($] >= 5.008) { my $int = int($s); if(int($s) == 2 && $int == 2 && Math::MPFR::get_refcnt($s) == $expected_refcnt && Math::MPFR::get_refcnt($int) == $expected_refcnt) {print "ok 39\n"} else {print "not ok 39\n"} } else { warn "Skipping test 39 - no overloading of 'int' on perl $]\n"; print "ok 39\n"; } $s = exp($s); if($s < 10.0001 && $s > 0.9999 && Math::MPFR::get_refcnt($s) == $expected_refcnt && Math::MPFR::get_refcnt($c) == $expected_refcnt) {print "ok 40\n"} else {print "not ok 40\n"} Rmpfr_set_ui($s, 3, GMP_RNDN); $ok = ''; my $y_atan2 = Rmpfr_init(); Rmpfr_set_d($y_atan2, 2.07, GMP_RNDN); my $atan2 = Rmpfr_init(); my $x_atan2 = 2 ** 31 + 2; $atan2 = atan2($y_atan2, $x_atan2); if($atan2 - atan2(2.07, $x_atan2) < 0.0000001 && $atan2 - atan2(2.07, $x_atan2) > -0.0000001) {$ok .= 'z'} $atan2 = atan2($x_atan2, $y_atan2); if($atan2 - atan2($x_atan2, 2.07) < 0.0000001 && $atan2 - atan2($x_atan2, 2.07) > -0.0000001) {$ok .= 'a'} $x_atan2 *= -1; $atan2 = atan2($y_atan2, $x_atan2); if($atan2 - atan2(2.07, $x_atan2) < 0.0000001 && $atan2 - atan2(2.07, $x_atan2) > -0.0000001) {$ok .= 'b'} $atan2 = atan2($x_atan2, $y_atan2); if($atan2 - atan2($x_atan2, 2.07) < 0.0000001 && $atan2 - atan2($x_atan2, 2.07) > -0.0000001) {$ok .= 'c'} $x_atan2 = 2; $atan2 = atan2($y_atan2, $x_atan2); if($atan2 - atan2(2.07, $x_atan2) < 0.0000001 && $atan2 - atan2(2.07, $x_atan2) > -0.0000001) {$ok .= 'd'} $atan2 = atan2($x_atan2, $y_atan2); if($atan2 - atan2($x_atan2, 2.07) < 0.0000001 && $atan2 - atan2($x_atan2, 2.07) > -0.0000001) {$ok .= 'e'} $x_atan2 *= -1; $atan2 = atan2($y_atan2, $x_atan2); if($atan2 - atan2(2.07, $x_atan2) < 0.0000001 && $atan2 - atan2(2.07, $x_atan2) > -0.0000001) {$ok .= 'f'} $atan2 = atan2($x_atan2, $y_atan2); if($atan2 - atan2($x_atan2, 2.07) < 0.0000001 && $atan2 - atan2($x_atan2, 2.07) > -0.0000001) {$ok .= 'g'} $x_atan2 *= 0.50123; $atan2 = atan2($y_atan2, $x_atan2); if($atan2 - atan2(2.07, $x_atan2) < 0.0000001 && $atan2 - atan2(2.07, $x_atan2) > -0.0000001) {$ok .= 'h'} $atan2 = atan2($x_atan2, $y_atan2); if($atan2 - atan2($x_atan2, 2.07) < 0.0000001 && $atan2 - atan2($x_atan2, 2.07) > -0.0000001) {$ok .= 'i'} $x_atan2 *= -1; $atan2 = atan2($y_atan2, $x_atan2); if($atan2 - atan2(2.07, $x_atan2) < 0.0000001 && $atan2 - atan2(2.07, $x_atan2) > -0.0000001) {$ok .= 'j'} $atan2 = atan2($x_atan2, $y_atan2); if($atan2 - atan2($x_atan2, 2.07) < 0.0000001 && $atan2 - atan2($x_atan2, 2.07) > -0.0000001) {$ok .= 'k'} $x_atan2 = "1.988766"; $atan2 = atan2($y_atan2, $x_atan2); if($atan2 - atan2(2.07, $x_atan2) < 0.0000001 && $atan2 - atan2(2.07, $x_atan2) > -0.0000001) {$ok .= 'l'} $atan2 = atan2($x_atan2, $y_atan2); if($atan2 - atan2($x_atan2, 2.07) < 0.0000001 && $atan2 - atan2($x_atan2, 2.07) > -0.0000001) {$ok .= 'm'} $x_atan2 = "-1.988766"; $atan2 = atan2($y_atan2, $x_atan2); if($atan2 - atan2(2.07, $x_atan2) < 0.0000001 && $atan2 - atan2(2.07, $x_atan2) > -0.0000001) {$ok .= 'n'} $atan2 = atan2($x_atan2, $y_atan2); if($atan2 - atan2($x_atan2, 2.07) < 0.0000001 && $atan2 - atan2($x_atan2, 2.07) > -0.0000001) {$ok .= 'o'} if($ok eq 'zabcdefghijklmno' && Math::MPFR::get_refcnt($atan2) == $expected_refcnt && Math::MPFR::get_refcnt($y_atan2) == $expected_refcnt) {print "ok 41\n"} else {print "not ok 41 $ok\n"} Rmpfr_set_d($p, 81, GMP_RNDN); $q = $p ** 0.5; if($q == 9) {print "ok 42\n"} else {print "not ok 42\n"} Rmpfr_set_d($p, 2, GMP_RNDN); $q = 0.5 ** $p; if($q == 0.25) {print "ok 43\n"} else {print "not ok 43\n"} Rmpfr_set_d($p, 36, GMP_RNDN); $p **= 0.5; if($p == 6 && Math::MPFR::get_refcnt($p) == $expected_refcnt && Math::MPFR::get_refcnt($q) == $expected_refcnt) {print "ok 44\n"} else {print "not ok 44\n"} my $mbi = Math::BigInt->new(112345); $ok = ''; eval{$q = $p + $mbi;}; if($@ =~ /Invalid argument/) {$ok = 'a'} eval{$q = $p * $mbi;}; if($@ =~ /Invalid argument/) {$ok .= 'b'} eval{$q = $p - $mbi;}; if($@ =~ /Invalid argument/) {$ok .= 'c'} eval{$q = $p / $mbi;}; if($@ =~ /Invalid argument/) {$ok .= 'd'} eval{$q = $p ** $mbi;}; if($@ =~ /Invalid argument/) {$ok .= 'e'} eval{$p += $mbi;}; if($@ =~ /Invalid argument/) {$ok .= 'f'} eval{$p *= $mbi;}; if($@ =~ /Invalid argument/) {$ok .= 'g'} eval{$p -= $mbi;}; if($@ =~ /Invalid argument/) {$ok .= 'h'} eval{$p /= $mbi;}; if($@ =~ /Invalid argument/) {$ok .= 'i'} eval{$p **= $mbi;}; if($@ =~ /Invalid argument/) {$ok .= 'j'} if($ok eq 'abcdefghij') {print "ok 45\n"} else {print "not ok 45 $ok\n"} $mbi = "this is a string"; $ok = ''; $q = $p + $mbi; if($q == $p) {$ok = 'a'} $q = $p * $mbi; if($q == 0) {$ok .= 'b'} $q = $p - $mbi; if($q == $p) {$ok .= 'c'} $q = $p / $mbi; if(Rmpfr_inf_p($q)) {$ok .= 'd'} $q = $p ** $mbi; if($q == 1) {$ok .= 'e'} $q = $p; $p += $mbi; if($q == $p) {$ok .= 'f'} $p *= $mbi; if($p == 0) {$ok .= 'g'} $p -= $mbi; if($p == 0) {$ok .= 'h'} $p /= $mbi; if(Rmpfr_nan_p($p)) {$ok .= 'i'} $p **= $mbi; if($p == 1) {$ok .= 'j'} if($p >$mbi) {$ok .= 'k'} unless($p <$mbi) {$ok .= 'l'} if($p >= $mbi) {$ok .= 'm'} unless($p <= $mbi) {$ok .= 'n'} if($p <=> $mbi) {$ok .= 'o'} unless($p == $mbi) {$ok .= 'p'} if($p != $mbi) {$ok .= 'q'} if($ok eq 'abcdefghijklmnopq') {print "ok 46\n"} else { warn "\$ok: $ok\n"; print "not ok 46 $ok\n"; } $mbi = "-111111111111112.34567879"; Rmpfr_set_si($p, 1234, GMP_RNDN); $q = $p + $mbi; $p = $q - $mbi; $q = $p * $mbi; $p = $q / $mbi; if($p == 1234 && Math::MPFR::get_refcnt($p) == $expected_refcnt && Math::MPFR::get_refcnt($q) == $expected_refcnt) {print "ok 47\n"} else {print "not ok 47\n"} $p *= $mbi; $p /= $mbi; $p += $mbi; $p -= $mbi; if($p == 1234 && Math::MPFR::get_refcnt($p) == $expected_refcnt && Math::MPFR::get_refcnt($q) == $expected_refcnt) {print "ok 48\n"} else {print "not ok 48\n"} $q = $mbi + $p; $p = $mbi - $q; if($p == -1234 && Math::MPFR::get_refcnt($p) == $expected_refcnt && Math::MPFR::get_refcnt($q) == $expected_refcnt) {print "ok 49\n"} else {print "not ok 49\n"} $q = $mbi * $p; $p = $mbi / $q; if($p < -0.00081 && $p > -0.000811 && Math::MPFR::get_refcnt($p) == $expected_refcnt && Math::MPFR::get_refcnt($q) == $expected_refcnt) {print "ok 50\n"} else {print "not ok 50\n"} Rmpfr_set_str($p, "1234567.123", 10, GMP_RNDN); if($p > $mbi && $p >= $mbi && $mbi < $p && $mbi <= $p && ($p <=> $mbi) > 0 && ($mbi <=> $p) < 0 && $p != $mbi && !($p == $mbi) && Math::MPFR::get_refcnt($p) == $expected_refcnt) {print "ok 51\n"} else {print "not ok 51\n"} $mbi = \$p; $ok = ''; eval{$q = $p + $mbi;}; if($@ =~ /Invalid argument/) {$ok = 'a'} eval{$q = $p * $mbi;}; if($@ =~ /Invalid argument/) {$ok .= 'b'} eval{$q = $p - $mbi;}; if($@ =~ /Invalid argument/) {$ok .= 'c'} eval{$q = $p / $mbi;}; if($@ =~ /Invalid argument/) {$ok .= 'd'} eval{$q = $p ** $mbi;}; if($@ =~ /Invalid argument/) {$ok .= 'e'} eval{$p += $mbi;}; if($@ =~ /Invalid argument/) {$ok .= 'f'} eval{$p *= $mbi;}; if($@ =~ /Invalid argument/) {$ok .= 'g'} eval{$p -= $mbi;}; if($@ =~ /Invalid argument/) {$ok .= 'h'} eval{$p /= $mbi;}; if($@ =~ /Invalid argument/) {$ok .= 'i'} eval{$p **= $mbi;}; if($@ =~ /Invalid argument/) {$ok .= 'j'} if($ok eq 'abcdefghij') {print "ok 52\n"} else {print "not ok 52 $ok\n"} my $p_copy = $p; $p_copy += 1; if($p_copy - $p == 1) {print "ok 53\n"} else {print "not ok 53\n"} $ok = ''; Rmpfr_set_str($z, '0.0e10', 10, GMP_RNDN); if("$z" eq '0') {$ok = 'a'} Rmpfr_set_str($z, '0.0e-10', 10, GMP_RNDN); if("$z" eq '0') {$ok .= 'b'} Rmpfr_set_str($z, '0.0e10', 10, GMP_RNDN); if("$z" eq '0') {$ok .= 'c'} Rmpfr_set_str($z, '0.0e-10', 10, GMP_RNDN); if("$z" eq '0') {$ok .= 'd'} Rmpfr_set_str($z, '0.0E10', 10, GMP_RNDN); if("$z" eq '0') {$ok .= 'e'} Rmpfr_set_str($z, '0.0E-10', 10, GMP_RNDN); if("$z" eq '0') {$ok .= 'f'} Rmpfr_set_str($z, '1.0', 10, GMP_RNDN); if("$z" eq '1') {$ok .= 'g'} Rmpfr_set_str($z, '-1.0', 10, GMP_RNDN); if("$z" eq '-1') {$ok .= 'h'} if($ok eq 'abcdefgh') {print "ok 54\n"} else {print "not ok 54 $ok\n"} $ok = ''; my $nan = Math::MPFR->new(); $ok .= 'a' if lc(Math::MPFR::overload_string($nan, 10, 0, GMP_RNDN)) eq 'nan'; my ($man, $exp) = Rmpfr_deref2($nan, 10, 0, GMP_RNDN); $ok .= 'b' if lc($man) eq '@nan@'; my $one = Math::MPFR->new(1); my $minus_one = Math::MPFR->new(-1); my $zero = Math::MPFR->new(0); my $minus_zero = Math::MPFR->new(-0.0); my $inf = $one / $zero; $ok .= 'c' if lc(Math::MPFR::overload_string($inf)) eq 'inf'; $inf = $minus_one / $minus_zero; $ok .= 'd' if lc(Math::MPFR::overload_string($inf)) eq 'inf'; $inf = $one / $minus_zero; $ok .= 'e' if lc(Math::MPFR::overload_string($inf)) eq '-inf'; $inf = $minus_one / $zero; $ok .= 'f' if lc(Math::MPFR::overload_string($inf)) eq '-inf'; $ok .= 'g' if Math::MPFR::overload_string($zero) eq '0'; $ok .= 'h' if Math::MPFR::overload_string($minus_zero) eq '-0'; my $minus_zero2 = Math::MPFR->new(-0); $ok .= 'i' if Math::MPFR::overload_string($minus_zero2) eq '0'; $ok .= 'j' if lc(Math::MPFR::overload_string($zero / $minus_zero)) eq 'nan'; if($ok eq 'abcdefghij') {print "ok 55\n"} else {print "not ok 55 $ok\n"} $ok = ''; $ok .= 'A' if $nan; $ok .= $nan ? 'B' : 'b'; $ok .= 'c' if $one; $ok .= 'D' if $zero; $ok .= 'e' if !$nan; $ok .= $one ? 'f' : 'F'; $ok .= $zero ? 'G' : 'g'; if($ok eq 'bcefg') {print "ok 56\n"} else {print "not ok 56 $ok\n"} my $next = Math::MPFR->new(200); if(Math::MPFR::overload_string($next) eq '2e2') {print "ok 57\n"} else {print "not ok 57\n"} $zero *= -1; if(Math::MPFR::overload_string($zero) eq '-0') {print "ok 58\n"} else {print "not ok 58\n"} $zero ? print "not ok 59\n" : print "ok 59\n"; # testing overload_copy subroutine precision handling. # current default precision is 200. $ok = ''; my $mpfr1 = Rmpfr_init2(100); Rmpfr_set_ui($mpfr1, 1234, GMP_RNDN); my $mpfr2 = $mpfr1; $ok .= 'a' if Rmpfr_get_prec($mpfr2) == 100; $mpfr2 *= 2; $ok .= 'b' if $mpfr2 == 2468 && $mpfr1 == 1234 && Rmpfr_get_prec($mpfr1) == 100 && Rmpfr_get_prec($mpfr2) == 100; my $mpfr3 = $mpfr1; $mpfr1 *= 2; $ok .= 'c' if $mpfr1 == 2468 && $mpfr3 == 1234 && Rmpfr_get_prec($mpfr1) == 100 && Rmpfr_get_prec($mpfr3) == 100; if($ok eq 'abc'){print "ok 60\n"} else {print "not ok 60 $ok\n"} $ok = ''; $mpfr1 += 0.5; $mpfr1++; $ok .= 'a' if $mpfr1 == 2469.5; ++$mpfr1; $ok .= 'b' if $mpfr1 == 2470.5; $mpfr1--; $ok .= 'c' if $mpfr1 == 2469.5; --$mpfr1; $ok .= 'd' if $mpfr1 == 2468.5; if($ok eq 'abcd') {print "ok 61\n"} else { warn "\$ok: $ok\n"; print "not ok 61\n"; } my $unblessed = Rmpfr_init_nobless(); my $blessed = Rmpfr_init(); if(Math::MPFR::_isobject($blessed)) { print "ok 62\n"} else {print "not ok 62\n"} unless(Math::MPFR::_isobject($unblessed)) { print "ok 63\n"} else {print "not ok 63\n"} if(Math::MPFR::nnumflag() == 17) { print "ok 64\n" } else { warn "nnumflag(): expected 17, got ", Math::MPFR::nnumflag(), "\n"; print "not ok 64\n"; } Math::MPFR::clear_nnum(); if(Math::MPFR::nnumflag() == 0) { print "ok 65\n" } else { warn "nnumflag(): expected 0, got ", Math::MPFR::nnumflag(), "\n"; print "not ok 65\n"; } Math::MPFR::set_nnum(16); if(Math::MPFR::nnumflag() == 16) { print "ok 66\n" } else { warn "nnumflag(): expected 16, got ", Math::MPFR::nnumflag(), "\n"; print "not ok 66\n"; } # Check that Math::MPFR->new(6) <=> Math::MPFR->new() returns undef, # and also that the erangeflag is set. # Neither of these events occurred in 4.22 and (probably) earlier. Rmpfr_clear_erangeflag(); if(!Rmpfr_erangeflag_p()) { print "ok 67\n" } else { warn "erangeflag not cleared\n"; print "not ok 67\n"; } my $cmpflag = Math::MPFR->new(1) <=> Math::MPFR->new(); if(!defined($cmpflag)) { print "ok 68\n" } else { warn "comparison with NaN Math::MPFR object returned a defined value\n"; print "not ok 68\n"; } if(Rmpfr_erangeflag_p()) { print "ok 69\n" } else { warn "erangeflag not set\n"; print "not ok 69\n"; } my $obj0 = Math::MPFR->new(sqrt 2); my $obj1 = $obj0++; if($obj1 - $obj0 == -1) {print "ok 70\n"} else { warn "$obj1 is not 1 less than $obj0\n"; print "not ok 70\n"; } my $obj2 = ++$obj0; if($obj2 == $obj0) {print "ok 71\n"} else { warn "$obj2 != $obj0\n"; print "not ok 71\n"; } if($obj2 - $obj1 == 2) {print "ok 72\n"} else { warn "$obj2 is not 2 greater than $obj1\n"; print "not ok 72\n"; } sub adjust { if($_[0]) { if($_[0] > 0) { return 1} return -1; } return 0; } Math-MPFR-4.38/t/overloadex.t0000755060175106010010000000753614765756127014522 0ustar OwnerNone# log_2() and log_10() are implementations of log2() and log10() that, just # like the overloaded log() function, calculate their return value according # to default precision and default rounding mode. # # sind() and cosd() work just like the overloaded sin() and cos() functions # except that their argument is expressed in degrees, not radians. # # tangent() works just as you would expect the overloaded tan function to # work if such overloading was available. That is, the argument is in # radians and the return value is calculated to default precision using # default rounding mode. # # tand() works just like tangent(), except that the given argument is in # degrees. use strict; use warnings; use Math::MPFR qw(:mpfr); use Test::More; my $input_prec = 128; my $input = Rmpfr_init2($input_prec); my $check = Math::MPFR->new(); Rmpfr_set_ui($input, 45, MPFR_RNDN); Rmpfr_log2($check, $input, MPFR_RNDN); my $log_2 = log_2($input); cmp_ok($log_2, '==', $check, "log_2() ok"); cmp_ok(Rmpfr_get_prec($log_2), '==', 53, "log_2() prec ok"); Rmpfr_log10($check, $input, MPFR_RNDN); my $log_10 = log_10($input); cmp_ok($log_10, '==', $check, "log_10() ok"); cmp_ok(Rmpfr_get_prec($log_10), '==', 53, "log_10() prec ok"); if(Math::MPFR::MPFR_VERSION >= 262656) { my $sind = sind($input); cmp_ok($sind, '==', Math::MPFR->new(2) ** -0.5, "sind() ok"); cmp_ok(Rmpfr_get_prec($sind), '==', 53, "sind() prec ok"); } else { eval{my $sind = sind($input);}; like($@, qr/sind function requires mpfr\-4\.2\.0/, "sind function not available"); } if(Math::MPFR::MPFR_VERSION >= 262656) { my $cosd = cosd($input); cmp_ok($cosd, '==', Math::MPFR->new(2) ** -0.5, "cosd() ok"); cmp_ok(Rmpfr_get_prec($cosd), '==', 53, "cosd() prec ok"); } else { eval{my $cosd = cosd($input);}; like($@, qr/cosd function requires mpfr\-4\.2\.0/, "cosd function not available"); } if(Math::MPFR::MPFR_VERSION >= 262656) { my $tand = tand($input); cmp_ok($tand, '==', 1, "tand() ok"); cmp_ok(Rmpfr_get_prec($tand), '==', 53, "tand() prec ok"); for(1 .. 10) { my $v = rand(360); cmp_ok(abs(sind(Math::MPFR->new("$v"))), '==', abs(sind(Math::MPFR->new("-$v"))), "abs(sind($v) == abs(sind(-$v)"); cmp_ok(abs(cosd(Math::MPFR->new("$v"))), '==', abs(cosd(Math::MPFR->new("-$v"))), "abs(cosd($v) == abs(cosd(-$v)"); cmp_ok(abs(tand(Math::MPFR->new("$v"))), '==', abs(tand(Math::MPFR->new("-$v"))), "abs(tand($v) == abs(tand(-$v)"); } # Next 3 tests should pass because "380.75" and "20.75" are exactly representable in base 2 and differ by # exactly 360.0. cmp_ok(sind(Math::MPFR->new('380.75')), '==', sind(Math::MPFR->new('20.75')), 'sind(380.75) == sind(20.75)'); cmp_ok(cosd(Math::MPFR->new('380.75')), '==', cosd(Math::MPFR->new('20.75')), 'cosd(380.75) == cosd(20.75)'); cmp_ok(tand(Math::MPFR->new('380.75')), '==', tand(Math::MPFR->new('20.75')), 'tand(380.75) == tand(20.75)'); # The next 3 tests should pass because "404.8" & "44.8" are NOT exactly representable in base 2 and # (more to the point) 404.8 - 44.8 is not sufficiently close to 360.0 as to allow the respective # sind()/cosd()/tand() calculations to provide identical results. my $big = '404.8'; my $small = '44.8'; cmp_ok(sind(Math::MPFR->new($big)), '!=', sind(Math::MPFR->new($small)), "sind($big) != sind($small)"); cmp_ok(cosd(Math::MPFR->new($big)), '!=', cosd(Math::MPFR->new($small)), "cosd($big) != cosd($small)"); cmp_ok(tand(Math::MPFR->new($big)), '!=', tand(Math::MPFR->new($small)), "tand($big) != tand($small)"); } else { eval{my $tand = tand($input);}; like($@, qr/tand function requires mpfr\-4\.2\.0/, "tand function not available"); } my $pi = Math::MPFR->new(); Rmpfr_const_pi($pi, MPFR_RNDN); Rmpfr_tan($check, $pi / 2, MPFR_RNDN); my $tan = tangent($pi / 2); cmp_ok($tan, '==', $check, "tangent() ok"); cmp_ok(Rmpfr_get_prec($tan), '==', 53, "tangent() prec ok"); done_testing(); Math-MPFR-4.38/t/overload_cmp_q.t0000755060175106010010000000205514765756127015333 0ustar OwnerNoneuse strict; use warnings; use Math::MPFR; eval{require Math::GMPq;}; if($@) { warn "\n\$\@:$@\n"; warn "\n Skipping all tests - couldn't load Math::GMPq\n"; print "1..1\n"; print "ok 1\n"; exit 0; } print "1..8\n"; my $nan = Math::MPFR->new(); my $fop = Math::MPFR->new('10.3'); my $qop = Math::GMPq->new('5/1'); if($nan == $qop || $nan < $qop || $nan > $qop || $nan <= $qop || $nan >= $qop) {print "not ok 1\n"} else {print "ok 1\n"} if($nan != $qop) {print "ok 2\n"} else {print "not ok 2\n"} my $undef = $nan <=> $qop; if(!defined($undef)) {print "ok 3\n"} else {print "not ok 3\n"} if($fop == $qop) {print "not ok 4\n"} else {print "ok 4\n"} if($fop > $qop && $fop >= $qop && -$fop < $qop && -$fop <= $qop && $fop != $qop) {print "ok 5\n"} else {print "not ok 5\n"} my $def = $fop <=> $qop; if($def > 0) {print "ok 6\n"} else {print "not ok 6\n"} $def = -$fop <=> $qop; if($def < 0) {print "ok 7\n"} else {print "not ok 7\n"} $def = Math::MPFR->new(0.5) <=> Math::GMPq->new('1/2'); if($def == 0) {print "ok 8\n"} else {print "not ok 8\n"} Math-MPFR-4.38/t/overload_cmp_z.t0000755060175106010010000000204514765756127015343 0ustar OwnerNoneuse strict; use warnings; use Math::MPFR; eval{require Math::GMPz;}; if($@) { warn "\n\$\@:$@\n"; warn "\n Skipping all tests - couldn't load Math::GMPz\n"; print "1..1\n"; print "ok 1\n"; exit 0; } print "1..8\n"; my $nan = Math::MPFR->new(); my $fop = Math::MPFR->new('10.3'); my $zop = Math::GMPz->new(5); if($nan == $zop || $nan < $zop || $nan > $zop || $nan <= $zop || $nan >= $zop) {print "not ok 1\n"} else {print "ok 1\n"} if($nan != $zop) {print "ok 2\n"} else {print "not ok 2\n"} my $undef = $nan <=> $zop; if(!defined($undef)) {print "ok 3\n"} else {print "not ok 3\n"} if($fop == $zop) {print "not ok 4\n"} else {print "ok 4\n"} if($fop > $zop && $fop >= $zop && -$fop < $zop && -$fop <= $zop && $fop != $zop) {print "ok 5\n"} else {print "not ok 5\n"} my $def = $fop <=> $zop; if($def > 0) {print "ok 6\n"} else {print "not ok 6\n"} $def = -$fop <=> $zop; if($def < 0) {print "ok 7\n"} else {print "not ok 7\n"} $def = Math::MPFR->new(2.0) <=> Math::GMPz->new(2); if($def == 0) {print "ok 8\n"} else {print "not ok 8\n"} Math-MPFR-4.38/t/overload_cross_class.t0000755060175106010010000001475514765756127016564 0ustar OwnerNoneuse warnings; use strict; use Math::MPFR qw(:mpfr); print "1..3\n"; my $message = ''; my ($have_mpz, $have_mpf, $have_mpq) = (1, 1, 1); my ($rop, $op, $mpz, $mpf, $mpq, $mpz_power, $mpf_power, $mpq_power); $op = Math::MPFR->new(307.5); eval{require Math::GMPz;}; if($@) { $have_mpz = 0; $message .= " Math::GMPz - currently not installed\n"; } else { $mpz = Math::GMPz->new(10); $mpz_power = Math::GMPz->new(4); $message .= " Math::GMPz - we only have $Math::GMPz::VERSION\n" if $Math::GMPz::VERSION < 0.35; } eval{require Math::GMPf;}; if($@) { $have_mpf = 0; $message .= " Math::GMPf - currently not installed\n"; } else { $mpf = Math::GMPf->new(10.0); $mpf_power = Math::GMPf->new(4.0); $message .= " Math::GMPf - we only have $Math::GMPf::VERSION\n" if $Math::GMPf::VERSION < 0.35; } eval{require Math::GMPq;}; if($@) { $have_mpq = 0; $message .= " Math::GMPq - currently not installed\n"; } else { $mpq = Math::GMPq->new(10.0); $mpq_power = Math::GMPq->new(4); $message .= " Math::GMPq - we only have $Math::GMPq::VERSION\n" if $Math::GMPq::VERSION < 0.35; } if($message) { $message = "\n Version 0.35 (or later) of the following modules is needed for a more \n" . " complete implementation of cross_class overloading:\n" . $message; } warn "$message\n" if $message; my $ok = ''; if($have_mpz) { $rop = $op + $mpz; if(ref($rop) eq 'Math::MPFR'){$ok .= 'a'} else { warn "1a: ref: ", ref($rop), "\n"} if($rop == 317.5) {$ok .= 'b'} else {warn "1b: \$rop: $rop\n"} $rop = $op * $mpz; if(ref($rop) eq 'Math::MPFR'){$ok .= 'c'} else { warn "1c: ref: ", ref($rop), "\n"} if($rop == 3075) {$ok .= 'd'} else {warn "1d: \$rop: $rop\n"} $rop = $op - $mpz; if(ref($rop) eq 'Math::MPFR'){$ok .= 'e'} else { warn "1e: ref: ", ref($rop), "\n"} if($rop == 297.5) {$ok .= 'f'} else {warn "1f: \$rop: $rop\n"} $rop = $op / $mpz; if(ref($rop) eq 'Math::MPFR'){$ok .= 'g'} else { warn "1g: ref: ", ref($rop), "\n"} if($rop == 30.75) {$ok .= 'h'} else {warn "1h: \$rop: $rop\n"} ###################################### $rop = $op ** $mpz_power; if(ref($rop) eq 'Math::MPFR'){$ok .= 'i'} else { warn "1i: ref: ", ref($rop), "\n"} if($rop == 8940884414.0625) {$ok .= 'j'} else {warn "1j: \$rop: $rop\n"} $op += $mpz; if($op == 317.5) {$ok .= 'k'} else {warn "1k: \$op: $op\n"} $op -= $mpz; if($op == 307.5) {$ok .= 'l'} else {warn "1l: \$op: $op\n"} $op *= $mpz; if($op == 3075) {$ok .= 'm'} else {warn "1m: \$op: $op\n"} $op /= $mpz; if($op == 307.5) {$ok .= 'n'} else {warn "1n: \$op: $op\n"} $op **= $mpz_power; if($op == 8940884414.0625) {$ok .= 'o'} else {warn "1o: \$op: $op\n"} Rmpfr_set_d($op, 307.5, GMP_RNDN); # Restore to original value ###################################### if($ok eq 'abcdefghijklmno') {print "ok 1\n"} else { warn "\$ok: $ok\n"; print "not ok 1\n"; } } # close mpz else { warn "\nSkipping test 1 - no Math::GMPz\n"; print "ok 1\n"; } $ok = ''; if($have_mpf) { $rop = $op + $mpf; if(ref($rop) eq 'Math::MPFR'){$ok .= 'a'} else { warn "2a: ref: ", ref($rop), "\n"} if($rop == 317.5) {$ok .= 'b'} else {warn "2b: \$rop: $rop\n"} $rop = $op * $mpf; if(ref($rop) eq 'Math::MPFR'){$ok .= 'c'} else { warn "2c: ref: ", ref($rop), "\n"} if($rop == 3075) {$ok .= 'd'} else {warn "2d: \$rop: $rop\n"} $rop = $op - $mpf; if(ref($rop) eq 'Math::MPFR'){$ok .= 'e'} else { warn "2e: ref: ", ref($rop), "\n"} if($rop == 297.5) {$ok .= 'f'} else {warn "2f: \$rop: $rop\n"} $rop = $op / $mpf; if(ref($rop) eq 'Math::MPFR'){$ok .= 'g'} else { warn "2g: ref: ", ref($rop), "\n"} if($rop == 30.75) {$ok .= 'h'} else {warn "2h: \$rop: $rop\n"} ###################################### $rop = $op ** $mpf_power; if(ref($rop) eq 'Math::MPFR'){$ok .= 'i'} else { warn "2i: ref: ", ref($rop), "\n"} if($rop == 8940884414.0625) {$ok .= 'j'} else {warn "2j: \$rop: $rop\n"} $op += $mpf; if($op == 317.5) {$ok .= 'k'} else {warn "2k: \$op: $op\n"} $op -= $mpf; if($op == 307.5) {$ok .= 'l'} else {warn "2l: \$op: $op\n"} $op *= $mpf; if($op == 3075) {$ok .= 'm'} else {warn "2m: \$op: $op\n"} $op /= $mpf; if($op == 307.5) {$ok .= 'n'} else {warn "2n: \$op: $op\n"} $op **= $mpf_power; if($op == 8940884414.0625) {$ok .= 'o'} else {warn "2o: \$op: $op\n"} Rmpfr_set_d($op, 307.5, GMP_RNDN); # Restore to original value ###################################### if($ok eq 'abcdefghijklmno') {print "ok 2\n"} else { warn "\$ok: $ok\n"; print "not ok 2\n"; } } # close mpf else { warn "\nSkipping test 2 - no Math::GMPf\n"; print "ok 2\n"; } $ok = ''; if($have_mpq) { $rop = $op + $mpq; if(ref($rop) eq 'Math::MPFR'){$ok .= 'a'} else { warn "3a: ref: ", ref($rop), "\n"} if($rop == 317.5) {$ok .= 'b'} else {warn "3b: \$rop: $rop\n"} $rop = $op * $mpq; if(ref($rop) eq 'Math::MPFR'){$ok .= 'c'} else { warn "3c: ref: ", ref($rop), "\n"} if($rop == 3075) {$ok .= 'd'} else {warn "3d: \$rop: $rop\n"} $rop = $op - $mpq; if(ref($rop) eq 'Math::MPFR'){$ok .= 'e'} else { warn "3e: ref: ", ref($rop), "\n"} if($rop == 297.5) {$ok .= 'f'} else {warn "3f: \$rop: $rop\n"} $rop = $op / $mpq; if(ref($rop) eq 'Math::MPFR'){$ok .= 'g'} else { warn "3g: ref: ", ref($rop), "\n"} if($rop == 30.75) {$ok .= 'h'} else {warn "3h: \$rop: $rop\n"} ###################################### $rop = $op ** $mpq_power; if(ref($rop) eq 'Math::MPFR'){$ok .= 'i'} else { warn "3i: ref: ", ref($rop), "\n"} if($rop == 8940884414.0625) {$ok .= 'j'} else {warn "3j: \$rop: $rop\n"} $op += $mpq; if($op == 317.5) {$ok .= 'k'} else {warn "3k: \$op: $op\n"} $op -= $mpq; if($op == 307.5) {$ok .= 'l'} else {warn "3l: \$op: $op\n"} $op *= $mpq; if($op == 3075) {$ok .= 'm'} else {warn "3m: \$op: $op\n"} $op /= $mpq; if($op == 307.5) {$ok .= 'n'} else {warn "3n: \$op: $op\n"} $op **= $mpq_power; if($op == 8940884414.0625) {$ok .= 'o'} else {warn "3o: \$op: $op\n"} Rmpfr_set_d($op, 307.5, GMP_RNDN); # Restore to original value ###################################### if($ok eq 'abcdefghijklmno') {print "ok 3\n"} else { warn "\$ok: $ok\n"; print "not ok 3\n"; } } # close mpq else { warn "\nSkipping test 3 - no Math::GMPq\n"; print "ok 3\n"; } # Check that the &PL_sv_yes bug # does not rear its ugly head here # See https://github.com/sisyphus/math-decimal64/pull/1 sub hmmmm () {!0} sub aaarh () {!1} Math-MPFR-4.38/t/overload_float128.t0000755060175106010010000000472114765756127015576 0ustar OwnerNoneuse strict; use warnings; use Config; use Math::MPFR qw(:mpfr); if(!Math::MPFR::_can_pass_float128()) { print "1..1\n"; warn "\n Skipping all tests - can't pass __float128 type\n"; print "ok 1\n"; exit 0; } if($Config{nvtype} ne '__float128') { print "1..1\n"; warn "\n What the ... ?? This shouldn't be possible\n"; print "not ok 1\n"; exit 0; } my $t = 1; print "1..$t\n"; Rmpfr_set_default_prec(113); my $ok = ''; my $rop = Math::MPFR->new(2.13); if($rop == 2.13) {$ok .= 'a'} else {warn "\n Expected:2.13 Got $rop\n"} $rop = Math::MPFR->new(1.0); $rop += 2.13; if($rop == 3.13) {$ok .= 'b'} else {warn "\n Expected:3.13 Got $rop\n"} $rop -= 2.13; if($rop == 1.0) {$ok .= 'c'} else {warn "\n Expected:1.0 Got $rop\n"} $rop *= 2.13; if($rop == 2.13) {$ok .= 'd'} else {warn "\n Expected:2.13 Got $rop\n"} $rop /= 2.13; if($rop == 1.0) {$ok .= 'e'} else {warn "\n Expected:1.0 Got $rop\n"} my $rop1 = $rop + 1.13; if($rop1 == 2.13) {$ok .= 'f'} else {warn "\n Expected:2.13 Got $rop1\n"} $rop1 = $rop - 2.13; if($rop1 == -1.13) {$ok .= 'g'} else {warn "\n Expected:-0.13 Got $rop1\n"} $rop1 = $rop * 2.13; if($rop1 == 2.13) {$ok .= 'h'} else {warn "\n Expected:2.13 Got $rop1\n"} $rop += 1.13; if($rop == 2.13) {$ok .= 'i'} else {warn "\n Expected:2.13 Got $rop\n"} $rop1 = $rop / 2.13; if($rop1 == 1.0) {$ok .= 'j'} else {warn "\n Expected:1.0 Got $rop1\n"} $rop1 = 2.13 / $rop; if($rop1 == 1.0) {$ok .= 'k'} else {warn "\n Expected:1.0 Got $rop1\n"} $rop1 = 3.13 - $rop; if($rop1 == 1.0) {$ok .= 'l'} else {warn "\n Expected:1.0 Got $rop1\n"} if(!($rop <=> 2.13)) {$ok .= 'm'} else {warn "\n Expected:2.13 Got $rop\n"} if($rop != 2.14) {$ok .= 'n'} else {warn "\n Expected:2.13 Got $rop\n"} if($rop <= 2.14) {$ok .= 'o'} else {warn "\n Expected:2.13 Got $rop\n"} if($rop <= 2.13) {$ok .= 'p'} else {warn "\n Expected:2.13 Got $rop\n"} if($rop < 2.14) {$ok .= 'q'} else {warn "\n Expected:2.13 Got $rop\n"} if($rop > 2.12) {$ok .= 'r'} else {warn "\n Expected:2.13 Got $rop\n"} if($rop >= 2.12) {$ok .= 's'} else {warn "\n Expected:2.13 Got $rop\n"} if($rop >= 2.13) {$ok .= 't'} else {warn "\n Expected:2.13 Got $rop\n"} if($rop ** 2.13 == 2.13 ** $rop) {$ok .= 'u'} else {warn $rop ** 2.13, " != ", 2.13 ** $rop, "\n"} $rop1 = $rop; $rop1 **= 2.13; if($rop1 == 2.13 ** $rop) {$ok .= 'v'} else {warn $rop ** 2.13, " != ", 2.13 ** $rop, "\n"} if($ok eq 'abcdefghijklmnopqrstuv') {print "ok 1\n"} else { warn "\n\$ok: $ok\n"; print "not ok 1\n"; } Math-MPFR-4.38/t/overload_math_gmp.t0000755060175106010010000000403714765756127016032 0ustar OwnerNone# Test overloading of gmp objects. # The only gotcha here is that Math::GMP overloading of Math::MPFR objects does not work. # Therefore, while the following DWIMs: # $ perl -MMath::MPFR -MMath::GMP -le 'print "ok" if Math::MPFR->new(0) < Math::GMP->new(10);' # ok # the converse does not, and will crash in some cases: # $ perl -MMath::MPFR -MMath::GMP -le 'print "ok" if Math::GMP->new(10) > Math::MPFR->new(0);' # # That is, while Math::MPFR evaluates Math::GMP objects as intended, Math::MPFR objects are # meaningless to Math::GMP. # It is therefore up to the user to ensure that Math::MPFR is doing the overloading. # (It seems to me that all Math::MPFR objects will be evaluated by Math::GMP as being zero.) use strict; use warnings; use Math::MPFR qw(:mpfr); use Test::More; eval { require Math::GMP; }; if($@) { warn "\$\@: $@\n"; warn "Skipping all tests as Math::GMP could not be loaded\n"; is(1, 1); done_testing(); exit 0; } my $z = Math::GMP->new('1234' x 2); my $f = Math::MPFR->new(0); cmp_ok( $f, '<', $z, "'<' ok"); cmp_ok( $f, '<', $z, "'!=' ok"); cmp_ok( $f, '<=', $z, "'<=' ok"); cmp_ok( $f + $z, '==', $z, "'==' ok"); cmp_ok( $f + $z, '==', $z, "'>=' ok"); cmp_ok( $f += $z, '==', $z, "'+=' ok"); $f += $z; cmp_ok( $f, '>', $z, "'>' ok"); cmp_ok( $f - $z, '==', $z, "'-' ok"); $f -= $z; cmp_ok($f, '==', $z, "'-=' ok"); cmp_ok($f ** Math::GMP->new(2), '==', $z ** 2, "'**' ok"); $f **= Math::GMP->new(2); cmp_ok($f, '==', $z ** 2, "'**=' ok"); $f **= 0.5; cmp_ok($f * 5, '==', $z * 5, "'*' ok"); cmp_ok($f *= Math::GMP->new(5), '==', $z * 5, "'*=' ok"); cmp_ok($f / Math::GMP->new(5), '==', $z, "'/' ok"); cmp_ok($f /= Math::GMP->new(5), '==', $z, "'/=' ok"); Rmpfr_sprintf(my $buf, "%Zd", $z, 32); cmp_ok($buf, 'eq', "$z", "'%Zd' formatting ok"); Rmpfr_sprintf($buf, "%Zu", $z, 32); cmp_ok($buf, 'eq', "$z", "'%Zu' formatting ok"); Rmpfr_sprintf($buf, "%Zx", $z, 32); cmp_ok($buf, 'eq', 'bc4ff2', "'%Zx' formatting ok"); Rmpfr_sprintf($buf, "%ZX", $z, 32); cmp_ok($buf, 'eq', 'BC4FF2', "'%ZX' formatting ok"); done_testing(); Math-MPFR-4.38/t/overload_mod.t0000755060175106010010000001102514765756127015010 0ustar OwnerNoneuse strict; use warnings; use Math::MPFR qw(:mpfr); use Test::More; my $check = Math::MPFR->new(); my $rop = Math::MPFR->new(); for my $num('1234.7', '-1234.7', ~0, ~0 * -1) { for my $div('18.8', '-18.8') { $check = Math::MPFR->new($num) % Math::MPFR->new($div); Rmpfr_fmod($rop, Math::MPFR->new($num), Math::MPFR->new($div), MPFR_RNDN); cmp_ok($check, '==', $rop, "$num % $div ok"); } } my $nan = Math::MPFR->new(); my $ninf = Math::MPFR->new(); Rmpfr_set_inf($ninf, -1); my $pinf = -$ninf; $check = $nan % $nan; Rmpfr_fmod($rop, $nan, $nan, MPFR_RNDN); my $ok = 0; $ok = 1 if Rmpfr_nan_p($check) && Rmpfr_nan_p($rop); cmp_ok($ok, '==', 1, "NaN % NaN is NaN"); $check = $nan % 0; Rmpfr_fmod($rop, $nan, Math::MPFR->new(0), MPFR_RNDN); $ok = 0; $ok = 1 if Rmpfr_nan_p($check) && Rmpfr_nan_p($rop); cmp_ok($ok, '==', 1, "NaN % 0 is NaN"); $check = 1234 % $nan; Rmpfr_fmod($rop, Math::MPFR->new(1234), $nan, MPFR_RNDN); $ok = 0; $ok = 1 if Rmpfr_nan_p($check) && Rmpfr_nan_p($rop); cmp_ok($ok, '==', 1, "1234 % NaN is NaN"); $check = Math::MPFR->new(1234) % 0; Rmpfr_fmod($rop, Math::MPFR->new(1234), $nan, MPFR_RNDN); $ok = 0; $ok = 1 if Rmpfr_nan_p($check) && Rmpfr_nan_p($rop); cmp_ok($ok, '==', 1, "1234 % 0 is NaN"); $check = $pinf % $pinf; Rmpfr_fmod($rop, $pinf, $pinf, MPFR_RNDN); $ok = 0; $ok = 1 if Rmpfr_nan_p($check) && Rmpfr_nan_p($rop); cmp_ok($ok, '==', 1, "Inf % Inf is NaN"); $check = $pinf % 0; Rmpfr_fmod($rop, $pinf, Math::MPFR->new(0), MPFR_RNDN); $ok = 0; $ok = 1 if Rmpfr_nan_p($check) && Rmpfr_nan_p($rop); cmp_ok($ok, '==', 1, "Inf % 0 is NaN"); $check = 1234.5 % $pinf; Rmpfr_fmod($rop, Math::MPFR->new(1234.5), $pinf, MPFR_RNDN); cmp_ok($check, '==', $rop, "1234.5 % Inf is $rop"); $check = $ninf % $ninf; Rmpfr_fmod($rop, $ninf, $ninf, MPFR_RNDN); $ok = 0; $ok = 1 if Rmpfr_nan_p($check) && Rmpfr_nan_p($rop); cmp_ok($ok, '==', 1, "-Inf % -Inf is NaN"); $check = $ninf % 0; Rmpfr_fmod($rop, $ninf, Math::MPFR->new(0), MPFR_RNDN); $ok = 0; $ok = 1 if Rmpfr_nan_p($check) && Rmpfr_nan_p($rop); cmp_ok($ok, '==', 1, "-Inf % 0 is NaN"); $check = 1234.5 % $ninf; Rmpfr_fmod($rop, Math::MPFR->new(1234.5), $ninf, MPFR_RNDN); cmp_ok($check, '==', $rop, "1234.5 % -Inf is $rop"); eval { require Math::GMPz; }; if(!$@) { if($Math::GMPz::VERSION >= 0.63) { for(1 .. 100) { my($x, $y) = ( int(rand(3000)) + 1000, int(rand(2000))); my $f1 = Math::MPFR->new($x); my $f2 = Math::MPFR->new($y); my $z1 = Math::GMPz->new($y); my $z2 = Math::GMPz->new($x); if(Rmpfr_nan_p($f1 % $z1) && Rmpfr_nan_p($z2 % $f2)) { cmp_ok(1, '==', 1, "X % Y is not dependent on type") } else { cmp_ok( $f1 % $z1, '==', $z2 % $f2, "X % Y is not dependent on type"); } cmp_ok(ref($f1 % $z1), 'eq', 'Math::MPFR', "'%' returns Math::MPFR object"); cmp_ok(ref($f1 % $z1), 'eq', ref($z2 % $f2), "X % Y always returns Math::MPFR object"); $z1 %= $f1; $f2 %= $z2; cmp_ok( $z1, '==', $f2, "X %= Y is not dependent on type"); cmp_ok(ref($z1), 'eq', 'Math::MPFR', "'%=' returns Math::MPFR object"); cmp_ok(ref($z1), 'eq', ref($f2), "X %= Y always returns Math::MPFR object"); } } else { warn "Skipping Math::GMPz tests - Math-GMPz-0.63 or later is require; have only $Math::GMPz::VERSION" } } else { warn "Skipping Math::GMPz tests - couldn't load Math::GMPz" } eval { require Math::GMPq; }; if(!$@) { if($Math::GMPq::VERSION >= 0.58) { my $q = Math::GMPq->new('23/2'); my $f = Math::MPFR->new('201.5'); my $alt = Math::MPFR->new('201.5'); cmp_ok(ref($f % $q), 'eq', 'Math::MPFR', "'%' returned a Math::MPFR object, as expected"); cmp_ok($f % $q, '==', 6, "201.5 % (23/2) returns 6"); $alt %= $q; cmp_ok(ref($alt), 'eq', 'Math::MPFR', "'%=' returned a Math::MPFR object, as expected"); cmp_ok($alt, '==', 6, "201.5 %= (23/2) returns 6"); $q *= 100.5; # 4623/4 == 1155.75 cmp_ok($q, '==', 1155.75, "value of Math::GMPq object is 1155.75 (4623/4)"); my $f_mod = $q % $f; cmp_ok(ref($f_mod), 'eq', 'Math::MPFR', "'%' (switched) : returns Math::MPFR object"); cmp_ok($f_mod, '==', 148.25, "'%' (switched) : returns correct value (148.25)"); $q %= $f; cmp_ok(ref($q), 'eq', 'Math::MPFR', "'%=' (switched) : returns Math::MPFR object"); cmp_ok($q, '==', 148.25, "'%=' (switched) : returns correct value (148.25)"); } else { warn "Skipping Math::GMPzqtests - Math-GMPq-0.58 or later is require; have only $Math::GMPq::VERSION" } } else { warn "Skipping Math::GMPq tests - couldn't load Math::GMPq" } done_testing(); Math-MPFR-4.38/t/overload_shift.t0000755060175106010010000001055614765756127015356 0ustar OwnerNone # Performing shift operations on floating-point types is not # permitted under IEEE standards. # Here, we simply overload the '<<' and '>>' operators to # increase/decrease the exponent by the given "shift" amount. # Effectively, we are multiplying/dividing the value held in # the Math::MPFR object by 2**$hift. # This is precisely what happens when we left-shift/right-shift # an integer value. use strict; use warnings; use Math::MPFR qw(:mpfr); use Math::BigFloat; # Aiming to emulate Math::BigFloat in Math::MPFR. use Config; use Test::More; my $f = Math::MPFR->new() << 10; cmp_ok(Rmpfr_nan_p($f), '!=', 0, "NaN << returns NaN"); $f = Math::MPFR->new() >> 10; cmp_ok(Rmpfr_nan_p($f), '!=', 0, "NaN >> returns NaN"); $f <<= 10; cmp_ok(Rmpfr_nan_p($f), '!=', 0, "NaN <<= returns NaN"); $f >>= 10; cmp_ok(Rmpfr_nan_p($f), '!=', 0, "NaN <<= returns NaN"); Rmpfr_set_inf($f, 0); my $n = $f << 10; cmp_ok(Rmpfr_inf_p($n), '!=', 0, "+Inf << returns Inf"); cmp_ok($n, '>', 0, "+Inf << returns +Inf"); $n = $f >> 10; cmp_ok(Rmpfr_inf_p($n), '!=', 0, "+Inf >> returns Inf"); cmp_ok($n, '>', 0, "+Inf >> returns +Inf"); $f <<= 10; cmp_ok(Rmpfr_inf_p($f), '!=', 0, "+Inf <<= returns Inf"); cmp_ok($f, '>', 0, "+Inf <<= returns +Inf"); $f >>= 10; cmp_ok(Rmpfr_inf_p($f), '!=', 0, "+Inf >>= returns Inf"); cmp_ok($f, '>', 0, "-Inf >>= returns +Inf"); my $fneg = Math::MPFR->new(); Rmpfr_set_inf($fneg, -1); ########################## $n = $fneg << 10; cmp_ok(Rmpfr_inf_p($n), '!=', 0, "-Inf << returns Inf"); cmp_ok($n, '<', 0, "-Inf << returns -Inf"); $n = $fneg >> 10; cmp_ok(Rmpfr_inf_p($n), '!=', 0, "-Inf >> returns Inf"); cmp_ok($n, '<', 0, "-Inf >> returns -Inf"); $fneg <<= 10; cmp_ok(Rmpfr_inf_p($f), '!=', 0, "-Inf <<= returns Inf"); cmp_ok($fneg, '<', 0, "-Inf <<= returns -Inf"); $fneg >>= 10; cmp_ok(Rmpfr_inf_p($f), '!=', 0, "-Inf >>= returns Inf"); cmp_ok($fneg, '<', 0, "-Inf >>= returns -Inf"); Rmpfr_set_NV($f, 0.0, MPFR_RNDN); $n = $f << 10; cmp_ok(Rmpfr_zero_p($f), '!=', 0, "'<<' 0 results in 0"); $n = $f >> 10; cmp_ok(Rmpfr_zero_p($f), '!=', 0, "'>>' 0 results in 0"); my $samples = 10; my($mpfr_res, $mbf_res); my @values; for(1 .. $samples) {push @values, rand(10000)} my @shifts; for(1 .. $samples) {push @shifts, int(rand(40)) - 20} $samples--; for my $i(0 .. $samples) { my $obj = Math::MPFR->new($values[$i]); my $mbf = Math::BigFloat->new($values[$i]); my $shift = $shifts[$i]; cmp_ok($obj << $shift, '==', $obj >> -$shift, "A: $obj: handled consistently by << and >>"); cmp_ok($obj << -$shift, '==', $obj >> $shift, "B: $obj: handled consistently by << and >>"); if($] >= 5.04) { $mpfr_res = $obj << $shift; $mbf_res = $mbf << $shift; cmp_ok("$mpfr_res", '==', "$mbf_res", "<<: Math::BigFloat and Math::MPFR concur"); $mpfr_res = $obj >> $shift; $mbf_res = $mbf >> $shift; cmp_ok("$mpfr_res", '==', "$mbf_res", ">>: Math::BigFloat and Math::MPFR concur"); } my($x, $y) = ($obj + 10, $obj + 10); $x <<= $shift; $y >>= -$shift; cmp_ok($x, '==', $y, "A: $obj: handled consistently by <<= and >>="); $x <<= -$shift; $y >>= $shift; cmp_ok($x, '==', $y, "B: $obj: handled consistently by <<= and >>="); } cmp_ok(Math::MPFR->new(-401.3) >> 1.8, '==', -201, "-401.3 >> 1.8 == -201"); cmp_ok(Math::MPFR->new(-401.3) >> 1.8, '==', -201, "-401.3 << -1.8 == -201"); eval { my $discard = 2 >> Math::MPFR->new(7);}; like($@, qr/argument that specifies the number of bits to be/, "switched overload throws expected error"); eval {my $discard = $f >> Math::BigFloat->new(7);}; like($@, qr/argument that specifies the number of bits to be/, "Math::BigFloat shift arg throws expected error with '>>'"); eval {$f <<= Math::BigInt->new(7);}; like($@, qr/argument that specifies the number of bits to be/, "Math::BigFloat shift arg throws expected error with '<<='"); if($Config{longsize} < $Config{ivsize}) { eval { my $discard = $f >> ~0;}; like ( $@, qr/In Math::MPFR overloading of '>>' operator,/, "mp_bitcnt_t overflow is caught in '>>'"); eval { my $discard = $f << ~0;}; like ( $@, qr/In Math::MPFR overloading of '<<' operator,/, "mp_bitcnt_t overflow is caught in '<<'"); eval { $f >>= ~0;}; like ( $@, qr/In Math::MPFR overloading of '>>=' operator,/, "mp_bitcnt_t overflow is caught in '>>='"); eval { $f <<= ~0;}; like ( $@, qr/In Math::MPFR overloading of '<<=' operator,/, "mp_bitcnt_t overflow is caught in '<<='"); } done_testing(); Math-MPFR-4.38/t/overload_switch.t0000755060175106010010000000244214765756127015535 0ustar OwnerNone# This file created in response to: # https://github.com/sisyphus/math-decimal64/pull/1, # which also applies to Math::MPFR # Thanks to @hiratara use strict; use warnings; use Math::MPFR; use Test::More; END { done_testing(); }; my $two = Math::MPFR->new(2); cmp_ok($two - 7, '==', -5, "Math::MPFR object - IV"); cmp_ok(5 - $two, '==', 3, "IV - Math::MPFR object"); cmp_ok($two / 2, '==', 1, "Math::MPFR object / IV"); cmp_ok(8 / $two, '==', 4, "IV / Math::MPFR object"); cmp_ok($two ** 6, '==', 64, "Math::MPFR object ** IV"); cmp_ok(6 ** $two, '==', 36, "IV ** Math::MPFR object"); cmp_ok($two, '>', 1, "Math::MPFR object > IV"); cmp_ok(4, '>', $two, "IV > Math::MPFR object"); cmp_ok($two, '>=', 1, "Math::MPFR object >= IV"); cmp_ok(4, '>=', $two, "IV >= Math::MPFR object"); cmp_ok($two, '<', 6, "Math::MPFR object < IV"); cmp_ok(-4, '<', $two, "IV < Math::MPFR object"); cmp_ok($two, '<=', 6, "Math::MPFR object <= IV"); cmp_ok(-4, '<=', $two, "IV <= Math::MPFR object"); cmp_ok($two <=> 6, '<', 0, "Math::MPFR object <=> IV"); cmp_ok(6 <=> $two, '>', 0, "IV <=> Math::MPFR object"); # These next 2 subs will cause failures here on perl-5.20.0 # and later if &PL_sv_yes or &PL_sv_no is encountered in the # overload sub. sub foo () {!0} # Breaks PL_sv_yes sub bar () {!1} # Breaks PL_sv_no Math-MPFR-4.38/t/pod.t0000755060175106010010000000047014765756127013122 0ustar OwnerNoneeval "use Test::Pod 1.00"; if($@) { print "1..1\n"; warn "Skipping test 1 - no recent version of Test::Pod installed\n"; print "ok 1\n"; } else { warn "\nTest::Pod version: $Test::Pod::VERSION\n"; warn "\nPod::Simple version: $Pod::Simple::VERSION\n"; Test::Pod::all_pod_files_ok(); } Math-MPFR-4.38/t/printf.t0000755060175106010010000002362114765756127013645 0ustar OwnerNoneuse warnings; use strict; use Math::BigInt; use Math::MPFR qw(:mpfr); use Config; # Because of the way I (sisyphus) build this module with MS # Visual Studio, XSubs that take a filehandle argument might # not work correctly. It therefore suits my purposes to be # able to avoid calling (and testing) those XSubs. # Hence the references to $ENV{SISYPHUS_SKIP} in this script. my $tests = 7; $tests = 5 if ($ENV{SISYPHUS_SKIP} || $Config{nvtype} eq '__float128'); print "1..$tests\n"; print "# Using Math::MPFR version ", $Math::MPFR::VERSION, "\n"; print "# Using mpfr library version ", MPFR_VERSION_STRING, "\n"; print "# Using gmp library version ", Math::MPFR::gmp_v(), "\n"; Rmpfr_set_default_prec(80); my $ok = ''; my $buf; my $copy = $buf; my $ul = 123; my $ret; my $mpfr1 = Math::MPFR->new(1234567.625); $ret = Rmpfr_printf("For testing: %.30Rf\n", $mpfr1); if($ret == 52) {$ok .= 'a'} else {warn "1a: $ret\n"} $ok .= 'b' if $ret == Rmpfr_printf("For testing: %.30RNf\n", $mpfr1); $ok .= 'c' if $ret == Rmpfr_printf("For testing: %.30R*f\n", GMP_RNDN, $mpfr1); unless($ENV{SISYPHUS_SKIP}) { $ok .= 'd' if $ret == Rmpfr_fprintf(\*STDOUT, "For testing: %.30Rf\n", $mpfr1); $ok .= 'e' if $ret == Rmpfr_fprintf(\*STDOUT, "For testing: %.30RNf\n", $mpfr1); $ok .= 'f' if $ret == Rmpfr_fprintf(\*STDOUT, "For testing: %.30R*f\n", GMP_RNDZ, $mpfr1); } $ok .= 'g' if $ret == Rmpfr_sprintf($buf, "For testing: %.30Rf\n", $mpfr1, 200); $ok .= 'h' if $ret == Rmpfr_sprintf($buf, "For testing: %.30RNf\n", $mpfr1, 200); $ok .= 'i' if $ret == Rmpfr_sprintf($buf, "For testing: %.30R*f\n", GMP_RNDN, $mpfr1, 60); if(length($buf) == 52) {$ok .= 'j'} else {warn "length \$buf: ", length($buf), "\n"} Math::MPFR::_readonly_on($buf); eval {Rmpfr_sprintf($buf, "For testing: %.30R*f\n", GMP_RNDN, $mpfr1, 200);}; if($@ =~ /Modification of a read-only value attempted/) {$ok .= 'k'} else { warn "\n1k: \$\@: $@\n"} Math::MPFR::_readonly_off($buf); Rmpfr_sprintf($buf, "For testing: %.30Rf\n", $mpfr1, 200); $ok .= 'm' if "For testing: 1234567.625000000000000000000000000000\n" eq $buf; Rmpfr_sprintf($buf, "For testing: %.30RNf\n", $mpfr1, 200); $ok .= 'n' if "For testing: 1234567.625000000000000000000000000000\n" eq $buf; Rmpfr_sprintf($buf, "For testing: %.30R*f\n", GMP_RNDU, $mpfr1, 200); $ok .= 'o' if "For testing: 1234567.625000000000000000000000000000\n" eq $buf; Rmpfr_sprintf($buf, "For some more testing: %.30Rf\n", $mpfr1, 200); $ok .= 'p' if "For some more testing: 1234567.625000000000000000000000000000\n" eq $buf; Rmpfr_sprintf($buf, "For some more testing: %.30RNf\n", $mpfr1, 200); $ok .= 'q' if "For some more testing: 1234567.625000000000000000000000000000\n" eq $buf; Rmpfr_sprintf($buf, "For some more testing: %.30R*f\n", GMP_RNDN, $mpfr1, 200); $ok .= 'r' if "For some more testing: 1234567.625000000000000000000000000000\n" eq $buf; Rmpfr_sprintf ($buf, "%Pu\n", prec_cast(Rmpfr_get_prec($mpfr1)), 200); if($buf == 80) {$ok .= 's'} else {warn "1s: $buf\n"} Rmpfr_sprintf($buf, "%.30Rb\n", $mpfr1, 200); if(lc($buf) eq "1.001011010110100001111010000000p+20\n") {$ok .= 't'} else {warn "1t: $buf\n"} Rmpfr_sprintf($buf, "%.30RNb\n", $mpfr1, 200); if(lc($buf) eq "1.001011010110100001111010000000p+20\n") {$ok .= 'u'} else {warn "1u: $buf\n"} Rmpfr_sprintf($buf, "%.30R*b\n", GMP_RNDD, $mpfr1, 200); if(lc($buf) eq "1.001011010110100001111010000000p+20\n") {$ok .= 'v'} else {warn "1v: $buf\n"} $ret = Rmpfr_printf("hello world", 0); if($ret == 11) {$ok .= 'w'} else {warn "1w: $ret\n"} $ret = Rmpfr_printf("$ul", 0); if($ret == 3) {$ok .= 'x'} else {warn "1x: $ret\n"} unless($ENV{SISYPHUS_SKIP}) { $ret = Rmpfr_fprintf(\*STDOUT, "hello world", 0); if($ret == 11) {$ok .= 'y'} else {warn "1y: $ret\n"} $ret = Rmpfr_fprintf(\*STDOUT, "$ul", 0); if($ret == 3) {$ok .= 'z'} else {warn "1z: $ret\n"} } $ret = Rmpfr_sprintf($buf, "hello world", 0, 15); if($ret == 11) {$ok .= 'A'} else {warn "1A: $ret\n"} if($buf eq 'hello world') {$ok .= 'B'} else {warn "1B: $buf\n"} $ret = Rmpfr_sprintf($buf, "$ul", 0, 5); if($ret == 3) {$ok .= 'C'} else {warn "\n1C: $ret $buf\n"} if($buf eq "123") {$ok .= 'D'} else {warn "\n1D: $buf\n"} if(!$copy) {$ok .= 'E'} else { warn "\n1l: \$copy: $copy\n"; } Rmpfr_printf("\n", 0); # Otherwise Test::Harness gets confused my $expected = $ENV{SISYPHUS_SKIP} ? 'abcghijkmnopqrstuvwxABCDE' : 'abcdefghijkmnopqrstuvwxyzABCDE'; if($ok eq $expected) {print "ok 1\n"} else { warn "got: $ok\n"; print "not ok 1 $ok\n"; } $ok = ''; my $mbi = Math::BigInt->new(123); eval {Rmpfr_printf("%RNd", $mbi);}; if($@ =~ /Unrecognised object/) {$ok .= 'a'} else {warn "2a got: $@\n"} unless($ENV{SISYPHUS_SKIP}) { eval {Rmpfr_fprintf(\*STDOUT, "%RDd", $mbi);}; if($@ =~ /Unrecognised object/) {$ok .= 'b'} else {warn "2b got: $@\n"} } eval {Rmpfr_sprintf($buf, "%RNd", $mbi, 200);}; if($@ =~ /Unrecognised object/) {$ok .= 'c'} else {warn "2c got: $@\n"} # no longer have Rmpfr_sprintf_ret(). #eval {Rmpfr_sprintf_ret("%RUd", $mbi, 200);}; #if($@ =~ /Unrecognised object/) {$ok .= 'd'} #else {warn "2d got: $@\n"} $ok .= 'd'; unless($ENV{SISYPHUS_SKIP}) { eval {Rmpfr_fprintf(\*STDOUT, "%R*d", GMP_RNDN, $mbi, $ul);}; if($@ =~ /must take 3 or 4 arguments/) {$ok .= 'e'} else {warn "2e got: $@\n"} } eval {Rmpfr_sprintf($buf, "%R*d", GMP_RNDN, $mbi, $ul, 50);}; if($@ =~ /must take 4 or 5 arguments/) {$ok .= 'f'} else {warn "2f got: $@\n"} eval {Rmpfr_sprintf("%RNd", $mbi);}; if($@ =~ /must take 4 or 5 arguments/) {$ok .= 'g'} else {warn "2g got: $@\n"} unless($ENV{SISYPHUS_SKIP}) { eval {Rmpfr_fprintf(\*STDOUT, "%R*d", 4, $mbi);}; if(MPFR_VERSION_MAJOR >= 3) { if($@ =~ /Unrecognised object supplied/) {$ok .= 'h'} else {warn "2h got: $@\n"} } else { if($@ =~ /Invalid 3rd argument/) {$ok .= 'h'} else {warn "2h got: $@\n"} } } eval {Rmpfr_sprintf("%R*d", 4, $mbi, 50);}; # Changed in response to http://www.cpantesters.org/cpan/report/2c6e2406-6bf5-1014-981d-364b06b49268 # which used mpfr-2.4.2 #if(MPFR_VERSION_MAJOR >= 3) { if($@ =~ /Unrecognised object supplied/) {$ok .= 'i'} else {warn "2i got: $@\n"} #} #else { # if($@ =~ /Invalid 3rd argument/) {$ok .= 'i'} # else {warn "2i got: $@\n"} #} eval {Rmpfr_printf("%R*d", 4, $mbi);}; if(MPFR_VERSION_MAJOR >= 3) { if($@ =~ /Unrecognised object supplied/) {$ok .= 'j'} else {warn "2j got: $@\n"} } else { if($@ =~ /Invalid 2nd argument/) {$ok .= 'j'} else {warn "2j got: $@\n"} } $expected = $ENV{SISYPHUS_SKIP} ? 'acdfgij' : 'abcdefghij'; if($ok eq $expected) {print "ok 2\n"} else {print "not ok 2 $ok\n"} # $mpfr1 contains the value 1.234567625e6. $ok = ''; $ret = Rmpfr_snprintf($buf, 5, "%.0Rf", $mpfr1, 10); if($buf eq '1234' && $ret == 7) {$ok .= 'a'} else {warn "3a: $buf $ret\n"} $ret = Rmpfr_snprintf($buf, 6, "%.0Rf", $mpfr1, 10); if($ret == 7) {$ok .= 'b'} else {warn "3b: $ret\n"} if($buf eq '12345') {$ok .= 'c'} else {warn "3c: $buf\n"} if($ok eq 'abc') {print "ok 3\n"} else {print "not ok 3\n"} $ok = ''; $ret = Rmpfr_snprintf($buf, 7, "%.0R*f", GMP_RNDD, $mpfr1, 10); if($buf eq '123456' && $ret == 7) {$ok .= 'a'} else {warn "4a: $ret\n"} #Rmpfr_printf("%.0R*f", GMP_RNDD, $mpfr1); $ret = Rmpfr_snprintf($buf, 6, "%.0R*f", GMP_RNDD, $mpfr1 / 10, 10); #Rmpfr_printf("%.0R*f", GMP_RNDD, $mpfr1 / 10); if($ret == 6) {$ok .= 'b'} else {warn "4b: $ret\n"} if($buf eq '12345') {$ok .= 'c'} else {warn "4c: $buf\n"} if($ok eq 'abc') {print "ok 4\n"} else { warn "4: \$ok: $ok\n"; print "not ok 4\n"; } $ok = ''; unless($ENV{SISYPHUS_SKIP}) { eval{Rmpfr_fprintf(\*STDOUT, "%Pu\n", GMP_RNDN, 123);}; if($@ =~ /In Rmpfr_fprintf: The rounding argument is specific to Math::MPFR objects/) {$ok .= 'a'} else {warn "\n5a: \$\@: $@\n"} } eval{Rmpfr_sprintf ($buf, "%Pu\n", GMP_RNDN, 123, 100);}; if($@ =~ /In Rmpfr_sprintf: The rounding argument is specific to Math::MPFR objects/) {$ok .= 'b'} else {warn "\n5b: \$\@: $@\n"} eval{Rmpfr_snprintf ($buf, 10, "%Pu\n", GMP_RNDN, 123, 100);}; if($@ =~ /In Rmpfr_snprintf: The rounding argument is specific to Math::MPFR objects/) {$ok .= 'c'} else {warn "\n5c: \$\@: $@\n"} $expected = $ENV{SISYPHUS_SKIP} ? 'bc' : 'abc'; if($ok eq $expected) {print "ok 5\n"} else { warn "5: \$ok: $ok\n"; print "not ok 5\n"; } # The following are mainly aimed at checking WIN32_FMT_BUG workaround: unless($ENV{SISYPHUS_SKIP}) { if($Config{nvsize} == 8) { my $ret = Rmpfr_fprintf(\*STDOUT, "For testing %%a formatting: %a\n", sqrt(2.0)); #print "RET: $ret\n"; if($ret == 48) {print "ok 6\n"} else { warn "Expected 48 but got $ret\n"; print "not ok 6\n"; } $ret = Rmpfr_fprintf(\*STDOUT, "For testing %%A formatting: %A\n", sqrt(2.0)); if($ret == 48) {print "ok 7\n"} else { warn "Expected 48 but got $ret\n"; print "not ok 7\n"; } } elsif($Config{nvtype} ne '__float128') { if(length(sqrt(2.0)) < 25) { # 80-bit extended precision long double my $ret = Rmpfr_fprintf(\*STDOUT, "For testing %%La formatting: %La\n", sqrt(2.0)); #print "RET: $ret\n"; if($ret == 51 || $ret == 52) {print "ok 6\n"} else { warn "Expected 51 or 52 but got $ret\n"; print "not ok 6\n"; } $ret = Rmpfr_fprintf(\*STDOUT, "For testing %%LA formatting: %LA\n", sqrt(2.0)); if($ret == 51 || $ret == 52) {print "ok 7\n"} else { warn "Expected 51 or 52 but got $ret\n"; print "not ok 7\n"; } } else { # IEEE 754 long double my $ret = Rmpfr_fprintf(\*STDOUT, "For testing %%La formatting: %La\n", sqrt(2.0)); #print "RET: $ret\n"; if($ret == 64) {print "ok 6\n"} else { warn "Expected 64 but got $ret\n"; print "not ok 6\n"; } $ret = Rmpfr_fprintf(\*STDOUT, "For testing %%LA formatting: %LA\n", sqrt(2.0)); if($ret == 64) {print "ok 7\n"} else { warn "Expected 64 but got $ret\n"; print "not ok 7\n"; } } } } __END__ Math-MPFR-4.38/t/PV_NV_BUG.t0000755060175106010010000000645714765756127014000 0ustar OwnerNone# Check that scalars that are (or might be) # both POK and NOK are being handled correctly. use strict; use warnings; use Math::MPFR qw(:mpfr); *_ITSA = \&Math::MPFR::_itsa; use Test::More; warn "\n MPFR_PV_NV_BUG set to ", MPFR_PV_NV_BUG, "\n"; warn " The string 'nan' apparently numifies to zero\n" if 'nan' + 0 == 0; # Check that both the perl environment and the XS # environment agree on whether the problem is present. cmp_ok(MPFR_PV_NV_BUG, '==', Math::MPFR::_has_pv_nv_bug(), "Perl environment and XS environment agree"); # Test 1 my $nv_1 = 1.3; my $s = "$nv_1"; cmp_ok(_ITSA($nv_1), '==', 3, "NV slot will be used"); # Test 2 my $nv_2 = '1.7'; if($nv_2 > 1) { # True cmp_ok(_ITSA($nv_2), '==', 4, "PV slot will be used"); # Test 3 } my $pv_finite = '5e5000'; if($pv_finite > 0) { # True my $fr = Math::MPFR->new($pv_finite); cmp_ok("$fr", 'eq', '5.0000000000000002e5000', "'5e5000' is not an Inf"); # Test 4 } if('nan' + 0 != 'nan' + 0) { # Skip if numification of # 'nan' fails to DWIM my $pv_nan = 'nan'; if($pv_nan != 42) { # True my $fr = Math::MPFR->new($pv_nan); cmp_ok(Rmpfr_nan_p($fr), '!=', 0, "NaN Math::MPFR object was created"); # Test 5 } } else { # Instead verify that 'nan' numifies to zero cmp_ok('nan' + 0, '==', 0, "'nan' numifies to zero"); # Test 5 alt. } if('inf' + 0 > 0) { # Skip if numification of # 'inf' fails to DWIM my $pv_inf = 'inf'; if($pv_inf > 0) { # True my $fr = Math::MPFR->new($pv_inf); cmp_ok(Rmpfr_inf_p($fr), '!=', 0, "Inf Math::MPFR object was created"); # Test 6 } } else { # Instead verify that 'inf' numifies to zero cmp_ok('inf' + 0, '==', 0, "'inf' numifies to zero"); # Test 6 alt. } my $nv_inf = Rmpfr_get_NV(Math::MPFR->new('Inf'), MPFR_RNDN); $s = "$nv_inf"; cmp_ok(Rmpfr_inf_p(Math::MPFR->new($nv_inf)), '!=', 0, "Inf Math::MPFR object was created"); # Test 7 my $nv_nan = Rmpfr_get_NV(Math::MPFR->new(), MPFR_RNDN); $s = "$nv_nan"; cmp_ok(Rmpfr_nan_p(Math::MPFR->new($nv_nan)), '!=', 0, "NaN Math::MPFR object was created"); # Test 8 Rmpfr_set_default_prec($Math::MPFR::NV_properties{bits}); my $mpfr_sqrt = sqrt(Math::MPFR->new(2)); my $perl_sqrt = Rmpfr_get_NV($mpfr_sqrt, MPFR_RNDN); # sqrt(2) as NV my $str = "$perl_sqrt"; # sqrt(2) as decimal string, rounded twice. if($str > 0) { cmp_ok(_ITSA($str), '==', 4, "Correctly designated a PV"); # Test 9 cmp_ok(_ITSA($perl_sqrt), '==', 3, "Correctly designated as an NV"); # Test 10 } my $nv_sqrt = sqrt(2); my $str_sqrt = "$nv_sqrt"; # The next 4 tests should fail if the value # in the PV slot of $nv_sqrt is used. cmp_ok(Math::MPFR->new(1) * $nv_sqrt, '==', sqrt(2), "overload_mul() uses value in NV slot"); # Test 11 cmp_ok(Math::MPFR->new(0) + $nv_sqrt, '==', sqrt(2), "overload_add() uses value in NV slot"); # Test 12 cmp_ok(Math::MPFR->new(0) - $nv_sqrt, '==', -(sqrt(2)), "overload_sub() uses value in NV slot"); # Test 13 cmp_ok(Math::MPFR->new(sqrt 2) / $nv_sqrt, '==', 1.0, "overload_div() uses value in NV slot"); # Test 14 done_testing(); Math-MPFR-4.38/t/P_specifier.t0000755060175106010010000000543714765756127014600 0ustar OwnerNoneuse strict; use warnings; use Math::MPFR qw(:mpfr); print "1..6\n"; my $prec = 100009; my ($fh, $RD); my $file = 'p_spec.txt'; my $ok = ''; my $bytes = 7; eval{Rmpfr_printf("hello world\n", 0);}; if($@) { warn "1a: \$\@: $@\n"; } else {$ok .= 'a'}; eval{Rmpfr_printf("%Pu\n", 0, 0);}; if($@ =~ /In Rmpfr_printf: The rounding argument is specific to Math::MPFR objects/) { $ok .= 'b' } else {warn "1b: \$\@: $@\n"}; eval{Rmpfr_printf("%Pu\n", prec_cast($prec));}; if($@) { warn "1c: \$\@: $@\n"; } else {$ok .= 'c'}; eval{Rmpfr_printf("%Pu\n", 0, prec_cast($prec));}; if($@ =~ /You've provided both a rounding arg and a Math::MPFR::Prec object to Rmpfr_printf/) { $ok .= 'd' } else {warn "1d: \$\@: $@\n"}; if($ok eq 'abcd') {print "ok 1\n"} else {print "not ok 1\n"} $ok = ''; ###################################################### unless($ENV{SISYPHUS_SKIP}) { # Because of the way I (sisyphus) build this module with MS # Visual Studio, XSubs that take a filehandle as an argument # may not work. It therefore suits my purposes to be able to # avoid calling (and testing) those particular XSubs my $o = open($fh, '>', $file); if($o) { Rmpfr_fprintf($fh, "%Pu\n", prec_cast($prec)); eval{Rmpfr_fprintf($fh, "%Pu\n", GMP_RNDN, prec_cast($prec));}; if($@ =~ /You've provided both a rounding arg and a Math::MPFR::Prec object to Rmpfr_fprintf/) {$ok = 'a'} else {warn "2a: \$\@: $@\n"} close $fh; if(open($RD, '<', $file)) { my $num = <$RD>; chomp $num; if($num == $prec) {$ok .= 'b'} close($RD); } else { warn "Failed to open $file for reading: $!";} if($ok eq 'ab') {print "ok 2\n"} else { warn "\$ok: $ok\n"; print "not ok 2\n"; } } else { warn "Failed to open $file for writing: $!"; warn "\nSkipping test 2 - couldn't open $file\n"; print "ok 2\n"; } } else { warn "\nskipping test 2 - \$ENV{SISYPHUS_SKIP} is set\n"; print "ok 2\n"; } ######################################################### my $buf; Rmpfr_sprintf ($buf, "%Pu\n", prec_cast($prec), 200); if($buf == 100009) {print "ok 3\n"} else { warn "\$buf: $buf\n"; print "not ok 3\n"; } eval{Rmpfr_sprintf ($buf, "%Pu\n", GMP_RNDN, prec_cast($prec), 100);}; if($@ =~ /You've provided both a rounding arg and a Math::MPFR::Prec object to Rmpfr_sprintf/) {print "ok 4\n"} else { warn "4: \$\@: $@\n"; print "not ok 4\n"; } Rmpfr_snprintf ($buf, $bytes, "%Pu\n", prec_cast($prec), 200); chomp $buf; if($buf == 100009) {print "ok 5\n"} else { warn "\$buf: $buf\n"; print "not ok 5\n"; } eval{Rmpfr_snprintf ($buf, $bytes, "%Pu\n", GMP_RNDN, prec_cast($prec), 10);}; if($@ =~ /You've provided both a rounding arg and a Math::MPFR::Prec object to Rmpfr_snprintf/) {print "ok 6\n"} else { warn "6: \$\@: $@\n"; print "not ok 6\n"; } Math-MPFR-4.38/t/q_arith.t0000755060175106010010000000771514765756127014000 0ustar OwnerNone # Test additional handling of mpq objects. # The mpfr arithmetic functions that take mpq objects as arguments all have a destination # variable of type mpfr object. # This often means that the result contained in the destination variable has been rounded. # We provide functions q_add_fr, q_sub_fr, q_mul_fr, q_div_fr that perform the same arithmetic # operations, but place the results as an exact rational value in a (mpq object) destination # variable. # # Also, Rmpfr_cmp_q($mpfr, $mpq) converts the value in $mpfr to its exact rational value, and # compares that rational value to the rational value held in $mpq. # We provide fr_cmp_q_rounded($mpfr, $mpq, $rnd) which instead converts $mpq to an mpfr object # (using default precision, rounded according to $rnd), and then compares the two mpfr objects. # Hence, Rmpfr_cmp_q() and fr_cmp_q_rounded() will often report different results for the same # mpfr and mpq objects. # # We test these functions below: use strict; use warnings; use Math::MPFR qw(:mpfr); use Test::More; eval { require Math::GMPq; }; if($@) { plan skip_all => 'Math::GMPq not available'; exit 0; } my $fr = Math::MPFR->new(0.5); my $rop = Math::MPFR->new(); my $rop_check = Math::MPFR->new(); my $q_rop = Math::GMPq->new(); my $q_op = Math::GMPq->new('7/9'); q_add_fr ( $q_rop, $q_op, $fr ); Rmpfr_set_q( $rop_check, $q_rop, MPFR_RNDN); Rmpfr_add_q( $rop, $fr, $q_op, MPFR_RNDN); cmp_ok( $q_rop, "==", Math::GMPq->new('23/18'), "q_add_fr produces expected result" ); cmp_ok( $rop, "!=", Math::GMPq->new('23/18'), "Rmpfr_add_q differs from q_add_fr" ); cmp_ok( $rop, "==", $rop_check, "Rmpfr_add_q produces expected result" ); my $cmp = fr_cmp_q_rounded( $rop, $q_rop, MPFR_RNDN ); cmp_ok($cmp, "==", 0, "q_cmp_fr reports equality" ); q_sub_fr( $q_rop, $q_op, $fr ); Rmpfr_set_q( $rop_check, $q_rop, MPFR_RNDN ); Rmpfr_sub_q( $rop, $fr, $q_op, MPFR_RNDN ); cmp_ok( $q_rop, "==", Math::GMPq->new('5/18'), "q_sub_fr produces expected result" ); cmp_ok( $rop, "!=", Math::GMPq->new('-5/18'), "Rmpfr_sub_q differs from complement of q_sub_fr" ); cmp_ok( $rop, "==", -$rop_check, "Rmpfr_sub_q produces expected result" ); $cmp = fr_cmp_q_rounded( $rop, $q_rop * -1, MPFR_RNDN ); cmp_ok($cmp, "==", 0, "q_cmp_fr reports equality" ); q_mul_fr ( $q_rop, $q_op, $fr ); Rmpfr_set_q( $rop_check, $q_rop, MPFR_RNDN); Rmpfr_mul_q( $rop, $fr, $q_op, MPFR_RNDN); cmp_ok( $q_rop, "==", Math::GMPq->new('7/18'), "q_mul_fr produces expected result" ); cmp_ok( $rop, "!=", Math::GMPq->new('7/18'), "Rmpfr_mul_q differs from q_mul_fr" ); cmp_ok( $rop, "==", $rop_check, "Rmpfr_mul_q produces expected result" ); $cmp = fr_cmp_q_rounded( $rop, $q_rop, MPFR_RNDN ); cmp_ok($cmp, "==", 0, "q_cmp_fr reports equality" ); q_div_fr ( $q_rop, $q_op, $fr ); Rmpfr_set_q ( $rop_check, $q_rop, MPFR_RNDN ); Rmpfr_q_div ( $rop, $q_op, $fr, MPFR_RNDN); cmp_ok( $q_rop, "==", Math::GMPq->new('14/9'), "q_div_fr produces expected result" ); cmp_ok( $rop, "!=", Math::GMPq->new('14/9'), "Rmpfr_q_div differs from q_div_fr" ); cmp_ok( $rop, "==", $rop_check, "Rmpfr_q_div produces expected result" ); $cmp = fr_cmp_q_rounded( $rop, $q_rop, MPFR_RNDN ); cmp_ok($cmp, "==", 0, "q_cmp_fr reports equality" ); my $q_arg = Math::GMPq->new('1/3'); my $fr_arg = Math::MPFR->new(7); q_add_fr($q_arg, $q_arg, $fr_arg); cmp_ok($q_arg, '==', '22/3', "Returned Math::GMPq object can be operand in addition"); Math::GMPq::Rmpq_set_str($q_arg, '1/3', 10); q_sub_fr($q_arg, $q_arg, $fr_arg); cmp_ok($q_arg, '==', '-20/3', "Returned Math::GMPq object can be operand in subtraction"); Math::GMPq::Rmpq_set_str($q_arg, '1/3', 10); q_mul_fr($q_arg, $q_arg, $fr_arg); cmp_ok($q_arg, '==', '7/3', "Returned Math::GMPq object can be operand in multiplication"); Math::GMPq::Rmpq_set_str($q_arg, '1/3', 10); q_div_fr($q_arg, $q_arg, $fr_arg); cmp_ok($q_arg, '==', '1/21', "Returned Math::GMPq object can be operand in division"); done_testing(); Math-MPFR-4.38/t/random2.t0000755060175106010010000000203714765756127013703 0ustar OwnerNone# Based on a demo script provided provided by Trizen. # See https://github.com/sisyphus/math-gmpz/issues/5 use Math::MPFR; use Test::More; BEGIN { if($] < 5.014) { warn "Skipping all tests - version 5.14.0 or later required\n"; is(1, 1,); done_testing(); exit 0; } }; package Number { sub new { my ($class, $n) = @_; bless \$n, $class; } sub add { my ($self, $n) = @_; Number->new($$self + $$n); } my $srand = 1352406084; my $state = Math::MPFR::Rmpfr_randinit_mt(); Math::MPFR::Rmpfr_randseed_ui($state, $srand); sub irand2 { # Rmpfr_urandomb my ($self) = @_; my $x = Math::MPFR->new($$self); Math::MPFR::Rmpfr_urandomb($x, $state); return Number->new($x); } } my $x = Number->new(420); my $second; $second = ${$x->add($x->irand2)}; cmp_ok($$x, '==', 420, 'TEST 1: Rmpfr_urandomb ok'); cmp_ok($second, '>=', 420, 'TEST 2: Rmpfr_urandomb ok'); cmp_ok($second, '<', 421, 'TEST 3: Rmpfr_urandomb ok'); done_testing(); Math-MPFR-4.38/t/random3.t0000755060175106010010000000163314765756127013705 0ustar OwnerNone# Based on a demo script provided provided by Trizen. # See https://github.com/sisyphus/math-gmpz/issues/5 use Math::MPFR; use Test::More; package Number; #{ sub new { my ($class, $n) = @_; bless \$n, $class; } sub add { my ($self, $n) = @_; Number->new($$self + $$n); } my $srand = 1352406084; my $state = Math::MPFR::Rmpfr_randinit_mt(); Math::MPFR::Rmpfr_randseed_ui($state, $srand); sub irand2 { # Rmpfr_urandomb my ($self) = @_; my $x = Math::MPFR->new($$self); Math::MPFR::Rmpfr_urandomb($x, $state); return Number->new($x); } #} package main; my $x = Number->new(420); my $second; $second = ${$x->add($x->irand2)}; cmp_ok($$x, '==', 420, 'TEST 1: Rmpfr_urandomb ok'); cmp_ok($second, '>=', 420, 'TEST 2: Rmpfr_urandomb ok'); cmp_ok($second, '<', 421, 'TEST 3: Rmpfr_urandomb ok'); done_testing(); Math-MPFR-4.38/t/remainder.t0000755060175106010010000000330414765756127014305 0ustar OwnerNoneuse warnings; use strict; use Math::MPFR qw(:mpfr); print "1..2\n"; print "# Using Math::MPFR version ", $Math::MPFR::VERSION, "\n"; print "# Using mpfr library version ", MPFR_VERSION_STRING, "\n"; print "# Using gmp library version ", Math::MPFR::gmp_v(), "\n"; my $ok = ''; my $numerator = Math::MPFR->new(11.5); my $denominator = Math::MPFR->new(3); my $zero = Math::MPFR->new(0); my $inf = Math::MPFR->new(1); $inf /= $zero; my $rop = Rmpfr_init(); Rmpfr_remainder($rop, $numerator, $denominator, GMP_RNDN); if($rop == -0.5) {$ok .= 'a'} Rmpfr_fmod($rop, $numerator, $denominator, GMP_RNDN); if($rop == 2.5) {$ok .= 'b'} Rmpfr_remainder($rop, $numerator, $zero, GMP_RNDN); if(Rmpfr_nan_p($rop)) {$ok .= 'c'} Rmpfr_fmod($rop, $numerator, $zero, GMP_RNDN); if(Rmpfr_nan_p($rop)) {$ok .= 'd'} Rmpfr_remquo($rop, $numerator, $zero, GMP_RNDN); if(Rmpfr_nan_p($rop)) {$ok .= 'e'} Rmpfr_remainder($rop, $inf, $denominator, GMP_RNDN); if(Rmpfr_nan_p($rop)) {$ok .= 'f'} Rmpfr_fmod($rop, $inf, $denominator, GMP_RNDN); if(Rmpfr_nan_p($rop)) {$ok .= 'g'} Rmpfr_remquo($rop, $inf, $denominator, GMP_RNDN); if(Rmpfr_nan_p($rop)) {$ok .= 'h'} Rmpfr_remainder($rop, $numerator, $inf, GMP_RNDN); if($rop == $numerator) {$ok .= 'i'} Rmpfr_fmod($rop, $numerator, $inf, GMP_RNDN); if($rop == $numerator) {$ok .= 'j'} Rmpfr_remquo($rop, $numerator, $inf, GMP_RNDN); if($rop == $numerator) {$ok .= 'k'} if($ok eq 'abcdefghijk') {print "ok 1\n"} else {print "not ok 1 $ok \n"} $ok = ''; $numerator += 30.5; # 42 $denominator += 14; # 17 my($q, $ret) = Rmpfr_remquo($rop, $numerator, $denominator, GMP_RNDN); if($q == 2) {$ok .= 'a'} if($rop == 8) {$ok .= 'b'} if($ok eq 'ab') {print "ok 2\n"} else {print "not ok 2 $ok\n"} Math-MPFR-4.38/t/Rmpfr_asinu.t0000755060175106010010000001246014765756127014627 0ustar OwnerNone# Test file for Rmpfr_asinpi(), Rmpfr_acospi(), Rmpfr_atanpi(), Rmpfr_atan2pi(), # and also for Rmpfr_asinu(), Rmpfr_acosu(), Rmpfr_atanu() anf Rmpfr_atan2u(). use strict; use warnings; use Config; use Test::More; use Math::MPFR qw(:mpfr); my $inex; my $has_420 = 0; $has_420++ if MPFR_VERSION() >= 262656; # mpfr-4.2.0 or later my $rop = Math::MPFR->new(); my $rop2 = Math::MPFR->new(); my $ropu = Math::MPFR->new(); my $roppi = Math::MPFR->new(); my $pi = Math::MPFR->new('3.1415926535897931'); my $op = Math::MPFR->new('0.5'); my $op2 = Math::MPFR->new('0.7'); my $pinf = Math::MPFR->new(); my $ui = 128; Rmpfr_set_inf($pinf, 1); my $ninf = $pinf * -1; if($has_420) { #### acos #### Rmpfr_acos ($rop, $op, MPFR_RNDN); Rmpfr_acospi($roppi, $op, MPFR_RNDN); Rmpfr_acosu ($ropu, $op, 128, MPFR_RNDN); # $ropu = $rop * 128 / (2 * $pi) my $rop_check = ($rop * 128) / (2 * $pi); cmp_ok(abs($ropu - $rop_check), '<', 1e-14, "Rmpfr_acosu in range ($ropu | $rop_check"); $inex = Rmpfr_acosu($rop2, Math::MPFR->new(0.5), 360, MPFR_RNDN); cmp_ok( $rop2, '==', 60, "inverse cosine of 0.5 is 60 degrees"); cmp_ok($inex, '==', 0, 'result was exact'); # $roppi = $rop / $pi $rop_check = $rop / $pi; cmp_ok(abs($roppi - $rop_check), '<', 1e-16, "Rmpfr_acospi in range ($roppi | $rop_check"); $inex = Rmpfr_acospi($rop2, Math::MPFR->new(-1), MPFR_RNDN); cmp_ok($rop2, '==', 1, 'acospi(-1) is 1'); cmp_ok($inex, '==', 0, 'result was exact'); $inex = Rmpfr_acospi($rop2, Math::MPFR->new(0), MPFR_RNDN); cmp_ok($rop2, '==', 0.5, 'acospi(0) is 0.5'); cmp_ok($inex, '==', 0, 'result was exact'); ### asin ### Rmpfr_asin ($rop, $op, MPFR_RNDN); Rmpfr_asinpi($roppi, $op, MPFR_RNDN); Rmpfr_asinu ($ropu, $op, 128, MPFR_RNDN); $inex = Rmpfr_asinu($rop2, Math::MPFR->new(0.5), 360, MPFR_RNDN); cmp_ok( $rop2, '==', 30, "inverse sine of 0.5 is 30 degrees"); cmp_ok($inex, '==', 0, 'result was exact'); # $ropu = $rop * 128 / (2 * $pi) $rop_check = ($rop * 128) / (2 * $pi); cmp_ok(abs($ropu - $rop_check), '<', 1e-14, "Rmpfr_asinu in range ($ropu | $rop_check"); # $roppi = $rop / $pi $rop_check = $rop / $pi; cmp_ok(abs($roppi - $rop_check), '<', 1e-16, "Rmpfr_asinpi in range ($roppi | $rop_check"); $inex = Rmpfr_asinpi($rop2, Math::MPFR->new(0), MPFR_RNDN); cmp_ok($rop2, '==', 0, 'asinpi(0) is 0'); cmp_ok($inex, '==', 0, 'result was exact'); $inex = Rmpfr_asinpi($rop2, Math::MPFR->new(1), MPFR_RNDN); cmp_ok($rop2, '==', 0.5, 'asinpi(1) is 0.5'); cmp_ok($inex, '==', 0, 'result was exact'); $inex = Rmpfr_asinpi($rop2, Math::MPFR->new(-1), MPFR_RNDN); cmp_ok($rop2, '==', -0.5, 'asinpi(-1) is -0.5'); cmp_ok($inex, '==', 0, 'result was exact'); ### atan ### Rmpfr_atan ($rop, $op, MPFR_RNDN); Rmpfr_atanpi($roppi, $op, MPFR_RNDN); Rmpfr_atanu ($ropu, $op, 128, MPFR_RNDN); # $ropu = $rop * 128 / (2 * $pi) $rop_check = ($rop * 128) / (2 * $pi); cmp_ok(abs($ropu - $rop_check), '==', 0, "Rmpfr_atanu in range ($ropu | $rop_check"); # 1e-14 $inex = Rmpfr_atanu($rop2, Math::MPFR->new(1), 360, MPFR_RNDN); cmp_ok( $rop2, '==', 45, "inverse tan of 1 is 45 degrees"); cmp_ok($inex, '==', 0, 'result was exact'); # $roppi = $rop / $pi $rop_check = $rop / $pi; cmp_ok(abs($roppi - $rop_check), '==', 0, "Rmpfr_atanpi in range ($roppi | $rop_check"); # 1e-16 $inex = Rmpfr_atanpi($rop2, Math::MPFR->new(0), MPFR_RNDN); cmp_ok("$rop2", 'eq', '0', 'atanpi(0) is 0'); cmp_ok($inex, '==', 0, 'result was exact'); $inex = Rmpfr_atanpi($rop2, $pinf, MPFR_RNDN); cmp_ok($rop2, '==', 0.5, 'atanpi(Inf) is 0.5'); cmp_ok($inex, '==', 0, 'result was exact'); $inex = Rmpfr_atanpi($rop2, $ninf, MPFR_RNDN); cmp_ok($rop2, '==', -0.5, 'atanpi(-Inf) is -0.5'); cmp_ok($inex, '==', 0, 'result was exact'); $inex = Rmpfr_atanpi($rop2, Math::MPFR->new(1), MPFR_RNDN); cmp_ok($rop2, '==', 0.25, 'atanpi(1) is 0.25'); cmp_ok($inex, '==', 0, 'result was exact'); $inex = Rmpfr_atanpi($rop2, Math::MPFR->new(-1), MPFR_RNDN); cmp_ok($rop2, '==', -0.25, 'atanpi(-1) is -0.25'); cmp_ok($inex, '==', 0, 'result was exact'); #### atan2 #### Rmpfr_atan2 ($rop, $op, $op2, MPFR_RNDN); Rmpfr_atan2pi($roppi, $op, $op2, MPFR_RNDN); Rmpfr_atan2u ($ropu, $op, $op2, 128, MPFR_RNDN); # $ropu = ($rop * 128) / (2 * $pi) $rop_check = ($rop * 128) / (2 * $pi); cmp_ok(abs($ropu - $rop_check), '==', 0, "Rmpfr_atan2u in range ($ropu | $rop_check"); # 1e-14 Rmpfr_atan2u ($rop_check, $op, $op2, 2, MPFR_RNDN); cmp_ok(abs($roppi - $rop_check), '==', 0, "Rmpfr_atan2pi in range ($roppi | $rop_check"); # 1e-16 } else { for (qw(Rmpfr_acosu Rmpfr_acospi Rmpfr_asinu Rmpfr_asinpi Rmpfr_atanu Rmpfr_atanpi Rmpfr_atan2u Rmpfr_atan2pi)) { if($_ =~ /u/) { version_check($_, 'u') } else { version_check($_, 'pi') } } } done_testing(); sub version_check{ my $f = shift; my $which = shift; my $op = Math::MPFR->new('0.5'); my $s; if($which eq 'pi') { if($f =~ /2/) { $s = "$f(\$op, \$op, \$op, MPFR_RNDN)" } # atan2 else { $s = "$f(\$op, \$op, MPFR_RNDN)" } eval( $s ); } else { if($f =~ /2/) { $s = "$f(\$op, \$op, \$op, 7, MPFR_RNDN)" } # atan2 else { $s = "$f(\$op, \$op, 7, MPFR_RNDN)" } eval( $s ); } like($@, qr/^$f function not implemented until/, "$f not implemented"); } Math-MPFR-4.38/t/Rmpfr_fmod_ui.t0000755060175106010010000000222114765756127015124 0ustar OwnerNone###################################################### # Testing mpfr_fmod_ui, introduced in mpfr-4.2.0-dev # # However, Rmpfr_fmod_ui works against aearlier # # versions of the mpfr library - albeit suboptimally # # when mpfr version is older than 4.2.0 # ###################################################### use warnings; use strict; use Math::MPFR qw(:mpfr); use Test::More; my $div = 2015; my $den = Rmpfr_init2(64); my $rop1 = Math::MPFR->new(); my $rop2 = Math::MPFR->new(); my $num = Math::MPFR->new(7000.2); Rmpfr_set_ui($den, $div, MPFR_RNDN); Rmpfr_fmod ( $rop1, $num, $den, MPFR_RNDN); Rmpfr_fmod_ui ( $rop2, $num, $div, MPFR_RNDN ); cmp_ok($rop1, '==', $rop2, '53-bit prec: Rmpfr_fmod and Rmpfr_fmod_ui agree'); Rmpfr_set_default_prec(6); my $rop3 = Math::MPFR->new(); my $rop4 = Math::MPFR->new(); for(1..149) { my $div = int(rand(2048)) + 1; my $num = Math::MPFR->new(1 + rand(6000)); Rmpfr_set_ui($den, $div, MPFR_RNDN); Rmpfr_fmod ( $rop3, $num, $den, MPFR_RNDN); Rmpfr_fmod_ui ( $rop4, $num, $div, MPFR_RNDN ); cmp_ok($rop3, '==', $rop4, "$num $div: Rmpfr_fmod and Rmpfr_fmod_ui agree"); } done_testing() Math-MPFR-4.38/t/Rmpfr_get_q.t0000755060175106010010000000550214765756127014606 0ustar OwnerNoneuse warnings; use strict; use Config; use Math::MPFR qw(:mpfr); eval {require Math::GMPq; Math::GMPq->import(':mpq');}; if($@) { print "1..1\n"; warn "\nSkipping all tests - Couldn't load Math::GMPq\n"; print "ok 1\n"; exit 0; } print "1..10\n"; my $nan = Math::MPFR->new(); my $ninf = Math::MPFR->new(-1) / Math::MPFR->new(0); my $pinf = Math::MPFR->new(1) / Math::MPFR->new(0); my $pzero = Math::MPFR->new(0); my $nzero = Math::MPFR->new(0) * Math::MPFR->new(-1); my $ok; my $q = Math::GMPq->new(); $ok .= 'a' unless Rmpfr_erangeflag_p(); eval {Rmpfr_get_q($q, $nan);}; if($@ =~ /^In Rmpfr_get_q: Cannot coerce an 'Inf' or 'NaN' to a Math::GMPq object/) {print "ok 1\n"} else { warn "\n\$\@\n:$@\n"; print "not ok 1\n"; } $ok .= 'b' if !Rmpfr_erangeflag_p(); Rmpfr_clear_erangeflag(); $ok .= 'c' unless Rmpfr_erangeflag_p(); eval {Rmpfr_get_q($q, $ninf);}; if($@ =~ /^In Rmpfr_get_q: Cannot coerce an 'Inf' or 'NaN' to a Math::GMPq object/) {print "ok 2\n"} else { warn "\n\$\@\n:$@\n"; print "not ok 2\n"; } $ok .= 'd' if !Rmpfr_erangeflag_p(); Rmpfr_clear_erangeflag(); $ok .= 'e' unless Rmpfr_erangeflag_p(); eval {Rmpfr_get_q($q, $pinf);}; if($@ =~ /^In Rmpfr_get_q: Cannot coerce an 'Inf' or 'NaN' to a Math::GMPq object/) {print "ok 3\n"} else { warn "\n\$\@\n:$@\n"; print "not ok 1\n"; } $ok .= 'f' if !Rmpfr_erangeflag_p(); Rmpfr_clear_erangeflag(); $ok .= 'g' unless Rmpfr_erangeflag_p(); Rmpfr_get_q($q, $pzero); if($q == 0) {print "ok 4\n"} else { warn "\nExpected 0, got $q\n"; print "not ok 4\n"; } Rmpfr_get_q($q, $nzero); if($q == 0) {print "ok 5\n"} else { warn "\nExpected 0, got $q\n"; print "not ok 5\n"; } my $val = Rmpfr_init2(121); Rmpfr_set_d($val, 2.0, MPFR_RNDN); $val **= 0.5; #print "$val\n"; Rmpfr_get_q($q, $val); if(Rmpfr_cmp_q($val, $q) == 0) {print "ok 6\n"} else { warn "\n\$val ($val) != \$q ($q)\n"; print "not ok 6\n"; } $ok .= 'h' unless Rmpfr_erangeflag_p(); if($ok eq 'abcdefgh') {print "ok 7\n"} else { warn "\nExpected 'abcdefgh', got '$ok'\n"; print "not ok 7\n"; } my $check = Rmpfr_init2(Rmpfr_get_prec($val) * 2); Rmpfr_set($check, $val, MPFR_RNDN); $check **= 2.0; if(Rmpfr_cmp_q($check, $q * $q) == 0) {print "ok 8\n"} else { warn "\n$check != ", $q * $q, "\n"; print "not ok 8\n"; } eval {require Math::GMPz; Math::GMPz->import(':mpz');}; if($@) { warn "\nSkipping (canonicalization) tests 9 & 10 - Couldn't load Math::GMPz\n"; print "ok 9\n"; print "ok 10\n"; } else { my $num = Math::GMPz->new(); my $rop = Math::GMPq->new(); Rmpfr_get_q($rop, Math::MPFR->new(1.5)); Rmpq_numref($num, $rop); if($num == 3) {print "ok 9\n"} else { warn "\nExpected 3, got $num\n"; print "not ok 9\n"; } Rmpq_denref($num, $rop); if($num == 2) {print "ok 10\n"} else { warn "\nExpected 2, got $num\n"; print "not ok 10\n"; } } Math-MPFR-4.38/t/Rmpfr_q_div_and_Rmpfr_z_div.t0000755060175106010010000001601714765756127017777 0ustar OwnerNoneuse strict; use warnings; use Math::MPFR qw(:mpfr); print "1..28\n"; eval{require Math::GMPq;}; if($@) { warn "\n\$\@: $@\n"; warn "\nSkipping mpq tests - couldn't load Math::GMPq\n"; for(1..14) {print "ok $_\n"} } else { my $rop = Math::MPFR->new(); my $fr = Math::MPFR->new(23); my $q = Math::GMPq->new('1/3'); my $check = Math::MPFR->new(Math::GMPq->new('1/69')); my $inex = Rmpfr_q_div($fr, $q, $fr, MPFR_RNDN); if($inex) {print "ok 1\n"} else { warn "\n\$inex: $inex\n"; print "not ok 1\n"; } if($check == $fr) {print "ok 2\n"} else { warn "\nExpected $check, got $fr\n"; print "not ok 2\n"; } $inex = Rmpfr_q_div($rop, $q, Math::MPFR->new(27), MPFR_RNDN); my $inex2 = Rmpfr_set_q($check, Math::GMPq->new('1/81'), MPFR_RNDN); if($inex == $inex2) {print "ok 3\n"} else { warn "\nExpected $inex, got $inex2\n"; print "not ok 3\n"; } if($rop == $check) {print "ok 4\n"} else { warn "\nExpected $rop, got $check\n"; print "not ok 4\n"; } $rop = $q / Math::MPFR->new(-10); Rmpfr_set_q($check, Math::GMPq->new('-1/30'), MPFR_RNDN); if($rop == $check) {print "ok 5\n"} else { warn "$rop != $check\n"; print "not ok 5\n"; } ######################### # divide by Inf, NaN, 0 # ######################### my $pzero = Math::MPFR->new(0); my $nzero = $pzero * -1.0; my $pinf = Math::MPFR->new(1) / $pzero; my $ninf = $pinf * -1.0; my $nan = $pinf / $pinf; my $pq = Math::GMPq->new('1/7'); my $nq = Math::GMPq->new('-1/7'); my $zq = $pq + $nq; my $rop1 = Math::MPFR->new(); my $rop2 = Math::MPFR->new(); Rmpfr_q_div($rop1, $pq, $pzero, MPFR_RNDN); Rmpfr_q_div($rop2, $pq, $nzero, MPFR_RNDN); if($rop1 > 0 && $rop1 == $rop2 * -1.0 && Rmpfr_inf_p($rop1)) {print "ok 6\n"} else { warn "$rop1 $rop2\n"; print "not ok 6\n"; } Rmpfr_q_div($rop1, $nq, $pzero, MPFR_RNDN); Rmpfr_q_div($rop2, $nq, $nzero, MPFR_RNDN); if($rop1 < 0 && $rop1 == $rop2 * -1.0 && Rmpfr_inf_p($rop1)) {print "ok 7\n"} else { warn "$rop1 $rop2\n"; print "not ok 7\n"; } Rmpfr_q_div($rop1, $zq, $pzero, MPFR_RNDN); Rmpfr_q_div($rop2, $zq, $nzero, MPFR_RNDN); if(Rmpfr_nan_p($rop1) && Rmpfr_nan_p($rop2)) {print "ok 8\n"} else { warn "$rop1 $rop2\n"; print "not ok 8\n"; } Rmpfr_q_div($rop1, $pq, $pinf, MPFR_RNDN); Rmpfr_q_div($rop2, $pq, $ninf, MPFR_RNDN); if(Rmpfr_zero_p($rop1) && Rmpfr_zero_p($rop2) && !Rmpfr_signbit($rop1) && Rmpfr_signbit($rop2)) {print "ok 9\n"} else { warn "$rop1 $rop2\n"; print "not ok 9\n"; } Rmpfr_q_div($rop1, $nq, $pinf, MPFR_RNDN); Rmpfr_q_div($rop2, $nq, $ninf, MPFR_RNDN); if(Rmpfr_zero_p($rop1) && Rmpfr_zero_p($rop2) && Rmpfr_signbit($rop1) && !Rmpfr_signbit($rop2)) {print "ok 10\n"} else { warn "$rop1 $rop2\n"; print "not ok 10\n"; } Rmpfr_q_div($rop1, $zq, $pinf, MPFR_RNDN); Rmpfr_q_div($rop2, $zq, $ninf, MPFR_RNDN); if(Rmpfr_zero_p($rop1) && Rmpfr_zero_p($rop2) && !Rmpfr_signbit($rop1) && Rmpfr_signbit($rop2)) {print "ok 11\n"} else { warn "$rop1 $rop2\n"; print "not ok 11\n"; } Rmpfr_q_div($rop1, $pq, $nan, MPFR_RNDN); if(Rmpfr_nan_p($rop1)) {print "ok 12\n"} else { warn "$rop1\n"; print "not ok 12\n"; } Rmpfr_q_div($rop1, $nq, $nan, MPFR_RNDN); if(Rmpfr_nan_p($rop1)) {print "ok 13\n"} else { warn "$rop1\n"; print "not ok 13\n"; } Rmpfr_q_div($rop1, $zq, $nan, MPFR_RNDN); if(Rmpfr_nan_p($rop1)) {print "ok 14\n"} else { warn "$rop1\n"; print "not ok 14\n"; } } eval{require Math::GMPz;}; if($@) { warn "\n\$\@: $@\n"; warn "\nSkipping mpz tests - couldn't load Math::GMPz\n"; for(15..28) {print "ok $_\n"} } else { my $rop = Math::MPFR->new(); my $fr = Math::MPFR->new(23); my $z = Math::GMPz->new(11); my $check = Math::MPFR->new(Math::MPFR->new(11) / Math::MPFR->new(23)); my $inex = Rmpfr_z_div($fr, $z, $fr, MPFR_RNDN); if($inex) {print "ok 15\n"} else { warn "\n\$inex: $inex\n"; print "not ok 15\n"; } if($check == $fr) {print "ok 16\n"} else { warn "\nExpected $check, got $fr\n"; print "not ok 16\n"; } $inex = Rmpfr_z_div($rop, $z, Math::MPFR->new(27), MPFR_RNDN); my $inex2 = Rmpfr_set($check, Math::MPFR->new(11) / Math::MPFR->new(27), MPFR_RNDN); if(0 == $inex2) {print "ok 17\n"} else { warn "\nExpected $inex, got $inex2\n"; print "not ok 17\n"; } if($rop == $check) {print "ok 18\n"} else { warn "\nExpected $rop, got $check\n"; print "not ok 18\n"; } $rop = $z / Math::MPFR->new(-10); Rmpfr_set($check, Math::MPFR->new(11) / Math::MPFR->new(-10), MPFR_RNDN); if($rop == $check) {print "ok 19\n"} else { warn "$rop != $check\n"; print "not ok 19\n"; } ######################### # divide by Inf, NaN, 0 # ######################### my $pzero = Math::MPFR->new(0); my $nzero = $pzero * -1.0; my $pinf = Math::MPFR->new(1) / $pzero; my $ninf = $pinf * -1.0; my $nan = $pinf / $pinf; my $pz = Math::GMPz->new('17'); my $nz = Math::GMPz->new('-17'); my $zz = $pz + $nz; my $rop1 = Math::MPFR->new(); my $rop2 = Math::MPFR->new(); Rmpfr_z_div($rop1, $pz, $pzero, MPFR_RNDN); Rmpfr_z_div($rop2, $pz, $nzero, MPFR_RNDN); if($rop1 > 0 && $rop1 == $rop2 * -1.0 && Rmpfr_inf_p($rop1)) {print "ok 20\n"} else { warn "$rop1 $rop2\n"; print "not ok 20\n"; } Rmpfr_z_div($rop1, $nz, $pzero, MPFR_RNDN); Rmpfr_z_div($rop2, $nz, $nzero, MPFR_RNDN); if($rop1 < 0 && $rop1 == $rop2 * -1.0 && Rmpfr_inf_p($rop1)) {print "ok 21\n"} else { warn "$rop1 $rop2\n"; print "not ok 21\n"; } Rmpfr_z_div($rop1, $zz, $pzero, MPFR_RNDN); Rmpfr_z_div($rop2, $zz, $nzero, MPFR_RNDN); if(Rmpfr_nan_p($rop1) && Rmpfr_nan_p($rop2)) {print "ok 22\n"} else { warn "$rop1 $rop2\n"; print "not ok 22\n"; } Rmpfr_z_div($rop1, $pz, $pinf, MPFR_RNDN); Rmpfr_z_div($rop2, $pz, $ninf, MPFR_RNDN); if(Rmpfr_zero_p($rop1) && Rmpfr_zero_p($rop2) && !Rmpfr_signbit($rop1) && Rmpfr_signbit($rop2)) {print "ok 23\n"} else { warn "$rop1 $rop2\n"; print "not ok 23\n"; } Rmpfr_z_div($rop1, $nz, $pinf, MPFR_RNDN); Rmpfr_z_div($rop2, $nz, $ninf, MPFR_RNDN); if(Rmpfr_zero_p($rop1) && Rmpfr_zero_p($rop2) && Rmpfr_signbit($rop1) && !Rmpfr_signbit($rop2)) {print "ok 24\n"} else { warn "$rop1 $rop2\n"; print "not ok 24\n"; } Rmpfr_z_div($rop1, $zz, $pinf, MPFR_RNDN); Rmpfr_z_div($rop2, $zz, $ninf, MPFR_RNDN); if(Rmpfr_zero_p($rop1) && Rmpfr_zero_p($rop2) && !Rmpfr_signbit($rop1) && Rmpfr_signbit($rop2)) {print "ok 25\n"} else { warn "$rop1 $rop2\n"; print "not ok 25\n"; } Rmpfr_z_div($rop1, $pz, $nan, MPFR_RNDN); if(Rmpfr_nan_p($rop1)) {print "ok 26\n"} else { warn "$rop1\n"; print "not ok 26\n"; } Rmpfr_z_div($rop1, $nz, $nan, MPFR_RNDN); if(Rmpfr_nan_p($rop1)) {print "ok 27\n"} else { warn "$rop1\n"; print "not ok 27\n"; } Rmpfr_z_div($rop1, $zz, $nan, MPFR_RNDN); if(Rmpfr_nan_p($rop1)) {print "ok 28\n"} else { warn "$rop1\n"; print "not ok 28\n"; } } Math-MPFR-4.38/t/Rmpfr_rec_root.t0000755060175106010010000002665114765756127015333 0ustar OwnerNone # mpfr_root is deprecated in favour of mpfr_rootn_ui in mpfr-4.0.0 # The 2 variants should produce identical results, except for the # nth root of -0 when n is zero. use strict; use warnings; use Math::MPFR qw(:mpfr); my $old = 0; if(MPFR_VERSION_MAJOR > 3) { *_ROOT = \&Rmpfr_rootn_ui; } else { *_ROOT = \&Rmpfr_root; $old = 1; } print "1..57\n"; my($inex1, $inex2, $check); my($rop1, $rop2) = (Rmpfr_init(), Rmpfr_init()); my $root = 2; my $op = Math::MPFR->new(17); $inex1 = Rmpfr_rec_sqrt($rop1, $op, MPFR_RNDN); $inex2 = Rmpfr_rec_root($rop2, $op, $root, MPFR_RNDN); if($inex1 == $inex2) {print "ok 1\n"} else { warn "\n \$inex1: $inex1\n \$inex2: $inex2\n"; print "not ok 1\n"; } if($rop1 == $rop2) {print "ok 2\n"} else { warn "\n \$rop1: $rop1\n \$rop2: $rop2\n"; print "not ok 2\n"; } $op *= -1; # -17 Rmpfr_clear_nanflag(); $inex1 = Rmpfr_rec_sqrt($rop1, $op, MPFR_RNDN); if(Rmpfr_nanflag_p()) {print "ok 3\n"} else {print "not ok 3\n"} Rmpfr_clear_nanflag(); $inex2 = Rmpfr_rec_root($rop2, $op, $root, MPFR_RNDN); if(Rmpfr_nanflag_p()) {print "ok 4\n"} else {print "not ok 4\n"} if($inex1 == $inex2) {print "ok 5\n"} else { warn "\n \$inex1: $inex1\n \$inex2: $inex2\n"; print "not ok 5\n"; } if(Rmpfr_nan_p($rop1) && Rmpfr_nan_p($rop2)) {print "ok 6\n"} else { warn "\n \$rop1: $rop1\n \$rop2: $rop2\n"; print "not ok 6\n"; } $root = 5; $inex1 = _ROOT ($rop1, $op, $root, MPFR_RNDN); $inex2 = Rmpfr_rec_root($rop2, $op, $root, MPFR_RNDN); $check = $rop1 * $rop2; if($check < 1.0000001 && $check > 0.9999999) {print "ok 7\n"} else { warn "\n \$check: $check\n"; print "not ok 7\n"; } # see tests 50-57 for root = 0. ## $op is +/- 0 ## ## root is even, root is odd, root is 0 my $pzero = Math::MPFR->new(0); my $nzero = $pzero * -1; # $root is 5 Rmpfr_clear_divby0(); $inex1 = _ROOT ($rop1, $pzero, $root, MPFR_RNDN); $inex2 = Rmpfr_rec_root($rop2, $pzero, $root, MPFR_RNDN); if($inex1 == $inex2 && Rmpfr_divby0_p()) {print "ok 8\n"} else { warn "\n \$inex1: $inex1\n \$inex2: $inex2\ndivby0: ", Rmpfr_divby0_p(), "\n"; print "not ok 8\n"; } Rmpfr_clear_divby0(); if($rop1 == 1 / $rop2 && !Rmpfr_divby0_p() && Rmpfr_signbit($rop1) == Rmpfr_signbit($rop2)) {print "ok 9\n"} else { warn "\n \$rop1: $rop1\n \$rop2: $rop2\ndivby0: ", Rmpfr_divby0_p(), "\n", "signbits \$rop1: ", Rmpfr_signbit($rop1), " \$rop2: ", Rmpfr_signbit($rop2), "\n"; print "not ok 9\n"; } $inex1 = _ROOT ($rop1, $nzero, $root, MPFR_RNDN); $inex2 = Rmpfr_rec_root($rop2, $nzero, $root, MPFR_RNDN); if($inex1 == $inex2 && Rmpfr_divby0_p()) {print "ok 10\n"} else { warn "\n \$inex1: $inex1\n \$inex2: $inex2\ndivby0: ", Rmpfr_divby0_p(), "\n"; print "not ok 10\n"; } Rmpfr_clear_divby0(); if($rop1 == 1 / $rop2 && !Rmpfr_divby0_p() && Rmpfr_signbit($rop1) == Rmpfr_signbit($rop2)) {print "ok 11\n"} else { warn "\n \$rop1: $rop1\n \$rop2: $rop2\ndivby0: ", Rmpfr_divby0_p(), "\n", "signbits \$rop1: ", Rmpfr_signbit($rop1), " \$rop2: ", Rmpfr_signbit($rop2), "\n"; print "not ok 11\n"; } $inex1 = _ROOT ($rop1, $pzero, $root - 1, MPFR_RNDN); $inex2 = Rmpfr_rec_root($rop2, $pzero, $root - 1, MPFR_RNDN); if($inex1 == $inex2 && Rmpfr_divby0_p()) {print "ok 12\n"} else { warn "\n \$inex1: $inex1\n \$inex2: $inex2\ndivby0: ", Rmpfr_divby0_p(), "\n"; print "not ok 12\n"; } Rmpfr_clear_divby0(); if($rop1 == 1 / $rop2 && !Rmpfr_divby0_p() && Rmpfr_signbit($rop1) == Rmpfr_signbit($rop2)) {print "ok 13\n"} else { warn "\n \$rop1: $rop1\n \$rop2: $rop2\ndivby0: ", Rmpfr_divby0_p(), "\n", "signbits \$rop1: ", Rmpfr_signbit($rop1), " \$rop2: ", Rmpfr_signbit($rop2), "\n"; print "not ok 13\n"; } $inex1 = _ROOT ($rop1, $nzero, $root - 1, MPFR_RNDN); $inex2 = Rmpfr_rec_root($rop2, $nzero, $root - 1, MPFR_RNDN); if($inex1 == $inex2 && Rmpfr_divby0_p()) {print "ok 14\n"} else { warn "\n \$inex1: $inex1\n \$inex2: $inex2\ndivby0: ", Rmpfr_divby0_p(), "\n"; print "not ok 14\n"; } Rmpfr_clear_divby0(); if($old) { if($rop1 == 1 / $rop2 && !Rmpfr_divby0_p() && Rmpfr_signbit($rop1) != Rmpfr_signbit($rop2)) {print "ok 15\n"} else { warn "\n \$rop1: $rop1\n \$rop2: $rop2\ndivby0: ", Rmpfr_divby0_p(), "\n", "signbits \$rop1: ", Rmpfr_signbit($rop1), " \$rop2: ", Rmpfr_signbit($rop2), "\n"; print "not ok 15\n"; } } else { if($rop1 == 1 / $rop2 && !Rmpfr_divby0_p() && Rmpfr_signbit($rop1) == Rmpfr_signbit($rop2)) {print "ok 15\n"} else { warn "\n \$rop1: $rop1\n \$rop2: $rop2\ndivby0: ", Rmpfr_divby0_p(), "\n", "signbits \$rop1: ", Rmpfr_signbit($rop1), " \$rop2: ", Rmpfr_signbit($rop2), "\n"; print "not ok 15\n"; } } Rmpfr_clear_divby0(); Rmpfr_clear_nanflag(); $inex1 = _ROOT($rop1, $pzero, 0, MPFR_RNDN); if(Rmpfr_nanflag_p() && !Rmpfr_divby0_p()) {print "ok 16\n"} else {print "not ok 16\n"} Rmpfr_clear_divby0(); Rmpfr_clear_nanflag(); $inex2 = Rmpfr_rec_root($rop2, $nzero, 0, MPFR_RNDN); if(Rmpfr_nanflag_p() && !Rmpfr_divby0_p()) {print "ok 17\n"} else {print "not ok 17\n"} Rmpfr_clear_divby0(); Rmpfr_clear_nanflag(); if($inex1 == $inex2) {print "ok 18\n"} else { warn "\n \$inex1: $inex1\n \$inex2: $inex2\n"; print "not ok 18\n"; } if(Rmpfr_nan_p($rop1) && Rmpfr_nan_p($rop2)) {print "ok 19\n"} else { warn "\n \$rop1: $rop1\n \$rop2: $rop2\n"; print "not ok 19\n"; } ## $op is +/- Inf ## ## root is even, root is odd, root is 0. $root = 2; Rmpfr_set_d($op, 999**(999**999), MPFR_RNDN); $inex1 = Rmpfr_rec_sqrt($rop1, $op, MPFR_RNDN); $inex2 = Rmpfr_rec_root($rop2, $op, $root, MPFR_RNDN); if($inex1 == $inex2) {print "ok 20\n"} else { warn "\n \$inex1: $inex1\n \$inex2: $inex2\n"; print "not ok 20\n"; } if($rop1 == $rop2) {print "ok 21\n"} else { warn "\n \$rop1: $rop1\n \$rop2: $rop2\n"; print "not ok 21\n"; } $op *= -1; # -Inf $inex1 = Rmpfr_rec_sqrt($rop1, $op, MPFR_RNDN); $inex2 = Rmpfr_rec_root($rop2, $op, $root, MPFR_RNDN); if($inex1 == $inex2) {print "ok 22\n"} else { warn "\n \$inex1: $inex1\n \$inex2: $inex2\n"; print "not ok 22\n"; } if(Rmpfr_nan_p($rop1) && Rmpfr_nan_p($rop2)) {print "ok 23\n"} else { warn "\n \$rop1: $rop1\n \$rop2: $rop2\n"; print "not ok 23\n"; } $root = 5; $inex1 = _ROOT ($rop1, $op, $root, MPFR_RNDN); $inex2 = Rmpfr_rec_root($rop2, $op, $root, MPFR_RNDN); if($inex1 == $inex2) {print "ok 24\n"} else { warn "\n \$inex1: $inex1\n \$inex2: $inex2\n"; print "not ok 24\n"; } if($rop1 == 1 / $rop2) {print "ok 25\n"} else { warn "\n \$check: $check\n"; print "not ok 25\n"; } $op *= -1; # +Inf $inex1 = _ROOT ($rop1, $op, $root, MPFR_RNDN); $inex2 = Rmpfr_rec_root($rop2, $op, $root, MPFR_RNDN); if($inex1 == $inex2) {print "ok 26\n"} else { warn "\n \$inex1: $inex1\n \$inex2: $inex2\n"; print "not ok 26\n"; } if($rop1 == 1 / $rop2) {print "ok 27\n"} else { warn "\n \$rop1: $rop1\n \$rop2: $rop2\n"; print "not ok 27\n"; } $inex1 = _ROOT ($rop1, $op, $root - 1, MPFR_RNDN); $inex2 = Rmpfr_rec_root($rop2, $op, $root - 1, MPFR_RNDN); if($inex1 == $inex2) {print "ok 28\n"} else { warn "\n \$inex1: $inex1\n \$inex2: $inex2\n"; print "not ok 28\n"; } if($rop1 == 1 / $rop2) {print "ok 29\n"} else { warn "\n \$check: $check\n"; print "not ok 29\n"; } Rmpfr_clear_nanflag(); $inex1 = _ROOT($rop1, $op, 0, MPFR_RNDN); if(Rmpfr_nanflag_p()) {print "ok 30\n"} else {print "not ok 30\n"} Rmpfr_clear_nanflag(); $inex2 = Rmpfr_rec_root($rop2, $op, 0, MPFR_RNDN); if(Rmpfr_nanflag_p()) {print "ok 31\n"} else {print "not ok 31\n"} if($inex1 == $inex2) {print "ok 32\n"} else { warn "\n \$inex1: $inex1\n \$inex2: $inex2\n"; print "not ok 32\n"; } if(Rmpfr_nan_p($rop1) && Rmpfr_nan_p($rop2) && Rmpfr_nanflag_p()) {print "ok 33\n"} else { warn "\n \$rop1: $rop1\n \$rop2: $rop2\n ", Rmpfr_nanflag_p(), "\n"; print "not ok 33\n"; } $op *= -1; # -Inf Rmpfr_clear_nanflag(); $inex1 = _ROOT($rop1, $op, 0, MPFR_RNDN); if(Rmpfr_nanflag_p()) {print "ok 34\n"} else {print "not ok 34\n"} Rmpfr_clear_nanflag(); $inex2 = Rmpfr_rec_root($rop2, $op, 0, MPFR_RNDN); if(Rmpfr_nanflag_p()) {print "ok 35\n"} else {print "not ok 35\n"} if($inex1 == $inex2) {print "ok 36\n"} else { warn "\n \$inex1: $inex1\n \$inex2: $inex2\n"; print "not ok 36\n"; } if(Rmpfr_nan_p($rop1) && Rmpfr_nan_p($rop2) && Rmpfr_nanflag_p()) {print "ok 37\n"} else { warn "\n \$rop1: $rop1\n \$rop2: $rop2\n ", Rmpfr_nanflag_p(), "\n"; print "not ok 37\n"; } ## $op is NaN ## root is even, root is odd, root is 0 Rmpfr_set_nan($op); $root = 2; Rmpfr_clear_nanflag(); $inex1 = Rmpfr_rec_sqrt($rop1, $op, MPFR_RNDN); if(Rmpfr_nanflag_p()) {print "ok 38\n"} else {print "not ok 38\n"} Rmpfr_clear_nanflag(); $inex2 = Rmpfr_rec_root($rop2, $op, $root, MPFR_RNDN); if(Rmpfr_nanflag_p()) {print "ok 39\n"} else {print "not ok 39\n"} Rmpfr_clear_nanflag(); if($inex1 == $inex2) {print "ok 40\n"} else { warn "\n \$inex1: $inex1\n \$inex2: $inex2\n"; print "not ok 40\n"; } if(Rmpfr_nan_p($rop1) && Rmpfr_nan_p($rop2)) {print "ok 41\n"} else { warn "\n \$rop1: $rop1\n \$rop2: $rop2\n ", Rmpfr_nanflag_p(), "\n"; print "not ok 41\n"; } $root = 5; Rmpfr_clear_nanflag(); $inex1 = _ROOT($rop1, $op, $root, MPFR_RNDN); if(Rmpfr_nanflag_p()) {print "ok 42\n"} else {print "not ok 42\n"} Rmpfr_clear_nanflag(); $inex2 = Rmpfr_rec_root($rop2, $op, $root, MPFR_RNDN); if(Rmpfr_nanflag_p()) {print "ok 43\n"} else {print "not ok 43\n"} Rmpfr_clear_nanflag(); if($inex1 == $inex2) {print "ok 44\n"} else { warn "\n \$inex1: $inex1\n \$inex2: $inex2\n"; print "not ok 44\n"; } if(Rmpfr_nan_p($rop1) && Rmpfr_nan_p($rop2)) {print "ok 45\n"} else { warn "\n \$rop1: $rop1\n \$rop2: $rop2\n ", Rmpfr_nanflag_p(), "\n"; print "not ok 45\n"; } $root = 0; Rmpfr_clear_nanflag(); $inex1 = _ROOT($rop1, $op, $root, MPFR_RNDN); if(Rmpfr_nanflag_p()) {print "ok 46\n"} else {print "not ok 46\n"} Rmpfr_clear_nanflag(); $inex2 = Rmpfr_rec_root($rop2, $op, $root, MPFR_RNDN); if(Rmpfr_nanflag_p()) {print "ok 47\n"} else {print "not ok 47\n"} Rmpfr_clear_nanflag(); if($inex1 == $inex2) {print "ok 48\n"} else { warn "\n \$inex1: $inex1\n \$inex2: $inex2\n"; print "not ok 48\n"; } if(Rmpfr_nan_p($rop1) && Rmpfr_nan_p($rop2)) {print "ok 49\n"} else { warn "\n \$rop1: $rop1\n \$rop2: $rop2\n ", Rmpfr_nanflag_p(), "\n"; print "not ok 49\n"; } Rmpfr_set_ui($op, 42, MPFR_RNDN); # Now check regular values for root = 0 (which was missed earlier). Rmpfr_clear_nanflag(); $inex1 = _ROOT($rop1, $op, 0, MPFR_RNDN); if(Rmpfr_nanflag_p()) {print "ok 50\n"} else {print "not ok 50\n"} Rmpfr_clear_nanflag(); $inex2 = Rmpfr_rec_root($rop2, $op, 0, MPFR_RNDN); if(Rmpfr_nanflag_p()) {print "ok 51\n"} else {print "not ok 51\n"} if($inex1 == $inex2) {print "ok 52\n"} else { warn "\n \$inex1: $inex1\n \$inex2: $inex2\n"; print "not ok 52\n"; } if(Rmpfr_nan_p($rop1) && Rmpfr_nan_p($rop2)) {print "ok 53\n"} else { warn "\n \$rop1: $rop1\n \$rop2: $rop2\n ", Rmpfr_nanflag_p(), "\n"; print "not ok 53\n"; } $op *= -1; # -42 Rmpfr_clear_nanflag(); $inex1 = _ROOT($rop1, $op, 0, MPFR_RNDN); if(Rmpfr_nanflag_p()) {print "ok 54\n"} else {print "not ok 54\n"} Rmpfr_clear_nanflag(); $inex2 = Rmpfr_rec_root($rop2, $op, 0, MPFR_RNDN); if(Rmpfr_nanflag_p()) {print "ok 55\n"} else {print "not ok 55\n"} if($inex1 == $inex2) {print "ok 56\n"} else { warn "\n \$inex1: $inex1\n \$inex2: $inex2\n"; print "not ok 56\n"; } if(Rmpfr_nan_p($rop1) && Rmpfr_nan_p($rop2)) {print "ok 57\n"} else { warn "\n \$rop1: $rop1\n \$rop2: $rop2\n ", Rmpfr_nanflag_p(), "\n"; print "not ok 57\n"; } Math-MPFR-4.38/t/Rmpfr_rootn_ui.t0000755060175106010010000000176714765756127015356 0ustar OwnerNone use strict; use warnings; use Math::MPFR qw(:mpfr); if(4 > MPFR_VERSION_MAJOR) { print "1..1\n"; my $rop = Math::MPFR->new(); eval {Rmpfr_rootn_ui($rop, Math::MPFR->new(3), 7, MPFR_RNDN);}; if($@ =~ /Rmpfr_rootn_ui not implemented/ || $@ =~ /Rmpfr_rec_root not implemented/) {print "ok 1\n"} else { warn "\n\$\@: $@\n"; print "not ok 1\n"; } } else { print "1..3\n"; my $rop1 = Math::MPFR->new(); my $rop2 = Math::MPFR->new(); my $op = Math::MPFR->new(10); Rmpfr_rootn_ui($rop1, $op, 0, MPFR_RNDN); if(Rmpfr_nan_p($rop1)) {print "ok 1\n"} else { warn "\nExpected NaN, got $rop1\n"; print "not ok 1\n"; } my $inex1 = Rmpfr_rootn_ui($rop1, $op, 3, MPFR_RNDN); my $inex2 = Rmpfr_cbrt($rop2, $op, MPFR_RNDN); if($inex1 * $inex2 > 0) {print "ok 2\n"} else { warn "\n\$inex1: $inex1\n\$inex2: $inex2\n"; print "not ok 2\n"; } if($rop1 == $rop2) {print "ok 3\n"} else { warn "\n\$rop1: $rop1\n\$rop2: $rop2\n"; print "not ok 3\n"; } } Math-MPFR-4.38/t/Rmpfr_sinu.t0000755060175106010010000002000514765756127014460 0ustar OwnerNone# Test file for Rmpfr_sinu(), Rmpfr_cosu(), Rmpfr_tanu(), # and also for Rmpfr_sinpi(), Rmpfr_cospi() and Rmpfr_tanpi() use strict; use warnings; use Config; use Test::More; use Math::MPFR qw(:mpfr); # For testing, set mpfr default precision # to the same value as NV precision Rmpfr_set_default_prec($Math::MPFR::NV_properties{bits}); my $rop1 = Math::MPFR->new(); my $rop2 = Math::MPFR->new(); my $pinf = Math::MPFR->new(); Rmpfr_set_inf($pinf, 1); my $ninf = $pinf * -1; my $inex; if(MPFR_VERSION() >= 262656) { # Rmpfr_sinu() and Rmpfr_cosu are available # With Rmpfr_sinu, when 2*$op divided by the third argument is an integer, # $rop should be set to 0 (-0 if $op is negative). $inex = Rmpfr_sinu($rop1, Math::MPFR->new(6), 3, MPFR_RNDN); cmp_ok( "$rop1", 'eq', '0', 'Rmpfr_sinu: Get 0 when 2*$op/3 is +ve integer'); cmp_ok($inex, '==', 0, 'result was exact'); $inex = Rmpfr_sinu($rop1, Math::MPFR->new(-12), 4, MPFR_RNDN); cmp_ok( "$rop1", 'eq', '-0', 'Rmpfr_sinu: Get -0 when 2*$op/4 is -ve integer'); cmp_ok($inex, '==', 0, 'result was exact'); # For Rmpfr_cosu, when 2*$op divided by the third argument is a half-integer, # $rop should be set to zero, irrespective of the sign of $op. $inex = Rmpfr_cosu($rop1, Math::MPFR->new(5), 4, MPFR_RNDN); cmp_ok( "$rop1", 'eq', '0', 'Rmpfr_cosu: Get 0 when 2*$op/4 is a +ve half-integer'); cmp_ok($inex, '==', 0, 'result was exact'); $inex = Rmpfr_cosu($rop1, Math::MPFR->new(-6.5), 2, MPFR_RNDN); cmp_ok( "$rop1", 'eq', '0', 'Rmpfr_cosu: Get 0 when 2*$op/2 is a -ve half-integer'); cmp_ok($inex, '==', 0, 'result was exact'); my $op1 = Math::MPFR->new(30); my $op2 = Math::MPFR->new(60); $inex = Rmpfr_sinu($rop1, $op1, 360, MPFR_RNDN); cmp_ok( $rop1, '==', 0.5, "sine of 30 degrees is 0.5"); cmp_ok($inex, '==', 0, 'result was exact'); $inex = Rmpfr_sinu($rop2, $op2, 360, MPFR_RNDN); cmp_ok( $rop2, '==', sqrt(Math::MPFR->new(3)) / 2, "sine of 60 degrees is 0.5 * sqrt(3)"); cmp_ok($inex, '!=', 0, 'result was inexact'); $inex = Rmpfr_cosu($rop1, $op1, 360, MPFR_RNDN); cmp_ok( $rop1, '==', $rop2, "cosine of 30 degrees == sine of 60 degrees"); cmp_ok($inex, '!=', 0, 'result was inexact'); $inex = Rmpfr_cosu($rop2, $op2, 360, MPFR_RNDN); cmp_ok( $rop2, '==', 0.5, "cosine of 60 degrees is 0.5"); cmp_ok($inex, '==', 0, 'result was exact'); ## $inex = Rmpfr_tanu($rop2, Math::MPFR->new(45), 360, MPFR_RNDN); cmp_ok( $rop2, '==', 1, "tan of 45 degrees is 1"); cmp_ok($inex, '==', 0, 'result was exact'); ## $inex = Rmpfr_sinpi($rop1, Math::MPFR->new(1), MPFR_RNDN); cmp_ok("$rop1", 'eq', '0', 'sinpi(1) is 0'); cmp_ok($inex, '==', 0, 'result was exact'); $inex = Rmpfr_sinpi($rop1, Math::MPFR->new(-1), MPFR_RNDN); cmp_ok("$rop1", 'eq', '-0', 'sinpi(-1) is -0'); cmp_ok($inex, '==', 0, 'result was exact'); $inex = Rmpfr_sinpi($rop1, Math::MPFR->new(0.5), MPFR_RNDN); cmp_ok($rop1, '==', 1, 'sinpi(0.5) is 1'); cmp_ok($inex, '==', 0, 'result was exact'); $inex = Rmpfr_sinpi($rop1, Math::MPFR->new(-0.5), MPFR_RNDN); cmp_ok($rop1, '==', -1, 'sinpi(-0.5) is -1'); cmp_ok($inex, '==', 0, 'result was exact'); SKIP: { skip 'This USE_QUADMATH build miscalculates sqrt(0.5) by 1ULP', 2 if ($Config{nvtype} eq '__float128' && sprintf("%.36g", sqrt(2.0)) ne '1.41421356237309504880168872420969798' ); $inex = Rmpfr_sinpi($rop1, Math::MPFR->new(0.25), MPFR_RNDN); cmp_ok($rop1, '==', sqrt(Math::MPFR->new(0.5)), 'sinpi(0.25) == sqrt(0.5)'); cmp_ok($inex, '!=', 0, 'result was inexact'); $inex = Rmpfr_sinpi($rop1, Math::MPFR->new(-0.25), MPFR_RNDN); cmp_ok($rop1, '==', -sqrt(Math::MPFR->new(0.5)), 'sinpi(0.25) == -sqrt(0.5)'); cmp_ok($inex, '!=', 0, 'result was inexact'); } ## $inex = Rmpfr_cospi($rop1, Math::MPFR->new(1), MPFR_RNDN); cmp_ok($rop1, '==', -1, 'cospi(1) is -1'); cmp_ok($inex, '==', 0, 'result was exact'); $inex = Rmpfr_cospi($rop1, Math::MPFR->new(-1), MPFR_RNDN); cmp_ok($rop1, '==', -1, 'cospi(-1) is -1'); cmp_ok($inex, '==', 0, 'result was exact'); $inex = Rmpfr_cospi($rop1, Math::MPFR->new(0.5), MPFR_RNDN); cmp_ok("$rop1", 'eq', '0', 'cospi(0.5) is 0'); cmp_ok($inex, '==', 0, 'result was exact'); $inex = Rmpfr_cospi($rop1, Math::MPFR->new(-0.5), MPFR_RNDN); cmp_ok("$rop1", 'eq', '0', 'cospi(-0.5) is 0'); cmp_ok($inex, '==', 0, 'result was exact'); SKIP: { skip 'This USE_QUADMATH build miscalculates sqrt(0.5) by 1ULP', 2 if ($Config{nvtype} eq '__float128' && sprintf("%.36g", sqrt(2.0)) ne '1.41421356237309504880168872420969798' ); $inex = Rmpfr_cospi($rop1, Math::MPFR->new(0.25), MPFR_RNDN); cmp_ok($rop1, '==', sqrt(Math::MPFR->new(0.5)), 'cospi(0.25) == sqrt(0.5)'); cmp_ok($inex, '!=', 0, 'result was inexact'); $inex = Rmpfr_cospi($rop1, Math::MPFR->new(-0.25), MPFR_RNDN); cmp_ok($rop1, '==', sqrt(Math::MPFR->new(0.5)), 'cospi(-0.25) == sqrt(0.5)'); cmp_ok($inex, '!=', 0, 'result was inexact'); }; ## $inex = Rmpfr_tanpi($rop1, Math::MPFR->new(1), MPFR_RNDN); cmp_ok("$rop1", 'eq', '-0', 'tanpi(1) is -0'); cmp_ok($inex, '==', 0, 'result was exact'); $inex = Rmpfr_tanpi($rop1, Math::MPFR->new(-1), MPFR_RNDN); cmp_ok("$rop1", 'eq', '0', 'tanpi(-1) is 0'); cmp_ok($inex, '==', 0, 'result was exact'); $inex = Rmpfr_tanpi($rop1, Math::MPFR->new(0.5), MPFR_RNDN); cmp_ok($rop1, '==', $pinf, 'tanpi(0.5) is +Inf'); cmp_ok($inex, '==', 0, 'result was exact'); $inex = Rmpfr_tanpi($rop1, Math::MPFR->new(-0.5), MPFR_RNDN); cmp_ok($rop1, '==', $ninf, 'tanpi(-0.5) is -Inf'); cmp_ok($inex, '==', 0, 'result was exact'); $inex = Rmpfr_tanpi($rop1, Math::MPFR->new(0.25), MPFR_RNDN); cmp_ok($rop1, '==', 1, 'tanpi(0.25) is 1'); cmp_ok($inex, '==', 0, 'result was exact'); $inex = Rmpfr_tanpi($rop1, Math::MPFR->new(-0.25), MPFR_RNDN); cmp_ok($rop1, '==', -1, 'tanpi(-0.25) is -1'); cmp_ok($inex, '==', 0, 'result was exact'); Rmpfr_sinpi($rop1, Math::MPFR->new(0.25), MPFR_RNDN); Rmpfr_sinu ($rop2, Math::MPFR->new(45), 360, MPFR_RNDN); cmp_ok($rop1, '==', $rop2, "Rmpfr_sinu and Rmpfr_sinpi agree"); Rmpfr_rec_sqrt($rop1, Math::MPFR->new(2), MPFR_RNDN); cmp_ok($rop1, '==', $rop2, "Rmpfr_rec_sqrt(2) == Rmpfr_sinu(2)"); ## my($s, $c) = (0, 0); my $rop3 = Math::MPFR->new(); my $rop4 = Math::MPFR->new(); for(2 .. $Math::MPFR::NV_properties{bits}) { next unless $_ % 11; $s += 2 ** -$_; $c = 0.5 - $s; my $op1 = Math::MPFR->new($s); my $op2 = Math::MPFR->new($c); Rmpfr_sinpi($rop1, Math::MPFR->new($op1), MPFR_RNDN); Rmpfr_cospi($rop2, Math::MPFR->new($op2), MPFR_RNDN); cmp_ok($rop1, '==', $rop2, "$_: sinpi(x) == cospi(0.5 - x)"); Rmpfr_sinu($rop3, Math::MPFR->new($op1 * 180), 360, MPFR_RNDN); Rmpfr_cosu($rop4, Math::MPFR->new($op2 * 180), 360, MPFR_RNDN); cmp_ok($rop1, '==', $rop3, "$_: sinpi(x) == sinu(x * 180, 360)"); cmp_ok($rop2, '==', $rop4, "$_: cospi(x) == cosu(x * 180, 360)"); } } else { # Rmpfr_sinu(), Rmpfr_cosu(), Rmpfr_tanu(), Rmpfr_sinpi(), # Rmpfr_cospi and Rmpfr_tanpi() are all unavailable eval{ Rmpfr_sinu($rop1, Math::MPFR->new(6), 3, MPFR_RNDN); }; like($@, qr/^Rmpfr_sinu function not implemented/, 'Rmpfr_sinu: $@ set as expected'); eval{ Rmpfr_cosu($rop1, Math::MPFR->new(6), 3, MPFR_RNDN); }; like($@, qr/^Rmpfr_cosu function not implemented/, 'Rmpfr_cosu: $@ set as expected'); eval{ Rmpfr_tanu($rop1, Math::MPFR->new(6), 3, MPFR_RNDN); }; like($@, qr/^Rmpfr_tanu function not implemented/, 'Rmpfr_tanu: $@ set as expected'); eval{ Rmpfr_sinpi($rop1, Math::MPFR->new(6), MPFR_RNDN); }; like($@, qr/^Rmpfr_sinpi function not implemented/, 'Rmpfr_sinpi: $@ set as expected'); eval{ Rmpfr_cospi($rop1, Math::MPFR->new(6), MPFR_RNDN); }; like($@, qr/^Rmpfr_cospi function not implemented/, 'Rmpfr_cospi: $@ set as expected'); eval{ Rmpfr_tanpi($rop1, Math::MPFR->new(6), MPFR_RNDN); }; like($@, qr/^Rmpfr_tanpi function not implemented/, 'Rmpfr_tanpi: $@ set as expected'); } done_testing(); __END__ Math-MPFR-4.38/t/rndna.t0000755060175106010010000012155014765756127013445 0ustar OwnerNoneuse strict; use warnings; use Math::MPFR qw(:mpfr); use Config; print "1..130\n"; warn "\n # Minimum allowed exponent: ", Rmpfr_get_emin_min(), "\n"; warn " # Current minimum exponent: ", Rmpfr_get_emin(), "\n"; my $ok = 1; my $have_gmpq = 0; my $have_gmpz = 0; eval {require Math::GMPq;}; unless($@) {$have_gmpq = 1} eval {require Math::GMPz;}; unless($@) {$have_gmpz = 1} for(1..10) { my $str = '1.'; for(1..70) {$str .= int(rand(2));} $str .= '01'; my $nstr = '-' . $str; my $longrop = Rmpfr_init2(73); my $check = Rmpfr_init2(72); my $shortrop = Rmpfr_init2(72); my $coderef = \&Rmpfr_set; my $inex = Rmpfr_set_str($longrop, $str, 2, MPFR_RNDN); if($inex) {die "Rmpfr_set_str falsely returned $inex"} my $ret = rndna($coderef, $shortrop, $longrop); # $shortrop should always be rounded up, $longrop is exact. unless($shortrop > $longrop && $ret > 0) { $ok = 0; warn "\n gt: \$shortrop: $shortrop\n \$longrop: $longrop\n \$ret: $ret\n"; } $ret = rndna(\&Rmpfr_strtofr, $check, $str, 2); unless($shortrop == $check && $ret > 0) { $ok = 0; warn "\n gt: \$shortrop: $shortrop\n \$check: $check\n"; } $longrop *= -1; $ret = rndna($coderef, $shortrop, $longrop); # $shortrop should always be rounded down, $longrop is exact. unless($shortrop < $longrop && $ret < 0) { $ok = 0; warn "\n lt: \$shortrop: $shortrop\n \$longrop: $longrop\n \$ret: $ret\n"; } $ret = rndna(\&Rmpfr_strtofr, $check, $nstr, 2); unless($shortrop == $check && $ret < 0) { $ok = 0; warn "\n gt: \$shortrop: $shortrop\n \$check: $check\n \$ret: $ret\n"; } } if($ok) {print "ok 1\n"} else {print "not ok 1\n"} $ok = 1; for(1..10) { my $str = '1.'; for(1..70) {$str .= int(rand(2));} $str .= '011'; my $nstr = '-' . $str; my $longrop = Rmpfr_init2(74); my $check = Rmpfr_init2(72); my $shortrop = Rmpfr_init2(72); my $coderef = \&Rmpfr_set; my $inex = Rmpfr_set_str($longrop, $str, 2, MPFR_RNDN); if($inex) {die "Rmpfr_set_str falsely returned $inex"} my $ret = rndna($coderef, $shortrop, $longrop); # $shortrop should always be rounded up, $longrop is exact. unless($shortrop > $longrop && $ret > 0) { $ok = 0; warn "\n gt: \$shortrop: $shortrop\n \$longrop: $longrop\n \$ret: $ret\n"; } $ret = rndna(\&Rmpfr_strtofr, $check, $str, 2); unless($shortrop == $check && $ret > 0) { $ok = 0; warn "\n gt: \$shortrop: $shortrop\n \$check: $check\n \$ret: $ret\n"; } $longrop *= -1; $ret = rndna($coderef, $shortrop, $longrop); # $shortrop should always be rounded down, $longrop is exact. unless($shortrop < $longrop && $ret < 0) { $ok = 0; warn "\n lt: \$shortrop: $shortrop\n \$longrop: $longrop\n \$ret: $ret\n"; } $ret = rndna(\&Rmpfr_strtofr, $check, $nstr, 2); unless($shortrop == $check && $ret < 0) { $ok = 0; warn "\n gt: \$shortrop: $shortrop\n \$check: $check\n \$ret: $ret\n"; } } if($ok) {print "ok 2\n"} else {print "not ok 2\n"} $ok = 1; for(1..10) { my $str = '1.'; for(1..70) {$str .= int(rand(2));} $str .= '001'; my $nstr = '-' . $str; my $longrop = Rmpfr_init2(74); my $check = Rmpfr_init2(72); my $shortrop = Rmpfr_init2(72); my $coderef = \&Rmpfr_set; my $inex = Rmpfr_set_str($longrop, $str, 2, MPFR_RNDN); if($inex) {die "Rmpfr_set_str falsely returned $inex"} my $ret = rndna($coderef, $shortrop, $longrop); # $shortrop should always be rounded down, $longrop is exact. unless($shortrop < $longrop && $ret < 0) { $ok = 0; warn "\n gt: \$shortrop: $shortrop\n \$longrop: $longrop\n \$ret: $ret\n"; } $ret = rndna(\&Rmpfr_strtofr, $check, $str, 2); unless($shortrop == $check && $ret < 0) { $ok = 0; warn "\n gt: \$shortrop: $shortrop\n \$check: $check\n \$ret: $ret\n"; } $longrop *= -1; $ret = rndna($coderef, $shortrop, $longrop); # $shortrop should always be rounded up, $longrop is exact. unless($shortrop > $longrop && $ret > 0) { $ok = 0; warn "\n lt: \$shortrop: $shortrop\n \$longrop: $longrop\n \$ret: $ret\n"; } $ret = rndna(\&Rmpfr_strtofr, $check, $nstr, 2); unless($shortrop == $check && $ret > 0) { $ok = 0; warn "\n gt: \$shortrop: $shortrop\n \$check: $check\n \$ret: $ret\n"; } } if($ok) {print "ok 3\n"} else {print "not ok 3\n"} $ok = 1; #################################### for my $suffix('010', '011', '110', '111') { for(1..10) { my $str = '1.'; for(1..70) {$str .= int(rand(2)); } $str .= $suffix; my $nstr = '-' . $str; my $longrop = Rmpfr_init2(74); my $check = Rmpfr_init2(72); my $shortrop = Rmpfr_init2(72); my $coderef = \&Rmpfr_set; my $inex = Rmpfr_set_str($longrop, $str, 2, MPFR_RNDN); if($inex) {die "Rmpfr_set_str falsely returned $inex"} my $ret = rndna($coderef, $shortrop, $longrop); # $shortrop should always be rounded up, $longrop is exact. unless($shortrop > $longrop && $ret > 0) { $ok = 0; warn "\n gt: \$shortrop: $shortrop\n \$longrop: $longrop\n \$ret: $ret\n"; } $ret = rndna(\&Rmpfr_strtofr, $check, $str, 2); unless($shortrop == $check && $ret > 0) { $ok = 0; warn "\n gt: \$shortrop: $shortrop\n \$check: $check\n \$ret: $ret\n"; } $longrop *= -1; $ret = rndna($coderef, $shortrop, $longrop); # $shortrop should always be rounded down, $longrop is exact. unless($shortrop < $longrop && $ret < 0) { $ok = 0; warn "\n lt: \$shortrop: $shortrop\n \$longrop: $longrop\n \$ret: $ret\n"; } $ret = rndna(\&Rmpfr_strtofr, $check, $nstr, 2); unless($shortrop == $check && $ret < 0) { $ok = 0; warn "\n gt: \$shortrop: $shortrop\n \$check: $check\n \$ret: $ret\n"; } } if($ok) { print "ok 4\n" if $suffix eq '010'; print "ok 5\n" if $suffix eq '011'; print "ok 6\n" if $suffix eq '110'; print "ok 7\n" if $suffix eq '111'; } else { print "not ok 4\n" if $suffix eq '010'; print "not ok 5\n" if $suffix eq '011'; print "not ok 6\n" if $suffix eq '110'; print "not ok 7\n" if $suffix eq '111'; } $ok = 1; } #################################### #################################### for my $suffix('001', '101') { for(1..10) { my $str = '1.'; for(1..70) {$str .= int(rand(2));} $str .= $suffix; my $nstr = '-' . $str; my $longrop = Rmpfr_init2(74); my $check = Rmpfr_init2(72); my $shortrop = Rmpfr_init2(72); my $coderef = \&Rmpfr_set; my $inex = Rmpfr_set_str($longrop, $str, 2, MPFR_RNDN); if($inex) {die "Rmpfr_set_str falsely returned $inex"} my $ret = rndna($coderef, $shortrop, $longrop); # $shortrop should always be rounded down, $longrop is exact. unless($shortrop < $longrop && $ret < 0) { $ok = 0; warn "\n gt: \$shortrop: $shortrop\n \$longrop: $longrop\n \$ret: $ret\n"; } $ret = rndna(\&Rmpfr_strtofr, $check, $str, 2); unless($shortrop == $check && $ret < 0) { $ok = 0; warn "\n gt: \$shortrop: $shortrop\n \$check: $check\n \$ret: $ret\n"; } $longrop *= -1; $ret = rndna($coderef, $shortrop, $longrop); # $shortrop should always be rounded up, $longrop is exact. unless($shortrop > $longrop && $ret > 0) { $ok = 0; warn "\n lt: \$shortrop: $shortrop\n \$longrop: $longrop\n \$ret: $ret\n"; } $ret = rndna(\&Rmpfr_strtofr, $check, $nstr, 2); unless($shortrop == $check && $ret > 0) { $ok = 0; warn "\n gt: \$shortrop: $shortrop\n \$check: $check\n \$ret: $ret\n"; } } if($ok) { print "ok 8\n" if $suffix eq '001'; print "ok 9\n" if $suffix eq '101'; } else { print "not ok 8\n" if $suffix eq '001'; print "not ok 9\n" if $suffix eq '101'; } $ok = 1; } #################################### #################################### #################################### for my $suffix('000', '100') { for(1..10) { my $str = '1.'; for(1..70) {$str .= int(rand(2));} $str .= $suffix; my $nstr = '-' . $str; my $longrop = Rmpfr_init2(74); my $check = Rmpfr_init2(72); my $shortrop = Rmpfr_init2(72); my $coderef = \&Rmpfr_set; my $inex = Rmpfr_set_str($longrop, $str, 2, MPFR_RNDN); if($inex) {die "Rmpfr_set_str falsely returned $inex"} my $ret = rndna($coderef, $shortrop, $longrop); # No rounding, result is exact. unless($shortrop == $longrop && $ret == 0) { $ok = 0; warn "\n gt: \$shortrop: $shortrop\n \$longrop: $longrop\n \$ret: $ret\n"; } $ret = rndna(\&Rmpfr_strtofr, $check, $str, 2); unless($shortrop == $check && $ret == 0) { $ok = 0; warn "\n gt: \$shortrop: $shortrop\n \$check: $check\n \$ret: $ret\n"; } $longrop *= -1; $ret = rndna($coderef, $shortrop, $longrop); # No rounding, result is exact unless($shortrop == $longrop && $ret == 0) { $ok = 0; warn "\n lt: \$shortrop: $shortrop\n \$longrop: $longrop\n \$ret: $ret\n"; } $ret = rndna(\&Rmpfr_strtofr, $check, $nstr, 2); unless($shortrop == $check && $ret == 0) { $ok = 0; warn "\n gt: \$shortrop: $shortrop\n \$check: $check\n \$ret: $ret\n"; } } if($ok) { print "ok 10\n" if $suffix eq '000'; print "ok 11\n" if $suffix eq '100'; } else { print "not ok 10\n" if $suffix eq '000'; print "not ok 11\n" if $suffix eq '100'; } $ok = 1; } #################################### #################################### #################################### #################################### #Rmpfr_set_emin(Rmpfr_get_emin_min()); $ok = 1; for(1..10) { my $str = '0.1'; for(1..70) {$str .= int(rand(2));} $str .= '01' . '@' . Rmpfr_get_emin(); my $nstr = '-' . $str; my $longrop = Rmpfr_init2(73); my $check = Rmpfr_init2(72); my $shortrop = Rmpfr_init2(72); my $coderef = \&Rmpfr_set; my $inex = Rmpfr_set_str($longrop, $str, 2, MPFR_RNDN); if($inex) {die "Rmpfr_set_str falsely returned $inex"} my $ret = rndna($coderef, $shortrop, $longrop); # $shortrop should always be rounded up, $longrop is exact. unless($shortrop > $longrop && $ret > 0) { $ok = 0; warn "\n gt: \$shortrop: $shortrop\n \$longrop: $longrop\n \$ret: $ret\n"; } $ret = rndna(\&Rmpfr_strtofr, $check, $str, 2); unless($shortrop == $check && $ret > 0) { $ok = 0; warn "\n gt: \$shortrop: $shortrop\n \$check: $check\n \$ret: $ret\n"; } $longrop *= -1; $ret = rndna($coderef, $shortrop, $longrop); # $shortrop should always be rounded down, $longrop is exact. unless($shortrop < $longrop && $ret < 0) { $ok = 0; warn "\n lt: \$shortrop: $shortrop\n \$longrop: $longrop\n \$ret: $ret\n"; } rndna(\&Rmpfr_strtofr, $check, $nstr, 2); unless($shortrop == $check && $ret < 0) { $ok = 0; warn "\n gt: \$shortrop: $shortrop\n \$check: $check\n \$ret: $ret\n"; } } if($ok) {print "ok 12\n"} else {print "not ok 12\n"} $ok = 1; for(1..10) { my $str = '0.1'; for(1..70) {$str .= int(rand(2));} $str .= '011' . '@' . Rmpfr_get_emin(); my $nstr = '-' . $str; my $longrop = Rmpfr_init2(74); my $check = Rmpfr_init2(72); my $shortrop = Rmpfr_init2(72); my $coderef = \&Rmpfr_set; my $inex = Rmpfr_set_str($longrop, $str, 2, MPFR_RNDN); if($inex) {die "Rmpfr_set_str falsely returned $inex"} my $ret = rndna($coderef, $shortrop, $longrop); # $shortrop should always be rounded up, $longrop is exact. unless($shortrop > $longrop && $ret > 0) { $ok = 0; warn "\n gt: \$shortrop: $shortrop\n \$longrop: $longrop\n \$ret: $ret\n"; } $ret = rndna(\&Rmpfr_strtofr, $check, $str, 2); unless($shortrop == $check && $ret > 0) { $ok = 0; warn "\n gt: \$shortrop: $shortrop\n \$check: $check\n \$ret: $ret\n"; } $longrop *= -1; $ret = rndna($coderef, $shortrop, $longrop); # $shortrop should always be rounded down, $longrop is exact. unless($shortrop < $longrop && $ret < 0) { $ok = 0; warn "\n lt: \$shortrop: $shortrop\n \$longrop: $longrop\n \$ret: $ret\n"; } $ret = rndna(\&Rmpfr_strtofr, $check, $nstr, 2); unless($shortrop == $check && $ret < 0) { $ok = 0; warn "\n gt: \$shortrop: $shortrop\n \$check: $check\n \$ret: $ret"; } } if($ok) {print "ok 13\n"} else {print "not ok 13\n"} $ok = 1; for(1..10) { my $str = '0.1'; for(1..70) {$str .= int(rand(2));} $str .= '001' . '@' . Rmpfr_get_emin(); my $nstr = '-' . $str; my $longrop = Rmpfr_init2(74); my $check = Rmpfr_init2(72); my $shortrop = Rmpfr_init2(72); my $coderef = \&Rmpfr_set; my $inex = Rmpfr_set_str($longrop, $str, 2, MPFR_RNDN); if($inex) {die "Rmpfr_set_str falsely returned $inex"} my $ret = rndna($coderef, $shortrop, $longrop); # $shortrop should always be rounded down, $longrop is exact. unless($shortrop < $longrop && $ret < 0) { $ok = 0; warn "\n gt: \$shortrop: $shortrop\n \$longrop: $longrop\n \$ret: $ret\n"; } $ret = rndna(\&Rmpfr_strtofr, $check, $str, 2); unless($shortrop == $check && $ret < 0) { $ok = 0; warn "\n gt: \$shortrop: $shortrop\n \$check: $check\n \$ret: $ret\n"; } $longrop *= -1; $ret = rndna($coderef, $shortrop, $longrop); # $shortrop should always be rounded up, $longrop is exact. unless($shortrop > $longrop && $ret > 0) { $ok = 0; warn "\n lt: \$shortrop: $shortrop\n \$longrop: $longrop\n \$ret: $ret\n"; } $ret = rndna(\&Rmpfr_strtofr, $check, $nstr, 2); unless($shortrop == $check && $ret > 0) { $ok = 0; warn "\n gt: \$shortrop: $shortrop\n \$check: $check\n \$ret: $ret\n"; } } if($ok) {print "ok 14\n"} else {print "not ok 14\n"} $ok = 1; my $longrop = Rmpfr_init2(73); my $shortrop = Rmpfr_init2(72); my $coderef = \&Rmpfr_set; ################ Rmpfr_set_inf($longrop, 1); my $ret = rndna($coderef,$shortrop, $longrop); if($shortrop == $longrop && $ret == 0) { print "ok 15\n"; } else { warn "\n $shortrop: $shortrop\n \$longrop: $longrop\n \$ret: $ret\n"; print "not ok 15\n"; } ################ ################ Rmpfr_set_inf($longrop, -1); $ret = rndna($coderef,$shortrop, $longrop); if($shortrop == $longrop && $ret == 0) { print "ok 16\n"; } else { warn "\n \$shortrop: $shortrop\n \$longrop: $longrop\n \$ret: $ret\n"; print "not ok 16\n"; } ################ ################ Rmpfr_set_zero($longrop, 1); $ret = rndna($coderef,$shortrop, $longrop); if($shortrop == $longrop && $ret == 0) { print "ok 17\n"; } else { warn "\n \$shortrop: $shortrop\n \$longrop: $longrop\n \$ret: $ret\n"; print "not ok 17\n"; } ################ ################ Rmpfr_set_zero($longrop, -1); $ret = rndna($coderef,$shortrop, $longrop); if($shortrop == $longrop && $ret == 0) { print "ok 18\n"; } else { warn "\n \$shortrop: $shortrop\n \$longrop: $longrop\n \$ret: $ret\n"; print "not ok 18\n"; } ################ ################ Rmpfr_set_nan($longrop); $ret = rndna($coderef,$shortrop, $longrop); if(Rmpfr_nan_p($shortrop) && Rmpfr_nan_p($longrop) && $ret == 0) { print "ok 19\n"; } else { warn "\n \$shortrop: $shortrop\n \$longrop: $longrop\n \$ret: $ret\n"; print "not ok 19\n"; } my $small_1 = Math::MPFR->new(7.5); my $small_2 = Math::MPFR->new(6.5); $ret = rndna(\&Rmpfr_prec_round, $small_1, 3); if($ret > 0 && $small_1 == 8) {print "ok 20\n"} else { warn "\n \$ret: $ret\n \$small_1:$small_1\n"; print "not ok 20\n"; } $ret = rndna(\&Rmpfr_prec_round, $small_2, 3); if($ret > 0 && $small_2 == 7) {print "ok 21\n"} else { warn "\n \$ret: $ret\n \$small_2:$small_2\n"; print "not ok 21\n"; } #################################### # Change precision to 53. Rmpfr_set_prec($small_1, 53); Rmpfr_set_prec($small_2, 53); Rmpfr_set_d($small_1, 7.4, MPFR_RNDN); Rmpfr_set_d($small_2, 6.6, MPFR_RNDN); $ret = rndna(\&Rmpfr_prec_round, $small_1, 3); if($ret < 0 && $small_1 == 7) {print "ok 22\n"} else { warn "\n \$ret: $ret\n \$small_1:$small_1\n"; print "not ok 22\n"; } $ret = rndna(\&Rmpfr_prec_round, $small_2, 3); if($ret > 0 && $small_2 == 7) {print "ok 23\n"} else { warn "\n \$ret: $ret\n \$small_2:$small_2\n"; print "not ok 23\n"; } #################################### # Change precision to 53. Rmpfr_set_prec($small_1, 53); Rmpfr_set_prec($small_2, 53); Rmpfr_set_d($small_1, 7.5, MPFR_RNDN); Rmpfr_set_d($small_2, 6.5, MPFR_RNDN); $ret = rndna(\&Rmpfr_prec_round, $small_1, 4); if($ret == 0 && $small_1 == 7.5) {print "ok 24\n"} else { warn "\n \$ret: $ret\n \$small_1:$small_1\n"; print "not ok 24\n"; } $ret = rndna(\&Rmpfr_prec_round, $small_2, 4); if($ret == 0 && $small_2 == 6.5) {print "ok 25\n"} else { warn "\n \$ret: $ret\n \$small_2:$small_2\n"; print "not ok 25\n"; } #################################### # Change precision to 53. Rmpfr_set_prec($small_1, 53); Rmpfr_set_prec($small_2, 53); Rmpfr_set_d($small_1, 7.25, MPFR_RNDN); Rmpfr_set_d($small_2, 6.25, MPFR_RNDN); $ret = rndna(\&Rmpfr_prec_round, $small_1, 3); if($ret < 0 && $small_1 == 7) {print "ok 26\n"} else { warn "\n \$ret: $ret\n \$small_1:$small_1\n"; print "not ok 26\n"; } $ret = rndna(\&Rmpfr_prec_round, $small_2, 3); if($ret < 0 && $small_2 == 6) {print "ok 27\n"} else { warn "\n \$ret: $ret\n \$small_2:$small_2\n"; print "not ok 27\n"; } #################################### # Change precision to 53. Rmpfr_set_prec($small_1, 53); Rmpfr_set_prec($small_2, 53); Rmpfr_set_d($small_1, 7.0, MPFR_RNDN); Rmpfr_set_d($small_2, 6.0, MPFR_RNDN); $ret = rndna(\&Rmpfr_prec_round, $small_1, 3); if($ret == 0 && $small_1 == 7) {print "ok 28\n"} else { warn "\n \$ret: $ret\n \$small_1:$small_1\n"; print "not ok 28\n"; } $ret = rndna(\&Rmpfr_prec_round, $small_2, 3); if($ret == 0 && $small_2 == 6) {print "ok 29\n"} else { warn "\n \$ret: $ret\n \$small_2:$small_2\n"; print "not ok 29\n"; } #################################### my $nan = Rmpfr_init(); my $inf = Math::MPFR->new(1) / Math::MPFR->new(0); my $ninf = Math::MPFR->new(-1) / Math::MPFR->new(0); #################################### $ret = rndna(\&Rmpfr_prec_round, $nan, 2); if(Rmpfr_get_prec($nan) == 2 && Rmpfr_nan_p($nan) && $ret == 0) {print "ok 30\n"} else { warn "\n prec: ", Rmpfr_get_prec($nan), "\n \$nan: $nan\n \$ret: $ret\n"; print "not ok 30\n"; } #################################### $ret = rndna(\&Rmpfr_prec_round, $inf, 2); if(Rmpfr_get_prec($inf) == 2 && Rmpfr_inf_p($inf) && $ret == 0 && $inf > 0) {print "ok 31\n"} else { warn "\n prec: ", Rmpfr_get_prec($inf), "\n \$inf: $inf\n \$ret: $ret\n"; print "not ok 31\n"; } #################################### $ret = rndna(\&Rmpfr_prec_round, $ninf, 2); if(Rmpfr_get_prec($ninf) == 2 && Rmpfr_inf_p($ninf) && $ret == 0 && $ninf < 0) {print "ok 32\n"} else { warn "\n prec: ", Rmpfr_get_prec($ninf), "\n \$ninf: $ninf\n \$ret: $ret\n"; print "not ok 32\n"; } #################################### #################################### my $rop = Rmpfr_init(); my $min = Rmpfr_init(); my $minstring = '0.1@' . Rmpfr_get_emin(); Rmpfr_set_str($min, $minstring, 2, MPFR_RNDN); my $mul = Math::MPFR->new(2); Rmpfr_pow_si($mul, $mul, Rmpfr_get_emin(), MPFR_RNDN); if($mul * 0.5 == $min) {print "ok 33\n"} else { warn "\n $mul * 0.5 != $min\n Ensuing tests may fail\n"; print "not ok 33\n"; } if(Rmpfr_get_emin() == Rmpfr_get_emin_min()) { eval {my $inex = Rmpfr_round_nearest_away(\&Rmpfr_mul_d, $rop, $mul, 0.25);}; if($@ =~ /You need to set emin \(using Rmpfr_set_emin/) {print "ok 34\n"} else { warn "\n\$\@: $@\n"; print "not ok 34\n"; } } else { warn "\n Skipping test 34 - Rmpfr_get_emin() != Rmpfr_get_emin_min()\n"; print "ok 34\n"; } my $inex = rndna(\&Rmpfr_mul_d, $rop, $mul, 0.25); # Expect that rndna() gets it wrong (and check that's what happens): if($inex == -1 && $rop == 0 && !Rmpfr_signbit($rop)) {print "ok 35\n"} else { warn "\n \$inex: $inex\n \$rop: $rop\n"; print "not ok 35\n"; } $inex = rndna(\&Rmpfr_mul_d, $rop, $mul, 0.0625); if($inex == -1 && $rop == 0) {print "ok 36\n"} else { warn "\n \$inex: $inex\n \$rop: $rop\n"; print "not ok 36\n"; } $inex = rndna(\&Rmpfr_mul_d, $rop, $mul, 0.75); if($inex == 0 && $rop > $min) {print "ok 37\n"} else { # Rmpfr_mul_d($rop, $mul, 0.75, MPFR_RNDA); warn "\n \$inex: $inex\n \$rop: $rop\n"; print "not ok 37\n"; } ################################ $inex = rndna(\&Rmpfr_mul_d, $rop, $mul, -0.5); if($inex == 0 && abs($rop) == $min) {print "ok 38\n"} else { # Rmpfr_mul_d($rop, $mul, -0.5, MPFR_RNDA); warn "\n\$inex: $inex\n \$rop: $rop\n"; print "not ok 38\n"; } $inex = rndna(\&Rmpfr_mul_d, $rop, $mul, -0.25); # Expect that rndna() gets it wrong (and check that's what happens): if($inex == 1 && $rop == 0 && Rmpfr_signbit($rop)) {print "ok 39\n"} else { # Rmpfr_mul_d($rop, $mul, -0.25, MPFR_RNDA); warn "\n\$inex: $inex\n \$rop: $rop\n"; print "not ok 39\n"; } $inex = rndna(\&Rmpfr_mul_d, $rop, $mul, -0.0625); if($inex == 1 && $rop ==0) {print "ok 40\n"} else { # Rmpfr_mul_d($rop, $mul, -0.0625, MPFR_RNDA); warn "\n\$inex: $inex\n \$rop: $rop\n"; print "not ok 40\n"; } $inex = rndna(\&Rmpfr_mul_d, $rop, $mul, -0.75); if($inex == 0 && $rop < $min * -1) {print "ok 41\n"} else { # Rmpfr_mul_d($rop, $mul, -0.75, MPFR_RNDA); warn "\n\$inex: $inex\n \$rop: $rop\n"; print "not ok 41\n"; } $inex = rndna(\&Rmpfr_mul_d, $rop, $mul, -0.0); if($inex == 0 && $rop == 0 && Rmpfr_signbit($rop)) {print "ok 42\n"} else { # Rmpfr_mul_d($rop, $mul, -0.0, MPFR_RNDA); warn "\n\$inex: $inex\n \$rop: $rop\n sign: ", Rmpfr_sgn($rop), "\n"; print "not ok 42\n"; } Rmpfr_set_default_prec(41); my $ps = Math::MPFR->new(); my $ns = Math::MPFR->new(); $ok = 1; for(1..100) { my $str = int(rand(2)); my $str_check = $str; for(1..40) {$str .= int(rand(2))} my $str_keep = $str; $str_check = substr($str, -1, 1) if $str_check; my $mul = int(rand(2)) == 0 ? 1 : -1; my $exponent = int(rand(100)); $exponent *= $mul; $str .= '@' . $exponent; Rmpfr_set_str($ps, $str, 2, MPFR_RNDN); Rmpfr_neg($ns, $ps, MPFR_RNDN); my $lsb = Math::MPFR::_lsb($ps); if(Math::MPFR::_lsb($ns) != $lsb) {$ok = 2} if(substr($str, 0, 1) eq '0' && "$lsb" ne '0') { $ok = 3; } if(substr($str_keep, 0, 1) eq '1' && substr($str_keep, -1, 1) eq '1' && "$lsb" ne '1') { warn "\n \$str_keep: $str_keep\n \$lsb: $lsb\n"; $ok = 4; } if($lsb != $str_check) {$ok = 0} } if($ok == 1) {print "ok 43\n"} else { warn "\n \$ok: $ok\n"; print "not ok 43\n"; } $ok = 1; Rmpfr_set_default_prec(67); my $ps2 = Math::MPFR->new(); my $ns2 = Math::MPFR->new(); for(1..100) { my $str = int(rand(2)); my $str_check = $str; for(1..66) {$str .= int(rand(2))} my $str_keep = $str; $str_check = substr($str, -1, 1) if $str_check; my $mul = int(rand(2)) == 0 ? 1 : -1; my $exponent = int(rand(1000)); $exponent *= $mul; $str .= '@' . $exponent; Rmpfr_set_str($ps2, $str, 2, MPFR_RNDN); Rmpfr_neg($ns2, $ps2, MPFR_RNDN); my $lsb = Math::MPFR::_lsb($ps2); if(Math::MPFR::_lsb($ns2) != $lsb) {$ok = 2} if(substr($str, 0, 1) eq '0' && "$lsb" ne '0') { $ok = 3; } if(substr($str_keep, 0, 1) eq '1' && substr($str_keep, -1, 1) eq '1' && "$lsb" ne '1') { warn "\n \$str_keep: $str_keep\n \$lsb: $lsb\n"; $ok = 4; } if($lsb != $str_check) {$ok = 0} } if($ok == 1) {print "ok 44\n"} else { warn "\n \$ok: $ok\n"; print "not ok 44\n"; } $ok = 1; if(Math::MPFR::_lsb(Math::MPFR->new()) == 0) {print "ok 45\n"} else { warn "\n ", Math::MPFR::_lsb(Math::MPFR->new()), "\n"; print "not ok 45\n"; } if(Math::MPFR::_lsb(Math::MPFR->new(1) / Math::MPFR->new(0)) == 0) {print "ok 46\n"} else { warn "\n ", Math::MPFR::_lsb(Math::MPFR->new(1) / Math::MPFR->new(0)), "\n"; print "not ok 46\n"; } if(Math::MPFR::_lsb(Math::MPFR->new(-1) / Math::MPFR->new(0)) == 0) {print "ok 47\n"} else { warn "\n ", Math::MPFR::_lsb(Math::MPFR->new(-1) / Math::MPFR->new(0)), "\n"; print "not ok 47\n"; } if(Math::MPFR::_lsb(Math::MPFR->new(0)) == 0) {print "ok 48\n"} else { warn "\n ", Math::MPFR::_lsb(Math::MPFR->new(0)), "\n"; print "not ok 48\n"; } my $prop = Rmpfr_init2(5); my $op = Math::MPFR->new(30.5); $inex = rndna(\&Rmpfr_abs, $prop, $op); if($inex > 0 && $prop == 31) {print "ok 49\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 49\n"; } $inex = rndna(\&Rmpfr_abs, $prop, $op * -1); if($inex > 0 && $prop == 31) {print "ok 50\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 50\n"; } Rmpfr_set_d($op, 29.5, MPFR_RNDN); $inex = rndna(\&Rmpfr_add, $prop, $op, Math::MPFR->new(1)); if($inex > 0 && $prop == 31) {print "ok 51\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 51\n"; } $inex = rndna(\&Rmpfr_add, $prop, $op * -1, Math::MPFR->new(-1)); if($inex < 0 && $prop == -31) {print "ok 52\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 52\n"; } $inex = rndna(\&Rmpfr_add_d, $prop, $op, 1.0); if($inex > 0 && $prop == 31) {print "ok 53\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 53\n"; } $inex = rndna(\&Rmpfr_add_d, $prop, $op * -1, -1.0); if($inex < 0 && $prop == -31) {print "ok 54\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 54\n"; } if($have_gmpq) { $inex = rndna(\&Rmpfr_add_q, $prop, $op, Math::GMPq->new(1.0)); if($inex > 0 && $prop == 31) {print "ok 55\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 55\n"; } $inex = rndna(\&Rmpfr_add_q, $prop, $op * -1, Math::GMPq->new(-1.0)); if($inex < 0 && $prop == -31) {print "ok 56\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 56\n"; } } else { warn "\n Skipping tests 55 & 56\n as Math::GMPq failed to load\n"; print "ok 55\n"; print "ok 56\n"; } $inex = rndna(\&Rmpfr_add_si, $prop, $op, 1); if($inex > 0 && $prop == 31) {print "ok 57\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 57\n"; } $inex = rndna(\&Rmpfr_add_si, $prop, $op * -1, -1); if($inex < 0 && $prop == -31) {print "ok 58\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 58\n"; } $inex = rndna(\&Rmpfr_add_ui, $prop, $op, 1); if($inex > 0 && $prop == 31) {print "ok 59\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 59\n"; } if($have_gmpz) { $inex = rndna(\&Rmpfr_add_z, $prop, $op, Math::GMPz->new(1.0)); if($inex > 0 && $prop == 31) {print "ok 60\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 60\n"; } $inex = rndna(\&Rmpfr_add_z, $prop, $op * -1, Math::GMPz->new(-1.0)); if($inex < 0 && $prop == -31) {print "ok 61\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 61\n"; } } else { warn "\n Skipping tests 60 & 61\n as Math::GMPz failed to load\n"; print "ok 60\n"; print "ok 61\n"; } ##~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~## Rmpfr_set_d($op, 15.25, MPFR_RNDN); $inex = rndna(\&Rmpfr_mul, $prop, $op, Math::MPFR->new(2)); if($inex > 0 && $prop == 31) {print "ok 62\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 62\n"; } $inex = rndna(\&Rmpfr_mul, $prop, $op * -1, Math::MPFR->new(2)); if($inex < 0 && $prop == -31) {print "ok 63\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 63\n"; } $inex = rndna(\&Rmpfr_mul_d, $prop, $op, 2.0); if($inex > 0 && $prop == 31) {print "ok 64\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 64\n"; } $inex = rndna(\&Rmpfr_mul_d, $prop, $op * -1, 2.0); if($inex < 0 && $prop == -31) {print "ok 65\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 65\n"; } if($have_gmpq) { $inex = rndna(\&Rmpfr_mul_q, $prop, $op, Math::GMPq->new(2.0)); if($inex > 0 && $prop == 31) {print "ok 66\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 66\n"; } $inex = rndna(\&Rmpfr_mul_q, $prop, $op * -1, Math::GMPq->new(2.0)); if($inex < 0 && $prop == -31) {print "ok 67\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 67\n"; } } else { warn "\n Skipping tests 66 & 67\n as Math::GMPq failed to load\n"; print "ok 66\n"; print "ok 67\n"; } $inex = rndna(\&Rmpfr_mul_si, $prop, $op, 2); if($inex > 0 && $prop == 31) {print "ok 68\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 68\n"; } $inex = rndna(\&Rmpfr_mul_si, $prop, $op, -2); if($inex < 0 && $prop == -31) {print "ok 69\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 69\n"; } $inex = rndna(\&Rmpfr_mul_ui, $prop, $op, 2); if($inex > 0 && $prop == 31) {print "ok 70\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 70\n"; } if($have_gmpz) { $inex = rndna(\&Rmpfr_mul_z, $prop, $op, Math::GMPz->new(2.0)); if($inex > 0 && $prop == 31) {print "ok 71\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 71\n"; } $inex = rndna(\&Rmpfr_mul_z, $prop, $op * -1, Math::GMPz->new(2.0)); if($inex < 0 && $prop == -31) {print "ok 72\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 72\n"; } } else { warn "\n Skipping tests 71 & 72\n as Math::GMPz failed to load\n"; print "ok 71\n"; print "ok 72\n"; } ##~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~## my $sqr = Rmpfr_init2(4); $inex = Rmpfr_set_d($sqr, 2.5, MPFR_RNDN); if(!$inex) {print "ok 73\n"} else { warn "\n \$inex: $inex\n"; print "not ok 73\n"; } $inex = rndna(\&Rmpfr_sqr, $sqr, $sqr); if($inex > 0 && $sqr == 6.5) {print "ok 74\n"} else { warn "\n \$inex: $inex\n \$sqr: $sqr\n"; print "not ok 74\n"; } Rmpfr_set_d($sqr, 2.5, MPFR_RNDN); $inex = Rmpfr_sqr($sqr, $sqr, MPFR_RNDN); if($inex < 0 && $sqr == 6) {print "ok 75\n"} else { warn "\n \$inex: $inex\n \$sqr: $sqr\n"; print "not ok 75\n"; } ##~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~## Rmpfr_set_d($op, 91.5, MPFR_RNDN); $inex = rndna(\&Rmpfr_div, $prop, $op, Math::MPFR->new(3)); if($inex > 0 && $prop == 31) {print "ok 76\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 76\n"; } $inex = rndna(\&Rmpfr_div, $prop, $op * -1, Math::MPFR->new(3)); if($inex < 0 && $prop == -31) {print "ok 77\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 77\n"; } $inex = rndna(\&Rmpfr_div_d, $prop, $op, 3.0); if($inex > 0 && $prop == 31) {print "ok 78\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 78\n"; } $inex = rndna(\&Rmpfr_div_d, $prop, $op * -1, 3.0); if($inex < 0 && $prop == -31) {print "ok 79\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 79\n"; } if($have_gmpq) { $inex = rndna(\&Rmpfr_div_q, $prop, $op, Math::GMPq->new(3.0)); if($inex > 0 && $prop == 31) {print "ok 80\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 80\n"; } $inex = rndna(\&Rmpfr_div_q, $prop, $op * -1, Math::GMPq->new(3.0)); if($inex < 0 && $prop == -31) {print "ok 81\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 81\n"; } } else { warn "\n Skipping tests 80 && 81\n as Math::GMPq failed to load\n"; print "ok 80\n"; print "ok 81\n"; } $inex = rndna(\&Rmpfr_div_si, $prop, $op, 3); if($inex > 0 && $prop == 31) {print "ok 82\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 82\n"; } $inex = rndna(\&Rmpfr_div_si, $prop, $op, -3); if($inex < 0 && $prop == -31) {print "ok 83\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 83\n"; } $inex = rndna(\&Rmpfr_div_ui, $prop, $op, 3); if($inex > 0 && $prop == 31) {print "ok 84\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 84\n"; } $inex = rndna(\&Rmpfr_div_ui, $prop, $op * -1, 3); if($inex < 0 && $prop == -31) {print "ok 85\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 85\n"; } if($have_gmpz) { $inex = rndna(\&Rmpfr_div_z, $prop, $op, Math::GMPz->new(3.0)); if($inex > 0 && $prop == 31) {print "ok 86\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 86\n"; } $inex = rndna(\&Rmpfr_div_z, $prop, $op * -1, Math::GMPz->new(3.0)); if($inex < 0 && $prop == -31) {print "ok 87\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 87\n"; } } else { warn "\n Skipping tests 86 & 87\n as Math::GMPz failed to load\n"; print "ok 86\n"; print "ok 87\n"; } Rmpfr_set_d($op, 6.0, MPFR_RNDN); $inex = rndna(\&Rmpfr_ui_div, $prop, 183, $op); if($inex > 0 && $prop == 31) {print "ok 88\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 88\n"; } $inex = rndna(\&Rmpfr_ui_div, $prop, 183, $op * -1); if($inex < 0 && $prop == -31) {print "ok 89\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 89\n"; } $inex = rndna(\&Rmpfr_si_div, $prop, 183, $op); if($inex > 0 && $prop == 31) {print "ok 90\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 90\n"; } $inex = rndna(\&Rmpfr_si_div, $prop, -183, $op); if($inex < 0 && $prop == -31) {print "ok 91\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 91\n"; } $inex = rndna(\&Rmpfr_d_div, $prop, 183.0, $op); if($inex > 0 && $prop == 31) {print "ok 92\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 92\n"; } $inex = rndna(\&Rmpfr_d_div, $prop, -183.0, $op); if($inex < 0 && $prop == -31) {print "ok 93\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 93\n"; } ##~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~## Rmpfr_set_d($prop, 1.5, MPFR_RNDN); $inex = rndna(\&Rmpfr_add, $prop, $prop, Math::MPFR->new(29)); if($inex > 0 && $prop == 31) {print "ok 94\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 94\n"; } Rmpfr_set_d($prop, 1.5, MPFR_RNDN); $inex = rndna(\&Rmpfr_add, $prop, $prop * -1, Math::MPFR->new(-29)); if($inex < 0 && $prop == -31) {print "ok 95\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 95\n"; } Rmpfr_set_d($prop, 2.0, MPFR_RNDN); $inex = rndna(\&Rmpfr_mul, $prop, $prop, Math::MPFR->new(15.25)); if($inex > 0 && $prop == 31) {print "ok 96\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 96\n"; } Rmpfr_set_d($prop, 2.0, MPFR_RNDN); $inex = rndna(\&Rmpfr_mul, $prop, $prop, Math::MPFR->new(-15.25)); if($inex < 0 && $prop == -31) {print "ok 97\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 97\n"; } Rmpfr_set_d($prop, 1.5, MPFR_RNDN); $inex = rndna(\&Rmpfr_sub, $prop, $prop, Math::MPFR->new(-29)); if($inex > 0 && $prop == 31) {print "ok 98\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 98\n"; } Rmpfr_set_d($prop, 1.5, MPFR_RNDN); $inex = rndna(\&Rmpfr_sub, $prop, $prop, Math::MPFR->new(32)); if($inex < 0 && $prop == -31) {print "ok 99\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 99\n"; } ##~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~## Rmpfr_set_d($op, 1.5, MPFR_RNDN); $inex = rndna(\&Rmpfr_sub, $prop, $op, Math::MPFR->new(-29)); if($inex > 0 && $prop == 31) {print "ok 100\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 100\n"; } $inex = rndna(\&Rmpfr_sub, $prop, $op * -1, Math::MPFR->new(29)); if($inex < 0 && $prop == -31) {print "ok 101\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 101\n"; } $inex = rndna(\&Rmpfr_sub_d, $prop, $op, -29.0); if($inex > 0 && $prop == 31) {print "ok 102\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 102\n"; } $inex = rndna(\&Rmpfr_sub_d, $prop, $op * -1, 29.0); if($inex < 0 && $prop == -31) {print "ok 103\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 103\n"; } if($have_gmpq) { $inex = rndna(\&Rmpfr_sub_q, $prop, $op, Math::GMPq->new(-29)); if($inex > 0 && $prop == 31) {print "ok 104\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 104\n"; } $inex = rndna(\&Rmpfr_sub_q, $prop, $op * -1, Math::GMPq->new(29)); if($inex < 0 && $prop == -31) {print "ok 105\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 105\n"; } } else { warn "\n Skipping tests 104 & 105\n as Math::GMPq failed to load\n"; print "ok 104\n"; print "ok 105\n"; } $inex = rndna(\&Rmpfr_sub_si, $prop, $op, -29); if($inex > 0 && $prop == 31) {print "ok 106\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 106\n"; } $inex = rndna(\&Rmpfr_sub_si, $prop, $op * -1, 29); if($inex < 0 && $prop == -31) {print "ok 107\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 107\n"; } $inex = rndna(\&Rmpfr_sub_ui, $prop, $op * -1, 29); if($inex < 0 && $prop == -31) {print "ok 108\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 108\n"; } if($have_gmpz) { $inex = rndna(\&Rmpfr_sub_z, $prop, $op, Math::GMPz->new(-29)); if($inex > 0 && $prop == 31) {print "ok 109\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 109\n"; } $inex = rndna(\&Rmpfr_sub_z, $prop, $op * -1, Math::GMPz->new(29)); if($inex < 0 && $prop == -31) {print "ok 110\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 110\n"; } $inex = rndna(\&Rmpfr_z_sub, $prop, Math::GMPz->new(-29), $op); if($inex < 0 && $prop == -31) {print "ok 111\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 111\n"; } } else { warn "\n Skipping tests 109, 110 & 111\n as Math::GMPz failed to load\n"; print "ok 109\n"; print "ok 110\n"; print "ok 111\n"; } Rmpfr_set_d($op, 29.5, MPFR_RNDN); $inex = rndna(\&Rmpfr_ui_sub, $prop, 60, $op); if($inex > 0 && $prop == 31) {print "ok 112\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 112\n"; } $inex = rndna(\&Rmpfr_si_sub, $prop, 60, $op); if($inex > 0 && $prop == 31) {print "ok 113\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 113\n"; } $inex = rndna(\&Rmpfr_si_sub, $prop, -60, $op * -1); if($inex < 0 && $prop == -31) {print "ok 114\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 114\n"; } $inex = rndna(\&Rmpfr_d_sub, $prop, 60.0, $op); if($inex > 0 && $prop == 31) {print "ok 115\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 115\n"; } $inex = rndna(\&Rmpfr_d_sub, $prop, -60.0, $op * -1); if($inex < 0 && $prop == -31) {print "ok 116\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 116\n"; } ##~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~## $inex = rndna(\&Rmpfr_fac_ui, $prop, 6); if($inex > 0 && $prop == 736) {print "ok 117\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 117\n"; } $inex = rndna(\&Rmpfr_sqrt, $prop, Math::MPFR->new(2025)); if($inex > 0 && $prop == 46) {print "ok 118\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 118\n"; } $inex = rndna(\&Rmpfr_sqrt_ui, $prop, 2025); if($inex > 0 && $prop == 46) {print "ok 119\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 119\n"; } if(MPFR_VERSION_MAJOR > 3) { $inex = rndna(\&Rmpfr_rootn_ui, $prop, Math::MPFR->new(2025), 2); } else { $inex = rndna(\&Rmpfr_root, $prop, Math::MPFR->new(2025), 2); } if($inex > 0 && $prop == 46) {print "ok 120\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 120\n"; } $inex = rndna(\&Rmpfr_cbrt, $prop, Math::MPFR->new(91125)); if($inex > 0 && $prop == 46) {print "ok 121\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 121\n"; } $inex = rndna(\&Rmpfr_set_ui, $prop, 45); if($inex > 0 && $prop == 46) {print "ok 122\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 122\n"; } $inex = rndna(\&Rmpfr_set_si, $prop, -45); if($inex < 0 && $prop == -46) {print "ok 123\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 123\n"; } $inex = rndna(\&Rmpfr_set_d, $prop, 45.0); if($inex > 0 && $prop == 46) {print "ok 124\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 124\n"; } if($Config{nvtype} eq '__float128' && Math::MPFR::_can_pass_float128()) { $inex = rndna(\&Rmpfr_set_float128, $prop, 45.0); if($inex > 0 && $prop == 46) {print "ok 125\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 125\n"; } } else { warn "Skipping test 125 - __float128 not supported\n"; print "ok 125\n"; } if($Config{nvsize} > 8) { # Rmpfr_set_ld is unavailable when nvsize <= 8 (even if nvtype is 'long double'). $inex = rndna(\&Rmpfr_set_ld, $prop, 45.0); if($inex > 0 && $prop == 46) {print "ok 126\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 126\n"; } } else { warn "Skipping test 126 - long double not supported\n"; print "ok 126\n"; } $inex = rndna(\&Rmpfr_ui_pow, $prop, 2025, Math::MPFR->new(0.5)); if($inex > 0 && $prop == 46) {print "ok 127\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 127\n"; } $inex = rndna(\&Rmpfr_pow_si, $sqr, Math::MPFR->new(2.5), 2); if($inex > 0 && $sqr == 6.5) {print "ok 128\n"} else { warn "\n \$inex: $inex\n \$sqr: $sqr\n"; print "not ok 128\n"; } $inex = rndna(\&Rmpfr_pow_ui, $sqr, Math::MPFR->new(2.5), 2); if($inex > 0 && $sqr == 6.5) {print "ok 129\n"} else { warn "\n \$inex: $inex\n \$sqr: $sqr\n"; print "not ok 129\n"; } if($have_gmpz) { $inex = rndna(\&Rmpfr_pow_z, $sqr, Math::MPFR->new(2.5), Math::GMPz->new(2)); if($inex > 0 && $sqr == 6.5) {print "ok 130\n"} else { warn "\n \$inex: $inex\n \$sqr: $sqr\n"; print "not ok 130\n"; } } else { warn "\n Skipping test 130\n as Math::GMPz failed to load\n"; print "ok 130\n"; } __END__ Math-MPFR-4.38/t/rndna2.t0000755060175106010010000012655014765756127013534 0ustar OwnerNone# Essentially the same as rndna.t, but # uses Rmpfr_round_nearest_away(). use strict; use warnings; use Math::MPFR qw(:mpfr); use Config; print "1..130\n"; warn "\n # Minimum allowed exponent: ", Rmpfr_get_emin_min(), "\n"; warn " # Current minimum exponent: ", Rmpfr_get_emin(), "\n"; if(Rmpfr_get_emin() <= Rmpfr_get_emin_min()) { Rmpfr_set_emin(Rmpfr_get_emin_min() + 1); warn " # Resetting minimum exponent to ", Rmpfr_get_emin(), "\n # for this test script. (See the\n", " # Rmpfr_round_nearest_away() documentation.)\n"; } my $ok = 1; my $have_gmpq = 0; my $have_gmpz = 0; eval {require Math::GMPq;}; unless($@) {$have_gmpq = 1} eval {require Math::GMPz;}; unless($@) {$have_gmpz = 1} for(1..10) { my $str = '1.'; for(1..70) {$str .= int(rand(2));} $str .= '01'; my $nstr = '-' . $str; my $longrop = Rmpfr_init2(73); my $check = Rmpfr_init2(72); my $shortrop = Rmpfr_init2(72); my $coderef = \&Rmpfr_set; my $inex = Rmpfr_set_str($longrop, $str, 2, MPFR_RNDN); if($inex) {die "Rmpfr_set_str falsely returned $inex"} my $ret = Rmpfr_round_nearest_away($coderef, $shortrop, $longrop); # $shortrop should always be rounded up, $longrop is exact. unless($shortrop > $longrop && $ret > 0) { $ok = 0; warn "\n gt: \$shortrop: $shortrop\n \$longrop: $longrop\n \$ret: $ret\n"; } $ret = Rmpfr_round_nearest_away(\&Rmpfr_strtofr, $check, $str, 2); unless($shortrop == $check && $ret > 0) { $ok = 0; warn "\n gt: \$shortrop: $shortrop\n \$check: $check\n"; } $longrop *= -1; $ret = Rmpfr_round_nearest_away($coderef, $shortrop, $longrop); # $shortrop should always be rounded down, $longrop is exact. unless($shortrop < $longrop && $ret < 0) { $ok = 0; warn "\n lt: \$shortrop: $shortrop\n \$longrop: $longrop\n \$ret: $ret\n"; } $ret = Rmpfr_round_nearest_away(\&Rmpfr_strtofr, $check, $nstr, 2); unless($shortrop == $check && $ret < 0) { $ok = 0; warn "\n gt: \$shortrop: $shortrop\n \$check: $check\n \$ret: $ret\n"; } } if($ok) {print "ok 1\n"} else {print "not ok 1\n"} $ok = 1; for(1..10) { my $str = '1.'; for(1..70) {$str .= int(rand(2));} $str .= '011'; my $nstr = '-' . $str; my $longrop = Rmpfr_init2(74); my $check = Rmpfr_init2(72); my $shortrop = Rmpfr_init2(72); my $coderef = \&Rmpfr_set; my $inex = Rmpfr_set_str($longrop, $str, 2, MPFR_RNDN); if($inex) {die "Rmpfr_set_str falsely returned $inex"} my $ret = Rmpfr_round_nearest_away($coderef, $shortrop, $longrop); # $shortrop should always be rounded up, $longrop is exact. unless($shortrop > $longrop && $ret > 0) { $ok = 0; warn "\n gt: \$shortrop: $shortrop\n \$longrop: $longrop\n \$ret: $ret\n"; } $ret = Rmpfr_round_nearest_away(\&Rmpfr_strtofr, $check, $str, 2); unless($shortrop == $check && $ret > 0) { $ok = 0; warn "\n gt: \$shortrop: $shortrop\n \$check: $check\n \$ret: $ret\n"; } $longrop *= -1; $ret = Rmpfr_round_nearest_away($coderef, $shortrop, $longrop); # $shortrop should always be rounded down, $longrop is exact. unless($shortrop < $longrop && $ret < 0) { $ok = 0; warn "\n lt: \$shortrop: $shortrop\n \$longrop: $longrop\n \$ret: $ret\n"; } $ret = Rmpfr_round_nearest_away(\&Rmpfr_strtofr, $check, $nstr, 2); unless($shortrop == $check && $ret < 0) { $ok = 0; warn "\n gt: \$shortrop: $shortrop\n \$check: $check\n \$ret: $ret\n"; } } if($ok) {print "ok 2\n"} else {print "not ok 2\n"} $ok = 1; for(1..10) { my $str = '1.'; for(1..70) {$str .= int(rand(2));} $str .= '001'; my $nstr = '-' . $str; my $longrop = Rmpfr_init2(74); my $check = Rmpfr_init2(72); my $shortrop = Rmpfr_init2(72); my $coderef = \&Rmpfr_set; my $inex = Rmpfr_set_str($longrop, $str, 2, MPFR_RNDN); if($inex) {die "Rmpfr_set_str falsely returned $inex"} my $ret = Rmpfr_round_nearest_away($coderef, $shortrop, $longrop); # $shortrop should always be rounded down, $longrop is exact. unless($shortrop < $longrop && $ret < 0) { $ok = 0; warn "\n gt: \$shortrop: $shortrop\n \$longrop: $longrop\n \$ret: $ret\n"; } $ret = Rmpfr_round_nearest_away(\&Rmpfr_strtofr, $check, $str, 2); unless($shortrop == $check && $ret < 0) { $ok = 0; warn "\n gt: \$shortrop: $shortrop\n \$check: $check\n \$ret: $ret\n"; } $longrop *= -1; $ret = Rmpfr_round_nearest_away($coderef, $shortrop, $longrop); # $shortrop should always be rounded up, $longrop is exact. unless($shortrop > $longrop && $ret > 0) { $ok = 0; warn "\n lt: \$shortrop: $shortrop\n \$longrop: $longrop\n \$ret: $ret\n"; } $ret = Rmpfr_round_nearest_away(\&Rmpfr_strtofr, $check, $nstr, 2); unless($shortrop == $check && $ret > 0) { $ok = 0; warn "\n gt: \$shortrop: $shortrop\n \$check: $check\n \$ret: $ret\n"; } } if($ok) {print "ok 3\n"} else {print "not ok 3\n"} $ok = 1; #################################### for my $suffix('010', '011', '110', '111') { for(1..10) { my $str = '1.'; for(1..70) {$str .= int(rand(2)); } $str .= $suffix; my $nstr = '-' . $str; my $longrop = Rmpfr_init2(74); my $check = Rmpfr_init2(72); my $shortrop = Rmpfr_init2(72); my $coderef = \&Rmpfr_set; my $inex = Rmpfr_set_str($longrop, $str, 2, MPFR_RNDN); if($inex) {die "Rmpfr_set_str falsely returned $inex"} my $ret = Rmpfr_round_nearest_away($coderef, $shortrop, $longrop); # $shortrop should always be rounded up, $longrop is exact. unless($shortrop > $longrop && $ret > 0) { $ok = 0; warn "\n gt: \$shortrop: $shortrop\n \$longrop: $longrop\n \$ret: $ret\n"; } $ret = Rmpfr_round_nearest_away(\&Rmpfr_strtofr, $check, $str, 2); unless($shortrop == $check && $ret > 0) { $ok = 0; warn "\n gt: \$shortrop: $shortrop\n \$check: $check\n \$ret: $ret\n"; } $longrop *= -1; $ret = Rmpfr_round_nearest_away($coderef, $shortrop, $longrop); # $shortrop should always be rounded down, $longrop is exact. unless($shortrop < $longrop && $ret < 0) { $ok = 0; warn "\n lt: \$shortrop: $shortrop\n \$longrop: $longrop\n \$ret: $ret\n"; } $ret = Rmpfr_round_nearest_away(\&Rmpfr_strtofr, $check, $nstr, 2); unless($shortrop == $check && $ret < 0) { $ok = 0; warn "\n gt: \$shortrop: $shortrop\n \$check: $check\n \$ret: $ret\n"; } } if($ok) { print "ok 4\n" if $suffix eq '010'; print "ok 5\n" if $suffix eq '011'; print "ok 6\n" if $suffix eq '110'; print "ok 7\n" if $suffix eq '111'; } else { print "not ok 4\n" if $suffix eq '010'; print "not ok 5\n" if $suffix eq '011'; print "not ok 6\n" if $suffix eq '110'; print "not ok 7\n" if $suffix eq '111'; } $ok = 1; } #################################### #################################### for my $suffix('001', '101') { for(1..10) { my $str = '1.'; for(1..70) {$str .= int(rand(2));} $str .= $suffix; my $nstr = '-' . $str; my $longrop = Rmpfr_init2(74); my $check = Rmpfr_init2(72); my $shortrop = Rmpfr_init2(72); my $coderef = \&Rmpfr_set; my $inex = Rmpfr_set_str($longrop, $str, 2, MPFR_RNDN); if($inex) {die "Rmpfr_set_str falsely returned $inex"} my $ret = Rmpfr_round_nearest_away($coderef, $shortrop, $longrop); # $shortrop should always be rounded down, $longrop is exact. unless($shortrop < $longrop && $ret < 0) { $ok = 0; warn "\n gt: \$shortrop: $shortrop\n \$longrop: $longrop\n \$ret: $ret\n"; } $ret = Rmpfr_round_nearest_away(\&Rmpfr_strtofr, $check, $str, 2); unless($shortrop == $check && $ret < 0) { $ok = 0; warn "\n gt: \$shortrop: $shortrop\n \$check: $check\n \$ret: $ret\n"; } $longrop *= -1; $ret = Rmpfr_round_nearest_away($coderef, $shortrop, $longrop); # $shortrop should always be rounded up, $longrop is exact. unless($shortrop > $longrop && $ret > 0) { $ok = 0; warn "\n lt: \$shortrop: $shortrop\n \$longrop: $longrop\n \$ret: $ret\n"; } $ret = Rmpfr_round_nearest_away(\&Rmpfr_strtofr, $check, $nstr, 2); unless($shortrop == $check && $ret > 0) { $ok = 0; warn "\n gt: \$shortrop: $shortrop\n \$check: $check\n \$ret: $ret\n"; } } if($ok) { print "ok 8\n" if $suffix eq '001'; print "ok 9\n" if $suffix eq '101'; } else { print "not ok 8\n" if $suffix eq '001'; print "not ok 9\n" if $suffix eq '101'; } $ok = 1; } #################################### #################################### #################################### for my $suffix('000', '100') { for(1..10) { my $str = '1.'; for(1..70) {$str .= int(rand(2));} $str .= $suffix; my $nstr = '-' . $str; my $longrop = Rmpfr_init2(74); my $check = Rmpfr_init2(72); my $shortrop = Rmpfr_init2(72); my $coderef = \&Rmpfr_set; my $inex = Rmpfr_set_str($longrop, $str, 2, MPFR_RNDN); if($inex) {die "Rmpfr_set_str falsely returned $inex"} my $ret = Rmpfr_round_nearest_away($coderef, $shortrop, $longrop); # No rounding, result is exact. unless($shortrop == $longrop && $ret == 0) { $ok = 0; warn "\n gt: \$shortrop: $shortrop\n \$longrop: $longrop\n \$ret: $ret\n"; } $ret = Rmpfr_round_nearest_away(\&Rmpfr_strtofr, $check, $str, 2); unless($shortrop == $check && $ret == 0) { $ok = 0; warn "\n gt: \$shortrop: $shortrop\n \$check: $check\n \$ret: $ret\n"; } $longrop *= -1; $ret = Rmpfr_round_nearest_away($coderef, $shortrop, $longrop); # No rounding, result is exact unless($shortrop == $longrop && $ret == 0) { $ok = 0; warn "\n lt: \$shortrop: $shortrop\n \$longrop: $longrop\n \$ret: $ret\n"; } $ret = Rmpfr_round_nearest_away(\&Rmpfr_strtofr, $check, $nstr, 2); unless($shortrop == $check && $ret == 0) { $ok = 0; warn "\n gt: \$shortrop: $shortrop\n \$check: $check\n \$ret: $ret\n"; } } if($ok) { print "ok 10\n" if $suffix eq '000'; print "ok 11\n" if $suffix eq '100'; } else { print "not ok 10\n" if $suffix eq '000'; print "not ok 11\n" if $suffix eq '100'; } $ok = 1; } #################################### #################################### #################################### #################################### #Rmpfr_set_emin(Rmpfr_get_emin_min()); $ok = 1; for(1..10) { my $str = '0.1'; for(1..70) {$str .= int(rand(2));} $str .= '01' . '@' . Rmpfr_get_emin(); my $nstr = '-' . $str; my $longrop = Rmpfr_init2(73); my $check = Rmpfr_init2(72); my $shortrop = Rmpfr_init2(72); my $coderef = \&Rmpfr_set; my $inex = Rmpfr_set_str($longrop, $str, 2, MPFR_RNDN); if($inex) {die "Rmpfr_set_str falsely returned $inex"} my $ret = Rmpfr_round_nearest_away($coderef, $shortrop, $longrop); # $shortrop should always be rounded up, $longrop is exact. unless($shortrop > $longrop && $ret > 0) { $ok = 0; warn "\n gt: \$shortrop: $shortrop\n \$longrop: $longrop\n \$ret: $ret\n"; } $ret = Rmpfr_round_nearest_away(\&Rmpfr_strtofr, $check, $str, 2); unless($shortrop == $check && $ret > 0) { $ok = 0; warn "\n gt: \$shortrop: $shortrop\n \$check: $check\n \$ret: $ret\n"; } $longrop *= -1; $ret = Rmpfr_round_nearest_away($coderef, $shortrop, $longrop); # $shortrop should always be rounded down, $longrop is exact. unless($shortrop < $longrop && $ret < 0) { $ok = 0; warn "\n lt: \$shortrop: $shortrop\n \$longrop: $longrop\n \$ret: $ret\n"; } Rmpfr_round_nearest_away(\&Rmpfr_strtofr, $check, $nstr, 2); unless($shortrop == $check && $ret < 0) { $ok = 0; warn "\n gt: \$shortrop: $shortrop\n \$check: $check\n \$ret: $ret\n"; } } if($ok) {print "ok 12\n"} else {print "not ok 12\n"} $ok = 1; for(1..10) { my $str = '0.1'; for(1..70) {$str .= int(rand(2));} $str .= '011' . '@' . Rmpfr_get_emin(); my $nstr = '-' . $str; my $longrop = Rmpfr_init2(74); my $check = Rmpfr_init2(72); my $shortrop = Rmpfr_init2(72); my $coderef = \&Rmpfr_set; my $inex = Rmpfr_set_str($longrop, $str, 2, MPFR_RNDN); if($inex) {die "Rmpfr_set_str falsely returned $inex"} my $ret = Rmpfr_round_nearest_away($coderef, $shortrop, $longrop); # $shortrop should always be rounded up, $longrop is exact. unless($shortrop > $longrop && $ret > 0) { $ok = 0; warn "\n gt: \$shortrop: $shortrop\n \$longrop: $longrop\n \$ret: $ret\n"; } $ret = Rmpfr_round_nearest_away(\&Rmpfr_strtofr, $check, $str, 2); unless($shortrop == $check && $ret > 0) { $ok = 0; warn "\n gt: \$shortrop: $shortrop\n \$check: $check\n \$ret: $ret\n"; } $longrop *= -1; $ret = Rmpfr_round_nearest_away($coderef, $shortrop, $longrop); # $shortrop should always be rounded down, $longrop is exact. unless($shortrop < $longrop && $ret < 0) { $ok = 0; warn "\n lt: \$shortrop: $shortrop\n \$longrop: $longrop\n \$ret: $ret\n"; } $ret = Rmpfr_round_nearest_away(\&Rmpfr_strtofr, $check, $nstr, 2); unless($shortrop == $check && $ret < 0) { $ok = 0; warn "\n gt: \$shortrop: $shortrop\n \$check: $check\n \$ret: $ret"; } } if($ok) {print "ok 13\n"} else {print "not ok 13\n"} $ok = 1; for(1..10) { my $str = '0.1'; for(1..70) {$str .= int(rand(2));} $str .= '001' . '@' . Rmpfr_get_emin(); my $nstr = '-' . $str; my $longrop = Rmpfr_init2(74); my $check = Rmpfr_init2(72); my $shortrop = Rmpfr_init2(72); my $coderef = \&Rmpfr_set; my $inex = Rmpfr_set_str($longrop, $str, 2, MPFR_RNDN); if($inex) {die "Rmpfr_set_str falsely returned $inex"} my $ret = Rmpfr_round_nearest_away($coderef, $shortrop, $longrop); # $shortrop should always be rounded down, $longrop is exact. unless($shortrop < $longrop && $ret < 0) { $ok = 0; warn "\n gt: \$shortrop: $shortrop\n \$longrop: $longrop\n \$ret: $ret\n"; } $ret = Rmpfr_round_nearest_away(\&Rmpfr_strtofr, $check, $str, 2); unless($shortrop == $check && $ret < 0) { $ok = 0; warn "\n gt: \$shortrop: $shortrop\n \$check: $check\n \$ret: $ret\n"; } $longrop *= -1; $ret = Rmpfr_round_nearest_away($coderef, $shortrop, $longrop); # $shortrop should always be rounded up, $longrop is exact. unless($shortrop > $longrop && $ret > 0) { $ok = 0; warn "\n lt: \$shortrop: $shortrop\n \$longrop: $longrop\n \$ret: $ret\n"; } $ret = Rmpfr_round_nearest_away(\&Rmpfr_strtofr, $check, $nstr, 2); unless($shortrop == $check && $ret > 0) { $ok = 0; warn "\n gt: \$shortrop: $shortrop\n \$check: $check\n \$ret: $ret\n"; } } if($ok) {print "ok 14\n"} else {print "not ok 14\n"} $ok = 1; my $longrop = Rmpfr_init2(73); my $shortrop = Rmpfr_init2(72); my $coderef = \&Rmpfr_set; ################ Rmpfr_set_inf($longrop, 1); my $ret = Rmpfr_round_nearest_away($coderef,$shortrop, $longrop); if($shortrop == $longrop && $ret == 0) { print "ok 15\n"; } else { warn "\n $shortrop: $shortrop\n \$longrop: $longrop\n \$ret: $ret\n"; print "not ok 15\n"; } ################ ################ Rmpfr_set_inf($longrop, -1); $ret = Rmpfr_round_nearest_away($coderef,$shortrop, $longrop); if($shortrop == $longrop && $ret == 0) { print "ok 16\n"; } else { warn "\n \$shortrop: $shortrop\n \$longrop: $longrop\n \$ret: $ret\n"; print "not ok 16\n"; } ################ ################ Rmpfr_set_zero($longrop, 1); $ret = Rmpfr_round_nearest_away($coderef,$shortrop, $longrop); if($shortrop == $longrop && $ret == 0) { print "ok 17\n"; } else { warn "\n \$shortrop: $shortrop\n \$longrop: $longrop\n \$ret: $ret\n"; print "not ok 17\n"; } ################ ################ Rmpfr_set_zero($longrop, -1); $ret = Rmpfr_round_nearest_away($coderef,$shortrop, $longrop); if($shortrop == $longrop && $ret == 0) { print "ok 18\n"; } else { warn "\n \$shortrop: $shortrop\n \$longrop: $longrop\n \$ret: $ret\n"; print "not ok 18\n"; } ################ ################ Rmpfr_set_nan($longrop); $ret = Rmpfr_round_nearest_away($coderef,$shortrop, $longrop); if(Rmpfr_nan_p($shortrop) && Rmpfr_nan_p($longrop) && $ret == 0) { print "ok 19\n"; } else { warn "\n \$shortrop: $shortrop\n \$longrop: $longrop\n \$ret: $ret\n"; print "not ok 19\n"; } my $small_1 = Math::MPFR->new(7.5); my $small_2 = Math::MPFR->new(6.5); $ret = Rmpfr_round_nearest_away(\&Rmpfr_prec_round, $small_1, 3); if($ret > 0 && $small_1 == 8) {print "ok 20\n"} else { warn "\n \$ret: $ret\n \$small_1:$small_1\n"; print "not ok 20\n"; } $ret = Rmpfr_round_nearest_away(\&Rmpfr_prec_round, $small_2, 3); if($ret > 0 && $small_2 == 7) {print "ok 21\n"} else { warn "\n \$ret: $ret\n \$small_2:$small_2\n"; print "not ok 21\n"; } #################################### # Change precision to 53. Rmpfr_set_prec($small_1, 53); Rmpfr_set_prec($small_2, 53); Rmpfr_set_d($small_1, 7.4, MPFR_RNDN); Rmpfr_set_d($small_2, 6.6, MPFR_RNDN); $ret = Rmpfr_round_nearest_away(\&Rmpfr_prec_round, $small_1, 3); if($ret < 0 && $small_1 == 7) {print "ok 22\n"} else { warn "\n \$ret: $ret\n \$small_1:$small_1\n"; print "not ok 22\n"; } $ret = Rmpfr_round_nearest_away(\&Rmpfr_prec_round, $small_2, 3); if($ret > 0 && $small_2 == 7) {print "ok 23\n"} else { warn "\n \$ret: $ret\n \$small_2:$small_2\n"; print "not ok 23\n"; } #################################### # Change precision to 53. Rmpfr_set_prec($small_1, 53); Rmpfr_set_prec($small_2, 53); Rmpfr_set_d($small_1, 7.5, MPFR_RNDN); Rmpfr_set_d($small_2, 6.5, MPFR_RNDN); $ret = Rmpfr_round_nearest_away(\&Rmpfr_prec_round, $small_1, 4); if($ret == 0 && $small_1 == 7.5) {print "ok 24\n"} else { warn "\n \$ret: $ret\n \$small_1:$small_1\n"; print "not ok 24\n"; } $ret = Rmpfr_round_nearest_away(\&Rmpfr_prec_round, $small_2, 4); if($ret == 0 && $small_2 == 6.5) {print "ok 25\n"} else { warn "\n \$ret: $ret\n \$small_2:$small_2\n"; print "not ok 25\n"; } #################################### # Change precision to 53. Rmpfr_set_prec($small_1, 53); Rmpfr_set_prec($small_2, 53); Rmpfr_set_d($small_1, 7.25, MPFR_RNDN); Rmpfr_set_d($small_2, 6.25, MPFR_RNDN); $ret = Rmpfr_round_nearest_away(\&Rmpfr_prec_round, $small_1, 3); if($ret < 0 && $small_1 == 7) {print "ok 26\n"} else { warn "\n \$ret: $ret\n \$small_1:$small_1\n"; print "not ok 26\n"; } $ret = Rmpfr_round_nearest_away(\&Rmpfr_prec_round, $small_2, 3); if($ret < 0 && $small_2 == 6) {print "ok 27\n"} else { warn "\n \$ret: $ret\n \$small_2:$small_2\n"; print "not ok 27\n"; } #################################### # Change precision to 53. Rmpfr_set_prec($small_1, 53); Rmpfr_set_prec($small_2, 53); Rmpfr_set_d($small_1, 7.0, MPFR_RNDN); Rmpfr_set_d($small_2, 6.0, MPFR_RNDN); $ret = Rmpfr_round_nearest_away(\&Rmpfr_prec_round, $small_1, 3); if($ret == 0 && $small_1 == 7) {print "ok 28\n"} else { warn "\n \$ret: $ret\n \$small_1:$small_1\n"; print "not ok 28\n"; } $ret = Rmpfr_round_nearest_away(\&Rmpfr_prec_round, $small_2, 3); if($ret == 0 && $small_2 == 6) {print "ok 29\n"} else { warn "\n \$ret: $ret\n \$small_2:$small_2\n"; print "not ok 29\n"; } #################################### my $nan = Rmpfr_init(); my $inf = Math::MPFR->new(1) / Math::MPFR->new(0); my $ninf = Math::MPFR->new(-1) / Math::MPFR->new(0); #################################### $ret = Rmpfr_round_nearest_away(\&Rmpfr_prec_round, $nan, 2); if(Rmpfr_get_prec($nan) == 2 && Rmpfr_nan_p($nan) && $ret == 0) {print "ok 30\n"} else { warn "\n prec: ", Rmpfr_get_prec($nan), "\n \$nan: $nan\n \$ret: $ret\n"; print "not ok 30\n"; } #################################### $ret = Rmpfr_round_nearest_away(\&Rmpfr_prec_round, $inf, 2); if(Rmpfr_get_prec($inf) == 2 && Rmpfr_inf_p($inf) && $ret == 0 && $inf > 0) {print "ok 31\n"} else { warn "\n prec: ", Rmpfr_get_prec($inf), "\n \$inf: $inf\n \$ret: $ret\n"; print "not ok 31\n"; } #################################### $ret = Rmpfr_round_nearest_away(\&Rmpfr_prec_round, $ninf, 2); if(Rmpfr_get_prec($ninf) == 2 && Rmpfr_inf_p($ninf) && $ret == 0 && $ninf < 0) {print "ok 32\n"} else { warn "\n prec: ", Rmpfr_get_prec($ninf), "\n \$ninf: $ninf\n \$ret: $ret\n"; print "not ok 32\n"; } #################################### #################################### my $rop = Rmpfr_init(); my $min = Rmpfr_init(); my $minstring = '0.1@' . Rmpfr_get_emin(); Rmpfr_set_str($min, $minstring, 2, MPFR_RNDN); my $mul = Math::MPFR->new(2); Rmpfr_pow_si($mul, $mul, Rmpfr_get_emin(), MPFR_RNDN); if($mul * 0.5 == $min) {print "ok 33\n"} else { warn "\n $mul * 0.5 != $min\n Ensuing tests may fail\n"; print "not ok 33\n"; } print "ok 34\n"; my $inex = Rmpfr_round_nearest_away(\&Rmpfr_mul_d, $rop, $mul, 0.25); if($inex == 1 && $rop == 0.5 * (Math::MPFR->new(2) ** Rmpfr_get_emin())) {print "ok 35\n"} else { warn "\n \$inex: $inex\n \$rop: $rop\n"; print "not ok 35\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_mul_d, $rop, $mul, 0.0625); if($inex == -1 && $rop == 0) {print "ok 36\n"} else { warn "\n \$inex: $inex\n \$rop: $rop\n"; print "not ok 36\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_mul_d, $rop, $mul, 0.75); if($inex == 0 && $rop > $min) {print "ok 37\n"} else { # Rmpfr_mul_d($rop, $mul, 0.75, MPFR_RNDA); warn "\n \$inex: $inex\n \$rop: $rop\n"; print "not ok 37\n"; } ################################ $inex = Rmpfr_round_nearest_away(\&Rmpfr_mul_d, $rop, $mul, -0.5); if($inex == 0 && abs($rop) == $min) {print "ok 38\n"} else { # Rmpfr_mul_d($rop, $mul, -0.5, MPFR_RNDA); warn "\n\$inex: $inex\n \$rop: $rop\n"; print "not ok 38\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_mul_d, $rop, $mul, -0.25); if($inex == -1 && abs($rop) == $min) {print "ok 39\n"} else { # Rmpfr_mul_d($rop, $mul, -0.25, MPFR_RNDA); warn "\n\$inex: $inex\n \$rop: $rop\n"; print "not ok 39\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_mul_d, $rop, $mul, -0.0625); if($inex == 1 && $rop ==0) {print "ok 40\n"} else { # Rmpfr_mul_d($rop, $mul, -0.0625, MPFR_RNDA); warn "\n\$inex: $inex\n \$rop: $rop\n"; print "not ok 40\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_mul_d, $rop, $mul, -0.75); if($inex == 0 && $rop < $min * -1) {print "ok 41\n"} else { # Rmpfr_mul_d($rop, $mul, -0.75, MPFR_RNDA); warn "\n\$inex: $inex\n \$rop: $rop\n"; print "not ok 41\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_mul_d, $rop, $mul, -0.0); if($inex == 0 && $rop == 0 && Rmpfr_signbit($rop)) {print "ok 42\n"} else { # Rmpfr_mul_d($rop, $mul, -0.0, MPFR_RNDA); warn "\n\$inex: $inex\n \$rop: $rop\n sign: ", Rmpfr_sgn($rop), "\n"; print "not ok 42\n"; } Rmpfr_set_default_prec(41); my $ps = Math::MPFR->new(); my $ns = Math::MPFR->new(); $ok = 1; for(1..100) { my $str = int(rand(2)); my $str_check = $str; for(1..40) {$str .= int(rand(2))} my $str_keep = $str; $str_check = substr($str, -1, 1) if $str_check; my $mul = int(rand(2)) == 0 ? 1 : -1; my $exponent = int(rand(100)); $exponent *= $mul; $str .= '@' . $exponent; Rmpfr_set_str($ps, $str, 2, MPFR_RNDN); Rmpfr_neg($ns, $ps, MPFR_RNDN); my $lsb = Math::MPFR::_lsb($ps); if(Math::MPFR::_lsb($ns) != $lsb) {$ok = 2} if(substr($str, 0, 1) eq '0' && "$lsb" ne '0') { $ok = 3; } if(substr($str_keep, 0, 1) eq '1' && substr($str_keep, -1, 1) eq '1' && "$lsb" ne '1') { warn "\n \$str_keep: $str_keep\n \$lsb: $lsb\n"; $ok = 4; } if($lsb != $str_check) {$ok = 0} } if($ok == 1) {print "ok 43\n"} else { warn "\n \$ok: $ok\n"; print "not ok 43\n"; } $ok = 1; Rmpfr_set_default_prec(67); my $ps2 = Math::MPFR->new(); my $ns2 = Math::MPFR->new(); for(1..100) { my $str = int(rand(2)); my $str_check = $str; for(1..66) {$str .= int(rand(2))} my $str_keep = $str; $str_check = substr($str, -1, 1) if $str_check; my $mul = int(rand(2)) == 0 ? 1 : -1; my $exponent = int(rand(1000)); $exponent *= $mul; $str .= '@' . $exponent; Rmpfr_set_str($ps2, $str, 2, MPFR_RNDN); Rmpfr_neg($ns2, $ps2, MPFR_RNDN); my $lsb = Math::MPFR::_lsb($ps2); if(Math::MPFR::_lsb($ns2) != $lsb) {$ok = 2} if(substr($str, 0, 1) eq '0' && "$lsb" ne '0') { $ok = 3; } if(substr($str_keep, 0, 1) eq '1' && substr($str_keep, -1, 1) eq '1' && "$lsb" ne '1') { warn "\n \$str_keep: $str_keep\n \$lsb: $lsb\n"; $ok = 4; } if($lsb != $str_check) {$ok = 0} } if($ok == 1) {print "ok 44\n"} else { warn "\n \$ok: $ok\n"; print "not ok 44\n"; } $ok = 1; if(Math::MPFR::_lsb(Math::MPFR->new()) == 0) {print "ok 45\n"} else { warn "\n ", Math::MPFR::_lsb(Math::MPFR->new()), "\n"; print "not ok 45\n"; } if(Math::MPFR::_lsb(Math::MPFR->new(1) / Math::MPFR->new(0)) == 0) {print "ok 46\n"} else { warn "\n ", Math::MPFR::_lsb(Math::MPFR->new(1) / Math::MPFR->new(0)), "\n"; print "not ok 46\n"; } if(Math::MPFR::_lsb(Math::MPFR->new(-1) / Math::MPFR->new(0)) == 0) {print "ok 47\n"} else { warn "\n ", Math::MPFR::_lsb(Math::MPFR->new(-1) / Math::MPFR->new(0)), "\n"; print "not ok 47\n"; } if(Math::MPFR::_lsb(Math::MPFR->new(0)) == 0) {print "ok 48\n"} else { warn "\n ", Math::MPFR::_lsb(Math::MPFR->new(0)), "\n"; print "not ok 48\n"; } my $prop = Rmpfr_init2(5); my $op = Math::MPFR->new(30.5); $inex = Rmpfr_round_nearest_away(\&Rmpfr_abs, $prop, $op); if($inex > 0 && $prop == 31) {print "ok 49\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 49\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_abs, $prop, $op * -1); if($inex > 0 && $prop == 31) {print "ok 50\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 50\n"; } Rmpfr_set_d($op, 29.5, MPFR_RNDN); $inex = Rmpfr_round_nearest_away(\&Rmpfr_add, $prop, $op, Math::MPFR->new(1)); if($inex > 0 && $prop == 31) {print "ok 51\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 51\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_add, $prop, $op * -1, Math::MPFR->new(-1)); if($inex < 0 && $prop == -31) {print "ok 52\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 52\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_add_d, $prop, $op, 1.0); if($inex > 0 && $prop == 31) {print "ok 53\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 53\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_add_d, $prop, $op * -1, -1.0); if($inex < 0 && $prop == -31) {print "ok 54\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 54\n"; } if($have_gmpq) { $inex = Rmpfr_round_nearest_away(\&Rmpfr_add_q, $prop, $op, Math::GMPq->new(1.0)); if($inex > 0 && $prop == 31) {print "ok 55\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 55\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_add_q, $prop, $op * -1, Math::GMPq->new(-1.0)); if($inex < 0 && $prop == -31) {print "ok 56\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 56\n"; } } else { warn "\n Skipping tests 55 & 56\n as Math::GMPq failed to load\n"; print "ok 55\n"; print "ok 56\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_add_si, $prop, $op, 1); if($inex > 0 && $prop == 31) {print "ok 57\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 57\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_add_si, $prop, $op * -1, -1); if($inex < 0 && $prop == -31) {print "ok 58\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 58\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_add_ui, $prop, $op, 1); if($inex > 0 && $prop == 31) {print "ok 59\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 59\n"; } if($have_gmpz) { $inex = Rmpfr_round_nearest_away(\&Rmpfr_add_z, $prop, $op, Math::GMPz->new(1.0)); if($inex > 0 && $prop == 31) {print "ok 60\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 60\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_add_z, $prop, $op * -1, Math::GMPz->new(-1.0)); if($inex < 0 && $prop == -31) {print "ok 61\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 61\n"; } } else { warn "\n Skipping tests 60 & 61\n as Math::GMPz failed to load\n"; print "ok 60\n"; print "ok 61\n"; } ##~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~## Rmpfr_set_d($op, 15.25, MPFR_RNDN); $inex = Rmpfr_round_nearest_away(\&Rmpfr_mul, $prop, $op, Math::MPFR->new(2)); if($inex > 0 && $prop == 31) {print "ok 62\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 62\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_mul, $prop, $op * -1, Math::MPFR->new(2)); if($inex < 0 && $prop == -31) {print "ok 63\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 63\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_mul_d, $prop, $op, 2.0); if($inex > 0 && $prop == 31) {print "ok 64\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 64\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_mul_d, $prop, $op * -1, 2.0); if($inex < 0 && $prop == -31) {print "ok 65\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 65\n"; } if($have_gmpq) { $inex = Rmpfr_round_nearest_away(\&Rmpfr_mul_q, $prop, $op, Math::GMPq->new(2.0)); if($inex > 0 && $prop == 31) {print "ok 66\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 66\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_mul_q, $prop, $op * -1, Math::GMPq->new(2.0)); if($inex < 0 && $prop == -31) {print "ok 67\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 67\n"; } } else { warn "\n Skipping tests 66 & 67\n as Math::GMPq failed to load\n"; print "ok 66\n"; print "ok 67\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_mul_si, $prop, $op, 2); if($inex > 0 && $prop == 31) {print "ok 68\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 68\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_mul_si, $prop, $op, -2); if($inex < 0 && $prop == -31) {print "ok 69\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 69\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_mul_ui, $prop, $op, 2); if($inex > 0 && $prop == 31) {print "ok 70\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 70\n"; } if($have_gmpz) { $inex = Rmpfr_round_nearest_away(\&Rmpfr_mul_z, $prop, $op, Math::GMPz->new(2.0)); if($inex > 0 && $prop == 31) {print "ok 71\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 71\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_mul_z, $prop, $op * -1, Math::GMPz->new(2.0)); if($inex < 0 && $prop == -31) {print "ok 72\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 72\n"; } } else { warn "\n Skipping tests 71 & 72\n as Math::GMPz failed to load\n"; print "ok 71\n"; print "ok 72\n"; } ##~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~## my $sqr = Rmpfr_init2(4); $inex = Rmpfr_set_d($sqr, 2.5, MPFR_RNDN); if(!$inex) {print "ok 73\n"} else { warn "\n \$inex: $inex\n"; print "not ok 73\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_sqr, $sqr, $sqr); if($inex > 0 && $sqr == 6.5) {print "ok 74\n"} else { warn "\n \$inex: $inex\n \$sqr: $sqr\n"; print "not ok 74\n"; } Rmpfr_set_d($sqr, 2.5, MPFR_RNDN); $inex = Rmpfr_sqr($sqr, $sqr, MPFR_RNDN); if($inex < 0 && $sqr == 6) {print "ok 75\n"} else { warn "\n \$inex: $inex\n \$sqr: $sqr\n"; print "not ok 75\n"; } ##~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~## Rmpfr_set_d($op, 91.5, MPFR_RNDN); $inex = Rmpfr_round_nearest_away(\&Rmpfr_div, $prop, $op, Math::MPFR->new(3)); if($inex > 0 && $prop == 31) {print "ok 76\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 76\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_div, $prop, $op * -1, Math::MPFR->new(3)); if($inex < 0 && $prop == -31) {print "ok 77\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 77\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_div_d, $prop, $op, 3.0); if($inex > 0 && $prop == 31) {print "ok 78\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 78\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_div_d, $prop, $op * -1, 3.0); if($inex < 0 && $prop == -31) {print "ok 79\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 79\n"; } if($have_gmpq) { $inex = Rmpfr_round_nearest_away(\&Rmpfr_div_q, $prop, $op, Math::GMPq->new(3.0)); if($inex > 0 && $prop == 31) {print "ok 80\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 80\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_div_q, $prop, $op * -1, Math::GMPq->new(3.0)); if($inex < 0 && $prop == -31) {print "ok 81\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 81\n"; } } else { warn "\n Skipping tests 80 && 81\n as Math::GMPq failed to load\n"; print "ok 80\n"; print "ok 81\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_div_si, $prop, $op, 3); if($inex > 0 && $prop == 31) {print "ok 82\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 82\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_div_si, $prop, $op, -3); if($inex < 0 && $prop == -31) {print "ok 83\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 83\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_div_ui, $prop, $op, 3); if($inex > 0 && $prop == 31) {print "ok 84\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 84\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_div_ui, $prop, $op * -1, 3); if($inex < 0 && $prop == -31) {print "ok 85\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 85\n"; } if($have_gmpz) { $inex = Rmpfr_round_nearest_away(\&Rmpfr_div_z, $prop, $op, Math::GMPz->new(3.0)); if($inex > 0 && $prop == 31) {print "ok 86\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 86\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_div_z, $prop, $op * -1, Math::GMPz->new(3.0)); if($inex < 0 && $prop == -31) {print "ok 87\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 87\n"; } } else { warn "\n Skipping tests 86 & 87\n as Math::GMPz failed to load\n"; print "ok 86\n"; print "ok 87\n"; } Rmpfr_set_d($op, 6.0, MPFR_RNDN); $inex = Rmpfr_round_nearest_away(\&Rmpfr_ui_div, $prop, 183, $op); if($inex > 0 && $prop == 31) {print "ok 88\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 88\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_ui_div, $prop, 183, $op * -1); if($inex < 0 && $prop == -31) {print "ok 89\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 89\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_si_div, $prop, 183, $op); if($inex > 0 && $prop == 31) {print "ok 90\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 90\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_si_div, $prop, -183, $op); if($inex < 0 && $prop == -31) {print "ok 91\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 91\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_d_div, $prop, 183.0, $op); if($inex > 0 && $prop == 31) {print "ok 92\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 92\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_d_div, $prop, -183.0, $op); if($inex < 0 && $prop == -31) {print "ok 93\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 93\n"; } ##~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~## Rmpfr_set_d($prop, 1.5, MPFR_RNDN); $inex = Rmpfr_round_nearest_away(\&Rmpfr_add, $prop, $prop, Math::MPFR->new(29)); if($inex > 0 && $prop == 31) {print "ok 94\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 94\n"; } Rmpfr_set_d($prop, 1.5, MPFR_RNDN); $inex = Rmpfr_round_nearest_away(\&Rmpfr_add, $prop, $prop * -1, Math::MPFR->new(-29)); if($inex < 0 && $prop == -31) {print "ok 95\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 95\n"; } Rmpfr_set_d($prop, 2.0, MPFR_RNDN); $inex = Rmpfr_round_nearest_away(\&Rmpfr_mul, $prop, $prop, Math::MPFR->new(15.25)); if($inex > 0 && $prop == 31) {print "ok 96\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 96\n"; } Rmpfr_set_d($prop, 2.0, MPFR_RNDN); $inex = Rmpfr_round_nearest_away(\&Rmpfr_mul, $prop, $prop, Math::MPFR->new(-15.25)); if($inex < 0 && $prop == -31) {print "ok 97\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 97\n"; } Rmpfr_set_d($prop, 1.5, MPFR_RNDN); $inex = Rmpfr_round_nearest_away(\&Rmpfr_sub, $prop, $prop, Math::MPFR->new(-29)); if($inex > 0 && $prop == 31) {print "ok 98\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 98\n"; } Rmpfr_set_d($prop, 1.5, MPFR_RNDN); $inex = Rmpfr_round_nearest_away(\&Rmpfr_sub, $prop, $prop, Math::MPFR->new(32)); if($inex < 0 && $prop == -31) {print "ok 99\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 99\n"; } ##~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~## Rmpfr_set_d($op, 1.5, MPFR_RNDN); $inex = Rmpfr_round_nearest_away(\&Rmpfr_sub, $prop, $op, Math::MPFR->new(-29)); if($inex > 0 && $prop == 31) {print "ok 100\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 100\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_sub, $prop, $op * -1, Math::MPFR->new(29)); if($inex < 0 && $prop == -31) {print "ok 101\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 101\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_sub_d, $prop, $op, -29.0); if($inex > 0 && $prop == 31) {print "ok 102\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 102\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_sub_d, $prop, $op * -1, 29.0); if($inex < 0 && $prop == -31) {print "ok 103\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 103\n"; } if($have_gmpq) { $inex = Rmpfr_round_nearest_away(\&Rmpfr_sub_q, $prop, $op, Math::GMPq->new(-29)); if($inex > 0 && $prop == 31) {print "ok 104\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 104\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_sub_q, $prop, $op * -1, Math::GMPq->new(29)); if($inex < 0 && $prop == -31) {print "ok 105\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 105\n"; } } else { warn "\n Skipping tests 104 & 105\n as Math::GMPq failed to load\n"; print "ok 104\n"; print "ok 105\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_sub_si, $prop, $op, -29); if($inex > 0 && $prop == 31) {print "ok 106\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 106\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_sub_si, $prop, $op * -1, 29); if($inex < 0 && $prop == -31) {print "ok 107\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 107\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_sub_ui, $prop, $op * -1, 29); if($inex < 0 && $prop == -31) {print "ok 108\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 108\n"; } if($have_gmpz) { $inex = Rmpfr_round_nearest_away(\&Rmpfr_sub_z, $prop, $op, Math::GMPz->new(-29)); if($inex > 0 && $prop == 31) {print "ok 109\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 109\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_sub_z, $prop, $op * -1, Math::GMPz->new(29)); if($inex < 0 && $prop == -31) {print "ok 110\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 110\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_z_sub, $prop, Math::GMPz->new(-29), $op); if($inex < 0 && $prop == -31) {print "ok 111\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 111\n"; } } else { warn "\n Skipping tests 109, 110 & 111\n as Math::GMPz failed to load\n"; print "ok 109\n"; print "ok 110\n"; print "ok 111\n"; } Rmpfr_set_d($op, 29.5, MPFR_RNDN); $inex = Rmpfr_round_nearest_away(\&Rmpfr_ui_sub, $prop, 60, $op); if($inex > 0 && $prop == 31) {print "ok 112\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 112\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_si_sub, $prop, 60, $op); if($inex > 0 && $prop == 31) {print "ok 113\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 113\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_si_sub, $prop, -60, $op * -1); if($inex < 0 && $prop == -31) {print "ok 114\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 114\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_d_sub, $prop, 60.0, $op); if($inex > 0 && $prop == 31) {print "ok 115\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 115\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_d_sub, $prop, -60.0, $op * -1); if($inex < 0 && $prop == -31) {print "ok 116\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 116\n"; } ##~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~## $inex = Rmpfr_round_nearest_away(\&Rmpfr_fac_ui, $prop, 6); if($inex > 0 && $prop == 736) {print "ok 117\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 117\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_sqrt, $prop, Math::MPFR->new(2025)); if($inex > 0 && $prop == 46) {print "ok 118\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 118\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_sqrt_ui, $prop, 2025); if($inex > 0 && $prop == 46) {print "ok 119\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 119\n"; } if(MPFR_VERSION_MAJOR > 3) { $inex = Rmpfr_round_nearest_away(\&Rmpfr_rootn_ui, $prop, Math::MPFR->new(2025), 2); } else { $inex = Rmpfr_round_nearest_away(\&Rmpfr_root, $prop, Math::MPFR->new(2025), 2); } if($inex > 0 && $prop == 46) {print "ok 120\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 120\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_cbrt, $prop, Math::MPFR->new(91125)); if($inex > 0 && $prop == 46) {print "ok 121\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 121\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_set_ui, $prop, 45); if($inex > 0 && $prop == 46) {print "ok 122\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 122\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_set_si, $prop, -45); if($inex < 0 && $prop == -46) {print "ok 123\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 123\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_set_d, $prop, 45.0); if($inex > 0 && $prop == 46) {print "ok 124\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 124\n"; } if($Config{nvtype} eq '__float128' && Math::MPFR::_can_pass_float128()) { $inex = Rmpfr_round_nearest_away(\&Rmpfr_set_float128, $prop, 45.0); if($inex > 0 && $prop == 46) {print "ok 125\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 125\n"; } } else { warn "Skipping test 125 - __float128 not supported\n"; print "ok 125\n"; } if($Config{nvsize} > 8) { # Rmpfr_set_ld is unavailable when nvsize <= 8 (even if nvtype is 'long double'). $inex = Rmpfr_round_nearest_away(\&Rmpfr_set_ld, $prop, 45.0); if($inex > 0 && $prop == 46) {print "ok 126\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 126\n"; } } else { warn "Skipping test 126 - long double not supported\n"; print "ok 126\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_ui_pow, $prop, 2025, Math::MPFR->new(0.5)); if($inex > 0 && $prop == 46) {print "ok 127\n"} else { warn "\n \$inex: $inex\n \$prop: $prop\n"; print "not ok 127\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_pow_si, $sqr, Math::MPFR->new(2.5), 2); if($inex > 0 && $sqr == 6.5) {print "ok 128\n"} else { warn "\n \$inex: $inex\n \$sqr: $sqr\n"; print "not ok 128\n"; } $inex = Rmpfr_round_nearest_away(\&Rmpfr_pow_ui, $sqr, Math::MPFR->new(2.5), 2); if($inex > 0 && $sqr == 6.5) {print "ok 129\n"} else { warn "\n \$inex: $inex\n \$sqr: $sqr\n"; print "not ok 129\n"; } if($have_gmpz) { $inex = Rmpfr_round_nearest_away(\&Rmpfr_pow_z, $sqr, Math::MPFR->new(2.5), Math::GMPz->new(2)); if($inex > 0 && $sqr == 6.5) {print "ok 130\n"} else { warn "\n \$inex: $inex\n \$sqr: $sqr\n"; print "not ok 130\n"; } } else { warn "\n Skipping test 130\n as Math::GMPz failed to load\n"; print "ok 130\n"; } __END__ Math-MPFR-4.38/t/ryu_checks.t0000755060175106010010000000270414765756127014501 0ustar OwnerNone# Check nvtoa() against Math::Ryu's ryu implementation. # Math::Ryu requires that nvsize is 8, so we skip all tests # if nvsize is not 8, or if Math::Ryu is not installed. use strict; use warnings; use Math::MPFR qw(:mpfr); use Config; use Test::More; if($Config{nvsize} != 8) { is(1, 1); warn "\nSkipping all tests because nvsize != 8\n"; done_testing(); exit 0; } eval { require Math::Ryu }; if($@) { is(1, 1); warn "\nSkipping all tests because Math::Ryu is unavailable\n"; done_testing(); exit 0; } my $rop1 = Rmpfr_init2(512); my $rop2 = Rmpfr_init2(512); for(-1075 .. 1025) { my $d = 2 ** $_; my $s1 = Math::Ryu::d2s($d); my $s2 = nvtoa($d); Rmpfr_set_str($rop1, $s1, 10, MPFR_RNDN); Rmpfr_set_str($rop2, $s2, 10, MPFR_RNDN); ok($rop1 == $rop2, "nvtoa agrees with ryu for 2 ** $_"); $d = (2 ** $_) + (2 ** ($_ + 1)) + (2 ** ($_ + 2)) + (2 ** ($_ + 3)); $s1 = Math::Ryu::d2s($d); $s2 = nvtoa($d); Rmpfr_set_str($rop1, $s1, 10, MPFR_RNDN); Rmpfr_set_str($rop2, $s2, 10, MPFR_RNDN); ok($rop1 == $rop2, "nvtoa agrees with ryu for 2 ** $_ + ....."); my $p = $_ <= 0 ? $_ + 4 + int(rand(50)) : $_ - 4 - int(rand(50)); $d = (2 ** $_) + (2 ** $p); $s1 = Math::Ryu::d2s($d); $s2 = nvtoa($d); Rmpfr_set_str($rop1, $s1, 10, MPFR_RNDN); Rmpfr_set_str($rop2, $s2, 10, MPFR_RNDN); ok($rop1 == $rop2, "nvtoa agrees with ryu for (2**$_) + (2**$p"); } done_testing(); Math-MPFR-4.38/t/set_IV.t0000755060175106010010000001236414765756127013536 0ustar OwnerNone# Check some values to verify that Rmpfr_set_IV is functioning # correctly. We check some values that are not IVs. # In all cases Rmpfr_set_IV should agree with both MPFR_SET_IV() # and MPFR_INIT_SET_IV(). use strict; use warnings; use Math::MPFR qw(:mpfr IOK_flag NOK_flag POK_flag); use Config; use Test::More; my $bits = $Config{ivsize} * 8; if($Config{ivtype} eq 'long' && $Config{ivsize} == $Config{longsize}) { *MPFR_SET_IV = \&Rmpfr_set_si; *MPFR_INIT_SET_IV = \&Rmpfr_init_set_si; *MPFR_SET_UV = \&Rmpfr_set_ui; *MPFR_INIT_SET_UV = \&Rmpfr_init_set_ui; *MPFR_CMP_IV = \&Rmpfr_cmp_si; *MPFR_CMP_UV = \&Rmpfr_cmp_ui; warn "\nUsing *_set_ui,*_set_si _cmp_ui and cmp_si functions\n"; } else { *MPFR_SET_IV = \&Rmpfr_set_sj; *MPFR_INIT_SET_IV = \&init_set_sj; # provided below *MPFR_SET_UV = \&Rmpfr_set_uj; *MPFR_INIT_SET_UV = \&init_set_uj; # provided below *MPFR_CMP_IV = \&Rmpfr_cmp_sj; *MPFR_CMP_UV = \&Rmpfr_cmp_uj; warn "\nUsing set_uj and _set_sj functions\n"; } Rmpfr_set_default_prec($bits); my $x = '42.3'; my $y = ~0; my $z = -1; my @in = (0, 'inf', '-inf', 'nan', '-nan', 'hello', ~0, -1, sqrt(2), Math::MPFR->new(), Math::MPFR->new(-11), $x, \$x, "$y", "$z", 2 ** 32, 2 ** 64, 2 ** -1069, 2 ** -16300, ~0 * 2, ~0 * -2); for(@in) { no warnings 'numeric'; # Create copies of $_ - and use each copy only once # as perl might change the flags. my($c1, $c2, $c3, $c4, $c5, $c6) = ($_, $_, $_, $_, $_, $_); my($rop1, $rop2, $rop3, $rop4, $inex1, $inex2, $inex3, $inex4); my $rnd = int(rand(4)); if(IOK_flag($c1)) { ($rop1, $inex1) = Rmpfr_init_set_IV($c1, $rnd); } else { eval { ($rop1, $inex1) = Rmpfr_init_set_IV($c1, $rnd);}; like($@, qr/Arg provided to Rmpfr_set_IV is not an IV/, '$@ set as expected'); next; } if($rop1 < (~0 >> 1)) { ($rop2, $inex2) = MPFR_INIT_SET_IV ($c2, $rnd); } else { ($rop2, $inex2) = MPFR_INIT_SET_UV ($c2, $rnd); } $rop3 = Math::MPFR->new(); $rop4 = Math::MPFR->new(); $inex3 = Rmpfr_set_IV($rop3, $c3, $rnd); if($rop1 < (~0 >> 1)) { $inex4 = MPFR_SET_IV ($rop4, $c4, $rnd); } else { $inex4 = MPFR_SET_UV ($rop4, $c4, $rnd); } cmp_ok($inex1, '==', $inex2, "$rnd: $_: \$inex1 == \$inex2"); cmp_ok($inex1, '==', $inex3, "$rnd: $_: \$inex1 == \$inex3"); cmp_ok($inex1, '==', $inex4, "$rnd: $_: \$inex1 == \$inex4"); cmp_ok(Rmpfr_nan_p($rop1), '==', 0, "$rnd: $_: not a NaN"); cmp_ok(Rmpfr_nan_p($rop2), '==', 0, "$rnd: $_: not a NaN"); cmp_ok(Rmpfr_nan_p($rop3), '==', 0, "$rnd: $_: not a NaN"); cmp_ok(Rmpfr_nan_p($rop4), '==', 0, "$rnd: $_: not a NaN"); cmp_ok($rop1, '==', $rop2, "$rnd: $_: \$rop1 == \$rop2"); cmp_ok($rop1, '==', $rop3, "$rnd: $_: \$rop1 == \$rop3"); cmp_ok($rop1, '==', $rop4, "$rnd: $_: \$rop1 == \$rop2"); } # We'll now run similar checks on Rmpfr_cmp_IV, using the # values (in @in) that we've already used to check Rmpfr_set_IV. for(@in) { no warnings 'numeric'; # Create copies of $_ - and use each copy only once # as perl might change the flags. my($c1, $c2, $c3, $c4, $c5, $c6) = ($_, $_, $_, $_, $_, $_); my $rnd = int(rand(4)); my $rop1 = Math::MPFR->new(); # Rmpfr_set_IV($rop1, $c1, $rnd); if(IOK_flag($c1)) { Rmpfr_set_IV($rop1, $c1, $rnd); } else { eval { Rmpfr_set_IV($rop1, $c1, $rnd);}; like($@, qr/Arg provided to Rmpfr_set_IV is not an IV/, '$@ set as expected'); next; } if($rop1 < (~0 >> 1)) { if(Rmpfr_cmp_IV ($rop1, $c2) < 0) { cmp_ok(MPFR_CMP_IV($rop1, $c6), '<', 0, "$rnd: $_: comparisons concur"); } elsif(Rmpfr_cmp_IV($rop1, $c3) == 0) { cmp_ok(MPFR_CMP_IV($rop1, $c6), '==', 0, "$rnd: $_: comparisons concur"); } else { cmp_ok(MPFR_CMP_IV($rop1, $c6), '>', 0, "$rnd: $_: comparisons concur"); } } else { if(Rmpfr_cmp_IV ($rop1, $c2) < 0) { cmp_ok(MPFR_CMP_UV($rop1, $c6), '<', 0, "$rnd: $_: comparisons concur"); } elsif(Rmpfr_cmp_IV($rop1, $c3) == 0) { cmp_ok(MPFR_CMP_UV($rop1, $c6), '==', 0, "$rnd: $_: comparisons concur"); } else { cmp_ok(MPFR_CMP_UV($rop1, $c6), '>', 0, "$rnd: $_: comparisons concur"); } } } cmp_ok(POK_flag("$bits"), '==', 1, "POK_flag set as expected" ); cmp_ok(POK_flag(2.3) , '==', 0, "POK_flag unset as expected"); cmp_ok(NOK_flag(2.3) , '==', 1, "NOK_flag set as expected" ); cmp_ok(NOK_flag("2.3") , '==', 0, "NOK_flag unset as expected"); done_testing(); sub init_set_sj { no warnings 'numeric'; my $ret = Math::MPFR->new(); my $inex = Rmpfr_set_sj($ret, $_[0], $_[1]); return ($ret, $inex); } sub init_set_uj { no warnings 'numeric'; my $ret = Math::MPFR->new(); my $inex = Rmpfr_set_uj($ret, $_[0], $_[1]); return ($ret, $inex); } Math-MPFR-4.38/t/set_NV.t0000755060175106010010000001371514765756127013544 0ustar OwnerNoneuse strict; use warnings; use Math::MPFR qw(:mpfr NOK_flag); use Config; use Test::More; Rmpfr_set_default_prec(120); my $fr1 = Rmpfr_init(); my $fr2 = Rmpfr_init(); my ($ret1, $ret2); my $infinity = Math::MPFR->new(); Rmpfr_set_inf($infinity, 1); # positive infinity my $inf = Rmpfr_get_NV($infinity, MPFR_RNDN); my $nan = Rmpfr_get_NV(Math::MPFR->new(), MPFR_RNDN); my $ninf = $inf * -1; $ret1 = Rmpfr_set_NV($fr1, sqrt(3.0), MPFR_RNDN); if(Math::MPFR::_has_longdouble() && !Math::MPFR::_nv_is_float128()) { $ret2 = Rmpfr_set_ld($fr2, sqrt(3.0), MPFR_RNDN); } elsif(Math::MPFR::_can_pass_float128()) { $ret2 = Rmpfr_set_float128($fr2, sqrt(3.0), MPFR_RNDN); } elsif(Math::MPFR::_nv_is_float128()) { $ret2 = Rmpfr_set_NV($fr2, sqrt(3.0), MPFR_RNDN); # tests 1 & 2 are bound to succeed } else { $ret2 = Rmpfr_set_d($fr2, sqrt(3.0), MPFR_RNDN); } cmp_ok($fr1, '==', $fr2, 'Both objects were assigned the same value'); cmp_ok($ret1, '==', $ret2, 'Both assignments returned the same "inexact" value'); cmp_ok($fr1, '==', sqrt(3.0), 'Confirmed that $fr1 was assigned the correct value'); cmp_ok($fr2, '==', sqrt(3.0), 'Confirmed that $fr2 was assigned the correct value'); Rmpfr_set_NV($fr1, $nan, MPFR_RNDN); cmp_ok($fr1, '!=', $fr1, 'NaN != NaN'); Rmpfr_set_NV($fr1, $inf, MPFR_RNDN); cmp_ok(Rmpfr_inf_p($fr1), '!=', 0, '$fr1 set to infinity'); cmp_ok($fr1, '>', 0, '$fr1 set to + infinity'); Rmpfr_set_NV($fr1, $ninf, MPFR_RNDN); cmp_ok(Rmpfr_inf_p($fr1), '!=', 0, '$fr1 again set to infinity'); cmp_ok($fr1, '<', 0, '$fr1 set to - infinity'); if($Config{nvtype} eq '__float128') { my $nv_max = 1.18973149535723176508575932662800702e4932; my $max = Rmpfr_init2(113); Rmpfr_set_NV($max, $nv_max, MPFR_RNDN); cmp_ok($max, '==', $nv_max, '$max == NV_MAX'); cmp_ok(Rmpfr_cmp_NV($max, $nv_max), '==', 0, 'Rmpfr_cmp_NV agrees with overloaded "=="'); my $nv_small_neg = -2.75423489483742700033038566794997947e-4928; my $small_neg = Rmpfr_init2(113); Rmpfr_set_NV($small_neg, $nv_small_neg, MPFR_RNDN); cmp_ok($small_neg, '==', $nv_small_neg, 'negative value close to zero assigned correctly'); cmp_ok(Rmpfr_cmp_NV($small_neg, $nv_small_neg), '==', 0, 'Rmpfr_cmp_NV again agrees with overloaded "=="'); } # We'll now check some more values - even ones that are not NVs. # If the value is an NV, Rmpfr_set_NV should agree with both # MPFR_SET_NV() and MPFR_INIT_SET_NV(). # If the value is not an NV, then Rmpfr_set_NV should croak # with expected error message that value is "not an NV". my $bits = $Math::MPFR::NV_properties{bits}; if ($bits == 53) { *MPFR_SET_NV =\&Rmpfr_set_d; *MPFR_INIT_SET_NV =\&Rmpfr_init_set_d; *MPFR_CMP_NV =\&Rmpfr_cmp_d; warn "\nUsing mpfr*_set_d and mpfr_cmp_d functions\n"; } elsif($Config{nvtype} eq 'long double') { *MPFR_SET_NV = \&Rmpfr_set_ld; *MPFR_INIT_SET_NV = \&Rmpfr_init_set_ld; *MPFR_CMP_NV = \&Rmpfr_cmp_ld; warn "\nUsing mpfr*_set_ld and mpfr_cmp_ld functions\n"; } else { *MPFR_SET_NV = \&Rmpfr_set_float128; *MPFR_INIT_SET_NV = \&Rmpfr_init_set_float128; *MPFR_CMP_NV = \&Rmpfr_cmp_float128; warn "\nUsing mpfr_set_float128 function\n"; } Rmpfr_set_default_prec($bits); my $x = '42.3'; my $y = ~0; my $z = -1; my @in = (0, 'inf', '-inf', 'nan', '-nan', 'hello', ~0, -1, sqrt(2), Math::MPFR->new(), Math::MPFR->new(-11), $x, \$x, "$y", "$z", 2 ** 32, 2 ** 64, 2 ** -1069, 2 ** -16300, ~0 * 2, ~0 * -2, 'nan' + 0, 'inf' + 0, '-inf' + 0, '-nan' + 0); for(@in) { no warnings 'numeric'; # Create copies of $_ - and use each copy only once # as perl might change the flags. my($c1, $c2, $c3, $c4) = ($_, $_, $_, $_); my $rnd = int(rand(4)); my($rop1, $inex1); if(NOK_flag($c1)) { ($rop1, $inex1) = Rmpfr_init_set_NV($c1, $rnd); } else { eval {($rop1, $inex1) = Rmpfr_init_set_NV($c1, $rnd);}; like($@, qr/In Rmpfr_set_NV, 2nd argument is not an NV/, '$@ set as expected'); next; } my($rop2, $inex2) = MPFR_INIT_SET_NV ($c2, $rnd); my $rop3 = Math::MPFR->new(); my $rop4 = Math::MPFR->new(); my $inex3 = Rmpfr_set_NV($rop3, $c3, $rnd); my $inex4 = MPFR_SET_NV ($rop4, $c4, $rnd); cmp_ok($inex1, '==', $inex2, "$rnd: $_: \$inex1 == \$inex2"); cmp_ok($inex1, '==', $inex3, "$rnd: $_: \$inex1 == \$inex3"); cmp_ok($inex1, '==', $inex4, "$rnd: $_: \$inex1 == \$inex4"); next if(Rmpfr_nan_p($rop1) && Rmpfr_nan_p($rop2) && Rmpfr_nan_p($rop3) && Rmpfr_nan_p($rop4)); cmp_ok($rop1, '==', $rop2, "$rnd: $_: \$rop1 == \$rop2"); cmp_ok($rop1, '==', $rop3, "$rnd: $_: \$rop1 == \$rop3"); cmp_ok($rop1, '==', $rop4, "$rnd: $_: \$rop1 == \$rop2"); } # We'll now run similar checks on Rmpfr_cmp_NV, using the # values (in @in) that we've already used to check Rmpfr_set_NV. # In all cases where the value is an NV, Rmpfr_cmp_NV should # agree with MPFR_CMP_NV(). for(@in) { no warnings 'numeric'; # Create copies of $_ - and use each copy only once # as perl might change the flags. my($c1, $c2, $c3,) = ($_, $_, $_); my $rop1 = Math::MPFR->new(10); if(!NOK_flag($c1)) { like($@, qr/not an NV/, '$@ set as expected'); } elsif(Rmpfr_cmp_NV($rop1, $c1) < 0) { cmp_ok(MPFR_CMP_NV($rop1, $c3), '<', 0, "$_: comparisons concur"); } elsif(Rmpfr_cmp_NV($rop1, $c2) == 0) { cmp_ok(MPFR_CMP_NV($rop1, $c3), '==', 0, "$_: comparisons concur"); } else { cmp_ok(MPFR_CMP_NV($rop1, $c3), '>', 0, "$_: comparisons concur"); } } done_testing(); # No longer used #sub init_set_float128 { # no warnings 'numeric'; # my $ret = Math::MPFR->new(); # my $inex = Rmpfr_set_float128($ret, $_[0], $_[1]); # return ($ret, $inex); #} Math-MPFR-4.38/t/set_str.t0000755060175106010010000001044514765756127014026 0ustar OwnerNoneuse strict; use warnings; use Math::MPFR qw(:mpfr); print "1..15\n"; print "# Using Math::MPFR version ", $Math::MPFR::VERSION, "\n"; print "# Using mpfr library version ", MPFR_VERSION_STRING, "\n"; print "# Using gmp library version ", Math::MPFR::gmp_v(), "\n"; my $hex = '0xabcde'; my $dec = 703710; my $dec_str = '703710'; my $bin = '0b10101011110011011110'; my ($pest, $b_hex, $b_bin, $b_dec, $b_dec2, $b_hex2, $b_bin2, $two, $rev, $z); ($b_hex, $pest) = Rmpfr_init_set_str($hex, 0, GMP_RNDN); if($b_hex == $hex && $b_hex == $dec && $b_hex == '703710') {print "ok 1\n"} else {print "not ok 1\n"} ($b_bin, $pest) = Rmpfr_init_set_str($bin, 0, GMP_RNDN); if($b_bin == $bin && $b_bin == $dec && $b_bin == '703710') {print "ok 2\n"} else {print "not ok 2\n"} $b_hex2 = Rmpfr_init(); $b_bin2 = Rmpfr_init(); $b_dec2 = Rmpfr_init(); Rmpfr_set_str($b_hex2, $hex, 0, GMP_RNDN); if($b_hex2 == $hex && $b_hex2 == $dec && $b_hex2 == '703710') {print "ok 3\n"} else {print "not ok 3\n"} Rmpfr_set_str($b_bin2, $bin, 0, GMP_RNDN); if($b_bin2 == $bin && $b_bin2 == $dec && $b_bin2 == '703710') {print "ok 4\n"} else {print "not ok 4\n"} ($b_dec, $pest) = Rmpfr_init_set_str($dec_str, 0, GMP_RNDN); if($b_dec == $hex && $b_dec == $dec && $b_dec == '703710') {print "ok 5\n"} else {print "not ok 5\n"} Rmpfr_set_str($b_dec2, $dec_str, 0, GMP_RNDN); if($b_dec2 == $bin && $b_dec2 == $dec && $b_dec2 == '703710') {print "ok 6\n"} else {print "not ok 6\n"} ($two, $pest) = Rmpfr_init_set_str('2', 0, GMP_RNDN); my $ok = ''; $two = $two * $hex; if($two == 1407420) {$ok = 'a'} $two = $two / $hex; if($two == 2) {$ok .= 'b'} $two = $two + $bin; if($two == $dec + 2) {$ok .= 'c'} $two = $two - $bin; if($two == 2) {$ok .= 'd'} $rev = $hex * $two; if($rev == 1407420) {$ok .= 'e'} $rev = $hex / $two; if($rev == 351855) {$ok .= 'f'} $rev = $bin + $two; if($rev == $dec + 2) {$ok .= 'g'} $rev = $bin - $two; if($rev == 703708) {$ok .= 'h'} if($ok eq 'abcdefgh') {print "ok 7\n"} else {print "not ok 7 $ok\n"} $ok = ''; $two *= $hex; if($two == 1407420) {$ok = 'a'} $two /= $hex; if($two == 2) {$ok .= 'b'} $two += $bin; if($two == $dec + 2) {$ok .= 'c'} $two -= $bin; if($two == 2) {$ok .= 'd'} if($two < '0b11') {$ok .= 'e'} if($two > '0x1') {$ok .= 'f'} if($two <= '0b10') {$ok .= 'g'} if($two >= '0x2') {$ok .= 'h'} if($two != '0b11111') {$ok .= 'i'} if(!($two <=> '0x2')) {$ok .= 'j'} if($ok eq 'abcdefghij') {print "ok 8\n"} else {print "not ok 8 $ok\n"} $rev = $two ** '0b11'; if($rev == '0b1000') {print "ok 9\n"} else {print "not ok 9 $rev\n"} $two **= '0x3'; if($two == 8) {print "ok 10\n"} else {print "not ok 10 $two\n"} $two **= 2; $two **= '0b1.0e-1'; # Take square root if($two == 8) {print "ok 11\n"} else {print "not ok 11\n"} Rmpfr_set_str($b_hex, '.12345@-11', 10, GMP_RNDN); Rmpfr_set_str($b_bin, ".12345\@-11", 0, GMP_RNDN); if($b_hex == $b_bin) {print "ok 12\n"} else {print "not ok 12\n"} Rmpfr_set_str($two, '2', 0, GMP_RNDN); $rev = '0b1e-1' ** $two; if($rev == '0.25') {print "ok 13\n"} else {print "not ok 13\n"} Rmpfr_set_default_prec(300); $z = Rmpfr_init(); my $bigstr = '0b'. ('1' x 250); Rmpfr_set_str($z, $bigstr, 0, GMP_RNDN); if($z == $bigstr) {print "ok 14\n"} else {print "not ok 14\n"} $ok = ''; my $ret = Rmpfr_strtofr($z, '11111111111.11111111111111', 0, GMP_RNDD); if($ret == -1) {$ok = 'a'} $ret = Rmpfr_strtofr($z, '11111111111.11111111111111', 0, GMP_RNDU); if($ret == 1) {$ok .= 'b'} $ret = Rmpfr_strtofr($z, '-11111111111.11111111111111', 0, GMP_RNDZ); if($ret == 1) {$ok .= 'c'} $ret = Rmpfr_strtofr($z, '11111111111.11111111111111', 0, GMP_RNDZ); if($ret == -1) {$ok .= 'd'} $ret = Rmpfr_strtofr($z, '-11111111111.5s11111111111111', 0, GMP_RNDD); if(!$ret) {$ok .= 'e'} $ret = Rmpfr_strtofr($z, '-11111111111.5s11111111111111', 0, GMP_RNDU); if(!$ret) {$ok .= 'f'} $ret = Rmpfr_strtofr($z, 'm11111111111.5s11111111111111', 0, GMP_RNDD); if(!$z) {$ok .= 'g'} $ret = Rmpfr_strtofr($z, 'm11111111111.5s11111111111111', 0, GMP_RNDU); if(!$z) {$ok .= 'h'} eval {$ret = Rmpfr_strtofr($z, '11111111111.11111111111111', 60, GMP_RNDD);}; if(MPFR_VERSION_MAJOR >= 3) { unless($@) {$ok .= 'i'} else {warn "15i: \$\@: $@\n"} } else { if($@ =~ /3rd argument supplied to Rmpfr_strtofr/) {$ok .= 'i'} else {warn "15i: \$\@: $@\n"} } if($ok eq 'abcdefghi') {print "ok 15\n"} else {print "not ok 15 $ok\n"} Math-MPFR-4.38/t/sign.t0000755060175106010010000000205314765756127013277 0ustar OwnerNoneuse warnings; use strict; use Math::MPFR qw(:mpfr); print "1..1\n"; print "# Using Math::MPFR version ", $Math::MPFR::VERSION, "\n"; print "# Using mpfr library version ", MPFR_VERSION_STRING, "\n"; print "# Using gmp library version ", Math::MPFR::gmp_v(), "\n"; Rmpfr_set_default_prec(150); my $nan = Math::MPFR->new(); my $inf = Math::MPFR->new(); my $neg = Math::MPFR->new(-12345); my $pos = Math::MPFR->new(23456); my $ok = ''; $ok .= 'a' if !Rmpfr_signbit($nan); $ok .= 'b' if Rmpfr_signbit($neg); $ok .= 'c' if !Rmpfr_signbit($pos); Rmpfr_set_si($nan, -2, GMP_RNDN); Rmpfr_setsign($nan, $neg, 0, GMP_RNDN); $ok .= 'd' if $nan + $neg == 0; Rmpfr_setsign($nan, $neg, -1, GMP_RNDN); $ok .= 'e' if $nan == $neg; Rmpfr_setsign($nan, $neg, 1, GMP_RNDN); $ok .= 'f' if $nan == $neg; Rmpfr_copysign($nan, $pos, $neg, GMP_RNDN); $ok .= 'g' if $nan + $pos == 0; Rmpfr_set_inf($inf, 1); $ok .= 'h' if !Rmpfr_signbit($inf); Rmpfr_set_inf($inf, -1); $ok .= 'i' if Rmpfr_signbit($inf); if($ok eq 'abcdefghi') {print "ok 1\n"} else {print "not ok $ok\n"} Math-MPFR-4.38/t/sizes.t0000755060175106010010000000141514765756127013475 0ustar OwnerNoneuse warnings; use strict; use Math::MPFR; use Config; print "1..4\n"; my @sizes = Math::MPFR::_mp_sizes(); if(@sizes == 3) {print "ok 1\n"} else { warn "scalar(\@sizes): ", scalar(@sizes), "\n"; print "not ok 1\n"; } if(Math::MPFR::_ivsize() == $Config::Config{ivsize}) {print "ok 2\n"} else { warn "Math::MPFR::_ivsize(): ", Math::MPFR::_ivsize(), "\n\$Config{ivsize}: $Config::Config{ivsize}\n"; print "not ok 2\n"; } if(Math::MPFR::_nvsize() == $Config::Config{nvsize}) {print "ok 3\n"} else { warn "Math::MPFR::_nvsize(): ", Math::MPFR::_nvsize(), "\n\$Config{nvsize}: $Config::Config{nvsize}\n"; print "not ok 3\n"; } my $ok = 1; for(@sizes) { unless($_ >= 4 && $_ <= Math::MPFR::_ivsize()) {$ok = 0} } if($ok) {print "ok 4\n"} else {print "not ok 4\n"} Math-MPFR-4.38/t/snprintf.t0000755060175106010010000000541314765756127014205 0ustar OwnerNoneuse strict; use warnings; use Config; use Math::MPFR qw(:mpfr); use Test::More; my($have_gmp, $have_mpz, $have_mpq, $have_mpf) = (0, 0, 0, 0); my $long_double_formats_ok = 1; if($^O =~ /^MSWin/ && $Config{libc} !~ /ucrt/) { $long_double_formats_ok = 0 if WIN32_FMT_BUG; } eval {require Math::GMP;}; $have_gmp = 1 unless $@; eval {require Math::GMPz;}; $have_mpz = 1 unless $@; eval {require Math::GMPq;}; $have_mpq = 1 unless $@; eval {require Math::GMPf;}; $have_mpf = 1 unless $@; my $buflen = 16; my $buf; my $nv = sqrt(2); if($Config{nvsize} == 8) { Rmpfr_snprintf($buf, 7, "%.14g", $nv, $buflen); cmp_ok($buf, 'eq', '1.4142', "sqrt 2 ok for 'double'"); Rmpfr_snprintf($buf, 8, "%a", $nv, $buflen); like($buf, qr/^0x1\.6a0$|^0xb\.504$|^0x2\.d4$|^0x5\.a8$/, 'sqrt 2 ok for "%a" formatting'); Rmpfr_snprintf($buf, 8, "%A", $nv, $buflen); like($buf, qr/^0X1\.6A0$|^0XB\.504$|^0X2\.D4$|^0x5\.A8$/, 'sqrt 2 ok for "%A" formatting'); } if($Config{nvtype} eq 'long double' && $long_double_formats_ok) { Rmpfr_snprintf($buf, 7, "%.14Lg", $nv, $buflen * 2); cmp_ok($buf, 'eq', '1.4142', "sqrt 2 ok for 'long double'"); if(length(sqrt(2.0)) > 25) { # IEEE 754 long double Rmpfr_snprintf($buf, 8, "%La", $nv, $buflen * 2); cmp_ok($buf, 'eq', '0x1.6a0', 'sqrt 2 ok for 128-bit "%La" formatting'); Rmpfr_snprintf($buf, 8, "%LA", $nv, $buflen * 2); cmp_ok($buf, 'eq', '0X1.6A0', 'sqrt 2 ok for 128-bit "%La" formatting'); } else { # 80-bit extended precision long double my($buf1, $buf2); Rmpfr_snprintf($buf1, 8, "%La", $nv, $buflen * 2); like($buf1, qr/^0x1.6a0$|^0x2.d41$|^0x5.a82$|^0xb.504$/, 'sqrt 2 ok for 80-bit "%La" formatting'); Rmpfr_snprintf($buf2, 8, "%LA", $nv, $buflen * 2); cmp_ok($buf2, 'eq', uc($buf1), 'sqrt 2 ok for 80-bit "%LA" formatting'); } } Rmpfr_snprintf($buf, 8, "%s", 'hello world', $buflen); cmp_ok($buf, 'eq', 'hello w', "'hello world' ok for PV"); if($have_gmp) { Rmpfr_snprintf($buf, 7, "%Zd", Math::GMP->new(12345678), $buflen); cmp_ok($buf, 'eq', '123456', "Math::GMP: 12345678 ok"); } if($have_mpz) { Rmpfr_snprintf($buf, 7, "%Zd", Math::GMPz->new(12345678), $buflen); cmp_ok($buf, 'eq', 123456, "Math::GMPz: 12345678 ok"); } if($have_mpq) { Rmpfr_snprintf($buf, 4, "%Qd", Math::GMPq->new('19/21'), $buflen); cmp_ok($buf, 'eq', '19/', "Math::GMPq: 19/21 ok"); } if($have_mpf) { Rmpfr_snprintf($buf, 7, "%.14Fg", sqrt(Math::GMPf->new(2)), $buflen); cmp_ok($buf, 'eq', '1.4142', "Math::GMPf: sqrt 2 ok"); } my $fr = Math::MPFR->new($nv); Rmpfr_snprintf($buf, 7, "%.14RDg", $fr, $buflen); cmp_ok($buf, 'eq', '1.4142', "Math::MPFR: sqrt 2 ok"); Rmpfr_snprintf($buf, 3, "%Pd", prec_cast(Rmpfr_get_prec($fr)), $buflen); cmp_ok($buf, 'eq', '53', "Math::MPFR precision is '53'"); done_testing(); Math-MPFR-4.38/t/sprintf.t0000755060175106010010000001536114765756127014032 0ustar OwnerNoneuse strict; use warnings; use Config; use Math::MPFR qw(:mpfr); use Test::More; my($have_gmp, $have_mpz, $have_mpq, $have_mpf) = (0, 0, 0, 0); my $long_double_formats_ok = 1; if($^O =~ /^MSWin/ && $Config{libc} !~ /ucrt/) { $long_double_formats_ok = 0 if WIN32_FMT_BUG; } eval {require Math::GMP;}; $have_gmp = 1 unless $@; eval {require Math::GMPz;}; $have_mpz = 1 unless $@; eval {require Math::GMPq;}; $have_mpq = 1 unless $@; eval {require Math::GMPf;}; $have_mpf = 1 unless $@; my $buflen = 32; my $buf; my $nv = sqrt(2); if($Config{nvtype} eq 'double') { Rmpfr_sprintf($buf, "%.14g", $nv, $buflen); cmp_ok($buf, 'eq', '1.4142135623731', "sqrt 2 ok for 'double'"); } if($Config{nvtype} eq 'long double' && $long_double_formats_ok) { Rmpfr_sprintf($buf, "%.14Lg", $nv, $buflen); cmp_ok($buf, 'eq', '1.4142135623731', "sqrt 2 ok for 'long double'"); } Rmpfr_sprintf($buf, "%s", 'hello world', $buflen); cmp_ok($buf, 'eq', 'hello world', "'hello world' ok for PV"); if($have_gmp) { Rmpfr_sprintf($buf, "%Zd", Math::GMP->new(~0), $buflen); cmp_ok($buf, '==', ~0, "Math::GMP: ~0 ok"); } if($have_mpz) { Rmpfr_sprintf($buf, "%Zd", Math::GMPz->new(~0), $buflen); cmp_ok($buf, '==', ~0, "Math::GMPz: ~0 ok"); } if($have_mpq) { Rmpfr_sprintf($buf, "%Qd", Math::GMPq->new('19/21'), $buflen); cmp_ok($buf, 'eq', '19/21', "Math::GMPq: 19/21 ok"); } if($have_mpf) { Rmpfr_sprintf($buf, "%.14Fg", sqrt(Math::GMPf->new(2)), $buflen); cmp_ok($buf, 'eq', '1.4142135623731', "Math::GMPf: sqrt 2 ok"); } my $fr = Math::MPFR->new($nv); Rmpfr_sprintf($buf, "%.14RUg", $fr, $buflen); cmp_ok($buf, 'eq', '1.4142135623731', "Math::MPFR: sqrt 2 ok"); Rmpfr_sprintf($buf, "%.14RDg", $fr, $buflen); cmp_ok($buf, 'eq', '1.414213562373', "Math::MPFR: sqrt 2 ok"); Rmpfr_sprintf($buf, "%Pd", prec_cast(Rmpfr_get_prec($fr)), $buflen); cmp_ok($buf, 'eq', '53', "Math::MPFR precision is '53'"); if($Config{nvsize} == 8) { Rmpfr_sprintf($buf, "%a", sqrt(2), 32); cmp_ok(Math::MPFR->new($buf), '==', sqrt(2), 'Rmpfr_sprintf() reads "%a" correctly'); Rmpfr_sprintf($buf, "%A", sqrt(2), 32); cmp_ok(Math::MPFR->new($buf), '==', sqrt(2), 'Rmpfr_sprintf() reads "%A" correctly'); } elsif($Config{nvtype} ne '__float128') { my $prec_orig = Rmpfr_get_default_prec(); my $prec = 64; if(length(sqrt(2)) > 25) { $prec = 113 } Rmpfr_set_default_prec($prec); Rmpfr_sprintf($buf, "%La", sqrt(2), 48); cmp_ok(Math::MPFR->new($buf), '==', sqrt(2), 'Rmpfr_sprintf() reads "%La" correctly'); Rmpfr_sprintf($buf, "%LA", sqrt(2), 48); cmp_ok(Math::MPFR->new($buf), '==', sqrt(2), 'Rmpfr_sprintf() reads "%LA" correctly'); Rmpfr_set_default_prec($prec_orig); } unless($Config{nvtype} eq '__float128') { # print formatting not supported by mpfr library my $fmt_string = $Math::MPFR::NV_properties{'bits'} == 53 ? "%a" : "%La"; my $garbage = $Math::MPFR::NV_properties{'bits'} == 53 ? " %%a " : " %%La "; my @check = (); my @expected = (); my @fmt_strings = ($fmt_string); push @fmt_strings, "$fmt_string\n"; push @fmt_strings, $garbage . $fmt_string; push @fmt_strings, $fmt_string . $garbage; push @fmt_strings, $garbage . $fmt_string . $garbage; for(0..4) { my $alt = $fmt_strings[$_]; $alt =~s/a/A/g; push @fmt_strings, $alt; } #for(@fmt_strings) {print "$_\n";} my $fmt_obj = Rmpfr_init2($Math::MPFR::NV_properties{'bits'}); my $fmt_nv = sqrt(2.0); Rmpfr_set_NV($fmt_obj, $fmt_nv, MPFR_RNDN); for (@fmt_strings) { my $s = $_; Rmpfr_sprintf($buf, $s, $fmt_nv, 64); push @check, "|$buf|"; } if($Math::MPFR::NV_properties{'bits'} == 53) { @expected = ( "|0x1.6a09e667f3bcdp+0|", "|0x1.6a09e667f3bcdp+0\n|", "| %a 0x1.6a09e667f3bcdp+0|", "|0x1.6a09e667f3bcdp+0 %a |", "| %a 0x1.6a09e667f3bcdp+0 %a |", "|0X1.6A09E667F3BCDP+0|", "|0X1.6A09E667F3BCDP+0\n|", "| %A 0X1.6A09E667F3BCDP+0|", "|0X1.6A09E667F3BCDP+0 %A |", "| %A 0X1.6A09E667F3BCDP+0 %A |", ); # Annoyingly, we might get an alternative, though numerically equivalent, format. # I'm not sure tht they're strictly allowed here but we'll accept any one of those # alternative formats. (The only one I've actually encountered is # 0xb.504f333f9de68p-3, and its upper case eqivalent on an MSWin32 perl-5.34.0.) my($alt, $lc_rep, $uc_rep) = ('', '', ''); $alt = 1 if($check[0] ne '|0x1.6a09e667f3bcc908p+0|'); if($alt) { $lc_rep = '0x2.d413cccfe779ap-1' if $check[0] eq '|0x2.d413cccfe779ap-1|'; $lc_rep = '0x5.a827999fcef34p-2' if $check[0] eq '|0x5.a827999fcef34p-2'; $lc_rep = '0xb.504f333f9de68p-3' if $check[0] eq '|0xb.504f333f9de68p-3|'; $uc_rep = uc($lc_rep) if $lc_rep; } for my $index(0..9) { if($alt && $uc_rep) { $expected[$index] =~ s/0x1\.6a09e667f3bcdp\+0/$lc_rep/; $expected[$index] =~ s/0X1\.6A09E667F3BCDP\+0/$uc_rep/; } cmp_ok($check[$index], 'eq', $expected[$index], "\$check[$index] eq \$expected[$index]"); } } else { # Correct 64-bit precision "%a" formatting of sqrt(2) can be either: # 0x1.6a09e667f3bcc908p+0 or 0xb.504f333f9de6484p-3 or 0x5.a827999fcef3242p-2 or 0x2.d413cccfe779921p-1 # # Correct 113-bit precision "%a" formatting of sqrt(2) produces: # 0x1.6a09e667f3bcc908b2fb1366ea95p+0 my $expect1 = "0x1.6a09e667f3bcc908p+0"; my $expect2 = "0x2d413cccfe779ap-1"; my $expect3 = "0x5.a827999fcef3242p-2"; my $expect4 = "0xb.504f333f9de6484p-3"; my $expect5 = "0x1.6a09e667f3bcc908b2fb1366ea95p+0"; my ($insert, $INSERT); if($check[0] =~ /0x1\.6a09e667f3bcc908p\+0/) { $insert = $expect1 } elsif($check[0] =~ /0x2\.d413cccfe779921p\-1/) { $insert = $expect2 } elsif($check[0] =~ /0x5\.a827999fcef3242p\-2/) { $insert = $expect3 } elsif($check[0] =~ /0xb\.504f333f9de6484p\-3/) { $insert = $expect4 } elsif($check[0] =~ /0x1\.6a09e667f3bcc908b2fb1366ea95p\+0/) { $insert = $expect5 } else { # If we haven't already found a valid representation of sqrt(2), then a FAIL should be reported. cmp_ok($check[0], 'eq', 'satisfactory value found', "Looking for a valid representation of sqrt(2)"); } $INSERT = uc($insert); # print "$_\n" for @check; my @expected = ( "|${insert}|", "|${insert}\n|", "| %La ${insert}|", "|${insert} %La |", "| %La ${insert} %La |", "|${INSERT}|", "|${INSERT}\n|", "| %LA ${INSERT}|", "|${INSERT} %LA |", "| %LA ${INSERT} %LA |", ); for my $index(0..9) { cmp_ok($check[$index], 'eq', $expected[$index], "\$check[$index] eq \$expected[$index]") } } } done_testing(); Math-MPFR-4.38/t/subnormal_doubles.t0000755060175106010010000000516214765756127016062 0ustar OwnerNone# Run some checks on subnormal double-doubles and doubles. # This script also checks some values that are Inf (or close to Inf). # For subnormal double values and Inf we check that atodouble() and atonv() return the same value. # We do the same for normal values - but not if the NV type is double-double. use strict; use warnings; use Math::MPFR qw(:mpfr); if( $Config::Config{nvtype} eq 'double' || ($Config::Config{nvtype} eq 'long double' && ($Config::Config{nvsize} == 8 || Math::MPFR::_required_ldbl_mant_dig() == 2098)) ) { my $have_atodouble = MPFR_VERSION <= 196869 ? 0 : 1; if($have_atodouble) { print "1..1\n"; my ($ok, $dmin, $inf) = (1, 2 ** - 1022, 99 ** (99 ** 99)); my($exp, $sig, $val, $d, $nv); for my $it(1 .. 1500) { $exp = 300 + int(rand(30)); $exp *= -1 if($it % 3); $sig = (1 + int(rand(9))) . '.' . int(rand(10)) . int(rand(10)) . int(rand(10)) . (1 + int(rand(9))); $val = "${sig}e${exp}"; $d = atodouble($val); $nv = atonv($val); if(($d == $inf || $nv == $inf) && $d != $nv) { warn "\n $d != $nv\n"; $ok = 0; } if($Math::MPFR::NV_properties{bits} != 2098) { # Check that $d == $nv for all values if($d != $nv) { warn "\n $d != $nv\n"; $ok = 0; } } elsif($d <= $dmin) { # Check that $d == $nv for subnormal values only if($d != $nv) { warn "\n $d != $nv\n"; $ok = 0; } } # Additional tests for double-double builds when (and only when) # the exponent <= -300. # Specifically, the least significant double in 10 + $val should # be identical to $d. if($Config::Config{nvtype} eq 'long double' && Math::MPFR::_required_ldbl_mant_dig() == 2098 && $exp <= -300) { my $prefix = "1" . ("0" x ($exp * -1)); my $nv = atonv($prefix . $val); my $hex_dd = unpack "H*", pack "D>", $nv; my $hex_d = unpack "H*", pack "d>", $d; if($hex_dd !~ /$hex_d$/) { warn "\n $hex_dd !~ /$hex_d\$/\n"; $ok = 0; } } } if($ok) {print "ok 1\n"} else {print "not ok 1\n"} } else { # atodouble is unavailable print "1..1\n"; eval{atodouble('1234.5');}; if($@ =~ /^The atodouble function requires mpfr-3.1.6 or later/) {print "ok 1\n"} else { warn "\n \$\@: $@\n"; print "not ok 1\n"; } } } else { # Not a double or double-double build print "1..1\n"; warn "\n Skipping tests: NV type ( $Config::Config{nvtype} ) is neither\n 'double' nor double-double'\n"; print "ok 1\n"; } Math-MPFR-4.38/t/sum.t0000755060175106010010000000354214765756127013147 0ustar OwnerNoneuse warnings; use strict; use Math::MPFR qw(:mpfr); print"1..6\n"; print "# Using Math::MPFR version ", $Math::MPFR::VERSION, "\n"; print "# Using mpfr library version ", MPFR_VERSION_STRING, "\n"; print "# Using gmp library version ", Math::MPFR::gmp_v(), "\n"; my ($sum, @obj); my $rop = Math::MPFR->new(); for(my $i = int(rand(201)); $i < 10000; $i++) { push @obj, Math::MPFR->new($i); $sum += $i; } my $ret = Rmpfr_sum($rop, \@obj, scalar(@obj), GMP_RNDN); if($sum == $rop) {print "ok 1\n"} else { warn "\n Got $rop\n Expected $sum\n"; print "not ok 1\n"; } Rmpfr_add_si($rop, $rop, -1, GMP_RNDN); if($rop == $sum - 1) {print "ok 2\n"} else { warn "\n Got $rop\n Expected ", $sum - 1, "\n"; print "not ok 2\n"; } my $size = @obj + 1; my $max = $size - 1; eval {Rmpfr_sum($rop, \@obj, $size, GMP_RNDN)}; if($@ =~ /2nd last arg to Rmpfr_sum is greater than the size of the array/) {print "ok 3\n"} else { warn "\n\$\@: $@\n"; print "not ok 3\n"; } if(4 <= MPFR_VERSION_MAJOR) { warn "\nCalling all cache freeing functions\n"; Rmpfr_free_cache2(MPFR_FREE_LOCAL_CACHE); Rmpfr_free_cache2(MPFR_FREE_GLOBAL_CACHE); Rmpfr_free_cache(); Rmpfr_free_pool(); warn "Skipping tests 4, 5 and 6 - not relevant to this build\n"; for(4 .. 6) {print "ok $_\n"} } else { warn "\nCalling Rmpfr_free_cache()\n"; Rmpfr_free_cache(); eval {Rmpfr_free_cache2(MPFR_FREE_LOCAL_CACHE);}; if($@ =~ /^Rmpfr_free_cache2 not implemented/) {print "ok 4\n"} else { warn "\$\@: $@\n"; print "not ok 4\n"; } eval {Rmpfr_free_cache2(MPFR_FREE_GLOBAL_CACHE);}; if($@ =~ /^Rmpfr_free_cache2 not implemented/) {print "ok 5\n"} else { warn "\$\@: $@\n"; print "not ok 5\n"; } eval {Rmpfr_free_pool();}; if($@ =~ /^Rmpfr_free_pool not implemented/) {print "ok 6\n"} else { warn "\$\@: $@\n"; print "not ok 6\n"; } } Math-MPFR-4.38/t/test1.t0000755060175106010010000006537314765756127013415 0ustar OwnerNoneuse strict; use warnings; use Math::MPFR qw(:mpfr); use Config; $| = 1; print "1..85\n"; print "# Using Math::MPFR version ", $Math::MPFR::VERSION, "\n"; print "# Using mpfr library version ", MPFR_VERSION_STRING, "\n"; print "# Using gmp library version ", Math::MPFR::gmp_v(), "\n"; my $expected_refcnt = 1; $expected_refcnt++ if $Config{ccflags} =~ /\-DPERL_RC_STACK/; my $arb = 2; my $double = 12345.5; my $ui = 4; my $si = -1369012; my ($ok, $exp); my($have_mpz, $have_mpf, $have_mpq, $have_Math_GMP) = (0, 0, 0, 0); eval{require Math::GMPz}; if(!$@) {$have_mpz = 1} eval{require Math::GMPf}; if(!$@) {$have_mpf = 1} eval{require Math::GMPq}; if(!$@) {$have_mpq = 1} eval{require Math::GMP}; if(!$@) {$have_Math_GMP = 1} my($z, $f, $q, $qq); if($have_mpz) {$z = Math::GMPz::Rmpz_init_set_str('aaaaaaaaaaaaaaaaaaaa', 36)} if($have_mpq) { $q = Math::GMPq::Rmpq_init(); Math::GMPq::Rmpq_set_str($q, 'qqqqqqqqqqqqqq/12345z', 36); Math::GMPq::Rmpq_canonicalize($q); } if($have_mpf) {$f = Math::GMPf::Rmpf_init_set_str('zzzzzzzzzzzzz123@-5', 36)} if(Rmpfr_get_default_prec() == 53) {print "ok 1\n"} else {print "not ok 1\n"} Rmpfr_set_default_prec(101); if(Rmpfr_get_default_prec() == 101) {print "ok 2\n"} else {print "not ok 2\n"} if(MPFR_VERSION_MAJOR >= 3) { if(Rmpfr_min_prec(Math::MPFR->new(0)) == 0) {$ok = 'a'} else {warn "3a: ", Rmpfr_min_prec(Math::MPFR->new(0)), "\n"} if(Rmpfr_min_prec(Math::MPFR->new(31)) == 5) {$ok .= 'b'} else {warn "3b: ", Rmpfr_min_prec(Math::MPFR->new(31)), "\n"} } else { eval{Rmpfr_min_prec(Math::MPFR->new(0));}; if($@ =~ /not implemented for/) {$ok = 'a'} else {warn "3a: ", $@ ? $@ : "\$\@ unexpectedly not set"} eval{Rmpfr_min_prec(Math::MPFR->new(31));}; if($@ =~ /not implemented for/) {$ok .= 'b'} else {warn "3b: ", $@ ? $@ : "\$\@ unexpectedly not set"} } # Here we're also testing that RMPFR_PREC_MIN and RMPFR_PREC_MAX are # parsed as intended when the comparison is '<', '<=' or '<=>'. if(RMPFR_PREC_MIN < RMPFR_PREC_MAX && RMPFR_PREC_MAX <= RMPFR_PREC_MAX + $arb && RMPFR_PREC_MAX <=> RMPFR_PREC_MIN) {$ok .= 'c'} else {warn "RMPFR_PREC_MAX: ", RMPFR_PREC_MAX, "\nRMPFR_PREC_MIN: ", RMPFR_PREC_MIN, "\n"} if($ok eq 'abc') {print "ok 3\n"} else { warn "\$ok: $ok\n"; print "not ok 3\n"; } $ok = ''; my $c = Rmpfr_init(); my $c_ui = Rmpfr_init(); my $d = Rmpfr_init2(300); my $e = Rmpfr_init2(300); my $check = Rmpfr_init2(300); my $check2 = Rmpfr_init2(300); my $check3 = Rmpfr_init2(300); #my $check4 = Rmpfr_init2(300); my $angle = Rmpfr_init2(300); my $unity = Rmpfr_init2(300); my $s = Rmpfr_init2(300); my $t = Rmpfr_init2(300); my $log1 = Rmpfr_init2(200); my $log2 = Rmpfr_init2(150); Rmpfr_set_d($angle, 3.217, GMP_RNDN); Rmpfr_set_ui($unity, 1, GMP_RNDN); #print Rmpfr_get_prec($c), "\n"; if(Rmpfr_get_prec($c) >= 101 && Rmpfr_get_prec($c) < 300 && Rmpfr_get_prec($d) >= 300) {print "ok 4\n"} else {print "not ok 4\n"} Rmpfr_set_prec($c, 300); if(Rmpfr_get_prec($c) == 300) {print "ok 5\n"} else {print "not ok 5\n"} Rmpfr_set_str($c, 'afsder.dgk1111111111111111111116', 36, GMP_RNDZ); my $s3 = Rmpfr_get_str($c, 16, 75, GMP_RNDU); my $s4 = Rmpfr_get_str($c, 16, 75, GMP_RNDD); if($s3 ne $s4) {print "ok 6\n"} else {print "not ok 6 $s3 $s4\n"} Rmpfr_set($d, $c, GMP_RNDD); $s3 = Rmpfr_get_str($d, 16, 75, GMP_RNDU); $s4 = Rmpfr_get_str($d, 16, 75, GMP_RNDD); if($s3 ne $s4) {print "ok 7\n"} else {print "not ok 7 $s3 $s4\n"} Rmpfr_set_d($c, $double, GMP_RNDN); if(Rmpfr_get_d($c, GMP_RNDN) == $double) {print "ok 8\n"} else {print "not ok 8\n"} if(Rmpfr_get_d1($c) == $double) {print "ok 9\n"} else {print "not ok 9\n"} if($have_mpz) { Rmpfr_set_z($c, $z, GMP_RNDN); if(Rmpfr_get_str($c, 36, 20, GMP_RNDN) eq 'a.aaaaaaaaaaaaaaaaaaa@19') {print "ok 10\n"} else {print "not ok 10 ", Rmpfr_get_str($c, 36, 20, GMP_RNDN), "\n"} } else { warn "Skipping test 10 - no Math::GMPz\n"; print "ok 10\n"; } Rmpfr_set_prec($c, 53); Rmpfr_set_ui($c, 2, GMP_RNDN); if($have_mpz) { my $exp = Rmpfr_get_z_exp($z, $c); if($exp == -51 && Math::GMPz::Rmpz_get_str($z, 10) eq '4503599627370496') {print "ok 11\n"} else {print "not ok 11\n"} } else { warn "Skipping test 11 - no Math::GMPz\n"; print "ok 11\n"; } Rmpfr_set_prec($c, 300); Rmpfr_set_str($c, 'zyxwvp123456@-2', 36, GMP_RNDN); Rmpfr_set($check, $c, GMP_RNDN); Rmpfr_add($c, $c, $d, GMP_RNDN); Rmpfr_add_ui($c, $c, 12345, GMP_RNDN); Rmpfr_sub($c, $c, $d, GMP_RNDN); Rmpfr_sub_ui($c, $c, 12345, GMP_RNDN); if(Rmpfr_eq($c, $check, 250)) {print "ok 12\n"} else {print "not ok 12\n"} Rmpfr_ui_sub($check, 0, $c, GMP_RNDN); Rmpfr_neg($c, $c, GMP_RNDN); if(!Rmpfr_cmp($c, $check)) {print "ok 13\n"} else {print "not ok 13\n"} Rmpfr_add($check, $c, $c, GMP_RNDN); Rmpfr_mul_ui($check2, $c, 2, GMP_RNDN); Rmpfr_mul_2exp($check3, $c, 1, GMP_RNDN); if(!Rmpfr_cmp($check, $check2) && !Rmpfr_cmp($check, $check3)) {print "ok 14\n"} else {print "not ok 14\n"} Rmpfr_div_ui($check2, $check, 2, GMP_RNDN); Rmpfr_div_2exp($check3, $check, 1, GMP_RNDN); Rmpfr_mul_2ui($check3, $check3, 3, GMP_RNDN); Rmpfr_mul_2si($check3, $check3, -3, GMP_RNDN); Rmpfr_div_2ui($check3, $check3, 3, GMP_RNDN); Rmpfr_div_2si($check3, $check3, -3, GMP_RNDN); if(!Rmpfr_cmp($check2, $check3)) {print "ok 15\n"} else {print "not ok 15\n"} Rmpfr_div($check, $c, $c, GMP_RNDN); if(!Rmpfr_cmp_ui($check, 1)) {print "ok 16\n"} else {print "not ok 16\n"} Rmpfr_ui_div($check, 1, $c, GMP_RNDN); Rmpfr_mul($check, $c, $check, GMP_RNDN); if(!Rmpfr_cmp_ui($check, 1)) {print "ok 17\n"} else {print "not ok 17\n"} Rmpfr_pow_ui($check2, $c, 2, GMP_RNDN); Rmpfr_sqrt($check2, $check2, GMP_RNDN); if(Rmpfr_cmp($check2, $c) && !Rmpfr_eq($check2, $c, 10)) {print "ok 18\n"} else {print "not ok 18\n"} Rmpfr_abs($c, $c, GMP_RNDN); if(Rmpfr_eq($check2, $c, 280)) {print "ok 19\n"} else {print "not ok 19\n"} if(Rmpfr_nan_p($e) && Rmpfr_number_p($c) && Rmpfr_sgn($c) == 1) {print "ok 20\n"} else {print "not ok 20\n"} Rmpfr_div_ui($check2, $c, 0, GMP_RNDN); if(Rmpfr_inf_p($check2)) {print "ok 21\n"} else {print "not ok 21\n"} Rmpfr_neg($check2, $c, GMP_RNDN); Rmpfr_reldiff($check, $check2, $c, GMP_RNDN); if(!Rmpfr_cmp_si($check, -2)) {print "ok 22\n"} else {print "not ok 22\n"} if($have_mpz) { Rmpfr_div_z($check2, $c, $z, GMP_RNDN); Rmpfr_mul_z($check2, $check2, $z, GMP_RNDN); if(Rmpfr_eq($check2, $c, 280)) {print "ok 23\n"} else {print "not ok 23\n"} } else { warn "Skipping test 23 - no Math::GMPz\n"; print "ok 23\n"; } if($have_mpq) { Rmpfr_div_q($check2, $c, $q, GMP_RNDN); Rmpfr_mul_q($check2, $check2, $q, GMP_RNDN); if(Rmpfr_eq($check2, $c, 280)) {print "ok 24\n"} else {print "not ok 24\n"} } else { warn "Skipping test 24 - no Math::GMPq\n"; print "ok 24\n"; } Rmpfr_neg($check, $c, GMP_RNDN); Rmpfr_set($check2, $c, GMP_RNDN); Rmpfr_swap($check2, $check); Rmpfr_add($check3, $check2, $check, GMP_RNDN); if(Rmpfr_sgn($check2) == -1 && Rmpfr_sgn($check) == 1 && !Rmpfr_cmp_ui($check3, 0)) {print "ok 25\n"} else {print "not ok 25\n"} Rmpfr_sin_cos($s, $c, $angle, GMP_RNDN); Rmpfr_pow_ui($check, $s, 2, GMP_RNDN); Rmpfr_pow_ui($check2, $c, 2, GMP_RNDN); Rmpfr_add($check3, $check2, $check, GMP_RNDN); if(Rmpfr_eq($check3, $unity, 280)) {print "ok 26\n"} else {print "not ok 26\n"} Rmpfr_tan($t, $angle, GMP_RNDN); Rmpfr_div($check, $s, $c, GMP_RNDN); if(Rmpfr_eq($t, $check, 280)) {print "ok 27\n"} else {print "not ok 27\n"} my $d2; Rmpfr_const_pi($c, GMP_RNDN); $d2 = Rmpfr_get_d($c, GMP_RNDN); if($d2 > 3.14159265 && $d2 < 3.14159266) {print "ok 28\n"} else {print "not ok 28\n"} Rmpfr_const_euler($c, GMP_RNDN); $d2 = Rmpfr_get_d($c, GMP_RNDN); if($d2 > 0.5772156649 && $d2 < 0.577215665) {print "ok 29\n"} else {print "not ok 29\n"} Rmpfr_const_log2($c, GMP_RNDN); $d2 = Rmpfr_get_d($c, GMP_RNDN); if($d2 > 0.69314718 && $d2 < 0.69314719) {print "ok 30\n"} else {print "not ok 30\n"} my $ret = Rmpfr_exp($c, $unity, GMP_RNDN); $d2 = Rmpfr_get_d($c, GMP_RNDN); if($ret && $d2 > 2.7182818284 && $d2 < 2.7182818285) {print "ok 31\n"} else {print "not ok 31\n"} Rmpfr_set_d($c, $d2, GMP_RNDN); Rmpfr_log($c, $c, GMP_RNDN); $d2 = Rmpfr_get_d($c, GMP_RNDN); if($d2 > 0.99999 && $d2 < 1.00001) {print "ok 32\n"} else {print "not ok 32\n"} Rmpfr_set_d($c, $double, GMP_RNDN); Rmpfr_exp2($c, $c, GMP_RNDN); Rmpfr_log2($c, $c, GMP_RNDN); $d2 = Rmpfr_get_d($c, GMP_RNDN); if($d2 > 12345.49 && $d2 < 12345.51) {print "ok 33\n"} else {print "not ok 33\n"} Rmpfr_set_d($c, 3.6, GMP_RNDN); Rmpfr_exp10($c, $c, GMP_RNDN); Rmpfr_log10($c, $c, GMP_RNDN); $d2 = Rmpfr_get_d($c, GMP_RNDN); if($d2 > 3.59 && $d2 < 3.61) {print "ok 34\n"} else {print "not ok 34\n"} Rmpfr_set_d($c, $double, GMP_RNDN); Rmpfr_set_ui($d, 10, GMP_RNDN); Rmpfr_pow($c, $d, $c, GMP_RNDN); Rmpfr_log10($c, $c, GMP_RNDN); $d2 = Rmpfr_get_d($c, GMP_RNDN); if($d2 > 12345.49 && $d2 < 12345.51) {print "ok 35\n"} else {print "not ok 35\n"} Rmpfr_set_ui($check2, 12345, GMP_RNDN); Rmpfr_set_ui($check3, 12346, GMP_RNDN); Rmpfr_agm($check, $check3, $check2, GMP_RNDN); $d2 = Rmpfr_get_d($check, GMP_RNDN); if($d2 > 12345.49999 && $d2 < 12345.50001) {print "ok 36\n"} else {print "not ok 36\n"} $ret = ''; Rmpfr_set_d($d, 123456.6, GMP_RNDN); Rmpfr_rint($c, $d, GMP_RNDD); if(!Rmpfr_cmp_ui($c, 123456)) { $ret .= 'a'} Rmpfr_ceil($c, $d); if(!Rmpfr_cmp_ui($c, 123457)) { $ret .= 'b'} Rmpfr_floor($c, $d); if(!Rmpfr_cmp_ui($c, 123456)) { $ret .= 'c'} Rmpfr_round($c, $d); if(!Rmpfr_cmp_ui($c, 123457)) { $ret .= 'd'} Rmpfr_trunc($c, $d); if(!Rmpfr_cmp_ui($c, 123456)) { $ret .= 'e'} if($ret eq 'abcde') {print "ok 37\n"} else {print "not ok 37 $ret\n"} if(Rmpfr_get_emin() < -1000000 && Rmpfr_get_emax > 1000000) {print "ok 38\n"} else {print "not ok 38\n"} if(!Rmpfr_check_range($d, 0, GMP_RNDN)) {print "ok 39\n"} else {print "not ok 39\n"} if($have_mpf) { Rmpfr_set_f($c, $f, GMP_RNDN); Rmpfr_set_str($d, 'zzzzzzzzzzzzz123@-5', 36, GMP_RNDN); if(Rmpfr_eq($c, $d, 100)) {print "ok 40\n"} else {print "not ok 40\n"} } else { warn "Skipping test 40 - no Math::GMPf\n"; print "ok 40\n"; } my @r = (); Rmpfr_set_default_prec(75); for(1..100) {push @r, Rmpfr_init()} if($have_mpz) { my $str = '1'; for(1..63) {$str .= int(rand(2))} my $seed = Math::GMPz::Rmpz_init_set_str($str, 2); my $state = Rmpfr_randinit_default(); Rmpfr_randseed($state, $seed); $ok = 1; Rmpfr_urandomb(@r, $state); for(@r) { if(length(Rmpfr_get_str($_, 2, 0, GMP_RNDN)) > 80 || length(Rmpfr_get_str($_, 2, 0, GMP_RNDN)) < 40) {$ok = 0} if($_ <= 0 || $_ >= 1) {$ok = 0} } for(my $i = 0; $i < 100; $i++) { for(my $j = $i + 1; $j < 100; $j++) { if($r[$i] == $r[$j]) {$ok = 0} } } if($ok) {print "ok 41\n"} else {print "not ok 41\n"} Rmpfr_randclear($state); } else { warn "Skipping test 41 - no Math::GMPz\n"; print "ok 41\n"; } { my $str = ''; for(1..21) {$str .= 1 + int(rand(9))} my $state = Rmpfr_randinit_lc_2exp_size(100); Rmpfr_randseed($state, $str); my $ok = 1; Rmpfr_urandomb(@r, $state); for(@r) { if(length(Rmpfr_get_str($_, 2, 0, GMP_RNDN)) > 80 || length(Rmpfr_get_str($_, 2, 0, GMP_RNDN)) < 40) {$ok = 0} if($_ <= 0 || $_ >= 1) {$ok = 0} } for(my $i = 0; $i < 100; $i++) { for(my $j = $i + 1; $j < 100; $j++) { if($r[$i] == $r[$j]) {$ok = 0} } } if($ok) {print "ok 42\n"} else {print "not ok 42\n"} Rmpfr_randclear($state); } my $o = Rmpfr_init(); Rmpfr_set_d($o, $double, GMP_RNDN); my ($t1, $s1) = Rmpfr_init_set($o, GMP_RNDN); my ($t2, $s2) = Rmpfr_init_set_d($double, GMP_RNDN); if(Rmpfr_eq($t1, $t2, 50)) {print "ok 43\n"} else {print "not ok 43\n"} my ($t3, $s33) = Rmpfr_init_set_ui(int($double), GMP_RNDN); my ($t4, $s44) = Rmpfr_init_set_si(int($double) + 1, GMP_RNDN); if(Rmpfr_cmp($t3, $t2) < 0 && Rmpfr_cmp($t4, $t2) > 0 && Rmpfr_get_prec($t3) == Rmpfr_get_default_prec()) {print "ok 44\n"} else {print "not ok 44\n"} if($have_mpz) { eval {my ($t, $inex) = Rmpfr_init_set_z($z, GMP_RNDN)}; if(!$@) {print "ok 45\n"} else {print "not ok 45\n"} } else { warn "Skipping test 45 - no Math::GMPz\n"; print "ok 45\n"; } if($have_mpq) { eval {my ($t, $inex) = Rmpfr_init_set_q($q, GMP_RNDN)}; if(!$@) {print "ok 46\n"} else {print "not ok 46\n"} } else { warn "Skipping test 46 - no Math::GMPq\n"; print "ok 46\n"; } if($have_mpf) { eval {my ($t, $inex) = Rmpfr_init_set_f($f, GMP_RNDN)}; if(!$@) {print "ok 47\n"} else {print "not ok 47\n"} } else { warn "Skipping test 47 - no Math::GMPf\n"; print "ok 47\n"; } if($have_mpz) { # Check that a specific MPFR bug has been fixed Rmpfr_clear_nanflag(); Math::GMPz::Rmpz_set_ui($z, 0); Rmpfr_set($check, $c, GMP_RNDN); my $ok = ''; Rmpfr_add_z($c, $c, $z, GMP_RNDN); if($c == $check) {$ok = 'a'} Rmpfr_sub_z($c, $c, $z, GMP_RNDN); if($c == $check) {$ok .= 'b'} Rmpfr_mul_z($check, $c, $z, GMP_RNDN); if($check == 0) {$ok .= 'c'} my $flag = Rmpfr_nanflag_p(); Rmpfr_div_z($check, $c, $z, GMP_RNDN); if(Rmpfr_inf_p($check)) {$ok .= 'd'} if($ok eq 'abcd' && !$flag && Math::MPFR::get_refcnt($c) == $expected_refcnt && Math::MPFR::get_refcnt($check) == $expected_refcnt){print "ok 48\n"} else {print "not ok 48 \$ok: $ok \$flag: $flag\n"} } else { warn "Skipping test 48 - no Math::GMPz\n"; print "ok 48\n"; } $ok = ''; $check = $c; $c *= 0; if($check != $c) {$ok = 'a'} $check *= 0; if($check == $c) {$ok .= 'b'} Rmpfr_clear_nanflag(); my $flag = Rmpfr_nanflag_p(); $check = $check / $c; if(!$flag && Rmpfr_nanflag_p() && Math::MPFR::get_refcnt($check) == $expected_refcnt && Math::MPFR::get_refcnt($c) == $expected_refcnt && $ok eq 'ab') {print "ok 49\n"} else {print "not ok 49 (Got: $flag ", Rmpfr_nanflag_p(), " $ok)\n"} ######################## ############################################### my $inf = Rmpfr_init(); Rmpfr_set_inf($inf, -1); if(Rmpfr_inf_p($inf)) {print "ok 50\n"} else {print "not ok 50\n"} my $nan = Rmpfr_init(); Rmpfr_set_nan($nan); if(Rmpfr_nan_p($nan)) {print "ok 51\n"} else {print "not ok 51\n"} Rmpfr_set_si($inf, -27, GMP_RNDN); Rmpfr_cbrt($inf, $inf, GMP_RNDN); if($inf == -3 && Rmpfr_integer_p($inf)) {print "ok 52\n"} else {print "not ok 52\n"} $ok = 1; my @r3 = (); Rmpfr_set_default_prec(75); for(1..100) {push @r3, Rmpfr_init()} if(!(MPFR_VERSION_MAJOR > 2)) { for(@r3) {Rmpfr_random2($_, 6, 2)} my $dup_count = 0; for(my $i = 0; $i < 100; $i++) { for(my $j = $i + 1; $j < 100; $j++) { if($r3[$i] == $r3[$j]) {$dup_count ++} } } if($dup_count < 6) {print "ok 53\n"} else {print "not ok 53\n"} } else { warn "Skipping test 53: Rmpfr_random2 no longer implemented\n"; print "ok 53\n"; } Rmpfr_set_si($c, -123, GMP_RNDN); Rmpfr_set_si($check, -7, GMP_RNDN); if(Rmpfr_cmpabs($c, $check) > 0 && !Rmpfr_unordered_p($c, $check)) {print "ok 54\n"} else {print "not ok 54\n"} $ok = ''; Rmpfr_min($check2, $check, $c, GMP_RNDN); if($check2 == $c) {$ok = 'a'} Rmpfr_max($check2, $check, $c, GMP_RNDN); if($check2 == $check) {$ok .= 'b'} if($ok eq 'ab') {print "ok 55\n"} else {print "not ok 55 $ok\n"} my $log3 = Rmpfr_init2(200); my $signp; Rmpfr_set_d($c, 1.003, GMP_RNDN); Rmpfr_lngamma($log2, $c, GMP_RNDN); ($signp, $ret) = Rmpfr_lgamma($log3, $c, GMP_RNDN); Rmpfr_gamma($c, $c, GMP_RNDN); Rmpfr_log($log1, $c, GMP_RNDN); if($c > 0.9982772 && $c < 0.9982773){print "ok 56\n"} else {print "not ok 56\n"} $ok = ''; if($log1 - $log3 < 0.000000001 && $log1 - $log3> -0.000000001){$ok .= 'a'} if($signp == 1) {$ok .= 'b'} if($log1 - $log2 < 0.000000001 && $log1 - $log2 > -0.000000001){$ok .= 'c'} if($ok eq 'abc'){print "ok 57\n"} else {print "not ok 57 $ok\n"} Rmpfr_set_ui($c, 0, GMP_RNDN); Rmpfr_erf($check, $c, GMP_RNDN); if($check == 0) {print "ok 58\n"} else {print "not ok 58\n"} Rmpfr_const_pi($check, GMP_RNDN); $check **= 4; $check /= 90; Rmpfr_set_ui($c, 4, GMP_RNDN); Rmpfr_zeta($c, $c, GMP_RNDN); Rmpfr_zeta_ui($c_ui, 4, GMP_RNDN); $ok = ''; if($c > $check - 0.00001 && $c < $check + 0.00001) {$ok .= 'a'} else {warn "59 a: $c\n$check\n"} if($c_ui > $check - 0.00001 && $c_ui < $check + 0.00001) {$ok .= 'b'} else {warn "59 b: $c_ui\n$check\n"} if($ok eq 'ab') {print "ok 59\n"} else {print "not ok 59 $ok\n"} my $fail = Rmpfr_set_exp($c, -5); if(!$fail && Rmpfr_get_exp($c) == -5) {print "ok 60\n"} else {print "not ok 60\n"} if(1) { my $str = ''; for(1..21) {$str .= 1 + int(rand(10))} my $state = Rmpfr_randinit_lc_2exp_size(90); Rmpfr_randseed($state, $str); my $ok = 1; Rmpfr_urandomb(@r, $state); for(@r) { if(length(Rmpfr_get_str($_, 2, 0, GMP_RNDN)) > 80 || length(Rmpfr_get_str($_, 2, 0, GMP_RNDN)) < 40) {$ok = 0} if($_ <= 0 || $_ >= 1) {$ok = 0} } for(my $i = 0; $i < 100; $i++) { for(my $j = $i + 1; $j < 100; $j++) { if($r[$i] == $r[$j]) {$ok = 0} } } if($ok) {print "ok 61\n"} else {print "not ok 61\n"} Rmpfr_randclear($state); } ########################################## if($have_mpz) { my $str = ''; for(1..21) {$str .= 1 + int(rand(9))} my $seed = Math::GMPz::Rmpz_init_set_str($str, 10); my $state = Rmpfr_randinit_lc_2exp_size(120); Rmpfr_randseed($state, $seed); my $ok = 1; Rmpfr_urandomb(@r, $state); for(@r) { if(length(Rmpfr_get_str($_, 2, 0, GMP_RNDN)) > 80 || length(Rmpfr_get_str($_, 2, 0, GMP_RNDN)) < 40) {$ok = 0} if($_ <= 0 || $_ >= 1) {$ok = 0} } for(my $i = 0; $i < 100; $i++) { for(my $j = $i + 1; $j < 100; $j++) { if($r[$i] == $r[$j]) {$ok = 0} } } if($ok) {print "ok 62\n"} else {print "not ok 62\n"} Rmpfr_randclear($state); } else { warn "Skipping test 62 - no Math::GMPz\n"; print "ok 62\n"; } ######################### if(1) { my $str = ''; for(1..21) {$str .= 1 + int(rand(10))} my $state = Rmpfr_randinit_lc_2exp_size(100); Rmpfr_randseed_ui($state, 1123456); my $ok = 1; Rmpfr_urandomb(@r, $state); for(@r) { if(length(Rmpfr_get_str($_, 2, 0, GMP_RNDN)) > 80 || length(Rmpfr_get_str($_, 2, 0, GMP_RNDN)) < 40) {$ok = 0} if($_ <= 0 || $_ >= 1) {$ok = 0} } for(my $i = 0; $i < 100; $i++) { for(my $j = $i + 1; $j < 100; $j++) { if($r[$i] == $r[$j]) {$ok = 0} } } if($ok) {print "ok 63\n"} else {print "not ok 63\n"} Rmpfr_randclear($state); } Rmpfr_set_d($c, 1123.5, GMP_RNDN); eval {Rmpfr_out_str($c, 10, 0, GMP_RNDN); print "\n";}; if($@) {print "not ok 64\n"} else {print "ok 64\n"} eval {Rmpfr_print_binary($c); print "\n";}; if($@) {print "ok 65\n"} else {print "not ok 65\n"} eval {Rmpfr_dump($c);}; if($@) {print "not ok 66\n"} else {print "ok 66\n"} eval{$ok = Math::MPFR::gmp_v();}; if($@ || $ok =~ /[^0-9\.]/) {print "not ok 67\n"} else {print "ok 67\n"} Rmpfr_const_catalan($c, GMP_RNDN); if($c - 0.915965594177 < 0.0000000001 && $c - 0.915965594177 > - 0.0000000001) {print "ok 68\n"} else {print "not ok 68\n"} Rmpfr_set_si($c, -3, GMP_RNDN); Rmpfr_lngamma($c, $c, GMP_RNDN); if(Rmpfr_inf_p($c)) {print "ok 69\n"} else { warn "lngamma(-3): $c\n"; print "not ok 69\n"; } Rmpfr_erf($s, $log1, GMP_RNDN); Rmpfr_erfc($t, $log1, GMP_RNDN); # erfc(x) = 1 - erf(x) if($s + $t < 1.00000000001 && $s + $t > 0.99999999999) {print "ok 70\n"} else {print "not ok 70\n"} Rmpfr_set_d($s, 175.92186044416, GMP_RNDN); if(MPFR_VERSION_MAJOR > 3) { Rmpfr_rootn_ui($s, $s, 11, GMP_RNDN); } else { Rmpfr_root($s, $s, 11, GMP_RNDN); } if($s - 1.6 < 0.0000000001 && $s - 1.6 > -0.0000000001) {print "ok 71\n"} else {print "not ok 71\n"} Rmpfr_set_si($s, -2, GMP_RNDN); Rmpfr_eint($s, $s, GMP_RNDN); # The behaviour of mpfr_eint() wrt -ve inputs changes after mpfr-3.1.x if(MPFR_VERSION >= 197120) { if($s < -0.0489005107 && $s > -0.04890051071) {print "ok 72\n"} else { warn "\n72: got $s\n"; print "not ok 72\n"; } } elsif(Rmpfr_nan_p($s)) {print "ok 72\n"} else {print "not ok 72\n"} Rmpfr_set_default_prec(300); if($have_mpz) { my $zzz = Math::GMPz::Rmpz_init_set_ui(60); Rmpfr_set_ui($s, 3, GMP_RNDN); Rmpfr_pow_z($s, $s, $zzz, GMP_RNDN); if($s == '42391158275216203514294433201') {print "ok 73\n"} else {print "not ok 73\n"} } else { warn "Skipping test 73 - no Math::GMPz\n"; print "ok 73\n"; } if($have_Math_GMP) { my $zzz = Math::GMP->new(60); Rmpfr_set_ui($s, 3, GMP_RNDN); Rmpfr_pow_z($s, $s, $zzz, GMP_RNDN); if($s == '42391158275216203514294433201') {print "ok 74\n"} else {print "not ok 74\n"} } else { warn "Skipping test 74 - no Math::GMP\n"; print "ok 74\n"; } if($have_mpf) { my $f1 = Math::GMPf::Rmpf_init(); Rmpfr_set_d($s, 23.625, GMP_RNDN); Rmpfr_get_f($f1, $s, GMP_RNDN); if(Rmpfr_cmp_f($s, $f1)) {print "not ok 75\n"} else {print "ok 75\n"} } else { warn "Skipping test 75 - no Math::GMPf\n"; print "ok 75\n"; } Rmpfr_set_d($s, 12345.5, GMP_RNDN); if(Rmpfr_cmp_d($s, 12345.5)) {print "not ok 76\n"} else {print "ok 76\n"} if($s == 12345.5 && $s <= 12345.5 && $s >= 12345.5 && ($s <=> 12345.6) < 0 && ($s <=> 12345.5) == 0 && ($s <=> 12345.4) > 0 && $s != 12345.4 && $s > 12345.4 && $s >= 12345.4 && $s < 12345.6 && $s <= 12345.6) {print "ok 77\n"} else {print "not ok 77\n"} my $hypot1 = Math::MPFR->new(5); my $hypot2 = Math::MPFR->new(12); Rmpfr_hypot($s, $hypot1, $hypot2, GMP_RNDN); if($s == 13) {print "ok 78\n"} else {print "not ok 78\n"} my $num1 = Math::MPFR->new(100); $double = Rmpfr_get_d_2exp($exp, $num1, GMP_RNDN); if($double > 0.781249 && $double < 0.781251 && $exp == 7) {print "ok 79\n"} else { warn "\n Got (double): $double\n Expected: 0.78125\n\n", " Got (exp): $exp\n Expected: 7\n"; print "not ok 79\n"; } my $posinf = Math::MPFR->new('inf'); my $neginf = Math::MPFR->new('-inf'); $ok = ''; if($posinf == - $neginf) {$ok .= 'a'} else {warn "a: $posinf ", $neginf * -1, "\n"} $double = Rmpfr_get_d($nan, GMP_RNDN); Rmpfr_set_d($nan, $double, GMP_RNDN); if(Rmpfr_nan_p($nan)) {$ok .= 'b'} else {warn "b: $nan\n"} $double = Rmpfr_get_d($posinf, GMP_RNDN); Rmpfr_set_d($posinf, $double, GMP_RNDN); if(Rmpfr_inf_p($posinf) && $posinf > 0) {$ok .= 'c'} else {warn "c: $posinf\n"} $double = Rmpfr_get_d($neginf, GMP_RNDN); Rmpfr_set_d($neginf, $double, GMP_RNDN); if(Rmpfr_inf_p($neginf) && $neginf < 0) {$ok .= 'd'} else {warn "d: $neginf\n"} $double = Rmpfr_get_NV($nan, GMP_RNDN); Rmpfr_set_d($nan, $double, GMP_RNDN); if(Rmpfr_nan_p($nan)) {$ok .= 'e'} else {warn "e: $nan\n"} $double = Rmpfr_get_NV($posinf, GMP_RNDN); Rmpfr_set_d($posinf, $double, GMP_RNDN); if(Rmpfr_inf_p($posinf) && $posinf > 0) {$ok .= 'f'} else {warn "f: $posinf\n"} $double = Rmpfr_get_NV($neginf, GMP_RNDN); Rmpfr_set_d($neginf, $double, GMP_RNDN); if(Rmpfr_inf_p($neginf) && $neginf < 0) {$ok .= 'g'} else {warn "g: $neginf\n"} if($ok eq 'abcdefg') {print "ok 80\n"} else {print "not ok 80 $ok\n"} $ok = ''; my $ac1 = Math::MPFR->new(12.25); Rmpfr_add_d($ac1, $ac1, 0.25, GMP_RNDN); if($ac1 == 12.50){$ok .= 'a'} else {warn "81 a: $ac1\n"} Rmpfr_sub_d($ac1, $ac1, 0.25, GMP_RNDN); if($ac1 == 12.25){$ok .= 'b'} else {warn "81 b: $ac1\n"} Rmpfr_d_sub($ac1, 24.5, $ac1, GMP_RNDN); if($ac1 == 12.25){$ok .= 'c'} else {warn "81 c: $ac1\n"} Rmpfr_mul_d($ac1, $ac1, 2.5, GMP_RNDN); if($ac1 == 30.625){$ok .= 'd'} else {warn "81 d: $ac1\n"} Rmpfr_div_d($ac1, $ac1, 2.5, GMP_RNDN); if($ac1 == 12.25){$ok .= 'e'} else {warn "81 e: $ac1\n"} Rmpfr_d_div($ac1, 24.5, $ac1, GMP_RNDN); if($ac1 == 2){$ok .= 'f'} else {warn "81 f: $ac1\n"} Rmpfr_set_d($ac1, 0.0625, GMP_RNDN); Rmpfr_rec_sqrt($ac1, $ac1, GMP_RNDN); if($ac1 == 4){$ok .= 'g'} else {warn "81 g: $ac1\n"} Rmpfr_set_ui($ac1, 0, GMP_RNDN); Rmpfr_rec_sqrt($ac1, $ac1, GMP_RNDN); if(Rmpfr_inf_p($ac1)){$ok .= 'h'} else {warn "81 h: $ac1\n"} Rmpfr_set_ui($ac1, 0, GMP_RNDN); Rmpfr_mul_d($ac1, $ac1, -1.0, GMP_RNDN); Rmpfr_rec_sqrt($ac1, $ac1, GMP_RNDN); if(Rmpfr_inf_p($ac1)){$ok .= 'i'} else {warn "81 i: $ac1\n"} my $ac2 = $ac1; $ac2 *= -1; Rmpfr_rec_sqrt($ac1, $ac1, GMP_RNDN); if($ac1 == 0){$ok .= 'j'} else {warn "81 j: $ac1\n"} Rmpfr_rec_sqrt($ac2, $ac2, GMP_RNDN); if(Rmpfr_nan_p($ac2)){$ok .= 'k'} else {warn "81 k: $ac2\n"} Rmpfr_set_d($ac1, 12.25, GMP_RNDN); Rmpfr_modf($ac1, $ac2, $ac1, GMP_RNDN); if($ac1 == 12) {$ok .= 'l'} else {warn "81 l: $ac1\n"} if($ac2 == 0.25) {$ok .= 'm'} else {warn "81 m: $ac2\n"} Rmpfr_set_ui($ac1, 0, GMP_RNDN); Rmpfr_li2($ac2, $ac1, GMP_RNDN); if(!$ac2) {$ok .= 'n'} else {warn "81 n: $ac2\n"} Rmpfr_set_ui($ac1, 1, GMP_RNDN); Rmpfr_li2($ac2, $ac1, GMP_RNDN); if($ac2 > 1.64493406 && $ac2 < 1.64493407) {$ok .= 'o'} else {warn "81 o: $ac2\n"} Rmpfr_set_ui($ac1, 2, GMP_RNDN); Rmpfr_li2($ac2, $ac1, GMP_RNDN); if($ac2 > 2.4674011002 && $ac2 < 2.4674011003) {$ok .= 'p'} else {warn "81 p: $ac2\n"} if($ok eq 'abcdefghijklmnop'){print "ok 81\n"} else {print "not ok 81 $ok\n"} if(MPFR_VERSION_MAJOR >= 3) { my $str = ''; for(1..21) {$str .= 1 + int(rand(10))} my $state = Rmpfr_randinit_lc_2exp_size(90); Rmpfr_randseed($state, $str); my $rand = Math::MPFR->new(); Rmpfr_urandom($rand, $state, MPFR_RNDN); if($rand < 1 && $rand > 0) {print "ok 82\n"} else { warn "82: \$rand: $rand\n"; print "not ok 82\n"; } } else { my $str = ''; for(1..21) {$str .= 1 + int(rand(10))} my $state = Rmpfr_randinit_lc_2exp_size(90); Rmpfr_randseed($state, $str); my $rand = Math::MPFR->new(); eval{Rmpfr_urandom($rand, $state, MPFR_RNDN);}; if($@ =~ /Rmpfr_urandom not implemented/) {print "ok 82\n"} else { warn "82: \$\@: $@\n"; print "not ok 82\n"; } } if($have_mpz) { my $z = Math::GMPz->new(5); my $fr = Math::MPFR->new(); if(MPFR_VERSION_MAJOR >= 3) { Rmpfr_set_z_2exp($fr, $z, -2, MPFR_RNDN); if($fr == 1.25) {print "ok 83\n"} else { warn "83: \$fr: $fr\n"; print "not ok 83\n"; } } else { eval{Rmpfr_set_z_2exp($fr, $z, -2, MPFR_RNDN);}; if($@ =~ /Rmpfr_set_z_2exp not implemented/) {print "ok 83\n"} else { warn "83: \$\@: $@\n"; print "not ok 83\n"; } } } else { warn "Skipping test 83: No Math::GMPz\n"; print "ok 83\n"; } if($have_Math_GMP) { my $z = Math::GMP->new(5); my $fr = Math::MPFR->new(); if(MPFR_VERSION_MAJOR >= 3) { Rmpfr_set_z_2exp($fr, $z, -2, MPFR_RNDN); if($fr == 1.25) {print "ok 84\n"} else { warn "84: \$fr: $fr\n"; print "not ok 84\n"; } } else { eval{Rmpfr_set_z_2exp($fr, $z, -2, MPFR_RNDN);}; if($@ =~ /Rmpfr_set_z_2exp not implemented/) {print "ok 84\n"} else { warn "84: \$\@: $@\n"; print "not ok 84\n"; } } } else { warn "Skipping test 84: No Math::GMP\n"; print "ok 84\n"; } my $nnum_val = Math::MPFR::nnumflag(); my $nnum_test = Math::MPFR->new('2 .3'); if(Math::MPFR::nnumflag() == $nnum_val + 1) {print "ok 85\n"} else { warn "\nnnumflag: expected ", $nnum_val + 1, ", got ", Math::MPFR::nnumflag(), "\n"; print "not ok 85\n"; } # Run the following to test Rmpfr_inp_str # and Rmpfr_dump __END__ print "\nEnter a number [eg .11235\@4]\n"; Rmpfr_inp_str($check, 10, GMP_RNDN); print "\n"; Rmpfr_dump($check); print "\n"; Math-MPFR-4.38/t/test2.t0000755060175106010010000001003514765756127013377 0ustar OwnerNoneuse strict; use warnings; use Config; use Math::MPFR qw(:mpfr); print "1..8\n"; print "# Using Math::MPFR version ", $Math::MPFR::VERSION, "\n"; print "# Using mpfr library version ", MPFR_VERSION_STRING, "\n"; print "# Using gmp library version ", Math::MPFR::gmp_v(), "\n"; my $expected_refcnt = 1; $expected_refcnt++ if $Config{ccflags} =~ /\-DPERL_RC_STACK/; my ($have_mpz, $have_gmp) = (0, 0); my $c = Rmpfr_init(); my $check2 = Rmpfr_init(); my $z; Rmpfr_set_default_prec(300); eval{require Math::GMP}; if(!$@) {$have_gmp = 1} eval{require Math::GMPz}; if(!$@) {$have_mpz = 1} if($have_gmp || $have_mpz) { if($have_gmp) {$z = Math::GMP->new("1123")} else {$z = Math::GMPz->new("1123")} Rmpfr_set_z($c, $z, GMP_RNDN); if($c == 1123 && Math::MPFR::get_refcnt($z) == $expected_refcnt && (Math::MPFR::get_package_name($z) eq "Math::GMP" || Math::MPFR::get_package_name($z) eq "Math::GMPz")) {print "ok 1\n"} else {print "not ok 1\n"} } else { warn "Skipping test 1 - no Math::GMP or Math::GMPz\n"; print "ok 1\n"; } if($have_gmp || $have_mpz) { Rmpfr_set_prec($c, 53); Rmpfr_set_ui($c, 2, GMP_RNDN); if($have_gmp) {$z = Math::GMP->new(0)} else {$z = Math::GMPz->new(0)} my $exp = Rmpfr_get_z_exp($z, $c); if($exp == -51 && "$z" eq '4503599627370496' && (Math::MPFR::get_package_name($z) eq "Math::GMP" || Math::MPFR::get_package_name($z) eq "Math::GMPz")) {print "ok 2\n"} else {print "not ok 2\n"} } else { warn "Skipping test 2 - no Math::GMP or Math::GMPz\n"; print "ok 2\n"; } if($have_gmp || $have_mpz) { if($have_gmp) {$z = Math::GMP->new(11234)} else {$z = Math::GMPz->new(11234)} Rmpfr_set_prec($c, 300); Rmpfr_set_ui($c, 237, GMP_RNDN); Rmpfr_div_z($check2, $c, $z, GMP_RNDN); Rmpfr_mul_z($check2, $check2, $z, GMP_RNDN); if($check2 - $c > -0.000001 && $check2 - $c < 0.000001 && (Math::MPFR::get_package_name($z) eq "Math::GMP" || Math::MPFR::get_package_name($z) eq "Math::GMPz")) {print "ok 3\n"} else {print "not ok 3\n"} } else { warn "Skipping test 3 - no Math::GMP or Math::GMPz\n"; print "ok 3\n"; } if($have_gmp || $have_mpz) { if($have_gmp) {$z = Math::GMP->new("1123")} else {$z = Math::GMPz->new("1123")} my ($c, $cmp) = Rmpfr_init_set_z($z, GMP_RNDN); if($c == 1123 && Math::MPFR::get_refcnt($z) == $expected_refcnt && (Math::MPFR::get_package_name($z) eq "Math::GMP" || Math::MPFR::get_package_name($z) eq "Math::GMPz")) {print "ok 4\n"} else {print "not ok 4\n"} } else { warn "Skipping test 4 - no Math::GMP or Math::GMPz\n"; print "ok 4\n"; } if($have_gmp || $have_mpz) { if($have_gmp) {$z = Math::GMP->new(17)} else {$z = Math::GMPz->new(17)} Rmpfr_set($check2, $c, GMP_RNDN); Rmpfr_add_z($c, $c, $z, GMP_RNDN); Rmpfr_sub_z($c, $c, $z, GMP_RNDN); if($c == $check2) {print "ok 5\n"} else {print "not ok 5\n"} } else { warn "Skipping test 5 - no Math::GMP or Math::GMPz\n"; print "ok 5\n"; } my $op1 = Math::MPFR->new(123); my $op2 = Math::MPFR->new(456); my $rop = Math::MPFR->new(); Rmpfr_dim($rop, $op1, $op2, GMP_RNDN); if($rop == 0) {print "ok 6\n"} else { warn "\n\$rop: $rop\n"; print "not ok 6\n"; } Rmpfr_dim($rop, $op2, $op1, GMP_RNDN); if($rop == 333) {print "ok 7\n"} else { warn "\n\$rop: $rop\n"; print "not ok 7\n"; } if($have_gmp || $have_mpz) { if((MPFR_VERSION_MAJOR == 3 && MPFR_VERSION_MINOR >= 1) || MPFR_VERSION_MAJOR > 3) { my $gmp; my $fr = Math::MPFR->new(10.25); if($have_gmp) {$gmp = Math::GMP->new(5)} else {$gmp = Math::GMPz->new(5)} my $ok = ''; Rmpfr_z_sub($fr, $gmp, $fr, GMP_RNDN); if($fr == -5.25) {print "ok 8\n"} else {print "not ok 8\n"} } else { my $z; my $fr = Math::MPFR->new(10.25); if($have_gmp) {$z = Math::GMP->new(5)} else {$z = Math::GMPz->new(5)} eval{Rmpfr_z_sub($fr, $z, $fr, GMP_RNDN);}; if($@ =~ /Rmpfr_z_sub not implemented/) {print "ok 8\n"} else { warn "\$\@: $@"; print "not ok 8\n"; } } } else { warn "Skipping test 8 - no Math::GMP or Math::GMPz\n"; print "ok 8\n"; } Math-MPFR-4.38/t/test3.t0000755060175106010010000001131114765756127013376 0ustar OwnerNone# Test the functions that became available with MPFR-2.1.0. use strict; use warnings; use Math::MPFR qw(:mpfr); print "1..21\n"; print "# Using Math::MPFR version ", $Math::MPFR::VERSION, "\n"; print "# Using mpfr library version ", MPFR_VERSION_STRING, "\n"; print "# Using gmp library version ", Math::MPFR::gmp_v(), "\n"; Rmpfr_set_default_prec(300); my $rnd = 0; my $double = 1234567.0987; my $mpfr_nan = Rmpfr_init(); my $mpfr1 = Rmpfr_init(); my $mpfr2 = Rmpfr_init(); my $v; my($have_mpz, $have_mpf, $have_mpq, $have_gmp) = (0, 0, 0, 0); eval{require Math::GMPz}; if(!$@) {$have_mpz = 1} eval{require Math::GMPf}; if(!$@) {$have_mpf = 1} eval{require Math::GMPq}; if(!$@) {$have_mpq = 1} eval{require Math::GMP}; if(!$@) {$have_gmp = 1} Rmpfr_set_d($mpfr1, $double, $rnd); if($have_mpz) { my $ok = ''; my $z = Math::GMPz::Rmpz_init_set_ui(123456); my $cmp = Rmpfr_cmp_z($mpfr_nan, $z); if(Rmpfr_erangeflag_p() && !$cmp) {$ok .= 'a'} Rmpfr_clear_erangeflag(); if(!Rmpfr_erangeflag_p()) {$ok .= 'b'} if(Rmpfr_cmp_z($mpfr1, $z) > 0) {$ok .= 'c'} my $ret = Rmpfr_get_z($z, $mpfr1, $rnd); if(MPFR_VERSION_MAJOR >= 3) { if(defined($ret)) {$ok .= 'D'} } else { if(!defined($ret)) {$ok .= 'D'} } Rmpfr_trunc($mpfr1, $mpfr1); if(!Rmpfr_cmp_z($mpfr1, $z)) {$ok .= 'd'} Rmpfr_set_d($mpfr1, $double, $rnd); if($ok eq 'abcDd') {print "ok 1\n"} else {print "not ok 1 $ok\n"} } else { warn "Skipping test 1 - no Math::GMPz\n"; print "ok 1\n"; } if($have_mpq) { my $ok = ''; my $q = Math::GMPq::Rmpq_init(); Math::GMPq::Rmpq_set_ui($q, 11, 17); my $cmp = Rmpfr_cmp_q($mpfr_nan, $q); if(Rmpfr_erangeflag_p() && !$cmp) {$ok .= 'a'} Rmpfr_clear_erangeflag(); if(!Rmpfr_erangeflag_p()) {$ok .= 'b'} if(Rmpfr_cmp_q($mpfr1, $q) > 0) {$ok .= 'c'} if($ok eq 'abc') {print "ok 2\n"} else {print "not ok 2 $ok\n"} } else { warn "Skipping test 2 - no Math::GMPq\n"; print "ok 2\n"; } if($have_mpf) { my $ok = ''; my $f = Math::GMPf::Rmpf_init_set_d(123456.12); my $cmp = Rmpfr_cmp_f($mpfr_nan, $f); if(Rmpfr_erangeflag_p() && !$cmp) {$ok .= 'a'} Rmpfr_clear_erangeflag(); if(!Rmpfr_erangeflag_p()) {$ok .= 'b'} if(Rmpfr_cmp_f($mpfr1, $f) > 0) {$ok .= 'c'} if($ok eq 'abc') {print "ok 3\n"} else {print "not ok 3 $ok\n"} } else { warn "Skipping test 3 - no Math::GMPf\n"; print "ok 3\n"; } if($have_gmp) { my $ok = ''; my $z = Math::GMP->new(123456); my $cmp = Rmpfr_cmp_z($mpfr_nan, $z); if(Rmpfr_erangeflag_p() && !$cmp) {$ok .= 'a'} Rmpfr_clear_erangeflag(); if(!Rmpfr_erangeflag_p()) {$ok .= 'b'} if(Rmpfr_cmp_z($mpfr1, $z) > 0) {$ok .= 'c'} Rmpfr_get_z($z, $mpfr1, $rnd); Rmpfr_trunc($mpfr1, $mpfr1); if(!Rmpfr_cmp_z($mpfr1, $z)) {$ok .= 'd'} Rmpfr_set_d($mpfr1, $double, $rnd); if($ok eq 'abcd') {print "ok 4\n"} else {print "not ok 4 $ok\n"} } else { warn "Skipping test 4 - no Math::GMP\n"; print "ok 4\n"; } Rmpfr_set_ui_2exp($mpfr2, 5, 3, $rnd); if($mpfr2 == 40) {print "ok 5\n"} else {print "not ok 5\n"} Rmpfr_set_si_2exp($mpfr2, 5, 3, $rnd); if($mpfr2 == 40) {print "ok 6\n"} else {print "not ok 6\n"} Rmpfr_set_si_2exp($mpfr2, 8, -3, $rnd); if($mpfr2 == 1) {print "ok 7\n"} else {print "not ok 7\n"} Rmpfr_sub_si($mpfr2, $mpfr2, -11, $rnd); if($mpfr2 == 12) {print "ok 8\n"} else {print "not ok 8\n"} Rmpfr_si_sub($mpfr2, -11, $mpfr2, $rnd); if($mpfr2 == -23) {print "ok 9\n"} else {print "not ok 9\n"} Rmpfr_mul_si($mpfr2, $mpfr2, -11, $rnd); if($mpfr2 == 253) {print "ok 10\n"} else {print "not ok 10\n"} Rmpfr_div_si($mpfr2, $mpfr2, -11, $rnd); if($mpfr2 == -23) {print "ok 11\n"} else {print "not ok 11\n"} $mpfr2++; Rmpfr_si_div($mpfr2, -11, $mpfr2, $rnd); if($mpfr2 == 0.5) {print "ok 12\n"} else {print "not ok 12\n"} Rmpfr_mul($mpfr1, $mpfr2, $mpfr2, $rnd); Rmpfr_sqr($mpfr2, $mpfr2, $rnd); if($mpfr1 == $mpfr2) {print "ok 13\n"} else {print "not ok 13\n"} Rmpfr_const_pi($mpfr1, $rnd); if(!Rmpfr_zero_p($mpfr1)) {print "ok 14\n"} else {print "not ok 14\n"} eval{Rmpfr_free_cache();}; if(!$@) {print "ok 15\n"} else {print "not ok 15: $@\n"} eval{$v = Rmpfr_get_version();}; if(!$@ && $v) {print "ok 16\n"} else {print "not ok 16: $@\n"} if((Rmpfr_get_emin_min() <= Rmpfr_get_emin_max()) && (Rmpfr_get_emax_min() <= Rmpfr_get_emax_max())) {print "ok 17\n"} else {print "not ok 17\n"} Rmpfr_set_d($mpfr1, $double, $rnd); Rmpfr_rint_ceil($mpfr2, $mpfr1, $rnd); if($mpfr2 == 1234568) {print "ok 18\n"} else {print "not ok 18\n"} Rmpfr_rint_floor($mpfr2, $mpfr1, $rnd); if($mpfr2 == 1234567) {print "ok 19\n"} else {print "not ok 19\n"} Rmpfr_rint_round($mpfr2, $mpfr1, $rnd); if($mpfr2 == 1234567) {print "ok 20\n"} else {print "not ok 20\n"} Rmpfr_rint_trunc($mpfr2, $mpfr1, $rnd); if($mpfr2 == 1234567) {print "ok 21\n"} else {print "not ok 21\n"} Math-MPFR-4.38/t/test4.t0000755060175106010010000002412414765756127013405 0ustar OwnerNoneuse warnings; use strict; use Math::MPFR qw(:mpfr); use Config; print "1..46\n"; print "# Using Math::MPFR version ", $Math::MPFR::VERSION, "\n"; print "# Using mpfr library version ", MPFR_VERSION_STRING, "\n"; print "# Using gmp library version ", Math::MPFR::gmp_v(), "\n"; my $have_mpq = 0; my $ok; eval{require Math::GMPq}; if(!$@) {$have_mpq = 1} Rmpfr_set_default_rounding_mode(GMP_RNDZ); if(Rmpfr_get_default_rounding_mode() == GMP_RNDZ) {print "ok 1\n"} else {print "not ok 1\n"} Rmpfr_set_default_rounding_mode(GMP_RNDN); if(Rmpfr_get_default_rounding_mode() == GMP_RNDN) {print "ok 2\n"} else {print "not ok 2\n"} Rmpfr_set_default_prec(300); my $f = Rmpfr_init(); Rmpfr_set_d($f, 13.5, GMP_RNDN); my $ret = Rmpfr_prec_round($f, 70, GMP_RNDN); if($ret == 0 && $f == 13.5 && Rmpfr_get_prec($f) == 70) {print "ok 3\n"} else {print "not ok 3\n"} my $emin = Rmpfr_get_emin(); my $emax = Rmpfr_get_emax(); $emin++; $emax--; if(!Rmpfr_set_emin($emin)) {print "ok 4\n"} else {print "not ok 4\n"} if(!Rmpfr_set_emax($emax)) {print "ok 5\n"} else {print "not ok 5\n"} if(Rmpfr_get_emin() == $emin && Rmpfr_get_emax() == $emax) {print "ok 6\n"} else {print "not ok 6\n"} $emin--; $emax++; if(!Rmpfr_set_emin($emin)) {print "ok 7\n"} else {print "not ok 7\n"} if(!Rmpfr_set_emax($emax)) {print "ok 8\n"} else {print "not ok 8\n"} if(Rmpfr_get_emin() == $emin && Rmpfr_get_emax() == $emax) {print "ok 9\n"} else {print "not ok 9\n"} $ok = ''; my $fma = Rmpfr_init(); my $m = Rmpfr_init(); my $a = Rmpfr_init(); Rmpfr_set_d($m, 121.5, GMP_RNDN); Rmpfr_set_d($a, 23.25, GMP_RNDN); Rmpfr_fma($fma, $f, $m, $a, GMP_RNDN); if($fma == 1663.5) {$ok .= 'a'} Rmpfr_fms($fma, $f, $m, $a, GMP_RNDN); if($fma == 1617) {$ok .= 'b'} if($ok eq 'ab') {print "ok 10\n"} else {print "not ok 10 $ok\n"} Rmpfr_sqrt_ui($fma, 2, GMP_RNDN); if($fma > 1.414213 && $fma < 1.414214) {print "ok 11\n"} else {print "not ok 11\n"} if(!Rmpfr_equal_p($fma, $m) && Rmpfr_lessgreater_p($fma, $m)) {print "ok 12\n"} else {print "not ok 12\n"} if(Rmpfr_lessequal_p($fma, $m) && Rmpfr_less_p($fma, $m) && Rmpfr_greater_p($m, $fma) && Rmpfr_greaterequal_p($m, $fma)) {print "ok 13\n"} else {print "not ok 13\n"} Rmpfr_fac_ui($fma, 10, GMP_RNDN); if($fma == 3628800) {print "ok 14\n"} else {print "not ok 14\n"} my $angle = Rmpfr_init(); my $s = Rmpfr_init(); my $c = Rmpfr_init(); Rmpfr_set_d($angle, 3.217, GMP_RNDN); Rmpfr_sin($s, $angle, GMP_RNDN); Rmpfr_cos($c, $angle, GMP_RNDN); Rmpfr_pow_ui($s, $s, 2, GMP_RNDN); Rmpfr_pow_ui($c, $c, 2, GMP_RNDN); Rmpfr_add($s, $s, $c, GMP_RNDN); if($s > 0.9999999 && $s < 1.00000001) {print "ok 15\n"} else {print "not ok 15\n"} $ret = Rmpfr_log1p($fma, $fma, GMP_RNDN); if($ret && $fma > 15.104412848648 && $fma < 15.104412848649) {print "ok 16\n"} else {print "not ok 16\n"} $ret = Rmpfr_expm1($fma, $fma, GMP_RNDN); if($ret && $fma > 3628799.99999 && $fma < 3628800.00001) {print "ok 17\n"} else {print "not ok 17\n"} $f *= -1; $ret = Rmpfr_frac($f, $f, GMP_RNDN); if(!$ret && $f == -0.5) {print "ok 18\n"} else {print "not ok 18\n"} my $next = Rmpfr_init(); Rmpfr_nexttoward($f, $next); if(Rmpfr_nan_p($f)) {print "ok 19\n"} else {print "not ok 19\n"} Rmpfr_set_d($f, 10.5, GMP_RNDN); Rmpfr_set_d($m, 11.5, GMP_RNDN); Rmpfr_nexttoward($f, $m); if($f > 10.5 && $f < 10.50001) {print "ok 20\n"} else {print "not ok 20\n"} Rmpfr_set_d($f, 10.5, GMP_RNDN); Rmpfr_nextabove($f); if($f > 10.5 && $f < 10.50001) {print "ok 21\n"} else {print "not ok 21\n"} Math::MPFR::Rmpfr_nextbelow($f); if($f == 10.5) {print "ok 22\n"} else {print "not ok 22\n"} Rmpfr_nextabove($next); if(Rmpfr_nan_p($next)) {print "ok 23\n"} else {print "not ok 23\n"} Math::MPFR::Rmpfr_nextbelow($next); if(Rmpfr_nan_p($next)) {print "ok 24\n"} else {print "not ok 24\n"} $ret = Rmpfr_ui_pow_ui($fma, 7, 5, GMP_RNDN); if(!$ret && $fma == 16807) {print "ok 25\n"} else {print "not ok 25\n"} Rmpfr_set_d($f, 1.23456789, GMP_RNDU); $ret = Rmpfr_ui_pow($fma, 7, $f, GMP_RNDN); if($ret && $fma > 11.049201764 && $fma < 11.049201765) {print "ok 26\n"} else {print "not ok 26\n"} $ret = Rmpfr_pow_si($fma, $f, -3, GMP_RNDN); if($ret && $fma > 0.531441014 && $fma < 0.531441015) {print "ok 27\n"} else {print "not ok 27\n"} Rmpfr_set_d($f, 0.25, GMP_RNDN); $ret = Rmpfr_cmp_ui_2exp($f, 2, -3); if(!$ret) {print "ok 28\n"} else {print "not ok 28\n"} $f *= -1; $ret = Rmpfr_cmp_si_2exp($f, -2, -3); if(!$ret) {print "ok 29\n"} else {print "not ok 29\n"} eval {Rmpfr_set_str_binary($f, '-1000.11E-3')}; if($@) {print "ok 30\n"} else {print "not ok 30\n"} Rmpfr_set_str($f, '-1000.11E-3', 2, MPFR_RNDN); $f *= -1; if($have_mpq) { my $q = Math::GMPq::Rmpq_init(); Math::GMPq::Rmpq_set_ui($q, 11, 17); Rmpfr_add_q($f, $f, $q, GMP_RNDN); Rmpfr_sub_q($f, $f, $q, GMP_RNDN); if($f > 1.0937499 && $f < 1.0937501) {print "ok 31\n"} else {print "not ok 31\n"} } else { warn "Skipping test 31 - no Math::GMPq\n"; print "ok 31\n"; } my ($u1, $cmp1) = Rmpfr_init_set_str('1.a', 16, GMP_RNDN); if(!$cmp1) {print "ok 32\n"} else {print "not ok 32\n"} my ($u2, $cmp2) = Rmpfr_init_set_str('1.a', 10, GMP_RNDZ); if($cmp2 == -1) {print "ok 33\n"} else {print "not ok 33\n"} #################################### $ok = ''; #my $h = Rmpfr_init2(59); #Rmpfr_set_str_binary ($h, "-0.10010001010111000011110010111010111110000000111101100111111E663"); #if (Rmpfr_can_round ($h, 54, GMP_RNDZ, GMP_RNDZ, 53) != 0) {$ok = 'E'} #else {$ok = 'a'} # #Rmpfr_set_str_binary ($h, "-Inf"); #if (Rmpfr_can_round ($h, 2000, GMP_RNDZ, GMP_RNDZ, 2000) != 0) {$ok .= 'E'} #else {$ok .= 'b'} # #Rmpfr_set_prec ($h, 64); #Rmpfr_set_str_binary ($h, "0.1011001000011110000110000110001111101011000010001110011000000000"); #if (Rmpfr_can_round ($h, 65, GMP_RNDN, GMP_RNDN, 54)) {$ok .= 'E'} #else {$ok .= 'c'} # #if($ok eq 'abc') {print "ok 34\n"} #else {print "not ok 34 $ok\n"} print "ok 34\n"; # test removed because Rmpfr_set_str_binary no longer implemented my $k = Rmpfr_init2(53); my $str = '1' x 53; Rmpfr_set_str($k, $str, 2, GMP_RNDN); my @deref = Math::MPFR::Rmpfr_deref2($k, 10, 0, GMP_RNDN); if($deref[0] eq '90071992547409910') {print "ok 35\n"} else {print "not ok 35 $deref[0]\n"} $ok = ''; if($Config::Config{longsize} == 8) { if(Rmpfr_fits_ulong_p($k, GMP_RNDN) && Rmpfr_fits_slong_p($k, GMP_RNDN)) {$ok = 'a'} } else { if(!Rmpfr_fits_ulong_p($k, GMP_RNDN) && !Rmpfr_fits_slong_p($k, GMP_RNDN)) {$ok = 'a'} } Rmpfr_set_d($k, 123.456789, GMP_RNDN); if(Rmpfr_fits_ulong_p($k, GMP_RNDN) && Rmpfr_fits_slong_p($k, GMP_RNDN)) {$ok .= 'b'} Rmpfr_set_d($k, 2147483648.4444, GMP_RNDN); if($Config::Config{longsize} == 8) { if(Rmpfr_fits_ulong_p($k, GMP_RNDN) && Rmpfr_fits_slong_p($k, GMP_RNDN)) {$ok .= 'c'} } else { if(Rmpfr_fits_ulong_p($k, GMP_RNDN) && !Rmpfr_fits_slong_p($k, GMP_RNDN)) {$ok .= 'c'} } if($ok eq 'abc') {print "ok 36\n"} else {print "not ok 36 $ok\n"} if(Rmpfr_get_ui($k, GMP_RNDN) == 2147483648) {print "ok 37\n"} else {print "not ok 37\n"} Rmpfr_set_si($k, -2147483647, GMP_RNDN); if(Rmpfr_get_si($k, GMP_RNDN) == -2147483647) {print "ok 38\n"} else {print "not ok 38\n"} my $u = Math::MPFR->new(256); if(Rmpfr_fits_intmax_p($u, GMP_RNDN) && Rmpfr_fits_sint_p($u, GMP_RNDN) && Rmpfr_fits_slong_p($u, GMP_RNDN) && Rmpfr_fits_sshort_p($u, GMP_RNDN) && Rmpfr_fits_uint_p($u, GMP_RNDN) && Rmpfr_fits_uintmax_p($u, GMP_RNDN) && Rmpfr_fits_ulong_p($u, GMP_RNDN) && Rmpfr_fits_ushort_p($u, GMP_RNDN)) {print "ok 39\n"} else {print "not ok 39\n"} Rmpfr_set_default_rounding_mode(GMP_RNDN); my $double = 17.625; if($double == Rmpfr_get_NV(Math::MPFR->new($double), GMP_RNDN)) {print "ok 40\n"} else { warn "\nGot: ", Rmpfr_get_NV(Math::MPFR->new($double), GMP_RNDN) , "\nExpected: $double\n"; print "not ok 40\n"; } $ok = ''; if(MPFR_VERSION_MAJOR >= 3) { if(Rmpfr_regular_p(Math::MPFR->new(17))) {$ok .= 'a'} if(!Rmpfr_regular_p(Math::MPFR->new(0))) {$ok .= 'b'} if(!Rmpfr_regular_p(Math::MPFR->new())) {$ok .= 'c'} if(!Rmpfr_regular_p(Math::MPFR->new(-1) / Math::MPFR->new(0))) {$ok .= 'd'} if(!Rmpfr_regular_p(Math::MPFR->new(1) / Math::MPFR->new(0))) {$ok .= 'e'} if($ok eq 'abcde') {print "ok 41\n"} else { warn "41: \$ok: $ok\n"; print "not ok 41\n"; } Rmpfr_set_zero($fma, -1); if($fma == 0) {print "ok 42\n"} else { warn "42: \$fma: $fma\n"; print "not ok 42\n"; } my $dig1 = Math::MPFR->new(); my $dig2 = Math::MPFR->new(); Rmpfr_digamma($dig1, Math::MPFR->new(2), MPFR_RNDN); Rmpfr_digamma($dig2, Math::MPFR->new(3), MPFR_RNDN); # Let's check the recurrence relation my $diff = $dig2 - ($dig1 + 0.5); if($diff < 0.00000000001 && $diff > -0.00000000001) {print "ok 43\n"} else { warn "43: \$diff: $diff\n"; print "not ok 43\n"; } my $ai = Math::MPFR->new(); Rmpfr_ai($ai, 1 / Math::MPFR->new(0), MPFR_RNDN); if($ai == 0) {print "ok 44\n"} else { warn "44: \$ai: $ai\n"; print "not ok 44\n"; } my $flt = Rmpfr_get_flt(Math::MPFR->new(0.25), MPFR_RNDN); if($flt == 0.25) {print "ok 45\n"} else { warn "45: \$flt: $flt\n"; print "not ok 45\n"; } Rmpfr_set_flt($ai, 0.25, MPFR_RNDN); if($ai == 0.25) {print "ok 46\n"} else { warn "46: \$ai: $ai\n"; print "not ok 46\n"; } } else { eval{Rmpfr_regular_p(Math::MPFR->new())}; if($@ =~ /Rmpfr_regular_p not implemented/) {print "ok 41\n"} else { warn "41: \$\@: $@\n"; print "not ok 41\n"; } eval{Rmpfr_set_zero($fma, -1);}; if($@ =~ /Rmpfr_set_zero not implemented/) {print "ok 42\n"} else { warn "42: \$\@: $@\n"; print "not ok 42\n"; } eval{Rmpfr_digamma($fma, $fma, MPFR_RNDN);}; if($@ =~ /Rmpfr_digamma not implemented/) {print "ok 43\n"} else { warn "43: \$\@: $@\n"; print "not ok 43\n"; } eval{Rmpfr_ai($fma, $fma, MPFR_RNDN);}; if($@ =~ /Rmpfr_ai not implemented/) {print "ok 44\n"} else { warn "44: \$\@: $@\n"; print "not ok 44\n"; } eval{my $flt = Rmpfr_get_flt($fma, MPFR_RNDN);}; if($@ =~ /Rmpfr_get_flt not implemented/) {print "ok 45\n"} else { warn "45: \$\@: $@\n"; print "not ok 45\n"; } eval{Rmpfr_set_flt($fma, 0.3, MPFR_RNDN);}; if($@ =~ /Rmpfr_set_flt not implemented/) {print "ok 46\n"} else { warn "46: \$\@: $@\n"; print "not ok 46\n"; } } Math-MPFR-4.38/t/tls.t0000755060175106010010000001352414765756127013146 0ustar OwnerNoneuse warnings; use strict; use Math::MPFR qw(:mpfr); my $cut = eval 'use threads; 1'; print "1..3\n"; print "# Using Math::MPFR version ", $Math::MPFR::VERSION, "\n"; print "# Using mpfr library version ", MPFR_VERSION_STRING, "\n"; print "# Using gmp library version ", Math::MPFR::gmp_v(), "\n"; if($cut) { if($threads::VERSION < 1.71) { warn "Skipping all tests - need at least threads-1.71, we have version $threads::VERSION\n"; print "ok 1\n"; print "ok 2\n"; print "ok 3\n"; exit(0); } } if($cut && $^O =~ /cygwin/i) { warn "Skipping all tests - failures known to occur on Cygwin\n"; print "ok 1\n"; print "ok 2\n"; print "ok 3\n"; exit(0); } my ($tls, $ok, $pid); eval {$tls = Rmpfr_buildopt_tls_p();}; my $cut_mess = $cut ? '' : "ithreads not available with this build of perl\n"; my $tls_mess = $tls ? '' : $@ ? "Unable to determine whether mpfr was built with '--enable-thread-safe'\n" : "Your mpfr library was not built with '--enable-thread-safe'\n"; if($cut && $tls) { # perform tests Rmpfr_set_default_prec(101); my $thr1 = threads->create( sub { Rmpfr_set_default_prec(201); return Rmpfr_get_default_prec(); } ); my $res = $thr1->join(); if($res == 201 && Rmpfr_get_default_prec() == 101) {$ok .= 'a'} else {warn "\n1a: \$res: $res\n prec: ", Rmpfr_get_default_prec(), "\n"} # Needs TLS to work correctly on MS Windows if($pid = fork()) { Rmpfr_set_default_prec(102); waitpid($pid,0); } else { sleep 1; Rmpfr_set_default_prec(202); _save(Rmpfr_get_default_prec()); exit(0); } sleep 2; if(Rmpfr_get_default_prec() == 102) {$ok .= 'b'} else {warn "\n1b: prec: ", Rmpfr_get_default_prec(), "\n"} my $f = _retrieve(); if($f == 999999) { warn "Skipping test 1c - couldn't open 'save_child_setting.txt'"; $ok .= 'c'; } elsif($f == 202) { $ok .= 'c'; } else { warn "\n1c: prec: $f\n"; } if($ok eq 'abc') {print "ok 1\n"} else { warn "\$ok: $ok\n"; print "not ok 1\n"; } ####################### $ok = ''; Rmpfr_set_default_rounding_mode(GMP_RNDZ); my $thr2 = threads->create( sub { Rmpfr_set_default_rounding_mode(GMP_RNDU); return Rmpfr_get_default_rounding_mode(); } ); $res = $thr2->join(); if($res == GMP_RNDU && Rmpfr_get_default_rounding_mode() == GMP_RNDZ) {$ok .= 'a'} else {warn "\n2a: \$res: $res\n rounding: ", Rmpfr_get_default_rounding_mode(), "\n"} # Needs TLS to work correctly on MS Windows if($pid = fork()) { Rmpfr_set_default_rounding_mode(GMP_RNDU); waitpid($pid,0); } else { sleep 1; Rmpfr_set_default_rounding_mode(GMP_RNDD); _save(Rmpfr_get_default_rounding_mode()); exit(0); } sleep 2; if(Rmpfr_get_default_rounding_mode() == GMP_RNDU) {$ok .= 'b'} else {warn "\n2b: rounding: ", Rmpfr_get_default_rounding_mode(), "\n"} $f = _retrieve(); if($f == 999999) { warn "Skipping test 2c - couldn't open 'save_child_setting.txt'"; $ok .= 'c'; } elsif($f == GMP_RNDD) { $ok .= 'c'; } else { warn "\n2c: rounding: $f\n"; } if($ok eq 'abc') {print "ok 2\n"} else { warn "\$ok: $ok\n"; print "not ok 2\n"; } ####################### $ok = ''; Rmpfr_set_default_rounding_mode(GMP_RNDN); Rmpfr_set_default_prec(103); my $thr3 = threads->create( {'context' => 'list'}, sub { Rmpfr_set_default_prec(203); Rmpfr_set_default_rounding_mode(GMP_RNDU); return (Rmpfr_get_default_prec(), Rmpfr_get_default_rounding_mode()); } ); my @res = $thr3->join(); if($res[0] == 203 && $res[1] == GMP_RNDU && Rmpfr_get_default_prec() == 103 && Rmpfr_get_default_rounding_mode() == GMP_RNDN) {$ok .= 'a'} else {warn "\n3a: \$res[0]: $res[0]\n \$res[1]: $res[1]\n prec: ", Rmpfr_get_default_prec(), "\n rounding: ", Rmpfr_get_default_rounding_mode(), "\n"} # Needs TLS to work correctly on MS Windows if($pid = fork()) { Rmpfr_set_default_prec(104); Rmpfr_set_default_rounding_mode(GMP_RNDU); waitpid($pid,0); } else { sleep 1; Rmpfr_set_default_prec(204); Rmpfr_set_default_rounding_mode(GMP_RNDD); my $p = Rmpfr_get_default_prec(); my $r = Rmpfr_get_default_rounding_mode(); _save("$p $r"); exit(0); } sleep 2; if(Rmpfr_get_default_rounding_mode() == GMP_RNDU && Rmpfr_get_default_prec() == 104) {$ok .= 'b'} else {warn "\n3b: prec: ", Rmpfr_get_default_prec(), "\n rounding: ", Rmpfr_get_default_rounding_mode(), "\n"} my @f = _retrieve(); if($f[0] == 999999) { warn "Skipping test 3c - couldn't open 'save_child_setting.txt'"; $ok .= 'c'; } elsif($f[0] == 204 && $f[1] == GMP_RNDD) { $ok .= 'c'; } else { warn "\n3c: prec: $f[0] rounding: $f[1]\n"; } if($ok eq 'abc') {print "ok 3\n"} else { warn "\$ok: $ok\n"; print "not ok 3\n"; } ####################### } else { warn "Skipping all tests: ${cut_mess}${tls_mess}"; print "ok 1\n"; print "ok 2\n"; print "ok 3\n"; } sub _save { my $WR; unless (open($WR, '>', 'save_child_setting.txt')) { warn "Can't open file 'save_child_setting.txt' for writing : $!"; return 0; } print $WR $_[0]; close($WR); return 1; } sub _retrieve { my $RD; unless (open ($RD, '<', 'save_child_setting.txt')) { warn "Can't open file 'save_child_setting.txt' for reading: $!"; return 999999; } my @ret; my $ret = <$RD>; chomp $ret; if($ret =~ / /) { @ret = split / /, $ret; close($RD); return @ret; } close($RD); return $ret; } Math-MPFR-4.38/t/tls_flags.t0000755060175106010010000001130514765756127014315 0ustar OwnerNoneuse warnings; use strict; use Math::MPFR qw(:mpfr); my $cut = eval 'use threads; 1'; print "1..1\n"; print "# Using Math::MPFR version ", $Math::MPFR::VERSION, "\n"; print "# Using mpfr library version ", MPFR_VERSION_STRING, "\n"; print "# Using gmp library version ", Math::MPFR::gmp_v(), "\n"; if($cut) { if($threads::VERSION < 1.71) { warn "Skipping this test script - need at least threads-1.71, we have version $threads::VERSION\n"; print "ok 1\n"; exit(0); } } if($cut && $^O =~ /cygwin/i) { warn "Skipping test - failure known to occur on Cygwin\n"; print "ok 1\n"; exit(0); } my ($tls, $ok); eval {$tls = Rmpfr_buildopt_tls_p();}; my $cut_mess = $cut ? '' : "ithreads not available with this build of perl\n"; my $tls_mess = $tls ? '' : $@ ? "Unable to determine whether mpfr was built with '--enable-thread-safe'\n" : "Your mpfr library was not built with '--enable-thread-safe'\n"; if($cut && $tls) { # perform tests #### my $thr1 = threads->create( {'context' => 'list'}, sub { my @ret; $ret[0] = Rmpfr_underflow_p() ? 1 : 0; Rmpfr_set_underflow(); $ret[1] = Rmpfr_underflow_p() ? 1 : 0; return @ret; } ); my @r = $thr1->join(); if($r[0] == 0 && $r[1] == 1) {$ok .= 'a'} else {warn "1a: \$r[0]: $r[0] \$r[1]: $r[1]\n"} if(!Rmpfr_underflow_p()) {$ok .= 'b'} else {warn "1b: Underflow set\n"} #### #### my $thr2 = threads->create( {'context' => 'list'}, sub { my @ret; $ret[0] = Rmpfr_overflow_p() ? 1 : 0; Rmpfr_set_overflow(); $ret[1] = Rmpfr_overflow_p() ? 1 : 0; return @ret; } ); @r = $thr2->join(); if($r[0] == 0 && $r[1] == 1) {$ok .= 'c'} else {warn "1c: \$r[0]: $r[0] \$r[1]: $r[1]\n"} if(!Rmpfr_overflow_p()) {$ok .= 'd'} else {warn "1d: Overflow set\n"} #### #### my $thr3 = threads->create( {'context' => 'list'}, sub { my @ret; $ret[0] = Rmpfr_nanflag_p() ? 1 : 0; Rmpfr_set_nanflag(); $ret[1] = Rmpfr_nanflag_p() ? 1 : 0; return @ret; } ); @r = $thr3->join(); if($r[0] == 0 && $r[1] == 1) {$ok .= 'e'} else {warn "1e: \$r[0]: $r[0] \$r[1]: $r[1]\n"} if(!Rmpfr_nanflag_p()) {$ok .= 'f'} else {warn "1f: Nanflag set\n"} #### #### my $thr4 = threads->create( {'context' => 'list'}, sub { my @ret; $ret[0] = Rmpfr_inexflag_p() ? 1 : 0; Rmpfr_set_inexflag(); $ret[1] = Rmpfr_inexflag_p() ? 1 : 0; return @ret; } ); @r = $thr4->join(); if($r[0] == 0 && $r[1] == 1) {$ok .= 'g'} else {warn "1g: \$r[0]: $r[0] \$r[1]: $r[1]\n"} if(!Rmpfr_inexflag_p()) {$ok .= 'h'} else {warn "1h: Inexflag set\n"} #### #### my $thr5 = threads->create( {'context' => 'list'}, sub { my @ret; $ret[0] = Rmpfr_erangeflag_p() ? 1 : 0; Rmpfr_set_erangeflag(); $ret[1] = Rmpfr_erangeflag_p() ? 1 : 0; return @ret; } ); @r = $thr5->join(); if($r[0] == 0 && $r[1] == 1) {$ok .= 'i'} else {warn "1i: \$r[0]: $r[0] \$r[1]: $r[1]\n"} if(!Rmpfr_erangeflag_p()) {$ok .= 'j'} else {warn "1j: Underflow set\n"} #### #### my $thr6 = threads->create( {'context' => 'list'}, sub { my @ret; $ret[0] = Rmpfr_divby0_p() ? 1 : 0; Rmpfr_set_divby0(); $ret[1] = Rmpfr_divby0_p() ? 1 : 0; return @ret; } ); @r = $thr6->join(); if($r[0] == 0 && $r[1] == 1) {$ok .= 'k'} else {warn "1k: \$r[0]: $r[0] \$r[1]: $r[1]\n"} if(!Rmpfr_divby0_p()) {$ok .= 'l'} else {warn "1l: Divide-by-zero set\n"} #### if($ok eq 'abcdefghijkl') {print "ok 1\n"} else { warn "\$ok: $ok\n"; print "not ok 1\n"; } } else { warn "Skipping all tests: ${cut_mess}${tls_mess}"; print "ok 1\n"; } Math-MPFR-4.38/t/trig.t0000755060175106010010000001166114765756127013311 0ustar OwnerNoneuse strict; use warnings; use Math::MPFR qw(:mpfr); use Math::Trig; # for checking results print "1..17\n"; print "# Using Math::MPFR version ", $Math::MPFR::VERSION, "\n"; print "# Using mpfr library version ", MPFR_VERSION_STRING, "\n"; print "# Using gmp library version ", Math::MPFR::gmp_v(), "\n"; Rmpfr_set_default_prec(100); my $angle = 2.2314; #13.2314; my $inv = 0.5123; my $angle2 = $angle * $inv; my $hangle = 0.1234; my $invatanh = 0.991; my $hinv = 1.4357; my $sin = Rmpfr_init(); my $cos = Rmpfr_init(); my $tan = Rmpfr_init(); my $asin = Rmpfr_init(); my $acos = Rmpfr_init(); my $atan = Rmpfr_init(); my $atan2 = Rmpfr_init(); my $sinh = Rmpfr_init(); my $cosh = Rmpfr_init(); my $tanh = Rmpfr_init(); my $asinh = Rmpfr_init(); my $acosh = Rmpfr_init(); my $atanh = Rmpfr_init(); my $b_angle = Rmpfr_init(); my $b_angle2 = Rmpfr_init(); my $b_inv = Rmpfr_init(); my $b_hangle = Rmpfr_init(); my $b_invatanh = Rmpfr_init(); my $b_hinv = Rmpfr_init(); my $rop = Rmpfr_init(); Rmpfr_set_d($b_angle, $angle, GMP_RNDN); Rmpfr_set_d($b_angle2, $angle2, GMP_RNDN); Rmpfr_set_d($b_inv, $inv, GMP_RNDN); Rmpfr_set_d($b_invatanh, $invatanh, GMP_RNDN); Rmpfr_set_d($b_hinv, $hinv, GMP_RNDN); Rmpfr_set_d($b_hangle, $hangle, GMP_RNDN); Rmpfr_sin($sin, $b_angle, GMP_RNDN); if($sin - sin($angle) < 0.00001 && $sin - sin($angle) > -0.00001) {print "ok 1\n"} else {print "not ok 1\n"} Rmpfr_cos($cos, $b_angle, GMP_RNDN); if($cos - cos($angle) < 0.00001 && $cos - cos($angle) > -0.00001) {print "ok 2\n"} else {print "not ok 2\n"} Rmpfr_tan($tan, $b_angle, GMP_RNDN); if($tan - tan($angle) < 0.00001 && $tan - tan($angle) > -0.00001) {print "ok 3\n"} else {print "not ok 3\n"} Rmpfr_asin($asin, $b_inv, GMP_RNDN); if($asin - asin($inv) < 0.00001 && $asin - asin($inv) > -0.00001) {print "ok 4\n"} else {print "not ok 4\n"} Rmpfr_acos($acos, $b_inv, GMP_RNDN); if($acos - acos($inv) < 0.00001 && $acos - acos($inv) > -0.00001) {print "ok 5\n"} else {print "not ok 5\n"} Rmpfr_atan($atan, $b_inv, GMP_RNDN); if($atan - atan($inv) < 0.00001 && $atan - atan($inv) > -0.00001) {print "ok 6\n"} else {print "not ok 6\n"} Rmpfr_sinh($sinh, $b_hangle, GMP_RNDN); if($sinh - sinh($hangle) < 0.00001 && $sinh - sinh($hangle) > -0.00001) {print "ok 7\n"} else {print "not ok 7\n"} Rmpfr_cosh($cosh, $b_hangle, GMP_RNDN); if($cosh - cosh($hangle) < 0.00001 && $cosh - cosh($hangle) > -0.00001) {print "ok 8\n"} else {print "not ok 8\n"} Rmpfr_tanh($tanh, $b_hangle, GMP_RNDN); if($tanh - tanh($hangle) < 0.00001 && $tanh - tanh($hangle) > -0.00001) {print "ok 9\n"} else {print "not ok 9\n"} Rmpfr_asinh($asinh, $b_hinv, GMP_RNDN); if($asinh - asinh($hinv) < 0.00001 && $asinh - asinh($hinv) > -0.00001) {print "ok 10\n"} else {print "not ok 10\n"} Rmpfr_acosh($acosh, $b_hinv, GMP_RNDN); if($acosh - acosh($hinv) < 0.00001 && $acosh - acosh($hinv) > -0.00001) {print "ok 11\n"} else {print "not ok 11\n"} Rmpfr_atanh($atanh, $b_invatanh, GMP_RNDN); if($atanh - atanh($invatanh) < 0.00001 && $atanh - atanh($invatanh) > -0.00001) {print "ok 12\n"} else {print "not ok 12\n"} Rmpfr_sin_cos($sin, $cos, $b_angle, GMP_RNDN); if($sin - sin($angle) < 0.00001 && $sin - sin($angle) > -0.00001 && $cos - cos($angle) < 0.00001 && $cos - cos($angle) > -0.00001) {print "ok 13\n"} else {print "not ok 13\n"} Rmpfr_atan2($atan2,$b_angle2, $b_angle, GMP_RNDN); if($atan2 - atan2($angle2, $angle) < 0.00000001 && $atan2 - atan2($angle2, $angle) > -0.00000001) {print "ok 14\n"} else {print "not ok 14 $atan2 ", atan2($angle2, $angle),"\n"} $angle *= -1; $b_angle *= -1; Rmpfr_atan2($atan2,$b_angle2, $b_angle, GMP_RNDN); if($atan2 - atan2($angle2, $angle) < 0.00000001 && $atan2 - atan2($angle2, $angle) > -0.00000001) {print "ok 15\n"} else {print "not ok 15 $atan2 ", atan2($angle2, $angle),"\n"} # Return $angle and $b_angle to their original values: $angle *= -1; $b_angle *= -1; my $ok = ''; Rmpfr_sec($rop, $b_angle, GMP_RNDN); if($rop - sec($angle) < 0.000000001 && $rop - sec($angle) > -0.000000001) {$ok .= 'a'} Rmpfr_csc($rop, $b_angle, GMP_RNDN); if($rop - csc($angle) < 0.000000001 && $rop - csc($angle) > -0.000000001) {$ok .= 'b'} Rmpfr_cot($rop, $b_angle, GMP_RNDN); if($rop - cot($angle) < 0.000000001 && $rop - cot($angle) > -0.000000001) {$ok .= 'c'} Rmpfr_sech($rop, $b_angle, GMP_RNDN); if($rop - sech($angle) < 0.000000001 && $rop - sech($angle) > -0.000000001) {$ok .= 'd'} Rmpfr_csch($rop, $b_angle, GMP_RNDN); if($rop - csch($angle) < 0.000000001 && $rop - csch($angle) > -0.000000001) {$ok .= 'e'} Rmpfr_coth($rop, $b_angle, GMP_RNDN); if($rop - coth($angle) < 0.000000001 && $rop - coth($angle) > -0.000000001) {$ok .= 'f'} if($ok eq 'abcdef') {print "ok 16\n"} else {print "not ok 16 $ok\n"} $ok = ''; Rmpfr_sinh_cosh($sinh, $cosh, $b_hinv, GMP_RNDN); if($sinh > 1.982318 && $sinh < 1.982319) {$ok .= 'a'} if($cosh > 2.22026726 && $cosh < 2.22026727) {$ok .= 'b'} if($ok eq 'ab') {print "ok 17\n"} else {print "not ok 17 $ok\n"} Math-MPFR-4.38/t/trigamma.t0000755060175106010010000000126514765756127014144 0ustar OwnerNone# Test script for: # mpfr_trigamma - new in 4.3.0 (version 262912) use strict; use warnings; use Math::MPFR qw(:mpfr); use Test::More; my ($inex, $x, $y) = ('hello', Math::MPFR->new(), Math::MPFR->new()); Rmpfr_set_inf($y, -1); Rmpfr_set_inf($x, 1); eval { $inex = Rmpfr_trigamma($y, $x, MPFR_RNDN);}; if(MPFR_VERSION >= 262912) { cmp_ok($inex , '==', 0, "result of trigamma(+Inf) is exact"); cmp_ok(Rmpfr_zero_p($y) , '!=', 0, "trigamma(+Inf) set to zero"); cmp_ok(Rmpfr_signbit($y), '==', 0, "trigamma(+Inf) signbit is unset"); } else { like($@, qr/^Rmpfr_trigamma function not implemented until mpfr\-4\.3\.0/, "trigamma() croaks as expected"); } done_testing(); Math-MPFR-4.38/t/TRmpfr_out_str.t0000755060175106010010000001455114765756127015336 0ustar OwnerNoneuse strict; use warnings; use Math::MPFR qw(:mpfr); my $tests = 8; # Because of the way I (sisyphus) build this module with MS # Visual Studio, XSubs that take a filehandle as an argument # may not work. It therefore suits my purposes to be able to # avoid calling (and testing) those particular XSubs $tests = 1 if $ENV{SISYPHUS_SKIP}; print "1..$tests\n"; if($tests == 1) { warn "\nskipping all tests - \$ENV{SISYPHUS_SKIP} is set\n"; print "ok 1\n"; exit 0; } print "# Using Math::MPFR version ", $Math::MPFR::VERSION, "\n"; print "# Using mpfr library version ", MPFR_VERSION_STRING, "\n"; print "# Using gmp library version ", Math::MPFR::gmp_v(), "\n"; Rmpfr_set_default_prec(64); my($WR1, $WR2, $WR3, $WR4, $WR5, $WR6, $WR7, $WR8); my($RD1, $RD2, $RD3, $RD4, $RD5, $RD6, $RD7, $RD8); my($ret, $ok, $mpfr, $count, $prefix, $suffix); $mpfr = Math::MPFR->new(17); open($WR1, '>', 'out1.txt') or die "Can't open WR1: $!"; open($WR2, '>', 'out2.txt') or die "Can't open WR2: $!"; open($WR3, '>', 'out3.txt') or die "Can't open WR3: $!"; open($WR4, '>', 'out4.txt') or die "Can't open WR4: $!"; open($WR5, '>', 'out5.txt') or die "Can't open WR5: $!"; open($WR6, '>', 'out6.txt') or die "Can't open WR6: $!"; open($WR7, '>', 'out7.txt') or die "Can't open WR7: $!"; $prefix = "This is the prefix "; $suffix = " and this is the suffix\n"; # No prefix, no suffix - the five numbers will all be # strung together on the one line. for(1..5) { $ret = TRmpfr_out_str(\*$WR1, 10, 0, $mpfr, GMP_RNDN); print $WR7 "From the first loop\n"; } # Prefix, but no suffix - again, the output will be # strung together on the one line. for(1..5) { $ret = TRmpfr_out_str($prefix, \*$WR2, 10, 0, $mpfr, GMP_RNDN); print $WR7 "From the second loop"; } # Suffix, but no prefix - this file will contain 5 lines. for(1..5) { $ret = TRmpfr_out_str(\*$WR3, 10, 0, $mpfr, GMP_RNDN, $suffix); print $WR7 "\nFrom the third loop"; } print $WR7 "\n"; # Both prefix and suffix - this file will contain 5 lines. for(1..5) { $ret = TRmpfr_out_str($prefix, \*$WR4, 10, 0, $mpfr, GMP_RNDN, $suffix); print $WR7 "From the fourth loop\n"; } $prefix .= "\n"; # Prefix, but no suffix - this file will contain 6 lines. for(1..5) { $ret = TRmpfr_out_str($prefix, \*$WR5, 10, 0, $mpfr, GMP_RNDN); print $WR7 "From the fifth loop"; } # Both prefix and suffix - this file will contain 10 lines - # the prefix appearing on one line, the number and the suffix # appearing on the next. for(1..5) { $ret = TRmpfr_out_str($prefix, \*$WR6, 10, 0, $mpfr, GMP_RNDN, $suffix); print $WR7 "From the sixth loop"; } close $WR1 or die "Can't close WR1: $!"; close $WR2 or die "Can't close WR2: $!"; close $WR3 or die "Can't close WR3: $!"; close $WR4 or die "Can't close WR4: $!"; close $WR5 or die "Can't close WR5: $!"; close $WR6 or die "Can't close WR6: $!"; close $WR7 or die "Can't close WR7: $!"; open($RD1, '<', 'out1.txt') or die "Can't open RD1: $!"; open($RD2, '<', 'out2.txt') or die "Can't open RD2: $!"; open($RD3, '<', 'out3.txt') or die "Can't open RD3: $!"; open($RD4, '<', 'out4.txt') or die "Can't open RD4: $!"; open($RD5, '<', 'out5.txt') or die "Can't open RD5: $!"; open($RD6, '<', 'out6.txt') or die "Can't open RD6: $!"; open($RD7, '<', 'out7.txt') or die "Can't open RD7: $!"; $ok = 1; $count = 0; while(<$RD1>) { $count = $.; chomp; unless($_ eq '1.70000000000000000000e1'x5) {$ok = 0} } if($ok && $count == 1) {print "ok 1\n"} else { warn "\n\$ok: $ok\n\$count: $count\n"; print "not ok 1\n"; } $ok = 1; $count = 0; while(<$RD2>) { $count = $.; chomp; unless($_ eq 'This is the prefix 1.70000000000000000000e1'x5) {$ok = 0} } if($ok && $count == 1) {print "ok 2\n"} else { warn "\n\$ok: $ok\n\$count: $count\n"; print "not ok 2\n"; } $ok = 1; $count = 0; while(<$RD3>) { $count = $.; chomp; unless($_ eq '1.70000000000000000000e1 and this is the suffix') {$ok = 0} } if($ok && $count == 5) {print "ok 3\n"} else { warn "\n\$ok: $ok\n\$count: $count\n"; print "not ok 3\n"; } $ok = 1; $count = 0; while(<$RD4>) { $count = $.; chomp; unless($_ eq 'This is the prefix 1.70000000000000000000e1 and this is the suffix') {$ok = 0} } if($ok && $count == 5) {print "ok 4\n"} else { warn "\n\$ok: $ok\n\$count: $count\n"; print "not ok 4\n"; } $ok = 1; $count = 0; while(<$RD5>) { $count = $.; chomp; if($. == 1) { unless($_ eq 'This is the prefix ') {$ok = 0} } elsif($. == 6) { unless($_ eq '1.70000000000000000000e1') {$ok = 0} } else { unless($_ eq '1.70000000000000000000e1This is the prefix ') {$ok = 0} } } if($ok && $count == 6) {print "ok 5\n"} else { warn "\n\$ok: $ok\n\$count: $count\n"; print "not ok 5\n"; } $ok = 1; $count = 0; while(<$RD6>) { $count = $.; chomp; if($. & 1) { unless($_ eq 'This is the prefix ') {$ok = 0} } else { unless($_ eq '1.70000000000000000000e1 and this is the suffix') {$ok = 0} } } if($ok && $count == 10) {print "ok 6\n"} else { warn "\n\$ok: $ok\n\$count: $count\n"; print "not ok 6\n"; } $ok = 1; $count = 0; while(<$RD7>) { $count = $.; chomp; if($. <= 5 && $. >= 1) { unless($_ eq 'From the first loop') {$ok = 0} } if($. == 6) { unless($_ eq 'From the second loop' x 5) {$ok = 0} } if($. <= 11 && $. >= 7) { unless($_ eq 'From the third loop') {$ok = 0} } if($. <= 16 && $. >= 12) { unless($_ eq 'From the fourth loop') {$ok = 0} } if($. == 17) { unless($_ eq 'From the fifth loop' x 5 . 'From the sixth loop' x 5) {$ok = 0} } } if($ok && $count == 17) {print "ok 7\n"} else { warn "\n\$ok: $ok\n\$count: $count\n"; print "not ok 7\n"; } close $RD1 or die "Can't close RD1: $!"; close $RD2 or die "Can't close RD2: $!"; close $RD3 or die "Can't close RD3: $!"; close $RD4 or die "Can't close RD4: $!"; close $RD5 or die "Can't close RD5: $!"; close $RD6 or die "Can't close RD6: $!"; close $RD7 or die "Can't close RD7: $!"; open($WR8, '>', 'out1.txt') or die "Can't open WR8: $!"; print $WR8 "1.5e2\n"; close $WR8 or die "Can't close WR8: $!"; open($RD8, '<', 'out1.txt') or die "Can't open RD8: $!"; $ret = TRmpfr_inp_str($mpfr, \*$RD8, 10, GMP_RNDN); close $RD8 or die "Can't close RD8: $!"; if($ret == 5 && $mpfr == 150) {print "ok 8\n"} else { warn "\n\$ok: $ok\n\$count: $count\n"; print "not ok 8\n"; } Math-MPFR-4.38/t/underflow.t0000755060175106010010000000101714765756127014343 0ustar OwnerNoneuse strict; use warnings; use Math::MPFR qw(:mpfr); print "1..2\n"; my $x = Math::MPFR->new('0.1@'. Rmpfr_get_emin(), 2); if($x != 0 && Rmpfr_underflow_p() == 0) { print "ok 1\n" } else { warn "\$x: $x\nmpfr_underflow_p(): ", Rmpfr_underflow_p(), "\n"; print "not ok 1\n"; } Rmpfr_clear_underflow(); my $y = Math::MPFR->new('0.1@'. (Rmpfr_get_emin() - 1), 2); if($y == 0 && Rmpfr_underflow_p() != 0) { print "ok 2\n" } else { warn "\$y: $y\nmpfr_underflow_p(): ", Rmpfr_underflow_p(), "\n"; print "not ok 1\n"; } Math-MPFR-4.38/t/use64bitint.t0000755060175106010010000002011414765756127014515 0ustar OwnerNone# Contrary to its name, this script is concerned not so much with 64-bit IV/UV, # more with IV/UV being a'long long int' (or not). use warnings; use strict; use Math::MPFR qw(:mpfr); use Config; print "1..7\n"; print "# Using Math::MPFR version ", $Math::MPFR::VERSION, "\n"; print "# Using mpfr library version ", MPFR_VERSION_STRING, "\n"; print "# Using gmp library version ", Math::MPFR::gmp_v(), "\n"; my $_64 = Math::MPFR::_has_longlong(); if($_64){warn "long long int support detected\n"} else {warn "long long int support is absent\n"} Rmpfr_set_default_prec(300); my $ok = ''; if($_64) { use integer; my $pp1; my $int1 = Math::MPFR->new(2 ** 57 + 12345); $int1 *= -1; if($int1 == -144115188075868217 && $int1 == "-144115188075868217" ) {$ok = 'a'} # if($Config::Config{cc} eq 'cl') { # $pp1 = Rmpfr_integer_string($int1, 10, GMP_RNDN); # } # else {$pp1 = Rmpfr_get_sj($int1, GMP_RNDN)} $pp1 = Rmpfr_get_sj($int1, GMP_RNDN); if($pp1 == -144115188075868217) {$ok .= 'b'} $pp1 += 14; my $int2 = Rmpfr_init(); # if($Config::Config{cc} eq 'cl') { # Rmpfr_set_str($int2, $pp1, 10, GMP_RNDN); # } # else {Rmpfr_set_sj($int2, $pp1, GMP_RNDN)} Rmpfr_set_sj($int2, $pp1, GMP_RNDN); if($int2 == $pp1 && $int2 - $int1 - 14 == 0 && !($int2 - $int1 - 14) ) {$ok .= 'c'} # if($Config::Config{cc} eq 'cl') { # eval{Rmpfr_set_sj_2exp($int2, $pp1, 2, GMP_RNDN);}; # if($@ =~ /not implemented on this build of perl/ && $@ !~ /\- use/) {$ok .= 'd'} # else {print $@, "\n"} eval{Rmpfr_set_uj_2exp($int2, $pp1, 2, GMP_RNDN);}; # if($@ =~ /not implemented on this build of perl/ && $@ !~ /\- use/) {$ok .= 'e'} # else {print $@, "\n"} # } # else { Rmpfr_set_sj_2exp($int2, $pp1, 2, GMP_RNDN); if($int2 == $pp1 * 4) {$ok .= 'de'} # } if($ok eq 'abcde') {print "ok 1\n"} else { warn "\$ok: $ok\n"; print "not ok 1 $ok\n"; } } $ok = ''; if($_64) { my $int3 = Rmpfr_init(); my $pp2 = 2 ** 57 + 12345; $pp2 *= -1; if(Math::MPFR::_itsa($pp2) == 2) {$ok = 'AB'} else { # if($Config::Config{cc} eq 'cl') {$ok = 'ab'} # Skip # else { Rmpfr_set_sj($int3, ~0, GMP_RNDN); if($int3 == -1) {$ok = 'a'} Rmpfr_set_sj_2exp($int3, ~0, 2, GMP_RNDN); if($int3 == -4) {$ok .= 'b'} # } } if(lc($ok) eq 'ab') {print "ok 2\n"} else {print "not ok 2 $ok\n"} } $ok = ''; if($_64) { my ($int, $discard) = Rmpfr_init_set_ui(2, GMP_RNDN); my $pint = -144115188075868217; if(Math::MPFR::_itsa($pint) == 2) {$ok .= 'a'} $int *= $pint; if($int == -288230376151736434 && $int <= -288230376151736434 && $int >= -288230376151736434 && ($int <=> -288230376151736434) == 0 && ($int <=> -288230376151736435) == 1 && $int != -288230376151736435 ) {$ok .= 'b'} $int += $pint; if($int == -432345564227604651 && ($int <=> -432345564227604651) == 0 && ($int <=> -432345564227604649) == -1 && $int != -432345564227604653 ) {$ok .= 'c'} $int -= $pint; if($int == -288230376151736434 && $int == "-288230376151736434" && ($int <=> -288230376151736434) == 0 && ($int <=> -288230376151736435) == 1 && $int != -288230376151736435 ) {$ok .= 'd'} $int += 12345; $int /= $pint; # $int is no longer an integer value if($int < 2 && $int > 1.99 && $int > "1.99" && $int <= 2 && $int >= 1.99 && ($int <=> 1.99) == 1 && ($int <=> 2) == -1 ) {$ok .= 'e'} ##################################### $int = 2; my $temp = Math::MPFR->new(); $temp = $int * $pint; if(!($] < 5.007 && !Math::MPFR::_has_longdouble() && Math::MPFR::_has_longlong())) { if($temp == -288230376151736434 && $temp != -288230376151736435 ) {$ok .= 'f'} $temp = $temp + $pint; if($temp == -432345564227604651 && $temp != -432345564227604653 ) {$ok .= 'g'} $temp = $temp - $pint; if($temp == -288230376151736434 && $temp != -288230376151736435 ) {$ok .= 'h'} } else { warn "Skipping tests 3f to 3h as they fail on perl 5.6\nbuilt with -Duse64bitint but without -Duselongdouble\n"; $ok .= 'fgh'; } ##################################### $temp = $temp + 12345; $temp = $temp / $pint; # $temp no longer an integer value if($temp < 2 && $temp > 1.99 && $temp <= 2 && $temp <= "2" && $temp >+ 1.99 ) {$ok .= 'i'} $pint *= -1; $temp = atan2(99999, $pint); if($temp > 6.938824e-13 && $temp < 6.938825e-13 && $temp >= 6.938824e-13 && $temp <= 6.938825e-13 && ($temp <=> 6.938825e-13) == -1 && ($temp <=> 6.938824e-13) == 1 ) {$ok .= 'j'} if($int) {$ok .= 'k'} $int *= 0; if(!$int) {$ok.= 'l'} my $temp2 = Math::MPFR->new($pint); my $pint2; if($Config::Config{cc} eq 'cl') { $pint2 = Rmpfr_integer_string($temp2, 10, GMP_RNDN); } else {$pint2 = Rmpfr_get_sj($temp2, GMP_RNDN)} if(!($] < 5.007 && !Math::MPFR::_has_longdouble() && Math::MPFR::_has_longlong())) { if($pint2 == $pint && $pint2 < $pint + 1 && $pint2 > $pint - 1 ) {$ok .= 'm'} } else { warn "Skipping test 3m as it fails on perl 5.6\nbuilt with -Duse64bitint but without -Duselongdouble\n"; $ok .= 'm'; } my $temp3 = new Math::MPFR($pint); if($temp3 == $temp2) {$ok .= 'n'} if($ok eq 'abcdefghijklmn') {print "ok 3\n"} else {print "not ok 3 $ok\n"} } $ok = ''; if($_64) { warn "Skipping test 4 - original test is no longer relevant"; print "ok 4\n"; } $ok = ''; if(!$_64) { my $int1 = Math::MPFR->new(); Rmpfr_set_uj_2exp($int1, 2 ** 23, 2, GMP_RNDN); if($int1 == 33554432) {$ok .= 'a'} Rmpfr_set_sj_2exp($int1, 2 ** 23, 2, GMP_RNDN); if($int1 == 33554432) {$ok .= 'b'} if($ok eq 'ab') {print "ok 1\n"} else { warn "\$ok: $ok\n"; print "not ok 1 $ok\n"; } $ok = ''; # Rmpfr_get_sj and Rmpfr_get_uj are still not ipmlemented # for these perls as they are unable to recieve such values. eval{Rmpfr_get_sj($int1, GMP_RNDN);}; if($@ =~ /not implemented on this build of perl/i && $@ !~ /\- use/) {$ok .= 'a'} else {warn $@, "\n"} eval{Rmpfr_get_uj($int1, GMP_RNDN);}; if($@ =~ /not implemented on this build of perl/i && $@ !~ /\- use/) {$ok .= 'b'} else {warn $@, "\n"} if($ok eq 'ab') {print "ok 2\n"} else {print "not ok 2 $ok\n"} $ok = ''; Rmpfr_set_sj($int1, 42, GMP_RNDN); if($int1 == 42) {$ok .= 'a'} Rmpfr_set_uj($int1, 43, GMP_RNDN); if($int1 == 43) {$ok .= 'b'} if($ok eq 'ab') {print "ok 3\n"} else {print "not ok 3 $ok\n"} warn "Skipping test 4 - nothing to test\n"; print "ok 4\n"; } my $bits = $Config{ivsize} * 8; my ($uhigh, $uhigh1, $uhigh2); { use integer; my $temp = (2 ** ($bits - 2)) - 1; $uhigh = (2 * $temp) + 1; #$uhigh = (2 ** $bits) - 1; } $uhigh = (2 * $uhigh) + 1; #Dump($uhigh); $uhigh1 = Math::MPFR->new($uhigh); $uhigh2 = Rmpfr_init(); if(Math::MPFR::_has_longlong()) { Rmpfr_set_uj($uhigh2, $uhigh, GMP_RNDN); } else { Rmpfr_set_ui($uhigh2, $uhigh, GMP_RNDN); } if($] < 5.007 && !Math::MPFR::_has_longdouble() && Math::MPFR::_has_longlong()) { warn "Skipping tests 5 and 6 as they fail on perl 5.6\nbuilt with -Duse64bitint but without -Duselongdouble\n"; print "ok 5\n"; print "ok 6\n"; } else { if(!Rmpfr_cmp($uhigh1, $uhigh2)) {print "ok 5\n"} else { warn "\n\$uhigh1: $uhigh1\n\$uhigh2: $uhigh2\n"; print "not ok 5\n"; } if(Math::MPFR::_has_longlong()) { # No mpfr_cmp_uj() yet available if(!Rmpfr_cmp($uhigh1, Math::MPFR->new($uhigh))) {print "ok 6\n"} else { warn "\n\$uhigh1: $uhigh1\n\$uhigh: ", Math::MPFR->new($uhigh), "\n"; print "not ok 6\n"; } } else { if(!Rmpfr_cmp_ui($uhigh1, $uhigh)) {print "ok 6\n"} else { warn "\n\$uhigh1: $uhigh1\n\$uhigh: $uhigh\n"; print "not ok 6\n"; } } } if(Math::MPFR::_has_longlong()) { # No mpfr_cmp_uj() yet available if(!Rmpfr_cmp($uhigh2, Math::MPFR->new($uhigh))) {print "ok 7\n"} else { warn "\n\$uhigh2: $uhigh2\n\$uhigh: $uhigh\n"; print "not ok 7\n"; } } else { if(!Rmpfr_cmp_ui($uhigh2, $uhigh)) {print "ok 7\n"} else { warn "\n\$uhigh2: $uhigh2\n\$uhigh: $uhigh\n"; print "not ok 7\n"; } } Math-MPFR-4.38/t/uselongdouble.t0000755060175106010010000002164114765756127015212 0ustar OwnerNoneuse strict; use warnings; use Math::MPFR qw(:mpfr); use Config; print "1..10\n"; print "# Using Math::MPFR version ", $Math::MPFR::VERSION, "\n"; print "# Using mpfr library version ", MPFR_VERSION_STRING, "\n"; print "# Using gmp library version ", Math::MPFR::gmp_v(), "\n"; if(Math::MPFR::_has_longdouble()) {print "Using long double\n"} else {print "Not using long double\n"} Rmpfr_set_default_prec(300); if(Math::MPFR::_has_longdouble()) { my $ok = ''; my $n = (2 ** 55) + 0.5; my $ld1 = Math::MPFR->new($n); my $ld2 = Math::MPFR::new($n); my $ld3 = Math::MPFR->new(); Rmpfr_set_ld($ld3, $n, GMP_RNDN); if( $ld1 == $ld2 && $ld2 == $ld3 && $ld2 <= $n && $ld2 >= $n && $ld2 < $n + 1 && $ld2 > $n - 1 && ($ld2 <=> $n) == 0 && ($ld2 <=> $n - 1) > 0 && ($ld2 <=> $n + 1) < 0 && $ld2 != $n - 1 ) {$ok .= 'a'} my $d2 = Rmpfr_get_ld($ld1, GMP_RNDN); if($d2 == $n) {$ok .= 'b'} if(!Rmpfr_cmp_ld($ld1, $n)) {$ok .= 'c'} if($ok eq 'abc') {print "ok 1\n"} else {print "not ok 1 $ok\n"} $ok = ''; # Check the overloaded operators. if($ld1 - 1 == $n - 1) {$ok .= 'a'} $ld1 -= 1; if($ld1 == $n - 1) {$ok .= 'b'} $ld1 = $ld1 / 2; if($ld1 == ($n - 1) / 2) {$ok .= 'c'} $ld1 = $ld1 * 2; if($ld1 == $n - 1) {$ok .= 'd'} $ld1 /= 2; if($ld1 == ($n - 1) / 2) {$ok .= 'e'} $ld1 *= 2; if($ld1 == $n - 1) {$ok .= 'f'} if($ld1 + 1 == $n) {$ok .= 'g'} $ld1 += 1; if($ld1 == $n) {$ok .= 'h'} if($ld1 ** 0.5 < 189812531.25 && $ld1 ** 0.5 > 189812531.24) {$ok .= 'i'} $ld1 **= 0.5; if($ld1 < 189812531.25 && $ld1 > 189812531.24) {$ok .= 'j'} if($ok eq 'abcdefghij') {print "ok 2\n"} else {print "not ok 2 $ok\n"} my $bits = $Config::Config{longdblsize} > $Config::Config{doublesize} ? $Config::Config{doublesize} * 7 : 50; $n = (2 ** $bits) + 0.5; my $ld4 = Math::MPFR->new($n); if($ld4 == int($ld4)) { print "not ok 3 precision has been lost: $ld4\n"} else {print "ok 3\n"} } else { my $ok = ''; my $int1 = Rmpfr_init(); eval{Rmpfr_set_ld($int1, 2 ** 23, GMP_RNDN);}; if($@ =~ /not implemented on this build of perl/i) {$ok = 'a'} eval{Rmpfr_cmp_ld($int1, 2 ** 23);}; if($@ =~ /not implemented on this build of perl/i) {$ok .= 'b'} eval{Rmpfr_get_ld($int1, GMP_RNDN);}; if($@ =~ /not implemented on this build of perl/i) {$ok .= 'c'} eval{my($int2, $ret) = Rmpfr_init_set_ld(2 ** 23, GMP_RNDN);}; if($@ =~ /not implemented on this build of perl/i) {$ok .= 'd'} if($ok eq 'abcd') {print "ok 1\n"} else {print "not ok 1 $ok\n"} warn "Skipping test 2 - nothing to test\n"; print "ok 2\n"; warn "Skipping test 3 - nothing to test\n"; print "ok 3\n"; } if(Math::MPFR::_has_longdouble()) { my $mpfr = Math::MPFR->new('1' x 62, 2); my $mpfr2 = Rmpfr_init(); my $ok = ''; if ($mpfr < 4611686018427387904 && $mpfr > 4611686018427387902) {$ok .= 'a'} if ($mpfr <= 4611686018427387904 && $mpfr >= 4611686018427387902) {$ok .= 'b'} if ($mpfr == 4611686018427387903) {$ok .= 'c'} if ($mpfr <= 4611686018427387903) {$ok .= 'd'} if ($mpfr >= 4611686018427387903) {$ok .= 'e'} my $ld = Rmpfr_get_ld($mpfr, GMP_RNDN); if ($ld < 4611686018427387904 && $ld > 4611686018427387902) {$ok .= 'f'} if ($ld == 4611686018427387903) {$ok .= 'g'} my $cmp = $mpfr <=> 4611686018427387902; if($cmp > 0) {$ok .= 'h'} $cmp = $mpfr <=> 4611686018427387903; if($cmp == 0) {$ok .= 'i'} $cmp = $mpfr <=> 4611686018427387904; if($cmp < 0) {$ok .= 'j'} $cmp = 4611686018427387902 <=> $mpfr; if($cmp < 0) {$ok .= 'k'} $cmp = 4611686018427387903 <=> $mpfr; if($cmp == 0) {$ok .= 'l'} $cmp = 4611686018427387904 <=> $mpfr; if($cmp > 0) {$ok .= 'm'} Rmpfr_set_ld($mpfr2, 4611686018427387903, GMP_RNDN); if($mpfr2 == $mpfr) {$ok .= 'n'} if($ok eq 'abcdefghijklmn') {print "ok 4\n"} else {print "not ok 4 $ok\n"} } else { warn "Skipping test 4 - no long double support\n"; print "ok 4\n"; } my $num1 = Math::MPFR->new(100); my $exp = \$num1; if(Math::MPFR::_has_longdouble()) { my $double = Rmpfr_get_ld_2exp($exp, $num1, GMP_RNDN); if($double > 0.781249 && $double < 0.781251 && $exp == 7) {print "ok 5\n"} else { warn "\n Got (double): $double\n Expected: 0.78125\n\n", " Got (exp): $exp\n Expected: 7\n"; print "not ok 5\n"; } } else { eval{my $double = Rmpfr_get_ld_2exp($exp, $num1, GMP_RNDN);}; if($@ =~ /Rmpfr_get_ld_2exp not implemented/) {print "ok 5\n"} else { warn "\n\$\@: $@\n"; print "not ok 5\n"; } } if(Math::MPFR::_has_longdouble()) { my $double = (2 ** 55) + 0.5; if($double == Rmpfr_get_NV(Math::MPFR->new($double), GMP_RNDN)) {print "ok 6\n"} else { warn "\nGot: ", Rmpfr_get_NV(Math::MPFR->new($double), GMP_RNDN) , "\nExpected: $double\n"; print "not ok 43\n"; } } else { warn "Skipping test 6 - no long double support\n"; print "ok 6\n"; } if(Math::MPFR::_has_longdouble()) { my $nan = Math::MPFR->new(); my $posinf = Math::MPFR->new('inf'); my $neginf = Math::MPFR->new('-inf'); my $ok = ''; if($posinf == - $neginf) {$ok .= 'a'} else {warn "a: $posinf ", $neginf * -1, "\n"} my $double = Rmpfr_get_ld($nan, GMP_RNDN); Rmpfr_set_ld($nan, $double, GMP_RNDN); if(Rmpfr_nan_p($nan)) {$ok .= 'b'} else {warn "b: $nan\n"} $double = Rmpfr_get_ld($posinf, GMP_RNDN); Rmpfr_set_ld($posinf, $double, GMP_RNDN); if(Rmpfr_inf_p($posinf) && $posinf > 0) {$ok .= 'c'} else {warn "c: $posinf\n"} $double = Rmpfr_get_ld($neginf, GMP_RNDN); Rmpfr_set_ld($neginf, $double, GMP_RNDN); if(Rmpfr_inf_p($neginf) && $neginf < 0) {$ok .= 'd'} else {warn "d: $neginf\n"} $double = Rmpfr_get_NV($nan, GMP_RNDN); Rmpfr_set_ld($nan, $double, GMP_RNDN); if(Rmpfr_nan_p($nan)) {$ok .= 'e'} else {warn "e: $nan\n"} $double = Rmpfr_get_NV($posinf, GMP_RNDN); Rmpfr_set_ld($posinf, $double, GMP_RNDN); if(Rmpfr_inf_p($posinf) && $posinf > 0) {$ok .= 'f'} else {warn "f: $posinf\n"} $double = Rmpfr_get_NV($neginf, GMP_RNDN); Rmpfr_set_ld($neginf, $double, GMP_RNDN); if(Rmpfr_inf_p($neginf) && $neginf < 0) {$ok .= 'g'} else {warn "g: $neginf\n"} if($ok eq 'abcdefg') {print "ok 7\n"} else {print "not ok 7 $ok\n"} } else { warn "Skipping test 7 - no long double support\n"; print "ok 7\n"; } if(Math::MPFR::_has_longdouble()) { # Check that the mpfr_get_ld() bug has been fixed (mpfr-2.4.2 and later only) if(MPFR_VERSION > 132097) { my $prec = Rmpfr_get_default_prec(); Rmpfr_set_default_prec(64); my $bugtest = Math::MPFR->new(-12345); Rmpfr_exp($bugtest, $bugtest, GMP_RNDN); my $ld = Rmpfr_get_ld($bugtest, GMP_RNDN); Rmpfr_set_default_prec($prec); if($ld < 0.000000001 && $ld >= 0){print "ok 8\n"} else { warn "Got: $ld\n"; print "not ok 8\n"; } } else { warn "Skipping test 8 - mpfr_get_ld bug with mpfr-2.4.1 and earlier will cause the test to fail\n"; print "ok 8\n"; } } else { warn "Skipping test 8 - no long double support\n"; print "ok 8\n"; } # Test for a bug that affects Double-Double type only. if(Math::MPFR::_has_longdouble()) { my $prob1 = Rmpfr_init2(2097); my $prob2 = Rmpfr_init2(2098); my $p_val = (2 ** 1023) + (2 ** -1074); my $res = $p_val > 2 ** 1023 ? 1 : 0; my $res1 = Rmpfr_set_ld($prob1, $p_val, MPFR_RNDN); my $res2 = Rmpfr_set_ld($prob2, $p_val, MPFR_RNDN); if($res) { # double-double if($res1 == -1 && $res2 == 0) { print "ok 9\n"; } else { warn "\nDouble-Double type: \$res1: $res1 \$res2: $res2\n"; print "not ok 9\n"; } } else { if(!$res1 && !$res2) { print "ok 9\n"; } else { warn "\nNOT Double-Double type: \$res1: $res1 \$res2: $res2\n"; print "not ok 9\n"; } } } else { warn "Skipping test 9 - no long double support\n"; print "ok 9\n"; } my $nv; # mpfr_get_ld is buggy for 64-bit subnormals on mpfr 3.1.4 (19868) and earlier # Since we don't have 64-bit floats on double-double architectures, we can skip # this test if LDBL_DIG == 31. if(Math::MPFR::_LDBL_DIG() == 31) { warn "\n Skipping test 10 for double-double nvtype\n"; print "ok 10\n"; } else { eval{$nv = Rmpfr_get_ld(Math::MPFR->new("2e-4950"), MPFR_RNDN);}; if($@ =~ /^Rmpfr_get_ld not implemented/) { warn "Skipping test 10 - no long double support\n"; print "ok 10\n"; } else { if(MPFR_VERSION() <= 196868) { if(2e-4956 == 0) { # bug exists for extended precision (64-bit) subnormal long double if($@ =~ /^\sVersion 3\.1\.5/) {print "ok 10\n"} else { warn "\n\$\@: $@\n"; print "not ok 10\n"; } } else { # no bug for quad (113-bit) subnormal long double if(!$@ && $nv != 0) {print "ok 10\n"} else { warn "\n\$\@: $@\n\$nv: $nv\n"; print "not ok 10"; } } } else { if($nv > 0) {print "ok 10\n"} else { warn "$nv !> 0\n"; print "not ok 10\n"; } } } } Math-MPFR-4.38/t/view_config.t0000755060175106010010000000063214765756127014637 0ustar OwnerNoneuse strict; use warnings; print "1..1\n"; warn "\n No tests here - just output (if any) from any configuration\n", " probing that was done during the 'perl Makefile.PL' step\n\n"; my $RD; my $save = open $RD, '<', 'save_config.txt'; warn "Couldn't open save_config.txt for reading: $!\n" unless $save; if($save) { while(<$RD>) { chomp; warn "$_\n"; } close($RD); } print "ok 1\n"; Math-MPFR-4.38/t/_1aaa_v.t0000755060175106010010000000176514765756127013637 0ustar OwnerNoneuse warnings; use strict; print "1..1\n"; eval {use Math::MPFR::V;}; if($@) { warn "\$\@: $@"; print "not ok 1\n"; } else { warn "\nGMP Header version (major): ", Math::MPFR::V::___GNU_MP_VERSION(), "\n"; warn "GMP Header version (minor): ", Math::MPFR::V::___GNU_MP_VERSION_MINOR(), "\n"; warn "GMP Header version (patchlevel): ", Math::MPFR::V::___GNU_MP_VERSION_PATCHLEVEL(), "\n"; warn "GMP CC: ", Math::MPFR::V::___GMP_CC(), "\n"; warn "GMP CFLAGS: ", Math::MPFR::V::___GMP_CFLAGS(), "\n"; warn "MPFR Header version (major): ", Math::MPFR::V::_MPFR_VERSION_MAJOR(), "\n"; warn "MPFR Header version (minor): ", Math::MPFR::V::_MPFR_VERSION_MINOR(), "\n"; warn "MPFR Header version (patchlevel): ", Math::MPFR::V::_MPFR_VERSION_PATCHLEVEL(), "\n"; print "ok 1\n"; } my $h_major = Math::MPFR::V::_MPFR_VERSION_MAJOR(); if($h_major < 3) { warn "\n\n Your MPFR Header version is outdated and unsupported.\n", " REMAINING TEST SUITE WILL POSSIBLY FAIL !!!!\n"; } Math-MPFR-4.38/t/_1basic.t0000755060175106010010000001314114765756127013640 0ustar OwnerNoneuse warnings; use strict; use Config; use Math::MPFR qw(:mpfr); use Math::MPFR::V; use Test::More; #print "1..10\n"; warn "\n# Using Math::MPFR version ", $Math::MPFR::VERSION, "\n"; warn "# MPFR_VERSION is ", MPFR_VERSION, "\n"; warn "# Using mpfr library version ", MPFR_VERSION_STRING, "\n"; warn "# Using gmp library version ", Math::MPFR::gmp_v(), "\n"; warn "# GMP_LIMB_BITS is ", Math::MPFR::_GMP_LIMB_BITS, "\n" if defined Math::MPFR::_GMP_LIMB_BITS; warn "# GMP_NAIL_BITS is ", Math::MPFR::_GMP_NAIL_BITS, "\n" if defined Math::MPFR::_GMP_NAIL_BITS; warn "# __GMP__CFLAGS is ", Math::MPFR::_gmp_cflags(), "\n"; warn "# __GMP__CC is ", Math::MPFR::_gmp_cc(), "\n"; warn "# sizeof mpfr_exp_t: ", Math::MPFR::_sizeof_exp(), " bytes\n"; warn "# sizeof mpfr_prec_t: ", Math::MPFR::_sizeof_prec(), " bytes\n"; warn "# has _WIN32_BIZARRE_INFNAN: ", Math::MPFR::_has_bizarre_infnan(), "\n"; warn "# has MPFR_PV_NV_BUG: ", Math::MPFR::_has_pv_nv_bug(), "\n"; warn "# has WIN32_FMT_BUG: ", Math::MPFR::Random::_buggy(), "\n"; warn "# has _Float16 ", Math::MPFR::_have_float16(), "\n"; if (pack("L", 305419897) eq pack("N", 305419897)) {warn "# Machine appears to be big-endian\n"} elsif(pack("L", 305419897) eq pack("V", 305419897)) {warn "# Machine appears to be little-endian\n"} warn "# Byte Order: ", $Config{byteorder}, "\n"; my($evaluate, $f128, $d64) = (0, 0, 0, 0); eval {$evaluate = Rmpfr_buildopt_tls_p()}; if(!$@) { $evaluate ? warn "# mpfr library built WITH thread safety\n" : warn "# mpfr library built WITHOUT thread safety\n"; } eval {$evaluate = Rmpfr_buildopt_decimal_p()}; if(!$@) { $evaluate ? warn "# mpfr library built WITH _Decimal64 support\n" : warn "# mpfr library built WITHOUT _Decimal64 support\n"; if(262400 <= MPFR_VERSION()){ $evaluate ? warn "# mpfr library built WITH _Decimal128 support\n" : warn "# mpfr library built WITHOUT _Decimal128 support\n"; } $d64 = 1 if $evaluate; } eval {$evaluate = Rmpfr_buildopt_float128_p()}; if(!$@) { $evaluate ? warn "# mpfr library built WITH __float128 support\n" : warn "# mpfr library built WITHOUT __float128 support\n"; $f128 = 1 if $evaluate; } eval {$evaluate = Rmpfr_buildopt_float16_p()}; if(!$@) { $evaluate ? warn "# mpfr library built WITH _Float16 support\n" : warn "# mpfr library built WITHOUT _Float16 support\n"; } eval {$evaluate = Rmpfr_buildopt_gmpinternals_p()}; if(!$@) { $evaluate ? warn "# mpfr library built WITH gmp internals\n" : warn "# mpfr library built WITHOUT gmp internals\n"; } eval {$evaluate = Rmpfr_buildopt_sharedcache_p()}; if(!$@) { $evaluate ? warn "# mpfr library built WITH shared cache\n" : warn "# mpfr library built WITHOUT shared cache\n"; } eval {$evaluate = Rmpfr_buildopt_tune_case()}; if(!$@) { $evaluate ? warn "# mpfr library thresholds file: $evaluate\n" : warn "# mpfr library thresholds file: $evaluate\n"; } cmp_ok($Math::MPFR::VERSION, 'eq', '4.38', "Math::MPFR::VERSION ($Math::MPFR::VERSION) is as expected"); my $xs_version = Math::MPFR::_get_xs_version(); cmp_ok($xs_version, 'eq', '4.38', "Math::MPFR::_get_xs_version returns $xs_version as expected"); my $l_ver = Rmpfr_get_version(); my $h_ver = MPFR_VERSION_STRING; cmp_ok($h_ver, 'eq', $l_ver, "Header version ($h_ver) matches Library version ($l_ver)"); my $max_base = Math::MPFR::_max_base(); if(3 <= MPFR_VERSION_MAJOR) { cmp_ok($max_base, '==', 62, "maximum base ($max_base) == 62"); } else { cmp_ok($max_base, '==', 36, "maximum base ($max_base) == 36"); } my $iv_bits = 8 * $Config{ivsize}; if(Math::MPFR::_has_longlong()) { cmp_ok(Math::MPFR::_ivsize_bits(), '==', $iv_bits, "IVSIZE_BITS set to expected value of $iv_bits"); } cmp_ok($Math::MPFR::VERSION, 'eq', $Math::MPFR::Random::VERSION, "Math::MPFR version ($Math::MPFR::VERSION) eq Math::MPFR::Random version ($Math::MPFR::Random::VERSION)"); cmp_ok($Math::MPFR::VERSION, 'eq', $Math::MPFR::Prec::VERSION, "Math::MPFR version ($Math::MPFR::VERSION) eq Math::MPFR::Prec version ($Math::MPFR::Prec::VERSION)"); cmp_ok($Math::MPFR::VERSION, 'eq', $Math::MPFR::V::VERSION, "Math::MPFR version ($Math::MPFR::VERSION) eq Math::MPFR::V version ($Math::MPFR::V::VERSION)"); cmp_ok(Math::MPFR::Random::_MPFR_VERSION(), '==', Math::MPFR::_MPFR_VERSION(), "Math::MPFR::Random::_MPFR_VERSION() == Math::MPFR::_MPFR_VERSION()"); my $v = Math::MPFR::_sis_perl_version; my $v_check = $]; $v_check =~ s/\.//; if($] =~ /^5\./) { cmp_ok($v, '==', $v_check, 'Math::MPFR::_sis_perl_version agrees with $]'); } else { # $] no longer matches /^5\./ # Just checking that Math::MPFR::_sis_perl_version > 5012000 will suffice. cmp_ok($v, '>', 5012000, 'Math::MPFR::_sis_perl_version > 5012000'); } if($^O =~ /^MSWin/) { if(WIN32_FMT_BUG) { # Check that if WIN32_FMT_BUG is set, then "-D__USE_MINGW_ANSI_STDIO" # is missing from both __GMP_CC and __GMP_CFLAGS unlike(Math::MPFR::_gmp_cflags(), qr/\-D__USE_MINGW_ANSI_STDIO/, "-D__USE_MINGW_ANSI_STDIO missing from __GMP_CFLAGS"); unlike(Math::MPFR::_gmp_cc(), qr/\-D__USE_MINGW_ANSI_STDIO/, "-D__USE_MINGW_ANSI_STDIO missing from __GMP_CC"); } if(Math::MPFR::_gmp_cflags =~ /\-D__USE_MINGW_ANSI_STDIO/ || Math::MPFR::_gmp_cc() =~ /\-D__USE_MINGW_ANSI_STDIO/ ) { # Check that if "-D__USE_MINGW_ANSI_STDIO" is present in either # of __GMP_CC and __GMP_CFLAGS then WIN32_FMT_BUG is set to 0. cmp_ok(WIN32_FMT_BUG, '==', 0, "WIN32_FMT_BUG set to zero"); } } done_testing(); Math-MPFR-4.38/t/_2exp.t0000755060175106010010000001335414765756127013362 0ustar OwnerNoneuse warnings; use strict; use Math::MPFR qw(:mpfr); #use Devel::Peek; print "1..3\n"; my ($exp, $ret); my $rop = Math::MPFR->new(); my $op1 = Math::MPFR->new(64.75); my $op2 = Math::MPFR->new(0.25); my $nan = Math::MPFR->new(); my $zero = Math::MPFR->new(0); my $unity = Math::MPFR->new(1); my $inf = $unity / $zero; my $ninf = -($inf); my $nzero = $zero * -1; my $ok = ''; if((MPFR_VERSION_MAJOR == 3 && MPFR_VERSION_MINOR >= 1) || MPFR_VERSION_MAJOR > 3) { $ret = Rmpfr_frexp($exp, $rop, $op1, GMP_RNDN); if($ret == 0 && $exp == 7 && $rop == 0.505859375) {$ok .= 'a'} #print "$ret $exp $rop\n", $rop * (2 ** $exp), "\n\n"; $ret = Rmpfr_frexp($exp, $rop, $op2, GMP_RNDN); if($ret == 0 && $exp == -1 && $rop == 0.5) {$ok .= 'b'} #print "$ret $exp $rop\n", $rop * (2 ** $exp), "\n\n"; $ret = Rmpfr_frexp($exp, $rop, -$op1, GMP_RNDN); if($ret == 0 && $exp == 7 && $rop == -0.505859375) {$ok .= 'c'} #print "$ret $exp $rop\n", $rop * (2 ** $exp), "\n\n"; $ret = Rmpfr_frexp($exp, $rop, -$op2, GMP_RNDN); if($ret == 0 && $exp == -1 && $rop == -0.5) {$ok .= 'd'} #print "$ret $exp $rop\n", $rop * (2 ** $exp), "\n\n"; $ret = Rmpfr_frexp($exp, $rop, $zero, GMP_RNDN); if($ret == 0 && $exp == 0 && $rop == 0 && Rmpfr_sgn($rop) == 0 && !Rmpfr_signbit($rop)) {$ok .= 'e'} #print "$ret $exp $rop\n", $rop * (2 ** $exp), "\n\n"; $ret = Rmpfr_frexp($exp, $rop, $nzero, GMP_RNDN); if($ret == 0 && $exp == 0 && $rop == 0 && !Rmpfr_sgn($rop) && Rmpfr_signbit($rop)) {$ok .= 'f'} #print "$ret $exp $rop\n", $rop * (2 ** $exp), "\n\n"; $ret = Rmpfr_frexp($exp, $rop, $nan, GMP_RNDN); if($ret == 0 && Rmpfr_nan_p($rop)) {$ok .= 'g'} #print "$ret $exp $rop\n", $rop * (2 ** $exp), "\n\n"; $ret = Rmpfr_frexp($exp, $rop, $inf, GMP_RNDN); if($ret == 0 && Rmpfr_inf_p($rop) && !Rmpfr_signbit($rop)) {$ok .= 'h'} #print "$ret $exp $rop\n", $rop * (2 ** $exp), "\n\n"; $ret = Rmpfr_frexp($exp, $rop, $ninf, GMP_RNDN); if($ret == 0 && Rmpfr_inf_p($rop) && Rmpfr_signbit($rop)) {$ok .= 'i'} #print "$ret $exp $rop\n", $rop * (2 ** $exp), "\n\n"; if($ok eq 'abcdefghi') {print "ok 1\n"} else { warn "1: \$ok: $ok\n"; print "not ok 1\n"; } } else { eval{Rmpfr_frexp($exp, $rop, $op1, GMP_RNDN);}; if($@ =~ /Rmpfr_frexp not implemented/) {print "ok 1\n"} else { warn "\$\@: $@"; print "not ok 1\n"; } } $ok = ''; $ret = Rmpfr_get_d_2exp($exp, $op1, GMP_RNDN); if($exp == 7 && $ret == 0.505859375) {$ok .= 'a'} #print "$ret $exp\n", $ret * (2 ** $exp), "\n\n"; $ret = Rmpfr_get_d_2exp($exp, $op2, GMP_RNDN); if($exp == -1 && $ret == 0.5) {$ok .= 'b'} #print "$ret $exp\n", $ret * (2 ** $exp), "\n\n"; $ret = Rmpfr_get_d_2exp($exp, -$op1, GMP_RNDN); if($exp == 7 && $ret == -0.505859375) {$ok .= 'c'} #print "$ret $exp\n", $ret * (2 ** $exp), "\n\n"; $ret = Rmpfr_get_d_2exp($exp, -$op2, GMP_RNDN); if($exp == -1 && $ret == -0.5) {$ok .= 'd'} #print "$ret $exp\n", $ret * (2 ** $exp), "\n\n"; $ret = Rmpfr_get_d_2exp($exp, $zero, GMP_RNDN); if($exp == 0 && is_pzero($ret)) {$ok .= 'e'} #print "$ret $exp\n", $ret * (2 ** $exp), "\n\n"; $ret = Rmpfr_get_d_2exp($exp, $nzero, GMP_RNDN); if($exp == 0 && is_nzero($ret)) {$ok .= 'f'} #print "$ret $exp\n", $ret * (2 ** $exp), "\n\n"; $ret = Rmpfr_get_d_2exp($exp, $nan, GMP_RNDN); if(is_nan($ret)) {$ok .= 'g'} #print "$ret $exp\n", $ret * (2 ** $exp), "\n\n"; $ret = Rmpfr_get_d_2exp($exp, $inf, GMP_RNDN); if(is_pinf($ret)) {$ok .= 'h'} #print "$ret $exp\n", $ret * (2 ** $exp), "\n\n"; $ret = Rmpfr_get_d_2exp($exp, $ninf, GMP_RNDN); if(is_ninf($ret)) {$ok .= 'i'} #print "$ret $exp\n", $ret * (2 ** $exp), "\n\n"; if($ok eq 'abcdefghi') {print "ok 2\n"} else { warn "2: \$ok: $ok\n"; print "not ok 2\n"; } $ok = ''; if(Math::MPFR::_has_longdouble()) { $ret = Rmpfr_get_ld_2exp($exp, $op1, GMP_RNDN); if($exp == 7 && $ret == 0.505859375) {$ok .= 'a'} #print "$ret $exp\n", $ret * (2 ** $exp), "\n\n"; $ret = Rmpfr_get_ld_2exp($exp, $op2, GMP_RNDN); if($exp == -1 && $ret == 0.5) {$ok .= 'b'} #print "$ret $exp\n", $ret * (2 ** $exp), "\n\n"; $ret = Rmpfr_get_ld_2exp($exp, -$op1, GMP_RNDN); if($exp == 7 && $ret == -0.505859375) {$ok .= 'c'} #print "$ret $exp\n", $ret * (2 ** $exp), "\n\n"; $ret = Rmpfr_get_ld_2exp($exp, -$op2, GMP_RNDN); if($exp == -1 && $ret == -0.5) {$ok .= 'd'} #print "$ret $exp\n", $ret * (2 ** $exp), "\n\n"; $ret = Rmpfr_get_ld_2exp($exp, $zero, GMP_RNDN); if($exp == 0 && is_pzero($ret)) {$ok .= 'e'} #print "$ret $exp\n", $ret * (2 ** $exp), "\n\n"; $ret = Rmpfr_get_ld_2exp($exp, $nzero, GMP_RNDN); if($exp == 0 && is_nzero($ret)) {$ok .= 'f'} #print "$ret $exp\n", $ret * (2 ** $exp), "\n\n"; $ret = Rmpfr_get_ld_2exp($exp, $nan, GMP_RNDN); if(is_nan($ret)) {$ok .= 'g'} #print "$ret $exp\n", $ret * (2 ** $exp), "\n\n"; $ret = Rmpfr_get_ld_2exp($exp, $inf, GMP_RNDN); if(is_pinf($ret)) {$ok .= 'h'} #print "$ret $exp\n", $ret * (2 ** $exp), "\n\n"; $ret = Rmpfr_get_ld_2exp($exp, $ninf, GMP_RNDN); if(is_ninf($ret)) {$ok .= 'i'} #print "$ret $exp\n", $ret * (2 ** $exp), "\n\n"; if($ok eq 'abcdefghi') {print "ok 3\n"} else { warn "3: \$ok: $ok\n"; print "not ok 3\n"; } } else { warn "Skipping test 3 - no long double support\n"; print "ok 3\n"; } sub is_nan { return Rmpfr_nan_p(Math::MPFR->new($_[0])); } sub is_pinf { my $x = Math::MPFR->new($_[0]); if(Rmpfr_inf_p($x) && !Rmpfr_signbit($x)) {return 1} return 0; } sub is_ninf { my $x = Math::MPFR->new($_[0]); if(Rmpfr_inf_p($x) && Rmpfr_signbit($x)) {return 1} return 0; } sub is_pzero { my $x = Math::MPFR->new($_[0]); if(Rmpfr_zero_p($x) && !Rmpfr_signbit($x)) {return 1} return 0; } sub is_nzero { my $x = Math::MPFR->new($_[0]); if(Rmpfr_zero_p($x) && Rmpfr_signbit($x)) {return 1} return 0; } Math-MPFR-4.38/t/_Float16.t0000755060175106010010000000206314765756127013713 0ustar OwnerNoneuse strict; use warnings; use Math::MPFR qw(:mpfr); use Test::More; if(MPFR_VERSION >= 262912) { # MPFR-4.3.0 or later if(Math::MPFR::_have_float16()) { cmp_ok(Rmpfr_buildopt_float16_p(), '==', 1, "MPFR library supports _Float16"); cmp_ok(Math::MPFR::_have_float16(), '==', 1, "_Float16 support is available && utilised"); my $op = sqrt(Math::MPFR->new(2)); my $nv = Rmpfr_get_float16($op, MPFR_RNDN); cmp_ok($op, '!=', $nv, "values no longer match"); my $op16 = Rmpfr_init2(11); # _Float16 has 11 bits of precision. Rmpfr_set_ui($op16, 2, MPFR_RNDN); Rmpfr_sqrt($op16, $op16, MPFR_RNDN); cmp_ok($nv, '==', $op16, "values match"); } else { cmp_ok(Math::MPFR::_have_float16(), '==', 0, "MPFR library support for_Float16 is not utilised"); } } else { eval{Rmpfr_buildopt_float16_p();}; like($@, qr/'mpfr_buildopt_float16_p' not implemented until MPFR\-4\.3\.0/, "Rmpfr_buildopt_float16_p() croaks as expected"); cmp_ok(Math::MPFR::_have_float16(), '==', 0, "_Float16 support is lacking"); } done_testing(); Math-MPFR-4.38/t/_itsa.t0000755060175106010010000000677214765756127013452 0ustar OwnerNone # In assigning values we look at the flags of the # given argument. Here we simply check that the flags # of that argument will be as expected. use strict; use warnings; use Test::More; use Math::MPFR; *_ITSA = \&Math::MPFR::_itsa; my $uv_max = ~0; my $nan1 = 'nan' + 0; my $nan2 = 'nan' + 0; my $inf1 = 'inf' + 0; my $inf2 = 'inf' + 0; if($] < 5.03) { warn "Skipping for $] - the aim here is to detect any recent changes,\n", " not to concern ourselves with old behaviour.\n"; is(1, 1); done_testing(); exit 0; } if($inf1 - $inf1 == 0) { warn "Skipping - failed to create an inf\n"; is(1, 1); done_testing(); exit 0; } if($nan1 == $nan1) { warn "Skipping - failed to create a nan\n"; is(1, 1); done_testing(); exit 0; } my $uv = $uv_max; cmp_ok(_ITSA($uv), '==', 1, "\$uv is UV"); my $uv_copy = $uv; my $uv_x = "$uv"; cmp_ok(_ITSA($uv), '==', 1, "\$uv is still UV"); $uv_x -= 2; cmp_ok(_ITSA($uv_x), '==', 1, "\$uv_x is also UV"); cmp_ok(_ITSA($uv_copy), '==', 1, "\$uv_copy is UV"); my $uv2 = ~0 - 1; my $foo = $uv2 + 2; cmp_ok(_ITSA($uv2), '==', 1, "\$uv2 is still UV"); my $uv3 = ~0; $uv3 += 1; cmp_ok(_ITSA($uv3), '==', 3, "\$uv3 is now NV"); my $uv4 = ~0; $foo = "$uv4"; $uv4 += 1; cmp_ok(_ITSA($uv4), '==', 3, "\$uv4 is now NV"); my $iv = -23; cmp_ok(_ITSA($iv), '==', 2, "\$iv is IV"); my $iv_copy = $iv; my $iv_x = "$iv"; cmp_ok(_ITSA($iv), '==', 2, "\$iv is still IV"); $iv_x -= 2; cmp_ok(_ITSA($iv_x), '==', 2, "\$iv_x is also IV"); cmp_ok(_ITSA($iv_copy), '==', 2, "\$iv_copy is IV"); my $iv2 = 14411; $foo = 112 / $iv2; cmp_ok(_ITSA($iv2), '==', 2, "\$iv2 is still IV"); my $pv1 = "$uv_max"; cmp_ok(_ITSA($pv1), '==', 4, "\$pv1 is PV"); $pv1 -= 1; cmp_ok(_ITSA($pv1), '==', 1, "\$pv1 is now UV"); $pv1 >>= 1; cmp_ok(_ITSA($pv1), '==', 2, "$pv1 is IV"); my $pv2 = "2.3"; cmp_ok(_ITSA($pv2), '==', 4, "\$pv2 is PV"); $pv2 -= 1; cmp_ok(_ITSA($pv2), '==', 3, "\$pv2 is now NV"); my $nv = 1.2e-11; cmp_ok(_ITSA($nv), '==', 3, "\$nv is NV"); my $nv_copy = $nv; my $nv_x = "$nv"; cmp_ok(_ITSA($nv), '==', 3, "\$nv is still NV"); $nv -= 2; cmp_ok(_ITSA($nv), '==', 3, "$nv is also NV"); cmp_ok(_ITSA($nv_copy), '==', 3, "\$nv_copy is NV"); my $nv2 = 2.3; $nv = $nv2 / 2; cmp_ok(_ITSA($nv2), '==', 3, "\$nv2 is still NV"); $foo = $inf1 / 2; cmp_ok(_ITSA($inf1), '==', 3, "\$inf1 is still NV"); $foo = $inf2 / $inf2; cmp_ok(_ITSA($inf2), '==', 3, "\$inf2 is still NV"); $foo = $nan1 / 2; cmp_ok(_ITSA($nan1), '==', 3, "\$nan1 is still NV"); $foo = $nan2 / $nan2; cmp_ok(_ITSA($nan2), '==', 3, "\$nan2 is still NV"); my $pv3 = '987654' x 100; cmp_ok(_ITSA($pv3), '==', 4, "\$pv3 is PV"); cmp_ok($pv3, '>=', 0, "\$pv3 >= 0"); # NOK flag is now set, but we want # to use the value in the PV slot cmp_ok(_ITSA($pv3), '==', 4, "\$pv3 is still PV"); cmp_ok($pv3, 'eq', '987654' x 100, "\$pv3 PV slot is unchanged"); my $pv4 = sprintf "%u", ~0; $foo = $pv4 + 1; # $pv4 should now be seen as UV, though it # would be ok if it were still seen as PV cmp_ok(_ITSA($pv4), '==', 1, "\$pv4 is now UV"); cmp_ok($pv4, 'eq', sprintf("%u", ~0), "\$pv4 PV slot is unchanged"); my $pv5 = sprintf("%u", ~0) . 'xyz'; { no warnings 'numeric'; $foo = $pv5 + 1; # $pv5 should still be seen as PV } cmp_ok(_ITSA($pv5), '==', 4, "\$pv5 is still PV"); cmp_ok($pv5, 'eq', sprintf("%u", ~0) . 'xyz', "\$pv5 PV slot is unchanged"); done_testing(); Math-MPFR-4.38/try_dec128.in0000755060175106010010000000054714765756127014131 0ustar OwnerNone #include #include #include int main(void) { #if MPFR_VERSION >= MPFR_VERSION_NUM(4,1,0) if(mpfr_buildopt_decimal_p()) printf("128"); else printf("mpfr_buildopt_decimal_p() returned false"); #else printf("This version (%s) of mpfr does not support _Decimal128. Need at least 4.1.0", MPFR_VERSION_STRING); #endif return 0; } Math-MPFR-4.38/try_dec64.in0000755060175106010010000000030014765756127014033 0ustar OwnerNone #include #include #include int main(void) { if(mpfr_buildopt_decimal_p()) printf("42"); else printf("mpfr_buildopt_decimal_p() returned false"); return 0; } Math-MPFR-4.38/try_flt128.in0000755060175106010010000000030214765756127014150 0ustar OwnerNone #include #include #include int main(void) { if(mpfr_buildopt_float128_p()) printf("42"); else printf("mpfr_buildopt_float128_p() returned false"); return 0; } Math-MPFR-4.38/typemap0000755060175106010010000000040214765756127013305 0ustar OwnerNonempq_t * GMP_PTR mpz_t * GMP_PTR mpf_t * GMP_PTR mpc_t * GMP_PTR mpfi_t * GMP_PTR mpfr_t * GMP_PTR gmp_randstate_t * GMP_PTR INPUT GMP_PTR $var = INT2PTR($type, SvIVX(SvRV($arg))) Math-MPFR-4.38/V/0000755060175106010010000000000014766136501012076 5ustar OwnerNoneMath-MPFR-4.38/V/Makefile.PL0000755060175106010010000000041614765756127014067 0ustar OwnerNoneuse strict; use warnings; use ExtUtils::MakeMaker; my %options = %{ { 'NAME' => 'Math::MPFR::V', 'INC' => $INC, 'VERSION_FROM' => 'V.pm' } }; WriteMakefile(%options); # Remove the Makefile dependency. Causes problems on a few systems. # sub MY::makefile { '' } Math-MPFR-4.38/V/V.pm0000755060175106010010000000076514765756127012667 0ustar OwnerNone## This file generated by InlineX::C2XS (version 0.24) using Inline::C (version 0.73) # Provides access to some gmp and mpfr macros/constants package Math::MPFR::V; use strict; use warnings; require Exporter; *import = \&Exporter::import; require DynaLoader; our $VERSION = '4.38'; #$VERSION = eval $VERSION; Math::MPFR::V->DynaLoader::bootstrap($VERSION); @Math::MPFR::V::EXPORT = (); @Math::MPFR::V::EXPORT_OK = (); sub dl_load_flags {0} # Prevent DynaLoader from complaining and croaking 1; Math-MPFR-4.38/V/V.xs0000755060175106010010000000404614765756127012701 0ustar OwnerNone #ifdef __MINGW32__ #ifndef __USE_MINGW_ANSI_STDIO #define __USE_MINGW_ANSI_STDIO 1 #endif #endif #define PERL_NO_GET_CONTEXT 1 #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "../math_mpfr_include.h" SV * ___GNU_MP_VERSION(pTHX) { return newSVuv(__GNU_MP_VERSION); } SV * ___GNU_MP_VERSION_MINOR(pTHX) { return newSVuv(__GNU_MP_VERSION_MINOR); } SV * ___GNU_MP_VERSION_PATCHLEVEL(pTHX) { return newSVuv(__GNU_MP_VERSION_PATCHLEVEL); } SV * ___GMP_CC(pTHX) { #ifdef __GMP_CC char * ret = __GMP_CC; return newSVpv(ret, 0); #else return &PL_sv_undef; #endif } SV * ___GMP_CFLAGS(pTHX) { #ifdef __GMP_CFLAGS char * ret = __GMP_CFLAGS; return newSVpv(ret, 0); #else return &PL_sv_undef; #endif } SV * _MPFR_VERSION(pTHX) { return newSVuv(MPFR_VERSION); } SV * _MPFR_VERSION_MAJOR(pTHX) { return newSVuv(MPFR_VERSION_MAJOR); } SV * _MPFR_VERSION_MINOR(pTHX) { return newSVuv(MPFR_VERSION_MINOR); } SV * _MPFR_VERSION_PATCHLEVEL(pTHX) { return newSVuv(MPFR_VERSION_PATCHLEVEL); } SV * _MPFR_VERSION_STRING(pTHX) { return newSVpv(MPFR_VERSION_STRING, 0); } MODULE = Math::MPFR::V PACKAGE = Math::MPFR::V PROTOTYPES: DISABLE SV * ___GNU_MP_VERSION () CODE: RETVAL = ___GNU_MP_VERSION (aTHX); OUTPUT: RETVAL SV * ___GNU_MP_VERSION_MINOR () CODE: RETVAL = ___GNU_MP_VERSION_MINOR (aTHX); OUTPUT: RETVAL SV * ___GNU_MP_VERSION_PATCHLEVEL () CODE: RETVAL = ___GNU_MP_VERSION_PATCHLEVEL (aTHX); OUTPUT: RETVAL SV * ___GMP_CC () CODE: RETVAL = ___GMP_CC (aTHX); OUTPUT: RETVAL SV * ___GMP_CFLAGS () CODE: RETVAL = ___GMP_CFLAGS (aTHX); OUTPUT: RETVAL SV * _MPFR_VERSION () CODE: RETVAL = _MPFR_VERSION (aTHX); OUTPUT: RETVAL SV * _MPFR_VERSION_MAJOR () CODE: RETVAL = _MPFR_VERSION_MAJOR (aTHX); OUTPUT: RETVAL SV * _MPFR_VERSION_MINOR () CODE: RETVAL = _MPFR_VERSION_MINOR (aTHX); OUTPUT: RETVAL SV * _MPFR_VERSION_PATCHLEVEL () CODE: RETVAL = _MPFR_VERSION_PATCHLEVEL (aTHX); OUTPUT: RETVAL SV * _MPFR_VERSION_STRING () CODE: RETVAL = _MPFR_VERSION_STRING (aTHX); OUTPUT: RETVAL