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;
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);
}
/* 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);
}
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";
{
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,
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);
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);
}
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)
{
OSDN Git Service
