/* 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. */
}
-/* 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);
-#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;
- }
-
- 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;
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:
-#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:
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:
-#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:
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:
-#ifdef HAVE_mpc
mpc_sub (result->value.complex, op1->value.complex,
op2->value.complex, GFC_MPC_RND_MODE);
-#else
- mpfr_sub (result->value.complex.r, op1->value.complex.r,
- op2->value.complex.r, GFC_RND_MODE);
-
- mpfr_sub (result->value.complex.i, op1->value.complex.i,
- op2->value.complex.i, GFC_RND_MODE);
-#endif
break;
default:
gfc_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)
{
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:
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 (
-#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). */
-
-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
-}
-
-
-/* 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 (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);
-}
-
-
/* 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:
-#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:
- {
- 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:
{
- 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;
}
- {
- 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);
- }
+ 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)
{
-#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 *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;
-
- head = gfc_copy_constructor (op1->value.constructor);
- rc = ARITH_OK;
+ arith 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 (op1, op2, "elemental binary operation")
- != 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);
-#ifdef HAVE_mpc
+ 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);
-#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;
}
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);
-#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)
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);
-#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);
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, mpc_realref (src->value.complex),
&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);
-#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);
gfc_expr *result;
arith rc;
- result = gfc_constant_result (BT_COMPLEX, kind, &src->where);
+ result = gfc_get_constant_expr (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);
{
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;
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,
-#ifdef HAVE_mpc
- result->value.complex
-#else
- result->value.complex.r, result->value.complex.i
-#endif
- );
+ 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,
OSDN Git Service
