===================================================================
@@ -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;
}
===================================================================
@@ -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 */
===================================================================
@@ -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;
}
===================================================================
@@ -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
===================================================================
@@ -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)
===================================================================
@@ -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;
}
===================================================================
@@ -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;
}
===================================================================
@@ -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
===================================================================
@@ -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
===================================================================
@@ -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
===================================================================
@@ -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,
Hello world, the attached patch improves the rather hard to read error messages for argument mismatches. With this patch, this reads argument_checking_21.f90:7:11: 6 | call foo(1.0) ! { dg-warning "Rank mismatch" } | 2 7 | call foo(b) ! { dg-warning "Rank mismatch" } | 1 Fehler: Rank mismatch between actual argument at (1) and actual argument at (2) (scalar and rank-2) which I think is fairly clear. It also makes sure that warnings are always emitted by -fallow-argument-mismatch by removing -Wargument-mismatch. Finally, for people who do not want to have too many warnings cluttering up their logs, a type mismatch is only shown once if it is a warning. While I was going on about fixing warnings, I also fixed PR 91557 with the bit in trans-expr.c. This part is trivial, I will backport it to the other affected branches. After this, I think we can close PR 91556. Regression-tested. OK for trunk? 2019-09-13 Thomas Koenig <tkoenig@gcc.gnu.org> 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 Thomas Koenig <tkoenig@gcc.gnu.org> 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.