/* Compiler arithmetic
- Copyright (C) 2000, 2001, 2002, 2003, 2004 Free Software Foundation,
- Inc.
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006
+ Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING. If not, write to the Free
-Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA. */
+Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
+02110-1301, USA. */
/* Since target arithmetic must be done on the host, there has to
be some way of evaluating arithmetic expressions as the host
- would evaluate them. We use the GNU MP library to do arithmetic,
- and this file provides the interface. */
+ would evaluate them. We use the GNU MP library and the MPFR
+ library to do arithmetic, and this file provides the interface. */
#include "config.h"
#include "system.h"
}
mpfr_clear (t);
-
}
switch (code)
{
case ARITH_OK:
- p = "Arithmetic OK";
+ p = _("Arithmetic OK at %L");
break;
case ARITH_OVERFLOW:
- p = "Arithmetic overflow";
+ p = _("Arithmetic overflow at %L");
break;
case ARITH_UNDERFLOW:
- p = "Arithmetic underflow";
+ p = _("Arithmetic underflow at %L");
break;
case ARITH_NAN:
- p = "Arithmetic NaN";
+ p = _("Arithmetic NaN at %L");
break;
case ARITH_DIV0:
- p = "Division by zero";
- break;
- case ARITH_0TO0:
- p = "Indeterminate form 0 ** 0";
+ p = _("Division by zero at %L");
break;
case ARITH_INCOMMENSURATE:
- p = "Array operands are incommensurate";
+ p = _("Array operands are incommensurate at %L");
break;
case ARITH_ASYMMETRIC:
- p = "Integer outside symmetric range implied by Standard Fortran";
+ p =
+ _("Integer outside symmetric range implied by Standard Fortran at %L");
break;
default:
gfc_internal_error ("gfc_arith_error(): Bad error code");
mpfr_init (a);
mpz_init (r);
- /* Convert the minimum/maximum values for each kind into their
+ /* Convert the minimum and maximum values for each kind into their
GNU MP representation. */
for (int_info = gfc_integer_kinds; int_info->kind != 0; int_info++)
{
- /* Huge */
+ /* Huge */
mpz_set_ui (r, int_info->radix);
mpz_pow_ui (r, r, int_info->digits);
/* These are the numbers that are actually representable by the
target. For bases other than two, this needs to be changed. */
if (int_info->radix != 2)
- gfc_internal_error ("Fix min_int, max_int calculation");
+ gfc_internal_error ("Fix min_int calculation");
/* See PRs 13490 and 17912, related to integer ranges.
The pedantic_min_int exists for range checking when a program
mpz_init (int_info->min_int);
mpz_sub_ui (int_info->min_int, int_info->pedantic_min_int, 1);
- mpz_init (int_info->max_int);
- mpz_add (int_info->max_int, int_info->huge, int_info->huge);
- mpz_add_ui (int_info->max_int, int_info->max_int, 1);
-
- /* Range */
+ /* Range */
mpfr_set_z (a, int_info->huge, GFC_RND_MODE);
mpfr_log10 (a, a, GFC_RND_MODE);
mpfr_trunc (a, a);
mpfr_init (c);
/* huge(x) = (1 - b**(-p)) * b**(emax-1) * b */
- /* a = 1 - b**(-p) */
+ /* a = 1 - b**(-p) */
mpfr_set_ui (a, 1, GFC_RND_MODE);
mpfr_set_ui (b, real_info->radix, GFC_RND_MODE);
mpfr_pow_si (b, b, -real_info->digits, GFC_RND_MODE);
mpfr_sub (a, a, b, GFC_RND_MODE);
- /* c = b**(emax-1) */
+ /* c = b**(emax-1) */
mpfr_set_ui (b, real_info->radix, GFC_RND_MODE);
mpfr_pow_ui (c, b, real_info->max_exponent - 1, GFC_RND_MODE);
- /* a = a * c = (1 - b**(-p)) * b**(emax-1) */
+ /* a = a * c = (1 - b**(-p)) * b**(emax-1) */
mpfr_mul (a, a, c, GFC_RND_MODE);
- /* a = (1 - b**(-p)) * b**(emax-1) * b */
+ /* a = (1 - b**(-p)) * b**(emax-1) * b */
mpfr_mul_ui (a, a, real_info->radix, GFC_RND_MODE);
mpfr_init (real_info->huge);
mpfr_set (real_info->huge, a, GFC_RND_MODE);
- /* tiny(x) = b**(emin-1) */
+ /* tiny(x) = b**(emin-1) */
mpfr_set_ui (b, real_info->radix, GFC_RND_MODE);
mpfr_pow_si (b, b, real_info->min_exponent - 1, GFC_RND_MODE);
mpfr_init (real_info->tiny);
mpfr_set (real_info->tiny, b, GFC_RND_MODE);
- /* epsilon(x) = b**(1-p) */
+ /* subnormal (x) = b**(emin - digit) */
+ mpfr_set_ui (b, real_info->radix, GFC_RND_MODE);
+ mpfr_pow_si (b, b, real_info->min_exponent - real_info->digits,
+ GFC_RND_MODE);
+
+ mpfr_init (real_info->subnormal);
+ mpfr_set (real_info->subnormal, b, GFC_RND_MODE);
+
+ /* epsilon(x) = b**(1-p) */
mpfr_set_ui (b, real_info->radix, GFC_RND_MODE);
mpfr_pow_si (b, b, 1 - real_info->digits, GFC_RND_MODE);
mpfr_init (real_info->epsilon);
mpfr_set (real_info->epsilon, b, GFC_RND_MODE);
- /* range(x) = int(min(log10(huge(x)), -log10(tiny)) */
+ /* range(x) = int(min(log10(huge(x)), -log10(tiny)) */
mpfr_log10 (a, real_info->huge, GFC_RND_MODE);
mpfr_log10 (b, real_info->tiny, GFC_RND_MODE);
mpfr_neg (b, b, GFC_RND_MODE);
+ /* a = min(a, b) */
if (mpfr_cmp (a, b) > 0)
- mpfr_set (a, b, GFC_RND_MODE); /* a = min(a, b) */
+ mpfr_set (a, b, GFC_RND_MODE);
mpfr_trunc (a, a);
gfc_mpfr_to_mpz (r, a);
real_info->range = mpz_get_si (r);
- /* precision(x) = int((p - 1) * log10(b)) + k */
+ /* precision(x) = int((p - 1) * log10(b)) + k */
mpfr_set_ui (a, real_info->radix, GFC_RND_MODE);
mpfr_log10 (a, a, GFC_RND_MODE);
gfc_mpfr_to_mpz (r, a);
real_info->precision = mpz_get_si (r);
- /* If the radix is an integral power of 10, add one to the
- precision. */
+ /* If the radix is an integral power of 10, add one to the precision. */
for (i = 10; i <= real_info->radix; i *= 10)
if (i == real_info->radix)
real_info->precision++;
for (ip = gfc_integer_kinds; ip->kind; ip++)
{
mpz_clear (ip->min_int);
- mpz_clear (ip->max_int);
+ mpz_clear (ip->pedantic_min_int);
mpz_clear (ip->huge);
}
mpfr_clear (rp->epsilon);
mpfr_clear (rp->huge);
mpfr_clear (rp->tiny);
+ mpfr_clear (rp->subnormal);
}
}
the range of the kind. Returns ARITH_OK, ARITH_ASYMMETRIC or
ARITH_OVERFLOW. */
-static arith
+arith
gfc_check_integer_range (mpz_t p, int kind)
{
arith result;
}
if (mpz_cmp (p, gfc_integer_kinds[i].min_int) < 0
- || mpz_cmp (p, gfc_integer_kinds[i].max_int) > 0)
+ || mpz_cmp (p, gfc_integer_kinds[i].huge) > 0)
result = ARITH_OVERFLOW;
return result;
mpfr_init (q);
mpfr_abs (q, p, GFC_RND_MODE);
- retval = ARITH_OK;
- if (mpfr_sgn (q) == 0)
- goto done;
-
- if (mpfr_cmp (q, gfc_real_kinds[i].huge) > 0)
+ if (mpfr_inf_p (p))
{
- retval = ARITH_OVERFLOW;
- goto done;
+ if (gfc_option.flag_range_check == 0)
+ retval = ARITH_OK;
+ else
+ retval = ARITH_OVERFLOW;
+ }
+ else if (mpfr_nan_p (p))
+ {
+ if (gfc_option.flag_range_check == 0)
+ retval = ARITH_OK;
+ else
+ retval = ARITH_NAN;
+ }
+ else if (mpfr_sgn (q) == 0)
+ retval = ARITH_OK;
+ else if (mpfr_cmp (q, gfc_real_kinds[i].huge) > 0)
+ {
+ if (gfc_option.flag_range_check == 0)
+ retval = ARITH_OK;
+ else
+ retval = ARITH_OVERFLOW;
+ }
+ else if (mpfr_cmp (q, gfc_real_kinds[i].subnormal) < 0)
+ {
+ if (gfc_option.flag_range_check == 0)
+ retval = ARITH_OK;
+ else
+ retval = ARITH_UNDERFLOW;
}
+ else if (mpfr_cmp (q, gfc_real_kinds[i].tiny) < 0)
+ {
+ /* MPFR operates on a number with a given precision and enormous
+ exponential range. To represent subnormal numbers, the exponent is
+ allowed to become smaller than emin, but always retains the full
+ precision. This code resets unused bits to 0 to alleviate
+ rounding problems. Note, a future version of MPFR will have a
+ mpfr_subnormalize() function, which handles this truncation in a
+ more efficient and robust way. */
+
+ int j, k;
+ char *bin, *s;
+ mp_exp_t e;
+
+ bin = mpfr_get_str (NULL, &e, gfc_real_kinds[i].radix, 0, q, GMP_RNDN);
+ k = gfc_real_kinds[i].digits - (gfc_real_kinds[i].min_exponent - e);
+ for (j = k; j < gfc_real_kinds[i].digits; j++)
+ bin[j] = '0';
+ /* Need space for '0.', bin, 'E', and e */
+ s = (char *) gfc_getmem (strlen(bin) + 10);
+ sprintf (s, "0.%sE%d", bin, (int) e);
+ mpfr_set_str (q, s, gfc_real_kinds[i].radix, GMP_RNDN);
+
+ if (mpfr_sgn (p) < 0)
+ mpfr_neg (p, q, GMP_RNDN);
+ else
+ mpfr_set (p, q, GMP_RNDN);
+
+ gfc_free (s);
+ gfc_free (bin);
- if (mpfr_cmp (q, gfc_real_kinds[i].tiny) < 0)
- retval = ARITH_UNDERFLOW;
+ retval = ARITH_OK;
+ }
+ else
+ retval = ARITH_OK;
-done:
mpfr_clear (q);
return retval;
}
-/* Function to return a constant expression node of a given type and
- kind. */
+/* Function to return a constant expression node of a given type and kind. */
gfc_expr *
gfc_constant_result (bt type, int kind, locus * where)
case BT_REAL:
rc = gfc_check_real_range (e->value.real, e->ts.kind);
if (rc == ARITH_UNDERFLOW)
- mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
+ mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
+ if (rc == ARITH_OVERFLOW)
+ mpfr_set_inf (e->value.real, mpfr_sgn (e->value.real));
+ if (rc == ARITH_NAN)
+ mpfr_set_nan (e->value.real);
break;
case BT_COMPLEX:
rc = gfc_check_real_range (e->value.complex.r, e->ts.kind);
if (rc == ARITH_UNDERFLOW)
- mpfr_set_ui (e->value.complex.r, 0, GFC_RND_MODE);
- if (rc == ARITH_OK || rc == ARITH_UNDERFLOW)
- {
- rc = gfc_check_real_range (e->value.complex.i, e->ts.kind);
- if (rc == ARITH_UNDERFLOW)
- mpfr_set_ui (e->value.complex.i, 0, GFC_RND_MODE);
- }
+ mpfr_set_ui (e->value.complex.r, 0, GFC_RND_MODE);
+ if (rc == ARITH_OVERFLOW)
+ mpfr_set_inf (e->value.complex.r, mpfr_sgn (e->value.complex.r));
+ if (rc == ARITH_NAN)
+ mpfr_set_nan (e->value.complex.r);
+ rc = gfc_check_real_range (e->value.complex.i, e->ts.kind);
+ if (rc == ARITH_UNDERFLOW)
+ mpfr_set_ui (e->value.complex.i, 0, GFC_RND_MODE);
+ if (rc == ARITH_OVERFLOW)
+ mpfr_set_inf (e->value.complex.i, mpfr_sgn (e->value.complex.i));
+ if (rc == ARITH_NAN)
+ mpfr_set_nan (e->value.complex.i);
break;
default:
}
+/* Several of the following routines use the same set of statements to
+ check the validity of the result. Encapsulate the checking here. */
+
+static arith
+check_result (arith rc, gfc_expr * x, gfc_expr * r, gfc_expr ** rp)
+{
+ arith val = rc;
+
+ if (val == ARITH_UNDERFLOW)
+ {
+ if (gfc_option.warn_underflow)
+ gfc_warning (gfc_arith_error (val), &x->where);
+ val = ARITH_OK;
+ }
+
+ if (val == ARITH_ASYMMETRIC)
+ {
+ gfc_warning (gfc_arith_error (val), &x->where);
+ val = ARITH_OK;
+ }
+
+ if (val != ARITH_OK)
+ gfc_free_expr (r);
+ else
+ *rp = r;
+
+ return val;
+}
+
+
/* It may seem silly to have a subroutine that actually computes the
unary plus of a constant, but it prevents us from making exceptions
in the code elsewhere. */
rc = gfc_range_check (result);
- if (rc == ARITH_UNDERFLOW)
- {
- if (gfc_option.warn_underflow)
- gfc_warning ("%s at %L", gfc_arith_error (rc), &op1->where);
- rc = ARITH_OK;
- *resultp = result;
- }
- else if (rc == ARITH_ASYMMETRIC)
- {
- gfc_warning ("%s at %L", gfc_arith_error (rc), &op1->where);
- rc = ARITH_OK;
- *resultp = result;
- }
- else if (rc != ARITH_OK)
- gfc_free_expr (result);
- else
- *resultp = result;
-
- return rc;
+ return check_result (rc, op1, result, resultp);
}
rc = gfc_range_check (result);
- if (rc == ARITH_UNDERFLOW)
- {
- if (gfc_option.warn_underflow)
- gfc_warning ("%s at %L", gfc_arith_error (rc), &op1->where);
- rc = ARITH_OK;
- *resultp = result;
- }
- else if (rc == ARITH_ASYMMETRIC)
- {
- gfc_warning ("%s at %L", gfc_arith_error (rc), &op1->where);
- rc = ARITH_OK;
- *resultp = result;
- }
- else if (rc != ARITH_OK)
- gfc_free_expr (result);
- else
- *resultp = result;
-
- return rc;
+ return check_result (rc, op1, result, resultp);
}
rc = gfc_range_check (result);
- if (rc == ARITH_UNDERFLOW)
- {
- if (gfc_option.warn_underflow)
- gfc_warning ("%s at %L", gfc_arith_error (rc), &op1->where);
- rc = ARITH_OK;
- *resultp = result;
- }
- else if (rc == ARITH_ASYMMETRIC)
- {
- gfc_warning ("%s at %L", gfc_arith_error (rc), &op1->where);
- rc = ARITH_OK;
- *resultp = result;
- }
- else if (rc != ARITH_OK)
- gfc_free_expr (result);
- else
- *resultp = result;
-
- return rc;
+ return check_result (rc, op1, result, resultp);
}
break;
case BT_COMPLEX:
-
- /* FIXME: possible numericals problem. */
-
gfc_set_model (op1->value.complex.r);
mpfr_init (x);
mpfr_init (y);
mpfr_clear (x);
mpfr_clear (y);
-
break;
default:
rc = gfc_range_check (result);
- if (rc == ARITH_UNDERFLOW)
- {
- if (gfc_option.warn_underflow)
- gfc_warning ("%s at %L", gfc_arith_error (rc), &op1->where);
- rc = ARITH_OK;
- *resultp = result;
- }
- else if (rc == ARITH_ASYMMETRIC)
- {
- gfc_warning ("%s at %L", gfc_arith_error (rc), &op1->where);
- rc = ARITH_OK;
- *resultp = result;
- }
- else if (rc != ARITH_OK)
- gfc_free_expr (result);
- else
- *resultp = result;
-
- return rc;
+ return check_result (rc, op1, result, resultp);
}
break;
case BT_REAL:
- /* FIXME: MPFR correctly generates NaN. This may not be needed. */
- if (mpfr_sgn (op2->value.real) == 0)
+ if (mpfr_sgn (op2->value.real) == 0
+ && gfc_option.flag_range_check == 1)
{
rc = ARITH_DIV0;
break;
break;
case BT_COMPLEX:
- /* FIXME: MPFR correctly generates NaN. This may not be needed. */
if (mpfr_sgn (op2->value.complex.r) == 0
- && mpfr_sgn (op2->value.complex.i) == 0)
+ && mpfr_sgn (op2->value.complex.i) == 0
+ && gfc_option.flag_range_check == 1)
{
rc = ARITH_DIV0;
break;
mpfr_init (y);
mpfr_init (div);
- /* FIXME: possible numerical problems. */
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_clear (x);
mpfr_clear (y);
mpfr_clear (div);
-
break;
default:
if (rc == ARITH_OK)
rc = gfc_range_check (result);
- if (rc == ARITH_UNDERFLOW)
- {
- if (gfc_option.warn_underflow)
- gfc_warning ("%s at %L", gfc_arith_error (rc), &op1->where);
- rc = ARITH_OK;
- *resultp = result;
- }
- else if (rc == ARITH_ASYMMETRIC)
- {
- gfc_warning ("%s at %L", gfc_arith_error (rc), &op1->where);
- rc = ARITH_OK;
- *resultp = result;
- }
- else if (rc != ARITH_OK)
- gfc_free_expr (result);
- else
- *resultp = result;
-
- return rc;
+ return check_result (rc, op1, result, resultp);
}
mpfr_init (re);
mpfr_init (im);
- /* FIXME: another possible numerical problem. */
mpfr_mul (mod, op->value.complex.r, op->value.complex.r, GFC_RND_MODE);
mpfr_mul (a, op->value.complex.i, op->value.complex.i, GFC_RND_MODE);
mpfr_add (mod, mod, a, GFC_RND_MODE);
result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
if (power == 0)
- { /* Handle something to the zeroth power */
+ {
+ /* 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:
- if (mpz_sgn (op1->value.integer) == 0)
- rc = ARITH_0TO0;
- else
- mpz_set_ui (result->value.integer, 1);
+ mpz_set_ui (result->value.integer, 1);
break;
case BT_REAL:
- if (mpfr_sgn (op1->value.real) == 0)
- rc = ARITH_0TO0;
- else
- mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
+ mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
break;
case BT_COMPLEX:
- if (mpfr_sgn (op1->value.complex.r) == 0
- && mpfr_sgn (op1->value.complex.i) == 0)
- rc = ARITH_0TO0;
- else
- {
- mpfr_set_ui (result->value.complex.r, 1, GFC_RND_MODE);
- mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
- }
-
+ mpfr_set_ui (result->value.complex.r, 1, GFC_RND_MODE);
+ mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
break;
default:
result->value.integer);
mpz_clear (unity_z);
}
-
break;
case BT_REAL:
if (rc == ARITH_OK)
rc = gfc_range_check (result);
- if (rc == ARITH_UNDERFLOW)
- {
- if (gfc_option.warn_underflow)
- gfc_warning ("%s at %L", gfc_arith_error (rc), &op1->where);
- rc = ARITH_OK;
- *resultp = result;
- }
- else if (rc == ARITH_ASYMMETRIC)
- {
- gfc_warning ("%s at %L", gfc_arith_error (rc), &op1->where);
- rc = ARITH_OK;
- *resultp = result;
- }
- else if (rc != ARITH_OK)
- gfc_free_expr (result);
- else
- *resultp = result;
-
- return rc;
+ return check_result (rc, op1, result, resultp);
}
/* Compare a pair of complex numbers. Naturally, this is only for
- equality/nonequality. */
+ equality and nonequality. */
static int
compare_complex (gfc_expr * op1, gfc_expr * op2)
}
-/* Given two constant strings and the inverse collating sequence,
- compare the strings. We return -1 for a<b, 0 for a==b and 1 for
- a>b. If the xcoll_table is NULL, we use the processor's default
- collating sequence. */
+/* Given two constant strings and the inverse collating sequence, compare the
+ strings. We return -1 for a < b, 0 for a == b and 1 for a > b. If the
+ xcoll_table is NULL, we use the processor's default collating sequence. */
int
-gfc_compare_string (gfc_expr * a, gfc_expr * b, const int *xcoll_table)
+gfc_compare_string (gfc_expr * a, gfc_expr * b, const int * xcoll_table)
{
int len, alen, blen, i, ac, bc;
for (i = 0; i < len; i++)
{
- ac = (i < alen) ? a->value.character.string[i] : ' ';
- bc = (i < blen) ? b->value.character.string[i] : ' ';
+ /* We cast to unsigned char because default char, if it is signed,
+ would lead to ac < 0 for string[i] > 127. */
+ ac = (unsigned char) ((i < alen) ? a->value.character.string[i] : ' ');
+ bc = (unsigned char) ((i < blen) ? b->value.character.string[i] : ' ');
if (xcoll_table != NULL)
{
switch (operator)
{
- case INTRINSIC_NOT: /* Logical unary */
+ /* Logical unary */
+ case INTRINSIC_NOT:
if (op1->ts.type != BT_LOGICAL)
goto runtime;
unary = 1;
break;
- /* Logical binary operators */
+ /* Logical binary operators */
case INTRINSIC_OR:
case INTRINSIC_AND:
case INTRINSIC_NEQV:
unary = 0;
break;
+ /* Numeric unary */
case INTRINSIC_UPLUS:
- case INTRINSIC_UMINUS: /* Numeric unary */
+ case INTRINSIC_UMINUS:
if (!gfc_numeric_ts (&op1->ts))
goto runtime;
unary = 1;
break;
+ case INTRINSIC_PARENTHESES:
+ temp.ts = op1->ts;
+
+ unary = 1;
+ break;
+
+ /* Additional restrictions for ordering relations. */
case INTRINSIC_GE:
- case INTRINSIC_LT: /* Additional restrictions */
- case INTRINSIC_LE: /* for ordering relations. */
+ case INTRINSIC_LT:
+ case INTRINSIC_LE:
case INTRINSIC_GT:
if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
{
goto runtime;
}
- /* else fall through */
-
+ /* Fall through */
case INTRINSIC_EQ:
case INTRINSIC_NE:
if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
break;
}
- /* else fall through */
-
+ /* Fall through */
+ /* Numeric binary */
case INTRINSIC_PLUS:
case INTRINSIC_MINUS:
case INTRINSIC_TIMES:
case INTRINSIC_DIVIDE:
- case INTRINSIC_POWER: /* Numeric binary */
+ case INTRINSIC_POWER:
if (!gfc_numeric_ts (&op1->ts) || !gfc_numeric_ts (&op2->ts))
goto runtime;
- /* Insert any necessary type conversions to make the operands compatible. */
+ /* Insert any necessary type conversions to make the operands
+ compatible. */
temp.expr_type = EXPR_OP;
gfc_clear_ts (&temp.ts);
- temp.operator = operator;
+ temp.value.op.operator = operator;
- temp.op1 = op1;
- temp.op2 = op2;
+ temp.value.op.op1 = op1;
+ temp.value.op.op2 = op2;
gfc_type_convert_binary (&temp);
unary = 0;
break;
- case INTRINSIC_CONCAT: /* Character binary */
+ /* Character binary */
+ case INTRINSIC_CONCAT:
if (op1->ts.type != BT_CHARACTER || op2->ts.type != BT_CHARACTER)
goto runtime;
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)))
+ if (op1->from_H
+ || (op1->expr_type != EXPR_CONSTANT
+ && (op1->expr_type != EXPR_ARRAY
+ || !gfc_is_constant_expr (op1)
+ || !gfc_expanded_ac (op1))))
goto runtime;
if (op2 != NULL
- && op2->expr_type != EXPR_CONSTANT
- && (op2->expr_type != EXPR_ARRAY
- || !gfc_is_constant_expr (op2)
- || !gfc_expanded_ac (op2)))
+ && (op2->from_H
+ || (op2->expr_type != EXPR_CONSTANT
+ && (op2->expr_type != EXPR_ARRAY
+ || !gfc_is_constant_expr (op2)
+ || !gfc_expanded_ac (op2)))))
goto runtime;
if (unary)
rc = reduce_binary (eval.f3, op1, op2, &result);
if (rc != ARITH_OK)
- { /* Something went wrong */
- gfc_error ("%s at %L", gfc_arith_error (rc), &op1->where);
+ { /* Something went wrong. */
+ gfc_error (gfc_arith_error (rc), &op1->where);
return NULL;
}
return result;
runtime:
- /* Create a run-time expression */
+ /* Create a run-time expression. */
result = gfc_get_expr ();
result->ts = temp.ts;
result->expr_type = EXPR_OP;
- result->operator = operator;
+ result->value.op.operator = operator;
- result->op1 = op1;
- result->op2 = op2;
+ result->value.op.op1 = op1;
+ result->value.op.op2 = op2;
result->where = op1->where;
/* Modify type of expression for zero size array. */
+
static gfc_expr *
-eval_type_intrinsic0 (gfc_intrinsic_op operator, gfc_expr *op)
+eval_type_intrinsic0 (gfc_intrinsic_op operator, gfc_expr * op)
{
if (op == NULL)
gfc_internal_error ("eval_type_intrinsic0(): op NULL");
}
-
gfc_expr *
gfc_uplus (gfc_expr * op)
{
return eval_intrinsic_f2 (INTRINSIC_UPLUS, gfc_arith_uplus, op, NULL);
}
+
gfc_expr *
gfc_uminus (gfc_expr * op)
{
return eval_intrinsic_f2 (INTRINSIC_UMINUS, gfc_arith_uminus, op, NULL);
}
+
gfc_expr *
gfc_add (gfc_expr * op1, gfc_expr * op2)
{
return eval_intrinsic_f3 (INTRINSIC_PLUS, gfc_arith_plus, op1, op2);
}
+
gfc_expr *
gfc_subtract (gfc_expr * op1, gfc_expr * op2)
{
return eval_intrinsic_f3 (INTRINSIC_MINUS, gfc_arith_minus, op1, op2);
}
+
gfc_expr *
gfc_multiply (gfc_expr * op1, gfc_expr * op2)
{
return eval_intrinsic_f3 (INTRINSIC_TIMES, gfc_arith_times, op1, op2);
}
+
gfc_expr *
gfc_divide (gfc_expr * op1, gfc_expr * op2)
{
return eval_intrinsic_f3 (INTRINSIC_DIVIDE, gfc_arith_divide, op1, op2);
}
+
gfc_expr *
gfc_power (gfc_expr * op1, gfc_expr * op2)
{
return eval_intrinsic_f3 (INTRINSIC_POWER, gfc_arith_power, op1, op2);
}
+
gfc_expr *
gfc_concat (gfc_expr * op1, gfc_expr * op2)
{
return eval_intrinsic_f3 (INTRINSIC_CONCAT, gfc_arith_concat, op1, op2);
}
+
gfc_expr *
gfc_and (gfc_expr * op1, gfc_expr * op2)
{
return eval_intrinsic_f3 (INTRINSIC_AND, gfc_arith_and, op1, op2);
}
+
gfc_expr *
gfc_or (gfc_expr * op1, gfc_expr * op2)
{
return eval_intrinsic_f3 (INTRINSIC_OR, gfc_arith_or, op1, op2);
}
+
gfc_expr *
gfc_not (gfc_expr * op1)
{
return eval_intrinsic_f2 (INTRINSIC_NOT, gfc_arith_not, op1, NULL);
}
+
gfc_expr *
gfc_eqv (gfc_expr * op1, gfc_expr * op2)
{
return eval_intrinsic_f3 (INTRINSIC_EQV, gfc_arith_eqv, op1, op2);
}
+
gfc_expr *
gfc_neqv (gfc_expr * op1, gfc_expr * op2)
{
return eval_intrinsic_f3 (INTRINSIC_NEQV, gfc_arith_neqv, op1, op2);
}
+
gfc_expr *
gfc_eq (gfc_expr * op1, gfc_expr * op2)
{
return eval_intrinsic_f3 (INTRINSIC_EQ, gfc_arith_eq, op1, op2);
}
+
gfc_expr *
gfc_ne (gfc_expr * op1, gfc_expr * op2)
{
return eval_intrinsic_f3 (INTRINSIC_NE, gfc_arith_ne, op1, op2);
}
+
gfc_expr *
gfc_gt (gfc_expr * op1, gfc_expr * op2)
{
return eval_intrinsic_f3 (INTRINSIC_GT, gfc_arith_gt, op1, op2);
}
+
gfc_expr *
gfc_ge (gfc_expr * op1, gfc_expr * op2)
{
return eval_intrinsic_f3 (INTRINSIC_GE, gfc_arith_ge, op1, op2);
}
+
gfc_expr *
gfc_lt (gfc_expr * op1, gfc_expr * op2)
{
return eval_intrinsic_f3 (INTRINSIC_LT, gfc_arith_lt, op1, op2);
}
+
gfc_expr *
gfc_le (gfc_expr * op1, gfc_expr * op2)
{
/* Convert an integer string to an expression node. */
gfc_expr *
-gfc_convert_integer (const char *buffer, int kind, int radix, locus * where)
+gfc_convert_integer (const char * buffer, int kind, int radix, locus * where)
{
gfc_expr *e;
const char *t;
e = gfc_constant_result (BT_INTEGER, kind, where);
- /* a leading plus is allowed, but not by mpz_set_str */
+ /* A leading plus is allowed, but not by mpz_set_str. */
if (buffer[0] == '+')
t = buffer + 1;
else
/* Convert a real string to an expression node. */
gfc_expr *
-gfc_convert_real (const char *buffer, int kind, locus * where)
+gfc_convert_real (const char * buffer, int kind, locus * where)
{
gfc_expr *e;
- const char *t;
e = gfc_constant_result (BT_REAL, kind, where);
- /* A leading plus is allowed in Fortran, but not by mpfr_set_str */
- if (buffer[0] == '+')
- t = buffer + 1;
- else
- t = buffer;
- mpfr_set_str (e->value.real, t, 10, GFC_RND_MODE);
+ mpfr_set_str (e->value.real, buffer, 10, GFC_RND_MODE);
return e;
}
static void
arith_error (arith rc, gfc_typespec * from, gfc_typespec * to, locus * where)
{
- gfc_error ("%s converting %s to %s at %L", gfc_arith_error (rc),
- gfc_typename (from), gfc_typename (to), where);
+ switch (rc)
+ {
+ case ARITH_OK:
+ gfc_error ("Arithmetic OK converting %s to %s at %L",
+ gfc_typename (from), gfc_typename (to), where);
+ break;
+ case ARITH_OVERFLOW:
+ gfc_error ("Arithmetic overflow converting %s to %s at %L",
+ gfc_typename (from), gfc_typename (to), where);
+ break;
+ case ARITH_UNDERFLOW:
+ gfc_error ("Arithmetic underflow converting %s to %s at %L",
+ gfc_typename (from), gfc_typename (to), where);
+ break;
+ case ARITH_NAN:
+ gfc_error ("Arithmetic NaN converting %s to %s at %L",
+ gfc_typename (from), gfc_typename (to), where);
+ break;
+ case ARITH_DIV0:
+ gfc_error ("Division by zero converting %s to %s at %L",
+ gfc_typename (from), gfc_typename (to), where);
+ break;
+ case ARITH_INCOMMENSURATE:
+ gfc_error ("Array operands are incommensurate converting %s to %s at %L",
+ gfc_typename (from), gfc_typename (to), where);
+ break;
+ case ARITH_ASYMMETRIC:
+ gfc_error ("Integer outside symmetric range implied by Standard Fortran"
+ " converting %s to %s at %L",
+ gfc_typename (from), gfc_typename (to), where);
+ break;
+ default:
+ gfc_internal_error ("gfc_arith_error(): Bad error code");
+ }
/* TODO: Do something about the error, ie, throw exception, return
NaN, etc. */
}
+
/* Convert integers to integers. */
gfc_expr *
{
if (rc == ARITH_ASYMMETRIC)
{
- gfc_warning ("%s at %L", gfc_arith_error (rc), &src->where);
+ gfc_warning (gfc_arith_error (rc), &src->where);
}
else
{
if (rc == ARITH_UNDERFLOW)
{
if (gfc_option.warn_underflow)
- gfc_warning ("%s at %L", gfc_arith_error (rc), &src->where);
+ gfc_warning (gfc_arith_error (rc), &src->where);
mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
}
else if (rc != ARITH_OK)
if (rc == ARITH_UNDERFLOW)
{
if (gfc_option.warn_underflow)
- gfc_warning ("%s at %L", gfc_arith_error (rc), &src->where);
+ gfc_warning (gfc_arith_error (rc), &src->where);
mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE);
}
else if (rc != ARITH_OK)
if (rc == ARITH_UNDERFLOW)
{
if (gfc_option.warn_underflow)
- gfc_warning ("%s at %L", gfc_arith_error (rc), &src->where);
+ gfc_warning (gfc_arith_error (rc), &src->where);
mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
}
if (rc != ARITH_OK)
if (rc == ARITH_UNDERFLOW)
{
if (gfc_option.warn_underflow)
- gfc_warning ("%s at %L", gfc_arith_error (rc), &src->where);
+ gfc_warning (gfc_arith_error (rc), &src->where);
mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE);
}
else if (rc != ARITH_OK)
if (rc == ARITH_UNDERFLOW)
{
if (gfc_option.warn_underflow)
- gfc_warning ("%s at %L", gfc_arith_error (rc), &src->where);
+ gfc_warning (gfc_arith_error (rc), &src->where);
mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
}
else if (rc != ARITH_OK)
return result;
}
+
+
+/* Convert logical to integer. */
+
+gfc_expr *
+gfc_log2int (gfc_expr *src, int kind)
+{
+ gfc_expr *result;
+
+ result = gfc_constant_result (BT_INTEGER, kind, &src->where);
+ mpz_set_si (result->value.integer, src->value.logical);
+
+ return result;
+}
+
+
+/* Convert integer to logical. */
+
+gfc_expr *
+gfc_int2log (gfc_expr *src, int kind)
+{
+ gfc_expr *result;
+
+ result = gfc_constant_result (BT_LOGICAL, kind, &src->where);
+ result->value.logical = (mpz_cmp_si (src->value.integer, 0) != 0);
+
+ return result;
+}
+
+
+/* Convert Hollerith to integer. The constant will be padded or truncated. */
+
+gfc_expr *
+gfc_hollerith2int (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_INTEGER;
+ result->ts.kind = kind;
+ result->where = src->where;
+ result->from_H = 1;
+
+ if (len > kind)
+ {
+ gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
+ &src->where, gfc_typename(&result->ts));
+ }
+ result->value.character.string = gfc_getmem (kind + 1);
+ memcpy (result->value.character.string, src->value.character.string,
+ MIN (kind, len));
+
+ if (len < kind)
+ memset (&result->value.character.string[len], ' ', kind - len);
+
+ result->value.character.string[kind] = '\0'; /* For debugger */
+ result->value.character.length = kind;
+
+ return result;
+}
+
+
+/* Convert Hollerith to real. The constant will be padded or truncated. */
+
+gfc_expr *
+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->from_H = 1;
+
+ if (len > kind)
+ {
+ gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
+ &src->where, gfc_typename(&result->ts));
+ }
+ result->value.character.string = gfc_getmem (kind + 1);
+ memcpy (result->value.character.string, src->value.character.string,
+ MIN (kind, len));
+
+ if (len < kind)
+ memset (&result->value.character.string[len], ' ', kind - len);
+
+ result->value.character.string[kind] = '\0'; /* For debugger. */
+ result->value.character.length = kind;
+
+ return result;
+}
+
+
+/* Convert Hollerith to complex. The constant will be padded or truncated. */
+
+gfc_expr *
+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->from_H = 1;
+
+ kind = kind * 2;
+
+ if (len > kind)
+ {
+ gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
+ &src->where, gfc_typename(&result->ts));
+ }
+ result->value.character.string = gfc_getmem (kind + 1);
+ memcpy (result->value.character.string, src->value.character.string,
+ MIN (kind, len));
+
+ if (len < kind)
+ memset (&result->value.character.string[len], ' ', kind - len);
+
+ result->value.character.string[kind] = '\0'; /* For debugger */
+ result->value.character.length = kind;
+
+ return result;
+}
+
+
+/* Convert Hollerith to character. */
+
+gfc_expr *
+gfc_hollerith2character (gfc_expr * src, int kind)
+{
+ gfc_expr *result;
+
+ result = gfc_copy_expr (src);
+ result->ts.type = BT_CHARACTER;
+ result->ts.kind = kind;
+ result->from_H = 1;
+
+ return result;
+}
+
+
+/* Convert Hollerith to logical. The constant will be padded or truncated. */
+
+gfc_expr *
+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->from_H = 1;
+
+ if (len > kind)
+ {
+ gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
+ &src->where, gfc_typename(&result->ts));
+ }
+ result->value.character.string = gfc_getmem (kind + 1);
+ memcpy (result->value.character.string, src->value.character.string,
+ MIN (kind, len));
+
+ if (len < kind)
+ memset (&result->value.character.string[len], ' ', kind - len);
+
+ result->value.character.string[kind] = '\0'; /* For debugger */
+ result->value.character.length = kind;
+
+ 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;
+}
projects / gcc.git / blobdiff