/* 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. */
void
-gfc_mpfr_to_mpz (mpz_t z, mpfr_t x)
+gfc_mpfr_to_mpz (mpz_t z, mpfr_t x, locus *where)
{
mp_exp_t e;
+ if (mpfr_inf_p (x) || mpfr_nan_p (x))
+ {
+ gfc_error ("Conversion of an Infinity or Not-a-Number at %L "
+ "to INTEGER", where);
+ mpz_set_ui (z, 0);
+ return;
+ }
+
e = mpfr_get_z_exp (z, x);
- /* MPFR 2.0.1 (included with GMP 4.1) has a bug whereby mpfr_get_z_exp
- may set the sign of z incorrectly. Work around that here. */
- if (mpfr_sgn (x) != mpz_sgn (z))
- mpz_neg (z, z);
if (e > 0)
mpz_mul_2exp (z, z, e);
for (rp = gfc_real_kinds; rp->kind; rp++)
mpfr_clears (rp->epsilon, rp->huge, rp->tiny, rp->subnormal, NULL);
+
+ mpfr_free_cache ();
}
en = gfc_real_kinds[i].min_exponent - gfc_real_kinds[i].digits + 1;
mpfr_set_emin ((mp_exp_t) en);
mpfr_set_emax ((mp_exp_t) gfc_real_kinds[i].max_exponent);
+ mpfr_check_range (q, 0, GFC_RND_MODE);
mpfr_subnormalize (q, 0, GFC_RND_MODE);
/* Reset emin and emax. */
}
-/* 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 an integer power. */
+/* Raise a number to a power. */
static arith
-gfc_arith_power (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
+arith_power (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
{
int power_sign;
gfc_expr *result;
arith rc;
- gcc_assert (op2->expr_type == EXPR_CONSTANT && op2->ts.type == BT_INTEGER);
-
rc = ARITH_OK;
- result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
- power_sign = mpz_sgn (op2->value.integer);
+ result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
- if (power_sign == 0)
+ switch (op2->ts.type)
{
- /* Handle something to the zeroth power. Since we're dealing
- with integral exponents, there is no ambiguity in the
- limiting procedure used to determine the value of 0**0. */
- switch (op1->ts.type)
+ case BT_INTEGER:
+ power_sign = mpz_sgn (op2->value.integer);
+
+ if (power_sign == 0)
{
- case BT_INTEGER:
- mpz_set_ui (result->value.integer, 1);
- break;
+ /* Handle something to the zeroth power. Since we're dealing
+ with integral exponents, there is no ambiguity in the
+ limiting procedure used to determine the value of 0**0. */
+ switch (op1->ts.type)
+ {
+ case BT_INTEGER:
+ mpz_set_ui (result->value.integer, 1);
+ break;
- case BT_REAL:
- mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
- break;
+ case BT_REAL:
+ mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
+ 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);
- break;
+ case BT_COMPLEX:
+ mpc_set_ui (result->value.complex, 1, GFC_MPC_RND_MODE);
+ break;
- default:
- gfc_internal_error ("gfc_arith_power(): Bad base");
+ default:
+ gfc_internal_error ("arith_power(): Bad base");
+ }
}
- }
- else
- {
- switch (op1->ts.type)
+ else
{
- case BT_INTEGER:
- {
- int power;
-
- /* First, we simplify the cases of op1 == 1, 0 or -1. */
- if (mpz_cmp_si (op1->value.integer, 1) == 0)
- {
- /* 1**op2 == 1 */
- mpz_set_si (result->value.integer, 1);
- }
- else if (mpz_cmp_si (op1->value.integer, 0) == 0)
- {
- /* 0**op2 == 0, if op2 > 0
- 0**op2 overflow, if op2 < 0 ; in that case, we
- set the result to 0 and return ARITH_DIV0. */
- mpz_set_si (result->value.integer, 0);
- if (mpz_cmp_si (op2->value.integer, 0) < 0)
- rc = ARITH_DIV0;
- }
- else if (mpz_cmp_si (op1->value.integer, -1) == 0)
+ switch (op1->ts.type)
+ {
+ case BT_INTEGER:
{
- /* (-1)**op2 == (-1)**(mod(op2,2)) */
- unsigned int odd = mpz_fdiv_ui (op2->value.integer, 2);
- if (odd)
- mpz_set_si (result->value.integer, -1);
+ int power;
+
+ /* First, we simplify the cases of op1 == 1, 0 or -1. */
+ if (mpz_cmp_si (op1->value.integer, 1) == 0)
+ {
+ /* 1**op2 == 1 */
+ mpz_set_si (result->value.integer, 1);
+ }
+ else if (mpz_cmp_si (op1->value.integer, 0) == 0)
+ {
+ /* 0**op2 == 0, if op2 > 0
+ 0**op2 overflow, if op2 < 0 ; in that case, we
+ set the result to 0 and return ARITH_DIV0. */
+ mpz_set_si (result->value.integer, 0);
+ if (mpz_cmp_si (op2->value.integer, 0) < 0)
+ rc = ARITH_DIV0;
+ }
+ else if (mpz_cmp_si (op1->value.integer, -1) == 0)
+ {
+ /* (-1)**op2 == (-1)**(mod(op2,2)) */
+ unsigned int odd = mpz_fdiv_ui (op2->value.integer, 2);
+ if (odd)
+ mpz_set_si (result->value.integer, -1);
+ else
+ mpz_set_si (result->value.integer, 1);
+ }
+ /* Then, we take care of op2 < 0. */
+ else if (mpz_cmp_si (op2->value.integer, 0) < 0)
+ {
+ /* if op2 < 0, op1**op2 == 0 because abs(op1) > 1. */
+ mpz_set_si (result->value.integer, 0);
+ }
+ else if (gfc_extract_int (op2, &power) != NULL)
+ {
+ /* If op2 doesn't fit in an int, the exponentiation will
+ overflow, because op2 > 0 and abs(op1) > 1. */
+ mpz_t max;
+ int i;
+ i = gfc_validate_kind (BT_INTEGER, result->ts.kind, false);
+
+ if (gfc_option.flag_range_check)
+ rc = ARITH_OVERFLOW;
+
+ /* Still, we want to give the same value as the
+ processor. */
+ mpz_init (max);
+ mpz_add_ui (max, gfc_integer_kinds[i].huge, 1);
+ mpz_mul_ui (max, max, 2);
+ mpz_powm (result->value.integer, op1->value.integer,
+ op2->value.integer, max);
+ mpz_clear (max);
+ }
else
- mpz_set_si (result->value.integer, 1);
- }
- /* Then, we take care of op2 < 0. */
- else if (mpz_cmp_si (op2->value.integer, 0) < 0)
- {
- /* if op2 < 0, op1**op2 == 0 because abs(op1) > 1. */
- mpz_set_si (result->value.integer, 0);
+ mpz_pow_ui (result->value.integer, op1->value.integer,
+ power);
}
- else if (gfc_extract_int (op2, &power) != NULL)
- {
- /* If op2 doesn't fit in an int, the exponentiation will
- overflow, because op2 > 0 and abs(op1) > 1. */
- mpz_t max;
- int i = gfc_validate_kind (BT_INTEGER, result->ts.kind, false);
-
- if (gfc_option.flag_range_check)
- rc = ARITH_OVERFLOW;
-
- /* Still, we want to give the same value as the processor. */
- mpz_init (max);
- mpz_add_ui (max, gfc_integer_kinds[i].huge, 1);
- mpz_mul_ui (max, max, 2);
- mpz_powm (result->value.integer, op1->value.integer,
- op2->value.integer, max);
- mpz_clear (max);
- }
- else
- mpz_pow_ui (result->value.integer, op1->value.integer, power);
- }
- break;
+ break;
- case BT_REAL:
- mpfr_pow_z (result->value.real, op1->value.real, op2->value.integer,
- GFC_RND_MODE);
- break;
+ case BT_REAL:
+ mpfr_pow_z (result->value.real, op1->value.real,
+ op2->value.integer, GFC_RND_MODE);
+ break;
- case BT_COMPLEX:
- {
- mpz_t apower;
+ case BT_COMPLEX:
+ mpc_pow_z (result->value.complex, op1->value.complex,
+ op2->value.integer, GFC_MPC_RND_MODE);
+ break;
- /* Compute op1**abs(op2) */
- mpz_init (apower);
- mpz_abs (apower, op2->value.integer);
- complex_pow (result, op1, apower);
- mpz_clear (apower);
+ default:
+ break;
+ }
+ }
+ break;
- /* If (op2 < 0), compute the inverse. */
- if (power_sign < 0)
- complex_reciprocal (result);
+ case BT_REAL:
- break;
- }
+ if (gfc_init_expr_flag)
+ {
+ if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Noninteger "
+ "exponent in an initialization "
+ "expression at %L", &op2->where) == FAILURE)
+ return ARITH_PROHIBIT;
+ }
- default:
- break;
+ if (mpfr_cmp_si (op1->value.real, 0) < 0)
+ {
+ gfc_error ("Raising a negative REAL at %L to "
+ "a REAL power is prohibited", &op1->where);
+ gfc_free (result);
+ return ARITH_PROHIBIT;
}
+
+ mpfr_pow (result->value.real, op1->value.real, op2->value.real,
+ GFC_RND_MODE);
+ break;
+
+ case BT_COMPLEX:
+ {
+ if (gfc_init_expr_flag)
+ {
+ if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Noninteger "
+ "exponent in an initialization "
+ "expression at %L", &op2->where) == FAILURE)
+ return ARITH_PROHIBIT;
+ }
+
+ mpc_pow (result->value.complex, op1->value.complex,
+ op2->value.complex, GFC_MPC_RND_MODE);
+ }
+ break;
+ default:
+ gfc_internal_error ("arith_power(): unknown type");
}
if (rc == ARITH_OK)
gfc_expr *result;
int len;
- result = gfc_constant_result (BT_CHARACTER, gfc_default_character_kind,
- &op1->where);
+ gcc_assert (op1->ts.kind == op2->ts.kind);
+ result = gfc_get_constant_expr (BT_CHARACTER, op1->ts.kind,
+ &op1->where);
len = op1->value.character.length + op2->value.character.length;
}
/* Comparison between real values; returns 0 if (op1 .op. op2) is true.
- This function mimics mpr_cmp but takes NaN into account. */
+ This function mimics mpfr_cmp but takes NaN into account. */
static int
compare_real (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
/* Compare a pair of complex numbers. Naturally, this is only for
- equality and nonequality. */
+ equality and inequality. */
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;
-
- 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;
+ arith rc = ARITH_OK;
- head = gfc_copy_constructor (op2->value.constructor);
- 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;
+ arith rc = ARITH_OK;
- head = gfc_copy_constructor (op1->value.constructor);
+ if (gfc_check_conformance (op1, op2,
+ "elemental binary operation") != SUCCESS)
+ return ARITH_INCOMMENSURATE;
- rc = ARITH_OK;
- d = op2->value.constructor;
-
- 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;
}
operands are array constructors. */
static gfc_expr *
-eval_intrinsic (gfc_intrinsic_op operator,
+eval_intrinsic (gfc_intrinsic_op op,
eval_f eval, gfc_expr *op1, gfc_expr *op2)
{
gfc_expr temp, *result;
gfc_clear_ts (&temp.ts);
- switch (operator)
+ switch (op)
{
/* Logical unary */
case INTRINSIC_NOT:
temp.expr_type = EXPR_OP;
gfc_clear_ts (&temp.ts);
- temp.value.op.operator = operator;
+ temp.value.op.op = op;
temp.value.op.op1 = op1;
temp.value.op.op2 = op2;
- gfc_type_convert_binary (&temp);
+ gfc_type_convert_binary (&temp, 0);
- if (operator == INTRINSIC_EQ || operator == INTRINSIC_NE
- || operator == INTRINSIC_GE || operator == INTRINSIC_GT
- || operator == INTRINSIC_LE || operator == INTRINSIC_LT
- || operator == INTRINSIC_EQ_OS || operator == INTRINSIC_NE_OS
- || operator == INTRINSIC_GE_OS || operator == INTRINSIC_GT_OS
- || operator == INTRINSIC_LE_OS || operator == INTRINSIC_LT_OS)
+ if (op == INTRINSIC_EQ || op == INTRINSIC_NE
+ || op == INTRINSIC_GE || op == INTRINSIC_GT
+ || op == INTRINSIC_LE || op == INTRINSIC_LT
+ || op == INTRINSIC_EQ_OS || op == INTRINSIC_NE_OS
+ || op == INTRINSIC_GE_OS || op == INTRINSIC_GT_OS
+ || op == INTRINSIC_LE_OS || op == INTRINSIC_LT_OS)
{
temp.ts.type = BT_LOGICAL;
temp.ts.kind = gfc_default_logical_kind;
gfc_internal_error ("eval_intrinsic(): Bad operator");
}
- /* Try to combine the operators. */
- if (operator == INTRINSIC_POWER && op2->ts.type != BT_INTEGER)
- goto runtime;
-
if (op1->expr_type != EXPR_CONSTANT
&& (op1->expr_type != EXPR_ARRAY
|| !gfc_is_constant_expr (op1) || !gfc_expanded_ac (op1)))
else
rc = reduce_binary (eval.f3, op1, op2, &result);
+
+ /* Something went wrong. */
+ if (op == INTRINSIC_POWER && rc == ARITH_PROHIBIT)
+ return NULL;
+
if (rc != ARITH_OK)
- { /* Something went wrong. */
+ {
gfc_error (gfc_arith_error (rc), &op1->where);
return NULL;
}
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.operator = operator;
-
- result->value.op.op1 = op1;
- result->value.op.op2 = op2;
-
- result->where = op1->where;
-
return result;
}
static gfc_expr *
-eval_intrinsic_f2 (gfc_intrinsic_op operator,
+eval_intrinsic_f2 (gfc_intrinsic_op op,
arith (*eval) (gfc_expr *, gfc_expr **),
gfc_expr *op1, gfc_expr *op2)
{
if (op2 == NULL)
{
if (gfc_zero_size_array (op1))
- return eval_type_intrinsic0 (operator, op1);
+ return eval_type_intrinsic0 (op, op1);
}
else
{
result = reduce_binary0 (op1, op2);
if (result != NULL)
- return eval_type_intrinsic0 (operator, result);
+ return eval_type_intrinsic0 (op, result);
}
f.f2 = eval;
- return eval_intrinsic (operator, f, op1, op2);
+ return eval_intrinsic (op, f, op1, op2);
}
static gfc_expr *
-eval_intrinsic_f3 (gfc_intrinsic_op operator,
+eval_intrinsic_f3 (gfc_intrinsic_op op,
arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
gfc_expr *op1, gfc_expr *op2)
{
result = reduce_binary0 (op1, op2);
if (result != NULL)
- return eval_type_intrinsic0(operator, result);
+ return eval_type_intrinsic0(op, result);
f.f3 = eval;
- return eval_intrinsic (operator, f, op1, op2);
+ return eval_intrinsic (op, f, op1, op2);
}
gfc_expr *
gfc_power (gfc_expr *op1, gfc_expr *op2)
{
- return eval_intrinsic_f3 (INTRINSIC_POWER, gfc_arith_power, op1, op2);
+ return eval_intrinsic_f3 (INTRINSIC_POWER, arith_power, op1, op2);
}
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_typename (from), gfc_typename (to), where);
break;
case ARITH_UNDERFLOW:
- gfc_error ("Arithmetic underflow converting %s to %s at %L",
+ gfc_error ("Arithmetic underflow converting %s to %s at %L. This check "
+ "can be disabled with the option -fno-range-check",
gfc_typename (from), gfc_typename (to), where);
break;
case ARITH_NAN:
- gfc_error ("Arithmetic NaN converting %s to %s at %L",
+ gfc_error ("Arithmetic NaN converting %s to %s at %L. This check "
+ "can be disabled with the option -fno-range-check",
gfc_typename (from), gfc_typename (to), where);
break;
case ARITH_DIV0:
gfc_internal_error ("gfc_arith_error(): Bad error code");
}
- /* TODO: Do something about the error, ie, throw exception, return
+ /* TODO: Do something about the error, i.e., throw exception, return
NaN, etc. */
}
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);
+ gfc_mpfr_to_mpz (result->value.integer, src->value.real, &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.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);
+ 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
