+2019-09-14 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 Steven G. Kargl <kargl@gcc.gnu.org>
PR fortran/91566
/* 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;
if (def_sym)
{
- gfc_procedure_use (def_sym, &actual, loc);
+ gfc_compare_actual_formal (&actual, def_sym->formal, 0, 0, 0, loc);
return 0;
}
/* 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 */
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)
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);
+ }
}
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;
}
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;
}
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;
}
&& 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))
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;
}
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),
&& 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);
{
/* 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);
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;
}
}
}
s->attr.dummy = 1;
+ s->declared_at = a->expr->where;
s->attr.intent = INTENT_UNKNOWN;
(*f)->sym = s;
}
@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
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}
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
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)
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;
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;
}
}
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;
}
+2019-09-14 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.
+
2019-09-14 Sandra Loosemore <sandra@codesourcery.com>
PR testsuite/83889
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
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
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
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
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
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
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
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
$ 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 )
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,
--- /dev/null
+! { 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
projects / gcc.git / commitdiff