Fortran: Diagnose all operands/arguments with constraint violations

04-Nov-2021  Sandra Loosemore <sandra@codesourcery.com>
	     Bernhard Reutner-Fischer <aldot@gcc.gnu.org>

	 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 24698be8364231976344a055aaea4320a0f2dc65..30c99ef3938d85110cdb4d99dcfa1b3a08b5b9a1 100644 (file)
--- 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",
                         &a->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, &a->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",
                       &a->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, &a->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, &a->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, &a->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"
                       " array at %L", f->sym->name, where);
-         return false;
+         ok = false;
+         goto match;
        }
 
       /* Diagnose F2018 C839 (TS29113 C535c).  Here the problem is
@@ -3421,7 +3432,8 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
            gfc_error ("Actual argument to assumed-rank INTENT(OUT) "
                       "dummy %qs at %L cannot be of unknown size",
                       f->sym->name, where);
-         return false;
+         ok = false;
+         goto match;
        }
 
       if (a->expr->expr_type != EXPR_NULL
@@ -3430,7 +3442,8 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
          if (where)
            gfc_error ("Actual argument for %qs must be a pointer at %L",
                       f->sym->name, &a->expr->where);
-         return false;
+         ok = false;
+         goto match;
        }
 
       if (a->expr->expr_type != EXPR_NULL
@@ -3440,7 +3453,8 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
          if (where)
            gfc_error ("Fortran 2008: Non-pointer actual argument at %L to "
                       "pointer dummy %qs", &a->expr->where,f->sym->name);
-         return false;
+         ok = false;
+         goto match;
        }
 
 
@@ -3451,7 +3465,8 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
            gfc_error ("Coindexed actual argument at %L to pointer "
                       "dummy %qs",
                       &a->expr->where, f->sym->name);
-         return false;
+         ok = false;
+         goto match;
        }
 
       /* Fortran 2008, 12.5.2.5 (no constraint).  */
@@ -3464,7 +3479,8 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
            gfc_error ("Coindexed actual argument at %L to allocatable "
                       "dummy %qs requires INTENT(IN)",
                       &a->expr->where, f->sym->name);
-         return false;
+         ok = false;
+         goto match;
        }
 
       /* Fortran 2008, C1237.  */
@@ -3479,7 +3495,8 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
                       "%L requires that dummy %qs has neither "
                       "ASYNCHRONOUS nor VOLATILE", &a->expr->where,
                       f->sym->name);
-         return false;
+         ok = false;
+         goto match;
        }
 
       /* Fortran 2008, 12.5.2.4 (no constraint).  */
@@ -3492,7 +3509,8 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
            gfc_error ("Coindexed actual argument at %L with allocatable "
                       "ultimate component to dummy %qs requires either VALUE "
                       "or INTENT(IN)", &a->expr->where, f->sym->name);
-         return false;
+         ok = false;
+         goto match;
        }
 
      if (f->sym->ts.type == BT_CLASS
@@ -3503,7 +3521,8 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
          if (where)
            gfc_error ("Actual CLASS array argument for %qs must be a full "
                       "array at %L", f->sym->name, &a->expr->where);
-         return false;
+         ok = false;
+         goto match;
        }
 
 
@@ -3513,7 +3532,8 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
          if (where)
            gfc_error ("Actual argument for %qs must be ALLOCATABLE at %L",
                       f->sym->name, &a->expr->where);
-         return false;
+         ok = false;
+         goto match;
        }
 
       /* Check intent = OUT/INOUT for definable actual argument.  */
@@ -3529,9 +3549,15 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
                && CLASS_DATA (f->sym)->attr.class_pointer)
               || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer))
              && !gfc_check_vardef_context (a->expr, true, false, false, context))
-           return false;
+           {
+             ok = false;
+             goto match;
+           }
          if (!gfc_check_vardef_context (a->expr, false, false, false, context))
-           return false;
+           {
+             ok = false;
+             goto match;
+           }
        }
 
       if ((f->sym->attr.intent == INTENT_OUT
@@ -3546,7 +3572,8 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
                       "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute "
                       "of the dummy argument %qs",
                       &a->expr->where, f->sym->name);
-         return false;
+         ok = false;
+         goto match;
        }
 
       /* C1232 (R1221) For an actual argument which is an array section or
@@ -3564,7 +3591,8 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
                       "incompatible with the non-assumed-shape "
                       "dummy argument %qs due to VOLATILE attribute",
                       &a->expr->where,f->sym->name);
-         return false;
+         ok = false;
+         goto match;
        }
 
       /* Find the last array_ref.  */
@@ -3581,7 +3609,8 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
                       "incompatible with the non-assumed-shape "
                       "dummy argument %qs due to VOLATILE attribute",
                       &a->expr->where, f->sym->name);
-         return false;
+         ok = false;
+         goto match;
        }
 
       /* C1233 (R1221) For an actual argument which is a pointer array, the
@@ -3601,7 +3630,8 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
                       "an assumed-shape or pointer-array dummy "
                       "argument %qs due to VOLATILE attribute",
                       &a->expr->where,f->sym->name);
-         return false;
+         ok = false;
+         goto match;
        }
 
     match:
@@ -3611,6 +3641,10 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
       new_arg[i++] = a;
     }
 
+  /* Give up now if we saw any bad argument.  */
+  if (!ok)
+    return false;
+
   /* Make sure missing actual arguments are optional.  */
   i = 0;
   for (f = formal; f; f = f->next, i++)

diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index f5c88d98cc9280269e39cbdb7858362089f73735..54d2d33c7d5cc24bfd2148db8b3b57ea1bbfd95f 100644 (file)
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -223,6 +223,7 @@ static bool
 do_ts29113_check (gfc_intrinsic_sym *specific, gfc_actual_arglist *arg)
 {
   gfc_actual_arglist *a;
+  bool ok = true;
 
   for (a = arg; a; a = a->next)
     {
@@ -238,7 +239,7 @@ do_ts29113_check (gfc_intrinsic_sym *specific, gfc_actual_arglist *arg)
          gfc_error ("Variable with NO_ARG_CHECK attribute at %L is only "
                     "permitted as argument to the intrinsic functions "
                     "C_LOC and PRESENT", &a->expr->where);
-         return false;
+         ok = false;
        }
       else if (a->expr->ts.type == BT_ASSUMED
               && specific->id != GFC_ISYM_LBOUND
@@ -254,32 +255,32 @@ do_ts29113_check (gfc_intrinsic_sym *specific, gfc_actual_arglist *arg)
          gfc_error ("Assumed-type argument at %L is not permitted as actual"
                     " argument to the intrinsic %s", &a->expr->where,
                     gfc_current_intrinsic);
-         return false;
+         ok = false;
        }
       else if (a->expr->ts.type == BT_ASSUMED && a != arg)
        {
          gfc_error ("Assumed-type argument at %L is only permitted as "
                     "first actual argument to the intrinsic %s",
                     &a->expr->where, gfc_current_intrinsic);
-         return false;
+         ok = false;
        }
-      if (a->expr->rank == -1 && !specific->inquiry)
+      else if (a->expr->rank == -1 && !specific->inquiry)
        {
          gfc_error ("Assumed-rank argument at %L is only permitted as actual "
                     "argument to intrinsic inquiry functions",
                     &a->expr->where);
-         return false;
+         ok = false;
        }
-      if (a->expr->rank == -1 && arg != a)
+      else if (a->expr->rank == -1 && arg != a)
        {
          gfc_error ("Assumed-rank argument at %L is only permitted as first "
                     "actual argument to the intrinsic inquiry function %s",
                     &a->expr->where, gfc_current_intrinsic);
-         return false;
+         ok = false;
        }
     }
 
-  return true;
+  return ok;
 }
 
 

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 1f4abd087208bc4e5cac4a0857313d087061f044..705d2326a29492741de6fca4bb8238ebd27f0446 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -4064,7 +4064,7 @@ resolve_operator (gfc_expr *e)
     {
     default:
       if (!gfc_resolve_expr (e->value.op.op2))
-       return false;
+       t = false;
 
     /* Fall through.  */
 
@@ -4091,6 +4091,9 @@ resolve_operator (gfc_expr *e)
   op2 = e->value.op.op2;
   if (op1 == NULL && op2 == NULL)
     return false;
+  /* Error out if op2 did not resolve. We already diagnosed op1.  */
+  if (t == false)
+    return false;
 
   dual_locus_error = false;
 

diff --git a/gcc/testsuite/gfortran.dg/bessel_3.f90 b/gcc/testsuite/gfortran.dg/bessel_3.f90
index 88177258c0de2c3f1cdf5676749fa650a51f6c80..51e11e9160a9b71d6b3d0597de935f896b62b9e0 100644 (file)
--- a/gcc/testsuite/gfortran.dg/bessel_3.f90
+++ b/gcc/testsuite/gfortran.dg/bessel_3.f90
@@ -9,10 +9,10 @@ print *, SIN (1.0)
 print *, BESSEL_J0(1.0) ! { dg-error "has no IMPLICIT type" })
 print *, BESSEL_J1(1.0) ! { dg-error "has no IMPLICIT type" }
 print *, BESSEL_JN(1,1.0) ! { dg-error "has no IMPLICIT type|Type mismatch" }
-print *, BESSEL_JN(1,2,1.0) ! { dg-error "has no IMPLICIT type|Type mismatch" }
+print *, BESSEL_JN(1,2,1.0) ! { dg-error "has no IMPLICIT type|Type mismatch|More actual than formal" }
 
 print *, BESSEL_Y0(1.0) ! { dg-error "has no IMPLICIT type" }
 print *, BESSEL_Y1(1.0) ! { dg-error "has no IMPLICIT type" }
 print *, BESSEL_YN(1,1.0) ! { dg-error "has no IMPLICIT type|Type mismatch" }
-print *, BESSEL_YN(1,2,1.0) ! { dg-error "has no IMPLICIT type|Type mismatch" }
+print *, BESSEL_YN(1,2,1.0) ! { dg-error "has no IMPLICIT type|Type mismatch|More actual than formal" }
 end

diff --git a/gcc/testsuite/gfortran.dg/c-interop/c407b-2.f90 b/gcc/testsuite/gfortran.dg/c-interop/c407b-2.f90
index 3d3cd635279eac1f512c96619c33a5ed2c38cb81..4f9f6c73d7d8b84a799c3e26bcd627c95cbcedae 100644 (file)
--- a/gcc/testsuite/gfortran.dg/c-interop/c407b-2.f90
+++ b/gcc/testsuite/gfortran.dg/c-interop/c407b-2.f90
@@ -78,11 +78,11 @@ subroutine s2 (x, y)
   end select
 
   ! relational operations
-  if (x & ! { dg-error "Assumed.type" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+  if (x & ! { dg-error "Assumed.type" "pr101337" }
       .eq. y) then  ! { dg-error "Assumed.type" } 
     return
   end if
-  if (.not. (x & ! { dg-error "Assumed.type" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+  if (.not. (x & ! { dg-error "Assumed.type" "pr101337" }
              .ne. y)) then  ! { dg-error "Assumed.type" } 
     return
   end if
@@ -99,7 +99,7 @@ subroutine s2 (x, y)
   ! arithmetic
   i = x + 1  ! { dg-error "Assumed.type" } 
   i = -y  ! { dg-error "Assumed.type" } 
-  i = (x & ! { dg-error "Assumed.type" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+  i = (x & ! { dg-error "Assumed.type" "pr101337" }
        + y)  ! { dg-error "Assumed.type" } 
 
   ! computed go to
@@ -131,19 +131,19 @@ subroutine s3 (x, y)
   i = exponent (x)  ! { dg-error "Assumed.type" }
 
   if (extends_type_of (x, &  ! { dg-error "Assumed.type" }
-                       y)) then  ! { dg-error "Assumed.type" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+                       y)) then  ! { dg-error "Assumed.type" "pr101337" }
     return
   end if
 
   if (same_type_as (x, &  ! { dg-error "Assumed.type" }
-                    y)) then  ! { dg-error "Assumed.type" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+                    y)) then  ! { dg-error "Assumed.type" "pr101337" }
     return
   end if
 
   i = storage_size (x)  ! { dg-error "Assumed.type" }
 
   i = iand (x, &  ! { dg-error "Assumed.type" }
-            y)    ! { dg-error "Assumed.type" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+            y)    ! { dg-error "Assumed.type" "pr101337" }
 
   i = kind (x)  ! { dg-error "Assumed.type" }
 

diff --git a/gcc/testsuite/gfortran.dg/c-interop/c535b-2.f90 b/gcc/testsuite/gfortran.dg/c-interop/c535b-2.f90
index 2dafd4490c3bf357674102d03aea2ab954ddd4ae..4d99f7fdb0e678678c555d82aa437efe4db371e8 100644 (file)
--- a/gcc/testsuite/gfortran.dg/c-interop/c535b-2.f90
+++ b/gcc/testsuite/gfortran.dg/c-interop/c535b-2.f90
@@ -57,18 +57,18 @@ subroutine test_calls (x, y)
   ! Make sure each invalid argument produces a diagnostic.
   ! scalar dummies
   call f (x, &  ! { dg-error "(A|a)ssumed.rank" }
-          y)  ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+          y)  ! { dg-error "(A|a)ssumed.rank" "pr101337" } 
   ! assumed-rank dummies
   call g (x, y)  ! OK
   ! assumed-size dummies
   call h (x, &  ! { dg-error "(A|a)ssumed.rank" "pr101334" }
-          y)  ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+          y)  ! { dg-error "(A|a)ssumed.rank" "pr101337" }
   ! assumed-shape dummies
   call i (x, &  ! { dg-error "(A|a)ssumed.rank" }
-          y)  ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+          y)  ! { dg-error "(A|a)ssumed.rank" "pr101337" }
  ! fixed-size array dummies
   call j (x, &  ! { dg-error "(A|a)ssumed.rank" "pr101334" }
-          y)  ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+          y)  ! { dg-error "(A|a)ssumed.rank" "pr101337" }
 end subroutine
 
 ! Check that you can't use an assumed-rank array variable in an array
@@ -81,7 +81,7 @@ subroutine test_designators (x)
 
   call f (x(1), 1)  ! { dg-error "(A|a)ssumed.rank" }
   call g (x(1:3:1), &  ! { dg-error "(A|a)ssumed.rank" }
-          x)  ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+          x)
 end subroutine
 
 ! Check that you can't use an assumed-rank array variable in elemental
@@ -122,7 +122,7 @@ subroutine test_expressions (a, b, c, l, m, n, x, y, z, p, q, r, s, i, j)
 
   z = x + y  ! OK
   c &  ! { dg-error "(A|a)ssumed.rank" }
-    = a &  ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+    = a &  ! { dg-error "(A|a)ssumed.rank" "pr101337" }
     + b  ! { dg-error "(A|a)ssumed.rank" }
   z = x + i  ! OK
   c &  ! { dg-error "(A|a)ssumed.rank" }
@@ -133,7 +133,7 @@ subroutine test_expressions (a, b, c, l, m, n, x, y, z, p, q, r, s, i, j)
 
   z = x - y  ! OK
   c &  ! { dg-error "(A|a)ssumed.rank" }
-    = a &  ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+    = a &  ! { dg-error "(A|a)ssumed.rank" "pr101337" }
     - b  ! { dg-error "(A|a)ssumed.rank" }
   z = x - i  ! OK
   c &  ! { dg-error "(A|a)ssumed.rank" }
@@ -144,7 +144,7 @@ subroutine test_expressions (a, b, c, l, m, n, x, y, z, p, q, r, s, i, j)
 
   z = x * y  ! OK
   c &  ! { dg-error "(A|a)ssumed.rank" }
-    = a &  ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+    = a &  ! { dg-error "(A|a)ssumed.rank" "pr101337" }
     * b  ! { dg-error "(A|a)ssumed.rank" }
   z = x * i  ! OK
   c &  ! { dg-error "(A|a)ssumed.rank" }
@@ -155,7 +155,7 @@ subroutine test_expressions (a, b, c, l, m, n, x, y, z, p, q, r, s, i, j)
 
   z = x / y  ! OK
   c &  ! { dg-error "(A|a)ssumed.rank" }
-    = a &  ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+    = a &  ! { dg-error "(A|a)ssumed.rank" "pr101337" }
     / b  ! { dg-error "(A|a)ssumed.rank" }
   z = x / i  ! OK
   c &  ! { dg-error "(A|a)ssumed.rank" }
@@ -166,7 +166,7 @@ subroutine test_expressions (a, b, c, l, m, n, x, y, z, p, q, r, s, i, j)
 
   z = x ** y  ! OK
   c &  ! { dg-error "(A|a)ssumed.rank" }
-    = a &  ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+    = a &  ! { dg-error "(A|a)ssumed.rank" "pr101337" }
     ** b  ! { dg-error "(A|a)ssumed.rank" }
   z = x ** i  ! OK
   c &  ! { dg-error "(A|a)ssumed.rank" }
@@ -179,7 +179,7 @@ subroutine test_expressions (a, b, c, l, m, n, x, y, z, p, q, r, s, i, j)
 
   r = x .eq. y  ! OK
   n &  ! { dg-error "(A|a)ssumed.rank" }
-    = a &  ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+    = a &  ! { dg-error "(A|a)ssumed.rank" "pr101337" }
     .eq. b  ! { dg-error "(A|a)ssumed.rank" }
   r = x .eq. i  ! OK
   n &  ! { dg-error "(A|a)ssumed.rank" }
@@ -190,7 +190,7 @@ subroutine test_expressions (a, b, c, l, m, n, x, y, z, p, q, r, s, i, j)
 
   r = x .ne. y  ! OK
   n &  ! { dg-error "(A|a)ssumed.rank" }
-    = a &  ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+    = a &  ! { dg-error "(A|a)ssumed.rank" "pr101337" }
     .ne. b  ! { dg-error "(A|a)ssumed.rank" }
   r = x .ne. i  ! OK
   n &  ! { dg-error "(A|a)ssumed.rank" }
@@ -201,7 +201,7 @@ subroutine test_expressions (a, b, c, l, m, n, x, y, z, p, q, r, s, i, j)
 
   r = x .lt. y  ! OK
   n &  ! { dg-error "(A|a)ssumed.rank" }
-    = a &  ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+    = a &  ! { dg-error "(A|a)ssumed.rank" "pr101337" }
     .lt. b  ! { dg-error "(A|a)ssumed.rank" }
   r = x .lt. i  ! OK
   n &  ! { dg-error "(A|a)ssumed.rank" }
@@ -212,7 +212,7 @@ subroutine test_expressions (a, b, c, l, m, n, x, y, z, p, q, r, s, i, j)
 
   r = x .le. y  ! OK
   n &  ! { dg-error "(A|a)ssumed.rank" }
-    = a &  ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+    = a &  ! { dg-error "(A|a)ssumed.rank" "pr101337" }
     .le. b  ! { dg-error "(A|a)ssumed.rank" }
   r = x .le. i  ! OK
   n &  ! { dg-error "(A|a)ssumed.rank" }
@@ -223,7 +223,7 @@ subroutine test_expressions (a, b, c, l, m, n, x, y, z, p, q, r, s, i, j)
 
   r = x .gt. y  ! OK
   n &  ! { dg-error "(A|a)ssumed.rank" }
-    = a &  ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+    = a &  ! { dg-error "(A|a)ssumed.rank" "pr101337" }
     .gt. b  ! { dg-error "(A|a)ssumed.rank" }
   r = x .gt. i  ! OK
   n &  ! { dg-error "(A|a)ssumed.rank" }
@@ -234,7 +234,7 @@ subroutine test_expressions (a, b, c, l, m, n, x, y, z, p, q, r, s, i, j)
 
   r = x .ge. y  ! OK
   n &  ! { dg-error "(A|a)ssumed.rank" }
-    = a &  ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+    = a &  ! { dg-error "(A|a)ssumed.rank" "pr101337" }
     .ge. b  ! { dg-error "(A|a)ssumed.rank" }
   r = x .ge. i  ! OK
   n &  ! { dg-error "(A|a)ssumed.rank" }
@@ -253,7 +253,7 @@ subroutine test_expressions (a, b, c, l, m, n, x, y, z, p, q, r, s, i, j)
 
   r = p .and. q  ! OK
   n &  ! { dg-error "(A|a)ssumed.rank" }
-    = l &  ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+    = l &  ! { dg-error "(A|a)ssumed.rank" "pr101337" }
     .and. m  ! { dg-error "(A|a)ssumed.rank" }
   r = p .and. j  ! OK
   n &  ! { dg-error "(A|a)ssumed.rank" }
@@ -264,7 +264,7 @@ subroutine test_expressions (a, b, c, l, m, n, x, y, z, p, q, r, s, i, j)
 
   r = p .or. q  ! OK
   n &  ! { dg-error "(A|a)ssumed.rank" }
-    = l &  ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+    = l &  ! { dg-error "(A|a)ssumed.rank" "pr101337" }
     .or. m  ! { dg-error "(A|a)ssumed.rank" }
   r = p .or. j  ! OK
   n &  ! { dg-error "(A|a)ssumed.rank" }
@@ -275,7 +275,7 @@ subroutine test_expressions (a, b, c, l, m, n, x, y, z, p, q, r, s, i, j)
 
   r = p .eqv. q  ! OK
   n &  ! { dg-error "(A|a)ssumed.rank" }
-    = l &  ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+    = l &  ! { dg-error "(A|a)ssumed.rank" "pr101337" }
     .eqv. m  ! { dg-error "(A|a)ssumed.rank" }
   r = p .eqv. j  ! OK
   n &  ! { dg-error "(A|a)ssumed.rank" }
@@ -286,7 +286,7 @@ subroutine test_expressions (a, b, c, l, m, n, x, y, z, p, q, r, s, i, j)
 
   r = p .neqv. q  ! OK
   n &  ! { dg-error "(A|a)ssumed.rank" }
-    = l &  ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+    = l &  ! { dg-error "(A|a)ssumed.rank" "pr101337" }
     .neqv. m  ! { dg-error "(A|a)ssumed.rank" }
   r = p .neqv. j  ! OK
   n &  ! { dg-error "(A|a)ssumed.rank" }
@@ -320,7 +320,7 @@ subroutine test_intrinsics (i1, i2, r1, r2, c1, c2, l1, l2, s1, s2)
   ! trig, hyperbolic, other math functions
   r1 &  ! { dg-error "(A|a)ssumed.rank" }
     = atan2 (r1, &  ! { dg-error "(A|a)ssumed.rank" }
-             r2)  ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+             r2)  ! { dg-error "(A|a)ssumed.rank" "pr101337" }
   r1 &  ! { dg-error "(A|a)ssumed.rank" }
     = atan (r2)  ! { dg-error "(A|a)ssumed.rank" }
   c1 &  ! { dg-error "(A|a)ssumed.rank" }
@@ -335,7 +335,7 @@ subroutine test_intrinsics (i1, i2, r1, r2, c1, c2, l1, l2, s1, s2)
   ! bit operations
   l1 &  ! { dg-error "(A|a)ssumed.rank" }
     = blt (i1, &  ! { dg-error "(A|a)ssumed.rank" }
-           i2)  ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+           i2)  ! { dg-error "(A|a)ssumed.rank" "pr101337" }
   l1 &  ! { dg-error "(A|a)ssumed.rank" }
     = btest (i1, 0)  ! { dg-error "(A|a)ssumed.rank" }
   i1 &  ! { dg-error "(A|a)ssumed.rank" }
@@ -348,7 +348,7 @@ subroutine test_intrinsics (i1, i2, r1, r2, c1, c2, l1, l2, s1, s2)
     = char (i1)  ! { dg-error "(A|a)ssumed.rank" }
   c1 &  ! { dg-error "(A|a)ssumed.rank" }
     = cmplx (r1, &  ! { dg-error "(A|a)ssumed.rank" }
-             r2)  ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+             r2)  ! { dg-error "(A|a)ssumed.rank" "pr101337" }
   i1 &  ! { dg-error "(A|a)ssumed.rank" }
     = floor (r1)  ! { dg-error "(A|a)ssumed.rank" }
   r1 &  ! { dg-error "(A|a)ssumed.rank" }
@@ -357,16 +357,16 @@ subroutine test_intrinsics (i1, i2, r1, r2, c1, c2, l1, l2, s1, s2)
   ! reductions
   l = any (l2)  ! { dg-error "(A|a)ssumed.rank" }
   r = dot_product (r1, &  ! { dg-error "(A|a)ssumed.rank" }
-                   r2)  ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+                   r2)  ! { dg-error "(A|a)ssumed.rank" "pr101337" }
   i = iall (i2, &  ! { dg-error "(A|a)ssumed.rank" }
-            l2)  ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+            l2)  ! { dg-error "(A|a)ssumed.rank" "pr101337" }
 
   ! string operations
   s1 &  ! { dg-error "(A|a)ssumed.rank" }
     = adjustr (s2)  ! { dg-error "(A|a)ssumed.rank" }
   i1 &  ! { dg-error "(A|a)ssumed.rank" }
     = index (c1, &  ! { dg-error "(A|a)ssumed.rank" }
-             c2)  ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+             c2)  ! { dg-error "(A|a)ssumed.rank" "pr101337" }
 
   ! misc
   i1 &  ! { dg-error "(A|a)ssumed.rank" }
@@ -374,12 +374,12 @@ subroutine test_intrinsics (i1, i2, r1, r2, c1, c2, l1, l2, s1, s2)
   i = findloc (r1, 0.0)  ! { dg-error "(A|a)ssumed.rank" }
   r1 &  ! { dg-error "(A|a)ssumed.rank" }
     = matmul (r1, &  ! { dg-error "(A|a)ssumed.rank" }
-              r2)  ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+              r2)  ! { dg-error "(A|a)ssumed.rank" "pr101337" }
   r1 &  ! { dg-error "(A|a)ssumed.rank" }
     = reshape (r2, [10, 3])  ! { dg-error "(A|a)ssumed.rank" }
   i1 &  ! { dg-error "(A|a)ssumed.rank" }
     = sign (i1, &  ! { dg-error "(A|a)ssumed.rank" }
-            i2)  ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+            i2)  ! { dg-error "(A|a)ssumed.rank" "pr101337" }
   s1 &  ! { dg-error "(A|a)ssumed.rank" }
     = transpose (s2)  ! { dg-error "(A|a)ssumed.rank" }
 

diff --git a/gcc/testsuite/gfortran.dg/pr24823.f b/gcc/testsuite/gfortran.dg/pr24823.f
index c6f638fbd0c1be1f804ec74bd4ef43ed13206179..93cd8a3deabb55d11341192bef7c0e3fa3c86dde 100644 (file)
--- a/gcc/testsuite/gfortran.dg/pr24823.f
+++ b/gcc/testsuite/gfortran.dg/pr24823.f
@@ -61,8 +61,8 @@
                   IF( ISYM.EQ.0 ) THEN
                   END IF
                END IF
-               A( I-J+KUU+1, J ) = ZLATM2( M, N, I, J, KL, KU,
-     $              DR, IPVTNG, IWORK, SPARSE )
+               A( I-J+KUU+1, J ) = ZLATM2( M, N, I, J, KL, KU,  ! { dg-warning "More actual than formal" }
+     $              DR, IPVTNG, IWORK, SPARSE )  ! { dg-warning "Type mismatch" }
             END IF
          END IF
       END IF

diff --git a/gcc/testsuite/gfortran.dg/pr39937.f b/gcc/testsuite/gfortran.dg/pr39937.f
index 17d3eb46a21336e002cee3c4752290da5cbd86cd..ed28693964eca240151172f6eb20bb2df9756595 100644 (file)
--- a/gcc/testsuite/gfortran.dg/pr39937.f
+++ b/gcc/testsuite/gfortran.dg/pr39937.f
@@ -20,7 +20,7 @@ C { dg-options "-std=legacy" }
           END IF
           CALL DLALN2( .FALSE., 2, 2, SMIN, ONE,
      $                            T( J-1, J-1 ), LDT, ONE, ONE,  ! { dg-warning "Type mismatch" }
-     $                            XNORM, IERR )
+     $                            XNORM, IERR )  ! { dg-warning "Type mismatch" }
           CALL DAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1,
      $                           WORK( 1+N ), 1 )
           CALL DAXPY( J-2, -X( 2, 2 ), T( 1, J ), 1,

diff --git a/gcc/testsuite/gfortran.dg/pr41011.f b/gcc/testsuite/gfortran.dg/pr41011.f
index 5a3218581d39c4ef7e241d8a8546e93662b1b32a..c0323102a0c7bb2a4baa11d1e0f4a2e9061023ea 100644 (file)
--- a/gcc/testsuite/gfortran.dg/pr41011.f
+++ b/gcc/testsuite/gfortran.dg/pr41011.f
@@ -1,6 +1,6 @@
 ! { dg-do compile }
 ! { dg-options "-O3 -std=legacy" }
-      CALL UVSET(NX,NY,NZ,HVAR,ZET,NP,DZ,DKM,UM,VM,UG,VG,TM,DCDX, ! { dg-warning "Rank mismatch" }
+      CALL UVSET(NX,NY,NZ,HVAR,ZET,NP,DZ,DKM,UM,VM,UG,VG,TM,DCDX, ! { dg-warning "Rank mismatch|Invalid procedure argument" }
      *ITY,ISH,NSMT,F)
          CALL DCTDX(NX,NY,NX1,NFILT,C(MLAG),DCDX(MLAG),HELP,HELPA,
      *   HELP,HELPA,FY,FYC,SAVEY)
@@ -18,6 +18,6 @@
      *WORK(*)
       IF(IH.EQ.0) THEN
          CALL PADEC(DKM,VM,HVAR,WORK(LWM),WORK(LWG), ! { dg-warning "Rank mismatch" }
-     *   WORK(LF),NZ,WORK(LA),WORK(LB),WORK(LC),ITY)
+     *   WORK(LF),NZ,WORK(LA),WORK(LB),WORK(LC),ITY) ! { dg-warning "Type mismatch" }
       ENDIF
       END

diff --git a/gcc/testsuite/gfortran.dg/pr61318.f90 b/gcc/testsuite/gfortran.dg/pr61318.f90
index 57da52d58905389d455b561f241430c7ae008ea3..7752ecda08e4d53b6b3823bfe3706410d43d5327 100644 (file)
--- a/gcc/testsuite/gfortran.dg/pr61318.f90
+++ b/gcc/testsuite/gfortran.dg/pr61318.f90
@@ -18,5 +18,5 @@ end module gbl_interfaces
 program test
   use gbl_message
   use gbl_interfaces
-  call gagout(seve%e,'Some string') ! { dg-error "Type mismatch in argument" }
+  call gagout(seve%e,'Some string') ! { dg-error "Type mismatch in argument|More actual than formal" }
 end program test