diff mbox

[Fortran] PR40276/PR57711 - improve generic diagnostic

Message ID 51CA9CB1.1000106@net-b.de
State New
Headers show

Commit Message

Tobias Burnus June 26, 2013, 7:48 a.m. UTC 
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.
diff mbox

Patch

2012-06-26  Tobias Burnus  <burnus@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  <burnus@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