/* Compiler arithmetic
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+ 2009, 2010
Free Software Foundation, Inc.
Contributed by Andy Vaught
#include "gfortran.h"
#include "arith.h"
#include "target-memory.h"
+#include "constructor.h"
/* MPFR does not have a direct replacement for mpz_set_f() from GMP.
It's easily implemented with a few calls though. */
for (rp = gfc_real_kinds; rp->kind; rp++)
mpfr_clears (rp->epsilon, rp->huge, rp->tiny, rp->subnormal, NULL);
+
+ mpfr_free_cache ();
}
}
-/* Function to return a constant expression node of a given type and kind. */
-
-gfc_expr *
-gfc_constant_result (bt type, int kind, locus *where)
-{
- gfc_expr *result;
-
- if (!where)
- gfc_internal_error ("gfc_constant_result(): locus 'where' cannot be NULL");
-
- result = gfc_get_expr ();
-
- result->expr_type = EXPR_CONSTANT;
- result->ts.type = type;
- result->ts.kind = kind;
- result->where = *where;
-
- switch (type)
- {
- case BT_INTEGER:
- mpz_init (result->value.integer);
- break;
-
- case BT_REAL:
- gfc_set_model_kind (kind);
- mpfr_init (result->value.real);
- break;
-
- case BT_COMPLEX:
- gfc_set_model_kind (kind);
- mpfr_init (result->value.complex.r);
- mpfr_init (result->value.complex.i);
- break;
-
- default:
- break;
- }
-
- return result;
-}
-
-
/* Low-level arithmetic functions. All of these subroutines assume
that all operands are of the same type and return an operand of the
same type. The other thing about these subroutines is that they
{
gfc_expr *result;
- result = gfc_constant_result (BT_LOGICAL, op1->ts.kind, &op1->where);
+ result = gfc_get_constant_expr (BT_LOGICAL, op1->ts.kind, &op1->where);
result->value.logical = !op1->value.logical;
*resultp = result;
{
gfc_expr *result;
- result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2),
- &op1->where);
+ result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2),
+ &op1->where);
result->value.logical = op1->value.logical && op2->value.logical;
*resultp = result;
{
gfc_expr *result;
- result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2),
- &op1->where);
+ result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2),
+ &op1->where);
result->value.logical = op1->value.logical || op2->value.logical;
*resultp = result;
{
gfc_expr *result;
- result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2),
- &op1->where);
+ result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2),
+ &op1->where);
result->value.logical = op1->value.logical == op2->value.logical;
*resultp = result;
{
gfc_expr *result;
- result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2),
- &op1->where);
+ result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2),
+ &op1->where);
result->value.logical = op1->value.logical != op2->value.logical;
*resultp = result;
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;
gfc_expr *result;
arith rc;
- result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
+ result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
switch (op1->ts.type)
{
break;
case BT_COMPLEX:
- 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);
+ mpc_neg (result->value.complex, op1->value.complex, GFC_MPC_RND_MODE);
break;
default:
gfc_expr *result;
arith rc;
- result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
+ result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
switch (op1->ts.type)
{
break;
case BT_COMPLEX:
- 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);
+ mpc_add (result->value.complex, op1->value.complex, op2->value.complex,
+ GFC_MPC_RND_MODE);
break;
default:
gfc_expr *result;
arith rc;
- result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
+ result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
switch (op1->ts.type)
{
break;
case BT_COMPLEX:
- 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);
+ mpc_sub (result->value.complex, op1->value.complex,
+ op2->value.complex, GFC_MPC_RND_MODE);
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);
+ result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
switch (op1->ts.type)
{
break;
case BT_COMPLEX:
- gfc_set_model (op1->value.complex.r);
- 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);
+ gfc_set_model (mpc_realref (op1->value.complex));
+ mpc_mul (result->value.complex, op1->value.complex, op2->value.complex,
+ GFC_MPC_RND_MODE);
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;
- result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
+ result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
switch (op1->ts.type)
{
break;
case BT_COMPLEX:
- if (mpfr_sgn (op2->value.complex.r) == 0
- && mpfr_sgn (op2->value.complex.i) == 0
+ if (mpc_cmp_si_si (op2->value.complex, 0, 0) == 0
&& gfc_option.flag_range_check == 1)
{
rc = ARITH_DIV0;
break;
}
- gfc_set_model (op1->value.complex.r);
- 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);
+ gfc_set_model (mpc_realref (op1->value.complex));
+ 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);
break;
default:
return check_result (rc, op1, result, resultp);
}
-
-/* Compute the reciprocal of a complex number (guaranteed nonzero). */
-
-static void
-complex_reciprocal (gfc_expr *op)
-{
- mpfr_t mod, tmp;
-
- gfc_set_model (op->value.complex.r);
- 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);
-}
-
-
-/* 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. */
-
-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 (base->value.complex.r);
- mpfr_init (x_r);
- mpfr_init (x_i);
- mpfr_init (tmp);
- mpfr_init (re);
- mpfr_init (im);
-
- /* res = 1 */
- mpfr_set_ui (result->value.complex.r, 1, GFC_RND_MODE);
- mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
-
- /* x = base */
- mpfr_set (x_r, base->value.complex.r, GFC_RND_MODE);
- mpfr_set (x_i, base->value.complex.i, 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 result->value.complex.r
-#define res_i result->value.complex.i
-
- /* 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);
-}
-
-
/* Raise a number to a power. */
static arith
int power_sign;
gfc_expr *result;
arith rc;
- extern bool init_flag;
rc = ARITH_OK;
- result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
+ result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
switch (op2->ts.type)
{
break;
case BT_COMPLEX:
- mpfr_set_ui (result->value.complex.r, 1, GFC_RND_MODE);
- mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
+ mpc_set_ui (result->value.complex, 1, GFC_MPC_RND_MODE);
break;
default:
break;
case BT_COMPLEX:
- {
- 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);
- }
+ mpc_pow_z (result->value.complex, op1->value.complex,
+ op2->value.integer, GFC_MPC_RND_MODE);
break;
default:
case BT_REAL:
- if (init_flag)
+ if (gfc_init_expr_flag)
{
if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Noninteger "
"exponent in an initialization "
case BT_COMPLEX:
{
- mpfr_t x, y, r, t;
-
- if (init_flag)
+ if (gfc_init_expr_flag)
{
if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Noninteger "
"exponent in an initialization "
return ARITH_PROHIBIT;
}
- gfc_set_model (op1->value.complex.r);
-
- mpfr_init (r);
-
- mpfr_hypot (r, op1->value.complex.r, op1->value.complex.i,
- GFC_RND_MODE);
- if (mpfr_cmp_si (r, 0) == 0)
- {
- mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE);
- mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
- mpfr_clear (r);
- break;
- }
- mpfr_log (r, r, GFC_RND_MODE);
-
- mpfr_init (t);
-
- mpfr_atan2 (t, op1->value.complex.i, op1->value.complex.r,
- GFC_RND_MODE);
-
- 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_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_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_clears (r, t, x, y, NULL);
+ mpc_pow (result->value.complex, op1->value.complex,
+ op2->value.complex, GFC_MPC_RND_MODE);
}
break;
default:
int len;
gcc_assert (op1->ts.kind == op2->ts.kind);
- result = gfc_constant_result (BT_CHARACTER, op1->ts.kind,
- &op1->where);
+ result = gfc_get_constant_expr (BT_CHARACTER, op1->ts.kind,
+ &op1->where);
len = op1->value.character.length + op2->value.character.length;
static int
compare_complex (gfc_expr *op1, gfc_expr *op2)
{
- return (mpfr_equal_p (op1->value.complex.r, op2->value.complex.r)
- && mpfr_equal_p (op1->value.complex.i, op2->value.complex.i));
+ return mpc_cmp (op1->value.complex, op2->value.complex) == 0;
}
{
gfc_expr *result;
- result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
- &op1->where);
+ result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
+ &op1->where);
result->value.logical = (op1->ts.type == BT_COMPLEX)
? compare_complex (op1, op2)
: (gfc_compare_expr (op1, op2, INTRINSIC_EQ) == 0);
{
gfc_expr *result;
- result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
- &op1->where);
+ result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
+ &op1->where);
result->value.logical = (op1->ts.type == BT_COMPLEX)
? !compare_complex (op1, op2)
: (gfc_compare_expr (op1, op2, INTRINSIC_EQ) != 0);
{
gfc_expr *result;
- result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
- &op1->where);
+ result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
+ &op1->where);
result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GT) > 0);
*resultp = result;
{
gfc_expr *result;
- result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
- &op1->where);
+ result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
+ &op1->where);
result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GE) >= 0);
*resultp = result;
{
gfc_expr *result;
- result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
- &op1->where);
+ result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
+ &op1->where);
result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_LT) < 0);
*resultp = result;
{
gfc_expr *result;
- result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
- &op1->where);
+ result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
+ &op1->where);
result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_LE) <= 0);
*resultp = result;
reduce_unary (arith (*eval) (gfc_expr *, gfc_expr **), gfc_expr *op,
gfc_expr **result)
{
- gfc_constructor *c, *head;
+ gfc_constructor_base head;
+ gfc_constructor *c;
gfc_expr *r;
arith rc;
return eval (op, result);
rc = ARITH_OK;
- head = gfc_copy_constructor (op->value.constructor);
-
- for (c = head; c; c = c->next)
+ head = gfc_constructor_copy (op->value.constructor);
+ for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
{
rc = reduce_unary (eval, c->expr, &r);
}
if (rc != ARITH_OK)
- gfc_free_constructor (head);
+ gfc_constructor_free (head);
else
{
- r = gfc_get_expr ();
- r->expr_type = EXPR_ARRAY;
- r->value.constructor = head;
+ gfc_constructor *c = gfc_constructor_first (head);
+ r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
+ &op->where);
r->shape = gfc_copy_shape (op->shape, op->rank);
-
- r->ts = head->expr->ts;
- r->where = op->where;
r->rank = op->rank;
-
+ r->value.constructor = head;
*result = r;
}
reduce_binary_ac (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
{
- gfc_constructor *c, *head;
+ gfc_constructor_base head;
+ gfc_constructor *c;
gfc_expr *r;
- arith rc;
+ arith rc = ARITH_OK;
- head = gfc_copy_constructor (op1->value.constructor);
- rc = ARITH_OK;
-
- for (c = head; c; c = c->next)
+ head = gfc_constructor_copy (op1->value.constructor);
+ for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
{
if (c->expr->expr_type == EXPR_CONSTANT)
rc = eval (c->expr, op2, &r);
}
if (rc != ARITH_OK)
- gfc_free_constructor (head);
+ gfc_constructor_free (head);
else
{
- r = gfc_get_expr ();
- r->expr_type = EXPR_ARRAY;
- r->value.constructor = head;
+ gfc_constructor *c = gfc_constructor_first (head);
+ r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
+ &op1->where);
r->shape = gfc_copy_shape (op1->shape, op1->rank);
-
- r->ts = head->expr->ts;
- r->where = op1->where;
r->rank = op1->rank;
-
+ r->value.constructor = head;
*result = r;
}
reduce_binary_ca (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
{
- gfc_constructor *c, *head;
+ gfc_constructor_base head;
+ gfc_constructor *c;
gfc_expr *r;
- arith rc;
-
- head = gfc_copy_constructor (op2->value.constructor);
- rc = ARITH_OK;
+ arith rc = ARITH_OK;
- for (c = head; c; c = c->next)
+ head = gfc_constructor_copy (op2->value.constructor);
+ for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
{
if (c->expr->expr_type == EXPR_CONSTANT)
rc = eval (op1, c->expr, &r);
}
if (rc != ARITH_OK)
- gfc_free_constructor (head);
+ gfc_constructor_free (head);
else
{
- r = gfc_get_expr ();
- r->expr_type = EXPR_ARRAY;
- r->value.constructor = head;
+ gfc_constructor *c = gfc_constructor_first (head);
+ r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
+ &op2->where);
r->shape = gfc_copy_shape (op2->shape, op2->rank);
-
- r->ts = head->expr->ts;
- r->where = op2->where;
r->rank = op2->rank;
-
+ r->value.constructor = head;
*result = r;
}
reduce_binary_aa (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
{
- gfc_constructor *c, *d, *head;
+ gfc_constructor_base head;
+ gfc_constructor *c, *d;
gfc_expr *r;
- arith rc;
-
- head = gfc_copy_constructor (op1->value.constructor);
+ arith rc = ARITH_OK;
- rc = ARITH_OK;
- d = op2->value.constructor;
+ if (gfc_check_conformance (op1, op2,
+ "elemental binary operation") != SUCCESS)
+ return ARITH_INCOMMENSURATE;
- if (gfc_check_conformance ("elemental binary operation", op1, op2)
- != SUCCESS)
- rc = ARITH_INCOMMENSURATE;
- else
+ head = gfc_constructor_copy (op1->value.constructor);
+ for (c = gfc_constructor_first (head),
+ d = gfc_constructor_first (op2->value.constructor);
+ c && d;
+ c = gfc_constructor_next (c), d = gfc_constructor_next (d))
{
- for (c = head; c; c = c->next, d = d->next)
- {
- if (d == NULL)
- {
- rc = ARITH_INCOMMENSURATE;
- break;
- }
-
- rc = reduce_binary (eval, c->expr, d->expr, &r);
- if (rc != ARITH_OK)
- break;
-
- gfc_replace_expr (c->expr, r);
- }
+ rc = reduce_binary (eval, c->expr, d->expr, &r);
+ if (rc != ARITH_OK)
+ break;
- if (d != NULL)
- rc = ARITH_INCOMMENSURATE;
+ gfc_replace_expr (c->expr, r);
}
+ if (c || d)
+ rc = ARITH_INCOMMENSURATE;
+
if (rc != ARITH_OK)
- gfc_free_constructor (head);
+ gfc_constructor_free (head);
else
{
- r = gfc_get_expr ();
- r->expr_type = EXPR_ARRAY;
- r->value.constructor = head;
+ gfc_constructor *c = gfc_constructor_first (head);
+ r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
+ &op1->where);
r->shape = gfc_copy_shape (op1->shape, op1->rank);
-
- r->ts = head->expr->ts;
- r->where = op1->where;
r->rank = op1->rank;
-
+ r->value.constructor = head;
*result = r;
}
temp.value.op.op1 = op1;
temp.value.op.op2 = op2;
- gfc_type_convert_binary (&temp);
+ gfc_type_convert_binary (&temp, 0);
if (op == INTRINSIC_EQ || op == INTRINSIC_NE
|| op == INTRINSIC_GE || op == INTRINSIC_GT
runtime:
/* Create a run-time expression. */
- result = gfc_get_expr ();
+ result = gfc_get_operator_expr (&op1->where, op, op1, op2);
result->ts = temp.ts;
- result->expr_type = EXPR_OP;
- result->value.op.op = op;
-
- result->value.op.op1 = op1;
- result->value.op.op2 = op2;
-
- result->where = op1->where;
-
return result;
}
gfc_expr *e;
const char *t;
- e = gfc_constant_result (BT_INTEGER, kind, where);
+ e = gfc_get_constant_expr (BT_INTEGER, kind, where);
/* A leading plus is allowed, but not by mpz_set_str. */
if (buffer[0] == '+')
t = buffer + 1;
{
gfc_expr *e;
- e = gfc_constant_result (BT_REAL, kind, where);
+ e = gfc_get_constant_expr (BT_REAL, kind, where);
mpfr_set_str (e->value.real, buffer, 10, GFC_RND_MODE);
return e;
{
gfc_expr *e;
- e = gfc_constant_result (BT_COMPLEX, kind, &real->where);
- mpfr_set (e->value.complex.r, real->value.real, GFC_RND_MODE);
- mpfr_set (e->value.complex.i, imag->value.real, GFC_RND_MODE);
+ e = gfc_get_constant_expr (BT_COMPLEX, kind, &real->where);
+ mpc_set_fr_fr (e->value.complex, real->value.real, imag->value.real,
+ GFC_MPC_RND_MODE);
return e;
}
gfc_expr *result;
arith rc;
- result = gfc_constant_result (BT_INTEGER, kind, &src->where);
+ result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
mpz_set (result->value.integer, src->value.integer);
gfc_expr *result;
arith rc;
- result = gfc_constant_result (BT_REAL, kind, &src->where);
+ result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
mpfr_set_z (result->value.real, src->value.integer, GFC_RND_MODE);
gfc_expr *result;
arith rc;
- result = gfc_constant_result (BT_COMPLEX, kind, &src->where);
+ result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
- mpfr_set_z (result->value.complex.r, src->value.integer, GFC_RND_MODE);
- mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
+ mpc_set_z (result->value.complex, src->value.integer, GFC_MPC_RND_MODE);
- 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);
gfc_expr *result;
arith rc;
- result = gfc_constant_result (BT_INTEGER, kind, &src->where);
+ result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
gfc_mpfr_to_mpz (result->value.integer, src->value.real, &src->where);
gfc_expr *result;
arith rc;
- result = gfc_constant_result (BT_REAL, kind, &src->where);
+ result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
mpfr_set (result->value.real, src->value.real, GFC_RND_MODE);
gfc_expr *result;
arith rc;
- result = gfc_constant_result (BT_COMPLEX, kind, &src->where);
+ result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
- mpfr_set (result->value.complex.r, src->value.real, GFC_RND_MODE);
- mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
+ mpc_set_fr (result->value.complex, src->value.real, GFC_MPC_RND_MODE);
- 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)
{
gfc_expr *result;
arith rc;
- result = gfc_constant_result (BT_INTEGER, kind, &src->where);
+ result = gfc_get_constant_expr (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)
{
gfc_expr *result;
arith rc;
- result = gfc_constant_result (BT_REAL, kind, &src->where);
+ result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
- mpfr_set (result->value.real, src->value.complex.r, GFC_RND_MODE);
+ mpc_real (result->value.real, src->value.complex, GFC_RND_MODE);
rc = gfc_check_real_range (result->value.real, kind);
gfc_expr *result;
arith rc;
- result = gfc_constant_result (BT_COMPLEX, kind, &src->where);
+ result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
- 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);
+ mpc_set (result->value.complex, src->value.complex, GFC_MPC_RND_MODE);
- 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)
{
{
gfc_expr *result;
- result = gfc_constant_result (BT_LOGICAL, kind, &src->where);
+ result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
result->value.logical = src->value.logical;
return result;
{
gfc_expr *result;
- result = gfc_constant_result (BT_INTEGER, kind, &src->where);
+ result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
mpz_set_si (result->value.integer, src->value.logical);
return result;
{
gfc_expr *result;
- result = gfc_constant_result (BT_LOGICAL, kind, &src->where);
+ result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
result->value.logical = (mpz_cmp_si (src->value.integer, 0) != 0);
return result;
{
int src_len, result_len;
- src_len = src->representation.length;
+ src_len = src->representation.length - src->ts.u.pad;
result_len = gfc_target_expr_size (result);
if (src_len > result_len)
gfc_hollerith2int (gfc_expr *src, int kind)
{
gfc_expr *result;
-
- result = gfc_get_expr ();
- result->expr_type = EXPR_CONSTANT;
- result->ts.type = BT_INTEGER;
- result->ts.kind = kind;
- result->where = src->where;
+ result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
hollerith2representation (result, src);
gfc_interpret_integer (kind, (unsigned char *) result->representation.string,
gfc_hollerith2real (gfc_expr *src, int kind)
{
gfc_expr *result;
- int len;
-
- len = src->value.character.length;
-
- result = gfc_get_expr ();
- result->expr_type = EXPR_CONSTANT;
- result->ts.type = BT_REAL;
- result->ts.kind = kind;
- result->where = src->where;
+ result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
hollerith2representation (result, src);
gfc_interpret_float (kind, (unsigned char *) result->representation.string,
gfc_hollerith2complex (gfc_expr *src, int kind)
{
gfc_expr *result;
- int len;
-
- len = src->value.character.length;
-
- result = gfc_get_expr ();
- result->expr_type = EXPR_CONSTANT;
- result->ts.type = BT_COMPLEX;
- result->ts.kind = kind;
- result->where = src->where;
+ result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
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, result->value.complex);
return result;
}
gfc_hollerith2logical (gfc_expr *src, int kind)
{
gfc_expr *result;
- int len;
-
- len = src->value.character.length;
-
- result = gfc_get_expr ();
- result->expr_type = EXPR_CONSTANT;
- result->ts.type = BT_LOGICAL;
- result->ts.kind = kind;
- result->where = src->where;
+ result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
hollerith2representation (result, src);
gfc_interpret_logical (kind, (unsigned char *) result->representation.string,
return result;
}
-
-
-/* Returns an initializer whose value is one higher than the value of the
- LAST_INITIALIZER argument. If the argument is NULL, the
- initializers value will be set to zero. The initializer's kind
- will be set to gfc_c_int_kind.
-
- If -fshort-enums is given, the appropriate kind will be selected
- later after all enumerators have been parsed. A warning is issued
- here if an initializer exceeds gfc_c_int_kind. */
-
-gfc_expr *
-gfc_enum_initializer (gfc_expr *last_initializer, locus where)
-{
- gfc_expr *result;
-
- result = gfc_get_expr ();
- result->expr_type = EXPR_CONSTANT;
- result->ts.type = BT_INTEGER;
- result->ts.kind = gfc_c_int_kind;
- result->where = where;
-
- mpz_init (result->value.integer);
-
- if (last_initializer != NULL)
- {
- mpz_add_ui (result->value.integer, last_initializer->value.integer, 1);
- result->where = last_initializer->where;
-
- if (gfc_check_integer_range (result->value.integer,
- gfc_c_int_kind) != ARITH_OK)
- {
- gfc_error ("Enumerator exceeds the C integer type at %C");
- return NULL;
- }
- }
- else
- {
- /* Control comes here, if it's the very first enumerator and no
- initializer has been given. It will be initialized to zero. */
- mpz_set_si (result->value.integer, 0);
- }
-
- return result;
-}
OSDN Git Service
