X-Git-Url: https://git.libre-soc.org/?a=blobdiff_plain;f=gcc%2Ffortran%2Farith.c;h=766169fa6e13d5bd0e23a5675feb07744d1f6e36;hb=7bee49dcaa2b662f6f1bad736d4d5d0cf142a123;hp=280fc9a84ac9999da207ea9f1f13d76bf5bb4a07;hpb=27dfc9c46db75a73ed617d47608c55c1f9f47c17;p=gcc.git diff --git a/gcc/fortran/arith.c b/gcc/fortran/arith.c index 280fc9a84ac..766169fa6e1 100644 --- a/gcc/fortran/arith.c +++ b/gcc/fortran/arith.c @@ -1,6 +1,6 @@ /* 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. @@ -17,13 +17,13 @@ for more details. 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" @@ -123,7 +123,6 @@ arctangent2 (mpfr_t y, mpfr_t x, mpfr_t result) } mpfr_clear (t); - } @@ -138,28 +137,26 @@ gfc_arith_error (arith code) 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"); @@ -184,11 +181,11 @@ gfc_arith_init_1 (void) 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); @@ -198,7 +195,7 @@ gfc_arith_init_1 (void) /* 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 @@ -213,11 +210,7 @@ gfc_arith_init_1 (void) 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); @@ -236,52 +229,61 @@ gfc_arith_init_1 (void) 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); @@ -290,8 +292,7 @@ gfc_arith_init_1 (void) 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++; @@ -316,7 +317,7 @@ gfc_arith_done_1 (void) 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); } @@ -325,6 +326,7 @@ gfc_arith_done_1 (void) mpfr_clear (rp->epsilon); mpfr_clear (rp->huge); mpfr_clear (rp->tiny); + mpfr_clear (rp->subnormal); } } @@ -333,7 +335,7 @@ gfc_arith_done_1 (void) 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; @@ -349,7 +351,7 @@ gfc_check_integer_range (mpz_t p, int kind) } 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; @@ -373,28 +375,79 @@ gfc_check_real_range (mpfr_t p, int kind) 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) @@ -530,20 +583,29 @@ gfc_range_check (gfc_expr * e) 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: @@ -554,6 +616,36 @@ gfc_range_check (gfc_expr * e) } +/* 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. */ @@ -595,25 +687,7 @@ gfc_arith_uminus (gfc_expr * op1, gfc_expr ** 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); } @@ -650,25 +724,7 @@ gfc_arith_plus (gfc_expr * op1, gfc_expr * op2, gfc_expr ** 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); } @@ -705,25 +761,7 @@ gfc_arith_minus (gfc_expr * op1, gfc_expr * op2, gfc_expr ** 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); } @@ -748,9 +786,6 @@ gfc_arith_times (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp) break; case BT_COMPLEX: - - /* FIXME: possible numericals problem. */ - gfc_set_model (op1->value.complex.r); mpfr_init (x); mpfr_init (y); @@ -765,7 +800,6 @@ gfc_arith_times (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp) mpfr_clear (x); mpfr_clear (y); - break; default: @@ -774,25 +808,7 @@ gfc_arith_times (gfc_expr * op1, gfc_expr * op2, gfc_expr ** 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); } @@ -821,8 +837,8 @@ gfc_arith_divide (gfc_expr * op1, gfc_expr * op2, gfc_expr ** 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; @@ -833,9 +849,9 @@ gfc_arith_divide (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp) 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; @@ -846,7 +862,6 @@ gfc_arith_divide (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp) 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); @@ -866,7 +881,6 @@ gfc_arith_divide (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp) mpfr_clear (x); mpfr_clear (y); mpfr_clear (div); - break; default: @@ -876,25 +890,7 @@ gfc_arith_divide (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp) 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); } @@ -911,7 +907,6 @@ complex_reciprocal (gfc_expr * op) 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); @@ -989,33 +984,23 @@ gfc_arith_power (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp) 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: @@ -1040,7 +1025,6 @@ gfc_arith_power (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp) result->value.integer); mpz_clear (unity_z); } - break; case BT_REAL: @@ -1072,25 +1056,7 @@ gfc_arith_power (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp) 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); } @@ -1160,7 +1126,7 @@ gfc_compare_expr (gfc_expr * op1, gfc_expr * op2) /* 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) @@ -1170,13 +1136,12 @@ compare_complex (gfc_expr * op1, gfc_expr * op2) } -/* Given two constant strings and the inverse collating sequence, - compare the strings. We return -1 for ab. 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; @@ -1187,8 +1152,10 @@ gfc_compare_string (gfc_expr * a, gfc_expr * b, const int *xcoll_table) 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) { @@ -1527,7 +1494,8 @@ eval_intrinsic (gfc_intrinsic_op operator, switch (operator) { - case INTRINSIC_NOT: /* Logical unary */ + /* Logical unary */ + case INTRINSIC_NOT: if (op1->ts.type != BT_LOGICAL) goto runtime; @@ -1537,7 +1505,7 @@ eval_intrinsic (gfc_intrinsic_op operator, unary = 1; break; - /* Logical binary operators */ + /* Logical binary operators */ case INTRINSIC_OR: case INTRINSIC_AND: case INTRINSIC_NEQV: @@ -1551,8 +1519,9 @@ eval_intrinsic (gfc_intrinsic_op operator, unary = 0; break; + /* Numeric unary */ case INTRINSIC_UPLUS: - case INTRINSIC_UMINUS: /* Numeric unary */ + case INTRINSIC_UMINUS: if (!gfc_numeric_ts (&op1->ts)) goto runtime; @@ -1561,9 +1530,16 @@ eval_intrinsic (gfc_intrinsic_op operator, 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) { @@ -1572,8 +1548,7 @@ eval_intrinsic (gfc_intrinsic_op operator, goto runtime; } - /* else fall through */ - + /* Fall through */ case INTRINSIC_EQ: case INTRINSIC_NE: if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER) @@ -1584,24 +1559,25 @@ eval_intrinsic (gfc_intrinsic_op operator, 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); @@ -1616,7 +1592,8 @@ eval_intrinsic (gfc_intrinsic_op operator, 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; @@ -1637,17 +1614,19 @@ eval_intrinsic (gfc_intrinsic_op operator, 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) @@ -1656,8 +1635,8 @@ eval_intrinsic (gfc_intrinsic_op operator, 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; } @@ -1666,15 +1645,15 @@ eval_intrinsic (gfc_intrinsic_op operator, 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; @@ -1683,8 +1662,9 @@ runtime: /* 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"); @@ -1786,115 +1766,132 @@ eval_intrinsic_f3 (gfc_intrinsic_op operator, } - 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) { @@ -1905,13 +1902,13 @@ 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 @@ -1925,18 +1922,12 @@ gfc_convert_integer (const char *buffer, int kind, int radix, locus * where) /* 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; } @@ -1966,13 +1957,46 @@ gfc_convert_complex (gfc_expr * real, gfc_expr * imag, int kind) 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 * @@ -1990,7 +2014,7 @@ gfc_int2int (gfc_expr * src, int kind) { if (rc == ARITH_ASYMMETRIC) { - gfc_warning ("%s at %L", gfc_arith_error (rc), &src->where); + gfc_warning (gfc_arith_error (rc), &src->where); } else { @@ -2092,7 +2116,7 @@ gfc_real2real (gfc_expr * src, int kind) 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) @@ -2124,7 +2148,7 @@ gfc_real2complex (gfc_expr * src, int kind) 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) @@ -2179,7 +2203,7 @@ gfc_complex2real (gfc_expr * src, int kind) 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) @@ -2211,7 +2235,7 @@ gfc_complex2complex (gfc_expr * src, int kind) 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) @@ -2226,7 +2250,7 @@ gfc_complex2complex (gfc_expr * src, int kind) 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) @@ -2252,3 +2276,238 @@ gfc_log2log (gfc_expr * src, int kind) 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; +}