+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>
PR fortran/40904
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:
-#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:
case BT_COMPLEX:
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_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;
default:
break;
case BT_COMPLEX:
- 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
+ if (mpc_cmp_si_si (op2->value.complex, 0, 0) == 0
&& gfc_option.flag_range_check == 1)
{
rc = ARITH_DIV0;
}
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
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);
-
- 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;
default:
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. */
static arith
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:
break;
case BT_COMPLEX:
- {
-#ifdef HAVE_mpc_pow_z
- 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 */
- }
+ mpc_pow_z (result->value.complex, op1->value.complex,
+ op2->value.integer, GFC_MPC_RND_MODE);
break;
default:
return ARITH_PROHIBIT;
}
-#ifdef HAVE_mpc_pow
mpc_pow (result->value.complex, op1->value.complex,
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;
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 (mpc_realref (result->value.complex), kind))
!= ARITH_OK)
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 (mpc_realref (result->value.complex), kind);
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 (mpc_realref (result->value.complex), kind);
hollerith2representation (result, src);
gfc_interpret_complex (kind, (unsigned char *) result->representation.string,
- result->representation.length,
-#ifdef HAVE_mpc
- result->value.complex
-#else
- result->value.complex.r, result->value.complex.i
-#endif
- );
+ result->representation.length, result->value.complex);
return result;
}
break;
case BT_COMPLEX:
-#ifdef HAVE_mpc
mpc_clear (e->value.complex);
-#else
- mpfr_clear (e->value.complex.r);
- mpfr_clear (e->value.complex.i);
-#endif
break;
default:
case BT_COMPLEX:
gfc_set_model_kind (q->ts.kind);
-#ifdef HAVE_mpc
mpc_init2 (q->value.complex, mpfr_get_default_prec());
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;
case BT_CHARACTER:
#include <gmp.h>
#include <mpfr.h>
-#ifdef HAVE_mpc
#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_MPC_RND_MODE MPC_RNDNN
mpfr_t real;
-#ifdef HAVE_mpc
- mpc_t
-#else
- struct
- {
- mpfr_t r, i;
- }
-#endif
- complex;
+ mpc_t complex;
struct
{
break;
case BT_COMPLEX:
-#ifdef HAVE_mpc
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)
{
case GFC_INIT_REAL_SNAN:
break;
case GFC_INIT_REAL_ZERO:
-#ifdef HAVE_mpc
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;
default:
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;
mpfr_acos (result->value.real, x->value.real, GFC_RND_MODE);
break;
case BT_COMPLEX:
-#ifdef HAVE_mpc_arc
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
mpc_acos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
break;
-#else
- return NULL;
-#endif
default:
gfc_internal_error ("in gfc_simplify_acos(): Bad type");
}
mpfr_acosh (result->value.real, x->value.real, GFC_RND_MODE);
break;
case BT_COMPLEX:
-#ifdef HAVE_mpc_arc
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
mpc_acosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
break;
-#else
- return NULL;
-#endif
default:
gfc_internal_error ("in gfc_simplify_acosh(): Bad type");
}
mpfr_asin (result->value.real, x->value.real, GFC_RND_MODE);
break;
case BT_COMPLEX:
-#ifdef HAVE_mpc_arc
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
mpc_asin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
break;
-#else
- return NULL;
-#endif
default:
gfc_internal_error ("in gfc_simplify_asin(): Bad type");
}
mpfr_asinh (result->value.real, x->value.real, GFC_RND_MODE);
break;
case BT_COMPLEX:
-#ifdef HAVE_mpc_arc
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
mpc_asinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
break;
-#else
- return NULL;
-#endif
default:
gfc_internal_error ("in gfc_simplify_asinh(): Bad type");
}
mpfr_atan (result->value.real, x->value.real, GFC_RND_MODE);
break;
case BT_COMPLEX:
-#ifdef HAVE_mpc_arc
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
mpc_atan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
break;
-#else
- return NULL;
-#endif
default:
gfc_internal_error ("in gfc_simplify_atan(): Bad type");
}
mpfr_atanh (result->value.real, x->value.real, GFC_RND_MODE);
break;
case BT_COMPLEX:
-#ifdef HAVE_mpc_arc
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
mpc_atanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
break;
-#else
- return NULL;
-#endif
default:
gfc_internal_error ("in gfc_simplify_atanh(): Bad type");
}
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:
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");
}
break;
case BT_COMPLEX:
gfc_set_model_kind (x->ts.kind);
-#ifdef HAVE_mpc
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;
default:
gfc_internal_error ("in gfc_simplify_cos(): Bad type");
if (x->ts.type == BT_REAL)
mpfr_cosh (result->value.real, x->value.real, GFC_RND_MODE);
else if (x->ts.type == BT_COMPLEX)
- {
-#if HAVE_mpc
- mpc_cosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
-#else
- gfc_free_expr (result);
- return NULL;
-#endif
- }
+ mpc_cosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
else
gcc_unreachable ();
case BT_COMPLEX:
gfc_set_model_kind (x->ts.kind);
-#ifdef HAVE_mpc
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;
default:
}
gfc_set_model_kind (x->ts.kind);
-#ifdef HAVE_mpc
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;
default:
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
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;
default:
if (x->ts.type == BT_REAL)
mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE);
else if (x->ts.type == BT_COMPLEX)
- {
-#if HAVE_mpc
- mpc_sinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
-#else
- gfc_free_expr (result);
- return NULL;
-#endif
- }
+ mpc_sinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
else
gcc_unreachable ();
case BT_COMPLEX:
gfc_set_model (e->value.real);
-#ifdef HAVE_mpc
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;
default:
if (x->ts.type == BT_REAL)
mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE);
else if (x->ts.type == BT_COMPLEX)
- {
-#if HAVE_mpc
- mpc_tan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
-#else
- gfc_free_expr (result);
- return NULL;
-#endif
- }
+ mpc_tan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
else
gcc_unreachable ();
if (x->ts.type == BT_REAL)
mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE);
else if (x->ts.type == BT_COMPLEX)
- {
-#if HAVE_mpc
- mpc_tanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
-#else
- gfc_free_expr (result);
- return NULL;
-#endif
- }
+ mpc_tanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
else
gcc_unreachable ();
static int
-encode_complex (int kind,
-#ifdef HAVE_mpc
- mpc_t cmplx,
-#else
- mpfr_t real, mpfr_t imaginary,
-#endif
+encode_complex (int kind, mpc_t cmplx,
unsigned char *buffer, size_t buffer_size)
{
int size;
- size = encode_float (kind,
-#ifdef HAVE_mpc
- mpc_realref (cmplx),
-#else
- real,
-#endif
- &buffer[0], buffer_size);
- size += encode_float (kind,
-#ifdef HAVE_mpc
- mpc_imagref (cmplx),
-#else
- imaginary,
-#endif
+ size = encode_float (kind, mpc_realref (cmplx), &buffer[0], buffer_size);
+ size += encode_float (kind, mpc_imagref (cmplx),
&buffer[size], buffer_size - size);
return size;
}
return encode_float (source->ts.kind, source->value.real, buffer,
buffer_size);
case BT_COMPLEX:
- return encode_complex (source->ts.kind,
-#ifdef HAVE_mpc
- source->value.complex,
-#else
- source->value.complex.r,
- source->value.complex.i,
-#endif
+ return encode_complex (source->ts.kind, source->value.complex,
buffer, buffer_size);
case BT_LOGICAL:
return encode_logical (source->ts.kind, source->value.logical, buffer,
int
gfc_interpret_complex (int kind, unsigned char *buffer, size_t buffer_size,
-#ifdef HAVE_mpc
- mpc_t complex
-#else
- mpfr_t real, mpfr_t imaginary
-#endif
- )
+ mpc_t complex)
{
int size;
size = gfc_interpret_float (kind, &buffer[0], buffer_size,
-#ifdef HAVE_mpc
- mpc_realref (complex)
-#else
- real
-#endif
- );
+ mpc_realref (complex));
size += gfc_interpret_float (kind, &buffer[size], buffer_size - size,
-#ifdef HAVE_mpc
- mpc_imagref (complex)
-#else
- imaginary
-#endif
- );
+ mpc_imagref (complex));
return size;
}
case BT_COMPLEX:
result->representation.length =
gfc_interpret_complex (result->ts.kind, buffer, buffer_size,
-#ifdef HAVE_mpc
- result->value.complex
-#else
- result->value.complex.r,
- result->value.complex.i
-#endif
- );
+ result->value.complex);
break;
case BT_LOGICAL:
}
else
{
-#ifdef HAVE_mpc
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,
-#ifdef HAVE_mpc
- expr->value.complex
-#else
- expr->value.complex.r, expr->value.complex.i
-#endif
- );
+ expr->value.complex);
}
expr->is_boz = 0;
expr->ts.type = ts->type;
int gfc_interpret_integer (int, unsigned char *, size_t, mpz_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);
-#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_character (unsigned char *, size_t, gfc_expr *);
int gfc_interpret_derived (unsigned char *, size_t, gfc_expr *);