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
}
}
+/* 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;
+
+ if (mask->rank == 0)
+ {
+ if (mask->ts.kind != 4)
+ newkind = 4;
+ }
+ 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);
+ }
+}
+
/********************** Resolution functions **********************/
void
+gfc_resolve_achar (gfc_expr *f, gfc_expr *x)
+{
+
+ f->ts.type = BT_CHARACTER;
+ f->ts.kind = gfc_default_character_kind;
+ 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);
+}
+
+
+void
gfc_resolve_acos (gfc_expr *f, gfc_expr *x)
{
f->ts = x->ts;
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)
{
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;
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)
{
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);
}
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";
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";
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"));
+ ? PREFIX ("pack_char") : 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"));
- }
+ f->value.function.name = (array->ts.type == BT_CHARACTER
+ ? PREFIX ("pack_s_char") : PREFIX ("pack_s"));
}
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";
prec = gfc_get_actual_arglist ();
prec->name = "p";
prec->expr = gfc_int_expr (gfc_real_kinds[k].digits);
+ /* The library routine expects INTEGER(4). */
+ if (prec->expr->ts.kind != gfc_c_int_kind)
+ {
+ gfc_typespec ts;
+ ts.type = BT_INTEGER;
+ ts.kind = gfc_c_int_kind;
+ gfc_convert_type (prec->expr, &ts, 2);
+ }
f->value.function.actual->next = prec;
}
{
gfc_typespec ts;
ts.type = BT_INTEGER;
- ts.kind = gfc_default_integer_kind;
+ ts.kind = gfc_c_int_kind;
gfc_convert_type_warn (i, &ts, 2, 0);
}
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);
}
/* 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)
+ if (i->ts.kind != gfc_c_int_kind)
{
gfc_typespec ts;
ts.type = BT_INTEGER;
- ts.kind = gfc_default_integer_kind;
+ ts.kind = gfc_c_int_kind;
gfc_convert_type_warn (i, &ts, 2, 0);
}
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;
emin_1 = gfc_get_actual_arglist ();
emin_1->name = "emin";
emin_1->expr = gfc_int_expr (gfc_real_kinds[k].min_exponent - 1);
+
+ /* The library routine expects INTEGER(4). */
+ if (emin_1->expr->ts.kind != gfc_c_int_kind)
+ {
+ gfc_typespec ts;
+ ts.type = BT_INTEGER;
+ ts.kind = gfc_c_int_kind;
+ gfc_convert_type (emin_1->expr, &ts, 2);
+ }
emin_1->next = tiny;
prec = gfc_get_actual_arglist ();
prec->name = "prec";
prec->expr = gfc_int_expr (gfc_real_kinds[k].digits);
+
+ /* The library routine expects INTEGER(4). */
+ if (prec->expr->ts.kind != gfc_c_int_kind)
+ {
+ gfc_typespec ts;
+ ts.type = BT_INTEGER;
+ ts.kind = gfc_c_int_kind;
+ gfc_convert_type (prec->expr, &ts, 2);
+ }
prec->next = emin_1;
f->value.function.actual->next = prec;
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";
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)
{
{
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,
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);
}
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;
+
+ /* 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);
}
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;
gfc_resolve_exit (gfc_code *c)
{
const char *name;
- int kind;
+ gfc_typespec ts;
+ gfc_expr *n;
- 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);
}
}
+void
+gfc_resolve_fseek_sub (gfc_code *c)
+{
+ gfc_expr *unit;
+ gfc_expr *offset;
+ gfc_expr *whence;
+ gfc_expr *status;
+ gfc_typespec 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)
{