This patch attempts to improve the diagnostic for generic matches, if a
dummy procedure is used which has nonmatching characteristics.
Before the patch:
call gen(sub)
1
Error: There is no specific subroutine for the generic 'gen' at (1)
After the patch:
call gen(sub)
1
Error: Interface mismatch in dummy procedure 'a' at (1): INTENT mismatch
in argument 'x'
The idea is that if the argument is a procedure* in generic resolution,
there cannot be nonambiguous specific where the characters match. Thus,
we first claim that there is a generic match - and later (after all
arguments match) re-check whether the characteristics of the
actual/dummy procedures are indeed the same.
Build and regtested on x86-64-gnu-linux.
OK for the trunk?
Tobias
* For completness: In F2008, one can distinguish a subroutine from a
function; I think that's not yet implemented and but it shouldn't affect
this patch, either.
PS: I think there could be some additional cases, which should be
handled likewise (e.g. pureness, pointer/allocatable attribute etc.) -
but I haven't thought about those. - PR57711 additionally shows that the
interface mismatch is not detected when directly invoking the specific
procedure and not using the generic one.
2012-06-26 Tobias Burnus <bur...@net-b.de>
PR fortran/40276
PR fortran/57711
* interface.c (compare_parameter): Always claim generic match if
actual and formal are procedures and "where" unset.
(compare_actual_formal): For generic match (where unset), add a
second round if a match has found to check the interface.
2012-06-26 Tobias Burnus <bur...@net-b.de>
PR fortran/40276
PR fortran/57711
* gfortran.dg/generic_28.f90: New.
* gfortran.dg/generic_29.f90: New.
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index f06ecfe..d74df1a 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1915,12 +1915,14 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
return 0;
}
- if (!gfc_compare_interfaces (formal, act_sym, act_sym->name, 0, 1, err,
- sizeof(err), NULL, NULL))
+ /* If where is not set (i.e. generic resolution), we claim a successful match
+ (in terms of amiguity) - such that it can be later diagnosed in a second
+ round. */
+ if (where && !gfc_compare_interfaces (formal, act_sym, act_sym->name,
+ 0, 1, err, sizeof(err), NULL, NULL))
{
- if (where)
- gfc_error ("Interface mismatch in dummy procedure '%s' at %L: %s",
- formal->name, &actual->where, err);
+ gfc_error ("Interface mismatch in dummy procedure '%s' at %L: %s",
+ formal->name, &actual->where, err);
return 0;
}
@@ -2453,6 +2455,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
int i, n, na;
unsigned long actual_size, formal_size;
bool full_array = false;
+ bool has_procedure = false;
actual = *ap;
@@ -2679,6 +2682,8 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
f->sym->name, &a->expr->where);
return 0;
}
+ else
+ has_procedure = true;
if (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE
&& a->expr->expr_type == EXPR_VARIABLE
@@ -2926,6 +2931,16 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
if (a->expr == NULL && a->label == NULL)
a->missing_arg_type = f->sym->ts.type;
+ /* Whe have a generic match, now check whether the dummy-procedure interface
+ has the same characteristics. */
+ if (!where && has_procedure)
+ {
+ for (a = *ap, f = formal; a; a = a->next, f = f->next)
+ if (a->expr && f && f->sym->attr.flavor == FL_PROCEDURE)
+ compare_parameter (f->sym, a->expr, ranks_must_agree,
+ is_elemental, &a->expr->where);
+ }
+
return 1;
}
--- /dev/null 2013-06-26 08:23:53.976189029 +0200
+++ gcc/gcc/testsuite/gfortran.dg/generic_28.f90 2013-06-26 09:19:11.918274187 +0200
@@ -0,0 +1,24 @@
+! { dg-do compile }
+!
+! PR fortran/40276
+! PR fortran/57711
+!
+module m
+ implicit none
+ interface gen
+ subroutine specific(a)
+ interface
+ subroutine a(x)
+ integer, intent(in) :: x
+ end subroutine a
+ end interface
+ end subroutine specific
+ end interface gen
+contains
+ subroutine test()
+ call gen(sub) ! { dg-error "Interface mismatch in dummy procedure 'a' at .1.: INTENT mismatch in argument 'x'" }
+ end subroutine test
+ subroutine sub(a)
+ integer, intent(inout) :: a
+ end subroutine sub
+end module m
--- /dev/null 2013-06-26 08:23:53.976189029 +0200
+++ gcc/gcc/testsuite/gfortran.dg/generic_29.f90 2013-06-26 09:19:28.576180621 +0200
@@ -0,0 +1,88 @@
+! { dg-do compile }
+!
+! PR fortran/40276
+! PR fortran/57711
+!
+! Contributed by Dmitry Kabanov
+!
+ MODULE VODE_INT
+ IMPLICIT NONE
+ PRIVATE
+
+! Fortran 90 Interface
+ INTERFACE VODE
+ MODULE PROCEDURE D_VODE
+ END INTERFACE
+
+ PUBLIC :: VODE
+
+ CONTAINS
+
+ SUBROUTINE D_VODE(ISTATE, F, JAC, Y, T, TOUT, TOL, PARAM)
+ INTEGER, INTENT(INOUT) :: ISTATE
+ DOUBLE PRECISION, INTENT(INOUT) :: Y(:)
+ DOUBLE PRECISION, INTENT(INOUT) :: T
+ DOUBLE PRECISION, INTENT(IN) :: TOUT
+ DOUBLE PRECISION, INTENT(IN), OPTIONAL :: TOL
+ DOUBLE PRECISION, INTENT(INOUT), OPTIONAL :: PARAM(50)
+
+ INTERFACE
+ SUBROUTINE F(NEQ, T, Y, YDOT, RPAR, IPAR)
+ INTEGER, INTENT(IN) :: NEQ
+ DOUBLE PRECISION, INTENT(IN) :: T
+ DOUBLE PRECISION, INTENT(IN) :: Y(NEQ)
+ DOUBLE PRECISION, INTENT(OUT) :: YDOT(NEQ)
+ DOUBLE PRECISION, INTENT(INOUT) :: RPAR(*)
+ INTEGER, INTENT(INOUT) :: IPAR(*)
+ END SUBROUTINE
+
+ SUBROUTINE JAC(NEQ, T, Y, ML, MU, PD, NROWPD, RPAR, IPAR)
+ INTEGER, INTENT(IN) :: NEQ
+ DOUBLE PRECISION, INTENT(IN) :: T
+ DOUBLE PRECISION, INTENT(IN) :: Y(NEQ)
+ INTEGER, INTENT(IN) :: ML
+ INTEGER, INTENT(IN) :: MU
+ INTEGER, INTENT(IN) :: NROWPD
+ DOUBLE PRECISION, INTENT(INOUT) :: PD(NROWPD,NEQ)
+ DOUBLE PRECISION, INTENT(INOUT) :: RPAR(*)
+ INTEGER, INTENT(INOUT) :: IPAR(*)
+ END SUBROUTINE
+ END INTERFACE
+
+ END SUBROUTINE
+
+ END MODULE
+
+module fcns
+contains
+subroutine lambda_fcn(n, x, lambda, rhs, rp, ip)
+ ! Computes the RHS of the ODE: dl/dx = k*(1-lambda)*exp(-e/(p*v))/u
+ integer, intent(in) :: n
+ double precision, intent(in) :: x, lambda(1)
+ double precision, intent(out) :: rhs(1)
+ double precision, intent(inout) :: rp(1)
+ integer, intent(inout) :: ip(1)
+end subroutine lambda_fcn
+
+subroutine dummy_jac(NEQ, T, Y, ML, MU, PD, NROWPD, RPAR, IPAR)
+ integer, intent(in) :: NEQ
+ double precision, intent(in) :: T
+ double precision, intent(in) :: Y(NEQ)
+ integer, intent(in) :: ML
+ integer, intent(in) :: MU
+ integer, intent(in) :: NROWPD
+ double precision, intent(inout) :: PD(NROWPD,NEQ)
+ double precision, intent(inout) :: RPAR(:)
+ integer, intent(inout) :: IPAR(:)
+end subroutine dummy_jac
+end module
+
+program dummy
+ use vode_int
+ use fcns
+ implicit none
+ integer :: istate
+ double precision :: x_tmp, x_end, lambda(1), tol, pm(50)
+
+ call vode(istate, lambda_fcn, dummy_jac, lambda, x_tmp, x_end, tol, pm) ! { dg-error "Interface mismatch in dummy procedure 'f' at .1.: Shape mismatch in dimension 1 of argument 'y'|Interface mismatch in dummy procedure 'jac' at .1.: Shape mismatch in argument 'rpar'" }
+end program dummy
