case BT_COMPLEX:
gfc_set_model_kind (kind);
+#ifdef HAVE_mpc
+ mpc_init2 (result->value.complex, mpfr_get_default_prec());
+#else
mpfr_init (result->value.complex.r);
mpfr_init (result->value.complex.i);
+#endif
break;
default:
break;
case BT_COMPLEX:
- rc = gfc_check_real_range (e->value.complex.r, e->ts.kind);
+ rc = gfc_check_real_range (mpc_realref (e->value.complex), e->ts.kind);
if (rc == ARITH_UNDERFLOW)
- mpfr_set_ui (e->value.complex.r, 0, GFC_RND_MODE);
+ mpfr_set_ui (mpc_realref (e->value.complex), 0, GFC_RND_MODE);
if (rc == ARITH_OVERFLOW)
- mpfr_set_inf (e->value.complex.r, mpfr_sgn (e->value.complex.r));
+ mpfr_set_inf (mpc_realref (e->value.complex),
+ mpfr_sgn (mpc_realref (e->value.complex)));
if (rc == ARITH_NAN)
- mpfr_set_nan (e->value.complex.r);
+ mpfr_set_nan (mpc_realref (e->value.complex));
- rc2 = gfc_check_real_range (e->value.complex.i, e->ts.kind);
+ rc2 = gfc_check_real_range (mpc_imagref (e->value.complex), e->ts.kind);
if (rc == ARITH_UNDERFLOW)
- mpfr_set_ui (e->value.complex.i, 0, GFC_RND_MODE);
+ mpfr_set_ui (mpc_imagref (e->value.complex), 0, GFC_RND_MODE);
if (rc == ARITH_OVERFLOW)
- mpfr_set_inf (e->value.complex.i, mpfr_sgn (e->value.complex.i));
+ mpfr_set_inf (mpc_imagref (e->value.complex),
+ mpfr_sgn (mpc_imagref (e->value.complex)));
if (rc == ARITH_NAN)
- mpfr_set_nan (e->value.complex.i);
+ mpfr_set_nan (mpc_imagref (e->value.complex));
if (rc == ARITH_OK)
rc = rc2;
break;
case BT_COMPLEX:
+#ifdef HAVE_mpc
+ mpc_neg (result->value.complex, op1->value.complex, GFC_MPC_RND_MODE);
+#else
mpfr_neg (result->value.complex.r, op1->value.complex.r, GFC_RND_MODE);
mpfr_neg (result->value.complex.i, op1->value.complex.i, GFC_RND_MODE);
+#endif
break;
default:
break;
case BT_COMPLEX:
+#ifdef HAVE_mpc
+ mpc_add (result->value.complex, op1->value.complex, op2->value.complex,
+ GFC_MPC_RND_MODE);
+#else
mpfr_add (result->value.complex.r, op1->value.complex.r,
op2->value.complex.r, GFC_RND_MODE);
mpfr_add (result->value.complex.i, op1->value.complex.i,
op2->value.complex.i, GFC_RND_MODE);
+#endif
break;
default:
break;
case BT_COMPLEX:
+#ifdef HAVE_mpc
+ mpc_sub (result->value.complex, op1->value.complex,
+ op2->value.complex, GFC_MPC_RND_MODE);
+#else
mpfr_sub (result->value.complex.r, op1->value.complex.r,
op2->value.complex.r, GFC_RND_MODE);
mpfr_sub (result->value.complex.i, op1->value.complex.i,
op2->value.complex.i, GFC_RND_MODE);
+#endif
break;
default:
gfc_arith_times (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
{
gfc_expr *result;
- mpfr_t x, y;
arith rc;
result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
break;
case BT_COMPLEX:
- gfc_set_model (op1->value.complex.r);
+ gfc_set_model (mpc_realref (op1->value.complex));
+#ifdef HAVE_mpc
+ mpc_mul (result->value.complex, op1->value.complex, op2->value.complex,
+ GFC_MPC_RND_MODE);
+#else
+ {
+ mpfr_t x, y;
mpfr_init (x);
mpfr_init (y);
mpfr_add (result->value.complex.i, x, y, GFC_RND_MODE);
mpfr_clears (x, y, NULL);
+ }
+#endif
break;
default:
gfc_arith_divide (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
{
gfc_expr *result;
- mpfr_t x, y, div;
arith rc;
rc = ARITH_OK;
break;
case BT_COMPLEX:
- if (mpfr_sgn (op2->value.complex.r) == 0
+ if (
+#ifdef HAVE_mpc
+ mpc_cmp_si_si (op2->value.complex, 0, 0) == 0
+#else
+ mpfr_sgn (op2->value.complex.r) == 0
&& mpfr_sgn (op2->value.complex.i) == 0
+#endif
&& gfc_option.flag_range_check == 1)
{
rc = ARITH_DIV0;
break;
}
- gfc_set_model (op1->value.complex.r);
+ gfc_set_model (mpc_realref (op1->value.complex));
+
+#ifdef HAVE_mpc
+ if (mpc_cmp_si_si (op2->value.complex, 0, 0) == 0)
+ {
+ /* In Fortran, return (NaN + NaN I) for any zero divisor. See
+ PR 40318. */
+ mpfr_set_nan (mpc_realref (result->value.complex));
+ mpfr_set_nan (mpc_imagref (result->value.complex));
+ }
+ else
+ mpc_div (result->value.complex, op1->value.complex, op2->value.complex,
+ GFC_MPC_RND_MODE);
+#else
+ {
+ mpfr_t x, y, div;
mpfr_init (x);
mpfr_init (y);
mpfr_init (div);
GFC_RND_MODE);
mpfr_clears (x, y, div, NULL);
+ }
+#endif
break;
default:
static void
complex_reciprocal (gfc_expr *op)
{
+ gfc_set_model (mpc_realref (op->value.complex));
+#ifdef HAVE_mpc
+ mpc_ui_div (op->value.complex, 1, op->value.complex, GFC_MPC_RND_MODE);
+#else
+ {
mpfr_t mod, tmp;
- gfc_set_model (op->value.complex.r);
mpfr_init (mod);
mpfr_init (tmp);
mpfr_div (op->value.complex.i, op->value.complex.i, mod, GFC_RND_MODE);
mpfr_clears (tmp, mod, NULL);
+ }
+#endif
}
{
mpfr_t x_r, x_i, tmp, re, im;
- gfc_set_model (base->value.complex.r);
+ gfc_set_model (mpc_realref (base->value.complex));
mpfr_init (x_r);
mpfr_init (x_i);
mpfr_init (tmp);
mpfr_init (im);
/* res = 1 */
+#ifdef HAVE_mpc
+ mpc_set_ui (result->value.complex, 1, GFC_MPC_RND_MODE);
+#else
mpfr_set_ui (result->value.complex.r, 1, GFC_RND_MODE);
mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
+#endif
/* x = base */
- mpfr_set (x_r, base->value.complex.r, GFC_RND_MODE);
- mpfr_set (x_i, base->value.complex.i, GFC_RND_MODE);
+ mpfr_set (x_r, mpc_realref (base->value.complex), GFC_RND_MODE);
+ mpfr_set (x_i, mpc_imagref (base->value.complex), GFC_RND_MODE);
/* Macro for complex multiplication. We have to take care that
res_r/res_i and a_r/a_i can (and will) be the same variable. */
mpfr_add (res_i, im, tmp, GFC_RND_MODE), \
mpfr_set (res_r, re, GFC_RND_MODE)
-#define res_r result->value.complex.r
-#define res_i result->value.complex.i
+#define res_r mpc_realref (result->value.complex)
+#define res_i mpc_imagref (result->value.complex)
/* for (; power > 0; x *= x) */
for (; mpz_cmp_si (power, 0) > 0; CMULT(x_r,x_i,x_r,x_i,x_r,x_i))
break;
case BT_COMPLEX:
+#ifdef HAVE_mpc
+ mpc_set_ui (result->value.complex, 1, GFC_MPC_RND_MODE);
+#else
mpfr_set_ui (result->value.complex.r, 1, GFC_RND_MODE);
mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
+#endif
break;
default:
case BT_COMPLEX:
{
- mpfr_t x, y, r, t;
-
if (init_flag)
{
if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Noninteger "
return ARITH_PROHIBIT;
}
- gfc_set_model (op1->value.complex.r);
+ {
+ mpfr_t x, y, r, t;
+
+ gfc_set_model (mpc_realref (op1->value.complex));
mpfr_init (r);
+#ifdef HAVE_mpc
+ mpc_abs (r, op1->value.complex, GFC_RND_MODE);
+#else
mpfr_hypot (r, op1->value.complex.r, op1->value.complex.i,
GFC_RND_MODE);
+#endif
if (mpfr_cmp_si (r, 0) == 0)
{
+#ifdef HAVE_mpc
+ mpc_set_ui (result->value.complex, 0, GFC_MPC_RND_MODE);
+#else
mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE);
mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
+#endif
mpfr_clear (r);
break;
}
mpfr_init (t);
+#ifdef HAVE_mpc
+ mpc_arg (t, op1->value.complex, GFC_RND_MODE);
+#else
mpfr_atan2 (t, op1->value.complex.i, op1->value.complex.r,
GFC_RND_MODE);
+#endif
mpfr_init (x);
mpfr_init (y);
- mpfr_mul (x, op2->value.complex.r, r, GFC_RND_MODE);
- mpfr_mul (y, op2->value.complex.i, t, GFC_RND_MODE);
+ mpfr_mul (x, mpc_realref (op2->value.complex), r, GFC_RND_MODE);
+ mpfr_mul (y, mpc_imagref (op2->value.complex), t, GFC_RND_MODE);
mpfr_sub (x, x, y, GFC_RND_MODE);
mpfr_exp (x, x, GFC_RND_MODE);
- mpfr_mul (y, op2->value.complex.r, t, GFC_RND_MODE);
- mpfr_mul (t, op2->value.complex.i, r, GFC_RND_MODE);
+ mpfr_mul (y, mpc_realref (op2->value.complex), t, GFC_RND_MODE);
+ mpfr_mul (t, mpc_imagref (op2->value.complex), r, GFC_RND_MODE);
mpfr_add (y, y, t, GFC_RND_MODE);
mpfr_cos (t, y, GFC_RND_MODE);
mpfr_sin (y, y, GFC_RND_MODE);
- mpfr_mul (result->value.complex.r, x, t, GFC_RND_MODE);
- mpfr_mul (result->value.complex.i, x, y, GFC_RND_MODE);
+ mpfr_mul (mpc_realref (result->value.complex), x, t, GFC_RND_MODE);
+ mpfr_mul (mpc_imagref (result->value.complex), x, y, GFC_RND_MODE);
mpfr_clears (r, t, x, y, NULL);
+ }
}
break;
default:
static int
compare_complex (gfc_expr *op1, gfc_expr *op2)
{
+#ifdef HAVE_mpc
+ return mpc_cmp (op1->value.complex, op2->value.complex) == 0;
+#else
return (mpfr_equal_p (op1->value.complex.r, op2->value.complex.r)
&& mpfr_equal_p (op1->value.complex.i, op2->value.complex.i));
+#endif
}
gfc_expr *e;
e = gfc_constant_result (BT_COMPLEX, kind, &real->where);
+#ifdef HAVE_mpc
+ mpc_set_fr_fr (e->value.complex, real->value.real, imag->value.real,
+ GFC_MPC_RND_MODE);
+#else
mpfr_set (e->value.complex.r, real->value.real, GFC_RND_MODE);
mpfr_set (e->value.complex.i, imag->value.real, GFC_RND_MODE);
+#endif
return e;
}
result = gfc_constant_result (BT_COMPLEX, kind, &src->where);
+#ifdef HAVE_mpc
+ mpc_set_z (result->value.complex, src->value.integer, GFC_MPC_RND_MODE);
+#else
mpfr_set_z (result->value.complex.r, src->value.integer, GFC_RND_MODE);
mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
+#endif
- if ((rc = gfc_check_real_range (result->value.complex.r, kind)) != ARITH_OK)
+ if ((rc = gfc_check_real_range (mpc_realref (result->value.complex), kind))
+ != ARITH_OK)
{
arith_error (rc, &src->ts, &result->ts, &src->where);
gfc_free_expr (result);
result = gfc_constant_result (BT_COMPLEX, kind, &src->where);
+#ifdef HAVE_mpc
+ mpc_set_fr (result->value.complex, src->value.real, GFC_MPC_RND_MODE);
+#else
mpfr_set (result->value.complex.r, src->value.real, GFC_RND_MODE);
mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
+#endif
- rc = gfc_check_real_range (result->value.complex.r, kind);
+ rc = gfc_check_real_range (mpc_realref (result->value.complex), kind);
if (rc == ARITH_UNDERFLOW)
{
if (gfc_option.warn_underflow)
gfc_warning (gfc_arith_error (rc), &src->where);
- mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE);
+ mpfr_set_ui (mpc_realref (result->value.complex), 0, GFC_RND_MODE);
}
else if (rc != ARITH_OK)
{
result = gfc_constant_result (BT_INTEGER, kind, &src->where);
- gfc_mpfr_to_mpz (result->value.integer, src->value.complex.r, &src->where);
+ gfc_mpfr_to_mpz (result->value.integer, mpc_realref (src->value.complex),
+ &src->where);
if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
{
result = gfc_constant_result (BT_REAL, kind, &src->where);
+#ifdef HAVE_mpc
+ mpc_real (result->value.real, src->value.complex, GFC_RND_MODE);
+#else
mpfr_set (result->value.real, src->value.complex.r, GFC_RND_MODE);
+#endif
rc = gfc_check_real_range (result->value.real, kind);
result = gfc_constant_result (BT_COMPLEX, kind, &src->where);
+#ifdef HAVE_mpc
+ mpc_set (result->value.complex, src->value.complex, GFC_MPC_RND_MODE);
+#else
mpfr_set (result->value.complex.r, src->value.complex.r, GFC_RND_MODE);
mpfr_set (result->value.complex.i, src->value.complex.i, GFC_RND_MODE);
+#endif
- rc = gfc_check_real_range (result->value.complex.r, kind);
+ rc = gfc_check_real_range (mpc_realref (result->value.complex), kind);
if (rc == ARITH_UNDERFLOW)
{
if (gfc_option.warn_underflow)
gfc_warning (gfc_arith_error (rc), &src->where);
- mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE);
+ mpfr_set_ui (mpc_realref (result->value.complex), 0, GFC_RND_MODE);
}
else if (rc != ARITH_OK)
{
return NULL;
}
- rc = gfc_check_real_range (result->value.complex.i, kind);
+ rc = gfc_check_real_range (mpc_imagref (result->value.complex), kind);
if (rc == ARITH_UNDERFLOW)
{
if (gfc_option.warn_underflow)
gfc_warning (gfc_arith_error (rc), &src->where);
- mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
+ mpfr_set_ui (mpc_imagref (result->value.complex), 0, GFC_RND_MODE);
}
else if (rc != ARITH_OK)
{
hollerith2representation (result, src);
gfc_interpret_complex (kind, (unsigned char *) result->representation.string,
- result->representation.length, result->value.complex.r,
- result->value.complex.i);
+ result->representation.length,
+#ifdef HAVE_mpc
+ result->value.complex
+#else
+ result->value.complex.r, result->value.complex.i
+#endif
+ );
return result;
}
}
}
-/* Helper function to convert to/from mpfr_t & mpc_t and call the
- supplied mpc function on the respective values. */
-
-#ifdef HAVE_mpc
-static void
-call_mpc_func (mpfr_ptr result_re, mpfr_ptr result_im,
- mpfr_srcptr input_re, mpfr_srcptr input_im,
- int (*func)(mpc_ptr, mpc_srcptr, mpc_rnd_t))
-{
- mpc_t c;
- mpc_init2 (c, mpfr_get_default_prec());
- mpc_set_fr_fr (c, input_re, input_im, GFC_MPC_RND_MODE);
- func (c, c, GFC_MPC_RND_MODE);
- mpfr_set (result_re, mpc_realref (c), GFC_RND_MODE);
- mpfr_set (result_im, mpc_imagref (c), GFC_RND_MODE);
- mpc_clear (c);
-}
-#endif
-
-
/* Test that the expression is an constant array. */
static bool
break;
case BT_COMPLEX:
+#ifdef HAVE_mpc
+ mpc_set_si (e->value.complex, init, GFC_MPC_RND_MODE);
+#else
mpfr_set_si (e->value.complex.r, init, GFC_RND_MODE);
mpfr_set_si (e->value.complex.i, 0, GFC_RND_MODE);
+#endif
break;
case BT_CHARACTER:
gfc_set_model_kind (e->ts.kind);
+#ifdef HAVE_mpc
+ mpc_abs (result->value.real, e->value.complex, GFC_RND_MODE);
+#else
mpfr_hypot (result->value.real, e->value.complex.r,
e->value.complex.i, GFC_RND_MODE);
+#endif
result = range_check (result, "CABS");
break;
return NULL;
result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
- mpfr_set (result->value.real, e->value.complex.i, GFC_RND_MODE);
+ mpfr_set (result->value.real, mpc_imagref (e->value.complex), GFC_RND_MODE);
return range_check (result, "AIMAG");
}
result = gfc_constant_result (BT_COMPLEX, kind, &x->where);
+#ifndef HAVE_mpc
mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
+#endif
switch (x->ts.type)
{
case BT_INTEGER:
if (!x->is_boz)
+#ifdef HAVE_mpc
+ mpc_set_z (result->value.complex, x->value.integer, GFC_MPC_RND_MODE);
+#else
mpfr_set_z (result->value.complex.r, x->value.integer, GFC_RND_MODE);
+#endif
break;
case BT_REAL:
+#ifdef HAVE_mpc
+ mpc_set_fr (result->value.complex, x->value.real, GFC_RND_MODE);
+#else
mpfr_set (result->value.complex.r, x->value.real, GFC_RND_MODE);
+#endif
break;
case BT_COMPLEX:
+#ifdef HAVE_mpc
+ mpc_set (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+#else
mpfr_set (result->value.complex.r, x->value.complex.r, GFC_RND_MODE);
mpfr_set (result->value.complex.i, x->value.complex.i, GFC_RND_MODE);
+#endif
break;
default:
{
case BT_INTEGER:
if (!y->is_boz)
- mpfr_set_z (result->value.complex.i, y->value.integer,
- GFC_RND_MODE);
+ mpfr_set_z (mpc_imagref (result->value.complex),
+ y->value.integer, GFC_RND_MODE);
break;
case BT_REAL:
- mpfr_set (result->value.complex.i, y->value.real, GFC_RND_MODE);
+ mpfr_set (mpc_imagref (result->value.complex),
+ y->value.real, GFC_RND_MODE);
break;
default:
ts.type = BT_REAL;
if (!gfc_convert_boz (x, &ts))
return &gfc_bad_expr;
- mpfr_set (result->value.complex.r, x->value.real, GFC_RND_MODE);
+ mpfr_set (mpc_realref (result->value.complex),
+ x->value.real, GFC_RND_MODE);
}
if (y && y->is_boz)
ts.type = BT_REAL;
if (!gfc_convert_boz (y, &ts))
return &gfc_bad_expr;
- mpfr_set (result->value.complex.i, y->value.real, GFC_RND_MODE);
+ mpfr_set (mpc_imagref (result->value.complex),
+ y->value.real, GFC_RND_MODE);
}
return range_check (result, name);
return NULL;
result = gfc_copy_expr (e);
+#ifdef HAVE_mpc
+ mpc_conj (result->value.complex, result->value.complex, GFC_MPC_RND_MODE);
+#else
mpfr_neg (result->value.complex.i, result->value.complex.i, GFC_RND_MODE);
+#endif
return range_check (result, "CONJG");
}
case BT_COMPLEX:
gfc_set_model_kind (x->ts.kind);
#ifdef HAVE_mpc
- call_mpc_func (result->value.complex.r, result->value.complex.i,
- x->value.complex.r, x->value.complex.i, mpc_cos);
+ mpc_cos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
#else
{
mpfr_t xp, xq;
case BT_COMPLEX:
gfc_set_model_kind (x->ts.kind);
#ifdef HAVE_mpc
- call_mpc_func (result->value.complex.r, result->value.complex.i,
- x->value.complex.r, x->value.complex.i, mpc_exp);
+ mpc_exp (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
#else
{
mpfr_t xp, xq;
break;
case BT_COMPLEX:
- if ((mpfr_sgn (x->value.complex.r) == 0)
- && (mpfr_sgn (x->value.complex.i) == 0))
+ if ((mpfr_sgn (mpc_realref (x->value.complex)) == 0)
+ && (mpfr_sgn (mpc_imagref (x->value.complex)) == 0))
{
gfc_error ("Complex argument of LOG at %L cannot be zero",
&x->where);
gfc_set_model_kind (x->ts.kind);
#ifdef HAVE_mpc
- call_mpc_func (result->value.complex.r, result->value.complex.i,
- x->value.complex.r, x->value.complex.i, mpc_log);
+ mpc_log (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
#else
{
mpfr_t xr, xi;
return NULL;
result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
+#ifdef HAVE_mpc
+ mpc_real (result->value.real, e->value.complex, GFC_RND_MODE);
+#else
mpfr_set (result->value.real, e->value.complex.r, GFC_RND_MODE);
+#endif
return range_check (result, "REALPART");
}
case BT_COMPLEX:
gfc_set_model (x->value.real);
#ifdef HAVE_mpc
- call_mpc_func (result->value.complex.r, result->value.complex.i,
- x->value.complex.r, x->value.complex.i, mpc_sin);
+ mpc_sin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
#else
{
mpfr_t xp, xq;
case BT_COMPLEX:
gfc_set_model (e->value.real);
#ifdef HAVE_mpc
- call_mpc_func (result->value.complex.r, result->value.complex.i,
- e->value.complex.r, e->value.complex.i, mpc_sqrt);
+ mpc_sqrt (result->value.complex, e->value.complex, GFC_MPC_RND_MODE);
#else
{
/* Formula taken from Numerical Recipes to avoid over- and