From patchwork Fri Nov 5 02:58:50 2021 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Sandra Loosemore X-Patchwork-Id: 47080 Return-Path: X-Original-To: patchwork@sourceware.org Delivered-To: patchwork@sourceware.org Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id EEF233857814 for ; Fri, 5 Nov 2021 02:59:17 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from esa1.mentor.iphmx.com (esa1.mentor.iphmx.com [68.232.129.153]) by sourceware.org (Postfix) with ESMTPS id 191233858D35; Fri, 5 Nov 2021 02:58:59 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org 191233858D35 Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=codesourcery.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=mentor.com IronPort-SDR: R6tI/Vv0yoNlh+Vzicxm3UReV3/bH+agmj/Kr/KhDnejm14UfAeyVJGDFbe/hLejI+SYB1zPsr w3h26PBSAjrF9qxvxKNhVURX92x0rlfGw+FNeanqJHlqOVKiM5ba9dog8uVWH55NhIGtgRoghv A+hMQE+II435ELIb7VWLbTrDWC8kFZmoyFAGg6UqbHKuEUvIRNnSGI57NLKi9Tzal27p1ms6Ug l8x2gRexMSd02MAMDU4basR7vwMOurK3hXyflM6UWBaakMOLQm2KPwi6tnWcEJuzouAjHIkZtx VqDJ0lCR7Y7cHpFUvzEZVyEr X-IronPort-AV: E=Sophos;i="5.87,210,1631606400"; d="scan'208";a="70573293" Received: from orw-gwy-02-in.mentorg.com ([192.94.38.167]) by esa1.mentor.iphmx.com with ESMTP; 04 Nov 2021 18:58:59 -0800 IronPort-SDR: 9wWlAjrCHzdr56DAw0vRXFxosGKc5hriztHoAe5Z8iFU5feeOwQljG/zfRFAGE64TLRzXjP0Zj WeqrvuAAteljIA6dSI+hohKqu9R9nOWfrOwkSWGdYKFu2Po6Mw1ytKihvyrUsbjnE0XwJ2Qdnt PXobVG9Hl4tIf4FCLAkAchLsIsHeq5m/1gvx+D75ojYuWQUWDWK3KArMAyujG5go6ScASPvw6p RQIXyM5mDVN9H+GKqwA5F4ntL+zE3X7QGDBHEyRkrygSG2He24DbCzjIAUM+Qfhq6+NjlaHQDp 3nk= To: "fortran@gcc.gnu.org" , "gcc-patches@gcc.gnu.org" , Bernhard Reutner-Fischer From: Sandra Loosemore Subject: [PATCH] Fortran: Diagnose all operands/arguments with constraint violations Message-ID: <109c753a-69b2-4b92-8967-cdacd065d90d@codesourcery.com> Date: Thu, 4 Nov 2021 20:58:50 -0600 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:78.0) Gecko/20100101 Thunderbird/78.13.0 MIME-Version: 1.0 Content-Language: en-US X-ClientProxiedBy: SVR-ORW-MBX-07.mgc.mentorg.com (147.34.90.207) To svr-orw-mbx-03.mgc.mentorg.com (147.34.90.203) X-Spam-Status: No, score=-8.2 required=5.0 tests=BAYES_00, GIT_PATCH_0, HEADER_FROM_DIFFERENT_DOMAINS, KAM_DMARC_STATUS, KAM_STOCKGEN, SCC_10_SHORT_WORD_LINES, SCC_5_SHORT_WORD_LINES, SPF_HELO_PASS, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.4 X-Spam-Checker-Version: SpamAssassin 3.4.4 (2020-01-24) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: gcc-patches-bounces+patchwork=sourceware.org@gcc.gnu.org Sender: "Gcc-patches" 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", &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 f5c88d9..54d2d33 100644 --- 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 21126cb..bb6a838 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -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; diff --git a/gcc/testsuite/gfortran.dg/bessel_3.f90 b/gcc/testsuite/gfortran.dg/bessel_3.f90 index 8817725..51e11e9 100644 --- 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 3d3cd63..4f9f6c7 100644 --- 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 2dafd44..4d99f7f 100644 --- 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 c6f638f..93cd8a3 100644 --- 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 17d3eb4..ed28693 100644 --- 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 5a32185..c032310 100644 --- 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 57da52d..7752ecd 100644 --- 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