This is an expanded version of the patch for PR 101337 that Bernhard
sent out a few days ago with a request for me to finish it. Bernhard
did the part for operands and I added the pieces for procedure arguments
and intrinsics, along with fixing up the test cases that were previously
full of xfails and a few others that were now showing multiple
diagnostics as a result of this change.
I suspect there might be other places where we are failing to check all
subexpressions for errors, but this catches all the ones I wrote
TS29113-related testcases for, at least.
OK to commit?
-Sandra
commit bf03dfe2431b15b44a6bbf5605bbf5af32199f87
Author: Sandra Loosemore
Date: Thu Nov 4 15:43:29 2021 -0700
Fortran: Diagnose all operands/arguments with constraint violations [PR101337]
04-Nov-2021 Sandra Loosemore
Bernhard Reutner-Fischer
PR fortran/101337
gcc/fortran/ChangeLog:
* interface.c (gfc_compare_actual_formal): Continue checking
all arguments after encountering an error.
* intrinsic.c (do_ts29113_check): Likewise.
* resolve.c (resolve_operator): Continue resolving on op2 error.
gcc/testsuite/ChangeLog:
* gfortran.dg/bessel_3.f90: Expect additional diagnostics from
multiple bad arguments in the call.
* gfortran.dg/pr24823.f: Likewise.
* gfortran.dg/pr39937.f: Likewise.
* gfortran.dg/pr41011.f: Likewise.
* gfortran.dg/pr61318.f90: Likewise.
* gfortran.dg/c-interop/c407b-2.f90: Remove xfails.
* gfortran.dg/c-interop/c535b-2.f90: Likewise.
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 24698be..30c99ef 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -3064,6 +3064,8 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
gfc_array_spec *fas, *aas;
bool pointer_dummy, pointer_arg, allocatable_arg;
+ bool ok = true;
+
actual = *ap;
if (actual == NULL && formal == NULL)
@@ -3134,7 +3136,6 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
if (where)
gfc_error ("More actual than formal arguments in procedure "
"call at %L", where);
-
return false;
}
@@ -3192,13 +3193,16 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
else if (where)
gfc_error ("Fortran 2008: Null pointer at %L to non-pointer "
"dummy %qs", where, f->sym->name);
-
- return false;
+ ok = false;
+ goto match;
}
if (!compare_parameter (f->sym, a->expr, ranks_must_agree,
is_elemental, where))
- return false;
+ {
+ ok = false;
+ goto match;
+ }
/* TS 29113, 6.3p2; F2018 15.5.2.4. */
if (f->sym->ts.type == BT_ASSUMED
@@ -3217,7 +3221,8 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
"has type parameters or is of "
"derived type with type-bound or FINAL procedures",
>expr->where);
- return false;
+ ok = false;
+ goto match;
}
}
@@ -3249,7 +3254,8 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
mpz_get_si (a->expr->ts.u.cl->length->value.integer),
mpz_get_si (f->sym->ts.u.cl->length->value.integer),
f->sym->name, >expr->where);
- return false;
+ ok = false;
+ goto match;
}
if ((f->sym->attr.pointer || f->sym->attr.allocatable)
@@ -3261,7 +3267,8 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
"pointer dummy argument %qs must have a deferred "
"length type parameter if and only if the dummy has one",
>expr->where, f->sym->name);
- return false;
+ ok = false;
+ goto match;
}
if (f->sym->ts.type == BT_CLASS)
@@ -3295,7 +3302,8 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
"at %L", f->sym->name, actual_size,
formal_size, >expr->where);
}
- return false;
+ ok = false;
+ goto match;
}
skip_size_check:
@@ -3312,7 +3320,8 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
if (where)
gfc_error ("Expected a procedure pointer for argument %qs at %L",
f->sym->name, >expr->where);
- return false;
+ ok = false;
+ goto match;
}
/* Satisfy F03:12.4.1.3 by ensuring that a procedure actual argument is
@@ -3328,7 +3337,8 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
if (where)
gfc_error ("Expected a procedure for argument %qs at %L",
f->sym->name, >expr->where);
- return false;
+ ok = false;
+ goto match;
}
/* Class array variables and expressions store array info in a
@@ -3392,7 +3402,8 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
if (where)
gfc_error ("Actual argument for %qs cannot be an assumed-size"
"
