/* Compiler arithmetic Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc. Contributed by Andy Vaught This file is part of GCC. GCC is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3, or (at your option) any later version. GCC is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with GCC; see the file COPYING3. If not see . */ /* 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 and the MPFR library to do arithmetic, and this file provides the interface. */ #include "config.h" #include "system.h" #include "flags.h" #include "gfortran.h" #include "arith.h" #include "target-memory.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) { mp_exp_t e; 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); else mpz_tdiv_q_2exp (z, z, -e); } /* Set the model number precision by the requested KIND. */ void gfc_set_model_kind (int kind) { int index = gfc_validate_kind (BT_REAL, kind, false); int base2prec; base2prec = gfc_real_kinds[index].digits; if (gfc_real_kinds[index].radix != 2) base2prec *= gfc_real_kinds[index].radix / 2; mpfr_set_default_prec (base2prec); } /* Set the model number precision from mpfr_t x. */ void gfc_set_model (mpfr_t x) { mpfr_set_default_prec (mpfr_get_prec (x)); } /* Given an arithmetic error code, return a pointer to a string that explains the error. */ static const char * gfc_arith_error (arith code) { const char *p; switch (code) { case ARITH_OK: p = _("Arithmetic OK at %L"); break; case ARITH_OVERFLOW: p = _("Arithmetic overflow at %L"); break; case ARITH_UNDERFLOW: p = _("Arithmetic underflow at %L"); break; case ARITH_NAN: p = _("Arithmetic NaN at %L"); break; case ARITH_DIV0: p = _("Division by zero at %L"); break; case ARITH_INCOMMENSURATE: p = _("Array operands are incommensurate at %L"); break; case ARITH_ASYMMETRIC: p = _("Integer outside symmetric range implied by Standard Fortran at %L"); break; default: gfc_internal_error ("gfc_arith_error(): Bad error code"); } return p; } /* Get things ready to do math. */ void gfc_arith_init_1 (void) { gfc_integer_info *int_info; gfc_real_info *real_info; mpfr_t a, b, c; mpz_t r; int i; mpfr_set_default_prec (128); mpfr_init (a); mpz_init (r); /* 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 */ mpz_set_ui (r, int_info->radix); mpz_pow_ui (r, r, int_info->digits); mpz_init (int_info->huge); mpz_sub_ui (int_info->huge, r, 1); /* 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 calculation"); /* See PRs 13490 and 17912, related to integer ranges. The pedantic_min_int exists for range checking when a program is compiled with -pedantic, and reflects the belief that Standard Fortran requires integers to be symmetrical, i.e. every negative integer must have a representable positive absolute value, and vice versa. */ mpz_init (int_info->pedantic_min_int); mpz_neg (int_info->pedantic_min_int, int_info->huge); mpz_init (int_info->min_int); mpz_sub_ui (int_info->min_int, int_info->pedantic_min_int, 1); /* Range */ mpfr_set_z (a, int_info->huge, GFC_RND_MODE); mpfr_log10 (a, a, GFC_RND_MODE); mpfr_trunc (a, a); gfc_mpfr_to_mpz (r, a); int_info->range = mpz_get_si (r); } mpfr_clear (a); for (real_info = gfc_real_kinds; real_info->kind != 0; real_info++) { gfc_set_model_kind (real_info->kind); mpfr_init (a); mpfr_init (b); mpfr_init (c); /* huge(x) = (1 - b**(-p)) * b**(emax-1) * b */ /* 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) */ 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) */ mpfr_mul (a, a, c, GFC_RND_MODE); /* 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) */ 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); /* 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)) */ 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); 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 */ mpfr_set_ui (a, real_info->radix, GFC_RND_MODE); mpfr_log10 (a, a, GFC_RND_MODE); mpfr_mul_ui (a, a, real_info->digits - 1, GFC_RND_MODE); mpfr_trunc (a, a); 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. */ for (i = 10; i <= real_info->radix; i *= 10) if (i == real_info->radix) real_info->precision++; mpfr_clear (a); mpfr_clear (b); mpfr_clear (c); } mpz_clear (r); } /* Clean up, get rid of numeric constants. */ void gfc_arith_done_1 (void) { gfc_integer_info *ip; gfc_real_info *rp; for (ip = gfc_integer_kinds; ip->kind; ip++) { mpz_clear (ip->min_int); mpz_clear (ip->pedantic_min_int); mpz_clear (ip->huge); } for (rp = gfc_real_kinds; rp->kind; rp++) { mpfr_clear (rp->epsilon); mpfr_clear (rp->huge); mpfr_clear (rp->tiny); mpfr_clear (rp->subnormal); } } /* Given an integer and a kind, make sure that the integer lies within the range of the kind. Returns ARITH_OK, ARITH_ASYMMETRIC or ARITH_OVERFLOW. */ arith gfc_check_integer_range (mpz_t p, int kind) { arith result; int i; i = gfc_validate_kind (BT_INTEGER, kind, false); result = ARITH_OK; if (pedantic) { if (mpz_cmp (p, gfc_integer_kinds[i].pedantic_min_int) < 0) result = ARITH_ASYMMETRIC; } if (gfc_option.flag_range_check == 0) return result; if (mpz_cmp (p, gfc_integer_kinds[i].min_int) < 0 || mpz_cmp (p, gfc_integer_kinds[i].huge) > 0) result = ARITH_OVERFLOW; return result; } /* Given a real and a kind, make sure that the real lies within the range of the kind. Returns ARITH_OK, ARITH_OVERFLOW or ARITH_UNDERFLOW. */ static arith gfc_check_real_range (mpfr_t p, int kind) { arith retval; mpfr_t q; int i; i = gfc_validate_kind (BT_REAL, kind, false); gfc_set_model (p); mpfr_init (q); mpfr_abs (q, p, GFC_RND_MODE); if (mpfr_inf_p (p)) { 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) { mp_exp_t emin, emax; int en; /* Save current values of emin and emax. */ emin = mpfr_get_emin (); emax = mpfr_get_emax (); /* Set emin and emax for the current model number. */ 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_subnormalize (q, 0, GFC_RND_MODE); /* Reset emin and emax. */ mpfr_set_emin (emin); mpfr_set_emax (emax); /* Copy sign if needed. */ if (mpfr_sgn (p) < 0) mpfr_neg (p, q, GMP_RNDN); else mpfr_set (p, q, GMP_RNDN); retval = ARITH_OK; } else retval = ARITH_OK; mpfr_clear (q); return retval; } /* 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 can fail in various ways -- overflow, underflow, division by zero, zero raised to the zero, etc. */ static arith gfc_arith_not (gfc_expr *op1, gfc_expr **resultp) { gfc_expr *result; result = gfc_constant_result (BT_LOGICAL, op1->ts.kind, &op1->where); result->value.logical = !op1->value.logical; *resultp = result; return ARITH_OK; } static arith gfc_arith_and (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) { gfc_expr *result; result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2), &op1->where); result->value.logical = op1->value.logical && op2->value.logical; *resultp = result; return ARITH_OK; } static arith gfc_arith_or (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) { gfc_expr *result; result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2), &op1->where); result->value.logical = op1->value.logical || op2->value.logical; *resultp = result; return ARITH_OK; } static arith gfc_arith_eqv (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) { gfc_expr *result; result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2), &op1->where); result->value.logical = op1->value.logical == op2->value.logical; *resultp = result; return ARITH_OK; } static arith gfc_arith_neqv (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) { gfc_expr *result; result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2), &op1->where); result->value.logical = op1->value.logical != op2->value.logical; *resultp = result; return ARITH_OK; } /* Make sure a constant numeric expression is within the range for its type and kind. Note that there's also a gfc_check_range(), but that one deals with the intrinsic RANGE function. */ arith gfc_range_check (gfc_expr *e) { arith rc; switch (e->ts.type) { case BT_INTEGER: rc = gfc_check_integer_range (e->value.integer, e->ts.kind); break; 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); 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_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: gfc_internal_error ("gfc_range_check(): Bad type"); } return rc; } /* 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. Used for unary plus and parenthesized expressions. */ static arith gfc_arith_identity (gfc_expr *op1, gfc_expr **resultp) { *resultp = gfc_copy_expr (op1); return ARITH_OK; } static arith gfc_arith_uminus (gfc_expr *op1, gfc_expr **resultp) { gfc_expr *result; arith rc; result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where); switch (op1->ts.type) { case BT_INTEGER: mpz_neg (result->value.integer, op1->value.integer); break; case BT_REAL: mpfr_neg (result->value.real, op1->value.real, GFC_RND_MODE); 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); break; default: gfc_internal_error ("gfc_arith_uminus(): Bad basic type"); } rc = gfc_range_check (result); return check_result (rc, op1, result, resultp); } static arith gfc_arith_plus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) { gfc_expr *result; arith rc; result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where); switch (op1->ts.type) { case BT_INTEGER: mpz_add (result->value.integer, op1->value.integer, op2->value.integer); break; case BT_REAL: mpfr_add (result->value.real, op1->value.real, op2->value.real, GFC_RND_MODE); 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); break; default: gfc_internal_error ("gfc_arith_plus(): Bad basic type"); } rc = gfc_range_check (result); return check_result (rc, op1, result, resultp); } static arith gfc_arith_minus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) { gfc_expr *result; arith rc; result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where); switch (op1->ts.type) { case BT_INTEGER: mpz_sub (result->value.integer, op1->value.integer, op2->value.integer); break; case BT_REAL: mpfr_sub (result->value.real, op1->value.real, op2->value.real, GFC_RND_MODE); 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); break; default: gfc_internal_error ("gfc_arith_minus(): Bad basic type"); } rc = gfc_range_check (result); return check_result (rc, op1, result, resultp); } static arith 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); switch (op1->ts.type) { case BT_INTEGER: mpz_mul (result->value.integer, op1->value.integer, op2->value.integer); break; case BT_REAL: mpfr_mul (result->value.real, op1->value.real, op2->value.real, GFC_RND_MODE); 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_clear (x); mpfr_clear (y); break; default: gfc_internal_error ("gfc_arith_times(): Bad basic type"); } rc = gfc_range_check (result); return check_result (rc, op1, result, resultp); } static arith 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); switch (op1->ts.type) { case BT_INTEGER: if (mpz_sgn (op2->value.integer) == 0) { rc = ARITH_DIV0; break; } mpz_tdiv_q (result->value.integer, op1->value.integer, op2->value.integer); break; case BT_REAL: if (mpfr_sgn (op2->value.real) == 0 && gfc_option.flag_range_check == 1) { rc = ARITH_DIV0; break; } mpfr_div (result->value.real, op1->value.real, op2->value.real, GFC_RND_MODE); break; case BT_COMPLEX: if (mpfr_sgn (op2->value.complex.r) == 0 && mpfr_sgn (op2->value.complex.i) == 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_clear (x); mpfr_clear (y); mpfr_clear (div); break; default: gfc_internal_error ("gfc_arith_divide(): Bad basic type"); } if (rc == ARITH_OK) rc = gfc_range_check (result); 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, a, re, im; gfc_set_model (op->value.complex.r); mpfr_init (mod); mpfr_init (a); mpfr_init (re); mpfr_init (im); 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); mpfr_div (re, op->value.complex.r, mod, GFC_RND_MODE); mpfr_neg (im, op->value.complex.i, GFC_RND_MODE); mpfr_div (im, im, mod, GFC_RND_MODE); mpfr_set (op->value.complex.r, re, GFC_RND_MODE); mpfr_set (op->value.complex.i, im, GFC_RND_MODE); mpfr_clear (re); mpfr_clear (im); mpfr_clear (mod); mpfr_clear (a); } /* 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_clear (x_r); mpfr_clear (x_i); mpfr_clear (tmp); mpfr_clear (re); mpfr_clear (im); } /* Raise a number to an integer power. */ static arith gfc_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); if (power_sign == 0) { /* 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_COMPLEX: mpfr_set_ui (result->value.complex.r, 1, GFC_RND_MODE); mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE); break; default: gfc_internal_error ("gfc_arith_power(): Bad base"); } } else { switch (op1->ts.type) { 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) { /* (-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 = 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; 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; /* Compute op1**abs(op2) */ mpz_init (apower); mpz_abs (apower, op2->value.integer); complex_pow (result, op1, apower); mpz_clear (apower); /* If (op2 < 0), compute the inverse. */ if (power_sign < 0) complex_reciprocal (result); break; } default: break; } } if (rc == ARITH_OK) rc = gfc_range_check (result); return check_result (rc, op1, result, resultp); } /* Concatenate two string constants. */ static arith gfc_arith_concat (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) { gfc_expr *result; int len; result = gfc_constant_result (BT_CHARACTER, gfc_default_character_kind, &op1->where); len = op1->value.character.length + op2->value.character.length; result->value.character.string = gfc_getmem (len + 1); result->value.character.length = len; memcpy (result->value.character.string, op1->value.character.string, op1->value.character.length); memcpy (result->value.character.string + op1->value.character.length, op2->value.character.string, op2->value.character.length); result->value.character.string[len] = '\0'; *resultp = result; return ARITH_OK; } /* Comparison operators. Assumes that the two expression nodes contain two constants of the same type. */ int gfc_compare_expr (gfc_expr *op1, gfc_expr *op2) { int rc; switch (op1->ts.type) { case BT_INTEGER: rc = mpz_cmp (op1->value.integer, op2->value.integer); break; case BT_REAL: rc = mpfr_cmp (op1->value.real, op2->value.real); break; case BT_CHARACTER: rc = gfc_compare_string (op1, op2); break; case BT_LOGICAL: rc = ((!op1->value.logical && op2->value.logical) || (op1->value.logical && !op2->value.logical)); break; default: gfc_internal_error ("gfc_compare_expr(): Bad basic type"); } return rc; } /* Compare a pair of complex numbers. Naturally, this is only for equality and nonequality. */ static int compare_complex (gfc_expr *op1, gfc_expr *op2) { return (mpfr_cmp (op1->value.complex.r, op2->value.complex.r) == 0 && mpfr_cmp (op1->value.complex.i, op2->value.complex.i) == 0); } /* 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. We use the processor's default collating sequence. */ int gfc_compare_string (gfc_expr *a, gfc_expr *b) { int len, alen, blen, i, ac, bc; alen = a->value.character.length; blen = b->value.character.length; len = (alen > blen) ? alen : blen; for (i = 0; i < len; 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 (ac < bc) return -1; if (ac > bc) return 1; } /* Strings are equal */ return 0; } /* Specific comparison subroutines. */ static arith gfc_arith_eq (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) { gfc_expr *result; result = gfc_constant_result (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) == 0); *resultp = result; return ARITH_OK; } static arith gfc_arith_ne (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) { gfc_expr *result; result = gfc_constant_result (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) != 0); *resultp = result; return ARITH_OK; } static arith gfc_arith_gt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) { gfc_expr *result; result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind, &op1->where); result->value.logical = (gfc_compare_expr (op1, op2) > 0); *resultp = result; return ARITH_OK; } static arith gfc_arith_ge (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) { gfc_expr *result; result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind, &op1->where); result->value.logical = (gfc_compare_expr (op1, op2) >= 0); *resultp = result; return ARITH_OK; } static arith gfc_arith_lt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) { gfc_expr *result; result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind, &op1->where); result->value.logical = (gfc_compare_expr (op1, op2) < 0); *resultp = result; return ARITH_OK; } static arith gfc_arith_le (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) { gfc_expr *result; result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind, &op1->where); result->value.logical = (gfc_compare_expr (op1, op2) <= 0); *resultp = result; return ARITH_OK; } static arith reduce_unary (arith (*eval) (gfc_expr *, gfc_expr **), gfc_expr *op, gfc_expr **result) { gfc_constructor *c, *head; gfc_expr *r; arith rc; if (op->expr_type == EXPR_CONSTANT) return eval (op, result); rc = ARITH_OK; head = gfc_copy_constructor (op->value.constructor); for (c = head; c; c = c->next) { rc = reduce_unary (eval, c->expr, &r); if (rc != ARITH_OK) break; gfc_replace_expr (c->expr, r); } if (rc != ARITH_OK) gfc_free_constructor (head); else { r = gfc_get_expr (); r->expr_type = EXPR_ARRAY; r->value.constructor = head; r->shape = gfc_copy_shape (op->shape, op->rank); r->ts = head->expr->ts; r->where = op->where; r->rank = op->rank; *result = r; } return rc; } static arith 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_expr *r; arith rc; head = gfc_copy_constructor (op1->value.constructor); rc = ARITH_OK; for (c = head; c; c = c->next) { if (c->expr->expr_type == EXPR_CONSTANT) rc = eval (c->expr, op2, &r); else rc = reduce_binary_ac (eval, c->expr, op2, &r); if (rc != ARITH_OK) break; gfc_replace_expr (c->expr, r); } if (rc != ARITH_OK) gfc_free_constructor (head); else { r = gfc_get_expr (); r->expr_type = EXPR_ARRAY; r->value.constructor = head; r->shape = gfc_copy_shape (op1->shape, op1->rank); r->ts = head->expr->ts; r->where = op1->where; r->rank = op1->rank; *result = r; } return rc; } static arith 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_expr *r; arith rc; head = gfc_copy_constructor (op2->value.constructor); rc = ARITH_OK; for (c = head; c; c = c->next) { if (c->expr->expr_type == EXPR_CONSTANT) rc = eval (op1, c->expr, &r); else rc = reduce_binary_ca (eval, op1, c->expr, &r); if (rc != ARITH_OK) break; gfc_replace_expr (c->expr, r); } if (rc != ARITH_OK) gfc_free_constructor (head); else { r = gfc_get_expr (); r->expr_type = EXPR_ARRAY; r->value.constructor = head; r->shape = gfc_copy_shape (op2->shape, op2->rank); r->ts = head->expr->ts; r->where = op2->where; r->rank = op2->rank; *result = r; } return rc; } /* We need a forward declaration of reduce_binary. */ static arith reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), gfc_expr *op1, gfc_expr *op2, gfc_expr **result); static arith 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_expr *r; arith rc; head = gfc_copy_constructor (op1->value.constructor); rc = ARITH_OK; d = op2->value.constructor; if (gfc_check_conformance ("elemental binary operation", op1, op2) != SUCCESS) rc = ARITH_INCOMMENSURATE; else { 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); } if (d != NULL) rc = ARITH_INCOMMENSURATE; } if (rc != ARITH_OK) gfc_free_constructor (head); else { r = gfc_get_expr (); r->expr_type = EXPR_ARRAY; r->value.constructor = head; r->shape = gfc_copy_shape (op1->shape, op1->rank); r->ts = head->expr->ts; r->where = op1->where; r->rank = op1->rank; *result = r; } return rc; } static arith reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), gfc_expr *op1, gfc_expr *op2, gfc_expr **result) { if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_CONSTANT) return eval (op1, op2, result); if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_ARRAY) return reduce_binary_ca (eval, op1, op2, result); if (op1->expr_type == EXPR_ARRAY && op2->expr_type == EXPR_CONSTANT) return reduce_binary_ac (eval, op1, op2, result); return reduce_binary_aa (eval, op1, op2, result); } typedef union { arith (*f2)(gfc_expr *, gfc_expr **); arith (*f3)(gfc_expr *, gfc_expr *, gfc_expr **); } eval_f; /* High level arithmetic subroutines. These subroutines go into eval_intrinsic(), which can do one of several things to its operands. If the operands are incompatible with the intrinsic operation, we return a node pointing to the operands and hope that an operator interface is found during resolution. If the operands are compatible and are constants, then we try doing the arithmetic. We also handle the cases where either or both operands are array constructors. */ static gfc_expr * eval_intrinsic (gfc_intrinsic_op operator, eval_f eval, gfc_expr *op1, gfc_expr *op2) { gfc_expr temp, *result; int unary; arith rc; gfc_clear_ts (&temp.ts); switch (operator) { /* Logical unary */ case INTRINSIC_NOT: if (op1->ts.type != BT_LOGICAL) goto runtime; temp.ts.type = BT_LOGICAL; temp.ts.kind = gfc_default_logical_kind; unary = 1; break; /* Logical binary operators */ case INTRINSIC_OR: case INTRINSIC_AND: case INTRINSIC_NEQV: case INTRINSIC_EQV: if (op1->ts.type != BT_LOGICAL || op2->ts.type != BT_LOGICAL) goto runtime; temp.ts.type = BT_LOGICAL; temp.ts.kind = gfc_default_logical_kind; unary = 0; break; /* Numeric unary */ case INTRINSIC_UPLUS: case INTRINSIC_UMINUS: if (!gfc_numeric_ts (&op1->ts)) goto runtime; temp.ts = op1->ts; unary = 1; break; case INTRINSIC_PARENTHESES: temp.ts = op1->ts; unary = 1; break; /* Additional restrictions for ordering relations. */ case INTRINSIC_GE: case INTRINSIC_GE_OS: case INTRINSIC_LT: case INTRINSIC_LT_OS: case INTRINSIC_LE: case INTRINSIC_LE_OS: case INTRINSIC_GT: case INTRINSIC_GT_OS: if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX) { temp.ts.type = BT_LOGICAL; temp.ts.kind = gfc_default_logical_kind; goto runtime; } /* Fall through */ case INTRINSIC_EQ: case INTRINSIC_EQ_OS: case INTRINSIC_NE: case INTRINSIC_NE_OS: if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER) { unary = 0; temp.ts.type = BT_LOGICAL; temp.ts.kind = gfc_default_logical_kind; break; } /* Fall through */ /* Numeric binary */ case INTRINSIC_PLUS: case INTRINSIC_MINUS: case INTRINSIC_TIMES: case INTRINSIC_DIVIDE: 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. */ temp.expr_type = EXPR_OP; gfc_clear_ts (&temp.ts); temp.value.op.operator = operator; temp.value.op.op1 = op1; temp.value.op.op2 = op2; gfc_type_convert_binary (&temp); 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) { temp.ts.type = BT_LOGICAL; temp.ts.kind = gfc_default_logical_kind; } unary = 0; break; /* Character binary */ case INTRINSIC_CONCAT: if (op1->ts.type != BT_CHARACTER || op2->ts.type != BT_CHARACTER) goto runtime; temp.ts.type = BT_CHARACTER; temp.ts.kind = gfc_default_character_kind; unary = 0; break; case INTRINSIC_USER: goto runtime; default: 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))) goto runtime; if (op2 != NULL && 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_unary (eval.f2, op1, &result); else rc = reduce_binary (eval.f3, op1, op2, &result); if (rc != ARITH_OK) { /* Something went wrong. */ gfc_error (gfc_arith_error (rc), &op1->where); return NULL; } gfc_free_expr (op1); gfc_free_expr (op2); return result; runtime: /* Create a run-time expression. */ result = gfc_get_expr (); 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; } /* Modify type of expression for zero size array. */ static gfc_expr * eval_type_intrinsic0 (gfc_intrinsic_op operator, gfc_expr *op) { if (op == NULL) gfc_internal_error ("eval_type_intrinsic0(): op NULL"); switch (operator) { case INTRINSIC_GE: case INTRINSIC_GE_OS: case INTRINSIC_LT: case INTRINSIC_LT_OS: case INTRINSIC_LE: case INTRINSIC_LE_OS: case INTRINSIC_GT: case INTRINSIC_GT_OS: case INTRINSIC_EQ: case INTRINSIC_EQ_OS: case INTRINSIC_NE: case INTRINSIC_NE_OS: op->ts.type = BT_LOGICAL; op->ts.kind = gfc_default_logical_kind; break; default: break; } return op; } /* Return nonzero if the expression is a zero size array. */ static int gfc_zero_size_array (gfc_expr *e) { if (e->expr_type != EXPR_ARRAY) return 0; return e->value.constructor == NULL; } /* Reduce a binary expression where at least one of the operands involves a zero-length array. Returns NULL if neither of the operands is a zero-length array. */ static gfc_expr * reduce_binary0 (gfc_expr *op1, gfc_expr *op2) { if (gfc_zero_size_array (op1)) { gfc_free_expr (op2); return op1; } if (gfc_zero_size_array (op2)) { gfc_free_expr (op1); return op2; } return NULL; } static gfc_expr * eval_intrinsic_f2 (gfc_intrinsic_op operator, arith (*eval) (gfc_expr *, gfc_expr **), gfc_expr *op1, gfc_expr *op2) { gfc_expr *result; eval_f f; if (op2 == NULL) { if (gfc_zero_size_array (op1)) return eval_type_intrinsic0 (operator, op1); } else { result = reduce_binary0 (op1, op2); if (result != NULL) return eval_type_intrinsic0 (operator, result); } f.f2 = eval; return eval_intrinsic (operator, f, op1, op2); } static gfc_expr * eval_intrinsic_f3 (gfc_intrinsic_op operator, arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), gfc_expr *op1, gfc_expr *op2) { gfc_expr *result; eval_f f; result = reduce_binary0 (op1, op2); if (result != NULL) return eval_type_intrinsic0(operator, result); f.f3 = eval; return eval_intrinsic (operator, f, op1, op2); } gfc_expr * gfc_parentheses (gfc_expr *op) { if (gfc_is_constant_expr (op)) return op; return eval_intrinsic_f2 (INTRINSIC_PARENTHESES, gfc_arith_identity, op, NULL); } gfc_expr * gfc_uplus (gfc_expr *op) { return eval_intrinsic_f2 (INTRINSIC_UPLUS, gfc_arith_identity, 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, gfc_intrinsic_op op) { return eval_intrinsic_f3 (op, gfc_arith_eq, op1, op2); } gfc_expr * gfc_ne (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op) { return eval_intrinsic_f3 (op, gfc_arith_ne, op1, op2); } gfc_expr * gfc_gt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op) { return eval_intrinsic_f3 (op, gfc_arith_gt, op1, op2); } gfc_expr * gfc_ge (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op) { return eval_intrinsic_f3 (op, gfc_arith_ge, op1, op2); } gfc_expr * gfc_lt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op) { return eval_intrinsic_f3 (op, gfc_arith_lt, op1, op2); } gfc_expr * gfc_le (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op) { return eval_intrinsic_f3 (op, gfc_arith_le, op1, op2); } /* Convert an integer string to an expression node. */ gfc_expr * 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. */ if (buffer[0] == '+') t = buffer + 1; else t = buffer; mpz_set_str (e->value.integer, t, radix); return e; } /* Convert a real string to an expression node. */ gfc_expr * gfc_convert_real (const char *buffer, int kind, locus *where) { gfc_expr *e; e = gfc_constant_result (BT_REAL, kind, where); mpfr_set_str (e->value.real, buffer, 10, GFC_RND_MODE); return e; } /* Convert a pair of real, constant expression nodes to a single complex expression node. */ gfc_expr * gfc_convert_complex (gfc_expr *real, gfc_expr *imag, int kind) { 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); return e; } /******* Simplification of intrinsic functions with constant arguments *****/ /* Deal with an arithmetic error. */ static void arith_error (arith rc, gfc_typespec *from, gfc_typespec *to, locus *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. This check " "can be disabled with the option -fno-range-check", 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 * gfc_int2int (gfc_expr *src, int kind) { gfc_expr *result; arith rc; result = gfc_constant_result (BT_INTEGER, kind, &src->where); mpz_set (result->value.integer, src->value.integer); if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK) { if (rc == ARITH_ASYMMETRIC) { gfc_warning (gfc_arith_error (rc), &src->where); } else { arith_error (rc, &src->ts, &result->ts, &src->where); gfc_free_expr (result); return NULL; } } return result; } /* Convert integers to reals. */ gfc_expr * gfc_int2real (gfc_expr *src, int kind) { gfc_expr *result; arith rc; result = gfc_constant_result (BT_REAL, kind, &src->where); mpfr_set_z (result->value.real, src->value.integer, GFC_RND_MODE); if ((rc = gfc_check_real_range (result->value.real, kind)) != ARITH_OK) { arith_error (rc, &src->ts, &result->ts, &src->where); gfc_free_expr (result); return NULL; } return result; } /* Convert default integer to default complex. */ gfc_expr * gfc_int2complex (gfc_expr *src, int kind) { gfc_expr *result; arith rc; result = gfc_constant_result (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); if ((rc = gfc_check_real_range (result->value.complex.r, kind)) != ARITH_OK) { arith_error (rc, &src->ts, &result->ts, &src->where); gfc_free_expr (result); return NULL; } return result; } /* Convert default real to default integer. */ gfc_expr * gfc_real2int (gfc_expr *src, int kind) { gfc_expr *result; arith rc; result = gfc_constant_result (BT_INTEGER, kind, &src->where); gfc_mpfr_to_mpz (result->value.integer, src->value.real); if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK) { arith_error (rc, &src->ts, &result->ts, &src->where); gfc_free_expr (result); return NULL; } return result; } /* Convert real to real. */ gfc_expr * gfc_real2real (gfc_expr *src, int kind) { gfc_expr *result; arith rc; result = gfc_constant_result (BT_REAL, kind, &src->where); mpfr_set (result->value.real, src->value.real, GFC_RND_MODE); rc = gfc_check_real_range (result->value.real, kind); if (rc == ARITH_UNDERFLOW) { if (gfc_option.warn_underflow) gfc_warning (gfc_arith_error (rc), &src->where); mpfr_set_ui (result->value.real, 0, GFC_RND_MODE); } else if (rc != ARITH_OK) { arith_error (rc, &src->ts, &result->ts, &src->where); gfc_free_expr (result); return NULL; } return result; } /* Convert real to complex. */ gfc_expr * gfc_real2complex (gfc_expr *src, int kind) { gfc_expr *result; arith rc; result = gfc_constant_result (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); rc = gfc_check_real_range (result->value.complex.r, 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); } else if (rc != ARITH_OK) { arith_error (rc, &src->ts, &result->ts, &src->where); gfc_free_expr (result); return NULL; } return result; } /* Convert complex to integer. */ gfc_expr * gfc_complex2int (gfc_expr *src, int kind) { gfc_expr *result; arith rc; result = gfc_constant_result (BT_INTEGER, kind, &src->where); gfc_mpfr_to_mpz (result->value.integer, src->value.complex.r); if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK) { arith_error (rc, &src->ts, &result->ts, &src->where); gfc_free_expr (result); return NULL; } return result; } /* Convert complex to real. */ gfc_expr * gfc_complex2real (gfc_expr *src, int kind) { gfc_expr *result; arith rc; result = gfc_constant_result (BT_REAL, kind, &src->where); mpfr_set (result->value.real, src->value.complex.r, GFC_RND_MODE); rc = gfc_check_real_range (result->value.real, kind); if (rc == ARITH_UNDERFLOW) { if (gfc_option.warn_underflow) gfc_warning (gfc_arith_error (rc), &src->where); mpfr_set_ui (result->value.real, 0, GFC_RND_MODE); } if (rc != ARITH_OK) { arith_error (rc, &src->ts, &result->ts, &src->where); gfc_free_expr (result); return NULL; } return result; } /* Convert complex to complex. */ gfc_expr * gfc_complex2complex (gfc_expr *src, int kind) { gfc_expr *result; arith rc; result = gfc_constant_result (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); rc = gfc_check_real_range (result->value.complex.r, 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); } else if (rc != ARITH_OK) { arith_error (rc, &src->ts, &result->ts, &src->where); gfc_free_expr (result); return NULL; } rc = gfc_check_real_range (result->value.complex.i, 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); } else if (rc != ARITH_OK) { arith_error (rc, &src->ts, &result->ts, &src->where); gfc_free_expr (result); return NULL; } return result; } /* Logical kind conversion. */ gfc_expr * gfc_log2log (gfc_expr *src, int kind) { gfc_expr *result; result = gfc_constant_result (BT_LOGICAL, kind, &src->where); result->value.logical = src->value.logical; 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; } /* Helper function to set the representation in a Hollerith conversion. This assumes that the ts.type and ts.kind of the result have already been set. */ static void hollerith2representation (gfc_expr *result, gfc_expr *src) { int src_len, result_len; src_len = src->representation.length; result_len = gfc_target_expr_size (result); if (src_len > result_len) { gfc_warning ("The Hollerith constant at %L is too long to convert to %s", &src->where, gfc_typename(&result->ts)); } result->representation.string = gfc_getmem (result_len + 1); memcpy (result->representation.string, src->representation.string, MIN (result_len, src_len)); if (src_len < result_len) memset (&result->representation.string[src_len], ' ', result_len - src_len); result->representation.string[result_len] = '\0'; /* For debugger */ result->representation.length = result_len; } /* Convert Hollerith to integer. The constant will be padded or truncated. */ gfc_expr * 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; hollerith2representation (result, src); gfc_interpret_integer(kind, (unsigned char *) result->representation.string, result->representation.length, result->value.integer); 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; hollerith2representation (result, src); gfc_interpret_float(kind, (unsigned char *) result->representation.string, result->representation.length, result->value.real); 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; hollerith2representation (result, src); gfc_interpret_complex(kind, (unsigned char *) result->representation.string, result->representation.length, result->value.complex.r, result->value.complex.i); 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->value.character.string = result->representation.string; result->value.character.length = result->representation.length; 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; hollerith2representation (result, src); gfc_interpret_logical(kind, (unsigned char *) result->representation.string, result->representation.length, &result->value.logical); 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; }