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);
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++;
}
}
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