/* Compiler arithmetic
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
Free Software Foundation, Inc.
Contributed by Andy Vaught
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
+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
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. */
+along with GCC; see the file COPYING3. If not see
+<http://www.gnu.org/licenses/>. */
/* Since target arithmetic must be done on the host, there has to
be some way of evaluating arithmetic expressions as the host
#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. */
{
gfc_integer_info *int_info;
gfc_real_info *real_info;
- mpfr_t a, b, c;
- mpz_t r;
+ mpfr_t a, b;
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);
+ mpz_set_ui (int_info->huge, int_info->radix);
+ mpz_pow_ui (int_info->huge, int_info->huge, int_info->digits);
+ mpz_sub_ui (int_info->huge, int_info->huge, 1);
/* These are the numbers that are actually representable by the
target. For bases other than two, this needs to be changed. */
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);
+ int_info->range = (int) mpfr_get_si (a, GFC_RND_MODE);
}
mpfr_clear (a);
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);
+ /* 1 - b**(-p) */
+ mpfr_init (real_info->huge);
+ mpfr_set_ui (real_info->huge, 1, GFC_RND_MODE);
+ mpfr_set_ui (a, real_info->radix, GFC_RND_MODE);
+ mpfr_pow_si (a, a, -real_info->digits, GFC_RND_MODE);
+ mpfr_sub (real_info->huge, real_info->huge, a, GFC_RND_MODE);
- /* a = a * c = (1 - b**(-p)) * b**(emax-1) */
- mpfr_mul (a, a, c, GFC_RND_MODE);
+ /* b**(emax-1) */
+ mpfr_set_ui (a, real_info->radix, GFC_RND_MODE);
+ mpfr_pow_ui (a, a, real_info->max_exponent - 1, GFC_RND_MODE);
- /* a = (1 - b**(-p)) * b**(emax-1) * b */
- mpfr_mul_ui (a, a, real_info->radix, GFC_RND_MODE);
+ /* (1 - b**(-p)) * b**(emax-1) */
+ mpfr_mul (real_info->huge, real_info->huge, a, GFC_RND_MODE);
- mpfr_init (real_info->huge);
- mpfr_set (real_info->huge, a, GFC_RND_MODE);
+ /* (1 - b**(-p)) * b**(emax-1) * b */
+ mpfr_mul_ui (real_info->huge, real_info->huge, real_info->radix,
+ 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);
+ mpfr_set_ui (real_info->tiny, real_info->radix, GFC_RND_MODE);
+ mpfr_pow_si (real_info->tiny, real_info->tiny,
+ real_info->min_exponent - 1, 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);
+ mpfr_set_ui (real_info->subnormal, real_info->radix, GFC_RND_MODE);
+ mpfr_pow_si (real_info->subnormal, real_info->subnormal,
+ real_info->min_exponent - real_info->digits, 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);
+ mpfr_set_ui (real_info->epsilon, real_info->radix, GFC_RND_MODE);
+ mpfr_pow_si (real_info->epsilon, real_info->epsilon,
+ 1 - real_info->digits, GFC_RND_MODE);
/* range(x) = int(min(log10(huge(x)), -log10(tiny)) */
mpfr_log10 (a, real_info->huge, 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_min (a, a, b, GFC_RND_MODE);
mpfr_trunc (a, a);
- gfc_mpfr_to_mpz (r, a);
- real_info->range = mpz_get_si (r);
+ real_info->range = (int) mpfr_get_si (a, GFC_RND_MODE);
/* 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);
+ real_info->precision = (int) mpfr_get_si (a, GFC_RND_MODE);
/* 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);
+ mpfr_clears (a, b, NULL);
}
-
- mpz_clear (r);
}
}
for (rp = gfc_real_kinds; rp->kind; rp++)
- {
- mpfr_clear (rp->epsilon);
- mpfr_clear (rp->huge);
- mpfr_clear (rp->tiny);
- mpfr_clear (rp->subnormal);
- }
+ mpfr_clears (rp->epsilon, rp->huge, rp->tiny, rp->subnormal, NULL);
+}
+
+
+/* Given a wide character value and a character kind, determine whether
+ the character is representable for that kind. */
+bool
+gfc_check_character_range (gfc_char_t c, int kind)
+{
+ /* As wide characters are stored as 32-bit values, they're all
+ representable in UCS=4. */
+ if (kind == 4)
+ return true;
+
+ if (kind == 1)
+ return c <= 255 ? true : false;
+
+ gcc_unreachable ();
}
mpfr_init (q);
mpfr_abs (q, p, GFC_RND_MODE);
+ retval = ARITH_OK;
+
if (mpfr_inf_p (p))
{
- if (gfc_option.flag_range_check == 0)
- retval = ARITH_OK;
- else
+ if (gfc_option.flag_range_check != 0)
retval = ARITH_OVERFLOW;
}
else if (mpfr_nan_p (p))
{
- if (gfc_option.flag_range_check == 0)
- retval = ARITH_OK;
- else
+ if (gfc_option.flag_range_check != 0)
retval = ARITH_NAN;
}
else if (mpfr_sgn (q) == 0)
- retval = ARITH_OK;
+ {
+ mpfr_clear (q);
+ return retval;
+ }
else if (mpfr_cmp (q, gfc_real_kinds[i].huge) > 0)
{
if (gfc_option.flag_range_check == 0)
- retval = ARITH_OK;
+ mpfr_set_inf (p, mpfr_sgn (p));
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;
+ {
+ if (mpfr_sgn (p) < 0)
+ {
+ mpfr_set_ui (p, 0, GFC_RND_MODE);
+ mpfr_set_si (q, -1, GFC_RND_MODE);
+ mpfr_copysign (p, p, q, GFC_RND_MODE);
+ }
+ else
+ mpfr_set_ui (p, 0, GFC_RND_MODE);
+ }
else
retval = ARITH_UNDERFLOW;
}
mpfr_neg (p, q, GMP_RNDN);
else
mpfr_set (p, q, GMP_RNDN);
-
- retval = ARITH_OK;
}
- else
- retval = ARITH_OK;
mpfr_clear (q);
gfc_range_check (gfc_expr *e)
{
arith rc;
+ arith rc2;
switch (e->ts.type)
{
if (rc == ARITH_NAN)
mpfr_set_nan (e->value.complex.r);
- rc = gfc_check_real_range (e->value.complex.i, e->ts.kind);
+ rc2 = 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);
+
+ if (rc == ARITH_OK)
+ rc = rc2;
break;
default:
/* 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. */
+ in the code elsewhere. Used for unary plus and parenthesized
+ expressions. */
static arith
-gfc_arith_uplus (gfc_expr *op1, gfc_expr **resultp)
+gfc_arith_identity (gfc_expr *op1, gfc_expr **resultp)
{
*resultp = gfc_copy_expr (op1);
return ARITH_OK;
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);
+ mpfr_clears (x, y, NULL);
break;
default:
mpfr_div (result->value.complex.i, result->value.complex.i, div,
GFC_RND_MODE);
- mpfr_clear (x);
- mpfr_clear (y);
- mpfr_clear (div);
+ mpfr_clears (x, y, div, NULL);
break;
default:
static void
complex_reciprocal (gfc_expr *op)
{
- mpfr_t mod, a, re, im;
+ mpfr_t mod, tmp;
gfc_set_model (op->value.complex.r);
mpfr_init (mod);
- mpfr_init (a);
- mpfr_init (re);
- mpfr_init (im);
+ mpfr_init (tmp);
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_mul (tmp, op->value.complex.i, op->value.complex.i, GFC_RND_MODE);
+ mpfr_add (mod, mod, tmp, GFC_RND_MODE);
- mpfr_neg (im, op->value.complex.i, GFC_RND_MODE);
- mpfr_div (im, im, mod, GFC_RND_MODE);
+ mpfr_div (op->value.complex.r, op->value.complex.r, 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_neg (op->value.complex.i, op->value.complex.i, GFC_RND_MODE);
+ mpfr_div (op->value.complex.i, op->value.complex.i, mod, GFC_RND_MODE);
- mpfr_clear (re);
- mpfr_clear (im);
- mpfr_clear (mod);
- mpfr_clear (a);
+ mpfr_clears (tmp, mod, NULL);
}
-/* Raise a complex number to positive power. */
+/* 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_ui (gfc_expr *base, int power, gfc_expr *result)
+complex_pow (gfc_expr *result, gfc_expr *base, mpz_t power)
{
- mpfr_t re, im, a;
+ 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);
- mpfr_init (a);
+ /* res = 1 */
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--)
+ /* 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))
{
- 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);
+ /* 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);
- 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);
+ /* power /= 2; */
+ mpz_fdiv_q_ui (power, power, 2);
}
- mpfr_clear (re);
- mpfr_clear (im);
- mpfr_clear (a);
+#undef res_r
+#undef res_i
+#undef CMULT
+
+ mpfr_clears (x_r, x_i, tmp, re, im, NULL);
}
static arith
gfc_arith_power (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
{
- int power, apower;
+ int power_sign;
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");
+ 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 == 0)
+ if (power_sign == 0)
{
/* Handle something to the zeroth power. Since we're dealing
with integral exponents, there is no ambiguity in the
}
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);
- }
+ {
+ 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_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);
- }
+ mpfr_pow_z (result->value.real, op1->value.real, op2->value.integer,
+ GFC_RND_MODE);
break;
case BT_COMPLEX:
- complex_pow_ui (op1, apower, result);
- if (power < 0)
- complex_reciprocal (result);
- break;
+ {
+ 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;
len = op1->value.character.length + op2->value.character.length;
- result->value.character.string = gfc_getmem (len + 1);
+ result->value.character.string = gfc_get_wide_string (len + 1);
result->value.character.length = len;
memcpy (result->value.character.string, op1->value.character.string,
- op1->value.character.length);
+ op1->value.character.length * sizeof (gfc_char_t));
- memcpy (result->value.character.string + op1->value.character.length,
- op2->value.character.string, op2->value.character.length);
+ memcpy (&result->value.character.string[op1->value.character.length],
+ op2->value.character.string,
+ op2->value.character.length * sizeof (gfc_char_t));
result->value.character.string[len] = '\0';
return ARITH_OK;
}
+/* Comparison between real values; returns 0 if (op1 .op. op2) is true.
+ This function mimics mpr_cmp but takes NaN into account. */
+
+static int
+compare_real (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
+{
+ int rc;
+ switch (op)
+ {
+ case INTRINSIC_EQ:
+ rc = mpfr_equal_p (op1->value.real, op2->value.real) ? 0 : 1;
+ break;
+ case INTRINSIC_GT:
+ rc = mpfr_greater_p (op1->value.real, op2->value.real) ? 1 : -1;
+ break;
+ case INTRINSIC_GE:
+ rc = mpfr_greaterequal_p (op1->value.real, op2->value.real) ? 1 : -1;
+ break;
+ case INTRINSIC_LT:
+ rc = mpfr_less_p (op1->value.real, op2->value.real) ? -1 : 1;
+ break;
+ case INTRINSIC_LE:
+ rc = mpfr_lessequal_p (op1->value.real, op2->value.real) ? -1 : 1;
+ break;
+ default:
+ gfc_internal_error ("compare_real(): Bad operator");
+ }
+
+ return rc;
+}
/* Comparison operators. Assumes that the two expression nodes
- contain two constants of the same type. */
+ contain two constants of the same type. The op argument is
+ needed to handle NaN correctly. */
int
-gfc_compare_expr (gfc_expr *op1, gfc_expr *op2)
+gfc_compare_expr (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
{
int rc;
break;
case BT_REAL:
- rc = mpfr_cmp (op1->value.real, op2->value.real);
+ rc = compare_real (op1, op2, op);
break;
case BT_CHARACTER:
- rc = gfc_compare_string (op1, op2, NULL);
+ rc = gfc_compare_string (op1, op2);
break;
case BT_LOGICAL:
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);
+ return (mpfr_equal_p (op1->value.complex.r, op2->value.complex.r)
+ && mpfr_equal_p (op1->value.complex.i, op2->value.complex.i));
}
/* Given two constant strings and the inverse collating sequence, compare the
- strings. We return -1 for a < b, 0 for a == b and 1 for a > b. If the
- xcoll_table is NULL, we use the processor's default collating sequence. */
+ 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, const int *xcoll_table)
+gfc_compare_string (gfc_expr *a, gfc_expr *b)
{
- int len, alen, blen, i, ac, bc;
+ int len, alen, blen, i;
+ gfc_char_t ac, bc;
alen = a->value.character.length;
blen = b->value.character.length;
- len = (alen > blen) ? alen : blen;
+ len = MAX(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] : ' ');
+ ac = ((i < alen) ? a->value.character.string[i] : ' ');
+ bc = ((i < blen) ? b->value.character.string[i] : ' ');
- if (xcoll_table != NULL)
+ if (ac < bc)
+ return -1;
+ if (ac > bc)
+ return 1;
+ }
+
+ /* Strings are equal */
+ return 0;
+}
+
+
+int
+gfc_compare_with_Cstring (gfc_expr *a, const char *b, bool case_sensitive)
+{
+ int len, alen, blen, i;
+ gfc_char_t ac, bc;
+
+ alen = a->value.character.length;
+ blen = strlen (b);
+
+ len = MAX(alen, blen);
+
+ for (i = 0; i < len; i++)
+ {
+ ac = ((i < alen) ? a->value.character.string[i] : ' ');
+ bc = ((i < blen) ? b[i] : ' ');
+
+ if (!case_sensitive)
{
- ac = xcoll_table[ac];
- bc = xcoll_table[bc];
+ ac = TOLOWER (ac);
+ bc = TOLOWER (bc);
}
if (ac < bc)
}
/* Strings are equal */
-
return 0;
}
&op1->where);
result->value.logical = (op1->ts.type == BT_COMPLEX)
? compare_complex (op1, op2)
- : (gfc_compare_expr (op1, op2) == 0);
+ : (gfc_compare_expr (op1, op2, INTRINSIC_EQ) == 0);
*resultp = result;
return ARITH_OK;
&op1->where);
result->value.logical = (op1->ts.type == BT_COMPLEX)
? !compare_complex (op1, op2)
- : (gfc_compare_expr (op1, op2) != 0);
+ : (gfc_compare_expr (op1, op2, INTRINSIC_EQ) != 0);
*resultp = result;
return ARITH_OK;
result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
&op1->where);
- result->value.logical = (gfc_compare_expr (op1, op2) > 0);
+ result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GT) > 0);
*resultp = result;
return ARITH_OK;
result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
&op1->where);
- result->value.logical = (gfc_compare_expr (op1, op2) >= 0);
+ result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GE) >= 0);
*resultp = result;
return ARITH_OK;
result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
&op1->where);
- result->value.logical = (gfc_compare_expr (op1, op2) < 0);
+ result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_LT) < 0);
*resultp = result;
return ARITH_OK;
result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
&op1->where);
- result->value.logical = (gfc_compare_expr (op1, op2) <= 0);
+ result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_LE) <= 0);
*resultp = result;
return ARITH_OK;
for (c = head; c; c = c->next)
{
- rc = eval (c->expr, &r);
+ rc = reduce_unary (eval, c->expr, &r);
+
if (rc != ARITH_OK)
break;
for (c = head; c; c = c->next)
{
- rc = eval (c->expr, op2, &r);
+ 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;
for (c = head; c; c = c->next)
{
- rc = eval (op1, c->expr, &r);
+ 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;
}
+/* 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)
rc = ARITH_OK;
d = op2->value.constructor;
- if (gfc_check_conformance ("Elemental binary operation", op1, op2)
+ if (gfc_check_conformance ("elemental binary operation", op1, op2)
!= SUCCESS)
rc = ARITH_INCOMMENSURATE;
else
break;
}
- rc = eval (c->expr, d->expr, &r);
+ rc = reduce_binary (eval, c->expr, d->expr, &r);
if (rc != ARITH_OK)
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;
/* 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;
+
+ /* If kind mismatch, exit and we'll error out later. */
+ if (op1->ts.kind != op2->ts.kind)
+ goto runtime;
+
break;
}
if (operator == INTRINSIC_EQ || operator == INTRINSIC_NE
|| operator == INTRINSIC_GE || operator == INTRINSIC_GT
- || operator == INTRINSIC_LE || operator == INTRINSIC_LT)
+ || 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;
/* Character binary */
case INTRINSIC_CONCAT:
- if (op1->ts.type != BT_CHARACTER || op2->ts.type != BT_CHARACTER)
+ if (op1->ts.type != BT_CHARACTER || op2->ts.type != BT_CHARACTER
+ || op1->ts.kind != op2->ts.kind)
goto runtime;
temp.ts.type = BT_CHARACTER;
- temp.ts.kind = gfc_default_character_kind;
+ temp.ts.kind = op1->ts.kind;
unary = 0;
break;
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))))
+ 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->from_H
- || (op2->expr_type != EXPR_CONSTANT
- && (op2->expr_type != EXPR_ARRAY
- || !gfc_is_constant_expr (op2) || !gfc_expanded_ac (op2)))))
+ && op2->expr_type != EXPR_CONSTANT
+ && (op2->expr_type != EXPR_ARRAY
+ || !gfc_is_constant_expr (op2) || !gfc_expanded_ac (op2)))
goto runtime;
if (unary)
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;
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_uplus, op, NULL);
+ return eval_intrinsic_f2 (INTRINSIC_UPLUS, gfc_arith_identity, op, NULL);
}
gfc_expr *
-gfc_eq (gfc_expr *op1, gfc_expr *op2)
+gfc_eq (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
{
- return eval_intrinsic_f3 (INTRINSIC_EQ, gfc_arith_eq, op1, op2);
+ return eval_intrinsic_f3 (op, gfc_arith_eq, op1, op2);
}
gfc_expr *
-gfc_ne (gfc_expr *op1, gfc_expr *op2)
+gfc_ne (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
{
- return eval_intrinsic_f3 (INTRINSIC_NE, gfc_arith_ne, op1, op2);
+ return eval_intrinsic_f3 (op, gfc_arith_ne, op1, op2);
}
gfc_expr *
-gfc_gt (gfc_expr *op1, gfc_expr *op2)
+gfc_gt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
{
- return eval_intrinsic_f3 (INTRINSIC_GT, gfc_arith_gt, op1, op2);
+ return eval_intrinsic_f3 (op, gfc_arith_gt, op1, op2);
}
gfc_expr *
-gfc_ge (gfc_expr *op1, gfc_expr *op2)
+gfc_ge (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
{
- return eval_intrinsic_f3 (INTRINSIC_GE, gfc_arith_ge, op1, op2);
+ return eval_intrinsic_f3 (op, gfc_arith_ge, op1, op2);
}
gfc_expr *
-gfc_lt (gfc_expr *op1, gfc_expr *op2)
+gfc_lt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
{
- return eval_intrinsic_f3 (INTRINSIC_LT, gfc_arith_lt, op1, op2);
+ return eval_intrinsic_f3 (op, gfc_arith_lt, op1, op2);
}
gfc_expr *
-gfc_le (gfc_expr *op1, gfc_expr *op2)
+gfc_le (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
{
- return eval_intrinsic_f3 (INTRINSIC_LE, gfc_arith_le, op1, op2);
+ return eval_intrinsic_f3 (op, gfc_arith_le, op1, op2);
}
gfc_typename (from), gfc_typename (to), where);
break;
case ARITH_OVERFLOW:
- gfc_error ("Arithmetic overflow converting %s to %s at %L",
+ 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:
}
+/* 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;
- 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;
+ hollerith2representation (result, src);
+ gfc_interpret_integer (kind, (unsigned char *) result->representation.string,
+ result->representation.length, result->value.integer);
return result;
}
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;
+ hollerith2representation (result, src);
+ gfc_interpret_float (kind, (unsigned char *) result->representation.string,
+ result->representation.length, result->value.real);
return result;
}
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;
+ 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;
}
result = gfc_copy_expr (src);
result->ts.type = BT_CHARACTER;
result->ts.kind = kind;
- result->from_H = 1;
+
+ result->value.character.length = result->representation.length;
+ result->value.character.string
+ = gfc_char_to_widechar (result->representation.string);
return result;
}
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;
+ hollerith2representation (result, src);
+ gfc_interpret_logical (kind, (unsigned char *) result->representation.string,
+ result->representation.length, &result->value.logical);
return result;
}
OSDN Git Service
