/* Simplify intrinsic functions at compile-time.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
Free Software Foundation, Inc.
Contributed by Andy Vaught & Katherine Holcomb
GCC is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
-Software Foundation; either version 2, or (at your option) any later
+Software Foundation; either version 3, or (at your option) any later
version.
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
for more details.
You should have received a copy of the GNU General Public License
-along with GCC; see the file COPYING. If not, write to the Free
-Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
-02110-1301, USA. */
+along with GCC; see the file COPYING3. If not see
+<http://www.gnu.org/licenses/>. */
#include "config.h"
#include "system.h"
#include "gfortran.h"
#include "arith.h"
#include "intrinsic.h"
+#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)
{
+ if (result == NULL)
+ return &gfc_bad_expr;
+
switch (gfc_range_check (result))
{
case ARITH_OK:
{
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, 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
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 *result;
int c, kind;
+ const char *ch;
kind = get_kind (BT_CHARACTER, k, "CHAR", gfc_default_character_kind);
if (kind == -1)
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- if (gfc_extract_int (e, &c) != NULL || c < 0 || c > UCHAR_MAX)
- {
- 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);
switch (x->ts.type)
{
case BT_INTEGER:
- mpfr_set_z (result->value.complex.r, x->value.integer, GFC_RND_MODE);
+ if (!x->is_boz)
+ mpfr_set_z (result->value.complex.r, x->value.integer, GFC_RND_MODE);
break;
case BT_REAL:
switch (y->ts.type)
{
case BT_INTEGER:
- mpfr_set_z (result->value.complex.i, y->value.integer, GFC_RND_MODE);
+ if (!y->is_boz)
+ mpfr_set_z (result->value.complex.i, y->value.integer, GFC_RND_MODE);
break;
case BT_REAL:
}
}
+ /* 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);
}
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:
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_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)
{
if (a->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_int2real (a, gfc_default_real_kind);
+ 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_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 *
-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");
convert_mpz_to_signed (result->value.integer,
gfc_integer_kinds[k].bit_size);
- return range_check (result, "IBCLR");
+ return result;
}
}
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));
gfc_free (bits);
- return range_check (result, "IBITS");
+ convert_mpz_to_signed (result->value.integer,
+ gfc_integer_kinds[k].bit_size);
+
+ return result;
}
convert_mpz_to_signed (result->value.integer,
gfc_integer_kinds[k].bit_size);
- return range_check (result, "IBSET");
+ return result;
}
gfc_expr *
-gfc_simplify_ichar (gfc_expr *e)
+gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind)
{
gfc_expr *result;
int index;
index = (unsigned char) e->value.character.string[0];
if (index < 0 || index > UCHAR_MAX)
- {
- gfc_error ("Argument of ICHAR at %L out of range of this processor",
- &e->where);
- return &gfc_bad_expr;
- }
+ 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_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;
static gfc_expr *
-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;
gfc_expr *l, *u, *result;
- int d;
+ int k;
- if (dim == NULL)
- /* TODO: Simplify constant multi-dimensional bounds. */
- 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;
+ }
+
+ /* Then, we need to know the extent of the given dimension. */
+ l = as->lower[d-1];
+ u = as->upper[d-1];
- if (dim->expr_type != EXPR_CONSTANT)
+ if (l->expr_type != EXPR_CONSTANT || u->expr_type != EXPR_CONSTANT)
return NULL;
+ 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;
gcc_unreachable ();
done:
+
if (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE)
return NULL;
- d = mpz_get_si (dim->value.integer);
-
- if (d < 1 || d > as->rank
- || (d == as->rank && as->type == AS_ASSUMED_SIZE && upper))
+ if (dim == NULL)
{
- gfc_error ("DIM argument at %L is out of bounds", &dim->where);
- return &gfc_bad_expr;
- }
+ /* 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;
+ }
- /* 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;
- }
+ /* 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;
- /* Then, we need to know the extent of the given dimension. */
- l = as->lower[d-1];
- u = as->upper[d-1];
+ for (j = 0; j < d; j++)
+ gfc_free_expr (bounds[j]);
+ return bounds[d];
+ }
+ }
- if (l->expr_type != EXPR_CONSTANT || u->expr_type != EXPR_CONSTANT)
- return NULL;
+ /* 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;
- result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
- &array->where);
+ /* 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);
- 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);
+ /* 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
{
- /* Nonzero extent. */
- if (upper)
- mpz_set (result->value.integer, u->value.integer);
- else
- mpz_set (result->value.integer, l->value.integer);
- }
+ /* A DIM argument is specified. */
+ if (dim->expr_type != EXPR_CONSTANT)
+ return NULL;
- return range_check (result, upper ? "UBOUND" : "LBOUND");
+ 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 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 (k == -1)
+ return &gfc_bad_expr;
if (e->expr_type == EXPR_CONSTANT)
{
- result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
- &e->where);
+ result = gfc_constant_result (BT_INTEGER, k, &e->where);
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->expr_type == EXPR_CONSTANT
+ && e->ts.cl->length->ts.type == BT_INTEGER)
{
- result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
- &e->where);
+ 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_lgamma (gfc_expr *x __attribute__((unused)))
+{
+#if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0)
+ gfc_expr *result;
+ int sg;
+
+ 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_lgamma (result->value.real, &sg, x->value.real, GFC_RND_MODE);
+
+ return range_check (result, "LGAMMA");
+#else
+ return NULL;
+#endif
+}
+
gfc_expr *
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);
}
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);
}
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);
}
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);
}
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 (mpfr_cmp (arg->expr->value.real, extremum->expr->value.real)
- * sign > 0)
- mpfr_set (extremum->expr->value.real, arg->expr->value.real,
- GFC_RND_MODE);
+ /* 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_simplify_nearest (gfc_expr *x, gfc_expr *s)
{
gfc_expr *result;
- mpfr_t tmp;
- int sgn;
+ mp_exp_t emin, emax;
+ int kind;
if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
return NULL;
gfc_set_model_kind (x->ts.kind);
result = gfc_copy_expr (x);
- sgn = mpfr_sgn (s->value.real);
- mpfr_init (tmp);
- mpfr_set_inf (tmp, sgn);
- mpfr_nexttoward (result->value.real, tmp);
- mpfr_clear (tmp);
+ /* Save current values of emin and emax. */
+ emin = mpfr_get_emin ();
+ emax = mpfr_get_emax ();
+
+ /* 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);
- return range_check (result, "NEAREST");
+ if (mpfr_sgn (s->value.real) > 0)
+ {
+ mpfr_nextabove (result->value.real);
+ mpfr_subnormalize (result->value.real, 0, GMP_RNDU);
+ }
+ else
+ {
+ mpfr_nextbelow (result->value.real);
+ mpfr_subnormalize (result->value.real, 0, GMP_RNDD);
+ }
+
+ 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 ("Result of NEAREST is NaN at %L", &result->where);
+ return &gfc_bad_expr;
+ }
+
+ return result;
}
{
gfc_expr *result;
- if (e->expr_type != EXPR_CONSTANT)
- return NULL;
-
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 */
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_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];
}
+/* 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 *
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;
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;
int n;
try t;
- if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
+ if (source->rank == 0)
+ return gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind,
+ &source->where);
+
+ if (source->expr_type != EXPR_VARIABLE)
return NULL;
result = gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind,
{
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_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
{
- /* Reference mold and size to suppress warning. */
- if (gfc_init_expr && (mold || size))
- gfc_error ("TRANSFER intrinsic not implemented for initialization at %L",
- &source->where);
+ 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;
- 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_ubound (gfc_expr *array, gfc_expr *dim)
+gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
{
- return 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;
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)
-{
- invert_table (ascii_table, xascii_table);
-}
projects / gcc.git / blobdiff