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);
}
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;
&& (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
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 (0, "Interface mismatch in global procedure %qs at %L:"
- " %s", sym->name, &sym->declared_at, reason);
+ /* 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.allow_std & GFC_STD_GNU)
+ && !bad_result_characteristics)
+ gfc_errors_to_warnings (true);
+
+ 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)
{
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 is BOZ, then op2 is not!. Try to convert to type of op2. */
if (op1->ts.type == BT_BOZ)
{
- if (gfc_invalid_boz ("BOZ literal constant near %L cannot appear as "
- "an operand of a relational operator",
- &op1->where))
+ 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))
/* 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 ("BOZ literal constant near %L cannot appear as "
- "an operand of a relational operator",
+ if (gfc_invalid_boz (G_("BOZ literal constant near %L cannot appear"
+ " as an operand of a relational operator"),
&op2->where))
return false;
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), &op1->where);
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);
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)
+ 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 the rest of the expr
+ /* 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. */
/* 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 (tsym->attr.subroutine
- || tsym->attr.external
- || (tsym->attr.function && tsym->result != tsym))
+ if (gfc_expr_attr (target).proc_pointer)
{
- gfc_error ("Associating entity %qs at %L is a procedure name",
+ gfc_error ("Associating entity %qs at %L is a procedure pointer",
tsym->name, &target->where);
return;
}
- if (gfc_expr_attr (target).proc_pointer)
+ if (tsym->attr.flavor == FL_PROCEDURE && tsym->generic
+ && (dsym = gfc_find_dt_in_generic (tsym)) != NULL
+ && dsym->attr.flavor == FL_DERIVED)
{
- gfc_error ("Associating entity %qs at %L is a procedure pointer",
+ 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_;
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)
gfc_namespace *ns;
gfc_code *body, *new_st, *tail;
gfc_case *c;
- char tname[GFC_MAX_SYMBOL_LEN];
+ char tname[GFC_MAX_SYMBOL_LEN + 7];
char name[2 * GFC_MAX_SYMBOL_LEN];
gfc_symtree *st;
gfc_expr *selector_expr = NULL;
"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_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);
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);
}
/* 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);
{
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;
}
}
{
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 proc has not been resolved at this point, proc->name may
actually be a USE associated entity. See PR fortran/89647. */
- if (!proc->resolved
+ if (!proc->resolve_symbol_called
&& proc->attr.function == 0 && proc->attr.subroutine == 0)
{
gfc_symbol *tmp;
}
}
- 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))
{
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++;
}
}
&& !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);
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);
projects / gcc.git / blobdiff