gmp.xs

来自「a very popular packet of cryptography to」· XS 代码 · 共 2,874 行 · 第 1/5 页

    }

  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);