Skip to content

R
riscv-gcc-1
Commit d0d92baf by Kaveh R. Ghazi Committed by Kaveh Ghazi
Options

re PR other/40302 (GCC must hard-require MPC before release) 

	PR other/40302
	* arith.c: Remove HAVE_mpc* checks throughout.
	* expr.c: Likewise.
	* gfortran.h: Likewise.
	* resolve.c: Likewise.
	* simplify.c: Likewise.
	* target-memory.c: Likewise.
	* target-memory.h: Likewise.

From-SVN: r155043
parent 2330bfb3
Showing with 29 additions and 654 deletions
gcc/fortran/ChangeLog
2009-12-07 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
PR other/40302
* arith.c: Remove HAVE_mpc* checks throughout.
* expr.c: Likewise.
* gfortran.h: Likewise.
* resolve.c: Likewise.
* simplify.c: Likewise.
* target-memory.c: Likewise.
* target-memory.h: Likewise.
2009-12-06 Daniel Franke <franke.daniel@gmail.com> 2009-12-06 Daniel Franke <franke.daniel@gmail.com>
PR fortran/40904 PR fortran/40904
......
gcc/fortran/arith.c
...@@ -429,12 +429,7 @@ gfc_constant_result (bt type, int kind, locus *where) ...@@ -429,12 +429,7 @@ gfc_constant_result (bt type, int kind, locus *where)
case BT_COMPLEX: case BT_COMPLEX:
gfc_set_model_kind (kind); gfc_set_model_kind (kind);
#ifdef HAVE_mpc
mpc_init2 (result->value.complex, mpfr_get_default_prec()); mpc_init2 (result->value.complex, mpfr_get_default_prec());
#else
mpfr_init (result->value.complex.r);
mpfr_init (result->value.complex.i);
#endif
break; break;
default: default:
...@@ -639,12 +634,7 @@ gfc_arith_uminus (gfc_expr *op1, gfc_expr **resultp) ...@@ -639,12 +634,7 @@ gfc_arith_uminus (gfc_expr *op1, gfc_expr **resultp)
break; break;
case BT_COMPLEX: case BT_COMPLEX:
#ifdef HAVE_mpc
mpc_neg (result->value.complex, op1->value.complex, GFC_MPC_RND_MODE); 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; break;
default: default:
...@@ -677,16 +667,8 @@ gfc_arith_plus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) ...@@ -677,16 +667,8 @@ gfc_arith_plus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
break; break;
case BT_COMPLEX: case BT_COMPLEX:
#ifdef HAVE_mpc
mpc_add (result->value.complex, op1->value.complex, op2->value.complex, mpc_add (result->value.complex, op1->value.complex, op2->value.complex,
GFC_MPC_RND_MODE); 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; break;
default: default:
...@@ -719,16 +701,8 @@ gfc_arith_minus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) ...@@ -719,16 +701,8 @@ gfc_arith_minus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
break; break;
case BT_COMPLEX: case BT_COMPLEX:
#ifdef HAVE_mpc
mpc_sub (result->value.complex, op1->value.complex, mpc_sub (result->value.complex, op1->value.complex,
op2->value.complex, GFC_MPC_RND_MODE); 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; break;
default: default:
...@@ -762,26 +736,8 @@ gfc_arith_times (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) ...@@ -762,26 +736,8 @@ gfc_arith_times (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
case BT_COMPLEX: case BT_COMPLEX:
gfc_set_model (mpc_realref (op1->value.complex)); gfc_set_model (mpc_realref (op1->value.complex));
#ifdef HAVE_mpc
mpc_mul (result->value.complex, op1->value.complex, op2->value.complex, mpc_mul (result->value.complex, op1->value.complex, op2->value.complex,
GFC_MPC_RND_MODE); GFC_MPC_RND_MODE);
#else
{
mpfr_t x, y;
mpfr_init (x);
mpfr_init (y);
mpfr_mul (x, op1->value.complex.r, op2->value.complex.r, GFC_RND_MODE);
mpfr_mul (y, op1->value.complex.i, op2->value.complex.i, GFC_RND_MODE);
mpfr_sub (result->value.complex.r, x, y, GFC_RND_MODE);
mpfr_mul (x, op1->value.complex.r, op2->value.complex.i, GFC_RND_MODE);
mpfr_mul (y, op1->value.complex.i, op2->value.complex.r, GFC_RND_MODE);
mpfr_add (result->value.complex.i, x, y, GFC_RND_MODE);
mpfr_clears (x, y, NULL);
}
#endif
break; break;
default: default:
...@@ -829,13 +785,7 @@ gfc_arith_divide (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) ...@@ -829,13 +785,7 @@ gfc_arith_divide (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
break; break;
case BT_COMPLEX: case BT_COMPLEX:
if ( if (mpc_cmp_si_si (op2->value.complex, 0, 0) == 0
#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) && gfc_option.flag_range_check == 1)
{ {
rc = ARITH_DIV0; rc = ARITH_DIV0;
...@@ -843,8 +793,6 @@ gfc_arith_divide (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) ...@@ -843,8 +793,6 @@ gfc_arith_divide (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
} }
gfc_set_model (mpc_realref (op1->value.complex)); gfc_set_model (mpc_realref (op1->value.complex));
#ifdef HAVE_mpc
if (mpc_cmp_si_si (op2->value.complex, 0, 0) == 0) if (mpc_cmp_si_si (op2->value.complex, 0, 0) == 0)
{ {
/* In Fortran, return (NaN + NaN I) for any zero divisor. See /* In Fortran, return (NaN + NaN I) for any zero divisor. See
...@@ -855,32 +803,6 @@ gfc_arith_divide (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) ...@@ -855,32 +803,6 @@ gfc_arith_divide (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
else else
mpc_div (result->value.complex, op1->value.complex, op2->value.complex, mpc_div (result->value.complex, op1->value.complex, op2->value.complex,
GFC_MPC_RND_MODE); GFC_MPC_RND_MODE);
#else
{
mpfr_t x, y, div;
mpfr_init (x);
mpfr_init (y);
mpfr_init (div);
mpfr_mul (x, op2->value.complex.r, op2->value.complex.r, GFC_RND_MODE);
mpfr_mul (y, op2->value.complex.i, op2->value.complex.i, GFC_RND_MODE);
mpfr_add (div, x, y, GFC_RND_MODE);
mpfr_mul (x, op1->value.complex.r, op2->value.complex.r, GFC_RND_MODE);
mpfr_mul (y, op1->value.complex.i, op2->value.complex.i, GFC_RND_MODE);
mpfr_add (result->value.complex.r, x, y, GFC_RND_MODE);
mpfr_div (result->value.complex.r, result->value.complex.r, div,
GFC_RND_MODE);
mpfr_mul (x, op1->value.complex.i, op2->value.complex.r, GFC_RND_MODE);
mpfr_mul (y, op1->value.complex.r, op2->value.complex.i, GFC_RND_MODE);
mpfr_sub (result->value.complex.i, x, y, GFC_RND_MODE);
mpfr_div (result->value.complex.i, result->value.complex.i, div,
GFC_RND_MODE);
mpfr_clears (x, y, div, NULL);
}
#endif
break; break;
default: default:
...@@ -893,107 +815,6 @@ gfc_arith_divide (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) ...@@ -893,107 +815,6 @@ gfc_arith_divide (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
return check_result (rc, op1, result, resultp); return check_result (rc, op1, result, resultp);
} }
/* Compute the reciprocal of a complex number (guaranteed nonzero). */
#if ! defined(HAVE_mpc_pow)
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;
mpfr_init (mod);
mpfr_init (tmp);
mpfr_mul (mod, op->value.complex.r, op->value.complex.r, GFC_RND_MODE);
mpfr_mul (tmp, op->value.complex.i, op->value.complex.i, GFC_RND_MODE);
mpfr_add (mod, mod, tmp, GFC_RND_MODE);
mpfr_div (op->value.complex.r, op->value.complex.r, mod, GFC_RND_MODE);
mpfr_neg (op->value.complex.i, op->value.complex.i, GFC_RND_MODE);
mpfr_div (op->value.complex.i, op->value.complex.i, mod, GFC_RND_MODE);
mpfr_clears (tmp, mod, NULL);
}
#endif
}
#endif /* ! HAVE_mpc_pow */
/* Raise a complex number to positive power (power > 0).
This function will modify the content of power.
Use Binary Method, which is not an optimal but a simple and reasonable
arithmetic. See section 4.6.3, "Evaluation of Powers" of Donald E. Knuth,
"Seminumerical Algorithms", Vol. 2, "The Art of Computer Programming",
3rd Edition, 1998. */
#if ! defined(HAVE_mpc_pow)
static void
complex_pow (gfc_expr *result, gfc_expr *base, mpz_t power)
{
mpfr_t x_r, x_i, tmp, re, im;
gfc_set_model (mpc_realref (base->value.complex));
mpfr_init (x_r);
mpfr_init (x_i);
mpfr_init (tmp);
mpfr_init (re);
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, 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. */
#define CMULT(res_r,res_i,a_r,a_i,b_r,b_i) \
mpfr_mul (re, a_r, b_r, GFC_RND_MODE), \
mpfr_mul (tmp, a_i, b_i, GFC_RND_MODE), \
mpfr_sub (re, re, tmp, GFC_RND_MODE), \
\
mpfr_mul (im, a_r, b_i, GFC_RND_MODE), \
mpfr_mul (tmp, a_i, b_r, GFC_RND_MODE), \
mpfr_add (res_i, im, tmp, GFC_RND_MODE), \
mpfr_set (res_r, re, GFC_RND_MODE)
#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))
{
/* if (power & 1) res = res * x; */
if (mpz_congruent_ui_p (power, 1, 2))
CMULT(res_r,res_i,res_r,res_i,x_r,x_i);
/* power /= 2; */
mpz_fdiv_q_ui (power, power, 2);
}
#undef res_r
#undef res_i
#undef CMULT
mpfr_clears (x_r, x_i, tmp, re, im, NULL);
}
#endif /* ! HAVE_mpc_pow */
/* Raise a number to a power. */ /* Raise a number to a power. */
static arith static arith
...@@ -1028,12 +849,7 @@ arith_power (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) ...@@ -1028,12 +849,7 @@ arith_power (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
break; break;
case BT_COMPLEX: case BT_COMPLEX:
#ifdef HAVE_mpc
mpc_set_ui (result->value.complex, 1, GFC_MPC_RND_MODE); 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; break;
default: default:
...@@ -1110,32 +926,8 @@ arith_power (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) ...@@ -1110,32 +926,8 @@ arith_power (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
break; break;
case BT_COMPLEX: case BT_COMPLEX:
{ mpc_pow_z (result->value.complex, op1->value.complex,
#ifdef HAVE_mpc_pow_z op2->value.integer, GFC_MPC_RND_MODE);
mpc_pow_z (result->value.complex, op1->value.complex,
op2->value.integer, GFC_MPC_RND_MODE);
#elif defined(HAVE_mpc_pow)
mpc_t apower;
gfc_set_model (mpc_realref (op1->value.complex));
mpc_init2 (apower, mpfr_get_default_prec());
mpc_set_z (apower, op2->value.integer, GFC_MPC_RND_MODE);
mpc_pow(result->value.complex, op1->value.complex, apower,
GFC_MPC_RND_MODE);
mpc_clear (apower);
#else
mpz_t apower;
/* Compute op1**abs(op2) */
mpz_init (apower);
mpz_abs (apower, op2->value.integer);
complex_pow (result, op1, apower);
mpz_clear (apower);
/* If (op2 < 0), compute the inverse. */
if (power_sign < 0)
complex_reciprocal (result);
#endif /* HAVE_mpc_pow */
}
break; break;
default: default:
...@@ -1176,63 +968,8 @@ arith_power (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) ...@@ -1176,63 +968,8 @@ arith_power (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
return ARITH_PROHIBIT; return ARITH_PROHIBIT;
} }
#ifdef HAVE_mpc_pow
mpc_pow (result->value.complex, op1->value.complex, mpc_pow (result->value.complex, op1->value.complex,
op2->value.complex, GFC_MPC_RND_MODE); op2->value.complex, GFC_MPC_RND_MODE);
#else
{
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_log (r, r, GFC_RND_MODE);
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, 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, 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 (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);
}
#endif /* HAVE_mpc_pow */
} }
break; break;
default: default:
...@@ -1350,12 +1087,7 @@ gfc_compare_expr (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op) ...@@ -1350,12 +1087,7 @@ gfc_compare_expr (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
static int static int
compare_complex (gfc_expr *op1, gfc_expr *op2) compare_complex (gfc_expr *op1, gfc_expr *op2)
{ {
#ifdef HAVE_mpc
return mpc_cmp (op1->value.complex, op2->value.complex) == 0; 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
} }
...@@ -2224,13 +1956,8 @@ gfc_convert_complex (gfc_expr *real, gfc_expr *imag, int kind) ...@@ -2224,13 +1956,8 @@ gfc_convert_complex (gfc_expr *real, gfc_expr *imag, int kind)
gfc_expr *e; gfc_expr *e;
e = gfc_constant_result (BT_COMPLEX, kind, &real->where); 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, mpc_set_fr_fr (e->value.complex, real->value.real, imag->value.real,
GFC_MPC_RND_MODE); 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; return e;
} }
...@@ -2350,12 +2077,7 @@ gfc_int2complex (gfc_expr *src, int kind) ...@@ -2350,12 +2077,7 @@ gfc_int2complex (gfc_expr *src, int kind)
result = gfc_constant_result (BT_COMPLEX, kind, &src->where); 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); 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 (mpc_realref (result->value.complex), kind)) if ((rc = gfc_check_real_range (mpc_realref (result->value.complex), kind))
!= ARITH_OK) != ARITH_OK)
...@@ -2433,12 +2155,7 @@ gfc_real2complex (gfc_expr *src, int kind) ...@@ -2433,12 +2155,7 @@ gfc_real2complex (gfc_expr *src, int kind)
result = gfc_constant_result (BT_COMPLEX, kind, &src->where); 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); 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 (mpc_realref (result->value.complex), kind); rc = gfc_check_real_range (mpc_realref (result->value.complex), kind);
...@@ -2493,11 +2210,7 @@ gfc_complex2real (gfc_expr *src, int kind) ...@@ -2493,11 +2210,7 @@ gfc_complex2real (gfc_expr *src, int kind)
result = gfc_constant_result (BT_REAL, kind, &src->where); result = gfc_constant_result (BT_REAL, kind, &src->where);
#ifdef HAVE_mpc
mpc_real (result->value.real, src->value.complex, GFC_RND_MODE); 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); rc = gfc_check_real_range (result->value.real, kind);
...@@ -2528,12 +2241,7 @@ gfc_complex2complex (gfc_expr *src, int kind) ...@@ -2528,12 +2241,7 @@ gfc_complex2complex (gfc_expr *src, int kind)
result = gfc_constant_result (BT_COMPLEX, kind, &src->where); result = gfc_constant_result (BT_COMPLEX, kind, &src->where);
#ifdef HAVE_mpc
mpc_set (result->value.complex, src->value.complex, GFC_MPC_RND_MODE); 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 (mpc_realref (result->value.complex), kind); rc = gfc_check_real_range (mpc_realref (result->value.complex), kind);
...@@ -2698,13 +2406,7 @@ gfc_hollerith2complex (gfc_expr *src, int kind) ...@@ -2698,13 +2406,7 @@ gfc_hollerith2complex (gfc_expr *src, int kind)
hollerith2representation (result, src); hollerith2representation (result, src);
gfc_interpret_complex (kind, (unsigned char *) result->representation.string, gfc_interpret_complex (kind, (unsigned char *) result->representation.string,
result->representation.length, result->representation.length, result->value.complex);
#ifdef HAVE_mpc
result->value.complex
#else
result->value.complex.r, result->value.complex.i
#endif
);
return result; return result;
} }
......
gcc/fortran/expr.c
...@@ -156,12 +156,7 @@ free_expr0 (gfc_expr *e) ...@@ -156,12 +156,7 @@ free_expr0 (gfc_expr *e)
break; break;
case BT_COMPLEX: case BT_COMPLEX:
#ifdef HAVE_mpc
mpc_clear (e->value.complex); mpc_clear (e->value.complex);
#else
mpfr_clear (e->value.complex.r);
mpfr_clear (e->value.complex.i);
#endif
break; break;
default: default:
...@@ -473,15 +468,8 @@ gfc_copy_expr (gfc_expr *p) ...@@ -473,15 +468,8 @@ gfc_copy_expr (gfc_expr *p)
case BT_COMPLEX: case BT_COMPLEX:
gfc_set_model_kind (q->ts.kind); gfc_set_model_kind (q->ts.kind);
#ifdef HAVE_mpc
mpc_init2 (q->value.complex, mpfr_get_default_prec()); mpc_init2 (q->value.complex, mpfr_get_default_prec());
mpc_set (q->value.complex, p->value.complex, GFC_MPC_RND_MODE); mpc_set (q->value.complex, p->value.complex, GFC_MPC_RND_MODE);
#else
mpfr_init (q->value.complex.r);
mpfr_init (q->value.complex.i);
mpfr_set (q->value.complex.r, p->value.complex.r, GFC_RND_MODE);
mpfr_set (q->value.complex.i, p->value.complex.i, GFC_RND_MODE);
#endif
break; break;
case BT_CHARACTER: case BT_CHARACTER:
......
gcc/fortran/gfortran.h
...@@ -1624,19 +1624,7 @@ gfc_class_esym_list; ...@@ -1624,19 +1624,7 @@ gfc_class_esym_list;
#include <gmp.h> #include <gmp.h>
#include <mpfr.h> #include <mpfr.h>
#ifdef HAVE_mpc
#include <mpc.h> #include <mpc.h>
# if MPC_VERSION >= MPC_VERSION_NUM(0,6,1)
# define HAVE_mpc_pow
# endif
# if MPC_VERSION >= MPC_VERSION_NUM(0,7,1)
# define HAVE_mpc_arc
# define HAVE_mpc_pow_z
# endif
#else
#define mpc_realref(X) ((X).r)
#define mpc_imagref(X) ((X).i)
#endif
#define GFC_RND_MODE GMP_RNDN #define GFC_RND_MODE GMP_RNDN
#define GFC_MPC_RND_MODE MPC_RNDNN #define GFC_MPC_RND_MODE MPC_RNDNN
...@@ -1695,15 +1683,7 @@ typedef struct gfc_expr ...@@ -1695,15 +1683,7 @@ typedef struct gfc_expr
mpfr_t real; mpfr_t real;
#ifdef HAVE_mpc mpc_t complex;
mpc_t
#else
struct
{
mpfr_t r, i;
}
#endif
complex;
struct struct
{ {
......
gcc/fortran/resolve.c
...@@ -8649,12 +8649,7 @@ build_default_init_expr (gfc_symbol *sym) ...@@ -8649,12 +8649,7 @@ build_default_init_expr (gfc_symbol *sym)
break; break;
case BT_COMPLEX: case BT_COMPLEX:
#ifdef HAVE_mpc
mpc_init2 (init_expr->value.complex, mpfr_get_default_prec()); mpc_init2 (init_expr->value.complex, mpfr_get_default_prec());
#else
mpfr_init (init_expr->value.complex.r);
mpfr_init (init_expr->value.complex.i);
#endif
switch (gfc_option.flag_init_real) switch (gfc_option.flag_init_real)
{ {
case GFC_INIT_REAL_SNAN: case GFC_INIT_REAL_SNAN:
...@@ -8676,12 +8671,7 @@ build_default_init_expr (gfc_symbol *sym) ...@@ -8676,12 +8671,7 @@ build_default_init_expr (gfc_symbol *sym)
break; break;
case GFC_INIT_REAL_ZERO: case GFC_INIT_REAL_ZERO:
#ifdef HAVE_mpc
mpc_set_ui (init_expr->value.complex, 0, GFC_MPC_RND_MODE); mpc_set_ui (init_expr->value.complex, 0, GFC_MPC_RND_MODE);
#else
mpfr_set_ui (init_expr->value.complex.r, 0.0, GFC_RND_MODE);
mpfr_set_ui (init_expr->value.complex.i, 0.0, GFC_RND_MODE);
#endif
break; break;
default: default:
......
gcc/fortran/simplify.c
...@@ -283,12 +283,7 @@ init_result_expr (gfc_expr *e, int init, gfc_expr *array) ...@@ -283,12 +283,7 @@ init_result_expr (gfc_expr *e, int init, gfc_expr *array)
break; break;
case BT_COMPLEX: case BT_COMPLEX:
#ifdef HAVE_mpc
mpc_set_si (e->value.complex, init, GFC_MPC_RND_MODE); 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; break;
case BT_CHARACTER: case BT_CHARACTER:
...@@ -644,12 +639,7 @@ gfc_simplify_abs (gfc_expr *e) ...@@ -644,12 +639,7 @@ gfc_simplify_abs (gfc_expr *e)
gfc_set_model_kind (e->ts.kind); gfc_set_model_kind (e->ts.kind);
#ifdef HAVE_mpc
mpc_abs (result->value.real, e->value.complex, GFC_RND_MODE); 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"); result = range_check (result, "CABS");
break; break;
...@@ -749,13 +739,9 @@ gfc_simplify_acos (gfc_expr *x) ...@@ -749,13 +739,9 @@ gfc_simplify_acos (gfc_expr *x)
mpfr_acos (result->value.real, x->value.real, GFC_RND_MODE); mpfr_acos (result->value.real, x->value.real, GFC_RND_MODE);
break; break;
case BT_COMPLEX: case BT_COMPLEX:
#ifdef HAVE_mpc_arc
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
mpc_acos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); mpc_acos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
break; break;
#else
return NULL;
#endif
default: default:
gfc_internal_error ("in gfc_simplify_acos(): Bad type"); gfc_internal_error ("in gfc_simplify_acos(): Bad type");
} }
...@@ -786,13 +772,9 @@ gfc_simplify_acosh (gfc_expr *x) ...@@ -786,13 +772,9 @@ gfc_simplify_acosh (gfc_expr *x)
mpfr_acosh (result->value.real, x->value.real, GFC_RND_MODE); mpfr_acosh (result->value.real, x->value.real, GFC_RND_MODE);
break; break;
case BT_COMPLEX: case BT_COMPLEX:
#ifdef HAVE_mpc_arc
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
mpc_acosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); mpc_acosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
break; break;
#else
return NULL;
#endif
default: default:
gfc_internal_error ("in gfc_simplify_acosh(): Bad type"); gfc_internal_error ("in gfc_simplify_acosh(): Bad type");
} }
...@@ -1054,13 +1036,9 @@ gfc_simplify_asin (gfc_expr *x) ...@@ -1054,13 +1036,9 @@ gfc_simplify_asin (gfc_expr *x)
mpfr_asin (result->value.real, x->value.real, GFC_RND_MODE); mpfr_asin (result->value.real, x->value.real, GFC_RND_MODE);
break; break;
case BT_COMPLEX: case BT_COMPLEX:
#ifdef HAVE_mpc_arc
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
mpc_asin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); mpc_asin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
break; break;
#else
return NULL;
#endif
default: default:
gfc_internal_error ("in gfc_simplify_asin(): Bad type"); gfc_internal_error ("in gfc_simplify_asin(): Bad type");
} }
...@@ -1084,13 +1062,9 @@ gfc_simplify_asinh (gfc_expr *x) ...@@ -1084,13 +1062,9 @@ gfc_simplify_asinh (gfc_expr *x)
mpfr_asinh (result->value.real, x->value.real, GFC_RND_MODE); mpfr_asinh (result->value.real, x->value.real, GFC_RND_MODE);
break; break;
case BT_COMPLEX: case BT_COMPLEX:
#ifdef HAVE_mpc_arc
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
mpc_asinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); mpc_asinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
break; break;
#else
return NULL;
#endif
default: default:
gfc_internal_error ("in gfc_simplify_asinh(): Bad type"); gfc_internal_error ("in gfc_simplify_asinh(): Bad type");
} }
...@@ -1114,13 +1088,9 @@ gfc_simplify_atan (gfc_expr *x) ...@@ -1114,13 +1088,9 @@ gfc_simplify_atan (gfc_expr *x)
mpfr_atan (result->value.real, x->value.real, GFC_RND_MODE); mpfr_atan (result->value.real, x->value.real, GFC_RND_MODE);
break; break;
case BT_COMPLEX: case BT_COMPLEX:
#ifdef HAVE_mpc_arc
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
mpc_atan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); mpc_atan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
break; break;
#else
return NULL;
#endif
default: default:
gfc_internal_error ("in gfc_simplify_atan(): Bad type"); gfc_internal_error ("in gfc_simplify_atan(): Bad type");
} }
...@@ -1152,13 +1122,9 @@ gfc_simplify_atanh (gfc_expr *x) ...@@ -1152,13 +1122,9 @@ gfc_simplify_atanh (gfc_expr *x)
mpfr_atanh (result->value.real, x->value.real, GFC_RND_MODE); mpfr_atanh (result->value.real, x->value.real, GFC_RND_MODE);
break; break;
case BT_COMPLEX: case BT_COMPLEX:
#ifdef HAVE_mpc_arc
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
mpc_atanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); mpc_atanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
break; break;
#else
return NULL;
#endif
default: default:
gfc_internal_error ("in gfc_simplify_atanh(): Bad type"); gfc_internal_error ("in gfc_simplify_atanh(): Bad type");
} }
...@@ -1357,36 +1323,19 @@ simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind) ...@@ -1357,36 +1323,19 @@ simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind)
result = gfc_constant_result (BT_COMPLEX, kind, &x->where); 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) switch (x->ts.type)
{ {
case BT_INTEGER: case BT_INTEGER:
if (!x->is_boz) if (!x->is_boz)
#ifdef HAVE_mpc
mpc_set_z (result->value.complex, x->value.integer, GFC_MPC_RND_MODE); 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; break;
case BT_REAL: case BT_REAL:
#ifdef HAVE_mpc
mpc_set_fr (result->value.complex, x->value.real, GFC_RND_MODE); 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; break;
case BT_COMPLEX: case BT_COMPLEX:
#ifdef HAVE_mpc
mpc_set (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); 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; break;
default: default:
...@@ -1517,12 +1466,7 @@ gfc_simplify_conjg (gfc_expr *e) ...@@ -1517,12 +1466,7 @@ gfc_simplify_conjg (gfc_expr *e)
return NULL; return NULL;
result = gfc_copy_expr (e); result = gfc_copy_expr (e);
#ifdef HAVE_mpc
mpc_conj (result->value.complex, result->value.complex, GFC_MPC_RND_MODE); 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"); return range_check (result, "CONJG");
} }
...@@ -1544,26 +1488,7 @@ gfc_simplify_cos (gfc_expr *x) ...@@ -1544,26 +1488,7 @@ gfc_simplify_cos (gfc_expr *x)
break; break;
case BT_COMPLEX: case BT_COMPLEX:
gfc_set_model_kind (x->ts.kind); gfc_set_model_kind (x->ts.kind);
#ifdef HAVE_mpc
mpc_cos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); mpc_cos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
#else
{
mpfr_t xp, xq;
mpfr_init (xp);
mpfr_init (xq);
mpfr_cos (xp, x->value.complex.r, GFC_RND_MODE);
mpfr_cosh (xq, x->value.complex.i, GFC_RND_MODE);
mpfr_mul (result->value.complex.r, xp, xq, GFC_RND_MODE);
mpfr_sin (xp, x->value.complex.r, GFC_RND_MODE);
mpfr_sinh (xq, x->value.complex.i, GFC_RND_MODE);
mpfr_mul (xp, xp, xq, GFC_RND_MODE);
mpfr_neg (result->value.complex.i, xp, GFC_RND_MODE );
mpfr_clears (xp, xq, NULL);
}
#endif
break; break;
default: default:
gfc_internal_error ("in gfc_simplify_cos(): Bad type"); gfc_internal_error ("in gfc_simplify_cos(): Bad type");
...@@ -1587,14 +1512,7 @@ gfc_simplify_cosh (gfc_expr *x) ...@@ -1587,14 +1512,7 @@ gfc_simplify_cosh (gfc_expr *x)
if (x->ts.type == BT_REAL) if (x->ts.type == BT_REAL)
mpfr_cosh (result->value.real, x->value.real, GFC_RND_MODE); mpfr_cosh (result->value.real, x->value.real, GFC_RND_MODE);
else if (x->ts.type == BT_COMPLEX) else if (x->ts.type == BT_COMPLEX)
{ mpc_cosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
#if HAVE_mpc
mpc_cosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
#else
gfc_free_expr (result);
return NULL;
#endif
}
else else
gcc_unreachable (); gcc_unreachable ();
...@@ -2000,21 +1918,7 @@ gfc_simplify_exp (gfc_expr *x) ...@@ -2000,21 +1918,7 @@ gfc_simplify_exp (gfc_expr *x)
case BT_COMPLEX: case BT_COMPLEX:
gfc_set_model_kind (x->ts.kind); gfc_set_model_kind (x->ts.kind);
#ifdef HAVE_mpc
mpc_exp (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); mpc_exp (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
#else
{
mpfr_t xp, xq;
mpfr_init (xp);
mpfr_init (xq);
mpfr_exp (xq, x->value.complex.r, GFC_RND_MODE);
mpfr_cos (xp, x->value.complex.i, GFC_RND_MODE);
mpfr_mul (result->value.complex.r, xq, xp, GFC_RND_MODE);
mpfr_sin (xp, x->value.complex.i, GFC_RND_MODE);
mpfr_mul (result->value.complex.i, xq, xp, GFC_RND_MODE);
mpfr_clears (xp, xq, NULL);
}
#endif
break; break;
default: default:
...@@ -3393,26 +3297,7 @@ gfc_simplify_log (gfc_expr *x) ...@@ -3393,26 +3297,7 @@ gfc_simplify_log (gfc_expr *x)
} }
gfc_set_model_kind (x->ts.kind); gfc_set_model_kind (x->ts.kind);
#ifdef HAVE_mpc
mpc_log (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); mpc_log (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
#else
{
mpfr_t xr, xi;
mpfr_init (xr);
mpfr_init (xi);
mpfr_atan2 (result->value.complex.i, x->value.complex.i,
x->value.complex.r, GFC_RND_MODE);
mpfr_mul (xr, x->value.complex.r, x->value.complex.r, GFC_RND_MODE);
mpfr_mul (xi, x->value.complex.i, x->value.complex.i, GFC_RND_MODE);
mpfr_add (xr, xr, xi, GFC_RND_MODE);
mpfr_sqrt (xr, xr, GFC_RND_MODE);
mpfr_log (result->value.complex.r, xr, GFC_RND_MODE);
mpfr_clears (xr, xi, NULL);
}
#endif
break; break;
default: default:
...@@ -4305,12 +4190,7 @@ gfc_simplify_realpart (gfc_expr *e) ...@@ -4305,12 +4190,7 @@ gfc_simplify_realpart (gfc_expr *e)
return NULL; return NULL;
result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where); 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); 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"); return range_check (result, "REALPART");
} }
...@@ -5089,25 +4969,7 @@ gfc_simplify_sin (gfc_expr *x) ...@@ -5089,25 +4969,7 @@ gfc_simplify_sin (gfc_expr *x)
case BT_COMPLEX: case BT_COMPLEX:
gfc_set_model (x->value.real); gfc_set_model (x->value.real);
#ifdef HAVE_mpc
mpc_sin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); mpc_sin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
#else
{
mpfr_t xp, xq;
mpfr_init (xp);
mpfr_init (xq);
mpfr_sin (xp, x->value.complex.r, GFC_RND_MODE);
mpfr_cosh (xq, x->value.complex.i, GFC_RND_MODE);
mpfr_mul (result->value.complex.r, xp, xq, GFC_RND_MODE);
mpfr_cos (xp, x->value.complex.r, GFC_RND_MODE);
mpfr_sinh (xq, x->value.complex.i, GFC_RND_MODE);
mpfr_mul (result->value.complex.i, xp, xq, GFC_RND_MODE);
mpfr_clears (xp, xq, NULL);
}
#endif
break; break;
default: default:
...@@ -5131,14 +4993,7 @@ gfc_simplify_sinh (gfc_expr *x) ...@@ -5131,14 +4993,7 @@ gfc_simplify_sinh (gfc_expr *x)
if (x->ts.type == BT_REAL) if (x->ts.type == BT_REAL)
mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE); mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE);
else if (x->ts.type == BT_COMPLEX) else if (x->ts.type == BT_COMPLEX)
{ mpc_sinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
#if HAVE_mpc
mpc_sinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
#else
gfc_free_expr (result);
return NULL;
#endif
}
else else
gcc_unreachable (); gcc_unreachable ();
...@@ -5329,87 +5184,7 @@ gfc_simplify_sqrt (gfc_expr *e) ...@@ -5329,87 +5184,7 @@ gfc_simplify_sqrt (gfc_expr *e)
case BT_COMPLEX: case BT_COMPLEX:
gfc_set_model (e->value.real); gfc_set_model (e->value.real);
#ifdef HAVE_mpc
mpc_sqrt (result->value.complex, e->value.complex, GFC_MPC_RND_MODE); mpc_sqrt (result->value.complex, e->value.complex, GFC_MPC_RND_MODE);
#else
{
/* Formula taken from Numerical Recipes to avoid over- and
underflow. */
mpfr_t ac, ad, s, t, w;
mpfr_init (ac);
mpfr_init (ad);
mpfr_init (s);
mpfr_init (t);
mpfr_init (w);
if (mpfr_cmp_ui (e->value.complex.r, 0) == 0
&& mpfr_cmp_ui (e->value.complex.i, 0) == 0)
{
mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE);
mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
break;
}
mpfr_abs (ac, e->value.complex.r, GFC_RND_MODE);
mpfr_abs (ad, e->value.complex.i, GFC_RND_MODE);
if (mpfr_cmp (ac, ad) >= 0)
{
mpfr_div (t, e->value.complex.i, e->value.complex.r, GFC_RND_MODE);
mpfr_mul (t, t, t, GFC_RND_MODE);
mpfr_add_ui (t, t, 1, GFC_RND_MODE);
mpfr_sqrt (t, t, GFC_RND_MODE);
mpfr_add_ui (t, t, 1, GFC_RND_MODE);
mpfr_div_ui (t, t, 2, GFC_RND_MODE);
mpfr_sqrt (t, t, GFC_RND_MODE);
mpfr_sqrt (s, ac, GFC_RND_MODE);
mpfr_mul (w, s, t, GFC_RND_MODE);
}
else
{
mpfr_div (s, e->value.complex.r, e->value.complex.i, GFC_RND_MODE);
mpfr_mul (t, s, s, GFC_RND_MODE);
mpfr_add_ui (t, t, 1, GFC_RND_MODE);
mpfr_sqrt (t, t, GFC_RND_MODE);
mpfr_abs (s, s, GFC_RND_MODE);
mpfr_add (t, t, s, GFC_RND_MODE);
mpfr_div_ui (t, t, 2, GFC_RND_MODE);
mpfr_sqrt (t, t, GFC_RND_MODE);
mpfr_sqrt (s, ad, GFC_RND_MODE);
mpfr_mul (w, s, t, GFC_RND_MODE);
}
if (mpfr_cmp_ui (w, 0) != 0 && mpfr_cmp_ui (e->value.complex.r, 0) >= 0)
{
mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
mpfr_div (result->value.complex.i, e->value.complex.i, t, GFC_RND_MODE);
mpfr_set (result->value.complex.r, w, GFC_RND_MODE);
}
else if (mpfr_cmp_ui (w, 0) != 0
&& mpfr_cmp_ui (e->value.complex.r, 0) < 0
&& mpfr_cmp_ui (e->value.complex.i, 0) >= 0)
{
mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
mpfr_div (result->value.complex.r, e->value.complex.i, t, GFC_RND_MODE);
mpfr_set (result->value.complex.i, w, GFC_RND_MODE);
}
else if (mpfr_cmp_ui (w, 0) != 0
&& mpfr_cmp_ui (e->value.complex.r, 0) < 0
&& mpfr_cmp_ui (e->value.complex.i, 0) < 0)
{
mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
mpfr_div (result->value.complex.r, ad, t, GFC_RND_MODE);
mpfr_neg (w, w, GFC_RND_MODE);
mpfr_set (result->value.complex.i, w, GFC_RND_MODE);
}
else
gfc_internal_error ("invalid complex argument of SQRT at %L",
&e->where);
mpfr_clears (s, t, ac, ad, w, NULL);
}
#endif
break; break;
default: default:
...@@ -5462,14 +5237,7 @@ gfc_simplify_tan (gfc_expr *x) ...@@ -5462,14 +5237,7 @@ gfc_simplify_tan (gfc_expr *x)
if (x->ts.type == BT_REAL) if (x->ts.type == BT_REAL)
mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE); mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE);
else if (x->ts.type == BT_COMPLEX) else if (x->ts.type == BT_COMPLEX)
{ mpc_tan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
#if HAVE_mpc
mpc_tan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
#else
gfc_free_expr (result);
return NULL;
#endif
}
else else
gcc_unreachable (); gcc_unreachable ();
...@@ -5490,14 +5258,7 @@ gfc_simplify_tanh (gfc_expr *x) ...@@ -5490,14 +5258,7 @@ gfc_simplify_tanh (gfc_expr *x)
if (x->ts.type == BT_REAL) if (x->ts.type == BT_REAL)
mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE); mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE);
else if (x->ts.type == BT_COMPLEX) else if (x->ts.type == BT_COMPLEX)
{ mpc_tanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
#if HAVE_mpc
mpc_tanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
#else
gfc_free_expr (result);
return NULL;
#endif
}
else else
gcc_unreachable (); gcc_unreachable ();
......
gcc/fortran/target-memory.c
...@@ -164,28 +164,12 @@ encode_float (int kind, mpfr_t real, unsigned char *buffer, size_t buffer_size) ...@@ -164,28 +164,12 @@ encode_float (int kind, mpfr_t real, unsigned char *buffer, size_t buffer_size)
static int static int
encode_complex (int kind, encode_complex (int kind, mpc_t cmplx,
#ifdef HAVE_mpc
mpc_t cmplx,
#else
mpfr_t real, mpfr_t imaginary,
#endif
unsigned char *buffer, size_t buffer_size) unsigned char *buffer, size_t buffer_size)
{ {
int size; int size;
size = encode_float (kind, size = encode_float (kind, mpc_realref (cmplx), &buffer[0], buffer_size);
#ifdef HAVE_mpc size += encode_float (kind, mpc_imagref (cmplx),
mpc_realref (cmplx),
#else
real,
#endif
&buffer[0], buffer_size);
size += encode_float (kind,
#ifdef HAVE_mpc
mpc_imagref (cmplx),
#else
imaginary,
#endif
&buffer[size], buffer_size - size); &buffer[size], buffer_size - size);
return size; return size;
} }
...@@ -283,13 +267,7 @@ gfc_target_encode_expr (gfc_expr *source, unsigned char *buffer, ...@@ -283,13 +267,7 @@ gfc_target_encode_expr (gfc_expr *source, unsigned char *buffer,
return encode_float (source->ts.kind, source->value.real, buffer, return encode_float (source->ts.kind, source->value.real, buffer,
buffer_size); buffer_size);
case BT_COMPLEX: case BT_COMPLEX:
return encode_complex (source->ts.kind, return encode_complex (source->ts.kind, source->value.complex,
#ifdef HAVE_mpc
source->value.complex,
#else
source->value.complex.r,
source->value.complex.i,
#endif
buffer, buffer_size); buffer, buffer_size);
case BT_LOGICAL: case BT_LOGICAL:
return encode_logical (source->ts.kind, source->value.logical, buffer, return encode_logical (source->ts.kind, source->value.logical, buffer,
...@@ -391,28 +369,13 @@ gfc_interpret_float (int kind, unsigned char *buffer, size_t buffer_size, ...@@ -391,28 +369,13 @@ gfc_interpret_float (int kind, unsigned char *buffer, size_t buffer_size,
int int
gfc_interpret_complex (int kind, unsigned char *buffer, size_t buffer_size, gfc_interpret_complex (int kind, unsigned char *buffer, size_t buffer_size,
#ifdef HAVE_mpc mpc_t complex)
mpc_t complex
#else
mpfr_t real, mpfr_t imaginary
#endif
)
{ {
int size; int size;
size = gfc_interpret_float (kind, &buffer[0], buffer_size, size = gfc_interpret_float (kind, &buffer[0], buffer_size,
#ifdef HAVE_mpc mpc_realref (complex));
mpc_realref (complex)
#else
real
#endif
);
size += gfc_interpret_float (kind, &buffer[size], buffer_size - size, size += gfc_interpret_float (kind, &buffer[size], buffer_size - size,
#ifdef HAVE_mpc mpc_imagref (complex));
mpc_imagref (complex)
#else
imaginary
#endif
);
return size; return size;
} }
...@@ -559,13 +522,7 @@ gfc_target_interpret_expr (unsigned char *buffer, size_t buffer_size, ...@@ -559,13 +522,7 @@ gfc_target_interpret_expr (unsigned char *buffer, size_t buffer_size,
case BT_COMPLEX: case BT_COMPLEX:
result->representation.length = result->representation.length =
gfc_interpret_complex (result->ts.kind, buffer, buffer_size, gfc_interpret_complex (result->ts.kind, buffer, buffer_size,
#ifdef HAVE_mpc result->value.complex);
result->value.complex
#else
result->value.complex.r,
result->value.complex.i
#endif
);
break; break;
case BT_LOGICAL: case BT_LOGICAL:
...@@ -766,19 +723,9 @@ gfc_convert_boz (gfc_expr *expr, gfc_typespec *ts) ...@@ -766,19 +723,9 @@ gfc_convert_boz (gfc_expr *expr, gfc_typespec *ts)
} }
else else
{ {
#ifdef HAVE_mpc
mpc_init2 (expr->value.complex, mpfr_get_default_prec()); mpc_init2 (expr->value.complex, mpfr_get_default_prec());
#else
mpfr_init (expr->value.complex.r);
mpfr_init (expr->value.complex.i);
#endif
gfc_interpret_complex (ts->kind, buffer, buffer_size, gfc_interpret_complex (ts->kind, buffer, buffer_size,
#ifdef HAVE_mpc expr->value.complex);
expr->value.complex
#else
expr->value.complex.r, expr->value.complex.i
#endif
);
} }
expr->is_boz = 0; expr->is_boz = 0;
expr->ts.type = ts->type; expr->ts.type = ts->type;
......
gcc/fortran/target-memory.h
...@@ -39,11 +39,7 @@ int gfc_target_encode_expr (gfc_expr *, unsigned char *, size_t); ...@@ -39,11 +39,7 @@ int gfc_target_encode_expr (gfc_expr *, unsigned char *, size_t);
int gfc_interpret_integer (int, unsigned char *, size_t, mpz_t); int gfc_interpret_integer (int, unsigned char *, size_t, mpz_t);
int gfc_interpret_float (int, unsigned char *, size_t, mpfr_t); int gfc_interpret_float (int, unsigned char *, size_t, mpfr_t);
#ifdef HAVE_mpc
int gfc_interpret_complex (int, unsigned char *, size_t, mpc_t); int gfc_interpret_complex (int, unsigned char *, size_t, mpc_t);
#else
int gfc_interpret_complex (int, unsigned char *, size_t, mpfr_t, mpfr_t);
#endif
int gfc_interpret_logical (int, unsigned char *, size_t, int *); int gfc_interpret_logical (int, unsigned char *, size_t, int *);
int gfc_interpret_character (unsigned char *, size_t, gfc_expr *); int gfc_interpret_character (unsigned char *, size_t, gfc_expr *);
int gfc_interpret_derived (unsigned char *, size_t, gfc_expr *); int gfc_interpret_derived (unsigned char *, size_t, gfc_expr *);
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment