| /* Compiler arithmetic |
| Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 |
| 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 2, 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 COPYING. If not, write to the Free |
| 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 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" |
| |
| /* 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)); |
| } |
| |
| #if defined(GFC_MPFR_TOO_OLD) |
| /* Calculate atan2 (y, x) |
| |
| atan2(y, x) = atan(y/x) if x > 0, |
| sign(y)*(pi - atan(|y/x|)) if x < 0, |
| 0 if x = 0 && y == 0, |
| sign(y)*pi/2 if x = 0 && y != 0. |
| */ |
| |
| void |
| arctangent2 (mpfr_t y, mpfr_t x, mpfr_t result) |
| { |
| int i; |
| mpfr_t t; |
| |
| gfc_set_model (y); |
| mpfr_init (t); |
| |
| i = mpfr_sgn (x); |
| |
| if (i > 0) |
| { |
| mpfr_div (t, y, x, GFC_RND_MODE); |
| mpfr_atan (result, t, GFC_RND_MODE); |
| } |
| else if (i < 0) |
| { |
| mpfr_const_pi (result, GFC_RND_MODE); |
| mpfr_div (t, y, x, GFC_RND_MODE); |
| mpfr_abs (t, t, GFC_RND_MODE); |
| mpfr_atan (t, t, GFC_RND_MODE); |
| mpfr_sub (result, result, t, GFC_RND_MODE); |
| if (mpfr_sgn (y) < 0) |
| mpfr_neg (result, result, GFC_RND_MODE); |
| } |
| else |
| { |
| if (mpfr_sgn (y) == 0) |
| mpfr_set_ui (result, 0, GFC_RND_MODE); |
| else |
| { |
| mpfr_const_pi (result, GFC_RND_MODE); |
| mpfr_div_ui (result, result, 2, GFC_RND_MODE); |
| if (mpfr_sgn (y) < 0) |
| mpfr_neg (result, result, GFC_RND_MODE); |
| } |
| } |
| |
| mpfr_clear (t); |
| } |
| #endif |
| |
| /* 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) |
| { |
| #if defined(GFC_MPFR_TOO_OLD) |
| /* 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); |
| |
| gfc_free (s); |
| gfc_free (bin); |
| #else |
| 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); |
| #endif |
| |
| /* 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. */ |
| |
| static arith |
| gfc_arith_uplus (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. */ |
| |
| static void |
| complex_pow_ui (gfc_expr * base, int power, gfc_expr * result) |
| { |
| mpfr_t re, im, a; |
| |
| gfc_set_model (base->value.complex.r); |
| mpfr_init (re); |
| mpfr_init (im); |
| mpfr_init (a); |
| |
| mpfr_set_ui (result->value.complex.r, 1, GFC_RND_MODE); |
| mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE); |
| |
| for (; power > 0; power--) |
| { |
| mpfr_mul (re, base->value.complex.r, result->value.complex.r, |
| GFC_RND_MODE); |
| mpfr_mul (a, base->value.complex.i, result->value.complex.i, |
| GFC_RND_MODE); |
| mpfr_sub (re, re, a, GFC_RND_MODE); |
| |
| mpfr_mul (im, base->value.complex.r, result->value.complex.i, |
| GFC_RND_MODE); |
| mpfr_mul (a, base->value.complex.i, result->value.complex.r, |
| GFC_RND_MODE); |
| mpfr_add (im, im, a, GFC_RND_MODE); |
| |
| mpfr_set (result->value.complex.r, re, GFC_RND_MODE); |
| mpfr_set (result->value.complex.i, im, GFC_RND_MODE); |
| } |
| |
| mpfr_clear (re); |
| mpfr_clear (im); |
| mpfr_clear (a); |
| } |
| |
| |
| /* Raise a number to an integer power. */ |
| |
| static arith |
| gfc_arith_power (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp) |
| { |
| int power, apower; |
| gfc_expr *result; |
| mpz_t unity_z; |
| mpfr_t unity_f; |
| arith rc; |
| |
| rc = ARITH_OK; |
| |
| if (gfc_extract_int (op2, &power) != NULL) |
| gfc_internal_error ("gfc_arith_power(): Bad exponent"); |
| |
| result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where); |
| |
| if (power == 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 |
| { |
| apower = power; |
| if (power < 0) |
| apower = -power; |
| |
| switch (op1->ts.type) |
| { |
| case BT_INTEGER: |
| mpz_pow_ui (result->value.integer, op1->value.integer, apower); |
| |
| if (power < 0) |
| { |
| mpz_init_set_ui (unity_z, 1); |
| mpz_tdiv_q (result->value.integer, unity_z, |
| result->value.integer); |
| mpz_clear (unity_z); |
| } |
| break; |
| |
| case BT_REAL: |
| mpfr_pow_ui (result->value.real, op1->value.real, apower, |
| GFC_RND_MODE); |
| |
| if (power < 0) |
| { |
| gfc_set_model (op1->value.real); |
| mpfr_init (unity_f); |
| mpfr_set_ui (unity_f, 1, GFC_RND_MODE); |
| mpfr_div (result->value.real, unity_f, result->value.real, |
| GFC_RND_MODE); |
| mpfr_clear (unity_f); |
| } |
| break; |
| |
| case BT_COMPLEX: |
| complex_pow_ui (op1, apower, result); |
| if (power < 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 = 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) |
| { |
| rc = 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) |
| { |
| rc = 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; |
| } |
| |
| |
| 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 = 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_LT: |
| case INTRINSIC_LE: |
| case INTRINSIC_GT: |
| 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_NE: |
| 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) |
| { |
| 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->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->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_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_LT: |
| case INTRINSIC_LE: |
| case INTRINSIC_GT: |
| case INTRINSIC_EQ: |
| case INTRINSIC_NE: |
| 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_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) |
| { |
| return eval_intrinsic_f3 (INTRINSIC_LE, 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", |
| 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; |
| } |
| |
| |
| /* 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; |
| } |