/* Simplify intrinsic functions at compile-time.
- Copyright (C) 2000, 2001, 2002 Free Software Foundation, Inc.
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
+ Free Software Foundation, Inc.
Contributed by Andy Vaught & Katherine Holcomb
-This file is part of GNU G95.
+This file is part of GCC.
-GNU G95 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 free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
-GNU G95 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.
+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 GNU G95; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330,
-Boston, MA 02111-1307, USA. */
+along with GCC; see the file COPYING3. If not see
+<http://www.gnu.org/licenses/>. */
#include "config.h"
#include "system.h"
#include "flags.h"
-
-#include <string.h>
-
#include "gfortran.h"
#include "arith.h"
#include "intrinsic.h"
-
-static mpf_t mpf_zero, mpf_half, mpf_one;
-static mpz_t mpz_zero;
+#include "target-memory.h"
gfc_expr gfc_bad_expr;
everything is reasonably straight-forward. The Standard, chapter 13
is the best comment you'll find for this file anyway. */
-/* Static table for converting non-ascii character sets to ascii.
- The xascii_table[] is the inverse table. */
-
-static int ascii_table[256] = {
- '\0', '\0', '\0', '\0', '\0', '\0', '\0', '\0',
- '\b', '\t', '\n', '\v', '\0', '\r', '\0', '\0',
- '\0', '\0', '\0', '\0', '\0', '\0', '\0', '\0',
- '\0', '\0', '\0', '\0', '\0', '\0', '\0', '\0',
- ' ', '!', '\'', '#', '$', '%', '&', '\'',
- '(', ')', '*', '+', ',', '-', '.', '/',
- '0', '1', '2', '3', '4', '5', '6', '7',
- '8', '9', ':', ';', '<', '=', '>', '?',
- '@', 'A', 'B', 'C', 'D', 'E', 'F', 'G',
- 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O',
- 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W',
- 'X', 'Y', 'Z', '[', '\\', ']', '^', '_',
- '`', 'a', 'b', 'c', 'd', 'e', 'f', 'g',
- 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o',
- 'p', 'q', 'r', 's', 't', 'u', 'v', 'w',
- 'x', 'y', 'z', '{', '|', '}', '~', '\?'
-};
-
-static int xascii_table[256];
-
-
/* Range checks an expression node. If all goes well, returns the
node, otherwise returns &gfc_bad_expr and frees the node. */
static gfc_expr *
-range_check (gfc_expr * result, const char *name)
+range_check (gfc_expr *result, const char *name)
{
+ if (result == NULL)
+ return &gfc_bad_expr;
- if (gfc_range_check (result) == ARITH_OK)
- return result;
+ switch (gfc_range_check (result))
+ {
+ case ARITH_OK:
+ return result;
+
+ case ARITH_OVERFLOW:
+ gfc_error ("Result of %s overflows its kind at %L", name,
+ &result->where);
+ break;
+
+ case ARITH_UNDERFLOW:
+ gfc_error ("Result of %s underflows its kind at %L", name,
+ &result->where);
+ break;
+
+ case ARITH_NAN:
+ gfc_error ("Result of %s is NaN at %L", name, &result->where);
+ break;
+
+ default:
+ gfc_error ("Result of %s gives range error for its kind at %L", name,
+ &result->where);
+ break;
+ }
- gfc_error ("Result of %s overflows its kind at %L", name, &result->where);
gfc_free_expr (result);
return &gfc_bad_expr;
}
kind parameter. Returns the kind, -1 if something went wrong. */
static int
-get_kind (bt type, gfc_expr * k, const char *name, int default_kind)
+get_kind (bt type, gfc_expr *k, const char *name, int default_kind)
{
int kind;
{
gfc_error ("KIND parameter of %s at %L must be an initialization "
"expression", name, &k->where);
-
return -1;
}
if (gfc_extract_int (k, &kind) != NULL
- || gfc_validate_kind (type, kind) == -1)
+ || gfc_validate_kind (type, kind, true) < 0)
{
-
gfc_error ("Invalid KIND parameter of %s at %L", name, &k->where);
return -1;
}
}
+/* Helper function to get an integer constant with a kind number given
+ by an integer constant expression. */
+static gfc_expr *
+int_expr_with_kind (int i, gfc_expr *kind, const char *name)
+{
+ gfc_expr *res = gfc_int_expr (i);
+ res->ts.kind = get_kind (BT_INTEGER, kind, name, gfc_default_integer_kind);
+ if (res->ts.kind == -1)
+ return NULL;
+ else
+ return res;
+}
+
+
+/* Converts an mpz_t signed variable into an unsigned one, assuming
+ two's complement representations and a binary width of bitsize.
+ The conversion is a no-op unless x is negative; otherwise, it can
+ be accomplished by masking out the high bits. */
+
+static void
+convert_mpz_to_unsigned (mpz_t x, int bitsize)
+{
+ mpz_t mask;
+
+ if (mpz_sgn (x) < 0)
+ {
+ /* Confirm that no bits above the signed range are unset. */
+ gcc_assert (mpz_scan0 (x, bitsize-1) == ULONG_MAX);
+
+ mpz_init_set_ui (mask, 1);
+ mpz_mul_2exp (mask, mask, bitsize);
+ mpz_sub_ui (mask, mask, 1);
+
+ mpz_and (x, x, mask);
+
+ mpz_clear (mask);
+ }
+ else
+ {
+ /* Confirm that no bits above the signed range are set. */
+ gcc_assert (mpz_scan1 (x, bitsize-1) == ULONG_MAX);
+ }
+}
+
+
+/* Converts an mpz_t unsigned variable into a signed one, assuming
+ two's complement representations and a binary width of bitsize.
+ If the bitsize-1 bit is set, this is taken as a sign bit and
+ the number is converted to the corresponding negative number. */
+
+static void
+convert_mpz_to_signed (mpz_t x, int bitsize)
+{
+ mpz_t mask;
+
+ /* Confirm that no bits above the unsigned range are set. */
+ gcc_assert (mpz_scan1 (x, bitsize) == ULONG_MAX);
+
+ if (mpz_tstbit (x, bitsize - 1) == 1)
+ {
+ mpz_init_set_ui (mask, 1);
+ mpz_mul_2exp (mask, mask, bitsize);
+ mpz_sub_ui (mask, mask, 1);
+
+ /* We negate the number by hand, zeroing the high bits, that is
+ make it the corresponding positive number, and then have it
+ negated by GMP, giving the correct representation of the
+ negative number. */
+ mpz_com (x, x);
+ mpz_add_ui (x, x, 1);
+ mpz_and (x, x, mask);
+
+ mpz_neg (x, x);
+
+ mpz_clear (mask);
+ }
+}
+
+
/********************** Simplification functions *****************************/
gfc_expr *
-gfc_simplify_abs (gfc_expr * e)
+gfc_simplify_abs (gfc_expr *e)
{
gfc_expr *result;
- mpf_t a, b;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
case BT_REAL:
result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
- mpf_abs (result->value.real, e->value.real);
+ mpfr_abs (result->value.real, e->value.real, GFC_RND_MODE);
result = range_check (result, "ABS");
break;
case BT_COMPLEX:
result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
- mpf_init (a);
- mpf_mul (a, e->value.complex.r, e->value.complex.r);
-
- mpf_init (b);
- mpf_mul (b, e->value.complex.i, e->value.complex.i);
-
- mpf_add (a, a, b);
- mpf_sqrt (result->value.real, a);
-
- mpf_clear (a);
- mpf_clear (b);
+ gfc_set_model_kind (e->ts.kind);
+ mpfr_hypot (result->value.real, e->value.complex.r,
+ e->value.complex.i, GFC_RND_MODE);
result = range_check (result, "CABS");
break;
return result;
}
+/* We use the processor's collating sequence, because all
+ systems that gfortran currently works on are ASCII. */
gfc_expr *
-gfc_simplify_achar (gfc_expr * e)
+gfc_simplify_achar (gfc_expr *e, gfc_expr *k)
{
gfc_expr *result;
- int index;
+ int c, kind;
+ const char *ch;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- /* We cannot assume that the native character set is ASCII in this
- function. */
- if (gfc_extract_int (e, &index) != NULL || index < 0 || index > 127)
- {
- gfc_error ("Extended ASCII not implemented: argument of ACHAR at %L "
- "must be between 0 and 127", &e->where);
- return &gfc_bad_expr;
- }
+ kind = get_kind (BT_CHARACTER, k, "ACHAR", gfc_default_character_kind);
+ if (kind == -1)
+ return &gfc_bad_expr;
- result = gfc_constant_result (BT_CHARACTER, gfc_default_character_kind (),
- &e->where);
+ ch = gfc_extract_int (e, &c);
+
+ if (ch != NULL)
+ gfc_internal_error ("gfc_simplify_achar: %s", ch);
+
+ if (gfc_option.warn_surprising && (c < 0 || c > 127))
+ gfc_warning ("Argument of ACHAR function at %L outside of range [0,127]",
+ &e->where);
+
+ result = gfc_constant_result (BT_CHARACTER, kind, &e->where);
result->value.character.string = gfc_getmem (2);
result->value.character.length = 1;
- result->value.character.string[0] = ascii_table[index];
+ result->value.character.string[0] = c;
result->value.character.string[1] = '\0'; /* For debugger */
return result;
}
gfc_expr *
-gfc_simplify_acos (gfc_expr * x)
+gfc_simplify_acos (gfc_expr *x)
{
gfc_expr *result;
- mpf_t negative, square, term;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- if (mpf_cmp_si (x->value.real, 1) > 0 || mpf_cmp_si (x->value.real, -1) < 0)
+ if (mpfr_cmp_si (x->value.real, 1) > 0
+ || mpfr_cmp_si (x->value.real, -1) < 0)
{
gfc_error ("Argument of ACOS at %L must be between -1 and 1",
&x->where);
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
- if (mpf_cmp_si (x->value.real, 1) == 0)
- {
- mpf_set_ui (result->value.real, 0);
- return range_check (result, "ACOS");
- }
+ mpfr_acos (result->value.real, x->value.real, GFC_RND_MODE);
+
+ return range_check (result, "ACOS");
+}
+
+gfc_expr *
+gfc_simplify_acosh (gfc_expr *x)
+{
+ gfc_expr *result;
- if (mpf_cmp_si (x->value.real, -1) == 0)
+ if (x->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ if (mpfr_cmp_si (x->value.real, 1) < 0)
{
- mpf_set (result->value.real, pi);
- return range_check (result, "ACOS");
+ gfc_error ("Argument of ACOSH at %L must not be less than 1",
+ &x->where);
+ return &gfc_bad_expr;
}
- mpf_init (negative);
- mpf_init (square);
- mpf_init (term);
-
- mpf_pow_ui (square, x->value.real, 2);
- mpf_ui_sub (term, 1, square);
- mpf_sqrt (term, term);
- mpf_div (term, x->value.real, term);
- mpf_neg (term, term);
- arctangent (&term, &negative);
- mpf_add (result->value.real, half_pi, negative);
+ result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
- mpf_clear (negative);
- mpf_clear (square);
- mpf_clear (term);
+ mpfr_acosh (result->value.real, x->value.real, GFC_RND_MODE);
- return range_check (result, "ACOS");
+ return range_check (result, "ACOSH");
}
-
gfc_expr *
-gfc_simplify_adjustl (gfc_expr * e)
+gfc_simplify_adjustl (gfc_expr *e)
{
gfc_expr *result;
int count, i, len;
}
for (i = 0; i < len - count; ++i)
- {
- result->value.character.string[i] =
- e->value.character.string[count + i];
- }
+ result->value.character.string[i] = e->value.character.string[count + i];
for (i = len - count; i < len; ++i)
- {
- result->value.character.string[i] = ' ';
- }
+ result->value.character.string[i] = ' ';
result->value.character.string[len] = '\0'; /* For debugger */
gfc_expr *
-gfc_simplify_adjustr (gfc_expr * e)
+gfc_simplify_adjustr (gfc_expr *e)
{
gfc_expr *result;
int count, i, len;
}
for (i = 0; i < count; ++i)
- {
- result->value.character.string[i] = ' ';
- }
+ result->value.character.string[i] = ' ';
for (i = count; i < len; ++i)
- {
- result->value.character.string[i] =
- e->value.character.string[i - count];
- }
+ result->value.character.string[i] = e->value.character.string[i - count];
result->value.character.string[len] = '\0'; /* For debugger */
gfc_expr *
-gfc_simplify_aimag (gfc_expr * e)
+gfc_simplify_aimag (gfc_expr *e)
{
gfc_expr *result;
return NULL;
result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
- mpf_set (result->value.real, e->value.complex.i);
+ mpfr_set (result->value.real, e->value.complex.i, GFC_RND_MODE);
return range_check (result, "AIMAG");
}
gfc_expr *
-gfc_simplify_aint (gfc_expr * e, gfc_expr * k)
+gfc_simplify_aint (gfc_expr *e, gfc_expr *k)
{
gfc_expr *rtrunc, *result;
int kind;
rtrunc = gfc_copy_expr (e);
- mpf_trunc (rtrunc->value.real, e->value.real);
+ mpfr_trunc (rtrunc->value.real, e->value.real);
result = gfc_real2real (rtrunc, kind);
gfc_free_expr (rtrunc);
gfc_expr *
-gfc_simplify_dint (gfc_expr * e)
+gfc_simplify_dint (gfc_expr *e)
{
gfc_expr *rtrunc, *result;
rtrunc = gfc_copy_expr (e);
- mpf_trunc (rtrunc->value.real, e->value.real);
+ mpfr_trunc (rtrunc->value.real, e->value.real);
- result = gfc_real2real (rtrunc, gfc_default_double_kind ());
+ result = gfc_real2real (rtrunc, gfc_default_double_kind);
gfc_free_expr (rtrunc);
return range_check (result, "DINT");
-
}
gfc_expr *
-gfc_simplify_anint (gfc_expr * e, gfc_expr * k)
+gfc_simplify_anint (gfc_expr *e, gfc_expr *k)
{
- gfc_expr *rtrunc, *result;
- int kind, cmp;
+ gfc_expr *result;
+ int kind;
kind = get_kind (BT_REAL, k, "ANINT", e->ts.kind);
if (kind == -1)
result = gfc_constant_result (e->ts.type, kind, &e->where);
- rtrunc = gfc_copy_expr (e);
+ mpfr_round (result->value.real, e->value.real);
+
+ return range_check (result, "ANINT");
+}
+
+
+gfc_expr *
+gfc_simplify_and (gfc_expr *x, gfc_expr *y)
+{
+ gfc_expr *result;
+ int kind;
- cmp = mpf_cmp_ui (e->value.real, 0);
+ if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
+ return NULL;
- if (cmp > 0)
+ kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
+ if (x->ts.type == BT_INTEGER)
{
- mpf_add (rtrunc->value.real, e->value.real, mpf_half);
- mpf_trunc (result->value.real, rtrunc->value.real);
+ result = gfc_constant_result (BT_INTEGER, kind, &x->where);
+ mpz_and (result->value.integer, x->value.integer, y->value.integer);
}
- else if (cmp < 0)
+ else /* BT_LOGICAL */
{
- mpf_sub (rtrunc->value.real, e->value.real, mpf_half);
- mpf_trunc (result->value.real, rtrunc->value.real);
+ result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
+ result->value.logical = x->value.logical && y->value.logical;
}
- else
- mpf_set_ui (result->value.real, 0);
-
- gfc_free_expr (rtrunc);
- return range_check (result, "ANINT");
+ return range_check (result, "AND");
}
gfc_expr *
-gfc_simplify_dnint (gfc_expr * e)
+gfc_simplify_dnint (gfc_expr *e)
{
- gfc_expr *rtrunc, *result;
- int cmp;
+ gfc_expr *result;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- result =
- gfc_constant_result (BT_REAL, gfc_default_double_kind (), &e->where);
-
- rtrunc = gfc_copy_expr (e);
-
- cmp = mpf_cmp_ui (e->value.real, 0);
-
- if (cmp > 0)
- {
- mpf_add (rtrunc->value.real, e->value.real, mpf_half);
- mpf_trunc (result->value.real, rtrunc->value.real);
- }
- else if (cmp < 0)
- {
- mpf_sub (rtrunc->value.real, e->value.real, mpf_half);
- mpf_trunc (result->value.real, rtrunc->value.real);
- }
- else
- mpf_set_ui (result->value.real, 0);
+ result = gfc_constant_result (BT_REAL, gfc_default_double_kind, &e->where);
- gfc_free_expr (rtrunc);
+ mpfr_round (result->value.real, e->value.real);
return range_check (result, "DNINT");
}
gfc_expr *
-gfc_simplify_asin (gfc_expr * x)
+gfc_simplify_asin (gfc_expr *x)
{
gfc_expr *result;
- mpf_t negative, square, term;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- if (mpf_cmp_si (x->value.real, 1) > 0 || mpf_cmp_si (x->value.real, -1) < 0)
+ if (mpfr_cmp_si (x->value.real, 1) > 0
+ || mpfr_cmp_si (x->value.real, -1) < 0)
{
gfc_error ("Argument of ASIN at %L must be between -1 and 1",
&x->where);
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
- if (mpf_cmp_si (x->value.real, 1) == 0)
- {
- mpf_set (result->value.real, half_pi);
- return range_check (result, "ASIN");
- }
+ mpfr_asin (result->value.real, x->value.real, GFC_RND_MODE);
+
+ return range_check (result, "ASIN");
+}
- if (mpf_cmp_si (x->value.real, -1) == 0)
- {
- mpf_init (negative);
- mpf_neg (negative, half_pi);
- mpf_set (result->value.real, negative);
- mpf_clear (negative);
- return range_check (result, "ASIN");
- }
- mpf_init (square);
- mpf_init (term);
+gfc_expr *
+gfc_simplify_asinh (gfc_expr *x)
+{
+ gfc_expr *result;
+
+ if (x->expr_type != EXPR_CONSTANT)
+ return NULL;
- mpf_pow_ui (square, x->value.real, 2);
- mpf_ui_sub (term, 1, square);
- mpf_sqrt (term, term);
- mpf_div (term, x->value.real, term);
- arctangent (&term, &result->value.real);
+ result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
- mpf_clear (square);
- mpf_clear (term);
+ mpfr_asinh (result->value.real, x->value.real, GFC_RND_MODE);
- return range_check (result, "ASIN");
+ return range_check (result, "ASINH");
}
gfc_expr *
-gfc_simplify_atan (gfc_expr * x)
+gfc_simplify_atan (gfc_expr *x)
{
gfc_expr *result;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
-
+
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
- arctangent (&x->value.real, &result->value.real);
+ mpfr_atan (result->value.real, x->value.real, GFC_RND_MODE);
return range_check (result, "ATAN");
+}
+
+
+gfc_expr *
+gfc_simplify_atanh (gfc_expr *x)
+{
+ gfc_expr *result;
+
+ if (x->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ if (mpfr_cmp_si (x->value.real, 1) >= 0
+ || mpfr_cmp_si (x->value.real, -1) <= 0)
+ {
+ gfc_error ("Argument of ATANH at %L must be inside the range -1 to 1",
+ &x->where);
+ return &gfc_bad_expr;
+ }
+
+ result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+
+ mpfr_atanh (result->value.real, x->value.real, GFC_RND_MODE);
+ return range_check (result, "ATANH");
}
gfc_expr *
-gfc_simplify_atan2 (gfc_expr * y, gfc_expr * x)
+gfc_simplify_atan2 (gfc_expr *y, gfc_expr *x)
{
gfc_expr *result;
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
-
- if (mpf_sgn (y->value.real) == 0 && mpf_sgn (x->value.real) == 0)
+ if (mpfr_sgn (y->value.real) == 0 && mpfr_sgn (x->value.real) == 0)
{
- gfc_error
- ("If first argument of ATAN2 %L is zero, the second argument "
- "must not be zero", &x->where);
+ gfc_error ("If first argument of ATAN2 %L is zero, then the "
+ "second argument must not be zero", &x->where);
gfc_free_expr (result);
return &gfc_bad_expr;
}
- arctangent2 (&y->value.real, &x->value.real, &result->value.real);
+ mpfr_atan2 (result->value.real, y->value.real, x->value.real, GFC_RND_MODE);
return range_check (result, "ATAN2");
-
}
gfc_expr *
-gfc_simplify_bit_size (gfc_expr * e)
+gfc_simplify_bit_size (gfc_expr *e)
{
gfc_expr *result;
int i;
- i = gfc_validate_kind (e->ts.type, e->ts.kind);
- if (i == -1)
- gfc_internal_error ("In gfc_simplify_bit_size(): Bad kind");
-
+ i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
result = gfc_constant_result (BT_INTEGER, e->ts.kind, &e->where);
mpz_set_ui (result->value.integer, gfc_integer_kinds[i].bit_size);
gfc_expr *
-gfc_simplify_btest (gfc_expr * e, gfc_expr * bit)
+gfc_simplify_btest (gfc_expr *e, gfc_expr *bit)
{
int b;
gfc_expr *
-gfc_simplify_ceiling (gfc_expr * e, gfc_expr * k)
+gfc_simplify_ceiling (gfc_expr *e, gfc_expr *k)
{
gfc_expr *ceil, *result;
int kind;
- kind = get_kind (BT_REAL, k, "CEILING", gfc_default_real_kind ());
+ kind = get_kind (BT_INTEGER, k, "CEILING", gfc_default_integer_kind);
if (kind == -1)
return &gfc_bad_expr;
ceil = gfc_copy_expr (e);
- mpf_ceil (ceil->value.real, e->value.real);
- mpz_set_f (result->value.integer, ceil->value.real);
+ mpfr_ceil (ceil->value.real, e->value.real);
+ gfc_mpfr_to_mpz (result->value.integer, ceil->value.real);
gfc_free_expr (ceil);
gfc_expr *
-gfc_simplify_char (gfc_expr * e, gfc_expr * k)
+gfc_simplify_char (gfc_expr *e, gfc_expr *k)
{
gfc_expr *result;
int c, kind;
+ const char *ch;
- kind = get_kind (BT_CHARACTER, k, "CHAR", gfc_default_character_kind ());
+ kind = get_kind (BT_CHARACTER, k, "CHAR", gfc_default_character_kind);
if (kind == -1)
return &gfc_bad_expr;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- if (gfc_extract_int (e, &c) != NULL || c < 0 || c > 255)
- {
- gfc_error ("Bad character in CHAR function at %L", &e->where);
- return &gfc_bad_expr;
- }
+ ch = gfc_extract_int (e, &c);
+
+ if (ch != NULL)
+ gfc_internal_error ("gfc_simplify_char: %s", ch);
+
+ if (c < 0 || c > UCHAR_MAX)
+ gfc_error ("Argument of CHAR function at %L outside of range [0,255]",
+ &e->where);
result = gfc_constant_result (BT_CHARACTER, kind, &e->where);
/* Common subroutine for simplifying CMPLX and DCMPLX. */
static gfc_expr *
-simplify_cmplx (const char *name, gfc_expr * x, gfc_expr * y, int kind)
+simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind)
{
gfc_expr *result;
result = gfc_constant_result (BT_COMPLEX, kind, &x->where);
- mpf_set_ui (result->value.complex.i, 0);
+ mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
switch (x->ts.type)
{
case BT_INTEGER:
- mpf_set_z (result->value.complex.r, x->value.integer);
+ if (!x->is_boz)
+ mpfr_set_z (result->value.complex.r, x->value.integer, GFC_RND_MODE);
break;
case BT_REAL:
- mpf_set (result->value.complex.r, x->value.real);
+ mpfr_set (result->value.complex.r, x->value.real, GFC_RND_MODE);
break;
case BT_COMPLEX:
- mpf_set (result->value.complex.r, x->value.complex.r);
- mpf_set (result->value.complex.i, x->value.complex.i);
+ mpfr_set (result->value.complex.r, x->value.complex.r, GFC_RND_MODE);
+ mpfr_set (result->value.complex.i, x->value.complex.i, GFC_RND_MODE);
break;
default:
switch (y->ts.type)
{
case BT_INTEGER:
- mpf_set_z (result->value.complex.i, y->value.integer);
+ if (!y->is_boz)
+ mpfr_set_z (result->value.complex.i, y->value.integer, GFC_RND_MODE);
break;
case BT_REAL:
- mpf_set (result->value.complex.i, y->value.real);
+ mpfr_set (result->value.complex.i, y->value.real, GFC_RND_MODE);
break;
default:
}
}
+ /* Handle BOZ. */
+ if (x->is_boz)
+ {
+ gfc_typespec ts;
+ gfc_clear_ts (&ts);
+ ts.kind = result->ts.kind;
+ ts.type = BT_REAL;
+ if (!gfc_convert_boz (x, &ts))
+ return &gfc_bad_expr;
+ mpfr_set (result->value.complex.r, x->value.real, GFC_RND_MODE);
+ }
+
+ if (y && y->is_boz)
+ {
+ gfc_typespec ts;
+ gfc_clear_ts (&ts);
+ ts.kind = result->ts.kind;
+ ts.type = BT_REAL;
+ if (!gfc_convert_boz (y, &ts))
+ return &gfc_bad_expr;
+ mpfr_set (result->value.complex.i, y->value.real, GFC_RND_MODE);
+ }
+
return range_check (result, name);
}
gfc_expr *
-gfc_simplify_cmplx (gfc_expr * x, gfc_expr * y, gfc_expr * k)
+gfc_simplify_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *k)
{
int kind;
|| (y != NULL && y->expr_type != EXPR_CONSTANT))
return NULL;
- kind = get_kind (BT_REAL, k, "CMPLX", gfc_default_real_kind ());
+ kind = get_kind (BT_REAL, k, "CMPLX", gfc_default_real_kind);
if (kind == -1)
return &gfc_bad_expr;
gfc_expr *
-gfc_simplify_conjg (gfc_expr * e)
+gfc_simplify_complex (gfc_expr *x, gfc_expr *y)
+{
+ int kind;
+
+ if (x->expr_type != EXPR_CONSTANT
+ || (y != NULL && y->expr_type != EXPR_CONSTANT))
+ return NULL;
+
+ if (x->ts.type == BT_INTEGER)
+ {
+ if (y->ts.type == BT_INTEGER)
+ kind = gfc_default_real_kind;
+ else
+ kind = y->ts.kind;
+ }
+ else
+ {
+ if (y->ts.type == BT_REAL)
+ kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind;
+ else
+ kind = x->ts.kind;
+ }
+
+ return simplify_cmplx ("COMPLEX", x, y, kind);
+}
+
+
+gfc_expr *
+gfc_simplify_conjg (gfc_expr *e)
{
gfc_expr *result;
return NULL;
result = gfc_copy_expr (e);
- mpf_neg (result->value.complex.i, result->value.complex.i);
+ mpfr_neg (result->value.complex.i, result->value.complex.i, GFC_RND_MODE);
return range_check (result, "CONJG");
}
gfc_expr *
-gfc_simplify_cos (gfc_expr * x)
+gfc_simplify_cos (gfc_expr *x)
{
gfc_expr *result;
- mpf_t xp, xq;
+ mpfr_t xp, xq;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
switch (x->ts.type)
{
case BT_REAL:
- cosine (&x->value.real, &result->value.real);
+ mpfr_cos (result->value.real, x->value.real, GFC_RND_MODE);
break;
case BT_COMPLEX:
- mpf_init (xp);
- mpf_init (xq);
+ gfc_set_model_kind (x->ts.kind);
+ mpfr_init (xp);
+ mpfr_init (xq);
- cosine (&x->value.complex.r, &xp);
- hypercos (&x->value.complex.i, &xq);
- mpf_mul (result->value.complex.r, xp, xq);
+ mpfr_cos (xp, x->value.complex.r, GFC_RND_MODE);
+ mpfr_cosh (xq, x->value.complex.i, GFC_RND_MODE);
+ mpfr_mul (result->value.complex.r, xp, xq, GFC_RND_MODE);
- sine (&x->value.complex.r, &xp);
- hypersine (&x->value.complex.i, &xq);
- mpf_mul (xp, xp, xq);
- mpf_neg (result->value.complex.i, xp);
+ mpfr_sin (xp, x->value.complex.r, GFC_RND_MODE);
+ mpfr_sinh (xq, x->value.complex.i, GFC_RND_MODE);
+ mpfr_mul (xp, xp, xq, GFC_RND_MODE);
+ mpfr_neg (result->value.complex.i, xp, GFC_RND_MODE );
- mpf_clear (xp);
- mpf_clear (xq);
+ mpfr_clear (xp);
+ mpfr_clear (xq);
break;
default:
gfc_internal_error ("in gfc_simplify_cos(): Bad type");
gfc_expr *
-gfc_simplify_cosh (gfc_expr * x)
+gfc_simplify_cosh (gfc_expr *x)
{
gfc_expr *result;
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
- hypercos (&x->value.real, &result->value.real);
+ mpfr_cosh (result->value.real, x->value.real, GFC_RND_MODE);
return range_check (result, "COSH");
}
gfc_expr *
-gfc_simplify_dcmplx (gfc_expr * x, gfc_expr * y)
+gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y)
{
if (x->expr_type != EXPR_CONSTANT
|| (y != NULL && y->expr_type != EXPR_CONSTANT))
return NULL;
- return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind ());
+ return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind);
}
gfc_expr *
-gfc_simplify_dble (gfc_expr * e)
+gfc_simplify_dble (gfc_expr *e)
{
gfc_expr *result;
switch (e->ts.type)
{
case BT_INTEGER:
- result = gfc_int2real (e, gfc_default_double_kind ());
+ if (!e->is_boz)
+ result = gfc_int2real (e, gfc_default_double_kind);
break;
case BT_REAL:
- result = gfc_real2real (e, gfc_default_double_kind ());
+ result = gfc_real2real (e, gfc_default_double_kind);
break;
case BT_COMPLEX:
- result = gfc_complex2real (e, gfc_default_double_kind ());
+ result = gfc_complex2real (e, gfc_default_double_kind);
break;
default:
gfc_internal_error ("gfc_simplify_dble(): bad type at %L", &e->where);
}
+ if (e->ts.type == BT_INTEGER && e->is_boz)
+ {
+ gfc_typespec ts;
+ gfc_clear_ts (&ts);
+ ts.type = BT_REAL;
+ ts.kind = gfc_default_double_kind;
+ result = gfc_copy_expr (e);
+ if (!gfc_convert_boz (result, &ts))
+ return &gfc_bad_expr;
+ }
+
return range_check (result, "DBLE");
}
gfc_expr *
-gfc_simplify_digits (gfc_expr * x)
+gfc_simplify_digits (gfc_expr *x)
{
int i, digits;
- i = gfc_validate_kind (x->ts.type, x->ts.kind);
- if (i == -1)
- goto bad;
-
+ i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
switch (x->ts.type)
{
case BT_INTEGER:
break;
default:
- bad:
- gfc_internal_error ("gfc_simplify_digits(): Bad type");
+ gcc_unreachable ();
}
return gfc_int_expr (digits);
gfc_expr *
-gfc_simplify_dim (gfc_expr * x, gfc_expr * y)
+gfc_simplify_dim (gfc_expr *x, gfc_expr *y)
{
gfc_expr *result;
+ int kind;
if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
+ result = gfc_constant_result (x->ts.type, kind, &x->where);
switch (x->ts.type)
{
if (mpz_cmp (x->value.integer, y->value.integer) > 0)
mpz_sub (result->value.integer, x->value.integer, y->value.integer);
else
- mpz_set (result->value.integer, mpz_zero);
+ mpz_set_ui (result->value.integer, 0);
break;
case BT_REAL:
- if (mpf_cmp (x->value.real, y->value.real) > 0)
- mpf_sub (result->value.real, x->value.real, y->value.real);
+ if (mpfr_cmp (x->value.real, y->value.real) > 0)
+ mpfr_sub (result->value.real, x->value.real, y->value.real,
+ GFC_RND_MODE);
else
- mpf_set (result->value.real, mpf_zero);
+ mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
break;
gfc_expr *
-gfc_simplify_dprod (gfc_expr * x, gfc_expr * y)
+gfc_simplify_dprod (gfc_expr *x, gfc_expr *y)
{
- gfc_expr *mult1, *mult2, *result;
+ gfc_expr *a1, *a2, *result;
if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
return NULL;
- result =
- gfc_constant_result (BT_REAL, gfc_default_double_kind (), &x->where);
+ result = gfc_constant_result (BT_REAL, gfc_default_double_kind, &x->where);
- mult1 = gfc_real2real (x, gfc_default_double_kind ());
- mult2 = gfc_real2real (y, gfc_default_double_kind ());
+ a1 = gfc_real2real (x, gfc_default_double_kind);
+ a2 = gfc_real2real (y, gfc_default_double_kind);
- mpf_mul (result->value.real, mult1->value.real, mult2->value.real);
+ mpfr_mul (result->value.real, a1->value.real, a2->value.real, GFC_RND_MODE);
- gfc_free_expr (mult1);
- gfc_free_expr (mult2);
+ gfc_free_expr (a1);
+ gfc_free_expr (a2);
return range_check (result, "DPROD");
}
gfc_expr *
-gfc_simplify_epsilon (gfc_expr * e)
+gfc_simplify_erf (gfc_expr *x)
+{
+ gfc_expr *result;
+
+ if (x->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+
+ mpfr_erf (result->value.real, x->value.real, GFC_RND_MODE);
+
+ return range_check (result, "ERF");
+}
+
+
+gfc_expr *
+gfc_simplify_erfc (gfc_expr *x)
+{
+ gfc_expr *result;
+
+ if (x->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+
+ mpfr_erfc (result->value.real, x->value.real, GFC_RND_MODE);
+
+ return range_check (result, "ERFC");
+}
+
+
+gfc_expr *
+gfc_simplify_epsilon (gfc_expr *e)
{
gfc_expr *result;
int i;
- i = gfc_validate_kind (e->ts.type, e->ts.kind);
- if (i == -1)
- gfc_internal_error ("gfc_simplify_epsilon(): Bad kind");
+ i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
- mpf_set (result->value.real, gfc_real_kinds[i].epsilon);
+ mpfr_set (result->value.real, gfc_real_kinds[i].epsilon, GFC_RND_MODE);
return range_check (result, "EPSILON");
}
gfc_expr *
-gfc_simplify_exp (gfc_expr * x)
+gfc_simplify_exp (gfc_expr *x)
{
gfc_expr *result;
- mpf_t xp, xq;
- double ln2, absval, rhuge;
+ mpfr_t xp, xq;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
- /* Exactitude doesn't matter here */
- ln2 = .6931472;
- rhuge = ln2 * mpz_get_d (gfc_integer_kinds[0].huge);
-
switch (x->ts.type)
{
case BT_REAL:
- absval = mpf_get_d (x->value.real);
- if (absval < 0)
- absval = -absval;
- if (absval > rhuge)
- {
- /* Underflow (set arg to zero) if x is negative and its
- magnitude is greater than the maximum C long int times
- ln2, because the exponential method in arith.c will fail
- for such values. */
- if (mpf_cmp_ui (x->value.real, 0) < 0)
- {
- if (pedantic == 1)
- gfc_warning_now
- ("Argument of EXP at %L is negative and too large, "
- "setting result to zero", &x->where);
- mpf_set_ui (result->value.real, 0);
- return range_check (result, "EXP");
- }
- /* Overflow if magnitude of x is greater than C long int
- huge times ln2. */
- else
- {
- gfc_error ("Argument of EXP at %L too large", &x->where);
- gfc_free_expr (result);
- return &gfc_bad_expr;
- }
- }
- exponential (&x->value.real, &result->value.real);
+ mpfr_exp (result->value.real, x->value.real, GFC_RND_MODE);
break;
case BT_COMPLEX:
- /* Using Euler's formula. */
- absval = mpf_get_d (x->value.complex.r);
- if (absval < 0)
- absval = -absval;
- if (absval > rhuge)
- {
- if (mpf_cmp_ui (x->value.complex.r, 0) < 0)
- {
- if (pedantic == 1)
- gfc_warning_now
- ("Real part of argument of EXP at %L is negative "
- "and too large, setting result to zero", &x->where);
-
- mpf_set_ui (result->value.complex.r, 0);
- mpf_set_ui (result->value.complex.i, 0);
- return range_check (result, "EXP");
- }
- else
- {
- gfc_error ("Real part of argument of EXP at %L too large",
- &x->where);
- gfc_free_expr (result);
- return &gfc_bad_expr;
- }
- }
- mpf_init (xp);
- mpf_init (xq);
- exponential (&x->value.complex.r, &xq);
- cosine (&x->value.complex.i, &xp);
- mpf_mul (result->value.complex.r, xq, xp);
- sine (&x->value.complex.i, &xp);
- mpf_mul (result->value.complex.i, xq, xp);
- mpf_clear (xp);
- mpf_clear (xq);
+ gfc_set_model_kind (x->ts.kind);
+ mpfr_init (xp);
+ mpfr_init (xq);
+ mpfr_exp (xq, x->value.complex.r, GFC_RND_MODE);
+ mpfr_cos (xp, x->value.complex.i, GFC_RND_MODE);
+ mpfr_mul (result->value.complex.r, xq, xp, GFC_RND_MODE);
+ mpfr_sin (xp, x->value.complex.i, GFC_RND_MODE);
+ mpfr_mul (result->value.complex.i, xq, xp, GFC_RND_MODE);
+ mpfr_clear (xp);
+ mpfr_clear (xq);
break;
default:
return range_check (result, "EXP");
}
-
gfc_expr *
-gfc_simplify_exponent (gfc_expr * x)
+gfc_simplify_exponent (gfc_expr *x)
{
- mpf_t i2, absv, ln2, lnx;
+ int i;
gfc_expr *result;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind (),
+ result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
&x->where);
- if (mpf_cmp (x->value.real, mpf_zero) == 0)
+ gfc_set_model (x->value.real);
+
+ if (mpfr_sgn (x->value.real) == 0)
{
mpz_set_ui (result->value.integer, 0);
return result;
}
- mpf_init_set_ui (i2, 2);
- mpf_init (absv);
- mpf_init (ln2);
- mpf_init (lnx);
-
- natural_logarithm (&i2, &ln2);
-
- mpf_abs (absv, x->value.real);
- natural_logarithm (&absv, &lnx);
-
- mpf_div (lnx, lnx, ln2);
- mpf_trunc (lnx, lnx);
- mpf_add_ui (lnx, lnx, 1);
- mpz_set_f (result->value.integer, lnx);
-
- mpf_clear (i2);
- mpf_clear (ln2);
- mpf_clear (lnx);
- mpf_clear (absv);
+ i = (int) mpfr_get_exp (x->value.real);
+ mpz_set_si (result->value.integer, i);
return range_check (result, "EXPONENT");
}
gfc_expr *
-gfc_simplify_float (gfc_expr * a)
+gfc_simplify_float (gfc_expr *a)
{
gfc_expr *result;
if (a->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_int2real (a, gfc_default_real_kind ());
- return range_check (result, "FLOAT");
-}
+ if (a->is_boz)
+ {
+ gfc_typespec ts;
+ gfc_clear_ts (&ts);
+
+ ts.type = BT_REAL;
+ ts.kind = gfc_default_real_kind;
+
+ result = gfc_copy_expr (a);
+ if (!gfc_convert_boz (result, &ts))
+ return &gfc_bad_expr;
+ }
+ else
+ result = gfc_int2real (a, gfc_default_real_kind);
+ return range_check (result, "FLOAT");
+}
gfc_expr *
-gfc_simplify_floor (gfc_expr * e, gfc_expr * k)
+gfc_simplify_floor (gfc_expr *e, gfc_expr *k)
{
gfc_expr *result;
- mpf_t floor;
+ mpfr_t floor;
int kind;
- kind = get_kind (BT_REAL, k, "FLOOR", gfc_default_real_kind ());
+ kind = get_kind (BT_INTEGER, k, "FLOOR", gfc_default_integer_kind);
if (kind == -1)
gfc_internal_error ("gfc_simplify_floor(): Bad kind");
result = gfc_constant_result (BT_INTEGER, kind, &e->where);
- mpf_init (floor);
- mpf_floor (floor, e->value.real);
- mpz_set_f (result->value.integer, floor);
- mpf_clear (floor);
+ gfc_set_model_kind (kind);
+ mpfr_init (floor);
+ mpfr_floor (floor, e->value.real);
+
+ gfc_mpfr_to_mpz (result->value.integer, floor);
+
+ mpfr_clear (floor);
return range_check (result, "FLOOR");
}
gfc_expr *
-gfc_simplify_fraction (gfc_expr * x)
+gfc_simplify_fraction (gfc_expr *x)
{
gfc_expr *result;
- mpf_t i2, absv, ln2, lnx, pow2;
- unsigned long exp2;
+ mpfr_t absv, exp, pow2;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
- if (mpf_cmp (x->value.real, mpf_zero) == 0)
+ gfc_set_model_kind (x->ts.kind);
+
+ if (mpfr_sgn (x->value.real) == 0)
{
- mpf_set (result->value.real, mpf_zero);
+ mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
return result;
}
- mpf_init_set_ui (i2, 2);
- mpf_init (absv);
- mpf_init (ln2);
- mpf_init (lnx);
- mpf_init (pow2);
+ mpfr_init (exp);
+ mpfr_init (absv);
+ mpfr_init (pow2);
- natural_logarithm (&i2, &ln2);
+ mpfr_abs (absv, x->value.real, GFC_RND_MODE);
+ mpfr_log2 (exp, absv, GFC_RND_MODE);
- mpf_abs (absv, x->value.real);
- natural_logarithm (&absv, &lnx);
+ mpfr_trunc (exp, exp);
+ mpfr_add_ui (exp, exp, 1, GFC_RND_MODE);
- mpf_div (lnx, lnx, ln2);
- mpf_trunc (lnx, lnx);
- mpf_add_ui (lnx, lnx, 1);
+ mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
- exp2 = (unsigned long) mpf_get_d (lnx);
- mpf_pow_ui (pow2, i2, exp2);
+ mpfr_div (result->value.real, absv, pow2, GFC_RND_MODE);
- mpf_div (result->value.real, absv, pow2);
-
- mpf_clear (i2);
- mpf_clear (ln2);
- mpf_clear (absv);
- mpf_clear (lnx);
- mpf_clear (pow2);
+ mpfr_clear (exp);
+ mpfr_clear (absv);
+ mpfr_clear (pow2);
return range_check (result, "FRACTION");
}
gfc_expr *
-gfc_simplify_huge (gfc_expr * e)
+gfc_simplify_gamma (gfc_expr *x)
+{
+ gfc_expr *result;
+
+ if (x->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+
+ gfc_set_model_kind (x->ts.kind);
+
+ mpfr_gamma (result->value.real, x->value.real, GFC_RND_MODE);
+
+ return range_check (result, "GAMMA");
+}
+
+
+gfc_expr *
+gfc_simplify_huge (gfc_expr *e)
{
gfc_expr *result;
int i;
- i = gfc_validate_kind (e->ts.type, e->ts.kind);
- if (i == -1)
- goto bad_type;
+ i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
break;
case BT_REAL:
- mpf_set (result->value.real, gfc_real_kinds[i].huge);
+ mpfr_set (result->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
break;
- bad_type:
default:
- gfc_internal_error ("gfc_simplify_huge(): Bad type");
+ gcc_unreachable ();
}
return result;
gfc_expr *
-gfc_simplify_iachar (gfc_expr * e)
+gfc_simplify_hypot (gfc_expr *x, gfc_expr *y)
+{
+ gfc_expr *result;
+
+ if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ mpfr_hypot (result->value.real, x->value.real, y->value.real, GFC_RND_MODE);
+ return range_check (result, "HYPOT");
+}
+
+
+/* We use the processor's collating sequence, because all
+ systems that gfortran currently works on are ASCII. */
+
+gfc_expr *
+gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind)
{
gfc_expr *result;
int index;
return &gfc_bad_expr;
}
- index = xascii_table[(int) e->value.character.string[0] & 0xFF];
+ index = (unsigned char) e->value.character.string[0];
+
+ if (gfc_option.warn_surprising && index > 127)
+ gfc_warning ("Argument of IACHAR function at %L outside of range 0..127",
+ &e->where);
+
+ if ((result = int_expr_with_kind (index, kind, "IACHAR")) == NULL)
+ return &gfc_bad_expr;
- result = gfc_int_expr (index);
result->where = e->where;
return range_check (result, "IACHAR");
gfc_expr *
-gfc_simplify_iand (gfc_expr * x, gfc_expr * y)
+gfc_simplify_iand (gfc_expr *x, gfc_expr *y)
{
gfc_expr *result;
gfc_expr *
-gfc_simplify_ibclr (gfc_expr * x, gfc_expr * y)
+gfc_simplify_ibclr (gfc_expr *x, gfc_expr *y)
{
gfc_expr *result;
int k, pos;
return &gfc_bad_expr;
}
- k = gfc_validate_kind (x->ts.type, x->ts.kind);
- if (k == -1)
- gfc_internal_error ("gfc_simplify_ibclr(): Bad kind");
+ k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
- if (pos > gfc_integer_kinds[k].bit_size)
+ if (pos >= gfc_integer_kinds[k].bit_size)
{
gfc_error ("Second argument of IBCLR exceeds bit size at %L",
&y->where);
result = gfc_copy_expr (x);
+ convert_mpz_to_unsigned (result->value.integer,
+ gfc_integer_kinds[k].bit_size);
+
mpz_clrbit (result->value.integer, pos);
- return range_check (result, "IBCLR");
+
+ convert_mpz_to_signed (result->value.integer,
+ gfc_integer_kinds[k].bit_size);
+
+ return result;
}
gfc_expr *
-gfc_simplify_ibits (gfc_expr * x, gfc_expr * y, gfc_expr * z)
+gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z)
{
gfc_expr *result;
int pos, len;
return &gfc_bad_expr;
}
- k = gfc_validate_kind (BT_INTEGER, x->ts.kind);
- if (k == -1)
- gfc_internal_error ("gfc_simplify_ibits(): Bad kind");
+ k = gfc_validate_kind (BT_INTEGER, x->ts.kind, false);
bitsize = gfc_integer_kinds[k].bit_size;
if (pos + len > bitsize)
{
- gfc_error
- ("Sum of second and third arguments of IBITS exceeds bit size "
- "at %L", &y->where);
+ gfc_error ("Sum of second and third arguments of IBITS exceeds "
+ "bit size at %L", &y->where);
return &gfc_bad_expr;
}
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ convert_mpz_to_unsigned (result->value.integer,
+ gfc_integer_kinds[k].bit_size);
bits = gfc_getmem (bitsize * sizeof (int));
for (i = 0; i < bitsize; i++)
{
if (bits[i] == 0)
- {
- mpz_clrbit (result->value.integer, i);
- }
+ mpz_clrbit (result->value.integer, i);
else if (bits[i] == 1)
- {
- mpz_setbit (result->value.integer, i);
- }
+ mpz_setbit (result->value.integer, i);
else
- {
- gfc_internal_error ("IBITS: Bad bit");
- }
+ gfc_internal_error ("IBITS: Bad bit");
}
gfc_free (bits);
- return range_check (result, "IBITS");
+ convert_mpz_to_signed (result->value.integer,
+ gfc_integer_kinds[k].bit_size);
+
+ return result;
}
gfc_expr *
-gfc_simplify_ibset (gfc_expr * x, gfc_expr * y)
+gfc_simplify_ibset (gfc_expr *x, gfc_expr *y)
{
gfc_expr *result;
int k, pos;
return &gfc_bad_expr;
}
- k = gfc_validate_kind (x->ts.type, x->ts.kind);
- if (k == -1)
- gfc_internal_error ("gfc_simplify_ibset(): Bad kind");
+ k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
- if (pos > gfc_integer_kinds[k].bit_size)
+ if (pos >= gfc_integer_kinds[k].bit_size)
{
gfc_error ("Second argument of IBSET exceeds bit size at %L",
&y->where);
result = gfc_copy_expr (x);
+ convert_mpz_to_unsigned (result->value.integer,
+ gfc_integer_kinds[k].bit_size);
+
mpz_setbit (result->value.integer, pos);
- return range_check (result, "IBSET");
+
+ convert_mpz_to_signed (result->value.integer,
+ gfc_integer_kinds[k].bit_size);
+
+ return result;
}
gfc_expr *
-gfc_simplify_ichar (gfc_expr * e)
+gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind)
{
gfc_expr *result;
int index;
return &gfc_bad_expr;
}
- index = (int) e->value.character.string[0];
+ index = (unsigned char) e->value.character.string[0];
- if (index < CHAR_MIN || index > CHAR_MAX)
- {
- gfc_error ("Argument of ICHAR at %L out of range of this processor",
- &e->where);
- return &gfc_bad_expr;
- }
+ if (index < 0 || index > UCHAR_MAX)
+ gfc_internal_error("Argument of ICHAR at %L out of range", &e->where);
+
+ if ((result = int_expr_with_kind (index, kind, "ICHAR")) == NULL)
+ return &gfc_bad_expr;
- result = gfc_int_expr (index);
result->where = e->where;
return range_check (result, "ICHAR");
}
gfc_expr *
-gfc_simplify_ieor (gfc_expr * x, gfc_expr * y)
+gfc_simplify_ieor (gfc_expr *x, gfc_expr *y)
{
gfc_expr *result;
gfc_expr *
-gfc_simplify_index (gfc_expr * x, gfc_expr * y, gfc_expr * b)
+gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b, gfc_expr *kind)
{
gfc_expr *result;
int back, len, lensub;
else
back = 0;
- result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind (),
- &x->where);
+ k = get_kind (BT_INTEGER, kind, "INDEX", gfc_default_integer_kind);
+ if (k == -1)
+ return &gfc_bad_expr;
+
+ result = gfc_constant_result (BT_INTEGER, k, &x->where);
len = x->value.character.length;
lensub = y->value.character.length;
if (back == 0)
{
-
if (lensub == 0)
{
mpz_set_si (result->value.integer, 1);
{
for (j = 0; j < lensub; j++)
{
- if (y->value.character.string[j] ==
- x->value.character.string[i])
+ if (y->value.character.string[j]
+ == x->value.character.string[i])
{
index = i + 1;
goto done;
{
for (j = 0; j < lensub; j++)
{
- if (y->value.character.string[j] ==
- x->value.character.string[i])
+ if (y->value.character.string[j]
+ == x->value.character.string[i])
{
start = i;
count = 0;
for (k = 0; k < lensub; k++)
{
- if (y->value.character.string[k] ==
- x->value.character.string[k + start])
+ if (y->value.character.string[k]
+ == x->value.character.string[k + start])
count++;
}
}
else
{
-
if (lensub == 0)
{
mpz_set_si (result->value.integer, len + 1);
{
for (j = 0; j < lensub; j++)
{
- if (y->value.character.string[j] ==
- x->value.character.string[len - i])
+ if (y->value.character.string[j]
+ == x->value.character.string[len - i])
{
index = len - i + 1;
goto done;
{
for (j = 0; j < lensub; j++)
{
- if (y->value.character.string[j] ==
- x->value.character.string[len - i])
+ if (y->value.character.string[j]
+ == x->value.character.string[len - i])
{
start = len - i;
if (start <= len - lensub)
{
count = 0;
for (k = 0; k < lensub; k++)
- if (y->value.character.string[k] ==
- x->value.character.string[k + start])
+ if (y->value.character.string[k]
+ == x->value.character.string[k + start])
count++;
if (count == lensub)
gfc_expr *
-gfc_simplify_int (gfc_expr * e, gfc_expr * k)
+gfc_simplify_int (gfc_expr *e, gfc_expr *k)
{
gfc_expr *rpart, *rtrunc, *result;
int kind;
- kind = get_kind (BT_REAL, k, "INT", gfc_default_real_kind ());
+ kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind);
if (kind == -1)
return &gfc_bad_expr;
case BT_REAL:
rtrunc = gfc_copy_expr (e);
- mpf_trunc (rtrunc->value.real, e->value.real);
- mpz_set_f (result->value.integer, rtrunc->value.real);
+ mpfr_trunc (rtrunc->value.real, e->value.real);
+ gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
gfc_free_expr (rtrunc);
break;
case BT_COMPLEX:
rpart = gfc_complex2real (e, kind);
rtrunc = gfc_copy_expr (rpart);
- mpf_trunc (rtrunc->value.real, rpart->value.real);
- mpz_set_f (result->value.integer, rtrunc->value.real);
+ mpfr_trunc (rtrunc->value.real, rpart->value.real);
+ gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
gfc_free_expr (rpart);
gfc_free_expr (rtrunc);
break;
}
+static gfc_expr *
+gfc_simplify_intconv (gfc_expr *e, int kind, const char *name)
+{
+ gfc_expr *rpart, *rtrunc, *result;
+
+ if (e->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ result = gfc_constant_result (BT_INTEGER, kind, &e->where);
+
+ switch (e->ts.type)
+ {
+ case BT_INTEGER:
+ mpz_set (result->value.integer, e->value.integer);
+ break;
+
+ case BT_REAL:
+ rtrunc = gfc_copy_expr (e);
+ mpfr_trunc (rtrunc->value.real, e->value.real);
+ gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
+ gfc_free_expr (rtrunc);
+ break;
+
+ case BT_COMPLEX:
+ rpart = gfc_complex2real (e, kind);
+ rtrunc = gfc_copy_expr (rpart);
+ mpfr_trunc (rtrunc->value.real, rpart->value.real);
+ gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
+ gfc_free_expr (rpart);
+ gfc_free_expr (rtrunc);
+ break;
+
+ default:
+ gfc_error ("Argument of %s at %L is not a valid type", name, &e->where);
+ gfc_free_expr (result);
+ return &gfc_bad_expr;
+ }
+
+ return range_check (result, name);
+}
+
+
+gfc_expr *
+gfc_simplify_int2 (gfc_expr *e)
+{
+ return gfc_simplify_intconv (e, 2, "INT2");
+}
+
+
gfc_expr *
-gfc_simplify_ifix (gfc_expr * e)
+gfc_simplify_int8 (gfc_expr *e)
+{
+ return gfc_simplify_intconv (e, 8, "INT8");
+}
+
+
+gfc_expr *
+gfc_simplify_long (gfc_expr *e)
+{
+ return gfc_simplify_intconv (e, 4, "LONG");
+}
+
+
+gfc_expr *
+gfc_simplify_ifix (gfc_expr *e)
{
gfc_expr *rtrunc, *result;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind (),
+ result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
&e->where);
rtrunc = gfc_copy_expr (e);
- mpf_trunc (rtrunc->value.real, e->value.real);
- mpz_set_f (result->value.integer, rtrunc->value.real);
+ mpfr_trunc (rtrunc->value.real, e->value.real);
+ gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
gfc_free_expr (rtrunc);
return range_check (result, "IFIX");
gfc_expr *
-gfc_simplify_idint (gfc_expr * e)
+gfc_simplify_idint (gfc_expr *e)
{
gfc_expr *rtrunc, *result;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind (),
+ result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
&e->where);
rtrunc = gfc_copy_expr (e);
- mpf_trunc (rtrunc->value.real, e->value.real);
- mpz_set_f (result->value.integer, rtrunc->value.real);
+ mpfr_trunc (rtrunc->value.real, e->value.real);
+ gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
gfc_free_expr (rtrunc);
return range_check (result, "IDINT");
gfc_expr *
-gfc_simplify_ior (gfc_expr * x, gfc_expr * y)
+gfc_simplify_ior (gfc_expr *x, gfc_expr *y)
{
gfc_expr *result;
gfc_expr *
-gfc_simplify_ishft (gfc_expr * e, gfc_expr * s)
+gfc_simplify_ishft (gfc_expr *e, gfc_expr *s)
{
gfc_expr *result;
- int shift, ashift, isize, k;
- long e_int;
+ int shift, ashift, isize, k, *bits, i;
if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
return NULL;
return &gfc_bad_expr;
}
- k = gfc_validate_kind (BT_INTEGER, e->ts.kind);
- if (k == -1)
- gfc_internal_error ("gfc_simplify_ishft(): Bad kind");
+ k = gfc_validate_kind (BT_INTEGER, e->ts.kind, false);
isize = gfc_integer_kinds[k].bit_size;
if (ashift > isize)
{
- gfc_error
- ("Magnitude of second argument of ISHFT exceeds bit size at %L",
- &s->where);
+ gfc_error ("Magnitude of second argument of ISHFT exceeds bit size "
+ "at %L", &s->where);
return &gfc_bad_expr;
}
- e_int = mpz_get_si (e->value.integer);
- if (e_int > INT_MAX || e_int < INT_MIN)
- gfc_internal_error ("ISHFT: unable to extract integer");
-
result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
if (shift == 0)
mpz_set (result->value.integer, e->value.integer);
return range_check (result, "ISHFT");
}
+
+ bits = gfc_getmem (isize * sizeof (int));
+
+ for (i = 0; i < isize; i++)
+ bits[i] = mpz_tstbit (e->value.integer, i);
if (shift > 0)
- mpz_set_si (result->value.integer, e_int << shift);
+ {
+ for (i = 0; i < shift; i++)
+ mpz_clrbit (result->value.integer, i);
+
+ for (i = 0; i < isize - shift; i++)
+ {
+ if (bits[i] == 0)
+ mpz_clrbit (result->value.integer, i + shift);
+ else
+ mpz_setbit (result->value.integer, i + shift);
+ }
+ }
else
- mpz_set_si (result->value.integer, e_int >> ashift);
+ {
+ for (i = isize - 1; i >= isize - ashift; i--)
+ mpz_clrbit (result->value.integer, i);
+
+ for (i = isize - 1; i >= ashift; i--)
+ {
+ if (bits[i] == 0)
+ mpz_clrbit (result->value.integer, i - ashift);
+ else
+ mpz_setbit (result->value.integer, i - ashift);
+ }
+ }
+
+ convert_mpz_to_signed (result->value.integer, isize);
- return range_check (result, "ISHFT");
+ gfc_free (bits);
+ return result;
}
gfc_expr *
-gfc_simplify_ishftc (gfc_expr * e, gfc_expr * s, gfc_expr * sz)
+gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz)
{
gfc_expr *result;
- int shift, ashift, isize, delta, k;
+ int shift, ashift, isize, ssize, delta, k;
int i, *bits;
if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
return &gfc_bad_expr;
}
- k = gfc_validate_kind (e->ts.type, e->ts.kind);
- if (k == -1)
- gfc_internal_error ("gfc_simplify_ishftc(): Bad kind");
+ k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
+ isize = gfc_integer_kinds[k].bit_size;
if (sz != NULL)
{
- if (gfc_extract_int (sz, &isize) != NULL || isize < 0)
+ if (sz->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ if (gfc_extract_int (sz, &ssize) != NULL || ssize <= 0)
{
gfc_error ("Invalid third argument of ISHFTC at %L", &sz->where);
return &gfc_bad_expr;
}
+
+ if (ssize > isize)
+ {
+ gfc_error ("Magnitude of third argument of ISHFTC exceeds "
+ "BIT_SIZE of first argument at %L", &s->where);
+ return &gfc_bad_expr;
+ }
}
else
- isize = gfc_integer_kinds[k].bit_size;
+ ssize = isize;
if (shift >= 0)
ashift = shift;
else
ashift = -shift;
- if (ashift > isize)
+ if (ashift > ssize)
{
- gfc_error
- ("Magnitude of second argument of ISHFTC exceeds third argument "
- "at %L", &s->where);
+ if (sz != NULL)
+ gfc_error ("Magnitude of second argument of ISHFTC exceeds "
+ "third argument at %L", &s->where);
+ else
+ gfc_error ("Magnitude of second argument of ISHFTC exceeds "
+ "BIT_SIZE of first argument at %L", &s->where);
return &gfc_bad_expr;
}
result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
- bits = gfc_getmem (isize * sizeof (int));
+ mpz_set (result->value.integer, e->value.integer);
- for (i = 0; i < isize; i++)
- bits[i] = mpz_tstbit (e->value.integer, i);
+ if (shift == 0)
+ return result;
- delta = isize - ashift;
+ convert_mpz_to_unsigned (result->value.integer, isize);
- if (shift == 0)
- {
- mpz_set (result->value.integer, e->value.integer);
- gfc_free (bits);
- return range_check (result, "ISHFTC");
- }
+ bits = gfc_getmem (ssize * sizeof (int));
+
+ for (i = 0; i < ssize; i++)
+ bits[i] = mpz_tstbit (e->value.integer, i);
+
+ delta = ssize - ashift;
- else if (shift > 0)
+ if (shift > 0)
{
for (i = 0; i < delta; i++)
{
if (bits[i] == 0)
mpz_clrbit (result->value.integer, i + shift);
- if (bits[i] == 1)
+ else
mpz_setbit (result->value.integer, i + shift);
}
- for (i = delta; i < isize; i++)
+ for (i = delta; i < ssize; i++)
{
if (bits[i] == 0)
mpz_clrbit (result->value.integer, i - delta);
- if (bits[i] == 1)
+ else
mpz_setbit (result->value.integer, i - delta);
}
-
- gfc_free (bits);
- return range_check (result, "ISHFTC");
}
else
{
{
if (bits[i] == 0)
mpz_clrbit (result->value.integer, i + delta);
- if (bits[i] == 1)
+ else
mpz_setbit (result->value.integer, i + delta);
}
- for (i = ashift; i < isize; i++)
+ for (i = ashift; i < ssize; i++)
{
if (bits[i] == 0)
mpz_clrbit (result->value.integer, i + shift);
- if (bits[i] == 1)
+ else
mpz_setbit (result->value.integer, i + shift);
}
-
- gfc_free (bits);
- return range_check (result, "ISHFTC");
}
+
+ convert_mpz_to_signed (result->value.integer, isize);
+
+ gfc_free (bits);
+ return result;
}
gfc_expr *
-gfc_simplify_kind (gfc_expr * e)
+gfc_simplify_kind (gfc_expr *e)
{
if (e->ts.type == BT_DERIVED)
static gfc_expr *
-gfc_simplify_bound (gfc_expr * array, gfc_expr * dim, int upper)
+simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
+ gfc_array_spec *as)
{
- gfc_ref *ref;
- gfc_array_spec *as;
- int i;
+ gfc_expr *l, *u, *result;
+ int k;
- if (array->expr_type != EXPR_VARIABLE)
- return NULL;
+ /* The last dimension of an assumed-size array is special. */
+ if (d == as->rank && as->type == AS_ASSUMED_SIZE && !upper)
+ {
+ if (as->lower[d-1]->expr_type == EXPR_CONSTANT)
+ return gfc_copy_expr (as->lower[d-1]);
+ else
+ return NULL;
+ }
- if (dim == NULL)
+ /* Then, we need to know the extent of the given dimension. */
+ l = as->lower[d-1];
+ u = as->upper[d-1];
+
+ if (l->expr_type != EXPR_CONSTANT || u->expr_type != EXPR_CONSTANT)
return NULL;
- if (dim->expr_type != EXPR_CONSTANT)
+ k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
+ gfc_default_integer_kind);
+ if (k == -1)
+ return &gfc_bad_expr;
+
+ result = gfc_constant_result (BT_INTEGER, k, &array->where);
+
+ if (mpz_cmp (l->value.integer, u->value.integer) > 0)
+ {
+ /* Zero extent. */
+ if (upper)
+ mpz_set_si (result->value.integer, 0);
+ else
+ mpz_set_si (result->value.integer, 1);
+ }
+ else
+ {
+ /* Nonzero extent. */
+ if (upper)
+ mpz_set (result->value.integer, u->value.integer);
+ else
+ mpz_set (result->value.integer, l->value.integer);
+ }
+
+ return range_check (result, upper ? "UBOUND" : "LBOUND");
+}
+
+
+static gfc_expr *
+simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
+{
+ gfc_ref *ref;
+ gfc_array_spec *as;
+ int d;
+
+ if (array->expr_type != EXPR_VARIABLE)
return NULL;
/* Follow any component references. */
as = array->symtree->n.sym->as;
- ref = array->ref;
- while (ref->next != NULL)
+ for (ref = array->ref; ref; ref = ref->next)
{
- if (ref->type == REF_COMPONENT)
- as = ref->u.c.sym->as;
- ref = ref->next;
+ switch (ref->type)
+ {
+ case REF_ARRAY:
+ switch (ref->u.ar.type)
+ {
+ case AR_ELEMENT:
+ as = NULL;
+ continue;
+
+ case AR_FULL:
+ /* We're done because 'as' has already been set in the
+ previous iteration. */
+ goto done;
+
+ case AR_SECTION:
+ case AR_UNKNOWN:
+ return NULL;
+ }
+
+ gcc_unreachable ();
+
+ case REF_COMPONENT:
+ as = ref->u.c.component->as;
+ continue;
+
+ case REF_SUBSTRING:
+ continue;
+ }
}
- if (ref->type != REF_ARRAY || ref->u.ar.type != AR_FULL)
+ gcc_unreachable ();
+
+ done:
+
+ if (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE)
return NULL;
-
- i = mpz_get_si (dim->value.integer);
- if (upper)
- return as->upper[i-1];
+
+ if (dim == NULL)
+ {
+ /* Multi-dimensional bounds. */
+ gfc_expr *bounds[GFC_MAX_DIMENSIONS];
+ gfc_expr *e;
+ gfc_constructor *head, *tail;
+ int k;
+
+ /* UBOUND(ARRAY) is not valid for an assumed-size array. */
+ if (upper && as->type == AS_ASSUMED_SIZE)
+ {
+ /* An error message will be emitted in
+ check_assumed_size_reference (resolve.c). */
+ return &gfc_bad_expr;
+ }
+
+ /* Simplify the bounds for each dimension. */
+ for (d = 0; d < array->rank; d++)
+ {
+ bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as);
+ if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
+ {
+ int j;
+
+ for (j = 0; j < d; j++)
+ gfc_free_expr (bounds[j]);
+ return bounds[d];
+ }
+ }
+
+ /* Allocate the result expression. */
+ e = gfc_get_expr ();
+ e->where = array->where;
+ e->expr_type = EXPR_ARRAY;
+ e->ts.type = BT_INTEGER;
+ k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
+ gfc_default_integer_kind);
+ if (k == -1)
+ return &gfc_bad_expr;
+ e->ts.kind = k;
+
+ /* The result is a rank 1 array; its size is the rank of the first
+ argument to {L,U}BOUND. */
+ e->rank = 1;
+ e->shape = gfc_get_shape (1);
+ mpz_init_set_ui (e->shape[0], array->rank);
+
+ /* Create the constructor for this array. */
+ head = tail = NULL;
+ for (d = 0; d < array->rank; d++)
+ {
+ /* Get a new constructor element. */
+ if (head == NULL)
+ head = tail = gfc_get_constructor ();
+ else
+ {
+ tail->next = gfc_get_constructor ();
+ tail = tail->next;
+ }
+
+ tail->where = e->where;
+ tail->expr = bounds[d];
+ }
+ e->value.constructor = head;
+
+ return e;
+ }
else
- return as->lower[i-1];
+ {
+ /* A DIM argument is specified. */
+ if (dim->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ d = mpz_get_si (dim->value.integer);
+
+ if (d < 1 || d > as->rank
+ || (d == as->rank && as->type == AS_ASSUMED_SIZE && upper))
+ {
+ gfc_error ("DIM argument at %L is out of bounds", &dim->where);
+ return &gfc_bad_expr;
+ }
+
+ return simplify_bound_dim (array, kind, d, upper, as);
+ }
}
gfc_expr *
-gfc_simplify_lbound (gfc_expr * array, gfc_expr * dim)
+gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
{
- return gfc_simplify_bound (array, dim, 0);
+ return simplify_bound (array, dim, kind, 0);
}
gfc_expr *
-gfc_simplify_len (gfc_expr * e)
+gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
{
gfc_expr *result;
+ int k = get_kind (BT_INTEGER, kind, "LEN", gfc_default_integer_kind);
- if (e->expr_type != EXPR_CONSTANT)
- return NULL;
+ if (k == -1)
+ return &gfc_bad_expr;
- result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind (),
- &e->where);
+ if (e->expr_type == EXPR_CONSTANT)
+ {
+ result = gfc_constant_result (BT_INTEGER, k, &e->where);
+ mpz_set_si (result->value.integer, e->value.character.length);
+ return range_check (result, "LEN");
+ }
- mpz_set_si (result->value.integer, e->value.character.length);
- return range_check (result, "LEN");
+ if (e->ts.cl != NULL && e->ts.cl->length != NULL
+ && e->ts.cl->length->expr_type == EXPR_CONSTANT
+ && e->ts.cl->length->ts.type == BT_INTEGER)
+ {
+ result = gfc_constant_result (BT_INTEGER, k, &e->where);
+ mpz_set (result->value.integer, e->ts.cl->length->value.integer);
+ return range_check (result, "LEN");
+ }
+
+ return NULL;
}
gfc_expr *
-gfc_simplify_len_trim (gfc_expr * e)
+gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind)
{
gfc_expr *result;
int count, len, lentrim, i;
+ int k = get_kind (BT_INTEGER, kind, "LEN_TRIM", gfc_default_integer_kind);
+
+ if (k == -1)
+ return &gfc_bad_expr;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind (),
- &e->where);
-
+ result = gfc_constant_result (BT_INTEGER, k, &e->where);
len = e->value.character.length;
for (count = 0, i = 1; i <= len; i++)
return range_check (result, "LEN_TRIM");
}
-
gfc_expr *
-gfc_simplify_lge (gfc_expr * a, gfc_expr * b)
+gfc_simplify_lgamma (gfc_expr *x __attribute__((unused)))
{
+#if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0)
+ gfc_expr *result;
+ int sg;
- if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
+ if (x->expr_type != EXPR_CONSTANT)
return NULL;
- return gfc_logical_expr (gfc_compare_string (a, b, xascii_table) >= 0,
- &a->where);
+ result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+
+ gfc_set_model_kind (x->ts.kind);
+
+ mpfr_lgamma (result->value.real, &sg, x->value.real, GFC_RND_MODE);
+
+ return range_check (result, "LGAMMA");
+#else
+ return NULL;
+#endif
}
gfc_expr *
-gfc_simplify_lgt (gfc_expr * a, gfc_expr * b)
+gfc_simplify_lge (gfc_expr *a, gfc_expr *b)
{
-
if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
return NULL;
- return gfc_logical_expr (gfc_compare_string (a, b, xascii_table) > 0,
- &a->where);
+ return gfc_logical_expr (gfc_compare_string (a, b) >= 0, &a->where);
}
gfc_expr *
-gfc_simplify_lle (gfc_expr * a, gfc_expr * b)
+gfc_simplify_lgt (gfc_expr *a, gfc_expr *b)
{
-
if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
return NULL;
- return gfc_logical_expr (gfc_compare_string (a, b, xascii_table) <= 0,
+ return gfc_logical_expr (gfc_compare_string (a, b) > 0,
&a->where);
}
gfc_expr *
-gfc_simplify_llt (gfc_expr * a, gfc_expr * b)
+gfc_simplify_lle (gfc_expr *a, gfc_expr *b)
{
+ if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ return gfc_logical_expr (gfc_compare_string (a, b) <= 0, &a->where);
+}
+
+gfc_expr *
+gfc_simplify_llt (gfc_expr *a, gfc_expr *b)
+{
if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
return NULL;
- return gfc_logical_expr (gfc_compare_string (a, b, xascii_table) < 0,
- &a->where);
+ return gfc_logical_expr (gfc_compare_string (a, b) < 0, &a->where);
}
gfc_expr *
-gfc_simplify_log (gfc_expr * x)
+gfc_simplify_log (gfc_expr *x)
{
gfc_expr *result;
- mpf_t xr, xi;
+ mpfr_t xr, xi;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ gfc_set_model_kind (x->ts.kind);
+
switch (x->ts.type)
{
case BT_REAL:
- if (mpf_cmp (x->value.real, mpf_zero) <= 0)
+ if (mpfr_sgn (x->value.real) <= 0)
{
- gfc_error
- ("Argument of LOG at %L cannot be less than or equal to zero",
- &x->where);
+ gfc_error ("Argument of LOG at %L cannot be less than or equal "
+ "to zero", &x->where);
gfc_free_expr (result);
return &gfc_bad_expr;
}
- natural_logarithm (&x->value.real, &result->value.real);
+ mpfr_log (result->value.real, x->value.real, GFC_RND_MODE);
break;
case BT_COMPLEX:
- if ((mpf_cmp (x->value.complex.r, mpf_zero) == 0)
- && (mpf_cmp (x->value.complex.i, mpf_zero) == 0))
+ if ((mpfr_sgn (x->value.complex.r) == 0)
+ && (mpfr_sgn (x->value.complex.i) == 0))
{
gfc_error ("Complex argument of LOG at %L cannot be zero",
&x->where);
return &gfc_bad_expr;
}
- mpf_init (xr);
- mpf_init (xi);
+ mpfr_init (xr);
+ mpfr_init (xi);
- mpf_div (xr, x->value.complex.i, x->value.complex.r);
- arctangent2 (&x->value.complex.i, &x->value.complex.r,
- &result->value.complex.i);
+ mpfr_atan2 (result->value.complex.i, x->value.complex.i,
+ x->value.complex.r, GFC_RND_MODE);
- mpf_mul (xr, x->value.complex.r, x->value.complex.r);
- mpf_mul (xi, x->value.complex.i, x->value.complex.i);
- mpf_add (xr, xr, xi);
- mpf_sqrt (xr, xr);
- natural_logarithm (&xr, &result->value.complex.r);
+ mpfr_mul (xr, x->value.complex.r, x->value.complex.r, GFC_RND_MODE);
+ mpfr_mul (xi, x->value.complex.i, x->value.complex.i, GFC_RND_MODE);
+ mpfr_add (xr, xr, xi, GFC_RND_MODE);
+ mpfr_sqrt (xr, xr, GFC_RND_MODE);
+ mpfr_log (result->value.complex.r, xr, GFC_RND_MODE);
- mpf_clear (xr);
- mpf_clear (xi);
+ mpfr_clear (xr);
+ mpfr_clear (xi);
break;
gfc_expr *
-gfc_simplify_log10 (gfc_expr * x)
+gfc_simplify_log10 (gfc_expr *x)
{
gfc_expr *result;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- if (mpf_cmp (x->value.real, mpf_zero) <= 0)
+ gfc_set_model_kind (x->ts.kind);
+
+ if (mpfr_sgn (x->value.real) <= 0)
{
- gfc_error
- ("Argument of LOG10 at %L cannot be less than or equal to zero",
- &x->where);
+ gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
+ "to zero", &x->where);
return &gfc_bad_expr;
}
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
- common_logarithm (&x->value.real, &result->value.real);
+ mpfr_log10 (result->value.real, x->value.real, GFC_RND_MODE);
return range_check (result, "LOG10");
}
gfc_expr *
-gfc_simplify_logical (gfc_expr * e, gfc_expr * k)
+gfc_simplify_logical (gfc_expr *e, gfc_expr *k)
{
gfc_expr *result;
int kind;
- kind = get_kind (BT_LOGICAL, k, "LOGICAL", gfc_default_logical_kind ());
+ kind = get_kind (BT_LOGICAL, k, "LOGICAL", gfc_default_logical_kind);
if (kind < 0)
return &gfc_bad_expr;
MAX(), -1 for MIN(). */
static gfc_expr *
-simplify_min_max (gfc_expr * expr, int sign)
+simplify_min_max (gfc_expr *expr, int sign)
{
gfc_actual_arglist *arg, *last, *extremum;
gfc_intrinsic_sym * specific;
if (mpz_cmp (arg->expr->value.integer,
extremum->expr->value.integer) * sign > 0)
mpz_set (extremum->expr->value.integer, arg->expr->value.integer);
-
break;
case BT_REAL:
- if (mpf_cmp (arg->expr->value.real, extremum->expr->value.real) *
- sign > 0)
- mpf_set (extremum->expr->value.real, arg->expr->value.real);
+ /* We need to use mpfr_min and mpfr_max to treat NaN properly. */
+ if (sign > 0)
+ mpfr_max (extremum->expr->value.real, extremum->expr->value.real,
+ arg->expr->value.real, GFC_RND_MODE);
+ else
+ mpfr_min (extremum->expr->value.real, extremum->expr->value.real,
+ arg->expr->value.real, GFC_RND_MODE);
+ break;
+ case BT_CHARACTER:
+#define LENGTH(x) ((x)->expr->value.character.length)
+#define STRING(x) ((x)->expr->value.character.string)
+ if (LENGTH(extremum) < LENGTH(arg))
+ {
+ char * tmp = STRING(extremum);
+
+ STRING(extremum) = gfc_getmem (LENGTH(arg) + 1);
+ memcpy (STRING(extremum), tmp, LENGTH(extremum));
+ memset (&STRING(extremum)[LENGTH(extremum)], ' ',
+ LENGTH(arg) - LENGTH(extremum));
+ STRING(extremum)[LENGTH(arg)] = '\0'; /* For debugger */
+ LENGTH(extremum) = LENGTH(arg);
+ gfc_free (tmp);
+ }
+
+ if (gfc_compare_string (arg->expr, extremum->expr) * sign > 0)
+ {
+ gfc_free (STRING(extremum));
+ STRING(extremum) = gfc_getmem (LENGTH(extremum) + 1);
+ memcpy (STRING(extremum), STRING(arg), LENGTH(arg));
+ memset (&STRING(extremum)[LENGTH(arg)], ' ',
+ LENGTH(extremum) - LENGTH(arg));
+ STRING(extremum)[LENGTH(extremum)] = '\0'; /* For debugger */
+ }
+#undef LENGTH
+#undef STRING
break;
+
default:
- gfc_internal_error ("gfc_simplify_max(): Bad type in arglist");
+ gfc_internal_error ("simplify_min_max(): Bad type in arglist");
}
/* Delete the extra constant argument. */
gfc_expr *
-gfc_simplify_min (gfc_expr * e)
+gfc_simplify_min (gfc_expr *e)
{
-
return simplify_min_max (e, -1);
}
gfc_expr *
-gfc_simplify_max (gfc_expr * e)
+gfc_simplify_max (gfc_expr *e)
{
-
return simplify_min_max (e, 1);
}
gfc_expr *
-gfc_simplify_maxexponent (gfc_expr * x)
+gfc_simplify_maxexponent (gfc_expr *x)
{
gfc_expr *result;
int i;
- i = gfc_validate_kind (BT_REAL, x->ts.kind);
- if (i == -1)
- gfc_internal_error ("gfc_simplify_maxexponent(): Bad kind");
+ i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
result = gfc_int_expr (gfc_real_kinds[i].max_exponent);
result->where = x->where;
gfc_expr *
-gfc_simplify_minexponent (gfc_expr * x)
+gfc_simplify_minexponent (gfc_expr *x)
{
gfc_expr *result;
int i;
- i = gfc_validate_kind (BT_REAL, x->ts.kind);
- if (i == -1)
- gfc_internal_error ("gfc_simplify_minexponent(): Bad kind");
+ i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
result = gfc_int_expr (gfc_real_kinds[i].min_exponent);
result->where = x->where;
gfc_expr *
-gfc_simplify_mod (gfc_expr * a, gfc_expr * p)
+gfc_simplify_mod (gfc_expr *a, gfc_expr *p)
{
gfc_expr *result;
- mpf_t quot, iquot, term;
+ mpfr_t quot, iquot, term;
+ int kind;
if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (a->ts.type, a->ts.kind, &a->where);
+ kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
+ result = gfc_constant_result (a->ts.type, kind, &a->where);
switch (a->ts.type)
{
break;
case BT_REAL:
- if (mpf_cmp_ui (p->value.real, 0) == 0)
+ if (mpfr_cmp_ui (p->value.real, 0) == 0)
{
/* Result is processor-dependent. */
gfc_error ("Second argument of MOD at %L is zero", &p->where);
return &gfc_bad_expr;
}
- mpf_init (quot);
- mpf_init (iquot);
- mpf_init (term);
+ gfc_set_model_kind (kind);
+ mpfr_init (quot);
+ mpfr_init (iquot);
+ mpfr_init (term);
- mpf_div (quot, a->value.real, p->value.real);
- mpf_trunc (iquot, quot);
- mpf_mul (term, iquot, p->value.real);
- mpf_sub (result->value.real, a->value.real, term);
+ mpfr_div (quot, a->value.real, p->value.real, GFC_RND_MODE);
+ mpfr_trunc (iquot, quot);
+ mpfr_mul (term, iquot, p->value.real, GFC_RND_MODE);
+ mpfr_sub (result->value.real, a->value.real, term, GFC_RND_MODE);
- mpf_clear (quot);
- mpf_clear (iquot);
- mpf_clear (term);
+ mpfr_clear (quot);
+ mpfr_clear (iquot);
+ mpfr_clear (term);
break;
default:
gfc_expr *
-gfc_simplify_modulo (gfc_expr * a, gfc_expr * p)
+gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
{
gfc_expr *result;
- mpf_t quot, iquot, term;
+ mpfr_t quot, iquot, term;
+ int kind;
if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (a->ts.type, a->ts.kind, &a->where);
+ kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
+ result = gfc_constant_result (a->ts.type, kind, &a->where);
switch (a->ts.type)
{
if (mpz_cmp_ui (p->value.integer, 0) == 0)
{
/* Result is processor-dependent. This processor just opts
- to not handle it at all. */
+ to not handle it at all. */
gfc_error ("Second argument of MODULO at %L is zero", &a->where);
gfc_free_expr (result);
return &gfc_bad_expr;
break;
case BT_REAL:
- if (mpf_cmp_ui (p->value.real, 0) == 0)
+ if (mpfr_cmp_ui (p->value.real, 0) == 0)
{
/* Result is processor-dependent. */
gfc_error ("Second argument of MODULO at %L is zero", &p->where);
return &gfc_bad_expr;
}
- mpf_init (quot);
- mpf_init (iquot);
- mpf_init (term);
+ gfc_set_model_kind (kind);
+ mpfr_init (quot);
+ mpfr_init (iquot);
+ mpfr_init (term);
- mpf_div (quot, a->value.real, p->value.real);
- mpf_floor (iquot, quot);
- mpf_mul (term, iquot, p->value.real);
+ mpfr_div (quot, a->value.real, p->value.real, GFC_RND_MODE);
+ mpfr_floor (iquot, quot);
+ mpfr_mul (term, iquot, p->value.real, GFC_RND_MODE);
+ mpfr_sub (result->value.real, a->value.real, term, GFC_RND_MODE);
- mpf_clear (quot);
- mpf_clear (iquot);
- mpf_clear (term);
-
- mpf_sub (result->value.real, a->value.real, term);
+ mpfr_clear (quot);
+ mpfr_clear (iquot);
+ mpfr_clear (term);
break;
default:
/* Exists for the sole purpose of consistency with other intrinsics. */
gfc_expr *
-gfc_simplify_mvbits (gfc_expr * f ATTRIBUTE_UNUSED,
- gfc_expr * fp ATTRIBUTE_UNUSED,
- gfc_expr * l ATTRIBUTE_UNUSED,
- gfc_expr * to ATTRIBUTE_UNUSED,
- gfc_expr * tp ATTRIBUTE_UNUSED)
+gfc_simplify_mvbits (gfc_expr *f ATTRIBUTE_UNUSED,
+ gfc_expr *fp ATTRIBUTE_UNUSED,
+ gfc_expr *l ATTRIBUTE_UNUSED,
+ gfc_expr *to ATTRIBUTE_UNUSED,
+ gfc_expr *tp ATTRIBUTE_UNUSED)
{
return NULL;
}
gfc_expr *
-gfc_simplify_nearest (gfc_expr * x, gfc_expr * s)
+gfc_simplify_nearest (gfc_expr *x, gfc_expr *s)
{
gfc_expr *result;
- float rval;
- double val, eps;
- int p, i, k, match_float;
-
- /* FIXME: This implementation is dopey and probably not quite right,
- but it's a start. */
+ mp_exp_t emin, emax;
+ int kind;
- if (x->expr_type != EXPR_CONSTANT)
+ if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
return NULL;
- k = gfc_validate_kind (x->ts.type, x->ts.kind);
- if (k == -1)
- gfc_internal_error ("gfc_simplify_precision(): Bad kind");
+ if (mpfr_sgn (s->value.real) == 0)
+ {
+ gfc_error ("Second argument of NEAREST at %L shall not be zero",
+ &s->where);
+ return &gfc_bad_expr;
+ }
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ gfc_set_model_kind (x->ts.kind);
+ result = gfc_copy_expr (x);
- val = mpf_get_d (x->value.real);
- p = gfc_real_kinds[k].digits;
+ /* Save current values of emin and emax. */
+ emin = mpfr_get_emin ();
+ emax = mpfr_get_emax ();
- eps = 1.;
- for (i = 1; i < p; ++i)
- {
- eps = eps / 2.;
- }
+ /* Set emin and emax for the current model number. */
+ kind = gfc_validate_kind (BT_REAL, x->ts.kind, 0);
+ mpfr_set_emin ((mp_exp_t) gfc_real_kinds[kind].min_exponent -
+ mpfr_get_prec(result->value.real) + 1);
+ mpfr_set_emax ((mp_exp_t) gfc_real_kinds[kind].max_exponent - 1);
- /* TODO we should make sure that 'float' matches kind 4 */
- match_float = gfc_real_kinds[k].kind == 4;
- if (mpf_cmp_ui (s->value.real, 0) > 0)
+ if (mpfr_sgn (s->value.real) > 0)
{
- if (match_float)
- {
- rval = (float) val;
- rval = rval + eps;
- mpf_set_d (result->value.real, rval);
- }
- else
- {
- val = val + eps;
- mpf_set_d (result->value.real, val);
- }
+ mpfr_nextabove (result->value.real);
+ mpfr_subnormalize (result->value.real, 0, GMP_RNDU);
}
- else if (mpf_cmp_ui (s->value.real, 0) < 0)
+ else
{
- if (match_float)
- {
- rval = (float) val;
- rval = rval - eps;
- mpf_set_d (result->value.real, rval);
- }
- else
- {
- val = val - eps;
- mpf_set_d (result->value.real, val);
- }
+ mpfr_nextbelow (result->value.real);
+ mpfr_subnormalize (result->value.real, 0, GMP_RNDD);
}
- else
+
+ mpfr_set_emin (emin);
+ mpfr_set_emax (emax);
+
+ /* Only NaN can occur. Do not use range check as it gives an
+ error for denormal numbers. */
+ if (mpfr_nan_p (result->value.real) && gfc_option.flag_range_check)
{
- gfc_error ("Invalid second argument of NEAREST at %L", &s->where);
- gfc_free (result);
+ gfc_error ("Result of NEAREST is NaN at %L", &result->where);
return &gfc_bad_expr;
}
- return range_check (result, "NEAREST");
-
+ return result;
}
static gfc_expr *
-simplify_nint (const char *name, gfc_expr * e, gfc_expr * k)
+simplify_nint (const char *name, gfc_expr *e, gfc_expr *k)
{
- gfc_expr *rtrunc, *itrunc, *result;
- int kind, cmp;
+ gfc_expr *itrunc, *result;
+ int kind;
- kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind ());
+ kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind);
if (kind == -1)
return &gfc_bad_expr;
result = gfc_constant_result (BT_INTEGER, kind, &e->where);
- rtrunc = gfc_copy_expr (e);
itrunc = gfc_copy_expr (e);
- cmp = mpf_cmp_ui (e->value.real, 0);
-
- if (cmp > 0)
- {
- mpf_add (rtrunc->value.real, e->value.real, mpf_half);
- mpf_trunc (itrunc->value.real, rtrunc->value.real);
- }
- else if (cmp < 0)
- {
- mpf_sub (rtrunc->value.real, e->value.real, mpf_half);
- mpf_trunc (itrunc->value.real, rtrunc->value.real);
- }
- else
- mpf_set_ui (itrunc->value.real, 0);
+ mpfr_round (itrunc->value.real, e->value.real);
- mpz_set_f (result->value.integer, itrunc->value.real);
+ gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real);
gfc_free_expr (itrunc);
- gfc_free_expr (rtrunc);
return range_check (result, name);
}
gfc_expr *
-gfc_simplify_nint (gfc_expr * e, gfc_expr * k)
+gfc_simplify_new_line (gfc_expr *e)
{
+ gfc_expr *result;
- return simplify_nint ("NINT", e, k);
+ result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
+ result->value.character.string = gfc_getmem (2);
+ result->value.character.length = 1;
+ result->value.character.string[0] = '\n';
+ result->value.character.string[1] = '\0'; /* For debugger */
+ return result;
}
gfc_expr *
-gfc_simplify_idnint (gfc_expr * e)
+gfc_simplify_nint (gfc_expr *e, gfc_expr *k)
{
+ return simplify_nint ("NINT", e, k);
+}
+
+gfc_expr *
+gfc_simplify_idnint (gfc_expr *e)
+{
return simplify_nint ("IDNINT", e, NULL);
}
gfc_expr *
-gfc_simplify_not (gfc_expr * e)
+gfc_simplify_not (gfc_expr *e)
{
gfc_expr *result;
- int i;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
mpz_com (result->value.integer, e->value.integer);
- /* Because of how GMP handles numbers, the result must be ANDed with
- the max_int mask. For radices <> 2, this will require change. */
+ return range_check (result, "NOT");
+}
+
- i = gfc_validate_kind (BT_INTEGER, e->ts.kind);
- if (i == -1)
- gfc_internal_error ("gfc_simplify_not(): Bad kind");
+gfc_expr *
+gfc_simplify_null (gfc_expr *mold)
+{
+ gfc_expr *result;
- mpz_and (result->value.integer, result->value.integer,
- gfc_integer_kinds[i].max_int);
+ if (mold == NULL)
+ {
+ result = gfc_get_expr ();
+ result->ts.type = BT_UNKNOWN;
+ }
+ else
+ result = gfc_copy_expr (mold);
+ result->expr_type = EXPR_NULL;
- return range_check (result, "NOT");
+ return result;
}
gfc_expr *
-gfc_simplify_null (gfc_expr * mold)
+gfc_simplify_or (gfc_expr *x, gfc_expr *y)
{
gfc_expr *result;
+ int kind;
- result = gfc_get_expr ();
- result->expr_type = EXPR_NULL;
+ if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
+ return NULL;
- if (mold == NULL)
- result->ts.type = BT_UNKNOWN;
- else
+ kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
+ if (x->ts.type == BT_INTEGER)
+ {
+ result = gfc_constant_result (BT_INTEGER, kind, &x->where);
+ mpz_ior (result->value.integer, x->value.integer, y->value.integer);
+ }
+ else /* BT_LOGICAL */
{
- result->ts = mold->ts;
- result->where = mold->where;
+ result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
+ result->value.logical = x->value.logical || y->value.logical;
}
- return result;
+ return range_check (result, "OR");
}
gfc_expr *
-gfc_simplify_precision (gfc_expr * e)
+gfc_simplify_precision (gfc_expr *e)
{
gfc_expr *result;
int i;
- i = gfc_validate_kind (e->ts.type, e->ts.kind);
- if (i == -1)
- gfc_internal_error ("gfc_simplify_precision(): Bad kind");
+ i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
result = gfc_int_expr (gfc_real_kinds[i].precision);
result->where = e->where;
gfc_expr *
-gfc_simplify_radix (gfc_expr * e)
+gfc_simplify_radix (gfc_expr *e)
{
gfc_expr *result;
int i;
- i = gfc_validate_kind (e->ts.type, e->ts.kind);
- if (i == -1)
- goto bad;
-
+ i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
switch (e->ts.type)
{
case BT_INTEGER:
break;
default:
- bad:
- gfc_internal_error ("gfc_simplify_radix(): Bad type");
+ gcc_unreachable ();
}
result = gfc_int_expr (i);
gfc_expr *
-gfc_simplify_range (gfc_expr * e)
+gfc_simplify_range (gfc_expr *e)
{
gfc_expr *result;
int i;
long j;
- i = gfc_validate_kind (e->ts.type, e->ts.kind);
- if (i == -1)
- goto bad_type;
+ i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
switch (e->ts.type)
{
j = gfc_real_kinds[i].range;
break;
- bad_type:
default:
- gfc_internal_error ("gfc_simplify_range(): Bad kind");
+ gcc_unreachable ();
}
result = gfc_int_expr (j);
gfc_expr *
-gfc_simplify_real (gfc_expr * e, gfc_expr * k)
+gfc_simplify_real (gfc_expr *e, gfc_expr *k)
{
gfc_expr *result;
int kind;
if (e->ts.type == BT_COMPLEX)
kind = get_kind (BT_REAL, k, "REAL", e->ts.kind);
else
- kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind ());
+ kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind);
if (kind == -1)
return &gfc_bad_expr;
switch (e->ts.type)
{
case BT_INTEGER:
- result = gfc_int2real (e, kind);
+ if (!e->is_boz)
+ result = gfc_int2real (e, kind);
break;
case BT_REAL:
/* Not reached */
}
+ if (e->ts.type == BT_INTEGER && e->is_boz)
+ {
+ gfc_typespec ts;
+ gfc_clear_ts (&ts);
+ ts.type = BT_REAL;
+ ts.kind = kind;
+ result = gfc_copy_expr (e);
+ if (!gfc_convert_boz (result, &ts))
+ return &gfc_bad_expr;
+ }
return range_check (result, "REAL");
}
+
+gfc_expr *
+gfc_simplify_realpart (gfc_expr *e)
+{
+ gfc_expr *result;
+
+ if (e->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
+ mpfr_set (result->value.real, e->value.complex.r, GFC_RND_MODE);
+
+ return range_check (result, "REALPART");
+}
+
gfc_expr *
-gfc_simplify_repeat (gfc_expr * e, gfc_expr * n)
+gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
{
gfc_expr *result;
- int i, j, len, ncopies, nlen;
+ int i, j, len, ncop, nlen;
+ mpz_t ncopies;
+ bool have_length = false;
- if (e->expr_type != EXPR_CONSTANT || n->expr_type != EXPR_CONSTANT)
+ /* If NCOPIES isn't a constant, there's nothing we can do. */
+ if (n->expr_type != EXPR_CONSTANT)
return NULL;
- if (n != NULL && (gfc_extract_int (n, &ncopies) != NULL || ncopies < 0))
+ /* If NCOPIES is negative, it's an error. */
+ if (mpz_sgn (n->value.integer) < 0)
{
- gfc_error ("Invalid second argument of REPEAT at %L", &n->where);
+ gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
+ &n->where);
return &gfc_bad_expr;
}
+ /* If we don't know the character length, we can do no more. */
+ if (e->ts.cl && e->ts.cl->length
+ && e->ts.cl->length->expr_type == EXPR_CONSTANT)
+ {
+ len = mpz_get_si (e->ts.cl->length->value.integer);
+ have_length = true;
+ }
+ else if (e->expr_type == EXPR_CONSTANT
+ && (e->ts.cl == NULL || e->ts.cl->length == NULL))
+ {
+ len = e->value.character.length;
+ }
+ else
+ return NULL;
+
+ /* If the source length is 0, any value of NCOPIES is valid
+ and everything behaves as if NCOPIES == 0. */
+ mpz_init (ncopies);
+ if (len == 0)
+ mpz_set_ui (ncopies, 0);
+ else
+ mpz_set (ncopies, n->value.integer);
+
+ /* Check that NCOPIES isn't too large. */
+ if (len)
+ {
+ mpz_t max, mlen;
+ int i;
+
+ /* Compute the maximum value allowed for NCOPIES: huge(cl) / len. */
+ mpz_init (max);
+ i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
+
+ if (have_length)
+ {
+ mpz_tdiv_q (max, gfc_integer_kinds[i].huge,
+ e->ts.cl->length->value.integer);
+ }
+ else
+ {
+ mpz_init_set_si (mlen, len);
+ mpz_tdiv_q (max, gfc_integer_kinds[i].huge, mlen);
+ mpz_clear (mlen);
+ }
+
+ /* The check itself. */
+ if (mpz_cmp (ncopies, max) > 0)
+ {
+ mpz_clear (max);
+ mpz_clear (ncopies);
+ gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
+ &n->where);
+ return &gfc_bad_expr;
+ }
+
+ mpz_clear (max);
+ }
+ mpz_clear (ncopies);
+
+ /* For further simplification, we need the character string to be
+ constant. */
+ if (e->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ if (len ||
+ (e->ts.cl->length &&
+ mpz_sgn (e->ts.cl->length->value.integer)) != 0)
+ {
+ const char *res = gfc_extract_int (n, &ncop);
+ gcc_assert (res == NULL);
+ }
+ else
+ ncop = 0;
+
len = e->value.character.length;
- nlen = ncopies * len;
+ nlen = ncop * len;
result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
- if (ncopies == 0)
+ if (ncop == 0)
{
result->value.character.string = gfc_getmem (1);
result->value.character.length = 0;
result->value.character.length = nlen;
result->value.character.string = gfc_getmem (nlen + 1);
- for (i = 0; i < ncopies; i++)
+ for (i = 0; i < ncop; i++)
for (j = 0; j < len; j++)
- result->value.character.string[j + i * len] =
- e->value.character.string[j];
+ result->value.character.string[j + i * len]
+ = e->value.character.string[j];
result->value.character.string[nlen] = '\0'; /* For debugger */
return result;
}
+/* Test that the expression is an constant array. */
+
+static bool
+is_constant_array_expr (gfc_expr *e)
+{
+ gfc_constructor *c;
+
+ if (e == NULL)
+ return true;
+
+ if (e->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (e))
+ return false;
+
+ if (e->value.constructor == NULL)
+ return false;
+
+ for (c = e->value.constructor; c; c = c->next)
+ if (c->expr->expr_type != EXPR_CONSTANT)
+ return false;
+
+ return true;
+}
+
+
/* This one is a bear, but mainly has to do with shuffling elements. */
gfc_expr *
-gfc_simplify_reshape (gfc_expr * source, gfc_expr * shape_exp,
- gfc_expr * pad, gfc_expr * order_exp)
+gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
+ gfc_expr *pad, gfc_expr *order_exp)
{
-
int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS];
int i, rank, npad, x[GFC_MAX_DIMENSIONS];
gfc_constructor *head, *tail;
size_t nsource;
gfc_expr *e;
- /* Unpack the shape array. */
- if (source->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (source))
+ /* Check that argument expression types are OK. */
+ if (!is_constant_array_expr (source))
return NULL;
- if (shape_exp->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (shape_exp))
+ if (!is_constant_array_expr (shape_exp))
return NULL;
- if (pad != NULL
- && (pad->expr_type != EXPR_ARRAY
- || !gfc_is_constant_expr (pad)))
+ if (!is_constant_array_expr (pad))
return NULL;
- if (order_exp != NULL
- && (order_exp->expr_type != EXPR_ARRAY
- || !gfc_is_constant_expr (order_exp)))
+ if (!is_constant_array_expr (order_exp))
return NULL;
+ /* Proceed with simplification, unpacking the array. */
+
mpz_init (index);
rank = 0;
head = tail = NULL;
{
for (i = 0; i < rank; i++)
order[i] = i;
-
}
else
{
-
for (i = 0; i < rank; i++)
x[i] = 0;
e = gfc_get_array_element (order_exp, i);
if (e == NULL)
{
- gfc_error
- ("ORDER parameter of RESHAPE at %L is not the same size "
- "as SHAPE parameter", &order_exp->where);
+ gfc_error ("ORDER parameter of RESHAPE at %L is not the same "
+ "size as SHAPE parameter", &order_exp->where);
goto bad_reshape;
}
if (npad == 0)
{
- gfc_error
- ("PAD parameter required for short SOURCE parameter at %L",
- &source->where);
+ gfc_error ("PAD parameter required for short SOURCE parameter "
+ "at %L", &source->where);
goto bad_reshape;
}
e->shape = gfc_get_shape (rank);
for (i = 0; i < rank; i++)
- mpz_init_set_ui (e->shape[i], shape[order[i]]);
+ mpz_init_set_ui (e->shape[i], shape[i]);
- e->ts = head->expr->ts;
+ e->ts = source->ts;
e->rank = rank;
return e;
gfc_expr *
-gfc_simplify_rrspacing (gfc_expr * x)
+gfc_simplify_rrspacing (gfc_expr *x)
{
gfc_expr *result;
- mpf_t i2, absv, ln2, lnx, frac, pow2;
- unsigned long exp2;
- int i, p;
+ int i;
+ long int e, p;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- i = gfc_validate_kind (x->ts.type, x->ts.kind);
- if (i == -1)
- gfc_internal_error ("gfc_simplify_rrspacing(): Bad kind");
+ i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
- p = gfc_real_kinds[i].digits;
+ mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
- if (mpf_cmp (x->value.real, mpf_zero) == 0)
+ /* Special case x = -0 and 0. */
+ if (mpfr_sgn (result->value.real) == 0)
{
- mpf_ui_div (result->value.real, 1, gfc_real_kinds[i].tiny);
+ mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
return result;
}
- mpf_init_set_ui (i2, 2);
- mpf_init (ln2);
- mpf_init (absv);
- mpf_init (lnx);
- mpf_init (frac);
- mpf_init (pow2);
-
- natural_logarithm (&i2, &ln2);
-
- mpf_abs (absv, x->value.real);
- natural_logarithm (&absv, &lnx);
+ /* | x * 2**(-e) | * 2**p. */
+ e = - (long int) mpfr_get_exp (x->value.real);
+ mpfr_mul_2si (result->value.real, result->value.real, e, GFC_RND_MODE);
- mpf_div (lnx, lnx, ln2);
- mpf_trunc (lnx, lnx);
- mpf_add_ui (lnx, lnx, 1);
-
- exp2 = (unsigned long) mpf_get_d (lnx);
- mpf_pow_ui (pow2, i2, exp2);
- mpf_div (frac, absv, pow2);
-
- exp2 = (unsigned long) p;
- mpf_mul_2exp (result->value.real, frac, exp2);
-
- mpf_clear (i2);
- mpf_clear (ln2);
- mpf_clear (absv);
- mpf_clear (lnx);
- mpf_clear (frac);
- mpf_clear (pow2);
+ p = (long int) gfc_real_kinds[i].digits;
+ mpfr_mul_2si (result->value.real, result->value.real, p, GFC_RND_MODE);
return range_check (result, "RRSPACING");
}
gfc_expr *
-gfc_simplify_scale (gfc_expr * x, gfc_expr * i)
+gfc_simplify_scale (gfc_expr *x, gfc_expr *i)
{
int k, neg_flag, power, exp_range;
- mpf_t scale, radix;
+ mpfr_t scale, radix;
gfc_expr *result;
if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
- if (mpf_sgn (x->value.real) == 0)
+ if (mpfr_sgn (x->value.real) == 0)
{
- mpf_set_ui (result->value.real, 0);
+ mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
return result;
}
- k = gfc_validate_kind (BT_REAL, x->ts.kind);
- if (k == -1)
- gfc_internal_error ("gfc_simplify_scale(): Bad kind");
+ k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
exp_range = gfc_real_kinds[k].max_exponent - gfc_real_kinds[k].min_exponent;
power = -power;
}
- mpf_init_set_ui (radix, gfc_real_kinds[k].radix);
- mpf_init (scale);
- mpf_pow_ui (scale, radix, power);
+ gfc_set_model_kind (x->ts.kind);
+ mpfr_init (scale);
+ mpfr_init (radix);
+ mpfr_set_ui (radix, gfc_real_kinds[k].radix, GFC_RND_MODE);
+ mpfr_pow_ui (scale, radix, power, GFC_RND_MODE);
if (neg_flag)
- mpf_div (result->value.real, x->value.real, scale);
+ mpfr_div (result->value.real, x->value.real, scale, GFC_RND_MODE);
else
- mpf_mul (result->value.real, x->value.real, scale);
+ mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE);
- mpf_clear (scale);
- mpf_clear (radix);
+ mpfr_clear (scale);
+ mpfr_clear (radix);
return range_check (result, "SCALE");
}
gfc_expr *
-gfc_simplify_scan (gfc_expr * e, gfc_expr * c, gfc_expr * b)
+gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind)
{
gfc_expr *result;
int back;
size_t i;
size_t indx, len, lenc;
+ int k = get_kind (BT_INTEGER, kind, "SCAN", gfc_default_integer_kind);
+
+ if (k == -1)
+ return &gfc_bad_expr;
if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT)
return NULL;
else
back = 0;
- result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind (),
- &e->where);
+ result = gfc_constant_result (BT_INTEGER, k, &e->where);
len = e->value.character.length;
lenc = c->value.character.length;
else
{
if (back == 0)
- {
- indx =
- strcspn (e->value.character.string, c->value.character.string) + 1;
- if (indx > len)
- indx = 0;
- }
+ {
+ indx = strcspn (e->value.character.string, c->value.character.string)
+ + 1;
+ if (indx > len)
+ indx = 0;
+ }
else
- {
- i = 0;
- for (indx = len; indx > 0; indx--)
- {
- for (i = 0; i < lenc; i++)
- {
- if (c->value.character.string[i]
- == e->value.character.string[indx - 1])
- break;
- }
- if (i < lenc)
- break;
- }
- }
+ {
+ i = 0;
+ for (indx = len; indx > 0; indx--)
+ {
+ for (i = 0; i < lenc; i++)
+ {
+ if (c->value.character.string[i]
+ == e->value.character.string[indx - 1])
+ break;
+ }
+ if (i < lenc)
+ break;
+ }
+ }
}
mpz_set_ui (result->value.integer, indx);
return range_check (result, "SCAN");
gfc_expr *
-gfc_simplify_selected_int_kind (gfc_expr * e)
+gfc_simplify_selected_int_kind (gfc_expr *e)
{
int i, kind, range;
gfc_expr *result;
gfc_expr *
-gfc_simplify_selected_real_kind (gfc_expr * p, gfc_expr * q)
+gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q)
{
int range, precision, i, kind, found_precision, found_range;
gfc_expr *result;
gfc_expr *
-gfc_simplify_set_exponent (gfc_expr * x, gfc_expr * i)
+gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i)
{
gfc_expr *result;
- mpf_t i2, ln2, absv, lnx, pow2, frac;
+ mpfr_t exp, absv, log2, pow2, frac;
unsigned long exp2;
if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
- if (mpf_cmp (x->value.real, mpf_zero) == 0)
+ gfc_set_model_kind (x->ts.kind);
+
+ if (mpfr_sgn (x->value.real) == 0)
{
- mpf_set (result->value.real, mpf_zero);
+ mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
return result;
}
- mpf_init_set_ui (i2, 2);
- mpf_init (ln2);
- mpf_init (absv);
- mpf_init (lnx);
- mpf_init (pow2);
- mpf_init (frac);
-
- natural_logarithm (&i2, &ln2);
+ mpfr_init (absv);
+ mpfr_init (log2);
+ mpfr_init (exp);
+ mpfr_init (pow2);
+ mpfr_init (frac);
- mpf_abs (absv, x->value.real);
- natural_logarithm (&absv, &lnx);
+ mpfr_abs (absv, x->value.real, GFC_RND_MODE);
+ mpfr_log2 (log2, absv, GFC_RND_MODE);
- mpf_div (lnx, lnx, ln2);
- mpf_trunc (lnx, lnx);
- mpf_add_ui (lnx, lnx, 1);
+ mpfr_trunc (log2, log2);
+ mpfr_add_ui (exp, log2, 1, GFC_RND_MODE);
/* Old exponent value, and fraction. */
- exp2 = (unsigned long) mpf_get_d (lnx);
- mpf_pow_ui (pow2, i2, exp2);
+ mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
- mpf_div (frac, absv, pow2);
+ mpfr_div (frac, absv, pow2, GFC_RND_MODE);
/* New exponent. */
exp2 = (unsigned long) mpz_get_d (i->value.integer);
- mpf_mul_2exp (result->value.real, frac, exp2);
+ mpfr_mul_2exp (result->value.real, frac, exp2, GFC_RND_MODE);
- mpf_clear (i2);
- mpf_clear (ln2);
- mpf_clear (absv);
- mpf_clear (lnx);
- mpf_clear (pow2);
- mpf_clear (frac);
+ mpfr_clear (absv);
+ mpfr_clear (log2);
+ mpfr_clear (pow2);
+ mpfr_clear (frac);
return range_check (result, "SET_EXPONENT");
}
gfc_expr *
-gfc_simplify_shape (gfc_expr * source)
+gfc_simplify_shape (gfc_expr *source)
{
mpz_t shape[GFC_MAX_DIMENSIONS];
gfc_expr *result, *e, *f;
int n;
try t;
- result = gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind (),
+ if (source->rank == 0)
+ return gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind,
&source->where);
- if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
- return result;
+ if (source->expr_type != EXPR_VARIABLE)
+ return NULL;
+
+ result = gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind,
+ &source->where);
ar = gfc_find_array_ref (source);
for (n = 0; n < source->rank; n++)
{
- e = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind (),
+ e = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
&source->where);
if (t == SUCCESS)
{
mpz_set_ui (e->value.integer, n + 1);
- f = gfc_simplify_size (source, e);
+ f = gfc_simplify_size (source, e, NULL);
gfc_free_expr (e);
if (f == NULL)
{
gfc_expr *
-gfc_simplify_size (gfc_expr * array, gfc_expr * dim)
+gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
{
mpz_t size;
gfc_expr *result;
int d;
+ int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind);
+
+ if (k == -1)
+ return &gfc_bad_expr;
if (dim == NULL)
{
return NULL;
}
- result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind (),
- &array->where);
-
+ result = gfc_constant_result (BT_INTEGER, k, &array->where);
mpz_set (result->value.integer, size);
-
return result;
}
gfc_expr *
-gfc_simplify_sign (gfc_expr * x, gfc_expr * y)
+gfc_simplify_sign (gfc_expr *x, gfc_expr *y)
{
gfc_expr *result;
case BT_REAL:
/* TODO: Handle -0.0 and +0.0 correctly on machines that support
- it. */
- mpf_abs (result->value.real, x->value.real);
- if (mpf_sgn (y->value.integer) < 0)
- mpf_neg (result->value.real, result->value.real);
+ it. */
+ mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
+ if (mpfr_sgn (y->value.real) < 0)
+ mpfr_neg (result->value.real, result->value.real, GFC_RND_MODE);
break;
gfc_expr *
-gfc_simplify_sin (gfc_expr * x)
+gfc_simplify_sin (gfc_expr *x)
{
gfc_expr *result;
- mpf_t xp, xq;
+ mpfr_t xp, xq;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
switch (x->ts.type)
{
case BT_REAL:
- sine (&x->value.real, &result->value.real);
+ mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE);
break;
case BT_COMPLEX:
- mpf_init (xp);
- mpf_init (xq);
+ gfc_set_model (x->value.real);
+ mpfr_init (xp);
+ mpfr_init (xq);
- sine (&x->value.complex.r, &xp);
- hypercos (&x->value.complex.i, &xq);
- mpf_mul (result->value.complex.r, xp, xq);
+ mpfr_sin (xp, x->value.complex.r, GFC_RND_MODE);
+ mpfr_cosh (xq, x->value.complex.i, GFC_RND_MODE);
+ mpfr_mul (result->value.complex.r, xp, xq, GFC_RND_MODE);
- cosine (&x->value.complex.r, &xp);
- hypersine (&x->value.complex.i, &xq);
- mpf_mul (result->value.complex.i, xp, xq);
+ mpfr_cos (xp, x->value.complex.r, GFC_RND_MODE);
+ mpfr_sinh (xq, x->value.complex.i, GFC_RND_MODE);
+ mpfr_mul (result->value.complex.i, xp, xq, GFC_RND_MODE);
- mpf_clear (xp);
- mpf_clear (xq);
+ mpfr_clear (xp);
+ mpfr_clear (xq);
break;
default:
gfc_expr *
-gfc_simplify_sinh (gfc_expr * x)
+gfc_simplify_sinh (gfc_expr *x)
{
gfc_expr *result;
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
- hypersine (&x->value.real, &result->value.real);
+ mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE);
return range_check (result, "SINH");
}
single precision. TODO: Rounding! */
gfc_expr *
-gfc_simplify_sngl (gfc_expr * a)
+gfc_simplify_sngl (gfc_expr *a)
{
gfc_expr *result;
if (a->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_real2real (a, gfc_default_real_kind ());
+ result = gfc_real2real (a, gfc_default_real_kind);
return range_check (result, "SNGL");
}
gfc_expr *
-gfc_simplify_spacing (gfc_expr * x)
+gfc_simplify_spacing (gfc_expr *x)
{
gfc_expr *result;
- mpf_t i1, i2, ln2, absv, lnx;
- long diff;
- unsigned long exp2;
- int i, p;
+ int i;
+ long int en, ep;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- i = gfc_validate_kind (x->ts.type, x->ts.kind);
- if (i == -1)
- gfc_internal_error ("gfc_simplify_spacing(): Bad kind");
-
- p = gfc_real_kinds[i].digits;
+ i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
- if (mpf_cmp (x->value.real, mpf_zero) == 0)
+ /* Special case x = 0 and -0. */
+ mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
+ if (mpfr_sgn (result->value.real) == 0)
{
- mpf_set (result->value.real, gfc_real_kinds[i].tiny);
+ mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
return result;
}
- mpf_init_set_ui (i1, 1);
- mpf_init_set_ui (i2, 2);
- mpf_init (ln2);
- mpf_init (absv);
- mpf_init (lnx);
-
- natural_logarithm (&i2, &ln2);
-
- mpf_abs (absv, x->value.real);
- natural_logarithm (&absv, &lnx);
-
- mpf_div (lnx, lnx, ln2);
- mpf_trunc (lnx, lnx);
- mpf_add_ui (lnx, lnx, 1);
-
- diff = (long) mpf_get_d (lnx) - (long) p;
- if (diff >= 0)
- {
- exp2 = (unsigned) diff;
- mpf_mul_2exp (result->value.real, i1, exp2);
- }
- else
- {
- diff = -diff;
- exp2 = (unsigned) diff;
- mpf_div_2exp (result->value.real, i1, exp2);
- }
+ /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
+ are the radix, exponent of x, and precision. This excludes the
+ possibility of subnormal numbers. Fortran 2003 states the result is
+ b**max(e - p, emin - 1). */
- mpf_clear (i1);
- mpf_clear (i2);
- mpf_clear (ln2);
- mpf_clear (absv);
- mpf_clear (lnx);
+ ep = (long int) mpfr_get_exp (x->value.real) - gfc_real_kinds[i].digits;
+ en = (long int) gfc_real_kinds[i].min_exponent - 1;
+ en = en > ep ? en : ep;
- if (mpf_cmp (result->value.real, gfc_real_kinds[i].tiny) < 0)
- mpf_set (result->value.real, gfc_real_kinds[i].tiny);
+ mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
+ mpfr_mul_2si (result->value.real, result->value.real, en, GFC_RND_MODE);
return range_check (result, "SPACING");
}
gfc_expr *
-gfc_simplify_sqrt (gfc_expr * e)
+gfc_simplify_sqrt (gfc_expr *e)
{
gfc_expr *result;
- mpf_t ac, ad, s, t, w;
+ mpfr_t ac, ad, s, t, w;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
switch (e->ts.type)
{
case BT_REAL:
- if (mpf_cmp_si (e->value.real, 0) < 0)
+ if (mpfr_cmp_si (e->value.real, 0) < 0)
goto negative_arg;
- mpf_sqrt (result->value.real, e->value.real);
+ mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE);
break;
case BT_COMPLEX:
/* Formula taken from Numerical Recipes to avoid over- and
- underflow. */
+ underflow. */
- mpf_init (ac);
- mpf_init (ad);
- mpf_init (s);
- mpf_init (t);
- mpf_init (w);
+ gfc_set_model (e->value.real);
+ mpfr_init (ac);
+ mpfr_init (ad);
+ mpfr_init (s);
+ mpfr_init (t);
+ mpfr_init (w);
- if (mpf_cmp_ui (e->value.complex.r, 0) == 0
- && mpf_cmp_ui (e->value.complex.i, 0) == 0)
+ if (mpfr_cmp_ui (e->value.complex.r, 0) == 0
+ && mpfr_cmp_ui (e->value.complex.i, 0) == 0)
{
-
- mpf_set_ui (result->value.complex.r, 0);
- mpf_set_ui (result->value.complex.i, 0);
+ mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE);
+ mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
break;
}
- mpf_abs (ac, e->value.complex.r);
- mpf_abs (ad, e->value.complex.i);
+ mpfr_abs (ac, e->value.complex.r, GFC_RND_MODE);
+ mpfr_abs (ad, e->value.complex.i, GFC_RND_MODE);
- if (mpf_cmp (ac, ad) >= 0)
+ if (mpfr_cmp (ac, ad) >= 0)
{
- mpf_div (t, e->value.complex.i, e->value.complex.r);
- mpf_mul (t, t, t);
- mpf_add_ui (t, t, 1);
- mpf_sqrt (t, t);
- mpf_add_ui (t, t, 1);
- mpf_div_ui (t, t, 2);
- mpf_sqrt (t, t);
- mpf_sqrt (s, ac);
- mpf_mul (w, s, t);
+ mpfr_div (t, e->value.complex.i, e->value.complex.r, GFC_RND_MODE);
+ mpfr_mul (t, t, t, GFC_RND_MODE);
+ mpfr_add_ui (t, t, 1, GFC_RND_MODE);
+ mpfr_sqrt (t, t, GFC_RND_MODE);
+ mpfr_add_ui (t, t, 1, GFC_RND_MODE);
+ mpfr_div_ui (t, t, 2, GFC_RND_MODE);
+ mpfr_sqrt (t, t, GFC_RND_MODE);
+ mpfr_sqrt (s, ac, GFC_RND_MODE);
+ mpfr_mul (w, s, t, GFC_RND_MODE);
}
else
{
- mpf_div (s, e->value.complex.r, e->value.complex.i);
- mpf_mul (t, s, s);
- mpf_add_ui (t, t, 1);
- mpf_sqrt (t, t);
- mpf_abs (s, s);
- mpf_add (t, t, s);
- mpf_div_ui (t, t, 2);
- mpf_sqrt (t, t);
- mpf_sqrt (s, ad);
- mpf_mul (w, s, t);
+ mpfr_div (s, e->value.complex.r, e->value.complex.i, GFC_RND_MODE);
+ mpfr_mul (t, s, s, GFC_RND_MODE);
+ mpfr_add_ui (t, t, 1, GFC_RND_MODE);
+ mpfr_sqrt (t, t, GFC_RND_MODE);
+ mpfr_abs (s, s, GFC_RND_MODE);
+ mpfr_add (t, t, s, GFC_RND_MODE);
+ mpfr_div_ui (t, t, 2, GFC_RND_MODE);
+ mpfr_sqrt (t, t, GFC_RND_MODE);
+ mpfr_sqrt (s, ad, GFC_RND_MODE);
+ mpfr_mul (w, s, t, GFC_RND_MODE);
}
- if (mpf_cmp_ui (w, 0) != 0 && mpf_cmp_ui (e->value.complex.r, 0) >= 0)
+ if (mpfr_cmp_ui (w, 0) != 0 && mpfr_cmp_ui (e->value.complex.r, 0) >= 0)
{
- mpf_mul_ui (t, w, 2);
- mpf_div (result->value.complex.i, e->value.complex.i, t);
- mpf_set (result->value.complex.r, w);
+ mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
+ mpfr_div (result->value.complex.i, e->value.complex.i, t, GFC_RND_MODE);
+ mpfr_set (result->value.complex.r, w, GFC_RND_MODE);
}
- else if (mpf_cmp_ui (w, 0) != 0
- && mpf_cmp_ui (e->value.complex.r, 0) < 0
- && mpf_cmp_ui (e->value.complex.i, 0) >= 0)
+ else if (mpfr_cmp_ui (w, 0) != 0
+ && mpfr_cmp_ui (e->value.complex.r, 0) < 0
+ && mpfr_cmp_ui (e->value.complex.i, 0) >= 0)
{
- mpf_mul_ui (t, w, 2);
- mpf_div (result->value.complex.r, e->value.complex.i, t);
- mpf_set (result->value.complex.i, w);
+ mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
+ mpfr_div (result->value.complex.r, e->value.complex.i, t, GFC_RND_MODE);
+ mpfr_set (result->value.complex.i, w, GFC_RND_MODE);
}
- else if (mpf_cmp_ui (w, 0) != 0
- && mpf_cmp_ui (e->value.complex.r, 0) < 0
- && mpf_cmp_ui (e->value.complex.i, 0) < 0)
+ else if (mpfr_cmp_ui (w, 0) != 0
+ && mpfr_cmp_ui (e->value.complex.r, 0) < 0
+ && mpfr_cmp_ui (e->value.complex.i, 0) < 0)
{
- mpf_mul_ui (t, w, 2);
- mpf_div (result->value.complex.r, ad, t);
- mpf_neg (w, w);
- mpf_set (result->value.complex.i, w);
+ mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
+ mpfr_div (result->value.complex.r, ad, t, GFC_RND_MODE);
+ mpfr_neg (w, w, GFC_RND_MODE);
+ mpfr_set (result->value.complex.i, w, GFC_RND_MODE);
}
else
gfc_internal_error ("invalid complex argument of SQRT at %L",
&e->where);
- mpf_clear (s);
- mpf_clear (t);
- mpf_clear (ac);
- mpf_clear (ad);
- mpf_clear (w);
+ mpfr_clear (s);
+ mpfr_clear (t);
+ mpfr_clear (ac);
+ mpfr_clear (ad);
+ mpfr_clear (w);
break;
gfc_expr *
-gfc_simplify_tan (gfc_expr * x)
+gfc_simplify_tan (gfc_expr *x)
{
- gfc_expr *result;
- mpf_t mpf_sin, mpf_cos, mag_cos;
int i;
+ gfc_expr *result;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- i = gfc_validate_kind (BT_REAL, x->ts.kind);
- if (i == -1)
- gfc_internal_error ("gfc_simplify_tan(): Bad kind");
+ i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
- mpf_init (mpf_sin);
- mpf_init (mpf_cos);
- mpf_init (mag_cos);
- sine (&x->value.real, &mpf_sin);
- cosine (&x->value.real, &mpf_cos);
- mpf_abs (mag_cos, mpf_cos);
- if (mpf_cmp_ui (mag_cos, 0) == 0)
- {
- gfc_error ("Tangent undefined at %L", &x->where);
- mpf_clear (mpf_sin);
- mpf_clear (mpf_cos);
- mpf_clear (mag_cos);
- gfc_free_expr (result);
- return &gfc_bad_expr;
- }
- else if (mpf_cmp (mag_cos, gfc_real_kinds[i].tiny) < 0)
- {
- gfc_error ("Tangent cannot be accurately evaluated at %L", &x->where);
- mpf_clear (mpf_sin);
- mpf_clear (mpf_cos);
- mpf_clear (mag_cos);
- gfc_free_expr (result);
- return &gfc_bad_expr;
- }
- else
- {
- mpf_div (result->value.real, mpf_sin, mpf_cos);
- mpf_clear (mpf_sin);
- mpf_clear (mpf_cos);
- mpf_clear (mag_cos);
- }
+ mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE);
return range_check (result, "TAN");
}
gfc_expr *
-gfc_simplify_tanh (gfc_expr * x)
+gfc_simplify_tanh (gfc_expr *x)
{
gfc_expr *result;
- mpf_t xp, xq;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
- mpf_init (xp);
- mpf_init (xq);
-
- hypersine (&x->value.real, &xq);
- hypercos (&x->value.real, &xp);
-
- mpf_div (result->value.real, xq, xp);
-
- mpf_clear (xp);
- mpf_clear (xq);
+ mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE);
return range_check (result, "TANH");
gfc_expr *
-gfc_simplify_tiny (gfc_expr * e)
+gfc_simplify_tiny (gfc_expr *e)
{
gfc_expr *result;
int i;
- i = gfc_validate_kind (BT_REAL, e->ts.kind);
- if (i == -1)
- gfc_internal_error ("gfc_simplify_error(): Bad kind");
+ i = gfc_validate_kind (BT_REAL, e->ts.kind, false);
result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
- mpf_set (result->value.real, gfc_real_kinds[i].tiny);
+ mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
+
+ return result;
+}
+
+
+gfc_expr *
+gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
+{
+ gfc_expr *result;
+ gfc_expr *mold_element;
+ size_t source_size;
+ size_t result_size;
+ size_t result_elt_size;
+ size_t buffer_size;
+ mpz_t tmp;
+ unsigned char *buffer;
+
+ if (!gfc_is_constant_expr (source)
+ || (gfc_init_expr && !gfc_is_constant_expr (mold))
+ || !gfc_is_constant_expr (size))
+ return NULL;
+
+ if (source->expr_type == EXPR_FUNCTION)
+ return NULL;
+
+ /* Calculate the size of the source. */
+ if (source->expr_type == EXPR_ARRAY
+ && gfc_array_size (source, &tmp) == FAILURE)
+ gfc_internal_error ("Failure getting length of a constant array.");
+
+ source_size = gfc_target_expr_size (source);
+
+ /* Create an empty new expression with the appropriate characteristics. */
+ result = gfc_constant_result (mold->ts.type, mold->ts.kind,
+ &source->where);
+ result->ts = mold->ts;
+
+ mold_element = mold->expr_type == EXPR_ARRAY
+ ? mold->value.constructor->expr
+ : mold;
+
+ /* Set result character length, if needed. Note that this needs to be
+ set even for array expressions, in order to pass this information into
+ gfc_target_interpret_expr. */
+ if (result->ts.type == BT_CHARACTER && gfc_is_constant_expr (mold_element))
+ result->value.character.length = mold_element->value.character.length;
+
+ /* Set the number of elements in the result, and determine its size. */
+ result_elt_size = gfc_target_expr_size (mold_element);
+ if (result_elt_size == 0)
+ {
+ gfc_free_expr (result);
+ return NULL;
+ }
+
+ if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
+ {
+ int result_length;
+
+ result->expr_type = EXPR_ARRAY;
+ result->rank = 1;
+
+ if (size)
+ result_length = (size_t)mpz_get_ui (size->value.integer);
+ else
+ {
+ result_length = source_size / result_elt_size;
+ if (result_length * result_elt_size < source_size)
+ result_length += 1;
+ }
+
+ result->shape = gfc_get_shape (1);
+ mpz_init_set_ui (result->shape[0], result_length);
+
+ result_size = result_length * result_elt_size;
+ }
+ else
+ {
+ result->rank = 0;
+ result_size = result_elt_size;
+ }
+
+ if (gfc_option.warn_surprising && source_size < result_size)
+ gfc_warning("Intrinsic TRANSFER at %L has partly undefined result: "
+ "source size %ld < result size %ld", &source->where,
+ (long) source_size, (long) result_size);
+
+ /* Allocate the buffer to store the binary version of the source. */
+ buffer_size = MAX (source_size, result_size);
+ buffer = (unsigned char*)alloca (buffer_size);
+
+ /* Now write source to the buffer. */
+ gfc_target_encode_expr (source, buffer, buffer_size);
+
+ /* And read the buffer back into the new expression. */
+ gfc_target_interpret_expr (buffer, buffer_size, result);
return result;
}
gfc_expr *
-gfc_simplify_trim (gfc_expr * e)
+gfc_simplify_trim (gfc_expr *e)
{
gfc_expr *result;
int count, i, len, lentrim;
gfc_expr *
-gfc_simplify_ubound (gfc_expr * array, gfc_expr * dim)
+gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
{
- return gfc_simplify_bound (array, dim, 1);
+ return simplify_bound (array, dim, kind, 1);
}
gfc_expr *
-gfc_simplify_verify (gfc_expr * s, gfc_expr * set, gfc_expr * b)
+gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b, gfc_expr *kind)
{
gfc_expr *result;
int back;
size_t index, len, lenset;
size_t i;
+ int k = get_kind (BT_INTEGER, kind, "VERIFY", gfc_default_integer_kind);
+
+ if (k == -1)
+ return &gfc_bad_expr;
if (s->expr_type != EXPR_CONSTANT || set->expr_type != EXPR_CONSTANT)
return NULL;
else
back = 0;
- result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind (),
- &s->where);
+ result = gfc_constant_result (BT_INTEGER, k, &s->where);
len = s->value.character.length;
lenset = set->value.character.length;
{
if (lenset == 0)
{
- mpz_set_ui (result->value.integer, len);
+ mpz_set_ui (result->value.integer, 1);
return result;
}
- index =
- strspn (s->value.character.string, set->value.character.string) + 1;
+ index = strspn (s->value.character.string, set->value.character.string)
+ + 1;
if (index > len)
index = 0;
{
if (lenset == 0)
{
- mpz_set_ui (result->value.integer, 1);
+ mpz_set_ui (result->value.integer, len);
return result;
}
for (index = len; index > 0; index --)
- {
- for (i = 0; i < lenset; i++)
- {
- if (s->value.character.string[index - 1]
- == set->value.character.string[i])
- break;
- }
- if (i == lenset)
- break;
- }
+ {
+ for (i = 0; i < lenset; i++)
+ {
+ if (s->value.character.string[index - 1]
+ == set->value.character.string[i])
+ break;
+ }
+ if (i == lenset)
+ break;
+ }
}
mpz_set_ui (result->value.integer, index);
return result;
}
+
+gfc_expr *
+gfc_simplify_xor (gfc_expr *x, gfc_expr *y)
+{
+ gfc_expr *result;
+ int kind;
+
+ if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
+ if (x->ts.type == BT_INTEGER)
+ {
+ result = gfc_constant_result (BT_INTEGER, kind, &x->where);
+ mpz_xor (result->value.integer, x->value.integer, y->value.integer);
+ }
+ else /* BT_LOGICAL */
+ {
+ result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
+ result->value.logical = (x->value.logical && !y->value.logical)
+ || (!x->value.logical && y->value.logical);
+ }
+
+ return range_check (result, "XOR");
+}
+
+
/****************** Constant simplification *****************/
/* Master function to convert one constant to another. While this is
do_simplify(). */
gfc_expr *
-gfc_convert_constant (gfc_expr * e, bt type, int kind)
+gfc_convert_constant (gfc_expr *e, bt type, int kind)
{
gfc_expr *g, *result, *(*f) (gfc_expr *, int);
gfc_constructor *head, *c, *tail = NULL;
case BT_COMPLEX:
f = gfc_int2complex;
break;
+ case BT_LOGICAL:
+ f = gfc_int2log;
+ break;
default:
goto oops;
}
break;
case BT_LOGICAL:
- if (type != BT_LOGICAL)
- goto oops;
- f = gfc_log2log;
+ switch (type)
+ {
+ case BT_INTEGER:
+ f = gfc_log2int;
+ break;
+ case BT_LOGICAL:
+ f = gfc_log2log;
+ break;
+ default:
+ goto oops;
+ }
+ break;
+
+ case BT_HOLLERITH:
+ switch (type)
+ {
+ case BT_INTEGER:
+ f = gfc_hollerith2int;
+ break;
+
+ case BT_REAL:
+ f = gfc_hollerith2real;
+ break;
+
+ case BT_COMPLEX:
+ f = gfc_hollerith2complex;
+ break;
+
+ case BT_CHARACTER:
+ f = gfc_hollerith2character;
+ break;
+
+ case BT_LOGICAL:
+ f = gfc_hollerith2logical;
+ break;
+
+ default:
+ goto oops;
+ }
break;
default:
return result;
}
-
-
-/****************** Helper functions ***********************/
-
-/* Given a collating table, create the inverse table. */
-
-static void
-invert_table (const int *table, int *xtable)
-{
- int i;
-
- for (i = 0; i < 256; i++)
- xtable[i] = 0;
-
- for (i = 0; i < 256; i++)
- xtable[table[i]] = i;
-}
-
-
-void
-gfc_simplify_init_1 (void)
-{
-
- mpf_init_set_str (mpf_zero, "0.0", 10);
- mpf_init_set_str (mpf_half, "0.5", 10);
- mpf_init_set_str (mpf_one, "1.0", 10);
- mpz_init_set_str (mpz_zero, "0", 10);
-
- invert_table (ascii_table, xascii_table);
-}
-
-
-void
-gfc_simplify_done_1 (void)
-{
-
- mpf_clear (mpf_zero);
- mpf_clear (mpf_half);
- mpf_clear (mpf_one);
- mpz_clear (mpz_zero);
-}