result->value.logical = x->value.logical && y->value.logical;
return 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);
-
if (mpfr_sgn (y->value.real) == 0 && mpfr_sgn (x->value.real) == 0)
{
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;
}
+ result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+
mpfr_atan2 (result->value.real, y->value.real, x->value.real, GFC_RND_MODE);
return range_check (result, "ATAN2");
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)
return NULL;
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
- gfc_set_model_kind (x->ts.kind);
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)
return NULL;
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
- gfc_set_model_kind (x->ts.kind);
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;
n = mpz_get_si (order->value.integer);
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
- gfc_set_model_kind (x->ts.kind);
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)
return NULL;
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
- gfc_set_model_kind (x->ts.kind);
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)
return NULL;
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
- gfc_set_model_kind (x->ts.kind);
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;
n = mpz_get_si (order->value.integer);
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
- gfc_set_model_kind (x->ts.kind);
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:
static gfc_expr *
only_convert_cmplx_boz (gfc_expr *x, gfc_expr *y, int kind)
{
- if (x->is_boz)
- {
- gfc_typespec ts;
- gfc_clear_ts (&ts);
- ts.type = BT_REAL;
- ts.kind = kind;
- if (!gfc_convert_boz (x, &ts))
- return &gfc_bad_expr;
- }
+ gfc_typespec ts;
+ gfc_clear_ts (&ts);
+ ts.type = BT_REAL;
+ ts.kind = kind;
- if (y && y->is_boz)
- {
- gfc_typespec ts;
- gfc_clear_ts (&ts);
- ts.type = BT_REAL;
- ts.kind = kind;
- if (!gfc_convert_boz (y, &ts))
- return &gfc_bad_expr;
- }
+ if (x->is_boz && !gfc_convert_boz (x, &ts))
+ return &gfc_bad_expr;
+
+ if (y && y->is_boz && !gfc_convert_boz (y, &ts))
+ return &gfc_bad_expr;
return NULL;
}
mpfr_mul (xp, xp, xq, GFC_RND_MODE);
mpfr_neg (result->value.complex.i, xp, GFC_RND_MODE );
- mpfr_clear (xp);
- mpfr_clear (xq);
+ mpfr_clears (xp, xq, NULL);
break;
default:
gfc_internal_error ("in gfc_simplify_cos(): Bad type");
gfc_expr *
gfc_simplify_dble (gfc_expr *e)
{
- gfc_expr *result;
+ gfc_expr *result = NULL;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
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);
+ mpfr_clears (xp, xq, NULL);
break;
default:
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);
result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
- gfc_set_model_kind (x->ts.kind);
-
if (mpfr_sgn (x->value.real) == 0)
{
mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
return result;
}
+ gfc_set_model_kind (x->ts.kind);
mpfr_init (exp);
mpfr_init (absv);
mpfr_init (pow2);
mpfr_div (result->value.real, absv, pow2, GFC_RND_MODE);
- mpfr_clear (exp);
- mpfr_clear (absv);
- mpfr_clear (pow2);
+ mpfr_clears (exp, absv, pow2, NULL);
return range_check (result, "FRACTION");
}
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");
convert_mpz_to_unsigned (result->value.integer,
gfc_integer_kinds[k].bit_size);
- bits = gfc_getmem (bitsize * sizeof (int));
+ bits = XCNEWVEC (int, bitsize);
for (i = 0; i < bitsize; i++)
bits[i] = 0;
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");
return range_check (result, "ISHFT");
}
- bits = gfc_getmem (isize * sizeof (int));
+ bits = XCNEWVEC (int, isize);
for (i = 0; i < isize; i++)
bits[i] = mpz_tstbit (e->value.integer, i);
convert_mpz_to_unsigned (result->value.integer, isize);
- bits = gfc_getmem (ssize * sizeof (int));
+ bits = XCNEWVEC (int, ssize);
for (i = 0; i < ssize; i++)
bits[i] = mpz_tstbit (e->value.integer, i);
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;
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
}
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
- gfc_set_model_kind (x->ts.kind);
switch (x->ts.type)
{
return &gfc_bad_expr;
}
+ gfc_set_model_kind (x->ts.kind);
mpfr_init (xr);
mpfr_init (xi);
mpfr_sqrt (xr, xr, GFC_RND_MODE);
mpfr_log (result->value.complex.r, xr, GFC_RND_MODE);
- mpfr_clear (xr);
- mpfr_clear (xi);
+ mpfr_clears (xr, xi, NULL);
break;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- 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 "
}
+/* 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)
{
gfc_simplify_mod (gfc_expr *a, gfc_expr *p)
{
gfc_expr *result;
- mpfr_t quot, iquot, term;
+ mpfr_t tmp;
int kind;
if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
}
gfc_set_model_kind (kind);
- mpfr_init (quot);
- mpfr_init (iquot);
- mpfr_init (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);
-
- mpfr_clear (quot);
- mpfr_clear (iquot);
- mpfr_clear (term);
+ mpfr_init (tmp);
+ mpfr_div (tmp, a->value.real, p->value.real, GFC_RND_MODE);
+ mpfr_trunc (tmp, tmp);
+ mpfr_mul (tmp, tmp, p->value.real, GFC_RND_MODE);
+ mpfr_sub (result->value.real, a->value.real, tmp, GFC_RND_MODE);
+ mpfr_clear (tmp);
break;
default:
gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
{
gfc_expr *result;
- mpfr_t quot, iquot, term;
+ mpfr_t tmp;
int kind;
if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
}
gfc_set_model_kind (kind);
- mpfr_init (quot);
- mpfr_init (iquot);
- mpfr_init (term);
-
- 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);
-
- mpfr_clear (quot);
- mpfr_clear (iquot);
- mpfr_clear (term);
+ mpfr_init (tmp);
+ mpfr_div (tmp, a->value.real, p->value.real, GFC_RND_MODE);
+ mpfr_floor (tmp, tmp);
+ mpfr_mul (tmp, tmp, p->value.real, GFC_RND_MODE);
+ mpfr_sub (result->value.real, a->value.real, tmp, GFC_RND_MODE);
+ mpfr_clear (tmp);
break;
default:
return &gfc_bad_expr;
}
- gfc_set_model_kind (x->ts.kind);
result = gfc_copy_expr (x);
/* Save current values of emin and emax. */
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);
gfc_expr *
gfc_simplify_real (gfc_expr *e, gfc_expr *k)
{
- gfc_expr *result;
+ gfc_expr *result = NULL;
int kind;
if (e->ts.type == BT_COMPLEX)
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;
else
mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE);
- mpfr_clear (scale);
- mpfr_clear (radix);
+ mpfr_clears (scale, radix, NULL);
return range_check (result, "SCALE");
}
if (gfc_compare_with_Cstring (e, "ascii", false) == 0
|| gfc_compare_with_Cstring (e, "default", false) == 0)
kind = 1;
+ else if (gfc_compare_with_Cstring (e, "iso_10646", false) == 0)
+ kind = 4;
else
kind = -1;
result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
- gfc_set_model_kind (x->ts.kind);
-
if (mpfr_sgn (x->value.real) == 0)
{
mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
return result;
}
+ gfc_set_model_kind (x->ts.kind);
mpfr_init (absv);
mpfr_init (log2);
mpfr_init (exp);
exp2 = (unsigned long) mpz_get_d (i->value.integer);
mpfr_mul_2exp (result->value.real, frac, exp2, GFC_RND_MODE);
- mpfr_clear (absv);
- mpfr_clear (log2);
- mpfr_clear (pow2);
- mpfr_clear (frac);
+ mpfr_clears (absv, log2, pow2, frac, NULL);
return range_check (result, "SET_EXPONENT");
}
gfc_expr *result, *e, *f;
gfc_array_ref *ar;
int n;
- try t;
+ gfc_try t;
if (source->rank == 0)
return gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind,
mpfr_sinh (xq, x->value.complex.i, GFC_RND_MODE);
mpfr_mul (result->value.complex.i, xp, xq, GFC_RND_MODE);
- mpfr_clear (xp);
- mpfr_clear (xq);
+ mpfr_clears (xp, xq, NULL);
break;
default:
gfc_internal_error ("invalid complex argument of SQRT at %L",
&e->where);
- mpfr_clear (s);
- mpfr_clear (t);
- mpfr_clear (ac);
- mpfr_clear (ad);
- mpfr_clear (w);
+ mpfr_clears (s, t, ac, ad, w, NULL);
break;
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;
if (!gfc_is_constant_expr (e))
return NULL;
- result = gfc_constant_result (BT_CHARACTER, kind, &e->where);
- if (result == NULL)
- return &gfc_bad_expr;
-
- result->value.character.length = e->value.character.length;
- result->value.character.string
- = gfc_get_wide_string (e->value.character.length + 1);
- memcpy (result->value.character.string, e->value.character.string,
- (e->value.character.length + 1) * sizeof (gfc_char_t));
-
- /* Check we only have values representable in the destination kind. */
- for (i = 0; i < result->value.character.length; i++)
- if (!gfc_check_character_range (result->value.character.string[i], kind))
- {
- gfc_error ("Character '%s' in string at %L cannot be converted into "
- "character kind %d",
- gfc_print_wide_char (result->value.character.string[i]),
- &e->where, kind);
+ if (e->expr_type == EXPR_CONSTANT)
+ {
+ /* Simple case of a scalar. */
+ result = gfc_constant_result (BT_CHARACTER, kind, &e->where);
+ if (result == NULL)
return &gfc_bad_expr;
- }
- return result;
+ result->value.character.length = e->value.character.length;
+ result->value.character.string
+ = gfc_get_wide_string (e->value.character.length + 1);
+ memcpy (result->value.character.string, e->value.character.string,
+ (e->value.character.length + 1) * sizeof (gfc_char_t));
+
+ /* Check we only have values representable in the destination kind. */
+ for (i = 0; i < result->value.character.length; i++)
+ if (!gfc_check_character_range (result->value.character.string[i],
+ kind))
+ {
+ gfc_error ("Character '%s' in string at %L cannot be converted "
+ "into character kind %d",
+ gfc_print_wide_char (result->value.character.string[i]),
+ &e->where, kind);
+ return &gfc_bad_expr;
+ }
+
+ return result;
+ }
+ else if (e->expr_type == EXPR_ARRAY)
+ {
+ /* For an array constructor, we convert each constructor element. */
+ gfc_constructor *head = NULL, *tail = NULL, *c;
+
+ for (c = e->value.constructor; c; c = c->next)
+ {
+ if (head == NULL)
+ head = tail = gfc_get_constructor ();
+ else
+ {
+ tail->next = gfc_get_constructor ();
+ tail = tail->next;
+ }
+
+ tail->where = c->where;
+ tail->expr = gfc_convert_char_constant (c->expr, type, kind);
+ if (tail->expr == &gfc_bad_expr)
+ {
+ tail->expr = NULL;
+ return &gfc_bad_expr;
+ }
+
+ if (tail->expr == NULL)
+ {
+ gfc_free_constructor (head);
+ return NULL;
+ }
+ }
+
+ result = gfc_get_expr ();
+ result->ts.type = type;
+ result->ts.kind = kind;
+ result->expr_type = EXPR_ARRAY;
+ result->value.constructor = head;
+ result->shape = gfc_copy_shape (e->shape, e->rank);
+ result->where = e->where;
+ result->rank = e->rank;
+ result->ts.cl = e->ts.cl;
+
+ return result;
+ }
+ else
+ return NULL;
}
OSDN Git Service
