Index: fortran/frontend-passes.c =================================================================== --- fortran/frontend-passes.c (Revision 275713) +++ fortran/frontend-passes.c (Arbeitskopie) @@ -5373,7 +5373,8 @@ gfc_code_walker (gfc_code **c, walk_code_fn_t code /* 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 @@ static int if (def_sym) { - gfc_procedure_use (def_sym, &actual, loc); + gfc_compare_actual_formal (&actual, def_sym->formal, 0, 0, 0, loc); return 0; } Index: fortran/gfortran.h =================================================================== --- fortran/gfortran.h (Revision 275713) +++ fortran/gfortran.h (Arbeitskopie) @@ -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 */ Index: fortran/interface.c =================================================================== --- fortran/interface.c (Revision 275713) +++ fortran/interface.c (Arbeitskopie) @@ -1807,9 +1807,9 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol 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 *act 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 *a 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 *a 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 *a 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 *a && 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 *a 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,8 +3112,7 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap 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), @@ -3070,8 +3119,7 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap 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 && 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 { /* 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, g 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 *sy } } s->attr.dummy = 1; + s->declared_at = a->expr->where; s->attr.intent = INTENT_UNKNOWN; (*f)->sym = s; } Index: fortran/invoke.texi =================================================================== --- fortran/invoke.texi (Revision 275713) +++ fortran/invoke.texi (Arbeitskopie) @@ -145,7 +145,7 @@ by type. Explanations are in the following sectio @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,9 +236,16 @@ intrinsic will be called except when it is explici 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} A BOZ literal constant can occur in a limited number of contexts in @@ -907,15 +914,6 @@ character constant, GNU Fortran assumes continuati 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 Index: fortran/lang.opt =================================================================== --- fortran/lang.opt (Revision 275713) +++ fortran/lang.opt (Arbeitskopie) @@ -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) Index: fortran/resolve.c =================================================================== --- fortran/resolve.c (Revision 275713) +++ fortran/resolve.c (Arbeitskopie) @@ -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 * 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; } Index: fortran/trans-decl.c =================================================================== --- fortran/trans-decl.c (Revision 275713) +++ fortran/trans-decl.c (Arbeitskopie) @@ -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; } Index: testsuite/gfortran.dg/bessel_3.f90 =================================================================== --- testsuite/gfortran.dg/bessel_3.f90 (Revision 275713) +++ testsuite/gfortran.dg/bessel_3.f90 (Arbeitskopie) @@ -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 Index: testsuite/gfortran.dg/g77/20010519-1.f =================================================================== --- testsuite/gfortran.dg/g77/20010519-1.f (Revision 275713) +++ testsuite/gfortran.dg/g77/20010519-1.f (Arbeitskopie) @@ -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 Index: testsuite/gfortran.dg/pr24823.f =================================================================== --- testsuite/gfortran.dg/pr24823.f (Revision 275713) +++ testsuite/gfortran.dg/pr24823.f (Arbeitskopie) @@ -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 Index: testsuite/gfortran.dg/pr39937.f =================================================================== --- testsuite/gfortran.dg/pr39937.f (Revision 275713) +++ testsuite/gfortran.dg/pr39937.f (Arbeitskopie) @@ -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,