/* 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
GCC is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
-Software Foundation; either version 2, or (at your option) any later
+Software Foundation; either version 3, or (at your option) any later
version.
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
for more details.
You should have received a copy of the GNU General Public License
-along with GCC; see the file COPYING. If not, write to the Free
-Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
-02110-1301, USA. */
+along with GCC; see the file COPYING3. If not see
+<http://www.gnu.org/licenses/>. */
/* Assign name and types to intrinsic procedures. For functions, the
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)
+{
+
+ 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)
+ {
+ ts.type = BT_LOGICAL;
+ ts.kind = 4;
+ gfc_convert_type (mask, &ts, 2);
+ }
+ }
+ else
+ {
+ /* 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);
+ }
+ }
}
/********************** Resolution functions **********************/
void
+gfc_resolve_adjustl (gfc_expr *f, gfc_expr *string)
+{
+ f->ts.type = BT_CHARACTER;
+ 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 (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");
+}
+
+
+void
gfc_resolve_acos (gfc_expr *f, gfc_expr *x)
{
f->ts = x->ts;
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;
{
int s_kind;
- s_kind = (size == NULL) ? gfc_default_integer_kind : shift->ts.kind;
+ s_kind = (size == NULL) ? gfc_default_integer_kind : size->ts.kind;
f->ts = i->ts;
f->value.function.name
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);
else
name = "mmaxloc";
- /* The mask can be kind 4 or 8 for the array case. For the
- scalar case, coerce it to default kind unconditionally. */
- if ((mask->ts.kind < gfc_default_logical_kind)
- || (mask->rank == 0 && mask->ts.kind != gfc_default_logical_kind))
- {
- gfc_typespec ts;
- ts.type = BT_LOGICAL;
- ts.kind = gfc_default_logical_kind;
- gfc_convert_type_warn (mask, &ts, 2, 0);
- }
+ resolve_mask_arg (mask);
}
else
name = "maxloc";
else
name = "mmaxval";
- /* The mask can be kind 4 or 8 for the array case. For the
- scalar case, coerce it to default kind unconditionally. */
- if ((mask->ts.kind < gfc_default_logical_kind)
- || (mask->rank == 0 && mask->ts.kind != gfc_default_logical_kind))
- {
- gfc_typespec ts;
- ts.type = BT_LOGICAL;
- ts.kind = gfc_default_logical_kind;
- gfc_convert_type_warn (mask, &ts, 2, 0);
- }
+ resolve_mask_arg (mask);
}
else
name = "maxval";
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);
else
name = "mminloc";
- /* The mask can be kind 4 or 8 for the array case. For the
- scalar case, coerce it to default kind unconditionally. */
- if ((mask->ts.kind < gfc_default_logical_kind)
- || (mask->rank == 0 && mask->ts.kind != gfc_default_logical_kind))
- {
- gfc_typespec ts;
- ts.type = BT_LOGICAL;
- ts.kind = gfc_default_logical_kind;
- gfc_convert_type_warn (mask, &ts, 2, 0);
- }
+ resolve_mask_arg (mask);
}
else
name = "minloc";
else
name = "mminval";
- /* The mask can be kind 4 or 8 for the array case. For the
- scalar case, coerce it to default kind unconditionally. */
- if ((mask->ts.kind < gfc_default_logical_kind)
- || (mask->rank == 0 && mask->ts.kind != gfc_default_logical_kind))
- {
- gfc_typespec ts;
- ts.type = BT_LOGICAL;
- ts.kind = gfc_default_logical_kind;
- gfc_convert_type_warn (mask, &ts, 2, 0);
- }
+ resolve_mask_arg (mask);
}
else
name = "minval";
}
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
{
- /* We convert mask to default logical only in the scalar case.
- In the array case we can simply read the array as if it were
- of type default logical. */
- if (mask->ts.kind != gfc_default_logical_kind)
- {
- gfc_typespec ts;
-
- ts.type = BT_LOGICAL;
- ts.kind = gfc_default_logical_kind;
- gfc_convert_type (mask, &ts, 2);
- }
-
- 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);
}
else
name = "mproduct";
- /* The mask can be kind 4 or 8 for the array case. For the
- scalar case, coerce it to default kind unconditionally. */
- if ((mask->ts.kind < gfc_default_logical_kind)
- || (mask->rank == 0 && mask->ts.kind != gfc_default_logical_kind))
- {
- gfc_typespec ts;
- ts.type = BT_LOGICAL;
- ts.kind = gfc_default_logical_kind;
- gfc_convert_type_warn (mask, &ts, 2, 0);
- }
+ resolve_mask_arg (mask);
}
else
name = "product";
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;
else
name = "msum";
- /* The mask can be kind 4 or 8 for the array case. For the
- scalar case, coerce it to default kind unconditionally. */
- if ((mask->ts.kind < gfc_default_logical_kind)
- || (mask->rank == 0 && mask->ts.kind != gfc_default_logical_kind))
- {
- gfc_typespec ts;
- ts.type = BT_LOGICAL;
- ts.kind = gfc_default_logical_kind;
- gfc_convert_type_warn (mask, &ts, 2, 0);
- }
+ resolve_mask_arg (mask);
}
else
name = "sum";
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);
- if (status != NULL && status->ts.kind != gfc_c_int_kind)
- gfc_convert_type (status, &ts, 2);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
gfc_resolve_mvbits (gfc_code *c)
{
const char *name;
- int kind;
- kind = c->ext.actual->expr->ts.kind;
- name = gfc_get_string (PREFIX ("mvbits_i%d"), kind);
+ 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. */
+ ts.type = BT_INTEGER;
+ ts.kind = gfc_c_int_kind;
+ if (c->ext.actual->next->expr->ts.kind != gfc_c_int_kind)
+ gfc_convert_type (c->ext.actual->next->expr, &ts, 2);
+ if (c->ext.actual->next->next->expr->ts.kind != gfc_c_int_kind)
+ gfc_convert_type (c->ext.actual->next->next->expr, &ts, 2);
+ if (c->ext.actual->next->next->next->next->expr->ts.kind != gfc_c_int_kind)
+ gfc_convert_type (c->ext.actual->next->next->next->next->expr, &ts, 2);
+
+ /* TO and FROM are guaranteed to have the same kind parameter. */
+ 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;
}
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;
}
+void
+gfc_resolve_fseek_sub (gfc_code *c)
+{
+ gfc_expr *unit;
+ gfc_expr *offset;
+ gfc_expr *whence;
+ gfc_expr *status;
+ gfc_typespec ts;
+ gfc_clear_ts (&ts);
+
+ unit = c->ext.actual->expr;
+ offset = c->ext.actual->next->expr;
+ whence = c->ext.actual->next->next->expr;
+ status = c->ext.actual->next->next->next->expr;
+
+ if (unit->ts.kind != gfc_c_int_kind)
+ {
+ ts.type = BT_INTEGER;
+ ts.kind = gfc_c_int_kind;
+ ts.derived = NULL;
+ ts.cl = NULL;
+ gfc_convert_type (unit, &ts, 2);
+ }
+
+ if (offset->ts.kind != gfc_intio_kind)
+ {
+ ts.type = BT_INTEGER;
+ ts.kind = gfc_intio_kind;
+ ts.derived = NULL;
+ ts.cl = NULL;
+ gfc_convert_type (offset, &ts, 2);
+ }
+
+ if (whence->ts.kind != gfc_c_int_kind)
+ {
+ ts.type = BT_INTEGER;
+ ts.kind = gfc_c_int_kind;
+ ts.derived = NULL;
+ ts.cl = NULL;
+ gfc_convert_type (whence, &ts, 2);
+ }
+
+ c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fseek_sub"));
+}
+
void
gfc_resolve_ftell_sub (gfc_code *c)
{
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)
{
OSDN Git Service
