/* 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
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:
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 c;
+ int c, kind;
const char *ch;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
+ kind = get_kind (BT_CHARACTER, k, "ACHAR", gfc_default_character_kind);
+ if (kind == -1)
+ return &gfc_bad_expr;
+
ch = gfc_extract_int (e, &c);
if (ch != NULL)
gfc_warning ("Argument of ACHAR function at %L outside of range [0,127]",
&e->where);
- result = gfc_constant_result (BT_CHARACTER, gfc_default_character_kind,
- &e->where);
+ result = gfc_constant_result (BT_CHARACTER, kind, &e->where);
result->value.character.string = gfc_getmem (2);
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)
{
gfc_expr *result;
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 *result;
return result;
}
+
+gfc_expr *
+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. */
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;
}
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)
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:
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 ();
- return range_check (result, "NEAREST");
+ /* 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);
+
+ 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;
}
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");
}
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- if (len || mpz_sgn (e->ts.cl->length->value.integer) != 0)
+ 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);
}
+/* 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;
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_t size;
gfc_expr *result;
int d;
- int k = get_kind (BT_INTEGER, kind, "SCAN", gfc_default_integer_kind);
+ int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind);
if (k == -1)
return &gfc_bad_expr;
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)
/* 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)
+ 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_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);
OSDN Git Service
