/* Intrinsic function resolution.
- 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 void
check_charlen_present (gfc_expr *source)
{
- if (source->expr_type == EXPR_CONSTANT && source->ts.cl == NULL)
+ if (source->ts.cl == NULL)
{
source->ts.cl = gfc_get_charlen ();
source->ts.cl->next = gfc_current_ns->cl_list;
gfc_current_ns->cl_list = source->ts.cl;
+ }
+
+ if (source->expr_type == EXPR_CONSTANT)
+ {
source->ts.cl->length = gfc_int_expr (source->value.character.length);
source->rank = 0;
}
+ else if (source->expr_type == EXPR_ARRAY)
+ source->ts.cl->length =
+ gfc_int_expr (source->value.constructor->expr->value.character.length);
}
/* Helper function for resolving the "mask" argument. */
static void
resolve_mask_arg (gfc_expr *mask)
{
- int newkind;
- /* The mask can be kind 4 or 8 for the array case.
- For the scalar case, coerce it to kind=4 unconditionally
- (because this is the only kind we have a library function
- for). */
-
- newkind = 0;
+ gfc_typespec ts;
+ gfc_clear_ts (&ts);
if (mask->rank == 0)
{
+ /* For the scalar case, coerce the mask to kind=4 unconditionally
+ (because this is the only kind we have a library function
+ for). */
+
if (mask->ts.kind != 4)
- newkind = 4;
+ {
+ ts.type = BT_LOGICAL;
+ ts.kind = 4;
+ gfc_convert_type (mask, &ts, 2);
+ }
}
else
{
- if (mask->ts.kind < 4)
- newkind = gfc_default_logical_kind;
- }
-
- if (newkind)
- {
- gfc_typespec ts;
-
- ts.type = BT_LOGICAL;
- ts.kind = newkind;
- gfc_convert_type (mask, &ts, 2);
+ /* In the library, we access the mask with a GFC_LOGICAL_1
+ argument. No need to waste memory if we are about to create
+ a temporary array. */
+ if (mask->expr_type == EXPR_OP && mask->ts.kind != 1)
+ {
+ ts.type = BT_LOGICAL;
+ ts.kind = 1;
+ gfc_convert_type (mask, &ts, 2);
+ }
}
}
void
-gfc_resolve_achar (gfc_expr *f, gfc_expr *x)
+gfc_resolve_adjustl (gfc_expr *f, gfc_expr *string)
{
-
f->ts.type = BT_CHARACTER;
- f->ts.kind = gfc_default_character_kind;
+ f->ts.kind = string->ts.kind;
+ f->value.function.name = gfc_get_string ("__adjustl_s%d", f->ts.kind);
+}
+
+
+void
+gfc_resolve_adjustr (gfc_expr *f, gfc_expr *string)
+{
+ f->ts.type = BT_CHARACTER;
+ f->ts.kind = string->ts.kind;
+ f->value.function.name = gfc_get_string ("__adjustr_s%d", f->ts.kind);
+}
+
+
+static void
+gfc_resolve_char_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind,
+ const char *name)
+{
+ f->ts.type = BT_CHARACTER;
+ f->ts.kind = (kind == NULL)
+ ? gfc_default_character_kind : mpz_get_si (kind->value.integer);
f->ts.cl = gfc_get_charlen ();
f->ts.cl->next = gfc_current_ns->cl_list;
gfc_current_ns->cl_list = f->ts.cl;
f->ts.cl->length = gfc_int_expr (1);
- f->value.function.name
- = gfc_get_string ("__achar_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
+ f->value.function.name = gfc_get_string (name, f->ts.kind,
+ gfc_type_letter (x->ts.type),
+ x->ts.kind);
+}
+
+
+void
+gfc_resolve_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind)
+{
+ gfc_resolve_char_achar (f, x, kind, "__achar_%d_%c%d");
}
gfc_resolve_aint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
{
gfc_typespec ts;
+ gfc_clear_ts (&ts);
f->ts.type = a->ts.type;
f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
gfc_resolve_anint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
{
gfc_typespec ts;
+ gfc_clear_ts (&ts);
f->ts.type = a->ts.type;
f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
gfc_resolve_besn (gfc_expr *f, gfc_expr *n, gfc_expr *x)
{
gfc_typespec ts;
+ gfc_clear_ts (&ts);
f->ts = x->ts;
if (n->ts.kind != gfc_c_int_kind)
void
gfc_resolve_char (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
{
- f->ts.type = BT_CHARACTER;
- f->ts.kind = (kind == NULL)
- ? gfc_default_character_kind : mpz_get_si (kind->value.integer);
- f->value.function.name
- = gfc_get_string ("__char_%d_%c%d", f->ts.kind,
- gfc_type_letter (a->ts.type), a->ts.kind);
+ gfc_resolve_char_achar (f, a, kind, "__char_%d_%c%d");
}
void
-gfc_resolve_count (gfc_expr *f, gfc_expr *mask, gfc_expr *dim)
+gfc_resolve_count (gfc_expr *f, gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
{
f->ts.type = BT_INTEGER;
- f->ts.kind = gfc_default_integer_kind;
+ if (kind)
+ f->ts.kind = mpz_get_si (kind->value.integer);
+ else
+ f->ts.kind = gfc_default_integer_kind;
if (dim != NULL)
{
f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
}
+ resolve_mask_arg (mask);
+
f->value.function.name
- = gfc_get_string (PREFIX ("count_%d_%c%d"), f->ts.kind,
- gfc_type_letter (mask->ts.type), mask->ts.kind);
+ = gfc_get_string (PREFIX ("count_%d_%c"), f->ts.kind,
+ gfc_type_letter (mask->ts.type));
}
gfc_resolve_cshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
gfc_expr *dim)
{
- int n;
+ int n, m;
+
+ if (array->ts.type == BT_CHARACTER && array->ref)
+ gfc_resolve_substring_charlen (array);
f->ts = array->ts;
f->rank = array->rank;
else
n = 0;
- /* Convert shift to at least gfc_default_integer_kind, so we don't need
- kind=1 and kind=2 versions of the library functions. */
- if (shift->ts.kind < gfc_default_integer_kind)
+ /* If dim kind is greater than default integer we need to use the larger. */
+ m = gfc_default_integer_kind;
+ if (dim != NULL)
+ m = m < dim->ts.kind ? dim->ts.kind : m;
+
+ /* Convert shift to at least m, so we don't need
+ kind=1 and kind=2 versions of the library functions. */
+ if (shift->ts.kind < m)
{
gfc_typespec ts;
+ gfc_clear_ts (&ts);
ts.type = BT_INTEGER;
- ts.kind = gfc_default_integer_kind;
+ ts.kind = m;
gfc_convert_type_warn (shift, &ts, 2, 0);
}
-
+
if (dim != NULL)
{
- gfc_resolve_dim_arg (dim);
- /* Convert dim to shift's kind, so we don't need so many variations. */
- if (dim->ts.kind != shift->ts.kind)
- gfc_convert_type_warn (dim, &shift->ts, 2, 0);
+ if (dim->expr_type != EXPR_CONSTANT && dim->symtree != NULL
+ && dim->symtree->n.sym->attr.optional)
+ {
+ /* Mark this for later setting the type in gfc_conv_missing_dummy. */
+ dim->representation.length = shift->ts.kind;
+ }
+ else
+ {
+ gfc_resolve_dim_arg (dim);
+ /* Convert dim to shift's kind to reduce variations. */
+ if (dim->ts.kind != shift->ts.kind)
+ gfc_convert_type_warn (dim, &shift->ts, 2, 0);
+ }
}
- f->value.function.name
- = gfc_get_string (PREFIX ("cshift%d_%d%s"), n, shift->ts.kind,
- array->ts.type == BT_CHARACTER ? "_char" : "");
+
+ if (array->ts.type == BT_CHARACTER)
+ {
+ if (array->ts.kind == gfc_default_character_kind)
+ f->value.function.name
+ = gfc_get_string (PREFIX ("cshift%d_%d_char"), n, shift->ts.kind);
+ else
+ f->value.function.name
+ = gfc_get_string (PREFIX ("cshift%d_%d_char%d"), n, shift->ts.kind,
+ array->ts.kind);
+ }
+ else
+ f->value.function.name
+ = gfc_get_string (PREFIX ("cshift%d_%d"), n, shift->ts.kind);
}
gfc_resolve_ctime (gfc_expr *f, gfc_expr *time)
{
gfc_typespec ts;
+ gfc_clear_ts (&ts);
f->ts.type = BT_CHARACTER;
f->ts.kind = gfc_default_character_kind;
temp.expr_type = EXPR_OP;
gfc_clear_ts (&temp.ts);
- temp.value.op.operator = INTRINSIC_NONE;
+ temp.value.op.op = INTRINSIC_NONE;
temp.value.op.op1 = a;
temp.value.op.op2 = b;
gfc_type_convert_binary (&temp);
gfc_resolve_eoshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
gfc_expr *boundary, gfc_expr *dim)
{
- int n;
+ int n, m;
+
+ if (array->ts.type == BT_CHARACTER && array->ref)
+ gfc_resolve_substring_charlen (array);
f->ts = array->ts;
f->rank = array->rank;
if (boundary && boundary->rank > 0)
n = n | 2;
- /* Convert shift to at least gfc_default_integer_kind, so we don't need
- kind=1 and kind=2 versions of the library functions. */
- if (shift->ts.kind < gfc_default_integer_kind)
+ /* If dim kind is greater than default integer we need to use the larger. */
+ m = gfc_default_integer_kind;
+ if (dim != NULL)
+ m = m < dim->ts.kind ? dim->ts.kind : m;
+
+ /* Convert shift to at least m, so we don't need
+ kind=1 and kind=2 versions of the library functions. */
+ if (shift->ts.kind < m)
{
gfc_typespec ts;
+ gfc_clear_ts (&ts);
ts.type = BT_INTEGER;
- ts.kind = gfc_default_integer_kind;
+ ts.kind = m;
gfc_convert_type_warn (shift, &ts, 2, 0);
}
-
+
if (dim != NULL)
{
- gfc_resolve_dim_arg (dim);
- /* Convert dim to shift's kind, so we don't need so many variations. */
- if (dim->ts.kind != shift->ts.kind)
- gfc_convert_type_warn (dim, &shift->ts, 2, 0);
+ if (dim->expr_type != EXPR_CONSTANT && dim->symtree != NULL
+ && dim->symtree->n.sym->attr.optional)
+ {
+ /* Mark this for later setting the type in gfc_conv_missing_dummy. */
+ dim->representation.length = shift->ts.kind;
+ }
+ else
+ {
+ gfc_resolve_dim_arg (dim);
+ /* Convert dim to shift's kind to reduce variations. */
+ if (dim->ts.kind != shift->ts.kind)
+ gfc_convert_type_warn (dim, &shift->ts, 2, 0);
+ }
}
- f->value.function.name
- = gfc_get_string (PREFIX ("eoshift%d_%d%s"), n, shift->ts.kind,
- array->ts.type == BT_CHARACTER ? "_char" : "");
+ if (array->ts.type == BT_CHARACTER)
+ {
+ if (array->ts.kind == gfc_default_character_kind)
+ f->value.function.name
+ = gfc_get_string (PREFIX ("eoshift%d_%d_char"), n, shift->ts.kind);
+ else
+ f->value.function.name
+ = gfc_get_string (PREFIX ("eoshift%d_%d_char%d"), n, shift->ts.kind,
+ array->ts.kind);
+ }
+ else
+ f->value.function.name
+ = gfc_get_string (PREFIX ("eoshift%d_%d"), n, shift->ts.kind);
}
void
+gfc_resolve_gamma (gfc_expr *f, gfc_expr *x)
+{
+ f->ts = x->ts;
+ f->value.function.name
+ = gfc_get_string ("__gamma_%d", x->ts.kind);
+}
+
+
+void
gfc_resolve_getcwd (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
{
f->ts.type = BT_INTEGER;
void
+gfc_resolve_hypot (gfc_expr *f, gfc_expr *x, gfc_expr *y ATTRIBUTE_UNUSED)
+{
+ f->ts = x->ts;
+ f->value.function.name = gfc_get_string ("__hypot_r%d", x->ts.kind);
+}
+
+
+void
gfc_resolve_iand (gfc_expr *f, gfc_expr *i, gfc_expr *j)
{
/* If the kind of i and j are different, then g77 cross-promoted the
void
-gfc_resolve_ichar (gfc_expr *f, gfc_expr *c)
+gfc_resolve_iachar (gfc_expr *f, gfc_expr *c, gfc_expr *kind)
{
f->ts.type = BT_INTEGER;
- f->ts.kind = gfc_default_integer_kind;
+ if (kind)
+ f->ts.kind = mpz_get_si (kind->value.integer);
+ else
+ f->ts.kind = gfc_default_integer_kind;
+ f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind);
+}
+
+
+void
+gfc_resolve_ichar (gfc_expr *f, gfc_expr *c, gfc_expr *kind)
+{
+ f->ts.type = BT_INTEGER;
+ if (kind)
+ f->ts.kind = mpz_get_si (kind->value.integer);
+ else
+ f->ts.kind = gfc_default_integer_kind;
f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind);
}
void
gfc_resolve_index_func (gfc_expr *f, gfc_expr *str,
- gfc_expr *sub_str ATTRIBUTE_UNUSED, gfc_expr *back)
+ gfc_expr *sub_str ATTRIBUTE_UNUSED, gfc_expr *back,
+ gfc_expr *kind)
{
gfc_typespec ts;
+ gfc_clear_ts (&ts);
f->ts.type = BT_INTEGER;
- f->ts.kind = gfc_default_integer_kind;
+ if (kind)
+ f->ts.kind = mpz_get_si (kind->value.integer);
+ else
+ f->ts.kind = gfc_default_integer_kind;
if (back && back->ts.kind != gfc_default_integer_kind)
{
gfc_resolve_isatty (gfc_expr *f, gfc_expr *u)
{
gfc_typespec ts;
+ gfc_clear_ts (&ts);
f->ts.type = BT_LOGICAL;
f->ts.kind = gfc_default_integer_kind;
void
-gfc_resolve_lbound (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
+gfc_resolve_lbound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
{
static char lbound[] = "__lbound";
f->ts.type = BT_INTEGER;
- f->ts.kind = gfc_default_integer_kind;
+ if (kind)
+ f->ts.kind = mpz_get_si (kind->value.integer);
+ else
+ f->ts.kind = gfc_default_integer_kind;
if (dim == NULL)
{
void
-gfc_resolve_len (gfc_expr *f, gfc_expr *string)
+gfc_resolve_len (gfc_expr *f, gfc_expr *string, gfc_expr *kind)
{
f->ts.type = BT_INTEGER;
- f->ts.kind = gfc_default_integer_kind;
+ if (kind)
+ f->ts.kind = mpz_get_si (kind->value.integer);
+ else
+ f->ts.kind = gfc_default_integer_kind;
f->value.function.name
= gfc_get_string ("__len_%d_i%d", string->ts.kind,
gfc_default_integer_kind);
void
-gfc_resolve_len_trim (gfc_expr *f, gfc_expr *string)
+gfc_resolve_len_trim (gfc_expr *f, gfc_expr *string, gfc_expr *kind)
{
f->ts.type = BT_INTEGER;
- f->ts.kind = gfc_default_integer_kind;
+ if (kind)
+ f->ts.kind = mpz_get_si (kind->value.integer);
+ else
+ f->ts.kind = gfc_default_integer_kind;
f->value.function.name = gfc_get_string ("__len_trim%d", string->ts.kind);
}
void
+gfc_resolve_lgamma (gfc_expr *f, gfc_expr *x)
+{
+ f->ts = x->ts;
+ f->value.function.name
+ = gfc_get_string ("__lgamma_%d", x->ts.kind);
+}
+
+
+void
gfc_resolve_link (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
gfc_expr *p2 ATTRIBUTE_UNUSED)
{
if (size->ts.kind < gfc_index_integer_kind)
{
gfc_typespec ts;
+ gfc_clear_ts (&ts);
ts.type = BT_INTEGER;
ts.kind = gfc_index_integer_kind;
{
temp.expr_type = EXPR_OP;
gfc_clear_ts (&temp.ts);
- temp.value.op.operator = INTRINSIC_NONE;
+ temp.value.op.op = INTRINSIC_NONE;
temp.value.op.op1 = a;
temp.value.op.op2 = b;
gfc_type_convert_binary (&temp);
f->rank = (a->rank == 2 && b->rank == 2) ? 2 : 1;
+ if (a->rank == 2 && b->rank == 2)
+ {
+ if (a->shape && b->shape)
+ {
+ f->shape = gfc_get_shape (f->rank);
+ mpz_init_set (f->shape[0], a->shape[0]);
+ mpz_init_set (f->shape[1], b->shape[1]);
+ }
+ }
+ else if (a->rank == 1)
+ {
+ if (b->shape)
+ {
+ f->shape = gfc_get_shape (f->rank);
+ mpz_init_set (f->shape[0], b->shape[1]);
+ }
+ }
+ else
+ {
+ /* b->rank == 1 and a->rank == 2 here, all other cases have
+ been caught in check.c. */
+ if (a->shape)
+ {
+ f->shape = gfc_get_shape (f->rank);
+ mpz_init_set (f->shape[0], a->shape[0]);
+ }
+ }
+
f->value.function.name
= gfc_get_string (PREFIX ("matmul_%c%d"), gfc_type_letter (f->ts.type),
f->ts.kind);
gfc_expr *fsource ATTRIBUTE_UNUSED,
gfc_expr *mask ATTRIBUTE_UNUSED)
{
+ if (tsource->ts.type == BT_CHARACTER && tsource->ref)
+ gfc_resolve_substring_charlen (tsource);
+
+ if (fsource->ts.type == BT_CHARACTER && fsource->ref)
+ gfc_resolve_substring_charlen (fsource);
+
if (tsource->ts.type == BT_CHARACTER)
check_charlen_present (tsource);
}
void
-gfc_resolve_nearest (gfc_expr *f, gfc_expr *a, gfc_expr *p ATTRIBUTE_UNUSED)
+gfc_resolve_nearest (gfc_expr *f, gfc_expr *a, gfc_expr *p)
{
+ if (p->ts.kind != a->ts.kind)
+ gfc_convert_type (p, &a->ts, 2);
+
f->ts = a->ts;
f->value.function.name
= gfc_get_string ("__nearest_%c%d", gfc_type_letter (a->ts.type),
gfc_resolve_pack (gfc_expr *f, gfc_expr *array, gfc_expr *mask,
gfc_expr *vector ATTRIBUTE_UNUSED)
{
+ if (array->ts.type == BT_CHARACTER && array->ref)
+ gfc_resolve_substring_charlen (array);
+
f->ts = array->ts;
f->rank = 1;
resolve_mask_arg (mask);
if (mask->rank != 0)
- f->value.function.name = (array->ts.type == BT_CHARACTER
- ? PREFIX ("pack_char") : PREFIX ("pack"));
+ {
+ if (array->ts.type == BT_CHARACTER)
+ f->value.function.name
+ = array->ts.kind == 1 ? PREFIX ("pack_char")
+ : gfc_get_string
+ (PREFIX ("pack_char%d"),
+ array->ts.kind);
+ else
+ f->value.function.name = PREFIX ("pack");
+ }
else
- f->value.function.name = (array->ts.type == BT_CHARACTER
- ? PREFIX ("pack_s_char") : PREFIX ("pack_s"));
+ {
+ if (array->ts.type == BT_CHARACTER)
+ f->value.function.name
+ = array->ts.kind == 1 ? PREFIX ("pack_s_char")
+ : gfc_get_string
+ (PREFIX ("pack_s_char%d"),
+ array->ts.kind);
+ else
+ f->value.function.name = PREFIX ("pack_s");
+ }
}
if (dim != NULL)
{
f->rank = array->rank - 1;
+ f->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
gfc_resolve_dim_arg (dim);
}
int kind;
int i;
+ if (source->ts.type == BT_CHARACTER && source->ref)
+ gfc_resolve_substring_charlen (source);
+
f->ts = source->ts;
gfc_array_size (shape, &rank);
case BT_REAL:
case BT_INTEGER:
case BT_LOGICAL:
+ case BT_CHARACTER:
kind = source->ts.kind;
break;
= gfc_get_string (PREFIX ("reshape_%c%d"),
gfc_type_letter (source->ts.type),
source->ts.kind);
+ else if (source->ts.type == BT_CHARACTER)
+ f->value.function.name = gfc_get_string (PREFIX ("reshape_char%d"),
+ kind);
else
f->value.function.name
= gfc_get_string (PREFIX ("reshape_%d"), source->ts.kind);
-
break;
default:
f->value.function.name = (source->ts.type == BT_CHARACTER
- ? PREFIX ("reshape_char") : PREFIX ("reshape"));
+ ? PREFIX ("reshape_char") : PREFIX ("reshape"));
break;
}
void
gfc_resolve_rrspacing (gfc_expr *f, gfc_expr *x)
{
- int k;
- gfc_actual_arglist *prec;
-
f->ts = x->ts;
f->value.function.name = gfc_get_string ("__rrspacing_%d", x->ts.kind);
-
- /* Create a hidden argument to the library routines for rrspacing. This
- hidden argument is the precision of x. */
- k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
- prec = gfc_get_actual_arglist ();
- prec->name = "p";
- prec->expr = gfc_int_expr (gfc_real_kinds[k].digits);
- f->value.function.actual->next = prec;
}
void
-gfc_resolve_scale (gfc_expr *f, gfc_expr *x, gfc_expr *i)
+gfc_resolve_scale (gfc_expr *f, gfc_expr *x, gfc_expr *i ATTRIBUTE_UNUSED)
{
f->ts = x->ts;
-
- /* The implementation calls scalbn which takes an int as the
- second argument. */
- if (i->ts.kind != gfc_c_int_kind)
- {
- gfc_typespec ts;
- ts.type = BT_INTEGER;
- ts.kind = gfc_default_integer_kind;
- gfc_convert_type_warn (i, &ts, 2, 0);
- }
-
f->value.function.name = gfc_get_string ("__scale_%d", x->ts.kind);
}
void
gfc_resolve_scan (gfc_expr *f, gfc_expr *string,
gfc_expr *set ATTRIBUTE_UNUSED,
- gfc_expr *back ATTRIBUTE_UNUSED)
+ gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind)
{
f->ts.type = BT_INTEGER;
- f->ts.kind = gfc_default_integer_kind;
+ if (kind)
+ f->ts.kind = mpz_get_si (kind->value.integer);
+ else
+ f->ts.kind = gfc_default_integer_kind;
f->value.function.name = gfc_get_string ("__scan_%d", string->ts.kind);
}
void
-gfc_resolve_set_exponent (gfc_expr *f, gfc_expr *x, gfc_expr *i)
+gfc_resolve_set_exponent (gfc_expr *f, gfc_expr *x,
+ gfc_expr *i ATTRIBUTE_UNUSED)
{
f->ts = x->ts;
-
- /* The library implementation uses GFC_INTEGER_4 unconditionally,
- convert type so we don't have to implement all possible
- permutations. */
- if (i->ts.kind != 4)
- {
- gfc_typespec ts;
- ts.type = BT_INTEGER;
- ts.kind = gfc_default_integer_kind;
- gfc_convert_type_warn (i, &ts, 2, 0);
- }
-
f->value.function.name = gfc_get_string ("__set_exponent_%d", x->ts.kind);
}
void
+gfc_resolve_size (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
+ gfc_expr *dim ATTRIBUTE_UNUSED, gfc_expr *kind)
+{
+ f->ts.type = BT_INTEGER;
+ if (kind)
+ f->ts.kind = mpz_get_si (kind->value.integer);
+ else
+ f->ts.kind = gfc_default_integer_kind;
+}
+
+
+void
gfc_resolve_spacing (gfc_expr *f, gfc_expr *x)
{
- int k;
- gfc_actual_arglist *prec, *tiny, *emin_1;
-
f->ts = x->ts;
f->value.function.name = gfc_get_string ("__spacing_%d", x->ts.kind);
-
- /* Create hidden arguments to the library routine for spacing. These
- hidden arguments are tiny(x), min_exponent - 1, and the precision
- of x. */
-
- k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
-
- tiny = gfc_get_actual_arglist ();
- tiny->name = "tiny";
- tiny->expr = gfc_get_expr ();
- tiny->expr->expr_type = EXPR_CONSTANT;
- tiny->expr->where = gfc_current_locus;
- tiny->expr->ts.type = x->ts.type;
- tiny->expr->ts.kind = x->ts.kind;
- mpfr_init (tiny->expr->value.real);
- mpfr_set (tiny->expr->value.real, gfc_real_kinds[k].tiny, GFC_RND_MODE);
-
- emin_1 = gfc_get_actual_arglist ();
- emin_1->name = "emin";
- emin_1->expr = gfc_int_expr (gfc_real_kinds[k].min_exponent - 1);
- emin_1->next = tiny;
-
- prec = gfc_get_actual_arglist ();
- prec->name = "prec";
- prec->expr = gfc_int_expr (gfc_real_kinds[k].digits);
- prec->next = emin_1;
-
- f->value.function.actual->next = prec;
}
gfc_resolve_spread (gfc_expr *f, gfc_expr *source, gfc_expr *dim,
gfc_expr *ncopies)
{
+ if (source->ts.type == BT_CHARACTER && source->ref)
+ gfc_resolve_substring_charlen (source);
+
if (source->ts.type == BT_CHARACTER)
check_charlen_present (source);
f->ts = source->ts;
f->rank = source->rank + 1;
if (source->rank == 0)
- f->value.function.name = (source->ts.type == BT_CHARACTER
- ? PREFIX ("spread_char_scalar")
- : PREFIX ("spread_scalar"));
+ {
+ if (source->ts.type == BT_CHARACTER)
+ f->value.function.name
+ = source->ts.kind == 1 ? PREFIX ("spread_char_scalar")
+ : gfc_get_string
+ (PREFIX ("spread_char%d_scalar"),
+ source->ts.kind);
+ else
+ f->value.function.name = PREFIX ("spread_scalar");
+ }
else
- f->value.function.name = (source->ts.type == BT_CHARACTER
- ? PREFIX ("spread_char")
- : PREFIX ("spread"));
+ {
+ if (source->ts.type == BT_CHARACTER)
+ f->value.function.name
+ = source->ts.kind == 1 ? PREFIX ("spread_char")
+ : gfc_get_string
+ (PREFIX ("spread_char%d"),
+ source->ts.kind);
+ else
+ f->value.function.name = PREFIX ("spread");
+ }
if (dim && gfc_is_constant_expr (dim)
&& ncopies && gfc_is_constant_expr (ncopies) && source->shape[0])
gfc_resolve_fgetc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
{
gfc_typespec ts;
+ gfc_clear_ts (&ts);
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_c_int_kind;
gfc_resolve_fputc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
{
gfc_typespec ts;
+ gfc_clear_ts (&ts);
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_c_int_kind;
gfc_resolve_ftell (gfc_expr *f, gfc_expr *u)
{
gfc_typespec ts;
+ gfc_clear_ts (&ts);
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_index_integer_kind;
if (dim != NULL)
{
f->rank = array->rank - 1;
+ f->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
gfc_resolve_dim_arg (dim);
}
/* TODO: Make this do something meaningful. */
static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";
+ if (mold->ts.type == BT_CHARACTER && !mold->ts.cl->length
+ && !(mold->expr_type == EXPR_VARIABLE && mold->symtree->n.sym->attr.dummy))
+ mold->ts.cl->length = gfc_int_expr (mold->value.character.length);
+
f->ts = mold->ts;
if (size == NULL && mold->rank == 0)
void
gfc_resolve_transpose (gfc_expr *f, gfc_expr *matrix)
{
+
+ if (matrix->ts.type == BT_CHARACTER && matrix->ref)
+ gfc_resolve_substring_charlen (matrix);
+
f->ts = matrix->ts;
f->rank = 2;
if (matrix->shape)
break;
default:
- f->value.function.name = PREFIX ("transpose");
+ if (matrix->ts.type == BT_CHARACTER && matrix->ts.kind == 4)
+ f->value.function.name = PREFIX ("transpose_char4");
+ else
+ f->value.function.name = PREFIX ("transpose");
break;
}
break;
void
-gfc_resolve_ubound (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
+gfc_resolve_ubound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
{
static char ubound[] = "__ubound";
f->ts.type = BT_INTEGER;
- f->ts.kind = gfc_default_integer_kind;
+ if (kind)
+ f->ts.kind = mpz_get_si (kind->value.integer);
+ else
+ f->ts.kind = gfc_default_integer_kind;
if (dim == NULL)
{
gfc_resolve_ttynam (gfc_expr *f, gfc_expr *unit)
{
gfc_typespec ts;
+ gfc_clear_ts (&ts);
f->ts.type = BT_CHARACTER;
f->ts.kind = gfc_default_character_kind;
gfc_resolve_unpack (gfc_expr *f, gfc_expr *vector, gfc_expr *mask,
gfc_expr *field ATTRIBUTE_UNUSED)
{
+ if (vector->ts.type == BT_CHARACTER && vector->ref)
+ gfc_resolve_substring_charlen (vector);
+
f->ts = vector->ts;
f->rank = mask->rank;
resolve_mask_arg (mask);
- f->value.function.name
- = gfc_get_string (PREFIX ("unpack%d%s"), field->rank > 0 ? 1 : 0,
- vector->ts.type == BT_CHARACTER ? "_char" : "");
+ if (vector->ts.type == BT_CHARACTER)
+ {
+ if (vector->ts.kind == 1)
+ f->value.function.name
+ = gfc_get_string (PREFIX ("unpack%d_char"), field->rank > 0 ? 1 : 0);
+ else
+ f->value.function.name
+ = gfc_get_string (PREFIX ("unpack%d_char%d"),
+ field->rank > 0 ? 1 : 0, vector->ts.kind);
+ }
+ else
+ f->value.function.name
+ = gfc_get_string (PREFIX ("unpack%d"), field->rank > 0 ? 1 : 0);
}
void
gfc_resolve_verify (gfc_expr *f, gfc_expr *string,
gfc_expr *set ATTRIBUTE_UNUSED,
- gfc_expr *back ATTRIBUTE_UNUSED)
+ gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind)
{
f->ts.type = BT_INTEGER;
- f->ts.kind = gfc_default_integer_kind;
+ if (kind)
+ f->ts.kind = mpz_get_si (kind->value.integer);
+ else
+ f->ts.kind = gfc_default_integer_kind;
f->value.function.name = gfc_get_string ("__verify_%d", string->ts.kind);
}
const char *name;
gfc_expr *seconds, *handler, *status;
gfc_typespec ts;
+ gfc_clear_ts (&ts);
seconds = c->ext.actual->expr;
handler = c->ext.actual->next->expr;
ts.type = BT_INTEGER;
ts.kind = gfc_c_int_kind;
- /* handler can be either BT_INTEGER or BT_PROCEDURE */
+ /* handler can be either BT_INTEGER or BT_PROCEDURE.
+ In all cases, the status argument is of default integer kind
+ (enforced in check.c) so that the function suffix is fixed. */
if (handler->ts.type == BT_INTEGER)
{
if (handler->ts.kind != gfc_c_int_kind)
gfc_convert_type (handler, &ts, 2);
- name = gfc_get_string (PREFIX ("alarm_sub_int"));
+ name = gfc_get_string (PREFIX ("alarm_sub_int_i%d"),
+ gfc_default_integer_kind);
}
else
- name = gfc_get_string (PREFIX ("alarm_sub"));
+ name = gfc_get_string (PREFIX ("alarm_sub_i%d"),
+ gfc_default_integer_kind);
if (seconds->ts.kind != gfc_c_int_kind)
gfc_convert_type (seconds, &ts, 2);
}
+/* Create a formal arglist based on an actual one and set the INTENTs given. */
+
+static gfc_formal_arglist*
+create_formal_for_intents (gfc_actual_arglist* actual, const sym_intent* ints)
+{
+ gfc_formal_arglist* head;
+ gfc_formal_arglist* tail;
+ int i;
+
+ if (!actual)
+ return NULL;
+
+ head = tail = gfc_get_formal_arglist ();
+ for (i = 0; actual; actual = actual->next, tail = tail->next, ++i)
+ {
+ gfc_symbol* sym;
+
+ sym = gfc_new_symbol ("dummyarg", NULL);
+ sym->ts = actual->expr->ts;
+
+ sym->attr.intent = ints[i];
+ tail->sym = sym;
+
+ if (actual->next)
+ tail->next = gfc_get_formal_arglist ();
+ }
+
+ return head;
+}
+
+
void
gfc_resolve_mvbits (gfc_code *c)
{
+ static const sym_intent INTENTS[] = {INTENT_IN, INTENT_IN, INTENT_IN,
+ INTENT_INOUT, INTENT_IN};
+
const char *name;
gfc_typespec ts;
+ gfc_clear_ts (&ts);
/* FROMPOS, LEN and TOPOS are restricted to small values. As such,
they will be converted so that they fit into a C int. */
name = gfc_get_string (PREFIX ("mvbits_i%d"),
c->ext.actual->expr->ts.kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+ /* Mark as elemental subroutine as this does not happen automatically. */
+ c->resolved_sym->attr.elemental = 1;
+
+ /* Create a dummy formal arglist so the INTENTs are known later for purpose
+ of creating temporaries. */
+ c->resolved_sym->formal = create_formal_for_intents (c->ext.actual, INTENTS);
}
void
+gfc_resolve_random_seed (gfc_code *c)
+{
+ const char *name;
+
+ name = gfc_get_string (PREFIX ("random_seed_i%d"), gfc_default_integer_kind);
+ c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
+void
gfc_resolve_rename_sub (gfc_code *c)
{
const char *name;
}
-/* G77 compatibility subroutines etime() and dtime(). */
+/* G77 compatibility subroutines dtime() and etime(). */
+
+void
+gfc_resolve_dtime_sub (gfc_code *c)
+{
+ const char *name;
+ name = gfc_get_string (PREFIX ("dtime_sub"));
+ c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
void
gfc_resolve_etime_sub (gfc_code *c)
gfc_resolve_getarg (gfc_code *c)
{
const char *name;
- int kind;
- kind = gfc_default_integer_kind;
- name = gfc_get_string (PREFIX ("getarg_i%d"), kind);
+
+ if (c->ext.actual->expr->ts.kind != gfc_default_integer_kind)
+ {
+ gfc_typespec ts;
+ gfc_clear_ts (&ts);
+
+ ts.type = BT_INTEGER;
+ ts.kind = gfc_default_integer_kind;
+
+ gfc_convert_type (c->ext.actual->expr, &ts, 2);
+ }
+
+ name = gfc_get_string (PREFIX ("getarg_i%d"), gfc_default_integer_kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
const char *name;
gfc_expr *number, *handler, *status;
gfc_typespec ts;
+ gfc_clear_ts (&ts);
number = c->ext.actual->expr;
handler = c->ext.actual->next->expr;
gfc_resolve_exit (gfc_code *c)
{
const char *name;
- int kind;
+ gfc_typespec ts;
+ gfc_expr *n;
+ gfc_clear_ts (&ts);
- if (c->ext.actual->expr != NULL)
- kind = c->ext.actual->expr->ts.kind;
- else
- kind = gfc_default_integer_kind;
+ /* The STATUS argument has to be of default kind. If it is not,
+ we convert it. */
+ ts.type = BT_INTEGER;
+ ts.kind = gfc_default_integer_kind;
+ n = c->ext.actual->expr;
+ if (n != NULL && n->ts.kind != ts.kind)
+ gfc_convert_type (n, &ts, 2);
- name = gfc_get_string (PREFIX ("exit_i%d"), kind);
+ name = gfc_get_string (PREFIX ("exit_i%d"), ts.kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
const char *name;
gfc_typespec ts;
gfc_expr *n;
+ gfc_clear_ts (&ts);
ts.type = BT_INTEGER;
ts.kind = gfc_default_integer_kind;
{
gfc_typespec ts;
gfc_expr *n;
+ gfc_clear_ts (&ts);
ts.type = BT_INTEGER;
ts.kind = gfc_index_integer_kind;
gfc_resolve_ctime_sub (gfc_code *c)
{
gfc_typespec ts;
+ gfc_clear_ts (&ts);
/* ctime TIME argument is a INTEGER(KIND=8), says the doc */
if (c->ext.actual->expr->ts.kind != 8)
const char *name;
gfc_typespec ts;
gfc_expr *u, *st;
+ gfc_clear_ts (&ts);
u = c->ext.actual->expr;
st = c->ext.actual->next->next->expr;
const char *name;
gfc_typespec ts;
gfc_expr *u, *st;
+ gfc_clear_ts (&ts);
u = c->ext.actual->expr;
st = c->ext.actual->next->next->expr;
gfc_expr *whence;
gfc_expr *status;
gfc_typespec ts;
+ gfc_clear_ts (&ts);
unit = c->ext.actual->expr;
offset = c->ext.actual->next->expr;
gfc_expr *unit;
gfc_expr *offset;
gfc_typespec ts;
+ gfc_clear_ts (&ts);
unit = c->ext.actual->expr;
offset = c->ext.actual->next->expr;
gfc_resolve_ttynam_sub (gfc_code *c)
{
gfc_typespec ts;
+ gfc_clear_ts (&ts);
if (c->ext.actual->expr->ts.kind != gfc_c_int_kind)
{