From: Thomas Koenig Date: Sat, 14 Sep 2019 20:40:55 +0000 (+0000) Subject: re PR fortran/91557 (Bogus warning about unused dummy argument _formal_*) X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=e0b9e5f9e3c90a55e643ea850cf828e3e6480fb5;p=gcc.git re PR fortran/91557 (Bogus warning about unused dummy argument _formal_*) 2019-09-14 Thomas Koenig PR fortran/91557 PR fortran/91556 * frontend-passes.c (check_externals_procedure): Reformat argument list. Use gfc_compare_actual_formal instead of gfc_procedure_use. * gfortran.h (gfc_symbol): Add flag error. * interface.c (gfc_compare_interfaces): Reformat. (argument_rank_mismatch): Add where_formal argument. If it is present, note that the error is between different calls. (compare_parameter): Change warnings that previously dependended on -Wargument-mismatch to unconditional. Issue an error / warning on type mismatch only once. Pass where_formal to argument_rank_mismatch for artificial variables. (compare_actual_formal): Change warnings that previously dependeded on -Wargument-mismatch to unconditional. (gfc_check_typebound_override): Likewise. (gfc_get_formal_from_actual_arglist): Set declared_at for artificial symbol. * invoke.texi: Extend description of -fallow-argument-mismatch. Delete -Wargument-mismatch. * lang.opt: Change -Wargument-mismatch to do-nothing option. * resolve.c (resolve_structure_cons): Change warnings that previously depended on -Wargument-mismatch to unconditional. * trans-decl.c (generate_local_decl): Do not warn if the symbol is artificial. 2019-09-14 Thomas Koenig PR fortran/91557 PR fortran/91556 * gfortran.dg/argument_checking_20.f90: New test. * gfortran.dg/argument_checking_21.f90: New test. * gfortran.dg/argument_checking_22.f90: New test. * gfortran.dg/argument_checking_23.f90: New test. * gfortran.dg/warn_unused_dummy_argument_5.f90: New test. * gfortran.dg/bessel_3.f90: Add pattern for type mismatch. * gfortran.dg/g77/20010519-1.f: Adjust dg-warning messages to new handling. * gfortran.dg/pr24823.f: Likewise. * gfortran.dg/pr39937.f: Likewise. From-SVN: r275719 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 6f2ba754726..56a107dae0a 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,30 @@ +2019-09-14 Thomas Koenig + + PR fortran/91557 + PR fortran/91556 + * frontend-passes.c (check_externals_procedure): Reformat argument + list. Use gfc_compare_actual_formal instead of gfc_procedure_use. + * gfortran.h (gfc_symbol): Add flag error. + * interface.c (gfc_compare_interfaces): Reformat. + (argument_rank_mismatch): Add where_formal argument. If it is + present, note that the error is between different calls. + (compare_parameter): Change warnings that previously dependended + on -Wargument-mismatch to unconditional. Issue an error / warning + on type mismatch only once. Pass where_formal to + argument_rank_mismatch for artificial variables. + (compare_actual_formal): Change warnings that previously + dependeded on -Wargument-mismatch to unconditional. + (gfc_check_typebound_override): Likewise. + (gfc_get_formal_from_actual_arglist): Set declared_at for + artificial symbol. + * invoke.texi: Extend description of -fallow-argument-mismatch. + Delete -Wargument-mismatch. + * lang.opt: Change -Wargument-mismatch to do-nothing option. + * resolve.c (resolve_structure_cons): Change warnings that + previously depended on -Wargument-mismatch to unconditional. + * trans-decl.c (generate_local_decl): Do not warn if the symbol is + artificial. + 2019-09-13 Steven G. Kargl PR fortran/91566 diff --git a/gcc/fortran/frontend-passes.c b/gcc/fortran/frontend-passes.c index 86debab0599..b095d5f3420 100644 --- a/gcc/fortran/frontend-passes.c +++ b/gcc/fortran/frontend-passes.c @@ -5373,7 +5373,8 @@ gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn, /* Common tests for argument checking for both functions and subroutines. */ static int -check_externals_procedure (gfc_symbol *sym, locus *loc, gfc_actual_arglist *actual) +check_externals_procedure (gfc_symbol *sym, locus *loc, + gfc_actual_arglist *actual) { gfc_gsymbol *gsym; gfc_symbol *def_sym = NULL; @@ -5396,7 +5397,7 @@ check_externals_procedure (gfc_symbol *sym, locus *loc, gfc_actual_arglist *actu if (def_sym) { - gfc_procedure_use (def_sym, &actual, loc); + gfc_compare_actual_formal (&actual, def_sym->formal, 0, 0, 0, loc); return 0; } diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 80e31ee1a87..6f7717d1134 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -1610,6 +1610,9 @@ typedef struct gfc_symbol /* Set if this is a module function or subroutine with the abreviated declaration in a submodule. */ unsigned abr_modproc_decl:1; + /* Set if a previous error or warning has occurred and no other + should be reported. */ + unsigned error:1; int refs; struct gfc_namespace *ns; /* namespace containing this symbol */ diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 43d7cd5a296..08e4f063a67 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -1807,9 +1807,9 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2, if (!compare_rank (f2->sym, f1->sym)) { if (errmsg != NULL) - snprintf (errmsg, err_len, "Rank mismatch in argument '%s' " - "(%i/%i)", f1->sym->name, symbol_rank (f1->sym), - symbol_rank (f2->sym)); + snprintf (errmsg, err_len, "Rank mismatch in argument " + "'%s' (%i/%i)", f1->sym->name, + symbol_rank (f1->sym), symbol_rank (f2->sym)); return false; } if ((gfc_option.allow_std & GFC_STD_F2008) @@ -2189,22 +2189,42 @@ compare_pointer (gfc_symbol *formal, gfc_expr *actual) static void argument_rank_mismatch (const char *name, locus *where, - int rank1, int rank2) + int rank1, int rank2, locus *where_formal) { /* TS 29113, C407b. */ - if (rank2 == -1) - gfc_error ("The assumed-rank array at %L requires that the dummy argument" - " %qs has assumed-rank", where, name); - else if (rank1 == 0) - gfc_error_opt (OPT_Wargument_mismatch, "Rank mismatch in argument %qs " - "at %L (scalar and rank-%d)", name, where, rank2); - else if (rank2 == 0) - gfc_error_opt (OPT_Wargument_mismatch, "Rank mismatch in argument %qs " - "at %L (rank-%d and scalar)", name, where, rank1); + if (where_formal == NULL) + { + if (rank2 == -1) + gfc_error ("The assumed-rank array at %L requires that the dummy " + "argument %qs has assumed-rank", where, name); + else if (rank1 == 0) + gfc_error_opt (0, "Rank mismatch in argument %qs " + "at %L (scalar and rank-%d)", name, where, rank2); + else if (rank2 == 0) + gfc_error_opt (0, "Rank mismatch in argument %qs " + "at %L (rank-%d and scalar)", name, where, rank1); + else + gfc_error_opt (0, "Rank mismatch in argument %qs " + "at %L (rank-%d and rank-%d)", name, where, rank1, + rank2); + } else - gfc_error_opt (OPT_Wargument_mismatch, "Rank mismatch in argument %qs " - "at %L (rank-%d and rank-%d)", name, where, rank1, rank2); + { + gcc_assert (rank2 != -1); + if (rank1 == 0) + gfc_error_opt (0, "Rank mismatch between actual argument at %L " + "and actual argument at %L (scalar and rank-%d)", + where, where_formal, rank2); + else if (rank2 == 0) + gfc_error_opt (0, "Rank mismatch between actual argument at %L " + "and actual argument at %L (rank-%d and scalar)", + where, where_formal, rank1); + else + gfc_error_opt (0, "Rank mismatch between actual argument at %L " + "and actual argument at %L (rank-%d and rank-%d", where, + where_formal, rank1, rank2); + } } @@ -2253,8 +2273,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, sizeof(err), NULL, NULL)) { if (where) - gfc_error_opt (OPT_Wargument_mismatch, - "Interface mismatch in dummy procedure %qs at %L:" + gfc_error_opt (0, "Interface mismatch in dummy procedure %qs at %L:" " %s", formal->name, &actual->where, err); return false; } @@ -2281,8 +2300,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, err, sizeof(err), NULL, NULL)) { if (where) - gfc_error_opt (OPT_Wargument_mismatch, - "Interface mismatch in dummy procedure %qs at %L:" + gfc_error_opt (0, "Interface mismatch in dummy procedure %qs at %L:" " %s", formal->name, &actual->where, err); return false; } @@ -2312,10 +2330,24 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, CLASS_DATA (actual)->ts.u.derived))) { if (where) - gfc_error_opt (OPT_Wargument_mismatch, - "Type mismatch in argument %qs at %L; passed %s to %s", - formal->name, where, gfc_typename (&actual->ts), - gfc_typename (&formal->ts)); + { + if (formal->attr.artificial) + { + if (!flag_allow_argument_mismatch || !formal->error) + gfc_error_opt (0, "Type mismatch between actual argument at %L " + "and actual argument at %L (%s/%s).", + &actual->where, + &formal->declared_at, + gfc_typename (&actual->ts), + gfc_typename (&formal->ts)); + + formal->error = 1; + } + else + gfc_error_opt (0, "Type mismatch in argument %qs at %L; passed %s " + "to %s", formal->name, where, gfc_typename (&actual->ts), + gfc_typename (&formal->ts)); + } return false; } @@ -2512,8 +2544,17 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, && gfc_is_coindexed (actual))) { if (where) - argument_rank_mismatch (formal->name, &actual->where, - symbol_rank (formal), actual->rank); + { + locus *where_formal; + if (formal->attr.artificial) + where_formal = &formal->declared_at; + else + where_formal = NULL; + + argument_rank_mismatch (formal->name, &actual->where, + symbol_rank (formal), actual->rank, + where_formal); + } return false; } else if (actual->rank != 0 && (is_elemental || formal->attr.dimension)) @@ -2584,8 +2625,17 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, if (ref == NULL && actual->expr_type != EXPR_NULL) { if (where) - argument_rank_mismatch (formal->name, &actual->where, - symbol_rank (formal), actual->rank); + { + locus *where_formal; + if (formal->attr.artificial) + where_formal = &formal->declared_at; + else + where_formal = NULL; + + argument_rank_mismatch (formal->name, &actual->where, + symbol_rank (formal), actual->rank, + where_formal); + } return false; } @@ -3062,16 +3112,14 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, f->sym->ts.u.cl->length->value.integer) != 0)) { if (where && (f->sym->attr.pointer || f->sym->attr.allocatable)) - gfc_warning (OPT_Wargument_mismatch, - "Character length mismatch (%ld/%ld) between actual " + gfc_warning (0, "Character length mismatch (%ld/%ld) between actual " "argument and pointer or allocatable dummy argument " "%qs at %L", 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); else if (where) - gfc_warning (OPT_Wargument_mismatch, - "Character length mismatch (%ld/%ld) between actual " + gfc_warning (0, "Character length mismatch (%ld/%ld) between actual " "argument and assumed-shape dummy argument %qs " "at %L", mpz_get_si (a->expr->ts.u.cl->length->value.integer), @@ -3102,8 +3150,7 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, && f->sym->attr.flavor != FL_PROCEDURE) { if (a->expr->ts.type == BT_CHARACTER && !f->sym->as && where) - gfc_warning (OPT_Wargument_mismatch, - "Character length of actual argument shorter " + gfc_warning (0, "Character length of actual argument shorter " "than of dummy argument %qs (%lu/%lu) at %L", f->sym->name, actual_size, formal_size, &a->expr->where); @@ -3111,8 +3158,7 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, { /* Emit a warning for -std=legacy and an error otherwise. */ if (gfc_option.warn_std == 0) - gfc_warning (OPT_Wargument_mismatch, - "Actual argument contains too few " + gfc_warning (0, "Actual argument contains too few " "elements for dummy argument %qs (%lu/%lu) " "at %L", f->sym->name, actual_size, formal_size, &a->expr->where); @@ -4706,8 +4752,7 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old) if (!gfc_check_dummy_characteristics (proc_formal->sym, old_formal->sym, check_type, err, sizeof(err))) { - gfc_error_opt (OPT_Wargument_mismatch, - "Argument mismatch for the overriding procedure " + gfc_error_opt (0, "Argument mismatch for the overriding procedure " "%qs at %L: %s", proc->name, &where, err); return false; } @@ -5184,6 +5229,7 @@ gfc_get_formal_from_actual_arglist (gfc_symbol *sym, } } s->attr.dummy = 1; + s->declared_at = a->expr->where; s->attr.intent = INTENT_UNKNOWN; (*f)->sym = s; } diff --git a/gcc/fortran/invoke.texi b/gcc/fortran/invoke.texi index ed8cefb0979..fa60effdbfe 100644 --- a/gcc/fortran/invoke.texi +++ b/gcc/fortran/invoke.texi @@ -145,7 +145,7 @@ by type. Explanations are in the following sections. @item Error and Warning Options @xref{Error and Warning Options,,Options to request or suppress errors and warnings}. -@gccoptlist{-Waliasing -Wall -Wampersand -Wargument-mismatch -Warray-bounds @gol +@gccoptlist{-Waliasing -Wall -Wampersand -Warray-bounds @gol -Wc-binding-type -Wcharacter-truncation -Wconversion @gol -Wdo-subscript -Wfunction-elimination -Wimplicit-interface @gol -Wimplicit-procedure -Wintrinsic-shadow -Wuse-without-only @gol @@ -236,8 +236,15 @@ intrinsic will be called except when it is explicitly declared @code{EXTERNAL}. Some code contains calls to external procedures whith mismatches between the calls and the procedure definition, or with mismatches between different calls. Such code is non-conforming, and will usually -be flagged with an error. This options degrades the error to a -warning. This option is implied by @option{-std=legacy}. +be flagged wi1th an error. This options degrades the error to a +warning, which can only be disabled by disabling all warnings vial +@option{-w}. Only a single occurrence per argument is flagged by this +warning. @option{-fallow-argument-mismatch} is implied by +@option{-std=legacy}. + +Using this option is @emph{strongly} discouraged. It is possible to +provide standard-conforming code which allows different types of +arguments by using an explicit interface and @code{TYPE(*)}. @item -fallow-invalid-boz @opindex @code{allow-invalid-boz} @@ -907,15 +914,6 @@ character constant, GNU Fortran assumes continuation at the first non-comment, non-whitespace character after the ampersand that initiated the continuation. -@item -Wargument-mismatch -@opindex @code{Wargument-mismatch} -@cindex warnings, argument mismatch -@cindex warnings, parameter mismatch -@cindex warnings, interface mismatch -Warn about type, rank, and other mismatches between formal parameters and actual -arguments to functions and subroutines. These warnings are recommended and -thus enabled by default. - @item -Warray-temporaries @opindex @code{Warray-temporaries} @cindex warnings, array temporaries diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt index 1b3364ba9d3..2cfc76df2ab 100644 --- a/gcc/fortran/lang.opt +++ b/gcc/fortran/lang.opt @@ -210,8 +210,8 @@ Fortran Warning Var(warn_array_temporaries) Warn about creation of array temporaries. Wargument-mismatch -Fortran Warning Var(warn_argument_mismatch) Init(1) -Warn about type and rank mismatches between arguments and parameters. +Fortran WarnRemoved +Does nothing. Preserved for backward compatibility. Wc-binding-type Fortran Var(warn_c_binding_type) Warning LangEnabledBy(Fortran,Wall) diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 383ba442f42..c4260bbb09c 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -1429,8 +1429,7 @@ resolve_structure_cons (gfc_expr *expr, int init) if (s2 && !gfc_compare_interfaces (comp->ts.interface, s2, name, 0, 1, err, sizeof (err), NULL, NULL)) { - gfc_error_opt (OPT_Wargument_mismatch, - "Interface mismatch for procedure-pointer " + gfc_error_opt (0, "Interface mismatch for procedure-pointer " "component %qs in structure constructor at %L:" " %s", comp->name, &cons->expr->where, err); return false; @@ -2609,8 +2608,7 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, int sub) if (!gfc_compare_interfaces (sym, def_sym, sym->name, 0, 1, reason, sizeof(reason), NULL, NULL)) { - gfc_error_opt (OPT_Wargument_mismatch, - "Interface mismatch in global procedure %qs at %L:" + gfc_error_opt (0, "Interface mismatch in global procedure %qs at %L:" " %s", sym->name, &sym->declared_at, reason); goto done; } diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 3c6ab60e9b2..c2c5d9d1b6a 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -5881,9 +5881,11 @@ generate_local_decl (gfc_symbol * sym) } else if (warn_unused_dummy_argument) { - gfc_warning (OPT_Wunused_dummy_argument, - "Unused dummy argument %qs at %L", sym->name, - &sym->declared_at); + if (!sym->attr.artificial) + gfc_warning (OPT_Wunused_dummy_argument, + "Unused dummy argument %qs at %L", sym->name, + &sym->declared_at); + if (sym->backend_decl != NULL_TREE) TREE_NO_WARNING(sym->backend_decl) = 1; } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 45ab4ea3310..bfc9e8a35a1 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,18 @@ +2019-09-14 Thomas Koenig + + PR fortran/91557 + PR fortran/91556 + * gfortran.dg/argument_checking_20.f90: New test. + * gfortran.dg/argument_checking_21.f90: New test. + * gfortran.dg/argument_checking_22.f90: New test. + * gfortran.dg/argument_checking_23.f90: New test. + * gfortran.dg/warn_unused_dummy_argument_5.f90: New test. + * gfortran.dg/bessel_3.f90: Add pattern for type mismatch. + * gfortran.dg/g77/20010519-1.f: Adjust dg-warning messages to new + handling. + * gfortran.dg/pr24823.f: Likewise. + * gfortran.dg/pr39937.f: Likewise. + 2019-09-14 Sandra Loosemore PR testsuite/83889 diff --git a/gcc/testsuite/gfortran.dg/argument_checking_20.f90 b/gcc/testsuite/gfortran.dg/argument_checking_20.f90 new file mode 100644 index 00000000000..12788cc868c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/argument_checking_20.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +program main + real :: a(10), b(10,10) +! This should be caugt + call foo(1.0) ! { dg-error "Rank mismatch" } + call foo(b) ! { dg-error "Rank mismatch" } +! This is OK + call bar(a) + call bar(b) + +end program main diff --git a/gcc/testsuite/gfortran.dg/argument_checking_21.f90 b/gcc/testsuite/gfortran.dg/argument_checking_21.f90 new file mode 100644 index 00000000000..d4f2ddf67f3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/argument_checking_21.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-fallow-argument-mismatch" } +program main + real :: a(10), b(10,10) +! This should be caugt + call foo(1.0) ! { dg-warning "Rank mismatch" } + call foo(b) ! { dg-warning "Rank mismatch" } +! This is OK + call bar(a) + call bar(b) + +end program main diff --git a/gcc/testsuite/gfortran.dg/argument_checking_22.f90 b/gcc/testsuite/gfortran.dg/argument_checking_22.f90 new file mode 100644 index 00000000000..783b53ffef4 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/argument_checking_22.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! PR 91556 - check that multiple errors are emitted for type mismatch +! (and that the check is also done in contained procedures). + +program main + real :: a + call foo(a) ! { dg-error "Type mismatch" } +contains + subroutine bar + integer :: b + complex :: c + call foo(b) ! { dg-error "Type mismatch" } + call foo(c) ! { dg-error "Type mismatch" } + end subroutine bar +end program main diff --git a/gcc/testsuite/gfortran.dg/argument_checking_23.f90 b/gcc/testsuite/gfortran.dg/argument_checking_23.f90 new file mode 100644 index 00000000000..74f72e364d7 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/argument_checking_23.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! { dg-options "-fallow-argument-mismatch" } +! PR 91556 - check that only a single warning iw emitted for type +! mismatch (and that the check is also done in contained procedures). + +program main + real :: a + call foo(a) ! { dg-warning "Type mismatch" } +contains + subroutine bar + integer :: b + complex :: c + call foo(b) ! { dg-warning "Type mismatch" } + call foo(c) + end subroutine bar +end program main diff --git a/gcc/testsuite/gfortran.dg/bessel_3.f90 b/gcc/testsuite/gfortran.dg/bessel_3.f90 index 05610ae0c38..88177258c0d 100644 --- a/gcc/testsuite/gfortran.dg/bessel_3.f90 +++ b/gcc/testsuite/gfortran.dg/bessel_3.f90 @@ -8,11 +8,11 @@ IMPLICIT NONE 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" } +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_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" } +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" } end diff --git a/gcc/testsuite/gfortran.dg/g77/20010519-1.f b/gcc/testsuite/gfortran.dg/g77/20010519-1.f index 4cefb958600..8a59906194d 100644 --- a/gcc/testsuite/gfortran.dg/g77/20010519-1.f +++ b/gcc/testsuite/gfortran.dg/g77/20010519-1.f @@ -773,7 +773,7 @@ C NTR=6 OLDPRN=PRNLEV PRNLEV=1 - CALL ORTHNM(1,6,NTR,HEAP(TRAROT),NAT3,.FALSE.,TOLER) + CALL ORTHNM(1,6,NTR,HEAP(TRAROT),NAT3,.FALSE.,TOLER) ! { dg-warning "Type mismatch" } PRNLEV=OLDPRN IF(IUNRMD .LT. 0) THEN C @@ -1126,7 +1126,7 @@ C NFCUT=NFRET OLDPRN=PRNLEV PRNLEV=1 - CALL ORTHNM(1,NFRET,NFCUT,DDV,NAT3,LPURG,TOLER) ! { dg-warning "Type mismatch" } + CALL ORTHNM(1,NFRET,NFCUT,DDV,NAT3,LPURG,TOLER) PRNLEV=OLDPRN NFRET=NFCUT IF(PRNLEV.GE.2) WRITE(OUTU,568) NFRET @@ -1174,7 +1174,7 @@ C TO DO-THE-DIAGONALISATIONS NFSAV=NFCUT1 OLDPRN=PRNLEV PRNLEV=1 - CALL ORTHNM(1,NFCUT1,NFCUT,DDV,NAT3,LPURG,TOLER) ! { dg-warning "Type mismatch" } + CALL ORTHNM(1,NFCUT1,NFCUT,DDV,NAT3,LPURG,TOLER) PRNLEV=OLDPRN CALL CPARAY(HEAP(DDVBAS),DDV,NAT3,1,NFCUT,1) NFRET=NDIM+NFCUT @@ -1224,7 +1224,7 @@ C CALL ADZERD(DDV,1,NFCUT1,NAT3,IS1,IS2,IS3,IS4) OLDPRN=PRNLEV PRNLEV=1 - CALL ORTHNM(1,NFCUT1,NFCUT,DDV,NAT3,LPURG,TOLER) ! { dg-warning "Type mismatch" } + CALL ORTHNM(1,NFCUT1,NFCUT,DDV,NAT3,LPURG,TOLER) PRNLEV=OLDPRN CALL CPARAY(HEAP(DDVBAS),DDV,NAT3,1,NFCUT,1) C diff --git a/gcc/testsuite/gfortran.dg/pr24823.f b/gcc/testsuite/gfortran.dg/pr24823.f index bb63c411b41..c6f638fbd0c 100644 --- a/gcc/testsuite/gfortran.dg/pr24823.f +++ b/gcc/testsuite/gfortran.dg/pr24823.f @@ -50,9 +50,9 @@ IF( I.LT.1 ) THEN IF( ISYM.EQ.0 ) THEN A( J-I+1, I ) = DCONJG( ZLATM2( M, N, I, J, KL, - $ DR, IPVTNG, IWORK, SPARSE ) ) + $ DR, IPVTNG, IWORK, SPARSE ) ) ! { dg-warning "Type mismatch" } ELSE - A( J-I+1, I ) = ZLATM2( M, N, I, J, KL, KU, ! { dg-warning "Type mismatch" } + A( J-I+1, I ) = ZLATM2( M, N, I, J, KL, KU, ! { dg-warning "Type mismatch" } $ IPVTNG, IWORK, SPARSE ) END IF END IF @@ -61,7 +61,7 @@ IF( ISYM.EQ.0 ) THEN END IF END IF - A( I-J+KUU+1, J ) = ZLATM2( M, N, I, J, KL, KU, ! { dg-warning "Type mismatch" } + A( I-J+KUU+1, J ) = ZLATM2( M, N, I, J, KL, KU, $ DR, IPVTNG, IWORK, SPARSE ) END IF END IF diff --git a/gcc/testsuite/gfortran.dg/pr39937.f b/gcc/testsuite/gfortran.dg/pr39937.f index 1ab22ee4397..17d3eb46a21 100644 --- a/gcc/testsuite/gfortran.dg/pr39937.f +++ b/gcc/testsuite/gfortran.dg/pr39937.f @@ -6,7 +6,7 @@ C { dg-options "-std=legacy" } $ WORK( * ) DOUBLE PRECISION X( 2, 2 ) CALL DLALN2( .FALSE., 1, 1, SMIN, ONE, T( J, J ), - $ ZERO, X, 2, SCALE, XNORM, IERR ) + $ ZERO, X, 2, SCALE, XNORM, IERR ) ! { dg-warning "Type mismatch" } CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 ) DO 90 J = KI - 2, 1, -1 IF( J.GT.JNXT ) @@ -19,8 +19,8 @@ C { dg-options "-std=legacy" } END IF END IF CALL DLALN2( .FALSE., 2, 2, SMIN, ONE, - $ T( J-1, J-1 ), LDT, ONE, ONE, - $ XNORM, IERR ) ! { dg-warning "Type mismatch" } + $ T( J-1, J-1 ), LDT, ONE, ONE, ! { dg-warning "Type mismatch" } + $ XNORM, IERR ) 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/warn_unused_dummy_argument_5.f90 b/gcc/testsuite/gfortran.dg/warn_unused_dummy_argument_5.f90 new file mode 100644 index 00000000000..fa93f1d7ff2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/warn_unused_dummy_argument_5.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! { dg-additional-options "-Wunused-dummy-argument" } +! PR 91557 - this used to generate a bogus warning +! Test case by Gerhard Steinmetz +program p + integer :: a, b + a = 1 + call g +contains + subroutine g + integer :: x, y + call h (x, y) + if ( a > 0 ) y = y - 1 + b = y - x + 1 + end +end