gfc_expr *
gfc_simplify_bessel_j0 (gfc_expr *x ATTRIBUTE_UNUSED)
{
-#if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0)
gfc_expr *result;
if (x->expr_type != EXPR_CONSTANT)
mpfr_j0 (result->value.real, x->value.real, GFC_RND_MODE);
return range_check (result, "BESSEL_J0");
-#else
- return NULL;
-#endif
}
gfc_expr *
gfc_simplify_bessel_j1 (gfc_expr *x ATTRIBUTE_UNUSED)
{
-#if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0)
gfc_expr *result;
if (x->expr_type != EXPR_CONSTANT)
mpfr_j1 (result->value.real, x->value.real, GFC_RND_MODE);
return range_check (result, "BESSEL_J1");
-#else
- return NULL;
-#endif
}
gfc_simplify_bessel_jn (gfc_expr *order ATTRIBUTE_UNUSED,
gfc_expr *x ATTRIBUTE_UNUSED)
{
-#if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0)
gfc_expr *result;
long n;
mpfr_jn (result->value.real, n, x->value.real, GFC_RND_MODE);
return range_check (result, "BESSEL_JN");
-#else
- return NULL;
-#endif
}
gfc_expr *
gfc_simplify_bessel_y0 (gfc_expr *x ATTRIBUTE_UNUSED)
{
-#if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0)
gfc_expr *result;
if (x->expr_type != EXPR_CONSTANT)
mpfr_y0 (result->value.real, x->value.real, GFC_RND_MODE);
return range_check (result, "BESSEL_Y0");
-#else
- return NULL;
-#endif
}
gfc_expr *
gfc_simplify_bessel_y1 (gfc_expr *x ATTRIBUTE_UNUSED)
{
-#if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0)
gfc_expr *result;
if (x->expr_type != EXPR_CONSTANT)
mpfr_y1 (result->value.real, x->value.real, GFC_RND_MODE);
return range_check (result, "BESSEL_Y1");
-#else
- return NULL;
-#endif
}
gfc_simplify_bessel_yn (gfc_expr *order ATTRIBUTE_UNUSED,
gfc_expr *x ATTRIBUTE_UNUSED)
{
-#if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0)
gfc_expr *result;
long n;
mpfr_yn (result->value.real, n, x->value.real, GFC_RND_MODE);
return range_check (result, "BESSEL_YN");
-#else
- return NULL;
-#endif
}
ceil = gfc_copy_expr (e);
mpfr_ceil (ceil->value.real, e->value.real);
- gfc_mpfr_to_mpz (result->value.integer, ceil->value.real);
+ gfc_mpfr_to_mpz (result->value.integer, ceil->value.real, &e->where);
gfc_free_expr (ceil);
{
case BT_INTEGER:
if (!y->is_boz)
- mpfr_set_z (result->value.complex.i, y->value.integer, GFC_RND_MODE);
+ mpfr_set_z (result->value.complex.i, y->value.integer,
+ GFC_RND_MODE);
break;
case BT_REAL:
mpfr_init (floor);
mpfr_floor (floor, e->value.real);
- gfc_mpfr_to_mpz (result->value.integer, floor);
+ gfc_mpfr_to_mpz (result->value.integer, floor, &e->where);
mpfr_clear (floor);
rtrunc = gfc_copy_expr (e);
mpfr_trunc (rtrunc->value.real, e->value.real);
- gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
+ gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where);
gfc_free_expr (rtrunc);
return range_check (result, "IFIX");
rtrunc = gfc_copy_expr (e);
mpfr_trunc (rtrunc->value.real, e->value.real);
- gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
+ gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where);
gfc_free_expr (rtrunc);
return range_check (result, "IDINT");
gfc_expr *
+gfc_simplify_leadz (gfc_expr *e)
+{
+ gfc_expr *result;
+ unsigned long lz, bs;
+ int i;
+
+ if (e->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
+ bs = gfc_integer_kinds[i].bit_size;
+ if (mpz_cmp_si (e->value.integer, 0) == 0)
+ lz = bs;
+ else
+ lz = bs - mpz_sizeinbase (e->value.integer, 2);
+
+ result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, &e->where);
+ mpz_set_ui (result->value.integer, lz);
+
+ return result;
+}
+
+
+gfc_expr *
gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
{
gfc_expr *result;
gfc_expr *
gfc_simplify_lgamma (gfc_expr *x ATTRIBUTE_UNUSED)
{
-#if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0)
gfc_expr *result;
int sg;
mpfr_lgamma (result->value.real, &sg, x->value.real, GFC_RND_MODE);
return range_check (result, "LGAMMA");
-#else
- return NULL;
-#endif
}
}
+/* Selects bewteen current value and extremum for simplify_min_max
+ and simplify_minval_maxval. */
+static void
+min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign)
+{
+ switch (arg->ts.type)
+ {
+ case BT_INTEGER:
+ if (mpz_cmp (arg->value.integer,
+ extremum->value.integer) * sign > 0)
+ mpz_set (extremum->value.integer, arg->value.integer);
+ break;
+
+ case BT_REAL:
+ /* We need to use mpfr_min and mpfr_max to treat NaN properly. */
+ if (sign > 0)
+ mpfr_max (extremum->value.real, extremum->value.real,
+ arg->value.real, GFC_RND_MODE);
+ else
+ mpfr_min (extremum->value.real, extremum->value.real,
+ arg->value.real, GFC_RND_MODE);
+ break;
+
+ case BT_CHARACTER:
+#define LENGTH(x) ((x)->value.character.length)
+#define STRING(x) ((x)->value.character.string)
+ if (LENGTH(extremum) < LENGTH(arg))
+ {
+ gfc_char_t *tmp = STRING(extremum);
+
+ STRING(extremum) = gfc_get_wide_string (LENGTH(arg) + 1);
+ memcpy (STRING(extremum), tmp,
+ LENGTH(extremum) * sizeof (gfc_char_t));
+ gfc_wide_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, extremum) * sign > 0)
+ {
+ gfc_free (STRING(extremum));
+ STRING(extremum) = gfc_get_wide_string (LENGTH(extremum) + 1);
+ memcpy (STRING(extremum), STRING(arg),
+ LENGTH(arg) * sizeof (gfc_char_t));
+ gfc_wide_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 ("simplify_min_max(): Bad type in arglist");
+ }
+}
+
+
/* This function is special since MAX() can take any number of
arguments. The simplified expression is a rewritten version of the
argument list containing at most one constant element. Other
continue;
}
- switch (arg->expr->ts.type)
- {
- case BT_INTEGER:
- 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:
- /* 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))
- {
- gfc_char_t *tmp = STRING(extremum);
-
- STRING(extremum) = gfc_get_wide_string (LENGTH(arg) + 1);
- memcpy (STRING(extremum), tmp,
- LENGTH(extremum) * sizeof (gfc_char_t));
- gfc_wide_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_get_wide_string (LENGTH(extremum) + 1);
- memcpy (STRING(extremum), STRING(arg),
- LENGTH(arg) * sizeof (gfc_char_t));
- gfc_wide_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 ("simplify_min_max(): Bad type in arglist");
- }
+ min_max_choose (arg->expr, extremum->expr, sign);
/* Delete the extra constant argument. */
if (last == NULL)
}
+/* This is a simplified version of simplify_min_max to provide
+ simplification of minval and maxval for a vector. */
+
+static gfc_expr *
+simplify_minval_maxval (gfc_expr *expr, int sign)
+{
+ gfc_constructor *ctr, *extremum;
+ gfc_intrinsic_sym * specific;
+
+ extremum = NULL;
+ specific = expr->value.function.isym;
+
+ ctr = expr->value.constructor;
+
+ for (; ctr; ctr = ctr->next)
+ {
+ if (ctr->expr->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ if (extremum == NULL)
+ {
+ extremum = ctr;
+ continue;
+ }
+
+ min_max_choose (ctr->expr, extremum->expr, sign);
+ }
+
+ if (extremum == NULL)
+ return NULL;
+
+ /* Convert to the correct type and kind. */
+ if (expr->ts.type != BT_UNKNOWN)
+ return gfc_convert_constant (extremum->expr,
+ expr->ts.type, expr->ts.kind);
+
+ if (specific->ts.type != BT_UNKNOWN)
+ return gfc_convert_constant (extremum->expr,
+ specific->ts.type, specific->ts.kind);
+
+ return gfc_copy_expr (extremum->expr);
+}
+
+
+gfc_expr *
+gfc_simplify_minval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
+{
+ if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask)
+ return NULL;
+
+ return simplify_minval_maxval (array, -1);
+}
+
+
+gfc_expr *
+gfc_simplify_maxval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
+{
+ if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask)
+ return NULL;
+ return simplify_minval_maxval (array, 1);
+}
+
+
gfc_expr *
gfc_simplify_maxexponent (gfc_expr *x)
{
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);
+ mpfr_check_range (result->value.real, 0, GMP_RNDU);
if (mpfr_sgn (s->value.real) > 0)
{
mpfr_round (itrunc->value.real, e->value.real);
- gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real);
+ gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real, &e->where);
gfc_free_expr (itrunc);
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;
gfc_expr *
+gfc_simplify_trailz (gfc_expr *e)
+{
+ gfc_expr *result;
+ unsigned long tz, bs;
+ int i;
+
+ if (e->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
+ bs = gfc_integer_kinds[i].bit_size;
+ tz = mpz_scan1 (e->value.integer, 0);
+
+ result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, &e->where);
+ mpz_set_ui (result->value.integer, MIN (tz, bs));
+
+ return result;
+}
+
+
+gfc_expr *
gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
{
gfc_expr *result;
OSDN Git Service
