/* Perform type resolution on the various structures.
- Copyright (C) 2001-2019 Free Software Foundation, Inc.
+ Copyright (C) 2001-2020 Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
Since a dummy argument cannot be a non-dummy procedure, the only
resort left for untyped names are the IMPLICIT types. */
-static void
-resolve_formal_arglist (gfc_symbol *proc)
+void
+gfc_resolve_formal_arglist (gfc_symbol *proc)
{
gfc_formal_arglist *f;
gfc_symbol *sym;
}
if (sym->attr.if_source != IFSRC_UNKNOWN)
- resolve_formal_arglist (sym);
+ gfc_resolve_formal_arglist (sym);
if (sym->attr.subroutine || sym->attr.external)
{
|| gfc_fl_struct (sym->attr.flavor) || sym->attr.intrinsic)
return;
- resolve_formal_arglist (sym);
+ gfc_resolve_formal_arglist (sym);
}
|| sym->attr.entry_master)
return;
+ if (!sym->result)
+ return;
+
/* Try to find out of what the return type is. */
if (sym->result->ts.type == BT_UNKNOWN && sym->result->ts.interface == NULL)
{
if (sym->attr.dimension)
{
if (el == ns->entries)
- gfc_error ("FUNCTION result %s can't be an array in "
+ gfc_error ("FUNCTION result %s cannot be an array in "
"FUNCTION %s at %L", sym->name,
ns->entries->sym->name, &sym->declared_at);
else
- gfc_error ("ENTRY result %s can't be an array in "
+ gfc_error ("ENTRY result %s cannot be an array in "
"FUNCTION %s at %L", sym->name,
ns->entries->sym->name, &sym->declared_at);
}
else if (sym->attr.pointer)
{
if (el == ns->entries)
- gfc_error ("FUNCTION result %s can't be a POINTER in "
+ gfc_error ("FUNCTION result %s cannot be a POINTER in "
"FUNCTION %s at %L", sym->name,
ns->entries->sym->name, &sym->declared_at);
else
- gfc_error ("ENTRY result %s can't be a POINTER in "
+ gfc_error ("ENTRY result %s cannot be a POINTER in "
"FUNCTION %s at %L", sym->name,
ns->entries->sym->name, &sym->declared_at);
}
if (sym)
{
if (el == ns->entries)
- gfc_error ("FUNCTION result %s can't be of type %s "
+ gfc_error ("FUNCTION result %s cannot be of type %s "
"in FUNCTION %s at %L", sym->name,
gfc_typename (ts), ns->entries->sym->name,
&sym->declared_at);
else
- gfc_error ("ENTRY result %s can't be of type %s "
+ gfc_error ("ENTRY result %s cannot be of type %s "
"in FUNCTION %s at %L", sym->name,
gfc_typename (ts), ns->entries->sym->name,
&sym->declared_at);
have been ignored to continue parsing.
We do the checks again here. */
if (!csym->attr.use_assoc)
- gfc_add_in_common (&csym->attr, csym->name, &common_block->where);
+ {
+ gfc_add_in_common (&csym->attr, csym->name, &common_block->where);
+ gfc_notify_std (GFC_STD_F2018_OBS, "COMMON block at %L",
+ &common_block->where);
+ }
if (csym->value || csym->attr.data)
{
resolve_common_vars (common_root->n.common, true);
- if (!gfc_notify_std (GFC_STD_F2018_OBS, "COMMON block at %L",
- &common_root->n.common->where))
- return;
-
/* The common name is a global name - in Fortran 2003 also if it has a
C binding name, since Fortran 2008 only the C binding name is a global
identifier. */
}
if (!gsym)
{
- gsym = gfc_get_gsymbol (common_root->n.common->name);
+ gsym = gfc_get_gsymbol (common_root->n.common->name, false);
gsym->type = GSYM_COMMON;
gsym->where = common_root->n.common->where;
gsym->defined = 1;
}
if (!gsym)
{
- gsym = gfc_get_gsymbol (common_root->n.common->binding_label);
+ gsym = gfc_get_gsymbol (common_root->n.common->binding_label, true);
gsym->type = GSYM_COMMON;
gsym->where = common_root->n.common->where;
gsym->defined = 1;
sym->name, &common_root->n.common->where, &sym->declared_at);
if (sym->attr.external)
- gfc_error ("COMMON block %qs at %L can not have the EXTERNAL attribute",
+ gfc_error ("COMMON block %qs at %L cannot have the EXTERNAL attribute",
sym->name, &common_root->n.common->where);
if (sym->attr.intrinsic)
if (s2 && !gfc_compare_interfaces (comp->ts.interface, s2, name, 0, 1,
err, sizeof (err), NULL, NULL))
{
- gfc_error_opt (OPT_Wargument_mismatch,
- "Interface mismatch for procedure-pointer "
+ gfc_error_opt (0, "Interface mismatch for procedure-pointer "
"component %qs in structure constructor at %L:"
" %s", comp->name, &cons->expr->where, err);
return false;
|| gfc_fl_struct (sym->attr.flavor))
return false;
- gcc_assert (sym->attr.flavor == FL_PROCEDURE);
-
/* If we've got an ENTRY, find real procedure. */
if (sym->attr.entry && sym->ns->entries)
proc_sym = sym->ns->entries->sym;
gfc_intrinsic_sym* isym = NULL;
const char* symstd;
- if (sym->formal)
+ if (sym->resolve_symbol_called >= 2)
return true;
+ sym->resolve_symbol_called = 2;
+
/* Already resolved. */
if (sym->from_intmod && sym->ts.type != BT_UNKNOWN)
return true;
}
+/* Check that name is not a derived type. */
+
+static bool
+is_dt_name (const char *name)
+{
+ gfc_symbol *dt_list, *dt_first;
+
+ dt_list = dt_first = gfc_derived_types;
+ for (; dt_list; dt_list = dt_list->dt_next)
+ {
+ if (strcmp(dt_list->name, name) == 0)
+ return true;
+ if (dt_first == dt_list->dt_next)
+ break;
+ }
+ return false;
+}
+
+
/* Resolve an actual argument list. Most of the time, this is just
resolving the expressions in the list.
The exception is that we sometimes have to decide whether arguments
sym = e->symtree->n.sym;
+ if (sym->attr.flavor == FL_PROCEDURE && is_dt_name (sym->name))
+ {
+ gfc_error ("Derived type %qs is used as an actual "
+ "argument at %L", sym->name, &e->where);
+ goto cleanup;
+ }
+
if (sym->attr.flavor == FL_PROCEDURE
|| sym->attr.intrinsic
|| sym->attr.external)
&& (set_by_optional || arg->expr->rank != rank)
&& !(isym && isym->id == GFC_ISYM_CONVERSION))
{
- gfc_warning (OPT_Wpedantic,
- "%qs at %L is an array and OPTIONAL; IF IT IS "
- "MISSING, it cannot be the actual argument of an "
- "ELEMENTAL procedure unless there is a non-optional "
- "argument with the same rank (12.4.1.5)",
- arg->expr->symtree->n.sym->name, &arg->expr->where);
+ bool t = false;
+ gfc_actual_arglist *a;
+
+ /* Scan the argument list for a non-optional argument with the
+ same rank as arg. */
+ for (a = arg0; a; a = a->next)
+ if (a != arg
+ && a->expr->rank == arg->expr->rank
+ && !a->expr->symtree->n.sym->attr.optional)
+ {
+ t = true;
+ break;
+ }
+
+ if (!t)
+ gfc_warning (OPT_Wpedantic,
+ "%qs at %L is an array and OPTIONAL; If it is not "
+ "present, then it cannot be the actual argument of "
+ "an ELEMENTAL procedure unless there is a non-optional"
+ " argument with the same rank "
+ "(Fortran 2018, 15.5.2.12)",
+ arg->expr->symtree->n.sym->name, &arg->expr->where);
}
}
/* Elemental procedure's array actual arguments must conform. */
if (e != NULL)
{
- if (!gfc_check_conformance (arg->expr, e, "elemental procedure"))
+ if (!gfc_check_conformance (arg->expr, e, _("elemental procedure")))
return false;
}
else
static void
-resolve_global_procedure (gfc_symbol *sym, locus *where,
- gfc_actual_arglist **actual, int sub)
+resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
{
gfc_gsymbol * gsym;
gfc_namespace *ns;
type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
- gsym = gfc_get_gsymbol (sym->binding_label ? sym->binding_label : sym->name);
+ gsym = gfc_get_gsymbol (sym->binding_label ? sym->binding_label : sym->name,
+ sym->binding_label != NULL);
if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
gfc_global_used (gsym, where);
&& gsym->type != GSYM_UNKNOWN
&& !gsym->binding_label
&& gsym->ns
- && gsym->ns->resolved != -1
&& gsym->ns->proc_name
&& not_in_recursive (sym, gsym->ns)
&& not_entry_self_reference (sym, gsym->ns))
{
gfc_symbol *def_sym;
+ def_sym = gsym->ns->proc_name;
- /* Resolve the gsymbol namespace if needed. */
- if (!gsym->ns->resolved)
+ if (gsym->ns->resolved != -1)
{
- gfc_symbol *old_dt_list;
- /* Stash away derived types so that the backend_decls do not
- get mixed up. */
- old_dt_list = gfc_derived_types;
- gfc_derived_types = NULL;
+ /* Resolve the gsymbol namespace if needed. */
+ if (!gsym->ns->resolved)
+ {
+ gfc_symbol *old_dt_list;
- gfc_resolve (gsym->ns);
+ /* Stash away derived types so that the backend_decls
+ do not get mixed up. */
+ old_dt_list = gfc_derived_types;
+ gfc_derived_types = NULL;
- /* Store the new derived types with the global namespace. */
- if (gfc_derived_types)
- gsym->ns->derived_types = gfc_derived_types;
+ gfc_resolve (gsym->ns);
- /* Restore the derived types of this namespace. */
- gfc_derived_types = old_dt_list;
- }
+ /* Store the new derived types with the global namespace. */
+ if (gfc_derived_types)
+ gsym->ns->derived_types = gfc_derived_types;
- /* Make sure that translation for the gsymbol occurs before
- the procedure currently being resolved. */
- ns = gfc_global_ns_list;
- for (; ns && ns != gsym->ns; ns = ns->sibling)
- {
- if (ns->sibling == gsym->ns)
- {
- ns->sibling = gsym->ns->sibling;
- gsym->ns->sibling = gfc_global_ns_list;
- gfc_global_ns_list = gsym->ns;
- break;
+ /* Restore the derived types of this namespace. */
+ gfc_derived_types = old_dt_list;
}
- }
- def_sym = gsym->ns->proc_name;
+ /* Make sure that translation for the gsymbol occurs before
+ the procedure currently being resolved. */
+ ns = gfc_global_ns_list;
+ for (; ns && ns != gsym->ns; ns = ns->sibling)
+ {
+ if (ns->sibling == gsym->ns)
+ {
+ ns->sibling = gsym->ns->sibling;
+ gsym->ns->sibling = gfc_global_ns_list;
+ gfc_global_ns_list = gsym->ns;
+ break;
+ }
+ }
- /* This can happen if a binding name has been specified. */
- if (gsym->binding_label && gsym->sym_name != def_sym->name)
- gfc_find_symbol (gsym->sym_name, gsym->ns, 0, &def_sym);
+ /* This can happen if a binding name has been specified. */
+ if (gsym->binding_label && gsym->sym_name != def_sym->name)
+ gfc_find_symbol (gsym->sym_name, gsym->ns, 0, &def_sym);
- if (def_sym->attr.entry_master)
- {
- gfc_entry_list *entry;
- for (entry = gsym->ns->entries; entry; entry = entry->next)
- if (strcmp (entry->sym->name, sym->name) == 0)
- {
- def_sym = entry->sym;
- break;
- }
+ if (def_sym->attr.entry_master || def_sym->attr.entry)
+ {
+ gfc_entry_list *entry;
+ for (entry = gsym->ns->entries; entry; entry = entry->next)
+ if (strcmp (entry->sym->name, sym->name) == 0)
+ {
+ def_sym = entry->sym;
+ break;
+ }
+ }
}
if (sym->attr.function && !gfc_compare_types (&sym->ts, &def_sym->ts))
goto done;
}
- if (!pedantic && (gfc_option.allow_std & GFC_STD_GNU))
- /* Turn erros into warnings with -std=gnu and -std=legacy. */
- gfc_errors_to_warnings (true);
-
+ bool bad_result_characteristics;
if (!gfc_compare_interfaces (sym, def_sym, sym->name, 0, 1,
- reason, sizeof(reason), NULL, NULL))
+ reason, sizeof(reason), NULL, NULL,
+ &bad_result_characteristics))
{
- gfc_error_opt (OPT_Wargument_mismatch,
- "Interface mismatch in global procedure %qs at %L:"
- " %s", sym->name, &sym->declared_at, reason);
- goto done;
- }
+ /* Turn erros into warnings with -std=gnu and -std=legacy,
+ unless a function returns a wrong type, which can lead
+ to all kinds of ICEs and wrong code. */
- if (!pedantic
- || ((gfc_option.warn_std & GFC_STD_LEGACY)
- && !(gfc_option.warn_std & GFC_STD_GNU)))
- gfc_errors_to_warnings (true);
+ if (!pedantic && (gfc_option.allow_std & GFC_STD_GNU)
+ && !bad_result_characteristics)
+ gfc_errors_to_warnings (true);
- if (sym->attr.if_source != IFSRC_IFBODY)
- gfc_procedure_use (def_sym, actual, where);
+ gfc_error ("Interface mismatch in global procedure %qs at %L: %s",
+ sym->name, &sym->declared_at, reason);
+ sym->error = 1;
+ gfc_errors_to_warnings (false);
+ goto done;
+ }
}
done:
- gfc_errors_to_warnings (false);
if (gsym->type == GSYM_UNKNOWN)
{
|| sym->intmod_sym_id == GFC_ISYM_CAF_SEND))
return true;
+ if (expr->ref)
+ {
+ gfc_error ("Unexpected junk after %qs at %L", expr->symtree->n.sym->name,
+ &expr->where);
+ return false;
+ }
+
if (sym && sym->attr.intrinsic
&& !gfc_resolve_intrinsic (sym, &expr->where))
return false;
/* If the procedure is external, check for usage. */
if (sym && is_external_proc (sym))
- resolve_global_procedure (sym, &expr->where,
- &expr->value.function.actual, 0);
+ resolve_global_procedure (sym, &expr->where, 0);
if (sym && sym->ts.type == BT_CHARACTER
&& sym->ts.u.cl
if (expr->expr_type != EXPR_FUNCTION)
return t;
+ /* Walk the argument list looking for invalid BOZ. */
+ for (arg = expr->value.function.actual; arg; arg = arg->next)
+ if (arg->expr && arg->expr->ts.type == BT_BOZ)
+ {
+ gfc_error ("A BOZ literal constant at %L cannot appear as an "
+ "actual argument in a function reference",
+ &arg->expr->where);
+ return false;
+ }
+
temp = need_full_assumed_size;
need_full_assumed_size = 0;
/* If external, check for usage. */
if (csym && is_external_proc (csym))
- resolve_global_procedure (csym, &c->loc, &c->ext.actual, 1);
+ resolve_global_procedure (csym, &c->loc, 1);
t = true;
if (c->resolved_sym == NULL)
return 0;
}
+/* Return true if TYPE is character based, false otherwise. */
+
+static int
+is_character_based (bt type)
+{
+ return type == BT_CHARACTER || type == BT_HOLLERITH;
+}
+
+
+/* If expression is a hollerith, convert it to character and issue a warning
+ for the conversion. */
+
+static void
+convert_hollerith_to_character (gfc_expr *e)
+{
+ if (e->ts.type == BT_HOLLERITH)
+ {
+ gfc_typespec t;
+ gfc_clear_ts (&t);
+ t.type = BT_CHARACTER;
+ t.kind = e->ts.kind;
+ gfc_convert_type_warn (e, &t, 2, 1);
+ }
+}
+
+/* Convert to numeric and issue a warning for the conversion. */
+
+static void
+convert_to_numeric (gfc_expr *a, gfc_expr *b)
+{
+ gfc_typespec t;
+ gfc_clear_ts (&t);
+ t.type = b->ts.type;
+ t.kind = b->ts.kind;
+ gfc_convert_type_warn (a, &t, 2, 1);
+}
/* Resolve an operator expression node. This can involve replacing the
operation with a user defined function call. */
gfc_expr *op1, *op2;
char msg[200];
bool dual_locus_error;
- bool t;
+ bool t = true;
/* Resolve all subnodes-- give them types. */
case INTRINSIC_PARENTHESES:
if (!gfc_resolve_expr (e->value.op.op1))
return false;
+ if (e->value.op.op1
+ && e->value.op.op1->ts.type == BT_BOZ && !e->value.op.op2)
+ {
+ gfc_error ("BOZ literal constant at %L cannot be an operand of "
+ "unary operator %qs", &e->value.op.op1->where,
+ gfc_op2string (e->value.op.op));
+ return false;
+ }
break;
}
op1 = e->value.op.op1;
op2 = e->value.op.op2;
+ if (op1 == NULL && op2 == NULL)
+ return false;
+
dual_locus_error = false;
+ /* op1 and op2 cannot both be BOZ. */
+ if (op1 && op1->ts.type == BT_BOZ
+ && op2 && op2->ts.type == BT_BOZ)
+ {
+ gfc_error ("Operands at %L and %L cannot appear as operands of "
+ "binary operator %qs", &op1->where, &op2->where,
+ gfc_op2string (e->value.op.op));
+ return false;
+ }
+
if ((op1 && op1->expr_type == EXPR_NULL)
|| (op2 && op2->expr_type == EXPR_NULL))
{
}
sprintf (msg, _("Operand of unary numeric operator %%<%s%%> at %%L is %s"),
- gfc_op2string (e->value.op.op), gfc_typename (&e->ts));
+ gfc_op2string (e->value.op.op), gfc_typename (e));
goto bad_op;
case INTRINSIC_PLUS:
else
sprintf (msg,
_("Operands of binary numeric operator %%<%s%%> at %%L are %s/%s"),
- gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
- gfc_typename (&op2->ts));
+ gfc_op2string (e->value.op.op), gfc_typename (op1),
+ gfc_typename (op2));
goto bad_op;
case INTRINSIC_CONCAT:
sprintf (msg,
_("Operands of string concatenation operator at %%L are %s/%s"),
- gfc_typename (&op1->ts), gfc_typename (&op2->ts));
+ gfc_typename (op1), gfc_typename (op2));
goto bad_op;
case INTRINSIC_AND:
if (op2->ts.type != e->ts.type || op2->ts.kind != e->ts.kind)
gfc_convert_type (op2, &e->ts, 1);
e = logical_to_bitwise (e);
- break;
+ goto simplify_op;
}
sprintf (msg, _("Operands of logical operator %%<%s%%> at %%L are %s/%s"),
- gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
- gfc_typename (&op2->ts));
+ gfc_op2string (e->value.op.op), gfc_typename (op1),
+ gfc_typename (op2));
goto bad_op;
e->ts.type = BT_INTEGER;
e->ts.kind = op1->ts.kind;
e = logical_to_bitwise (e);
- break;
+ goto simplify_op;
}
if (op1->ts.type == BT_LOGICAL)
}
sprintf (msg, _("Operand of .not. operator at %%L is %s"),
- gfc_typename (&op1->ts));
+ gfc_typename (op1));
goto bad_op;
case INTRINSIC_GT:
case INTRINSIC_EQ_OS:
case INTRINSIC_NE:
case INTRINSIC_NE_OS:
+
+ if (flag_dec
+ && is_character_based (op1->ts.type)
+ && is_character_based (op2->ts.type))
+ {
+ convert_hollerith_to_character (op1);
+ convert_hollerith_to_character (op2);
+ }
+
if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
&& op1->ts.kind == op2->ts.kind)
{
break;
}
+ /* If op1 is BOZ, then op2 is not!. Try to convert to type of op2. */
+ if (op1->ts.type == BT_BOZ)
+ {
+ if (gfc_invalid_boz (G_("BOZ literal constant near %L cannot appear "
+ "as an operand of a relational operator"),
+ &op1->where))
+ return false;
+
+ if (op2->ts.type == BT_INTEGER && !gfc_boz2int (op1, op2->ts.kind))
+ return false;
+
+ if (op2->ts.type == BT_REAL && !gfc_boz2real (op1, op2->ts.kind))
+ return false;
+ }
+
+ /* If op2 is BOZ, then op1 is not!. Try to convert to type of op2. */
+ if (op2->ts.type == BT_BOZ)
+ {
+ if (gfc_invalid_boz (G_("BOZ literal constant near %L cannot appear"
+ " as an operand of a relational operator"),
+ &op2->where))
+ return false;
+
+ if (op1->ts.type == BT_INTEGER && !gfc_boz2int (op2, op1->ts.kind))
+ return false;
+
+ if (op1->ts.type == BT_REAL && !gfc_boz2real (op2, op1->ts.kind))
+ return false;
+ }
+ if (flag_dec
+ && op1->ts.type == BT_HOLLERITH && gfc_numeric_ts (&op2->ts))
+ convert_to_numeric (op1, op2);
+
+ if (flag_dec
+ && gfc_numeric_ts (&op1->ts) && op2->ts.type == BT_HOLLERITH)
+ convert_to_numeric (op2, op1);
+
if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
{
gfc_type_convert_binary (e, 1);
const char *msg;
if (op == INTRINSIC_EQ || op == INTRINSIC_EQ_OS)
- msg = "Equality comparison for %s at %L";
+ msg = G_("Equality comparison for %s at %L");
else
- msg = "Inequality comparison for %s at %L";
+ msg = G_("Inequality comparison for %s at %L");
gfc_warning (OPT_Wcompare_reals, msg,
- gfc_typename (&op1->ts), &op1->where);
+ gfc_typename (op1), &op1->where);
}
}
else
sprintf (msg,
_("Operands of comparison operator %%<%s%%> at %%L are %s/%s"),
- gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
- gfc_typename (&op2->ts));
+ gfc_op2string (e->value.op.op), gfc_typename (op1),
+ gfc_typename (op2));
goto bad_op;
}
else if (op2 == NULL)
sprintf (msg, _("Operand of user operator %%<%s%%> at %%L is %s"),
- e->value.op.uop->name, gfc_typename (&op1->ts));
+ e->value.op.uop->name, gfc_typename (op1));
else
{
sprintf (msg, _("Operands of user operator %%<%s%%> at %%L are %s/%s"),
- e->value.op.uop->name, gfc_typename (&op1->ts),
- gfc_typename (&op2->ts));
+ e->value.op.uop->name, gfc_typename (op1),
+ gfc_typename (op2));
e->value.op.uop->op->sym->attr.referenced = 1;
}
/* Deal with arrayness of an operand through an operator. */
- t = true;
-
switch (e->value.op.op)
{
case INTRINSIC_PLUS:
break;
}
+simplify_op:
+
/* Attempt to simplify the expression. */
if (t)
{
gfc_array_spec *as;
gfc_component *c;
gfc_ref *ref;
+ bool class_as = false;
if (e->symtree->n.sym->ts.type == BT_CLASS)
- as = CLASS_DATA (e->symtree->n.sym)->as;
+ {
+ as = CLASS_DATA (e->symtree->n.sym)->as;
+ class_as = true;
+ }
else
as = e->symtree->n.sym->as;
c = ref->u.c.component;
if (c->attr.dimension)
{
- if (as != NULL)
+ if (as != NULL && !(class_as && as == c->as))
gfc_internal_error ("find_array_spec(): unused as(1)");
as = c->as;
}
static bool
-resolve_substring (gfc_ref *ref)
+resolve_substring (gfc_ref *ref, bool *equal_length)
{
int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
&ref->u.ss.end->where);
return false;
}
+ /* If the substring has the same length as the original
+ variable, the reference itself can be deleted. */
+
+ if (ref->u.ss.length != NULL
+ && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_EQ
+ && compare_bound_int (ref->u.ss.start, 1) == CMP_EQ)
+ *equal_length = true;
}
return true;
gfc_ref *char_ref;
gfc_expr *start, *end;
gfc_typespec *ts = NULL;
+ mpz_t diff;
for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
{
return;
}
- e->ts.type = BT_CHARACTER;
- e->ts.kind = gfc_default_character_kind;
-
if (!e->ts.u.cl)
e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
return;
}
- /* Length = (end - start + 1). */
- e->ts.u.cl->length = gfc_subtract (end, start);
- e->ts.u.cl->length = gfc_add (e->ts.u.cl->length,
- gfc_get_int_expr (gfc_charlen_int_kind,
- NULL, 1));
+ /* Length = (end - start + 1).
+ Check first whether it has a constant length. */
+ if (gfc_dep_difference (end, start, &diff))
+ {
+ gfc_expr *len = gfc_get_constant_expr (BT_INTEGER, gfc_charlen_int_kind,
+ &e->where);
+
+ mpz_add_ui (len->value.integer, diff, 1);
+ mpz_clear (diff);
+ e->ts.u.cl->length = len;
+ /* The check for length < 0 is handled below */
+ }
+ else
+ {
+ e->ts.u.cl->length = gfc_subtract (end, start);
+ e->ts.u.cl->length = gfc_add (e->ts.u.cl->length,
+ gfc_get_int_expr (gfc_charlen_int_kind,
+ NULL, 1));
+ }
/* F2008, 6.4.1: Both the starting point and the ending point shall
be within the range 1, 2, ..., n unless the starting point exceeds
/* Resolve subtype references. */
-static bool
-resolve_ref (gfc_expr *expr)
+bool
+gfc_resolve_ref (gfc_expr *expr)
{
- int current_part_dimension, n_components, seen_part_dimension;
- gfc_ref *ref;
+ int current_part_dimension, n_components, seen_part_dimension, dim;
+ gfc_ref *ref, **prev, *array_ref;
+ bool equal_length;
for (ref = expr->ref; ref; ref = ref->next)
if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
break;
}
- for (ref = expr->ref; ref; ref = ref->next)
- switch (ref->type)
+ for (prev = &expr->ref; *prev != NULL;
+ prev = *prev == NULL ? prev : &(*prev)->next)
+ switch ((*prev)->type)
{
case REF_ARRAY:
- if (!resolve_array_ref (&ref->u.ar))
+ if (!resolve_array_ref (&(*prev)->u.ar))
return false;
break;
break;
case REF_SUBSTRING:
- if (!resolve_substring (ref))
+ equal_length = false;
+ if (!resolve_substring (*prev, &equal_length))
return false;
+
+ if (expr->expr_type != EXPR_SUBSTRING && equal_length)
+ {
+ /* Remove the reference and move the charlen, if any. */
+ ref = *prev;
+ *prev = ref->next;
+ ref->next = NULL;
+ expr->ts.u.cl = ref->u.ss.length;
+ ref->u.ss.length = NULL;
+ gfc_free_ref_list (ref);
+ }
break;
}
current_part_dimension = 0;
seen_part_dimension = 0;
n_components = 0;
+ array_ref = NULL;
for (ref = expr->ref; ref; ref = ref->next)
{
switch (ref->type)
{
case REF_ARRAY:
+ array_ref = ref;
switch (ref->u.ar.type)
{
case AR_FULL:
break;
case AR_ELEMENT:
+ array_ref = NULL;
current_part_dimension = 0;
break;
break;
case REF_SUBSTRING:
+ break;
+
case REF_INQUIRY:
+ /* Implement requirement in note 9.7 of F2018 that the result of the
+ LEN inquiry be a scalar. */
+ if (ref->u.i == INQUIRY_LEN && array_ref && expr->ts.deferred)
+ {
+ array_ref->u.ar.type = AR_ELEMENT;
+ expr->rank = 0;
+ /* INQUIRY_LEN is not evaluated from the rest of the expr
+ but directly from the string length. This means that setting
+ the array indices to one does not matter but might trigger
+ a runtime bounds error. Suppress the check. */
+ expr->no_bounds_check = 1;
+ for (dim = 0; dim < array_ref->u.ar.dimen; dim++)
+ {
+ array_ref->u.ar.dimen_type[dim] = DIMEN_ELEMENT;
+ if (array_ref->u.ar.start[dim])
+ gfc_free_expr (array_ref->u.ar.start[dim]);
+ array_ref->u.ar.start[dim]
+ = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
+ if (array_ref->u.ar.end[dim])
+ gfc_free_expr (array_ref->u.ar.end[dim]);
+ if (array_ref->u.ar.stride[dim])
+ gfc_free_expr (array_ref->u.ar.stride[dim]);
+ }
+ }
break;
}
examining the base symbol and any reference structures it may have. */
void
-expression_rank (gfc_expr *e)
+gfc_expression_rank (gfc_expr *e)
{
gfc_ref *ref;
int i, rank;
goto done;
/* Constructors can have a rank different from one via RESHAPE(). */
- if (e->symtree == NULL)
- {
- e->rank = 0;
- goto done;
- }
-
- e->rank = (e->symtree->n.sym->as == NULL)
- ? 0 : e->symtree->n.sym->as->rank;
+ e->rank = ((e->symtree == NULL || e->symtree->n.sym->as == NULL)
+ ? 0 : e->symtree->n.sym->as->rank);
goto done;
}
{
/* Figure out the rank of the section. */
if (rank != 0)
- gfc_internal_error ("expression_rank(): Two array specs");
+ gfc_internal_error ("gfc_expression_rank(): Two array specs");
for (i = 0; i < ref->u.ar.dimen; i++)
if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
}
}
/* TS 29113, C535b. */
- else if ((sym->ts.type == BT_CLASS && sym->attr.class_ok
- && CLASS_DATA (sym)->as
- && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
- || (sym->ts.type != BT_CLASS && sym->as
- && sym->as->type == AS_ASSUMED_RANK))
+ else if (((sym->ts.type == BT_CLASS && sym->attr.class_ok
+ && CLASS_DATA (sym)->as
+ && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
+ || (sym->ts.type != BT_CLASS && sym->as
+ && sym->as->type == AS_ASSUMED_RANK))
+ && !sym->attr.select_rank_temporary)
{
- if (!actual_arg)
+ if (!actual_arg
+ && !(cs_base && cs_base->current
+ && cs_base->current->op == EXEC_SELECT_RANK))
{
gfc_error ("Assumed-rank variable %s at %L may only be used as "
"actual argument", sym->name, &e->where);
}
}
- if (e->ref && !resolve_ref (e))
+ if (e->ref && !gfc_resolve_ref (e))
return false;
if (sym->attr.flavor == FL_PROCEDURE
}
if (t)
- expression_rank (e);
+ gfc_expression_rank (e);
if (t && flag_coarray == GFC_FCOARRAY_LIB && gfc_is_coindexed (e))
add_caf_get_intrinsic (e);
{
gfc_expr* po;
+ if (e->expr_type == EXPR_UNKNOWN)
+ {
+ gfc_error ("Error in typebound call at %L",
+ &e->where);
+ return NULL;
+ }
+
gcc_assert (e->expr_type == EXPR_COMPCALL);
if (e->value.compcall.base_object)
if (!base)
return false;
- gcc_assert (base->ts.type == BT_DERIVED || base->ts.type == BT_CLASS);
+ if (base->ts.type != BT_DERIVED && base->ts.type != BT_CLASS)
+ {
+ gfc_error ("Error in typebound call at %L", &e->where);
+ goto cleanup;
+ }
if (base->ts.type == BT_CLASS && !gfc_expr_attr (base).class_ok)
return false;
return false;
}
+
/* These must not be assign-calls! */
gcc_assert (!e->value.compcall.assign);
overridable = !e->value.compcall.tbp->non_overridable;
if (expr && expr->ts.type == BT_CLASS && e->value.compcall.name)
{
- /* If the base_object is not a variable, the corresponding actual
- argument expression must be stored in e->base_expression so
- that the corresponding tree temporary can be used as the base
- object in gfc_conv_procedure_call. */
- if (expr->expr_type != EXPR_VARIABLE)
- {
- gfc_actual_arglist *args;
-
- for (args= e->value.function.actual; args; args = args->next)
- {
- if (expr == args->expr)
- expr = args->expr;
- }
- }
-
/* Since the typebound operators are generic, we have to ensure
that any delays in resolution are corrected and that the vtab
is present. */
if (st == NULL)
return resolve_compcall (e, NULL);
- if (!resolve_ref (e))
+ if (!gfc_resolve_ref (e))
return false;
/* Get the CLASS declared type. */
}
c = gfc_find_component (declared, "_data", true, true, NULL);
- declared = c->ts.u.derived;
/* Treat the call as if it is a typebound procedure, in order to roll
out the correct name for the specific function. */
if (st == NULL)
return resolve_typebound_call (code, NULL, NULL);
- if (!resolve_ref (code->expr1))
+ if (!gfc_resolve_ref (code->expr1))
return false;
/* Get the CLASS declared type. */
if (!comp->attr.subroutine)
gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where);
- if (!resolve_ref (c->expr1))
+ if (!gfc_resolve_ref (c->expr1))
return false;
if (!update_ppc_arglist (c->expr1))
if (!comp->attr.function)
gfc_add_function (&comp->attr, comp->name, &e->where);
- if (!resolve_ref (e))
+ if (!gfc_resolve_ref (e))
return false;
if (!resolve_actual_arglist (e->value.function.actual, comp->attr.proc,
bool t;
bool inquiry_save, actual_arg_save, first_actual_arg_save;
- if (e == NULL)
+ if (e == NULL || e->do_not_resolve_again)
return true;
/* inquiry_argument only applies to variables. */
break;
case EXPR_SUBSTRING:
- t = resolve_ref (e);
+ t = gfc_resolve_ref (e);
break;
case EXPR_CONSTANT:
case EXPR_ARRAY:
t = false;
- if (!resolve_ref (e))
+ if (!gfc_resolve_ref (e))
break;
t = gfc_resolve_array_constructor (e);
/* Also try to expand a constructor. */
if (t)
{
- expression_rank (e);
+ gfc_expression_rank (e);
if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e))
gfc_expand_constructor (e, false);
}
break;
case EXPR_STRUCTURE:
- t = resolve_ref (e);
+ t = gfc_resolve_ref (e);
if (!t)
break;
actual_arg = actual_arg_save;
first_actual_arg = first_actual_arg_save;
+ /* For some reason, resolving these expressions a second time mangles
+ the typespec of the expression itself. */
+ if (t && e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->attr.select_rank_temporary
+ && UNLIMITED_POLY (e->symtree->n.sym))
+ e->do_not_resolve_again = 1;
+
return t;
}
"Step expression in DO loop"))
return false;
- if (iter->step->expr_type == EXPR_CONSTANT)
- {
- if ((iter->step->ts.type == BT_INTEGER
- && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
- || (iter->step->ts.type == BT_REAL
- && mpfr_sgn (iter->step->value.real) == 0))
- {
- gfc_error ("Step expression in DO loop at %L cannot be zero",
- &iter->step->where);
- return false;
- }
- }
-
/* Convert start, end, and step to the same type as var. */
if (iter->start->ts.kind != iter->var->ts.kind
|| iter->start->ts.type != iter->var->ts.type)
|| iter->step->ts.type != iter->var->ts.type)
gfc_convert_type (iter->step, &iter->var->ts, 1);
+ if (iter->step->expr_type == EXPR_CONSTANT)
+ {
+ if ((iter->step->ts.type == BT_INTEGER
+ && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
+ || (iter->step->ts.type == BT_REAL
+ && mpfr_sgn (iter->step->value.real) == 0))
+ {
+ gfc_error ("Step expression in DO loop at %L cannot be zero",
+ &iter->step->where);
+ return false;
+ }
+ }
+
if (iter->start->expr_type == EXPR_CONSTANT
&& iter->end->expr_type == EXPR_CONSTANT
&& iter->step->expr_type == EXPR_CONSTANT)
for (ref = result->ref; ref; ref = ref->next)
if (ref->type == REF_ARRAY && ref->next == NULL)
{
+ if (ref->u.ar.dimen == 0
+ && ref->u.ar.as && ref->u.ar.as->corank)
+ return result;
+
ref->u.ar.type = AR_FULL;
for (i = 0; i < ref->u.ar.dimen; i++)
for (tail = e2->ref; tail && tail->next; tail = tail->next);
/* First compare rank. */
- if ((tail && e1->rank != tail->u.ar.as->rank)
+ if ((tail && (!tail->u.ar.as || e1->rank != tail->u.ar.as->rank))
|| (!tail && e1->rank != e2->rank))
{
gfc_error ("Source-expr at %L must be scalar or have the "
if (codimension)
for (i = ar->dimen; i < ar->dimen + ar->codimen; i++)
- if (ar->dimen_type[i] == DIMEN_THIS_IMAGE)
- {
- gfc_error ("Coarray specification required in ALLOCATE statement "
- "at %L", &e->where);
- goto failure;
- }
+ {
+ switch (ar->dimen_type[i])
+ {
+ case DIMEN_THIS_IMAGE:
+ gfc_error ("Coarray specification required in ALLOCATE statement "
+ "at %L", &e->where);
+ goto failure;
+ case DIMEN_RANGE:
+ if (ar->start[i] == 0 || ar->end[i] == 0)
+ {
+ /* If ar->stride[i] is NULL, we issued a previous error. */
+ if (ar->stride[i] == NULL)
+ gfc_error ("Bad array specification in ALLOCATE statement "
+ "at %L", &e->where);
+ goto failure;
+ }
+ else if (gfc_dep_compare_expr (ar->start[i], ar->end[i]) == 1)
+ {
+ gfc_error ("Upper cobound is less than lower cobound at %L",
+ &ar->start[i]->where);
+ goto failure;
+ }
+ break;
+
+ case DIMEN_ELEMENT:
+ if (ar->start[i]->expr_type == EXPR_CONSTANT)
+ {
+ gcc_assert (ar->start[i]->ts.type == BT_INTEGER);
+ if (mpz_cmp_si (ar->start[i]->value.integer, 1) < 0)
+ {
+ gfc_error ("Upper cobound is less than lower cobound "
+ "of 1 at %L", &ar->start[i]->where);
+ goto failure;
+ }
+ }
+ break;
+
+ case DIMEN_STAR:
+ break;
+
+ default:
+ gfc_error ("Bad array specification in ALLOCATE statement at %L",
+ &e->where);
+ goto failure;
+
+ }
+ }
for (i = 0; i < ar->dimen; i++)
{
if (ar->type == AR_ELEMENT || ar->type == AR_FULL)
if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
{
gfc_error ("Argument of SELECT statement at %L cannot be %s",
- &case_expr->where, gfc_typename (&case_expr->ts));
+ &case_expr->where, gfc_typename (case_expr));
/* Punt. Going on here just produce more garbage error messages. */
return;
case_expr->ts.kind) != ARITH_OK)
gfc_warning (0, "Expression in CASE statement at %L is "
"not in the range of %s", &cp->low->where,
- gfc_typename (&case_expr->ts));
+ gfc_typename (case_expr));
if (cp->high
&& cp->low != cp->high
case_expr->ts.kind) != ARITH_OK)
gfc_warning (0, "Expression in CASE statement at %L is "
"not in the range of %s", &cp->high->where,
- gfc_typename (&case_expr->ts));
+ gfc_typename (case_expr));
}
/* PR 19168 has a long discussion concerning a mismatch of the kinds
/* For variable targets, we get some attributes from the target. */
if (target->expr_type == EXPR_VARIABLE)
{
- gfc_symbol* tsym;
+ gfc_symbol *tsym, *dsym;
gcc_assert (target->symtree);
tsym = target->symtree->n.sym;
+ if (gfc_expr_attr (target).proc_pointer)
+ {
+ gfc_error ("Associating entity %qs at %L is a procedure pointer",
+ tsym->name, &target->where);
+ return;
+ }
+
+ if (tsym->attr.flavor == FL_PROCEDURE && tsym->generic
+ && (dsym = gfc_find_dt_in_generic (tsym)) != NULL
+ && dsym->attr.flavor == FL_DERIVED)
+ {
+ gfc_error ("Derived type %qs cannot be used as a variable at %L",
+ tsym->name, &target->where);
+ return;
+ }
+
+ if (tsym->attr.flavor == FL_PROCEDURE)
+ {
+ bool is_error = true;
+ if (tsym->attr.function && tsym->result == tsym)
+ for (gfc_namespace *ns = sym->ns; ns; ns = ns->parent)
+ if (tsym == ns->proc_name)
+ {
+ is_error = false;
+ break;
+ }
+ if (is_error)
+ {
+ gfc_error ("Associating entity %qs at %L is a procedure name",
+ tsym->name, &target->where);
+ return;
+ }
+ }
+
sym->attr.asynchronous = tsym->attr.asynchronous;
sym->attr.volatile_ = tsym->attr.volatile_;
if (is_subref_array (target))
sym->attr.subref_array_pointer = 1;
}
+ else if (target->ts.type == BT_PROCEDURE)
+ {
+ gfc_error ("Associating selector-expression at %L yields a procedure",
+ &target->where);
+ return;
+ }
if (target->expr_type == EXPR_NULL)
{
if (target->ts.type == BT_CLASS)
gfc_fix_class_refs (target);
- if (target->rank != 0)
+ if (target->rank != 0 && !sym->attr.select_rank_temporary)
{
gfc_array_spec *as;
/* The rank may be incorrectly guessed at parsing, therefore make sure
CLASS_DATA (sym)->attr.codimension = 1;
}
}
- else
+ else if (!sym->attr.select_rank_temporary)
{
/* target's rank is 0, but the type of the sym is still array valued,
which has to be corrected. */
as = NULL;
sym->ts = *ts;
sym->ts.type = BT_CLASS;
- attr = CLASS_DATA (sym)->attr;
+ attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr;
attr.class_ok = 0;
attr.associate_var = 1;
attr.dimension = attr.codimension = 0;
{
if (code->expr1->symtree->n.sym->attr.untyped)
code->expr1->symtree->n.sym->ts = code->expr2->ts;
- selector_type = CLASS_DATA (code->expr2)->ts.u.derived;
+ selector_type = CLASS_DATA (code->expr2)
+ ? CLASS_DATA (code->expr2)->ts.u.derived : code->expr2->ts.u.derived;
}
if (code->expr2->rank && CLASS_DATA (code->expr1)->as)
default_case->next = if_st;
}
- /* Resolve the internal code. This can not be done earlier because
+ /* Resolve the internal code. This cannot be done earlier because
it requires that the sym->assoc of selectors is set already. */
gfc_current_ns = ns;
gfc_resolve_blocks (code->block, gfc_current_ns);
}
+/* Resolve a SELECT RANK statement. */
+
+static void
+resolve_select_rank (gfc_code *code, gfc_namespace *old_ns)
+{
+ gfc_namespace *ns;
+ gfc_code *body, *new_st, *tail;
+ gfc_case *c;
+ char tname[GFC_MAX_SYMBOL_LEN + 7];
+ char name[2 * GFC_MAX_SYMBOL_LEN];
+ gfc_symtree *st;
+ gfc_expr *selector_expr = NULL;
+ int case_value;
+ HOST_WIDE_INT charlen = 0;
+
+ ns = code->ext.block.ns;
+ gfc_resolve (ns);
+
+ code->op = EXEC_BLOCK;
+ if (code->expr2)
+ {
+ gfc_association_list* assoc;
+
+ assoc = gfc_get_association_list ();
+ assoc->st = code->expr1->symtree;
+ assoc->target = gfc_copy_expr (code->expr2);
+ assoc->target->where = code->expr2->where;
+ /* assoc->variable will be set by resolve_assoc_var. */
+
+ code->ext.block.assoc = assoc;
+ code->expr1->symtree->n.sym->assoc = assoc;
+
+ resolve_assoc_var (code->expr1->symtree->n.sym, false);
+ }
+ else
+ code->ext.block.assoc = NULL;
+
+ /* Loop over RANK cases. Note that returning on the errors causes a
+ cascade of further errors because the case blocks do not compile
+ correctly. */
+ for (body = code->block; body; body = body->block)
+ {
+ c = body->ext.block.case_list;
+ if (c->low)
+ case_value = (int) mpz_get_si (c->low->value.integer);
+ else
+ case_value = -2;
+
+ /* Check for repeated cases. */
+ for (tail = code->block; tail; tail = tail->block)
+ {
+ gfc_case *d = tail->ext.block.case_list;
+ int case_value2;
+
+ if (tail == body)
+ break;
+
+ /* Check F2018: C1153. */
+ if (!c->low && !d->low)
+ gfc_error ("RANK DEFAULT at %L is repeated at %L",
+ &c->where, &d->where);
+
+ if (!c->low || !d->low)
+ continue;
+
+ /* Check F2018: C1153. */
+ case_value2 = (int) mpz_get_si (d->low->value.integer);
+ if ((case_value == case_value2) && case_value == -1)
+ gfc_error ("RANK (*) at %L is repeated at %L",
+ &c->where, &d->where);
+ else if (case_value == case_value2)
+ gfc_error ("RANK (%i) at %L is repeated at %L",
+ case_value, &c->where, &d->where);
+ }
+
+ if (!c->low)
+ continue;
+
+ /* Check F2018: C1155. */
+ if (case_value == -1 && (gfc_expr_attr (code->expr1).allocatable
+ || gfc_expr_attr (code->expr1).pointer))
+ gfc_error ("RANK (*) at %L cannot be used with the pointer or "
+ "allocatable selector at %L", &c->where, &code->expr1->where);
+
+ if (case_value == -1 && (gfc_expr_attr (code->expr1).allocatable
+ || gfc_expr_attr (code->expr1).pointer))
+ gfc_error ("RANK (*) at %L cannot be used with the pointer or "
+ "allocatable selector at %L", &c->where, &code->expr1->where);
+ }
+
+ /* Add EXEC_SELECT to switch on rank. */
+ new_st = gfc_get_code (code->op);
+ new_st->expr1 = code->expr1;
+ new_st->expr2 = code->expr2;
+ new_st->block = code->block;
+ code->expr1 = code->expr2 = NULL;
+ code->block = NULL;
+ if (!ns->code)
+ ns->code = new_st;
+ else
+ ns->code->next = new_st;
+ code = new_st;
+ code->op = EXEC_SELECT_RANK;
+
+ selector_expr = code->expr1;
+
+ /* Loop over SELECT RANK cases. */
+ for (body = code->block; body; body = body->block)
+ {
+ c = body->ext.block.case_list;
+ int case_value;
+
+ /* Pass on the default case. */
+ if (c->low == NULL)
+ continue;
+
+ /* Associate temporary to selector. This should only be done
+ when this case is actually true, so build a new ASSOCIATE
+ that does precisely this here (instead of using the
+ 'global' one). */
+ if (c->ts.type == BT_CHARACTER && c->ts.u.cl && c->ts.u.cl->length
+ && c->ts.u.cl->length->expr_type == EXPR_CONSTANT)
+ charlen = gfc_mpz_get_hwi (c->ts.u.cl->length->value.integer);
+
+ if (c->ts.type == BT_CLASS)
+ sprintf (tname, "class_%s", c->ts.u.derived->name);
+ else if (c->ts.type == BT_DERIVED)
+ sprintf (tname, "type_%s", c->ts.u.derived->name);
+ else if (c->ts.type != BT_CHARACTER)
+ sprintf (tname, "%s_%d", gfc_basic_typename (c->ts.type), c->ts.kind);
+ else
+ sprintf (tname, "%s_" HOST_WIDE_INT_PRINT_DEC "_%d",
+ gfc_basic_typename (c->ts.type), charlen, c->ts.kind);
+
+ case_value = (int) mpz_get_si (c->low->value.integer);
+ if (case_value >= 0)
+ sprintf (name, "__tmp_%s_rank_%d", tname, case_value);
+ else
+ sprintf (name, "__tmp_%s_rank_m%d", tname, -case_value);
+
+ st = gfc_find_symtree (ns->sym_root, name);
+ gcc_assert (st->n.sym->assoc);
+
+ st->n.sym->assoc->target = gfc_get_variable_expr (selector_expr->symtree);
+ st->n.sym->assoc->target->where = selector_expr->where;
+
+ new_st = gfc_get_code (EXEC_BLOCK);
+ new_st->ext.block.ns = gfc_build_block_ns (ns);
+ new_st->ext.block.ns->code = body->next;
+ body->next = new_st;
+
+ /* Chain in the new list only if it is marked as dangling. Otherwise
+ there is a CASE label overlap and this is already used. Just ignore,
+ the error is diagnosed elsewhere. */
+ if (st->n.sym->assoc->dangling)
+ {
+ new_st->ext.block.assoc = st->n.sym->assoc;
+ st->n.sym->assoc->dangling = 0;
+ }
+
+ resolve_assoc_var (st->n.sym, false);
+ }
+
+ gfc_current_ns = ns;
+ gfc_resolve_blocks (code->block, gfc_current_ns);
+ gfc_current_ns = old_ns;
+}
+
+
/* Resolve a transfer statement. This is making sure that:
-- a derived type being transferred has only non-pointer components
-- a derived type being transferred doesn't have private components, unless
return;
}
- /* C_PTR and C_FUNPTR have private components which means they can not
+ /* C_PTR and C_FUNPTR have private components which means they cannot
be printed. However, if -std=gnu and not -pedantic, allow
the component to be printed to help debugging. */
if (ts->u.derived->ts.f90_type == BT_VOID)
"an assumed-size array", &code->loc);
return;
}
-
- if (async_io_dt && exp->expr_type == EXPR_VARIABLE)
- exp->symtree->n.sym->attr.asynchronous = 1;
}
case EXEC_SELECT:
case EXEC_SELECT_TYPE:
+ case EXEC_SELECT_RANK:
case EXEC_FORALL:
case EXEC_DO:
case EXEC_DO_WHILE:
case EXEC_OACC_PARALLEL:
case EXEC_OACC_KERNELS_LOOP:
case EXEC_OACC_KERNELS:
+ case EXEC_OACC_SERIAL_LOOP:
+ case EXEC_OACC_SERIAL:
case EXEC_OACC_DATA:
case EXEC_OACC_HOST_DATA:
case EXEC_OACC_LOOP:
lhs = code->expr1;
rhs = code->expr2;
- if (rhs->is_boz
- && !gfc_notify_std (GFC_STD_GNU, "BOZ literal at %L outside "
- "a DATA statement and outside INT/REAL/DBLE/CMPLX",
- &code->loc))
- return false;
+ if ((gfc_numeric_ts (&lhs->ts) || lhs->ts.type == BT_LOGICAL)
+ && rhs->ts.type == BT_CHARACTER
+ && (rhs->expr_type != EXPR_CONSTANT || !flag_dec_char_conversions))
+ {
+ /* Use of -fdec-char-conversions allows assignment of character data
+ to non-character variables. This not permited for nonconstant
+ strings. */
+ gfc_error ("Cannot convert %s to %s at %L", gfc_typename (rhs),
+ gfc_typename (lhs), &rhs->where);
+ return false;
+ }
/* Handle the case of a BOZ literal on the RHS. */
- if (rhs->is_boz && lhs->ts.type != BT_INTEGER)
+ if (rhs->ts.type == BT_BOZ)
{
- int rc;
- if (warn_surprising)
- gfc_warning (OPT_Wsurprising,
- "BOZ literal at %L is bitwise transferred "
- "non-integer symbol %qs", &code->loc,
- lhs->symtree->n.sym->name);
-
- if (!gfc_convert_boz (rhs, &lhs->ts))
+ if (gfc_invalid_boz ("BOZ literal constant at %L is neither a DATA "
+ "statement value nor an actual argument of "
+ "INT/REAL/DBLE/CMPLX intrinsic subprogram",
+ &rhs->where))
return false;
- if ((rc = gfc_range_check (rhs)) != ARITH_OK)
- {
- if (rc == ARITH_UNDERFLOW)
- gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
- ". This check can be disabled with the option "
- "%<-fno-range-check%>", &rhs->where);
- else if (rc == ARITH_OVERFLOW)
- gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
- ". This check can be disabled with the option "
- "%<-fno-range-check%>", &rhs->where);
- else if (rc == ARITH_NAN)
- gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
- ". This check can be disabled with the option "
- "%<-fno-range-check%>", &rhs->where);
+
+ switch (lhs->ts.type)
+ {
+ case BT_INTEGER:
+ if (!gfc_boz2int (rhs, lhs->ts.kind))
+ return false;
+ break;
+ case BT_REAL:
+ if (!gfc_boz2real (rhs, lhs->ts.kind))
+ return false;
+ break;
+ default:
+ gfc_error ("Invalid use of BOZ literal constant at %L", &rhs->where);
return false;
}
}
- if (lhs->ts.type == BT_CHARACTER
- && warn_character_truncation)
+ if (lhs->ts.type == BT_CHARACTER && warn_character_truncation)
{
HOST_WIDE_INT llen = 0, rlen = 0;
if (lhs->ts.u.cl != NULL
"component in a PURE procedure",
&rhs->where);
else
- gfc_error ("The impure variable at %L is assigned to "
- "a derived type variable with a POINTER "
- "component in a PURE procedure (12.6)",
+ /* F2008, C1283 (4). */
+ gfc_error ("In a pure subprogram an INTENT(IN) dummy argument "
+ "shall not be used as the expr at %L of an intrinsic "
+ "assignment statement in which the variable is of a "
+ "derived type if the derived type has a pointer "
+ "component at any level of component selection.",
&rhs->where);
return rval;
}
if (!gfc_check_dependency ((*code)->expr1, (*code)->expr2, 1))
return false;
+ if (gfc_expr_attr ((*code)->expr1).pointer)
+ return false;
+
tmp_expr = get_temp_from_expr ((*code)->expr1, ns);
tmp_expr->where = (*code)->loc;
case EXEC_OACC_PARALLEL:
case EXEC_OACC_KERNELS_LOOP:
case EXEC_OACC_KERNELS:
+ case EXEC_OACC_SERIAL_LOOP:
+ case EXEC_OACC_SERIAL:
case EXEC_OACC_DATA:
case EXEC_OACC_HOST_DATA:
case EXEC_OACC_LOOP:
case EXEC_GOTO:
if (code->expr1 != NULL)
{
- if (code->expr1->ts.type != BT_INTEGER)
- gfc_error ("ASSIGNED GOTO statement at %L requires an "
- "INTEGER variable", &code->expr1->where);
- else if (code->expr1->symtree->n.sym->attr.assign != 1)
+ if (code->expr1->expr_type != EXPR_VARIABLE
+ || code->expr1->ts.type != BT_INTEGER
+ || (code->expr1->ref
+ && code->expr1->ref->type == REF_ARRAY)
+ || code->expr1->symtree == NULL
+ || (code->expr1->symtree->n.sym
+ && (code->expr1->symtree->n.sym->attr.flavor
+ == FL_PARAMETER)))
+ gfc_error ("ASSIGNED GOTO statement at %L requires a "
+ "scalar INTEGER variable", &code->expr1->where);
+ else if (code->expr1->symtree->n.sym
+ && code->expr1->symtree->n.sym->attr.assign != 1)
gfc_error ("Variable %qs has not been assigned a target "
"label at %L", code->expr1->symtree->n.sym->name,
&code->expr1->where);
|| code->expr1->symtree->n.sym->ts.type != BT_INTEGER
|| code->expr1->symtree->n.sym->ts.kind
!= gfc_default_integer_kind
+ || code->expr1->symtree->n.sym->attr.flavor == FL_PARAMETER
|| code->expr1->symtree->n.sym->as != NULL))
gfc_error ("ASSIGN statement at %L requires a scalar "
"default INTEGER variable", &code->expr1->where);
resolve_select_type (code, ns);
break;
+ case EXEC_SELECT_RANK:
+ resolve_select_rank (code, ns);
+ break;
+
case EXEC_BLOCK:
resolve_block_construct (code);
break;
break;
case EXEC_OPEN:
- if (!gfc_resolve_open (code->ext.open))
+ if (!gfc_resolve_open (code->ext.open, &code->loc))
break;
resolve_branch (code->ext.open->err, code);
break;
case EXEC_CLOSE:
- if (!gfc_resolve_close (code->ext.close))
+ if (!gfc_resolve_close (code->ext.close, &code->loc))
break;
resolve_branch (code->ext.close->err, code);
case EXEC_READ:
case EXEC_WRITE:
- if (!gfc_resolve_dt (code->ext.dt, &code->loc))
+ if (!gfc_resolve_dt (code, code->ext.dt, &code->loc))
break;
resolve_branch (code->ext.dt->err, code);
case EXEC_OACC_PARALLEL:
case EXEC_OACC_KERNELS_LOOP:
case EXEC_OACC_KERNELS:
+ case EXEC_OACC_SERIAL_LOOP:
+ case EXEC_OACC_SERIAL:
case EXEC_OACC_DATA:
case EXEC_OACC_HOST_DATA:
case EXEC_OACC_LOOP:
&& (gsym->type == GSYM_FUNCTION || gsym->type == GSYM_SUBROUTINE)))
{
if (!gsym)
- gsym = gfc_get_gsymbol (sym->binding_label);
+ gsym = gfc_get_gsymbol (sym->binding_label, true);
gsym->where = sym->declared_at;
gsym->sym_name = sym->name;
gsym->binding_label = sym->binding_label;
sym->binding_label, &sym->declared_at, &gsym->where);
/* Clear the binding label to prevent checking multiple times. */
sym->binding_label = NULL;
-
+ return;
}
- else if (sym->attr.flavor == FL_VARIABLE && module
- && (strcmp (module, gsym->mod_name) != 0
- || strcmp (sym->name, gsym->sym_name) != 0))
+
+ if (sym->attr.flavor == FL_VARIABLE && module
+ && (strcmp (module, gsym->mod_name) != 0
+ || strcmp (sym->name, gsym->sym_name) != 0))
{
/* This can only happen if the variable is defined in a module - if it
isn't the same module, reject it. */
sym->name, module, sym->binding_label,
&sym->declared_at, &gsym->where, gsym->mod_name);
sym->binding_label = NULL;
+ return;
}
- else if ((sym->attr.function || sym->attr.subroutine)
- && ((gsym->type != GSYM_SUBROUTINE && gsym->type != GSYM_FUNCTION)
- || (gsym->defined && sym->attr.if_source != IFSRC_IFBODY))
- && sym != gsym->ns->proc_name
- && (module != gsym->mod_name
- || strcmp (gsym->sym_name, sym->name) != 0
- || (module && strcmp (module, gsym->mod_name) != 0)))
+
+ if ((sym->attr.function || sym->attr.subroutine)
+ && ((gsym->type != GSYM_SUBROUTINE && gsym->type != GSYM_FUNCTION)
+ || (gsym->defined && sym->attr.if_source != IFSRC_IFBODY))
+ && (sym != gsym->ns->proc_name && sym->attr.entry == 0)
+ && (module != gsym->mod_name
+ || strcmp (gsym->sym_name, sym->name) != 0
+ || (module && strcmp (module, gsym->mod_name) != 0)))
{
/* Print an error if the procedure is defined multiple times; we have to
exclude references to the same procedure via module association or
}
/* cl->length has been resolved. It should have an integer type. */
- if (cl->length->ts.type != BT_INTEGER)
+ if (cl->length->ts.type != BT_INTEGER || cl->length->rank != 0)
{
gfc_error ("Scalar INTEGER expression expected at %L",
&cl->length->where);
simplification now. */
for (i = 0; i < sym->as->rank + sym->as->corank; i++)
{
+ if (i == GFC_MAX_DIMENSIONS)
+ break;
+
e = sym->as->lower[i];
if (e && (!resolve_index_expr(e)
|| !gfc_is_constant_expr (e)))
{
gfc_error ("Array pointer %qs at %L must have a deferred shape or "
"assumed rank", sym->name, &sym->declared_at);
+ sym->error = 1;
return false;
}
}
|| sym->attr.associate_var
|| sym->attr.omp_udr_artificial_var))
{
+ /* If a function has a result variable, only check the variable. */
+ if (sym->result && sym->name != sym->result->name)
+ return true;
+
gfc_error ("Entity %qs at %L has a deferred type parameter and "
"requires either the POINTER or ALLOCATABLE attribute",
sym->name, &sym->declared_at);
static bool
resolve_fl_variable (gfc_symbol *sym, int mp_flag)
{
- int no_init_flag, automatic_flag;
- gfc_expr *e;
- const char *auto_save_msg;
- bool saved_specification_expr;
-
- auto_save_msg = "Automatic object %qs at %L cannot have the "
- "SAVE attribute";
+ const char *auto_save_msg = "Automatic object %qs at %L cannot have the "
+ "SAVE attribute";
if (!resolve_fl_var_and_proc (sym, mp_flag))
return false;
/* Set this flag to check that variables are parameters of all entries.
This check is effected by the call to gfc_resolve_expr through
is_non_constant_shape_array. */
- saved_specification_expr = specification_expr;
+ bool saved_specification_expr = specification_expr;
specification_expr = true;
if (sym->ns->proc_name
{
/* Make sure that character string variables with assumed length are
dummy arguments. */
+ gfc_expr *e = NULL;
+
if (sym->ts.u.cl)
e = sym->ts.u.cl->length;
else
apply_default_init_local (sym); /* Try to apply a default initialization. */
/* Determine if the symbol may not have an initializer. */
- no_init_flag = automatic_flag = 0;
+ int no_init_flag = 0, automatic_flag = 0;
if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
|| sym->attr.intrinsic || sym->attr.result)
no_init_flag = 1;
&& !resolve_fl_var_and_proc (sym, mp_flag))
return false;
+ /* Constraints on deferred type parameter. */
+ if (!deferred_requirements (sym))
+ return false;
+
if (sym->ts.type == BT_CHARACTER)
{
gfc_charlen *cl = sym->ts.u.cl;
module procedures are excluded by 2.2.3.3 - i.e., they are not
externally accessible and can access all the objects accessible in
the host. */
- if (!(sym->ns->parent
+ if (!(sym->ns->parent && sym->ns->parent->proc_name
&& sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
&& gfc_check_symbol_access (sym))
{
{
if (arg->sym
&& arg->sym->ts.type == BT_DERIVED
+ && arg->sym->ts.u.derived
&& !arg->sym->ts.u.derived->attr.use_assoc
&& !gfc_check_symbol_access (arg->sym->ts.u.derived)
&& !gfc_notify_std (GFC_STD_F2003, "%qs is of a PRIVATE type "
{
if (sym->attr.proc_pointer)
{
+ const char* name = (sym->attr.result ? sym->ns->proc_name->name
+ : sym->name);
gfc_error ("Procedure pointer %qs at %L shall not be elemental",
- sym->name, &sym->declared_at);
+ name, &sym->declared_at);
return false;
}
if (sym->attr.dummy)
if (sym->attr.subroutine && sym->attr.result)
{
gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
- "in %qs at %L", sym->name, &sym->declared_at);
+ "in %qs at %L", sym->ns->proc_name->name, &sym->declared_at);
return false;
}
if (sym->attr.external && sym->attr.function && !sym->attr.module_procedure
if (sym1->attr.subroutine != sym2->attr.subroutine
|| sym1->attr.function != sym2->attr.function)
{
- gfc_error ("%qs and %qs can't be mixed FUNCTION/SUBROUTINE for"
+ gfc_error ("%qs and %qs cannot be mixed FUNCTION/SUBROUTINE for"
" GENERIC %qs at %L",
sym1->name, sym2->name, generic_name, &where);
return false;
/* If we attempt to "overwrite" a specific binding, this is an error. */
if (p->overridden && !p->overridden->is_generic)
{
- gfc_error ("GENERIC %qs at %L can't overwrite specific binding with"
+ gfc_error ("GENERIC %qs at %L cannot overwrite specific binding with"
" the same name", name, &p->where);
return false;
}
/* F08:C468. All operator bindings must have a passed-object dummy argument. */
if (target->specific->nopass)
{
- gfc_error ("Type-bound operator at %L can't be NOPASS", &where);
+ gfc_error ("Type-bound operator at %L cannot be NOPASS", &where);
return NULL;
}
}
else
{
+ /* If proc has not been resolved at this point, proc->name may
+ actually be a USE associated entity. See PR fortran/89647. */
+ if (!proc->resolve_symbol_called
+ && proc->attr.function == 0 && proc->attr.subroutine == 0)
+ {
+ gfc_symbol *tmp;
+ gfc_find_symbol (proc->name, gfc_current_ns->parent, 1, &tmp);
+ if (tmp && tmp->attr.use_assoc)
+ {
+ proc->module = tmp->module;
+ proc->attr.proc = tmp->attr.proc;
+ proc->attr.function = tmp->attr.function;
+ proc->attr.subroutine = tmp->attr.subroutine;
+ proc->attr.use_assoc = tmp->attr.use_assoc;
+ proc->ts = tmp->ts;
+ proc->result = tmp->result;
+ }
+ }
+
/* Check for F08:C465. */
if ((!proc->attr.subroutine && !proc->attr.function)
|| (proc->attr.proc != PROC_MODULE
&& proc->attr.if_source != IFSRC_IFBODY)
|| proc->attr.abstract)
{
- gfc_error ("%qs must be a module procedure or an external procedure with"
- " an explicit interface at %L", proc->name, &where);
+ gfc_error ("%qs must be a module procedure or an external "
+ "procedure with an explicit interface at %L",
+ proc->name, &where);
goto error;
}
}
resolve_component (gfc_component *c, gfc_symbol *sym)
{
gfc_symbol *super_type;
+ symbol_attribute *attr;
if (c->attr.artificial)
return true;
}
/* F2008, C448. */
- if (c->attr.contiguous && (!c->attr.dimension || !c->attr.pointer))
+ if (c->ts.type == BT_CLASS)
+ {
+ if (CLASS_DATA (c))
+ {
+ attr = &(CLASS_DATA (c)->attr);
+
+ /* Fix up contiguous attribute. */
+ if (c->attr.contiguous)
+ attr->contiguous = 1;
+ }
+ else
+ attr = NULL;
+ }
+ else
+ attr = &c->attr;
+
+ if (attr && attr->contiguous && (!attr->dimension || !attr->pointer))
{
gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but "
"is not an array pointer", c->name, &c->loc);
}
}
- if (async_io_dt)
- {
- for (nl = sym->namelist; nl; nl = nl->next)
- nl->sym->attr.asynchronous = 1;
- }
return true;
}
gfc_array_spec *as;
bool saved_specification_expr;
- if (sym->resolved)
+ if (sym->resolve_symbol_called >= 1)
return;
- sym->resolved = 1;
+ sym->resolve_symbol_called = 1;
/* No symbol will ever have union type; only components can be unions.
Union type declaration symbols have type BT_UNKNOWN but flavor FL_UNION
if (flag_coarray == GFC_FCOARRAY_LIB && sym->ts.type == BT_CLASS
&& sym->ts.u.derived && CLASS_DATA (sym)
&& CLASS_DATA (sym)->attr.codimension
+ && CLASS_DATA (sym)->ts.u.derived
&& (CLASS_DATA (sym)->ts.u.derived->attr.alloc_comp
|| CLASS_DATA (sym)->ts.u.derived->attr.pointer_comp))
{
}
/* TS 29113, C535a. */
if (as->type == AS_ASSUMED_RANK && !sym->attr.dummy
- && !sym->attr.select_type_temporary)
+ && !sym->attr.select_type_temporary
+ && !(cs_base && cs_base->current
+ && cs_base->current->op == EXEC_SELECT_RANK))
{
gfc_error ("Assumed-rank array at %L must be a dummy argument",
&sym->declared_at);
for (; formal; formal = formal->next)
if (formal->sym && formal->sym->attr.flavor == FL_NAMELIST)
{
- gfc_error ("Namelist %qs can not be an argument to "
+ gfc_error ("Namelist %qs cannot be an argument to "
"subroutine or function at %L",
formal->sym->name, &sym->declared_at);
return;
/* Set the formal_arg_flag so that check_conflict will not throw
an error for host associated variables in the specification
expression for an array_valued function. */
- if (sym->attr.function && sym->as)
+ if ((sym->attr.function || sym->attr.result) && sym->as)
formal_arg_flag = true;
saved_specification_expr = specification_expr;
if (formal)
{
sym->formal_ns = formal->sym->ns;
- if (sym->ns != formal->sym->ns)
+ if (sym->formal_ns && sym->ns != formal->sym->ns)
sym->formal_ns->refs++;
}
}
return false;
}
- has_pointer = sym->attr.pointer;
-
if (gfc_is_coindexed (e))
{
gfc_error ("DATA element %qs at %L cannot have a coindex", sym->name,
return false;
}
+ has_pointer = sym->attr.pointer;
+
for (ref = e->ref; ref; ref = ref->next)
{
if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
has_pointer = 1;
- if (has_pointer
- && ref->type == REF_ARRAY
- && ref->u.ar.type != AR_FULL)
- {
- gfc_error ("DATA element %qs at %L is a pointer and so must "
- "be a full array", sym->name, where);
- return false;
- }
+ if (has_pointer)
+ {
+ if (ref->type == REF_ARRAY && ref->u.ar.type != AR_FULL)
+ {
+ gfc_error ("DATA element %qs at %L is a pointer and so must "
+ "be a full array", sym->name, where);
+ return false;
+ }
+
+ if (values.vnode->expr->expr_type == EXPR_CONSTANT)
+ {
+ gfc_error ("DATA object near %L has the pointer attribute "
+ "and the corresponding DATA value is not a valid "
+ "initial-data-target", where);
+ return false;
+ }
+ }
}
if (e->rank == 0 || has_pointer)
&& !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where))
continue;
- identical_types:
+identical_types:
+
last_ts =&sym->ts;
last_where = &e->where;
continue;
/* Shall not be an automatic array. */
- if (e->ref->type == REF_ARRAY
- && !gfc_resolve_array_spec (e->ref->u.ar.as, 1))
+ if (e->ref->type == REF_ARRAY && is_non_constant_shape_array (sym))
{
gfc_error ("Array %qs at %L with non-constant bounds cannot be "
"an EQUIVALENCE object", sym->name, &e->where);
}
-/* Function called by resolve_fntype to flag other symbol used in the
- length type parameter specification of function resuls. */
+/* Function called by resolve_fntype to flag other symbols used in the
+ length type parameter specification of function results. */
static bool
flag_fn_result_spec (gfc_expr *expr,
gfc_data *d;
gfc_equiv *eq;
gfc_namespace* old_ns = gfc_current_ns;
+ bool recursive = ns->proc_name && ns->proc_name->attr.recursive;
if (ns->types_resolved)
return;
if (ns->proc_name && ns->proc_name->attr.flavor == FL_PROCEDURE
&& ns->proc_name->attr.if_source == IFSRC_IFBODY)
- resolve_formal_arglist (ns->proc_name);
+ gfc_resolve_formal_arglist (ns->proc_name);
gfc_traverse_ns (ns, resolve_bind_c_derived_types);
gfc_traverse_ns (ns, resolve_values);
- if (ns->save_all)
+ if (ns->save_all || (!flag_automatic && !recursive))
gfc_save_all (ns);
iter_stack = NULL;
bitmap_obstack_initialize (&labels_obstack);
gfc_resolve_oacc_declare (ns);
+ gfc_resolve_oacc_routines (ns);
gfc_resolve_omp_local_vars (ns);
gfc_resolve_code (ns->code, ns);
projects / gcc.git / blobdiff