gcc/gmp/demos/perl/GMP.xs - Issue 3050029: [gcc] GCC 4.5.0=>4.5.1

Unified Diff: gcc/gmp/demos/perl/GMP.xs

Issue 3050029: [gcc] GCC 4.5.0=>4.5.1 (Closed) Base URL: ssh://git@gitrw.chromium.org:9222/nacl-toolchain.git

Patch Set: Created 10 years, 5 months ago

Use n/p to move between diff chunks; N/P to move between comments. Draft comments are only viewable by you.

Jump to:

View side-by-side diff with in-line comments

Index: gcc/gmp/demos/perl/GMP.xs

diff --git a/gcc/gmp/demos/perl/GMP.xs b/gcc/gmp/demos/perl/GMP.xs

deleted file mode 100644

index 2282c89282fba0760678f22ff2fbf26c176b5af3..0000000000000000000000000000000000000000

--- a/gcc/gmp/demos/perl/GMP.xs

+++ /dev/null

@@ -1,3201 +0,0 @@

-/* GMP module external subroutines.

-This file is part of the GNU MP Library.

-The GNU MP Library is free software; you can redistribute it and/or modify

-it under the terms of the GNU Lesser General Public License as published by

-the Free Software Foundation; either version 3 of the License, or (at your

-option) any later version.

-The GNU MP Library is distributed in the hope that it will be useful, but

-WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY

-or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public

-License for more details.

-You should have received a copy of the GNU Lesser General Public License

-along with the GNU MP Library. If not, see http://www.gnu.org/licenses/.

-/* Notes:

- Routines are grouped with the alias feature and a table of function

- pointers where possible, since each xsub routine ends up with quite a bit

- of code size. Different combinations of arguments and return values have

- to be separate though.

- The "INTERFACE:" feature isn't available in perl 5.005 and so isn't used.

- "ALIAS:" requires a table lookup with CvXSUBANY(cv).any_i32 (which is

- "ix") whereas "INTERFACE:" would have CvXSUBANY(cv).any_dptr as the

- function pointer immediately.

- Mixed-type swapped-order assignments like "$a = 123; $a += mpz(456);"

- invoke the plain overloaded "+", not "+=", which makes life easier.

- mpz_assume etc types are used with the overloaded operators since such

- operators are always called with a class object as the first argument, we

- don't need an sv_derived_from() lookup to check. There's assert()s in

- MPX_ASSUME() for this though.

- The overload_constant routines reached via overload::constant get 4

- arguments in perl 5.6, not the 3 as documented. This is apparently a

- bug, using "..." lets us ignore the extra one.

- There's only a few "si" functions in gmp, so usually SvIV values get

- handled with an mpz_set_si into a temporary and then a full precision mpz

- routine. This is reasonably efficient.

- Argument types are checked, with a view to preserving all bits in the

- operand. Perl is a bit looser in its arithmetic, allowing rounding or

- truncation to an intended operand type (IV, UV or NV).

- Bugs:

- The memory leak detection attempted in GMP::END() doesn't work when mpz's

- are created as constants because END() is called before they're

- destroyed. What's the right place to hook such a check?

- See the bugs section of GMP.pm too. */

-/* Comment this out to get assertion checking. */

-#define NDEBUG

-/* Change this to "#define TRACE(x) x" for some diagnostics. */

-#define TRACE(x)

-#include <assert.h>

-#include <float.h>

-#include "EXTERN.h"

-#include "perl.h"

-#include "XSUB.h"

-#include "patchlevel.h"

-#include "gmp.h"

-/* Perl 5.005 doesn't have SvIsUV, only 5.6 and up.

- Perl 5.8 has SvUOK, but not 5.6, so we don't use that. */

-#ifndef SvIsUV

-#define SvIsUV(sv) 0

-#endif

-#ifndef SvUVX

-#define SvUVX(sv) (croak("GMP: oops, shouldn't be using SvUVX"), 0)

-#endif

-/* Code which doesn't check anything itself, but exists to support other

- assert()s. */

-#ifdef NDEBUG

-#define assert_support(x)

-#else

-#define assert_support(x) x

-#endif

-/* LONG_MAX + 1 and ULONG_MAX + 1, as a doubles */

-#define LONG_MAX_P1_AS_DOUBLE ((double) ((unsigned long) LONG_MAX + 1))

-#define ULONG_MAX_P1_AS_DOUBLE (2.0 * (double) ((unsigned long) ULONG_MAX/2 + 1))

-/* Check for perl version "major.minor".

- Perl 5.004 doesn't have PERL_REVISION and PERL_VERSION, but that's ok,

- we're only interested in tests above that. */

-#if defined (PERL_REVISION) && defined (PERL_VERSION)

-#define PERL_GE(major,minor) \

- (PERL_REVISION > (major) \

- || ((major) == PERL_REVISION && PERL_VERSION >= (minor)))

-#else

-#define PERL_GE(major,minor) (0)

-#endif

-#define PERL_LT(major,minor) (! PERL_GE(major,minor))

-/* sv_derived_from etc in 5.005 took "char *" rather than "const char *".

- Avoid some compiler warnings by using const only where it works. */

-#if PERL_LT (5,6)

-#define classconst

-#else

-#define classconst const

-#endif

-/* In a MINGW or Cygwin DLL build of gmp, the various gmp functions are

- given with dllimport directives, which prevents them being used as

- initializers for constant data. We give function tables as

- "static_functable const ...", which is normally "static const", but for

- mingw expands to just "const" making the table an automatic with a

- run-time initializer.

- In gcc 3.3.1, the function tables initialized like this end up getting

- all the __imp__foo values fetched, even though just one or two will be

- used. This is wasteful, but probably not too bad. */

-#if defined (__MINGW32__) || defined (__CYGWIN__)

-#define static_functable

-#else

-#define static_functable static

-#endif

-#define GMP_MALLOC_ID 42

-static classconst char mpz_class[] = "GMP::Mpz";

-static classconst char mpq_class[] = "GMP::Mpq";

-static classconst char mpf_class[] = "GMP::Mpf";

-static classconst char rand_class[] = "GMP::Rand";

-static HV *mpz_class_hv;

-static HV *mpq_class_hv;

-static HV *mpf_class_hv;

-assert_support (static long mpz_count = 0;)

-assert_support (static long mpq_count = 0;)

-assert_support (static long mpf_count = 0;)

-assert_support (static long rand_count = 0;)

-#define TRACE_ACTIVE() \

- assert_support \

- (TRACE (printf (" active %ld mpz, %ld mpq, %ld mpf, %ld randstate\n", \

- mpz_count, mpq_count, mpf_count, rand_count)))

-/* Each "struct mpz_elem" etc is an mpz_t with a link field tacked on the

- end so they can be held on a linked list. */

-#define CREATE_MPX(type) \

- \

- /* must have mpz_t etc first, for sprintf below */ \

- struct type##_elem { \

- type##_t m; \

- struct type##_elem *next; \

- }; \

- typedef struct type##_elem *type; \

- typedef struct type##_elem *type##_assume; \

- typedef type##_ptr type##_coerce; \

- \

- static type type##_freelist = NULL; \

- \

- static type \

- new_##type (void) \

- { \

- type p; \

- TRACE (printf ("new %s\n", type##_class)); \

- if (type##_freelist != NULL) \

- { \

- p = type##_freelist; \

- type##_freelist = type##_freelist->next; \

- } \

- else \

- { \

- New (GMP_MALLOC_ID, p, 1, struct type##_elem); \

- type##_init (p->m); \

- } \

- TRACE (printf (" p=%p\n", p)); \

- assert_support (type##_count++); \

- TRACE_ACTIVE (); \

- return p; \

- } \

-CREATE_MPX (mpz)

-CREATE_MPX (mpq)

-typedef mpf_ptr mpf;

-typedef mpf_ptr mpf_assume;

-typedef mpf_ptr mpf_coerce_st0;

-typedef mpf_ptr mpf_coerce_def;

-static mpf

-new_mpf (unsigned long prec)

- mpf p;

- New (GMP_MALLOC_ID, p, 1, __mpf_struct);

- mpf_init2 (p, prec);

- TRACE (printf (" mpf p=%p\n", p));

- assert_support (mpf_count++);

- TRACE_ACTIVE ();

- return p;

-/* tmp_mpf_t records an allocated precision with an mpf_t so changes of

- precision can be done with just an mpf_set_prec_raw. */

-struct tmp_mpf_struct {

- mpf_t m;

- unsigned long allocated_prec;

-};

-typedef const struct tmp_mpf_struct *tmp_mpf_srcptr;

-typedef struct tmp_mpf_struct *tmp_mpf_ptr;

-typedef struct tmp_mpf_struct tmp_mpf_t[1];

-#define tmp_mpf_init(f) \

- do { \

- mpf_init (f->m); \

- f->allocated_prec = mpf_get_prec (f->m); \

- } while (0)

-static void

-tmp_mpf_grow (tmp_mpf_ptr f, unsigned long prec)

- mpf_set_prec_raw (f->m, f->allocated_prec);

- mpf_set_prec (f->m, prec);

- f->allocated_prec = mpf_get_prec (f->m);

-#define tmp_mpf_shrink(f) tmp_mpf_grow (f, 1L)

-#define tmp_mpf_set_prec(f,prec) \

- do { \

- if (prec > f->allocated_prec) \

- tmp_mpf_grow (f, prec); \

- else \

- mpf_set_prec_raw (f->m, prec); \

- } while (0)

-static mpz_t tmp_mpz_0, tmp_mpz_1, tmp_mpz_2;

-static mpq_t tmp_mpq_0, tmp_mpq_1;

-static tmp_mpf_t tmp_mpf_0, tmp_mpf_1;

-/* for GMP::Mpz::export */

-#define tmp_mpz_4 tmp_mpz_2

-#define FREE_MPX_FREELIST(p,type) \

- do { \

- TRACE (printf ("free %s\n", type##_class)); \

- p->next = type##_freelist; \

- type##_freelist = p; \

- assert_support (type##_count--); \

- TRACE_ACTIVE (); \

- assert (type##_count >= 0); \

- } while (0)

-/* this version for comparison, if desired */

-#define FREE_MPX_NOFREELIST(p,type) \

- do { \

- TRACE (printf ("free %s\n", type##_class)); \

- type##_clear (p->m); \

- Safefree (p); \

- assert_support (type##_count--); \

- TRACE_ACTIVE (); \

- assert (type##_count >= 0); \

- } while (0)

-#define free_mpz(z) FREE_MPX_FREELIST (z, mpz)

-#define free_mpq(q) FREE_MPX_FREELIST (q, mpq)

-/* Return a new mortal SV holding the given mpx_ptr pointer.

- class_hv should be one of mpz_class_hv etc. */

-#define MPX_NEWMORTAL(mpx_ptr, class_hv) \

- sv_bless (sv_setref_pv (sv_newmortal(), NULL, mpx_ptr), class_hv)

-/* Aliases for use in typemaps */

-typedef char *malloced_string;

-typedef const char *const_string;

-typedef const char *const_string_assume;

-typedef char *string;

-typedef SV *order_noswap;

-typedef SV *dummy;

-typedef SV *SV_copy_0;

-typedef unsigned long ulong_coerce;

-typedef __gmp_randstate_struct *randstate;

-typedef UV gmp_UV;

-#define SvMPX(s,type) ((type) SvIV((SV*) SvRV(s)))

-#define SvMPZ(s) SvMPX(s,mpz)

-#define SvMPQ(s) SvMPX(s,mpq)

-#define SvMPF(s) SvMPX(s,mpf)

-#define SvRANDSTATE(s) SvMPX(s,randstate)

-#define MPX_ASSUME(x,sv,type) \

- do { \

- assert (sv_derived_from (sv, type##_class)); \

- x = SvMPX(sv,type); \

- } while (0)

-#define MPZ_ASSUME(z,sv) MPX_ASSUME(z,sv,mpz)

-#define MPQ_ASSUME(q,sv) MPX_ASSUME(q,sv,mpq)

-#define MPF_ASSUME(f,sv) MPX_ASSUME(f,sv,mpf)

-#define numberof(x) (sizeof (x) / sizeof ((x)[0]))

-#define SGN(x) ((x)<0 ? -1 : (x) != 0)

-#define ABS(x) ((x)>=0 ? (x) : -(x))

-#define double_integer_p(d) (floor (d) == (d))

-#define x_mpq_integer_p(q) \

- (mpz_cmp_ui (mpq_denref(q), 1L) == 0)

-#define assert_table(ix) assert (ix >= 0 && ix < numberof (table))

-#define SV_PTR_SWAP(x,y) \

- do { SV *__tmp = (x); (x) = (y); (y) = __tmp; } while (0)

-#define MPF_PTR_SWAP(x,y) \

- do { mpf_ptr __tmp = (x); (x) = (y); (y) = __tmp; } while (0)

-static void

-class_or_croak (SV *sv, classconst char *cl)

- if (! sv_derived_from (sv, cl))

- croak("not type %s", cl);

-/* These are macros, wrap them in functions. */

-static int

-x_mpz_odd_p (mpz_srcptr z)

- return mpz_odd_p (z);

-static int

-x_mpz_even_p (mpz_srcptr z)

- return mpz_even_p (z);

-static void

-x_mpq_pow_ui (mpq_ptr r, mpq_srcptr b, unsigned long e)

- mpz_pow_ui (mpq_numref(r), mpq_numref(b), e);

- mpz_pow_ui (mpq_denref(r), mpq_denref(b), e);

-static void *

-my_gmp_alloc (size_t n)

- void *p;

- TRACE (printf ("my_gmp_alloc %u\n", n));

- New (GMP_MALLOC_ID, p, n, char);

- TRACE (printf (" p=%p\n", p));

- return p;

-static void *

-my_gmp_realloc (void *p, size_t oldsize, size_t newsize)

- TRACE (printf ("my_gmp_realloc %p, %u to %u\n", p, oldsize, newsize));

- Renew (p, newsize, char);

- TRACE (printf (" p=%p\n", p));

- return p;

-static void

-my_gmp_free (void *p, size_t n)

- TRACE (printf ("my_gmp_free %p %u\n", p, n));

- Safefree (p);

-#define my_mpx_set_svstr(type) \

- static void \

- my_##type##_set_svstr (type##_ptr x, SV *sv) \

- { \

- const char *str; \

- STRLEN len; \

- TRACE (printf (" my_" #type "_set_svstr\n")); \

- assert (SvPOK(sv) || SvPOKp(sv)); \

- str = SvPV (sv, len); \

- TRACE (printf (" str \"%s\"\n", str)); \

- if (type##_set_str (x, str, 0) != 0) \

- croak ("%s: invalid string: %s", type##_class, str); \

- }

-my_mpx_set_svstr(mpz)

-my_mpx_set_svstr(mpq)

-my_mpx_set_svstr(mpf)

-/* very slack */

-static int

-x_mpq_cmp_si (mpq_srcptr x, long yn, unsigned long yd)

- mpq y;

- int ret;

- y = new_mpq ();

- mpq_set_si (y->m, yn, yd);

- ret = mpq_cmp (x, y->m);

- free_mpq (y);

- return ret;

-static int

-x_mpq_fits_slong_p (mpq_srcptr q)

- return x_mpq_cmp_si (q, LONG_MIN, 1L) >= 0

- && mpq_cmp_ui (q, LONG_MAX, 1L) <= 0;

-static int

-x_mpz_cmp_q (mpz_ptr x, mpq_srcptr y)

- int ret;

- mpz_set_ui (mpq_denref(tmp_mpq_0), 1L);

- mpz_swap (mpq_numref(tmp_mpq_0), x);

- ret = mpq_cmp (tmp_mpq_0, y);

- mpz_swap (mpq_numref(tmp_mpq_0), x);

- return ret;

-static int

-x_mpz_cmp_f (mpz_srcptr x, mpf_srcptr y)

- tmp_mpf_set_prec (tmp_mpf_0, mpz_sizeinbase (x, 2));

- mpf_set_z (tmp_mpf_0->m, x);

- return mpf_cmp (tmp_mpf_0->m, y);

-#define USE_UNKNOWN 0

-#define USE_IVX 1

-#define USE_UVX 2

-#define USE_NVX 3

-#define USE_PVX 4

-#define USE_MPZ 5

-#define USE_MPQ 6

-#define USE_MPF 7

-/* mg_get is called every time we get a value, even if the private flags are

- still set from a previous such call. This is the same as as SvIV and

- friends do.

- When POK, we use the PV, even if there's an IV or NV available. This is

- because it's hard to be sure there wasn't any rounding in establishing

- the IV and/or NV. Cases of overflow, where the PV should definitely be

- used, are easy enough to spot, but rounding is hard. So although IV or

- NV would be more efficient, we must use the PV to be sure of getting all

- the data. Applications should convert once to mpz, mpq or mpf when using

- a value repeatedly.

- Zany dual-type scalars like $! where the IV is an error code and the PV

- is an error description string won't work with this preference for PV,

- but that's too bad. Such scalars should be rare, and unlikely to be used

- in bignum calculations.

- When IOK and NOK are both set, we would prefer to use the IV since it can

- be converted more efficiently, and because on a 64-bit system the NV may

- have less bits than the IV. The following rules are applied,

- - If the NV is not an integer, then we must use that NV, since clearly

- the IV was merely established by rounding and is not the full value.

- - In perl prior to 5.8, an NV too big for an IV leaves an overflow value

- 0xFFFFFFFF. If the NV is too big to fit an IV then clearly it's the NV

- which is the true value and must be used.

- - In perl 5.8 and up, such an overflow doesn't set IOK, so that test is

- unnecessary. However when coming from get-magic, IOKp _is_ set, and we

- must check for overflow the same as in older perl.

- FIXME:

- We'd like to call mg_get just once, but unfortunately sv_derived_from()

- will call it for each of our checks. We could do a string compare like

- sv_isa ourselves, but that only tests the exact class, it doesn't

- recognise subclassing. There doesn't seem to be a public interface to

- the subclassing tests (in the internal isa_lookup() function). */

-int

-use_sv (SV *sv)

- double d;

- if (SvGMAGICAL(sv))

- {

- mg_get(sv);

- if (SvPOKp(sv))

- return USE_PVX;

- if (SvIOKp(sv))

- {

- if (SvIsUV(sv))

- {

- if (SvNOKp(sv))

- goto u_or_n;

- return USE_UVX;

- }

- else

- {

- if (SvNOKp(sv))

- goto i_or_n;

- return USE_IVX;

- }

- if (SvNOKp(sv))

- return USE_NVX;

- goto rok_or_unknown;

- }

- if (SvPOK(sv))

- return USE_PVX;

- if (SvIOK(sv))

- {

- if (SvIsUV(sv))

- {

- if (SvNOK(sv))

- {

- if (PERL_LT (5, 8))

- {

- u_or_n:

- d = SvNVX(sv);

- if (d >= ULONG_MAX_P1_AS_DOUBLE || d < 0.0)

- return USE_NVX;

- }

- d = SvNVX(sv);

- if (d != floor (d))

- return USE_NVX;

- }

- return USE_UVX;

- }

- else

- {

- if (SvNOK(sv))

- {

- if (PERL_LT (5, 8))

- {

- i_or_n:

- d = SvNVX(sv);

- if (d >= LONG_MAX_P1_AS_DOUBLE || d < (double) LONG_MIN)

- return USE_NVX;

- }

- d = SvNVX(sv);

- if (d != floor (d))

- return USE_NVX;

- }

- return USE_IVX;

- }

- if (SvNOK(sv))

- return USE_NVX;

- rok_or_unknown:

- if (SvROK(sv))

- {

- if (sv_derived_from (sv, mpz_class))

- return USE_MPZ;

- if (sv_derived_from (sv, mpq_class))

- return USE_MPQ;

- if (sv_derived_from (sv, mpf_class))

- return USE_MPF;

- }

- return USE_UNKNOWN;

-/* Coerce sv to an mpz. Use tmp to hold the converted value if sv isn't

- already an mpz (or an mpq of which the numerator can be used). Return

- the chosen mpz (tmp or the contents of sv). */

-static mpz_ptr

-coerce_mpz_using (mpz_ptr tmp, SV *sv, int use)

- switch (use) {

- case USE_IVX:

- mpz_set_si (tmp, SvIVX(sv));

- return tmp;

- case USE_UVX:

- mpz_set_ui (tmp, SvUVX(sv));

- return tmp;

- case USE_NVX:

- {

- double d;

- d = SvNVX(sv);

- if (! double_integer_p (d))

- croak ("cannot coerce non-integer double to mpz");

- mpz_set_d (tmp, d);

- return tmp;

- }

- case USE_PVX:

- my_mpz_set_svstr (tmp, sv);

- return tmp;

- case USE_MPZ:

- return SvMPZ(sv)->m;

- case USE_MPQ:

- {

- mpq q = SvMPQ(sv);

- if (! x_mpq_integer_p (q->m))

- croak ("cannot coerce non-integer mpq to mpz");

- return mpq_numref(q->m);

- }

- case USE_MPF:

- {

- mpf f = SvMPF(sv);

- if (! mpf_integer_p (f))

- croak ("cannot coerce non-integer mpf to mpz");

- mpz_set_f (tmp, f);

- return tmp;

- }

- default:

- croak ("cannot coerce to mpz");

- }

-static mpz_ptr

-coerce_mpz (mpz_ptr tmp, SV *sv)

- return coerce_mpz_using (tmp, sv, use_sv (sv));

-/* Coerce sv to an mpq. If sv is an mpq then just return that, otherwise

- use tmp to hold the converted value and return that. */

-static mpq_ptr

-coerce_mpq_using (mpq_ptr tmp, SV *sv, int use)

- TRACE (printf ("coerce_mpq_using %p %d\n", tmp, use));

- switch (use) {

- case USE_IVX:

- mpq_set_si (tmp, SvIVX(sv), 1L);

- return tmp;

- case USE_UVX:

- mpq_set_ui (tmp, SvUVX(sv), 1L);

- return tmp;

- case USE_NVX:

- mpq_set_d (tmp, SvNVX(sv));

- return tmp;

- case USE_PVX:

- my_mpq_set_svstr (tmp, sv);

- return tmp;

- case USE_MPZ:

- mpq_set_z (tmp, SvMPZ(sv)->m);

- return tmp;

- case USE_MPQ:

- return SvMPQ(sv)->m;

- case USE_MPF:

- mpq_set_f (tmp, SvMPF(sv));

- return tmp;

- default:

- croak ("cannot coerce to mpq");

- }

-static mpq_ptr

-coerce_mpq (mpq_ptr tmp, SV *sv)

- return coerce_mpq_using (tmp, sv, use_sv (sv));

-static void

-my_mpf_set_sv_using (mpf_ptr f, SV *sv, int use)

- switch (use) {

- case USE_IVX:

- mpf_set_si (f, SvIVX(sv));

- break;

- case USE_UVX:

- mpf_set_ui (f, SvUVX(sv));

- break;

- case USE_NVX:

- mpf_set_d (f, SvNVX(sv));

- break;

- case USE_PVX:

- my_mpf_set_svstr (f, sv);

- break;

- case USE_MPZ:

- mpf_set_z (f, SvMPZ(sv)->m);

- break;

- case USE_MPQ:

- mpf_set_q (f, SvMPQ(sv)->m);

- break;

- case USE_MPF:

- mpf_set (f, SvMPF(sv));

- break;

- default:

- croak ("cannot coerce to mpf");

- }

-/* Coerce sv to an mpf. If sv is an mpf then just return that, otherwise

- use tmp to hold the converted value (with prec precision). */

-static mpf_ptr

-coerce_mpf_using (tmp_mpf_ptr tmp, SV *sv, unsigned long prec, int use)

- if (use == USE_MPF)

- return SvMPF(sv);

- tmp_mpf_set_prec (tmp, prec);

- my_mpf_set_sv_using (tmp->m, sv, use);

- return tmp->m;

-static mpf_ptr

-coerce_mpf (tmp_mpf_ptr tmp, SV *sv, unsigned long prec)

- return coerce_mpf_using (tmp, sv, prec, use_sv (sv));

-/* Coerce xv to an mpf and store the pointer in x, ditto for yv to x. If

- one of xv or yv is an mpf then use it for the precision, otherwise use

- the default precision. */

-unsigned long

-coerce_mpf_pair (mpf *xp, SV *xv, mpf *yp, SV *yv)

- int x_use = use_sv (xv);

- int y_use = use_sv (yv);

- unsigned long prec;

- mpf x, y;

- if (x_use == USE_MPF)

- {

- x = SvMPF(xv);

- prec = mpf_get_prec (x);

- y = coerce_mpf_using (tmp_mpf_0, yv, prec, y_use);

- }

- else

- {

- y = coerce_mpf_using (tmp_mpf_0, yv, mpf_get_default_prec(), y_use);

- prec = mpf_get_prec (y);

- x = coerce_mpf_using (tmp_mpf_1, xv, prec, x_use);

- }

- *xp = x;

- *yp = y;

- return prec;

-/* Note that SvUV is not used, since it merely treats the signed IV as if it

- was unsigned. We get an IV and check its sign. */

-static unsigned long

-coerce_ulong (SV *sv)

- long n;

- switch (use_sv (sv)) {

- case USE_IVX:

- n = SvIVX(sv);

- negative_check:

- if (n < 0)

- goto range_error;

- return n;

- case USE_UVX:

- return SvUVX(sv);

- case USE_NVX:

- {

- double d;

- d = SvNVX(sv);

- if (! double_integer_p (d))

- goto integer_error;

- n = SvIV(sv);

- }

- goto negative_check;

- case USE_PVX:

- /* FIXME: Check the string is an integer. */

- n = SvIV(sv);

- goto negative_check;

- case USE_MPZ:

- {

- mpz z = SvMPZ(sv);

- if (! mpz_fits_ulong_p (z->m))

- goto range_error;

- return mpz_get_ui (z->m);

- }

- case USE_MPQ:

- {

- mpq q = SvMPQ(sv);

- if (! x_mpq_integer_p (q->m))

- goto integer_error;

- if (! mpz_fits_ulong_p (mpq_numref (q->m)))

- goto range_error;

- return mpz_get_ui (mpq_numref (q->m));

- }

- case USE_MPF:

- {

- mpf f = SvMPF(sv);

- if (! mpf_integer_p (f))

- goto integer_error;

- if (! mpf_fits_ulong_p (f))

- goto range_error;

- return mpf_get_ui (f);

- }

- default:

- croak ("cannot coerce to ulong");

- }

- integer_error:

- croak ("not an integer");

- range_error:

- croak ("out of range for ulong");

-static long

-coerce_long (SV *sv)

- switch (use_sv (sv)) {

- case USE_IVX:

- return SvIVX(sv);

- case USE_UVX:

- {

- UV u = SvUVX(sv);

- if (u > (UV) LONG_MAX)

- goto range_error;

- return u;

- }

- case USE_NVX:

- {

- double d = SvNVX(sv);

- if (! double_integer_p (d))

- goto integer_error;

- return SvIV(sv);

- }

- case USE_PVX:

- /* FIXME: Check the string is an integer. */

- return SvIV(sv);

- case USE_MPZ:

- {

- mpz z = SvMPZ(sv);

- if (! mpz_fits_slong_p (z->m))

- goto range_error;

- return mpz_get_si (z->m);

- }

- case USE_MPQ:

- {

- mpq q = SvMPQ(sv);

- if (! x_mpq_integer_p (q->m))

- goto integer_error;

- if (! mpz_fits_slong_p (mpq_numref (q->m)))

- goto range_error;

- return mpz_get_si (mpq_numref (q->m));

- }

- case USE_MPF:

- {

- mpf f = SvMPF(sv);

- if (! mpf_integer_p (f))

- goto integer_error;

- if (! mpf_fits_slong_p (f))

- goto range_error;

- return mpf_get_si (f);

- }

- default:

- croak ("cannot coerce to long");

- }

- integer_error:

- croak ("not an integer");

- range_error:

- croak ("out of range for ulong");

-/* ------------------------------------------------------------------------- */

-MODULE = GMP PACKAGE = GMP

-BOOT:

- TRACE (printf ("GMP boot\n"));

- mp_set_memory_functions (my_gmp_alloc, my_gmp_realloc, my_gmp_free);

- mpz_init (tmp_mpz_0);

- mpz_init (tmp_mpz_1);

- mpz_init (tmp_mpz_2);

- mpq_init (tmp_mpq_0);

- mpq_init (tmp_mpq_1);

- tmp_mpf_init (tmp_mpf_0);

- tmp_mpf_init (tmp_mpf_1);

- mpz_class_hv = gv_stashpv (mpz_class, 1);

- mpq_class_hv = gv_stashpv (mpq_class, 1);

- mpf_class_hv = gv_stashpv (mpf_class, 1);

-void

-END()

-CODE:

- TRACE (printf ("GMP end\n"));

- TRACE_ACTIVE ();

- /* These are not always true, see Bugs at the top of the file. */

- /* assert (mpz_count == 0); */

- /* assert (mpq_count == 0); */

- /* assert (mpf_count == 0); */

- /* assert (rand_count == 0); */

-const_string

-version()

-CODE:

- RETVAL = gmp_version;

-OUTPUT:

- RETVAL

-bool

-fits_slong_p (sv)

- SV *sv

-CODE:

- switch (use_sv (sv)) {

- case USE_IVX:

- RETVAL = 1;

- break;

- case USE_UVX:

- {

- UV u = SvUVX(sv);

- RETVAL = (u <= LONG_MAX);

- }

- break;

- case USE_NVX:

- {

- double d = SvNVX(sv);

- RETVAL = (d >= (double) LONG_MIN && d < LONG_MAX_P1_AS_DOUBLE);

- }

- break;

- case USE_PVX:

- {

- STRLEN len;

- const char *str = SvPV (sv, len);

- if (mpq_set_str (tmp_mpq_0, str, 0) == 0)

- RETVAL = x_mpq_fits_slong_p (tmp_mpq_0);

- else

- {

- /* enough precision for a long */

- tmp_mpf_set_prec (tmp_mpf_0, 2*mp_bits_per_limb);

- if (mpf_set_str (tmp_mpf_0->m, str, 10) != 0)

- croak ("GMP::fits_slong_p invalid string format");

- RETVAL = mpf_fits_slong_p (tmp_mpf_0->m);

- }

- break;

- case USE_MPZ:

- RETVAL = mpz_fits_slong_p (SvMPZ(sv)->m);

- break;

- case USE_MPQ:

- RETVAL = x_mpq_fits_slong_p (SvMPQ(sv)->m);

- break;

- case USE_MPF:

- RETVAL = mpf_fits_slong_p (SvMPF(sv));

- break;

- default:

- croak ("GMP::fits_slong_p invalid argument");

- }

-OUTPUT:

- RETVAL

-double

-get_d (sv)

- SV *sv

-CODE:

- switch (use_sv (sv)) {

- case USE_IVX:

- RETVAL = (double) SvIVX(sv);

- break;

- case USE_UVX:

- RETVAL = (double) SvUVX(sv);

- break;

- case USE_NVX:

- RETVAL = SvNVX(sv);

- break;

- case USE_PVX:

- {

- STRLEN len;

- RETVAL = atof(SvPV(sv, len));

- }

- break;

- case USE_MPZ:

- RETVAL = mpz_get_d (SvMPZ(sv)->m);

- break;

- case USE_MPQ:

- RETVAL = mpq_get_d (SvMPQ(sv)->m);

- break;

- case USE_MPF:

- RETVAL = mpf_get_d (SvMPF(sv));

- break;

- default:

- croak ("GMP::get_d invalid argument");

- }

-OUTPUT:

- RETVAL

-void

-get_d_2exp (sv)

- SV *sv

-PREINIT:

- double ret;

- long exp;

-PPCODE:

- switch (use_sv (sv)) {

- case USE_IVX:

- ret = (double) SvIVX(sv);

- goto use_frexp;

- case USE_UVX:

- ret = (double) SvUVX(sv);

- goto use_frexp;

- case USE_NVX:

- {

- int i_exp;

- ret = SvNVX(sv);

- use_frexp:

- ret = frexp (ret, &i_exp);

- exp = i_exp;

- }

- break;

- case USE_PVX:

- /* put strings through mpf to give full exp range */

- tmp_mpf_set_prec (tmp_mpf_0, DBL_MANT_DIG);

- my_mpf_set_svstr (tmp_mpf_0->m, sv);

- ret = mpf_get_d_2exp (&exp, tmp_mpf_0->m);

- break;

- case USE_MPZ:

- ret = mpz_get_d_2exp (&exp, SvMPZ(sv)->m);

- break;

- case USE_MPQ:

- tmp_mpf_set_prec (tmp_mpf_0, DBL_MANT_DIG);

- mpf_set_q (tmp_mpf_0->m, SvMPQ(sv)->m);

- ret = mpf_get_d_2exp (&exp, tmp_mpf_0->m);

- break;

- case USE_MPF:

- ret = mpf_get_d_2exp (&exp, SvMPF(sv));

- break;

- default:

- croak ("GMP::get_d_2exp invalid argument");

- }

- PUSHs (sv_2mortal (newSVnv (ret)));

- PUSHs (sv_2mortal (newSViv (exp)));

-long

-get_si (sv)

- SV *sv

-CODE:

- switch (use_sv (sv)) {

- case USE_IVX:

- RETVAL = SvIVX(sv);

- break;

- case USE_UVX:

- RETVAL = SvUVX(sv);

- break;

- case USE_NVX:

- RETVAL = (long) SvNVX(sv);

- break;

- case USE_PVX:

- RETVAL = SvIV(sv);

- break;

- case USE_MPZ:

- RETVAL = mpz_get_si (SvMPZ(sv)->m);

- break;

- case USE_MPQ:

- mpz_set_q (tmp_mpz_0, SvMPQ(sv)->m);

- RETVAL = mpz_get_si (tmp_mpz_0);

- break;

- case USE_MPF:

- RETVAL = mpf_get_si (SvMPF(sv));

- break;

- default:

- croak ("GMP::get_si invalid argument");

- }

-OUTPUT:

- RETVAL

-void

-get_str (sv, ...)

- SV *sv

-PREINIT:

- char *str;

- mp_exp_t exp;

- mpz_ptr z;

- mpq_ptr q;

- mpf f;

- int base;

- int ndigits;

-PPCODE:

- TRACE (printf ("GMP::get_str\n"));

- if (items >= 2)

- base = coerce_long (ST(1));

- else

- base = 10;

- TRACE (printf (" base=%d\n", base));

- if (items >= 3)

- ndigits = coerce_long (ST(2));

- else

- ndigits = 10;

- TRACE (printf (" ndigits=%d\n", ndigits));

- EXTEND (SP, 2);

- switch (use_sv (sv)) {

- case USE_IVX:

- mpz_set_si (tmp_mpz_0, SvIVX(sv));

- get_tmp_mpz_0:

- z = tmp_mpz_0;

- goto get_mpz;

- case USE_UVX:

- mpz_set_ui (tmp_mpz_0, SvUVX(sv));

- goto get_tmp_mpz_0;

- case USE_NVX:

- /* only digits in the original double, not in the coerced form */

- if (ndigits == 0)

- ndigits = DBL_DIG;

- mpf_set_d (tmp_mpf_0->m, SvNVX(sv));

- f = tmp_mpf_0->m;

- goto get_mpf;

- case USE_PVX:

- {

- /* get_str on a string is not much more than a base conversion */

- STRLEN len;

- str = SvPV (sv, len);

- if (mpz_set_str (tmp_mpz_0, str, 0) == 0)

- {

- z = tmp_mpz_0;

- goto get_mpz;

- }

- else if (mpq_set_str (tmp_mpq_0, str, 0) == 0)

- {

- q = tmp_mpq_0;

- goto get_mpq;

- }

- else

- {

- /* FIXME: Would like perhaps a precision equivalent to the

- number of significant digits of the string, in its given

- base. */

- tmp_mpf_set_prec (tmp_mpf_0, strlen(str));

- if (mpf_set_str (tmp_mpf_0->m, str, 10) == 0)

- {

- f = tmp_mpf_0->m;

- goto get_mpf;

- }

- else

- croak ("GMP::get_str invalid string format");

- }

- break;

- case USE_MPZ:

- z = SvMPZ(sv)->m;

- get_mpz:

- str = mpz_get_str (NULL, base, z);

- push_str:

- PUSHs (sv_2mortal (newSVpv (str, 0)));

- break;

- case USE_MPQ:

- q = SvMPQ(sv)->m;

- get_mpq:

- str = mpq_get_str (NULL, base, q);

- goto push_str;

- case USE_MPF:

- f = SvMPF(sv);

- get_mpf:

- str = mpf_get_str (NULL, &exp, base, 0, f);

- PUSHs (sv_2mortal (newSVpv (str, 0)));

- PUSHs (sv_2mortal (newSViv (exp)));

- break;

- default:

- croak ("GMP::get_str invalid argument");

- }

-bool

-integer_p (sv)

- SV *sv

-CODE:

- switch (use_sv (sv)) {

- case USE_IVX:

- case USE_UVX:

- RETVAL = 1;

- break;

- case USE_NVX:

- RETVAL = double_integer_p (SvNVX(sv));

- break;

- case USE_PVX:

- {

- /* FIXME: Maybe this should be done by parsing the string, not by an

- actual conversion. */

- STRLEN len;

- const char *str = SvPV (sv, len);

- if (mpq_set_str (tmp_mpq_0, str, 0) == 0)

- RETVAL = x_mpq_integer_p (tmp_mpq_0);

- else

- {

- /* enough for all digits of the string */

- tmp_mpf_set_prec (tmp_mpf_0, strlen(str)+64);

- if (mpf_set_str (tmp_mpf_0->m, str, 10) == 0)

- RETVAL = mpf_integer_p (tmp_mpf_0->m);

- else

- croak ("GMP::integer_p invalid string format");

- }

- break;

- case USE_MPZ:

- RETVAL = 1;

- break;

- case USE_MPQ:

- RETVAL = x_mpq_integer_p (SvMPQ(sv)->m);

- break;

- case USE_MPF:

- RETVAL = mpf_integer_p (SvMPF(sv));

- break;

- default:

- croak ("GMP::integer_p invalid argument");

- }

-OUTPUT:

- RETVAL

-int

-sgn (sv)

- SV *sv

-CODE:

- switch (use_sv (sv)) {

- case USE_IVX:

- RETVAL = SGN (SvIVX(sv));

- break;

- case USE_UVX:

- RETVAL = (SvUVX(sv) > 0);

- break;

- case USE_NVX:

- RETVAL = SGN (SvNVX(sv));

- break;

- case USE_PVX:

- {

- /* FIXME: Maybe this should be done by parsing the string, not by an

- actual conversion. */

- STRLEN len;

- const char *str = SvPV (sv, len);

- if (mpq_set_str (tmp_mpq_0, str, 0) == 0)

- RETVAL = mpq_sgn (tmp_mpq_0);

- else

- {

- /* enough for all digits of the string */

- tmp_mpf_set_prec (tmp_mpf_0, strlen(str)+64);

- if (mpf_set_str (tmp_mpf_0->m, str, 10) == 0)

- RETVAL = mpf_sgn (tmp_mpf_0->m);

- else

- croak ("GMP::sgn invalid string format");

- }

- break;

- case USE_MPZ:

- RETVAL = mpz_sgn (SvMPZ(sv)->m);

- break;

- case USE_MPQ:

- RETVAL = mpq_sgn (SvMPQ(sv)->m);

- break;

- case USE_MPF:

- RETVAL = mpf_sgn (SvMPF(sv));

- break;

- default:

- croak ("GMP::sgn invalid argument");

- }

-OUTPUT:

- RETVAL

-# currently undocumented

-void

-shrink ()

-CODE:

-#define x_mpz_shrink(z) \

- mpz_set_ui (z, 0L); _mpz_realloc (z, 1)

-#define x_mpq_shrink(q) \

- x_mpz_shrink (mpq_numref(q)); x_mpz_shrink (mpq_denref(q))

- x_mpz_shrink (tmp_mpz_0);

- x_mpz_shrink (tmp_mpz_1);

- x_mpz_shrink (tmp_mpz_2);

- x_mpq_shrink (tmp_mpq_0);

- x_mpq_shrink (tmp_mpq_1);

- tmp_mpf_shrink (tmp_mpf_0);

- tmp_mpf_shrink (tmp_mpf_1);

-malloced_string

-sprintf_internal (fmt, sv)

- const_string fmt

- SV *sv

-CODE:

- assert (strlen (fmt) >= 3);

- assert (SvROK(sv));

- assert ((sv_derived_from (sv, mpz_class) && fmt[strlen(fmt)-2] == 'Z')

- || (sv_derived_from (sv, mpq_class) && fmt[strlen(fmt)-2] == 'Q')

- || (sv_derived_from (sv, mpf_class) && fmt[strlen(fmt)-2] == 'F'));

- TRACE (printf ("GMP::sprintf_internal\n");

- printf (" fmt |%s|\n", fmt);

- printf (" sv |%p|\n", SvMPZ(sv)));

- /* cheat a bit here, SvMPZ works for mpq and mpf too */

- gmp_asprintf (&RETVAL, fmt, SvMPZ(sv));

- TRACE (printf (" result |%s|\n", RETVAL));

-OUTPUT:

- RETVAL

-#------------------------------------------------------------------------------

-MODULE = GMP PACKAGE = GMP::Mpz

-mpz

-mpz (...)

-ALIAS:

- GMP::Mpz::new = 1

-PREINIT:

- SV *sv;

-CODE:

- TRACE (printf ("%s new, ix=%ld, items=%d\n", mpz_class, ix, (int) items));

- RETVAL = new_mpz();

- switch (items) {

- case 0:

- mpz_set_ui (RETVAL->m, 0L);

- break;

- case 1:

- sv = ST(0);

- TRACE (printf (" use %d\n", use_sv (sv)));

- switch (use_sv (sv)) {

- case USE_IVX:

- mpz_set_si (RETVAL->m, SvIVX(sv));

- break;

- case USE_UVX:

- mpz_set_ui (RETVAL->m, SvUVX(sv));

- break;

- case USE_NVX:

- mpz_set_d (RETVAL->m, SvNVX(sv));

- break;

- case USE_PVX:

- my_mpz_set_svstr (RETVAL->m, sv);

- break;

- case USE_MPZ:

- mpz_set (RETVAL->m, SvMPZ(sv)->m);

- break;

- case USE_MPQ:

- mpz_set_q (RETVAL->m, SvMPQ(sv)->m);

- break;

- case USE_MPF:

- mpz_set_f (RETVAL->m, SvMPF(sv));

- break;

- default:

- goto invalid;

- }

- break;

- default:

- invalid:

- croak ("%s new: invalid arguments", mpz_class);

- }

-OUTPUT:

- RETVAL

-void

-overload_constant (str, pv, d1, ...)

- const_string_assume str

- SV *pv

- dummy d1

-PREINIT:

- mpz z;

-PPCODE:

- TRACE (printf ("%s constant: %s\n", mpz_class, str));

- z = new_mpz();

- if (mpz_set_str (z->m, str, 0) == 0)

- {

- PUSHs (MPX_NEWMORTAL (z, mpz_class_hv));

- }

- else

- {

- free_mpz (z);

- PUSHs(pv);

- }

-mpz

-overload_copy (z, d1, d2)

- mpz_assume z

- dummy d1

- dummy d2

-CODE:

- RETVAL = new_mpz();

- mpz_set (RETVAL->m, z->m);

-OUTPUT:

- RETVAL

-void

-DESTROY (z)

- mpz_assume z

-CODE:

- TRACE (printf ("%s DESTROY %p\n", mpz_class, z));

- free_mpz (z);

-malloced_string

-overload_string (z, d1, d2)

- mpz_assume z

- dummy d1

- dummy d2

-CODE:

- TRACE (printf ("%s overload_string %p\n", mpz_class, z));

- RETVAL = mpz_get_str (NULL, 10, z->m);

-OUTPUT:

- RETVAL

-mpz

-overload_add (xv, yv, order)

- SV *xv

- SV *yv

- SV *order

-ALIAS:

- GMP::Mpz::overload_sub = 1

- GMP::Mpz::overload_mul = 2

- GMP::Mpz::overload_div = 3

- GMP::Mpz::overload_rem = 4

- GMP::Mpz::overload_and = 5

- GMP::Mpz::overload_ior = 6

- GMP::Mpz::overload_xor = 7

-PREINIT:

- static_functable const struct {

- void (*op) (mpz_ptr, mpz_srcptr, mpz_srcptr);

- } table[] = {

- { mpz_add }, /* 0 */

- { mpz_sub }, /* 1 */

- { mpz_mul }, /* 2 */

- { mpz_tdiv_q }, /* 3 */

- { mpz_tdiv_r }, /* 4 */

- { mpz_and }, /* 5 */

- { mpz_ior }, /* 6 */

- { mpz_xor }, /* 7 */

- };

-CODE:

- assert_table (ix);

- if (order == &PL_sv_yes)

- SV_PTR_SWAP (xv, yv);

- RETVAL = new_mpz();

- (*table[ix].op) (RETVAL->m,

- coerce_mpz (tmp_mpz_0, xv),

- coerce_mpz (tmp_mpz_1, yv));

-OUTPUT:

- RETVAL

-void

-overload_addeq (x, y, o)

- mpz_assume x

- mpz_coerce y

- order_noswap o

-ALIAS:

- GMP::Mpz::overload_subeq = 1

- GMP::Mpz::overload_muleq = 2

- GMP::Mpz::overload_diveq = 3

- GMP::Mpz::overload_remeq = 4

- GMP::Mpz::overload_andeq = 5

- GMP::Mpz::overload_ioreq = 6

- GMP::Mpz::overload_xoreq = 7

-PREINIT:

- static_functable const struct {

- void (*op) (mpz_ptr, mpz_srcptr, mpz_srcptr);

- } table[] = {

- { mpz_add }, /* 0 */

- { mpz_sub }, /* 1 */

- { mpz_mul }, /* 2 */

- { mpz_tdiv_q }, /* 3 */

- { mpz_tdiv_r }, /* 4 */

- { mpz_and }, /* 5 */

- { mpz_ior }, /* 6 */

- { mpz_xor }, /* 7 */

- };

-PPCODE:

- assert_table (ix);

- (*table[ix].op) (x->m, x->m, y);

- XPUSHs (ST(0));

-mpz

-overload_lshift (zv, nv, order)

- SV *zv

- SV *nv

- SV *order

-ALIAS:

- GMP::Mpz::overload_rshift = 1

- GMP::Mpz::overload_pow = 2

-PREINIT:

- static_functable const struct {

- void (*op) (mpz_ptr, mpz_srcptr, unsigned long);

- } table[] = {

- { mpz_mul_2exp }, /* 0 */

- { mpz_div_2exp }, /* 1 */

- { mpz_pow_ui }, /* 2 */

- };

-CODE:

- assert_table (ix);

- if (order == &PL_sv_yes)

- SV_PTR_SWAP (zv, nv);

- RETVAL = new_mpz();

- (*table[ix].op) (RETVAL->m, coerce_mpz (RETVAL->m, zv), coerce_ulong (nv));

-OUTPUT:

- RETVAL

-void

-overload_lshifteq (z, n, o)

- mpz_assume z

- ulong_coerce n

- order_noswap o

-ALIAS:

- GMP::Mpz::overload_rshifteq = 1

- GMP::Mpz::overload_poweq = 2

-PREINIT:

- static_functable const struct {

- void (*op) (mpz_ptr, mpz_srcptr, unsigned long);

- } table[] = {

- { mpz_mul_2exp }, /* 0 */

- { mpz_div_2exp }, /* 1 */

- { mpz_pow_ui }, /* 2 */

- };

-PPCODE:

- assert_table (ix);

- (*table[ix].op) (z->m, z->m, n);

- XPUSHs(ST(0));

-mpz

-overload_abs (z, d1, d2)

- mpz_assume z

- dummy d1

- dummy d2

-ALIAS:

- GMP::Mpz::overload_neg = 1

- GMP::Mpz::overload_com = 2

- GMP::Mpz::overload_sqrt = 3

-PREINIT:

- static_functable const struct {

- void (*op) (mpz_ptr w, mpz_srcptr x);

- } table[] = {

- { mpz_abs }, /* 0 */

- { mpz_neg }, /* 1 */

- { mpz_com }, /* 2 */

- { mpz_sqrt }, /* 3 */

- };

-CODE:

- assert_table (ix);

- RETVAL = new_mpz();

- (*table[ix].op) (RETVAL->m, z->m);

-OUTPUT:

- RETVAL

-void

-overload_inc (z, d1, d2)

- mpz_assume z

- dummy d1

- dummy d2

-ALIAS:

- GMP::Mpz::overload_dec = 1

-PREINIT:

- static_functable const struct {

- void (*op) (mpz_ptr w, mpz_srcptr x, unsigned long y);

- } table[] = {

- { mpz_add_ui }, /* 0 */

- { mpz_sub_ui }, /* 1 */

- };

-CODE:

- assert_table (ix);

- (*table[ix].op) (z->m, z->m, 1L);

-int

-overload_spaceship (xv, yv, order)

- SV *xv

- SV *yv

- SV *order

-PREINIT:

- mpz x;

-CODE:

- TRACE (printf ("%s overload_spaceship\n", mpz_class));

- MPZ_ASSUME (x, xv);

- switch (use_sv (yv)) {

- case USE_IVX:

- RETVAL = mpz_cmp_si (x->m, SvIVX(yv));

- break;

- case USE_UVX:

- RETVAL = mpz_cmp_ui (x->m, SvUVX(yv));

- break;

- case USE_PVX:

- RETVAL = mpz_cmp (x->m, coerce_mpz (tmp_mpz_0, yv));

- break;

- case USE_NVX:

- RETVAL = mpz_cmp_d (x->m, SvNVX(yv));

- break;

- case USE_MPZ:

- RETVAL = mpz_cmp (x->m, SvMPZ(yv)->m);

- break;

- case USE_MPQ:

- RETVAL = x_mpz_cmp_q (x->m, SvMPQ(yv)->m);

- break;

- case USE_MPF:

- RETVAL = x_mpz_cmp_f (x->m, SvMPF(yv));

- break;

- default:

- croak ("%s <=>: invalid operand", mpz_class);

- }

- RETVAL = SGN (RETVAL);

- if (order == &PL_sv_yes)

- RETVAL = -RETVAL;

-OUTPUT:

- RETVAL

-bool

-overload_bool (z, d1, d2)

- mpz_assume z

- dummy d1

- dummy d2

-ALIAS:

- GMP::Mpz::overload_not = 1

-CODE:

- RETVAL = (mpz_sgn (z->m) != 0) ^ ix;

-OUTPUT:

- RETVAL

-mpz

-bin (n, k)

- mpz_coerce n

- ulong_coerce k

-ALIAS:

- GMP::Mpz::root = 1

-PREINIT:

- /* mpz_root returns an int, hence the cast */

- static_functable const struct {

- void (*op) (mpz_ptr, mpz_srcptr, unsigned long);

- } table[] = {

- { mpz_bin_ui }, /* 0 */

- { (void (*)(mpz_ptr, mpz_srcptr, unsigned long)) mpz_root }, /* 1 */

- };

-CODE:

- assert_table (ix);

- RETVAL = new_mpz();

- (*table[ix].op) (RETVAL->m, n, k);

-OUTPUT:

- RETVAL

-void

-cdiv (a, d)

- mpz_coerce a

- mpz_coerce d

-ALIAS:

- GMP::Mpz::fdiv = 1

- GMP::Mpz::tdiv = 2

-PREINIT:

- static_functable const struct {

- void (*op) (mpz_ptr, mpz_ptr, mpz_srcptr, mpz_srcptr);

- } table[] = {

- { mpz_cdiv_qr }, /* 0 */

- { mpz_fdiv_qr }, /* 1 */

- { mpz_tdiv_qr }, /* 2 */

- };

- mpz q, r;

-PPCODE:

- assert_table (ix);

- q = new_mpz();

- r = new_mpz();

- (*table[ix].op) (q->m, r->m, a, d);

- EXTEND (SP, 2);

- PUSHs (MPX_NEWMORTAL (q, mpz_class_hv));

- PUSHs (MPX_NEWMORTAL (r, mpz_class_hv));

-void

-cdiv_2exp (a, d)

- mpz_coerce a

- ulong_coerce d

-ALIAS:

- GMP::Mpz::fdiv_2exp = 1

- GMP::Mpz::tdiv_2exp = 2

-PREINIT:

- static_functable const struct {

- void (*q) (mpz_ptr, mpz_srcptr, unsigned long);

- void (*r) (mpz_ptr, mpz_srcptr, unsigned long);

- } table[] = {

- { mpz_cdiv_q_2exp, mpz_cdiv_r_2exp }, /* 0 */

- { mpz_fdiv_q_2exp, mpz_fdiv_r_2exp }, /* 1 */

- { mpz_tdiv_q_2exp, mpz_tdiv_r_2exp }, /* 2 */

- };

- mpz q, r;

-PPCODE:

- assert_table (ix);

- q = new_mpz();

- r = new_mpz();

- (*table[ix].q) (q->m, a, d);

- (*table[ix].r) (r->m, a, d);

- EXTEND (SP, 2);

- PUSHs (MPX_NEWMORTAL (q, mpz_class_hv));

- PUSHs (MPX_NEWMORTAL (r, mpz_class_hv));

-bool

-congruent_p (a, c, d)

- mpz_coerce a

- mpz_coerce c

- mpz_coerce d

-PREINIT:

-CODE:

- RETVAL = mpz_congruent_p (a, c, d);

-OUTPUT:

- RETVAL

-bool

-congruent_2exp_p (a, c, d)

- mpz_coerce a

- mpz_coerce c

- ulong_coerce d

-PREINIT:

-CODE:

- RETVAL = mpz_congruent_2exp_p (a, c, d);

-OUTPUT:

- RETVAL

-mpz

-divexact (a, d)

- mpz_coerce a

- mpz_coerce d

-ALIAS:

- GMP::Mpz::mod = 1

-PREINIT:

- static_functable const struct {

- void (*op) (mpz_ptr, mpz_srcptr, mpz_srcptr);

- } table[] = {

- { mpz_divexact }, /* 0 */

- { mpz_mod }, /* 1 */

- };

-CODE:

- assert_table (ix);

- RETVAL = new_mpz();

- (*table[ix].op) (RETVAL->m, a, d);

-OUTPUT:

- RETVAL

-bool

-divisible_p (a, d)

- mpz_coerce a

- mpz_coerce d

-CODE:

- RETVAL = mpz_divisible_p (a, d);

-OUTPUT:

- RETVAL

-bool

-divisible_2exp_p (a, d)

- mpz_coerce a

- ulong_coerce d

-CODE:

- RETVAL = mpz_divisible_2exp_p (a, d);

-OUTPUT:

- RETVAL

-bool

-even_p (z)

- mpz_coerce z

-ALIAS:

- GMP::Mpz::odd_p = 1

- GMP::Mpz::perfect_square_p = 2

- GMP::Mpz::perfect_power_p = 3

-PREINIT:

- static_functable const struct {

- int (*op) (mpz_srcptr z);

- } table[] = {

- { x_mpz_even_p }, /* 0 */

- { x_mpz_odd_p }, /* 1 */

- { mpz_perfect_square_p }, /* 2 */

- { mpz_perfect_power_p }, /* 3 */

- };

-CODE:

- assert_table (ix);

- RETVAL = (*table[ix].op) (z);

-OUTPUT:

- RETVAL

-mpz

-fac (n)

- ulong_coerce n

-ALIAS:

- GMP::Mpz::fib = 1

- GMP::Mpz::lucnum = 2

-PREINIT:

- static_functable const struct {

- void (*op) (mpz_ptr r, unsigned long n);

- } table[] = {

- { mpz_fac_ui }, /* 0 */

- { mpz_fib_ui }, /* 1 */

- { mpz_lucnum_ui }, /* 2 */

- };

-CODE:

- assert_table (ix);

- RETVAL = new_mpz();

- (*table[ix].op) (RETVAL->m, n);

-OUTPUT:

- RETVAL

-void

-fib2 (n)

- ulong_coerce n

-ALIAS:

- GMP::Mpz::lucnum2 = 1

-PREINIT:

- static_functable const struct {

- void (*op) (mpz_ptr r, mpz_ptr r2, unsigned long n);

- } table[] = {

- { mpz_fib2_ui }, /* 0 */

- { mpz_lucnum2_ui }, /* 1 */

- };

- mpz r, r2;

-PPCODE:

- assert_table (ix);

- r = new_mpz();

- r2 = new_mpz();

- (*table[ix].op) (r->m, r2->m, n);

- EXTEND (SP, 2);

- PUSHs (MPX_NEWMORTAL (r, mpz_class_hv));

- PUSHs (MPX_NEWMORTAL (r2, mpz_class_hv));

-mpz

-gcd (x, ...)

- mpz_coerce x

-ALIAS:

- GMP::Mpz::lcm = 1

-PREINIT:

- static_functable const struct {

- void (*op) (mpz_ptr w, mpz_srcptr x, mpz_srcptr y);

- void (*op_ui) (mpz_ptr w, mpz_srcptr x, unsigned long y);

- } table[] = {

- /* cast to ignore ulong return from mpz_gcd_ui */

- { mpz_gcd,

- (void (*) (mpz_ptr, mpz_srcptr, unsigned long)) mpz_gcd_ui }, /* 0 */

- { mpz_lcm, mpz_lcm_ui }, /* 1 */

- };

- int i;

- SV *yv;

-CODE:

- assert_table (ix);

- RETVAL = new_mpz();

- if (items == 1)

- mpz_set (RETVAL->m, x);

- else

- {

- for (i = 1; i < items; i++)

- {

- yv = ST(i);

- if (SvIOK(yv))

- (*table[ix].op_ui) (RETVAL->m, x, ABS(SvIVX(yv)));

- else

- (*table[ix].op) (RETVAL->m, x, coerce_mpz (tmp_mpz_1, yv));

- x = RETVAL->m;

- }

-OUTPUT:

- RETVAL

-void

-gcdext (a, b)

- mpz_coerce a

- mpz_coerce b

-PREINIT:

- mpz g, x, y;

- SV *sv;

-PPCODE:

- g = new_mpz();

- x = new_mpz();

- y = new_mpz();

- mpz_gcdext (g->m, x->m, y->m, a, b);

- EXTEND (SP, 3);

- PUSHs (MPX_NEWMORTAL (g, mpz_class_hv));

- PUSHs (MPX_NEWMORTAL (x, mpz_class_hv));

- PUSHs (MPX_NEWMORTAL (y, mpz_class_hv));

-unsigned long

-hamdist (x, y)

- mpz_coerce x

- mpz_coerce y

-CODE:

- RETVAL = mpz_hamdist (x, y);

-OUTPUT:

- RETVAL

-mpz

-invert (a, m)

- mpz_coerce a

- mpz_coerce m

-CODE:

- RETVAL = new_mpz();

- if (! mpz_invert (RETVAL->m, a, m))

- {

- free_mpz (RETVAL);

- XSRETURN_UNDEF;

- }

-OUTPUT:

- RETVAL

-int

-jacobi (a, b)

- mpz_coerce a

- mpz_coerce b

-CODE:

- RETVAL = mpz_jacobi (a, b);

-OUTPUT:

- RETVAL

-int

-kronecker (a, b)

- SV *a

- SV *b

-CODE:

- if (SvIOK(b))

- RETVAL = mpz_kronecker_si (coerce_mpz(tmp_mpz_0,a), SvIVX(b));

- else if (SvIOK(a))

- RETVAL = mpz_si_kronecker (SvIVX(a), coerce_mpz(tmp_mpz_0,b));

- else

- RETVAL = mpz_kronecker (coerce_mpz(tmp_mpz_0,a),

- coerce_mpz(tmp_mpz_1,b));

-OUTPUT:

- RETVAL

-void

-mpz_export (order, size, endian, nails, z)

- int order

- size_t size

- int endian

- size_t nails

- mpz_coerce z

-PREINIT:

- size_t numb, count, bytes, actual_count;

- char *data;

- SV *sv;

-PPCODE:

- numb = 8*size - nails;

- count = (mpz_sizeinbase (z, 2) + numb-1) / numb;

- bytes = count * size;

- New (GMP_MALLOC_ID, data, bytes+1, char);

- mpz_export (data, &actual_count, order, size, endian, nails, z);

- assert (count == actual_count);

- data[bytes] = '\0';

- sv = sv_newmortal(); sv_usepvn_mg (sv, data, bytes); PUSHs(sv);

-mpz

-mpz_import (order, size, endian, nails, sv)

- int order

- size_t size

- int endian

- size_t nails

- SV *sv

-PREINIT:

- size_t count;

- const char *data;

- STRLEN len;

-CODE:

- data = SvPV (sv, len);

- if ((len % size) != 0)

- croak ("%s mpz_import: string not a multiple of the given size",

- mpz_class);

- count = len / size;

- RETVAL = new_mpz();

- mpz_import (RETVAL->m, count, order, size, endian, nails, data);

-OUTPUT:

- RETVAL

-mpz

-nextprime (z)

- mpz_coerce z

-CODE:

- RETVAL = new_mpz();

- mpz_nextprime (RETVAL->m, z);

-OUTPUT:

- RETVAL

-unsigned long

-popcount (x)

- mpz_coerce x

-CODE:

- RETVAL = mpz_popcount (x);

-OUTPUT:

- RETVAL

-mpz

-powm (b, e, m)

- mpz_coerce b

- mpz_coerce e

- mpz_coerce m

-CODE:

- RETVAL = new_mpz();

- mpz_powm (RETVAL->m, b, e, m);

-OUTPUT:

- RETVAL

-bool

-probab_prime_p (z, n)

- mpz_coerce z

- ulong_coerce n

-CODE:

- RETVAL = mpz_probab_prime_p (z, n);

-OUTPUT:

- RETVAL

-# No attempt to coerce here, only an mpz makes sense.

-void

-realloc (z, limbs)

- mpz z

- int limbs

-CODE:

- _mpz_realloc (z->m, limbs);

-void

-remove (z, f)

- mpz_coerce z

- mpz_coerce f

-PREINIT:

- SV *sv;

- mpz rem;

- unsigned long mult;

-PPCODE:

- rem = new_mpz();

- mult = mpz_remove (rem->m, z, f);

- EXTEND (SP, 2);

- PUSHs (MPX_NEWMORTAL (rem, mpz_class_hv));

- PUSHs (sv_2mortal (newSViv (mult)));

-void

-roote (z, n)

- mpz_coerce z

- ulong_coerce n

-PREINIT:

- SV *sv;

- mpz root;

- int exact;

-PPCODE:

- root = new_mpz();

- exact = mpz_root (root->m, z, n);

- EXTEND (SP, 2);

- PUSHs (MPX_NEWMORTAL (root, mpz_class_hv));

- sv = (exact ? &PL_sv_yes : &PL_sv_no); sv_2mortal(sv); PUSHs(sv);

-void

-rootrem (z, n)

- mpz_coerce z

- ulong_coerce n

-PREINIT:

- SV *sv;

- mpz root;

- mpz rem;

-PPCODE:

- root = new_mpz();

- rem = new_mpz();

- mpz_rootrem (root->m, rem->m, z, n);

- EXTEND (SP, 2);

- PUSHs (MPX_NEWMORTAL (root, mpz_class_hv));

- PUSHs (MPX_NEWMORTAL (rem, mpz_class_hv));

-# In the past scan0 and scan1 were described as returning ULONG_MAX which

-# could be obtained in perl with ~0. That wasn't true on 64-bit systems

-# (eg. alpha) with perl 5.005, since in that version IV and UV were still

-# 32-bits.

-# We changed in gmp 4.2 to just say ~0 for the not-found return. It's

-# likely most people have used ~0 rather than POSIX::ULONG_MAX(), so this

-# change should match existing usage. It only actually makes a difference

-# in old perl, since recent versions have gone to 64-bits for IV and UV, the

-# same as a ulong.

-# In perl 5.005 we explicitly mask the mpz return down to 32-bits to get ~0.

-# UV_MAX is no good, it reflects the size of the UV type (64-bits), rather

-# than the size of the values one ought to be storing in an SV (32-bits).

-gmp_UV

-scan0 (z, start)

- mpz_coerce z

- ulong_coerce start

-ALIAS:

- GMP::Mpz::scan1 = 1

-PREINIT:

- static_functable const struct {

- unsigned long (*op) (mpz_srcptr, unsigned long);

- } table[] = {

- { mpz_scan0 }, /* 0 */

- { mpz_scan1 }, /* 1 */

- };

-CODE:

- assert_table (ix);

- RETVAL = (*table[ix].op) (z, start);

- if (PERL_LT (5,6))

- RETVAL &= 0xFFFFFFFF;

-OUTPUT:

- RETVAL

-void

-setbit (sv, bit)

- SV *sv

- ulong_coerce bit

-ALIAS:

- GMP::Mpz::clrbit = 1

- GMP::Mpz::combit = 2

-PREINIT:

- static_functable const struct {

- void (*op) (mpz_ptr, unsigned long);

- } table[] = {

- { mpz_setbit }, /* 0 */

- { mpz_clrbit }, /* 1 */

- { mpz_combit }, /* 2 */

- };

- int use;

- mpz z;

-CODE:

- use = use_sv (sv);

- if (use == USE_MPZ && SvREFCNT(SvRV(sv)) == 1 && ! SvSMAGICAL(sv))

- {

- /* our operand is a non-magical mpz with a reference count of 1, so

- we can just modify it */

- (*table[ix].op) (SvMPZ(sv)->m, bit);

- }

- else

- {

- /* otherwise we need to make a new mpz, from whatever we have, and

- operate on that, possibly invoking magic when storing back */

- SV *new_sv;

- mpz z = new_mpz ();

- mpz_ptr coerce_ptr = coerce_mpz_using (z->m, sv, use);

- if (coerce_ptr != z->m)

- mpz_set (z->m, coerce_ptr);

- (*table[ix].op) (z->m, bit);

- new_sv = sv_bless (sv_setref_pv (sv_newmortal(), NULL, z),

- mpz_class_hv);

- SvSetMagicSV (sv, new_sv);

- }

-void

-sqrtrem (z)

- mpz_coerce z

-PREINIT:

- SV *sv;

- mpz root;

- mpz rem;

-PPCODE:

- root = new_mpz();

- rem = new_mpz();

- mpz_sqrtrem (root->m, rem->m, z);

- EXTEND (SP, 2);

- PUSHs (MPX_NEWMORTAL (root, mpz_class_hv));

- PUSHs (MPX_NEWMORTAL (rem, mpz_class_hv));

-size_t

-sizeinbase (z, base)

- mpz_coerce z

- int base

-CODE:

- RETVAL = mpz_sizeinbase (z, base);

-OUTPUT:

- RETVAL

-int

-tstbit (z, bit)

- mpz_coerce z

- ulong_coerce bit

-CODE:

- RETVAL = mpz_tstbit (z, bit);

-OUTPUT:

- RETVAL

-#------------------------------------------------------------------------------

-MODULE = GMP PACKAGE = GMP::Mpq

-mpq

-mpq (...)

-ALIAS:

- GMP::Mpq::new = 1

-CODE:

- TRACE (printf ("%s new, ix=%ld, items=%d\n", mpq_class, ix, (int) items));

- RETVAL = new_mpq();

- switch (items) {

- case 0:

- mpq_set_ui (RETVAL->m, 0L, 1L);

- break;

- case 1:

- {

- mpq_ptr rp = RETVAL->m;

- mpq_ptr cp = coerce_mpq (rp, ST(0));

- if (cp != rp)

- mpq_set (rp, cp);

- }

- break;

- case 2:

- {

- mpz_ptr rp, cp;

- rp = mpq_numref (RETVAL->m);

- cp = coerce_mpz (rp, ST(0));

- if (cp != rp)

- mpz_set (rp, cp);

- rp = mpq_denref (RETVAL->m);

- cp = coerce_mpz (rp, ST(1));

- if (cp != rp)

- mpz_set (rp, cp);

- }

- break;

- default:

- croak ("%s new: invalid arguments", mpq_class);

- }

-OUTPUT:

- RETVAL

-void

-overload_constant (str, pv, d1, ...)

- const_string_assume str

- SV *pv

- dummy d1

-PREINIT:

- SV *sv;

- mpq q;

-PPCODE:

- TRACE (printf ("%s constant: %s\n", mpq_class, str));

- q = new_mpq();

- if (mpq_set_str (q->m, str, 0) == 0)

- { sv = sv_bless (sv_setref_pv (sv_newmortal(), NULL, q), mpq_class_hv); }

- else

- { free_mpq (q); sv = pv; }

- XPUSHs(sv);

-mpq

-overload_copy (q, d1, d2)

- mpq_assume q

- dummy d1

- dummy d2

-CODE:

- RETVAL = new_mpq();

- mpq_set (RETVAL->m, q->m);

-OUTPUT:

- RETVAL

-void

-DESTROY (q)

- mpq_assume q

-CODE:

- TRACE (printf ("%s DESTROY %p\n", mpq_class, q));

- free_mpq (q);

-malloced_string

-overload_string (q, d1, d2)

- mpq_assume q

- dummy d1

- dummy d2

-CODE:

- TRACE (printf ("%s overload_string %p\n", mpq_class, q));

- RETVAL = mpq_get_str (NULL, 10, q->m);

-OUTPUT:

- RETVAL

-mpq

-overload_add (xv, yv, order)

- SV *xv

- SV *yv

- SV *order

-ALIAS:

- GMP::Mpq::overload_sub = 1

- GMP::Mpq::overload_mul = 2

- GMP::Mpq::overload_div = 3

-PREINIT:

- static_functable const struct {

- void (*op) (mpq_ptr, mpq_srcptr, mpq_srcptr);

- } table[] = {

- { mpq_add }, /* 0 */

- { mpq_sub }, /* 1 */

- { mpq_mul }, /* 2 */

- { mpq_div }, /* 3 */

- };

-CODE:

- TRACE (printf ("%s binary\n", mpf_class));

- assert_table (ix);

- if (order == &PL_sv_yes)

- SV_PTR_SWAP (xv, yv);

- RETVAL = new_mpq();

- (*table[ix].op) (RETVAL->m,

- coerce_mpq (tmp_mpq_0, xv),

- coerce_mpq (tmp_mpq_1, yv));

-OUTPUT:

- RETVAL

-void

-overload_addeq (x, y, o)

- mpq_assume x

- mpq_coerce y

- order_noswap o

-ALIAS:

- GMP::Mpq::overload_subeq = 1

- GMP::Mpq::overload_muleq = 2

- GMP::Mpq::overload_diveq = 3

-PREINIT:

- static_functable const struct {

- void (*op) (mpq_ptr, mpq_srcptr, mpq_srcptr);

- } table[] = {

- { mpq_add }, /* 0 */

- { mpq_sub }, /* 1 */

- { mpq_mul }, /* 2 */

- { mpq_div }, /* 3 */

- };

-PPCODE:

- assert_table (ix);

- (*table[ix].op) (x->m, x->m, y);

- XPUSHs(ST(0));

-mpq

-overload_lshift (qv, nv, order)

- SV *qv

- SV *nv

- SV *order

-ALIAS:

- GMP::Mpq::overload_rshift = 1

- GMP::Mpq::overload_pow = 2

-PREINIT:

- static_functable const struct {

- void (*op) (mpq_ptr, mpq_srcptr, unsigned long);

- } table[] = {

- { mpq_mul_2exp }, /* 0 */

- { mpq_div_2exp }, /* 1 */

- { x_mpq_pow_ui }, /* 2 */

- };

-CODE:

- assert_table (ix);

- if (order == &PL_sv_yes)

- SV_PTR_SWAP (qv, nv);

- RETVAL = new_mpq();

- (*table[ix].op) (RETVAL->m, coerce_mpq (RETVAL->m, qv), coerce_ulong (nv));

-OUTPUT:

- RETVAL

-void

-overload_lshifteq (q, n, o)

- mpq_assume q

- ulong_coerce n

- order_noswap o

-ALIAS:

- GMP::Mpq::overload_rshifteq = 1

- GMP::Mpq::overload_poweq = 2

-PREINIT:

- static_functable const struct {

- void (*op) (mpq_ptr, mpq_srcptr, unsigned long);

- } table[] = {

- { mpq_mul_2exp }, /* 0 */

- { mpq_div_2exp }, /* 1 */

- { x_mpq_pow_ui }, /* 2 */

- };

-PPCODE:

- assert_table (ix);

- (*table[ix].op) (q->m, q->m, n);

- XPUSHs(ST(0));

-void

-overload_inc (q, d1, d2)

- mpq_assume q

- dummy d1

- dummy d2

-ALIAS:

- GMP::Mpq::overload_dec = 1

-PREINIT:

- static_functable const struct {

- void (*op) (mpz_ptr, mpz_srcptr, mpz_srcptr);

- } table[] = {

- { mpz_add }, /* 0 */

- { mpz_sub }, /* 1 */

- };

-CODE:

- assert_table (ix);

- (*table[ix].op) (mpq_numref(q->m), mpq_numref(q->m), mpq_denref(q->m));

-mpq

-overload_abs (q, d1, d2)

- mpq_assume q

- dummy d1

- dummy d2

-ALIAS:

- GMP::Mpq::overload_neg = 1

-PREINIT:

- static_functable const struct {

- void (*op) (mpq_ptr w, mpq_srcptr x);

- } table[] = {

- { mpq_abs }, /* 0 */

- { mpq_neg }, /* 1 */

- };

-CODE:

- assert_table (ix);

- RETVAL = new_mpq();

- (*table[ix].op) (RETVAL->m, q->m);

-OUTPUT:

- RETVAL

-int

-overload_spaceship (x, y, order)

- mpq_assume x

- mpq_coerce y

- SV *order

-CODE:

- RETVAL = mpq_cmp (x->m, y);

- RETVAL = SGN (RETVAL);

- if (order == &PL_sv_yes)

- RETVAL = -RETVAL;

-OUTPUT:

- RETVAL

-bool

-overload_bool (q, d1, d2)

- mpq_assume q

- dummy d1

- dummy d2

-ALIAS:

- GMP::Mpq::overload_not = 1

-CODE:

- RETVAL = (mpq_sgn (q->m) != 0) ^ ix;

-OUTPUT:

- RETVAL

-bool

-overload_eq (x, yv, d)

- mpq_assume x

- SV *yv

- dummy d

-ALIAS:

- GMP::Mpq::overload_ne = 1

-PREINIT:

- int use;

-CODE:

- use = use_sv (yv);

- switch (use) {

- case USE_IVX:

- case USE_UVX:

- case USE_MPZ:

- RETVAL = 0;

- if (x_mpq_integer_p (x->m))

- {

- switch (use) {

- case USE_IVX:

- RETVAL = (mpz_cmp_si (mpq_numref(x->m), SvIVX(yv)) == 0);

- break;

- case USE_UVX:

- RETVAL = (mpz_cmp_ui (mpq_numref(x->m), SvUVX(yv)) == 0);

- break;

- case USE_MPZ:

- RETVAL = (mpz_cmp (mpq_numref(x->m), SvMPZ(yv)->m) == 0);

- break;

- }

- break;

- case USE_MPQ:

- RETVAL = (mpq_equal (x->m, SvMPQ(yv)->m) != 0);

- break;

- default:

- RETVAL = (mpq_equal (x->m, coerce_mpq_using (tmp_mpq_0, yv, use)) != 0);

- break;

- }

- RETVAL ^= ix;

-OUTPUT:

- RETVAL

-void

-canonicalize (q)

- mpq q

-CODE:

- mpq_canonicalize (q->m);

-mpq

-inv (q)

- mpq_coerce q

-CODE:

- RETVAL = new_mpq();

- mpq_inv (RETVAL->m, q);

-OUTPUT:

- RETVAL

-mpz

-num (q)

- mpq q

-ALIAS:

- GMP::Mpq::den = 1

-CODE:

- RETVAL = new_mpz();

- mpz_set (RETVAL->m, (ix == 0 ? mpq_numref(q->m) : mpq_denref(q->m)));

-OUTPUT:

- RETVAL

-#------------------------------------------------------------------------------

-MODULE = GMP PACKAGE = GMP::Mpf

-mpf

-mpf (...)

-ALIAS:

- GMP::Mpf::new = 1

-PREINIT:

- unsigned long prec;

-CODE:

- TRACE (printf ("%s new\n", mpf_class));

- if (items > 2)

- croak ("%s new: invalid arguments", mpf_class);

- prec = (items == 2 ? coerce_ulong (ST(1)) : mpf_get_default_prec());

- RETVAL = new_mpf (prec);

- if (items >= 1)

- {

- SV *sv = ST(0);

- my_mpf_set_sv_using (RETVAL, sv, use_sv(sv));

- }

-OUTPUT:

- RETVAL

-mpf

-overload_constant (sv, d1, d2, ...)

- SV *sv

- dummy d1

- dummy d2

-CODE:

- assert (SvPOK (sv));

- TRACE (printf ("%s constant: %s\n", mpq_class, SvPVX(sv)));

- RETVAL = new_mpf (mpf_get_default_prec());

- my_mpf_set_svstr (RETVAL, sv);

-OUTPUT:

- RETVAL

-mpf

-overload_copy (f, d1, d2)

- mpf_assume f

- dummy d1

- dummy d2

-CODE:

- TRACE (printf ("%s copy\n", mpf_class));

- RETVAL = new_mpf (mpf_get_prec (f));

- mpf_set (RETVAL, f);

-OUTPUT:

- RETVAL

-void

-DESTROY (f)

- mpf_assume f

-CODE:

- TRACE (printf ("%s DESTROY %p\n", mpf_class, f));

- mpf_clear (f);

- Safefree (f);

- assert_support (mpf_count--);

- TRACE_ACTIVE ();

-mpf

-overload_add (x, y, order)

- mpf_assume x

- mpf_coerce_st0 y

- SV *order

-ALIAS:

- GMP::Mpf::overload_sub = 1

- GMP::Mpf::overload_mul = 2

- GMP::Mpf::overload_div = 3

-PREINIT:

- static_functable const struct {

- void (*op) (mpf_ptr, mpf_srcptr, mpf_srcptr);

- } table[] = {

- { mpf_add }, /* 0 */

- { mpf_sub }, /* 1 */

- { mpf_mul }, /* 2 */

- { mpf_div }, /* 3 */

- };

-CODE:

- assert_table (ix);

- RETVAL = new_mpf (mpf_get_prec (x));

- if (order == &PL_sv_yes)

- MPF_PTR_SWAP (x, y);

- (*table[ix].op) (RETVAL, x, y);

-OUTPUT:

- RETVAL

-void

-overload_addeq (x, y, o)

- mpf_assume x

- mpf_coerce_st0 y

- order_noswap o

-ALIAS:

- GMP::Mpf::overload_subeq = 1

- GMP::Mpf::overload_muleq = 2

- GMP::Mpf::overload_diveq = 3

-PREINIT:

- static_functable const struct {

- void (*op) (mpf_ptr, mpf_srcptr, mpf_srcptr);

- } table[] = {

- { mpf_add }, /* 0 */

- { mpf_sub }, /* 1 */

- { mpf_mul }, /* 2 */

- { mpf_div }, /* 3 */

- };

-PPCODE:

- assert_table (ix);

- (*table[ix].op) (x, x, y);

- XPUSHs(ST(0));

-mpf

-overload_lshift (fv, nv, order)

- SV *fv

- SV *nv

- SV *order

-ALIAS:

- GMP::Mpf::overload_rshift = 1

- GMP::Mpf::overload_pow = 2

-PREINIT:

- static_functable const struct {

- void (*op) (mpf_ptr, mpf_srcptr, unsigned long);

- } table[] = {

- { mpf_mul_2exp }, /* 0 */

- { mpf_div_2exp }, /* 1 */

- { mpf_pow_ui }, /* 2 */

- };

- mpf f;

- unsigned long prec;

-CODE:

- assert_table (ix);

- MPF_ASSUME (f, fv);

- prec = mpf_get_prec (f);

- if (order == &PL_sv_yes)

- SV_PTR_SWAP (fv, nv);

- f = coerce_mpf (tmp_mpf_0, fv, prec);

- RETVAL = new_mpf (prec);

- (*table[ix].op) (RETVAL, f, coerce_ulong (nv));

-OUTPUT:

- RETVAL

-void

-overload_lshifteq (f, n, o)

- mpf_assume f

- ulong_coerce n

- order_noswap o

-ALIAS:

- GMP::Mpf::overload_rshifteq = 1

- GMP::Mpf::overload_poweq = 2

-PREINIT:

- static_functable const struct {

- void (*op) (mpf_ptr, mpf_srcptr, unsigned long);

- } table[] = {

- { mpf_mul_2exp }, /* 0 */

- { mpf_div_2exp }, /* 1 */

- { mpf_pow_ui }, /* 2 */

- };

-PPCODE:

- assert_table (ix);

- (*table[ix].op) (f, f, n);

- XPUSHs(ST(0));

-mpf

-overload_abs (f, d1, d2)

- mpf_assume f

- dummy d1

- dummy d2

-ALIAS:

- GMP::Mpf::overload_neg = 1

- GMP::Mpf::overload_sqrt = 2

-PREINIT:

- static_functable const struct {

- void (*op) (mpf_ptr w, mpf_srcptr x);

- } table[] = {

- { mpf_abs }, /* 0 */

- { mpf_neg }, /* 1 */

- { mpf_sqrt }, /* 2 */

- };

-CODE:

- assert_table (ix);

- RETVAL = new_mpf (mpf_get_prec (f));

- (*table[ix].op) (RETVAL, f);

-OUTPUT:

- RETVAL

-void

-overload_inc (f, d1, d2)

- mpf_assume f

- dummy d1

- dummy d2

-ALIAS:

- GMP::Mpf::overload_dec = 1

-PREINIT:

- static_functable const struct {

- void (*op) (mpf_ptr w, mpf_srcptr x, unsigned long y);

- } table[] = {

- { mpf_add_ui }, /* 0 */

- { mpf_sub_ui }, /* 1 */

- };

-CODE:

- assert_table (ix);

- (*table[ix].op) (f, f, 1L);

-int

-overload_spaceship (xv, yv, order)

- SV *xv

- SV *yv

- SV *order

-PREINIT:

- mpf x;

-CODE:

- MPF_ASSUME (x, xv);

- switch (use_sv (yv)) {

- case USE_IVX:

- RETVAL = mpf_cmp_si (x, SvIVX(yv));

- break;

- case USE_UVX:

- RETVAL = mpf_cmp_ui (x, SvUVX(yv));

- break;

- case USE_NVX:

- RETVAL = mpf_cmp_d (x, SvNVX(yv));

- break;

- case USE_PVX:

- {

- STRLEN len;

- const char *str = SvPV (yv, len);

- /* enough for all digits of the string */

- tmp_mpf_set_prec (tmp_mpf_0, strlen(str)+64);

- if (mpf_set_str (tmp_mpf_0->m, str, 10) != 0)

- croak ("%s <=>: invalid string format", mpf_class);

- RETVAL = mpf_cmp (x, tmp_mpf_0->m);

- }

- break;

- case USE_MPZ:

- RETVAL = - x_mpz_cmp_f (SvMPZ(yv)->m, x);

- break;

- case USE_MPF:

- RETVAL = mpf_cmp (x, SvMPF(yv));

- break;

- default:

- RETVAL = mpq_cmp (coerce_mpq (tmp_mpq_0, xv),

- coerce_mpq (tmp_mpq_1, yv));

- break;

- }

- RETVAL = SGN (RETVAL);

- if (order == &PL_sv_yes)

- RETVAL = -RETVAL;

-OUTPUT:

- RETVAL

-bool

-overload_bool (f, d1, d2)

- mpf_assume f

- dummy d1

- dummy d2

-ALIAS:

- GMP::Mpf::overload_not = 1

-CODE:

- RETVAL = (mpf_sgn (f) != 0) ^ ix;

-OUTPUT:

- RETVAL

-mpf

-ceil (f)

- mpf_coerce_def f

-ALIAS:

- GMP::Mpf::floor = 1

- GMP::Mpf::trunc = 2

-PREINIT:

- static_functable const struct {

- void (*op) (mpf_ptr w, mpf_srcptr x);

- } table[] = {

- { mpf_ceil }, /* 0 */

- { mpf_floor }, /* 1 */

- { mpf_trunc }, /* 2 */

- };

-CODE:

- assert_table (ix);

- RETVAL = new_mpf (mpf_get_prec (f));

- (*table[ix].op) (RETVAL, f);

-OUTPUT:

- RETVAL

-unsigned long

-get_default_prec ()

-CODE:

- RETVAL = mpf_get_default_prec();

-OUTPUT:

- RETVAL

-unsigned long

-get_prec (f)

- mpf_coerce_def f

-CODE:

- RETVAL = mpf_get_prec (f);

-OUTPUT:

- RETVAL

-bool

-mpf_eq (xv, yv, bits)

- SV *xv

- SV *yv

- ulong_coerce bits

-PREINIT:

- mpf x, y;

-CODE:

- TRACE (printf ("%s eq\n", mpf_class));

- coerce_mpf_pair (&x,xv, &y,yv);

- RETVAL = mpf_eq (x, y, bits);

-OUTPUT:

- RETVAL

-mpf

-reldiff (xv, yv)

- SV *xv

- SV *yv

-PREINIT:

- mpf x, y;

- unsigned long prec;

-CODE:

- TRACE (printf ("%s reldiff\n", mpf_class));

- prec = coerce_mpf_pair (&x,xv, &y,yv);

- RETVAL = new_mpf (prec);

- mpf_reldiff (RETVAL, x, y);

-OUTPUT:

- RETVAL

-void

-set_default_prec (prec)

- ulong_coerce prec

-CODE:

- TRACE (printf ("%s set_default_prec %lu\n", mpf_class, prec));

- mpf_set_default_prec (prec);

-void

-set_prec (sv, prec)

- SV *sv

- ulong_coerce prec

-PREINIT:

- mpf_ptr old_f, new_f;

- int use;

-CODE:

- TRACE (printf ("%s set_prec to %lu\n", mpf_class, prec));

- use = use_sv (sv);

- if (use == USE_MPF)

- {

- old_f = SvMPF(sv);

- if (SvREFCNT(SvRV(sv)) == 1)

- mpf_set_prec (old_f, prec);

- else

- {

- TRACE (printf (" fork new mpf\n"));

- new_f = new_mpf (prec);

- mpf_set (new_f, old_f);

- goto setref;

- }

- else

- {

- TRACE (printf (" coerce to mpf\n"));

- new_f = new_mpf (prec);

- my_mpf_set_sv_using (new_f, sv, use);

- setref:

- sv_bless (sv_setref_pv (sv, NULL, new_f), mpf_class_hv);

- }

-#------------------------------------------------------------------------------

-MODULE = GMP PACKAGE = GMP::Rand

-randstate

-new (...)

-ALIAS:

- GMP::Rand::randstate = 1

-CODE:

- TRACE (printf ("%s new\n", rand_class));

- New (GMP_MALLOC_ID, RETVAL, 1, __gmp_randstate_struct);

- TRACE (printf (" RETVAL %p\n", RETVAL));

- assert_support (rand_count++);

- TRACE_ACTIVE ();

- if (items == 0)

- {

- gmp_randinit_default (RETVAL);

- }

- else

- {

- if (SvROK (ST(0)) && sv_derived_from (ST(0), rand_class))

- {

- if (items != 1)

- goto invalid;

- gmp_randinit_set (RETVAL, SvRANDSTATE (ST(0)));

- }

- else

- {

- STRLEN len;

- const char *method = SvPV (ST(0), len);

- assert (len == strlen (method));

- if (strcmp (method, "lc_2exp") == 0)

- {

- if (items != 4)

- goto invalid;

- gmp_randinit_lc_2exp (RETVAL,

- coerce_mpz (tmp_mpz_0, ST(1)),

- coerce_ulong (ST(2)),

- coerce_ulong (ST(3)));

- }

- else if (strcmp (method, "lc_2exp_size") == 0)

- {

- if (items != 2)

- goto invalid;

- if (! gmp_randinit_lc_2exp_size (RETVAL, coerce_ulong (ST(1))))

- {

- Safefree (RETVAL);

- XSRETURN_UNDEF;

- }

- else if (strcmp (method, "mt") == 0)

- {

- if (items != 1)

- goto invalid;

- gmp_randinit_mt (RETVAL);

- }

- else

- {

- invalid:

- croak ("%s new: invalid arguments", rand_class);

- }

-OUTPUT:

- RETVAL

-void

-DESTROY (r)

- randstate r

-CODE:

- TRACE (printf ("%s DESTROY\n", rand_class));

- gmp_randclear (r);

- Safefree (r);

- assert_support (rand_count--);

- TRACE_ACTIVE ();

-void

-seed (r, z)

- randstate r

- mpz_coerce z

-CODE:

- gmp_randseed (r, z);

-mpz

-mpz_urandomb (r, bits)

- randstate r

- ulong_coerce bits

-ALIAS:

- GMP::Rand::mpz_rrandomb = 1

-PREINIT:

- static_functable const struct {

- void (*fun) (mpz_ptr, gmp_randstate_t r, unsigned long bits);

- } table[] = {

- { mpz_urandomb }, /* 0 */

- { mpz_rrandomb }, /* 1 */

- };

-CODE:

- assert_table (ix);

- RETVAL = new_mpz();

- (*table[ix].fun) (RETVAL->m, r, bits);

-OUTPUT:

- RETVAL

-mpz

-mpz_urandomm (r, m)

- randstate r

- mpz_coerce m

-CODE:

- RETVAL = new_mpz();

- mpz_urandomm (RETVAL->m, r, m);

-OUTPUT:

- RETVAL

-mpf

-mpf_urandomb (r, bits)

- randstate r

- ulong_coerce bits

-CODE:

- RETVAL = new_mpf (bits);

- mpf_urandomb (RETVAL, r, bits);

-OUTPUT:

- RETVAL

-unsigned long

-gmp_urandomb_ui (r, bits)

- randstate r

- ulong_coerce bits

-ALIAS:

- GMP::Rand::gmp_urandomm_ui = 1

-PREINIT:

- static_functable const struct {

- unsigned long (*fun) (gmp_randstate_t r, unsigned long bits);

- } table[] = {

- { gmp_urandomb_ui }, /* 0 */

- { gmp_urandomm_ui }, /* 1 */

- };

-CODE:

- assert_table (ix);

- RETVAL = (*table[ix].fun) (r, bits);

-OUTPUT:

- RETVAL

« no previous file with comments | « gcc/gmp/demos/perl/GMP.pm ('k') | gcc/gmp/demos/perl/GMP/Mpq.pm » ('j') | no next file with comments »