commit bf03dfe2431b15b44a6bbf5605bbf5af32199f87
Author: Sandra Loosemore <sandra@codesourcery.com>
Date: Thu Nov 4 15:43:29 2021 -0700
Fortran: Diagnose all operands/arguments with constraint violations [PR101337]
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.
@@ -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++)
@@ -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;
}
@@ -4051,7 +4051,7 @@ resolve_operator (gfc_expr *e)
{
default:
if (!gfc_resolve_expr (e->value.op.op2))
- return false;
+ t = false;
/* Fall through. */
@@ -4078,6 +4078,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;
@@ -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
@@ -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" }
@@ -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" }
@@ -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
@@ -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,
@@ -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
@@ -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