/* 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:
{
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
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)
{
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)
{
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. */
gfc_expr *
-gfc_simplify_iachar (gfc_expr *e)
+gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind)
{
gfc_expr *result;
int index;
gfc_warning ("Argument of IACHAR function at %L outside of range 0..127",
&e->where);
- result = gfc_int_expr (index);
+ if ((result = int_expr_with_kind (index, kind, "IACHAR")) == NULL)
+ return &gfc_bad_expr;
+
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;
if (index < 0 || index > UCHAR_MAX)
gfc_internal_error("Argument of ICHAR at %L out of range", &e->where);
- result = gfc_int_expr (index);
+ if ((result = int_expr_with_kind (index, kind, "ICHAR")) == NULL)
+ return &gfc_bad_expr;
+
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_dim (gfc_expr *array, int d, int upper, gfc_array_spec *as)
+simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
+ gfc_array_spec *as)
{
gfc_expr *l, *u, *result;
+ int k;
/* The last dimension of an assumed-size array is special. */
if (d == as->rank && as->type == AS_ASSUMED_SIZE && !upper)
if (l->expr_type != EXPR_CONSTANT || u->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
- &array->where);
+ 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)
{
static gfc_expr *
-simplify_bound (gfc_expr *array, gfc_expr *dim, int upper)
+simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
{
gfc_ref *ref;
gfc_array_spec *as;
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)
/* Simplify the bounds for each dimension. */
for (d = 0; d < array->rank; d++)
{
- bounds[d] = simplify_bound_dim (array, d + 1, upper, as);
+ bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as);
if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
{
int j;
e->where = array->where;
e->expr_type = EXPR_ARRAY;
e->ts.type = BT_INTEGER;
- e->ts.kind = gfc_default_integer_kind;
+ 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. */
return &gfc_bad_expr;
}
- return simplify_bound_dim (array, d, upper, as);
+ 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");
}
&& 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");
}
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)
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 ();
+
+ /* 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 range_check (result, "NEAREST");
+ 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;
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;
}
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);
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;