This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

Re: [Patch, Fortran] PR 36947/40039: Better error messages for dummy procedures and check for OPTIONAL


2009/5/25 Tobias Burnus <burnus@net-b.de>:
>> "If the interface of the dummy argument is explicit, the
>> ?characteristics listed in 12.2 shall be the same for the
>> ?associated actual argument and the corresponding dummy argument, ..."
>
> I think passing an actual argument with an implicit interface to
> an explicit-interface dummy is also allowed. If the explicit
> argument were required, the standard had written it explicitly.

Attached is a new version of the patch, which retreats to the old
behaviour in this matter. In addition I fixed a smaller bug that
Tobias reported privately and added another test case. I also made
sure that it still passes the testsuite without failures.

Tobi's other comments I will take care of in a follow-up patch (pure,
elemental, recursive checking etc).

Ok for trunk?

Cheers,
Janus


2009-06-12  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/36947
	PR fortran/40039
	* expr.c (gfc_check_pointer_assign): Call 'gfc_compare_interfaces' with
	error message.
	* gfortran.h (gfc_compare_interfaces): Additional argument.
	* interface.c (operator_correspondence): Removed.
	(gfc_compare_interfaces): Additional argument to return error message.
	Directly use the code from 'operator_correspondence' instead of calling
	the function. Check for OPTIONAL. Some rearrangements.
	(check_interface1): Call 'gfc_compare_interfaces' without error message.
	(compare_parameter): Call 'gfc_compare_interfaces' with error message.
	* resolve.c (check_generic_tbp_ambiguity): Call 'gfc_compare_interfaces'
	without error message.


2009-06-12  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/36947
	PR fortran/40039
	* gfortran.dg/dummy_procedure_1.f90: Extended test case.
	* gfortran.dg/interface_20.f90: Modified error messages.
	* gfortran.dg/interface_21.f90: Ditto.
	* gfortran.dg/interface_26.f90: Ditto.
	* gfortran.dg/interface_27.f90: Ditto.
	* gfortran.dg/interface_28.f90: Extended test case.
	* gfortran.dg/interface_29.f90: New.
	* gfortran.dg/proc_decl_7.f90: Modified error messages.
	* gfortran.dg/proc_decl_8.f90: Ditto.
	* gfortran.dg/proc_ptr_11.f90: Ditto.
	* gfortran.dg/proc_ptr_15.f90: Ditto.


> I think some other checks should still be added, e.g.
>
> a) PUREness check (see example below); passing/assigning
> ? a pure to a non-pure dummy/proc-pointer is OK; doing vice versa
> ? is not.
>
> See "12.4.1.3" (dummy-actual arguments)
> ?"If the interface of the dummy argument is explicit,
> ?the characteristics listed in 12.2 shall be the same for the
> ?associated actual argument and the corresponding dummy argument,
> ?except that a pure actual argument may be associated with a dummy
> ?argument that is not pure and an elemental intrinsic actual
> ?procedure may be associated with a dummy procedure (which is
> ?prohibited from being elemental)."
> And also "7.4.2.2" (proc-pointer assignment):
> ?"If proc-pointer-object has an explicit interface, its
> ?characteristics shall be the same as proc-target except that
> ?proc-target may be pure even if proc-pointer-object is not pure
> ?and proc-target may be an elemental intrinsic procedure even
> ?if proc-pointer-object is not elemental."
>
> b) Similarly for ELEMENTAL. For proc-pointer assignments, use the
> ? first example with PURE changed to ELEMENTAL. That non-intrinsic
> ? elementals are not allowed as actual argument, is already checked
> ? for (cf. C1228). Except of the remark in parentheses I could not
> ? find in F2003/F2008 anything which prohibits ELEMENTAL for the
> ? dummy argument; however, the parentheses is normative. Maybe one
> ? should re-check the standard before adding an error check (see
> ? example below).
>
> c) One needs to go recursively over the arguments as the second
> ? example below shows.
>
>
> Tobias
>
>
> PROGRAM PURENESS
> implicit none
> interface
> ?subroutine one(a,b,c,d,e,f,g,h,i)
> ? ?implicit none
> ? ?integer,intent(in) :: a,b,c,d,e,f,g,h,i
> ?end subroutine one
> ?pure subroutine two(a,b,c,d,e,f,g,h,i)
> ? ?implicit none
> ? ?integer,intent(in) :: a,b,c,d,e,f,g,h,i
> ?end subroutine two
> end interface
> procedure(two), pointer :: ptr
> ptr => one ?! Invalid: (pure) => (unpure)
> end program pureness
>
>
> program RecursiveInterface
> ?interface
> ? ?subroutine a(x)
> ? ? ?real :: x
> ? ?end subroutine a
> ? ?subroutine b(a)
> ? ? ?integer :: a
> ? ?end subroutine b
> ? ?subroutine c(f)
> ? ? ?procedure(a) :: f
> ? ?end subroutine c
> ? ?subroutine d(f)
> ? ? ?procedure(b) :: f
> ? ?end subroutine d
> ? ?subroutine e(f)
> ? ? procedure(c) :: f
> ? ?end subroutine e
> ?end interface
> ?call e(d) ! Argument (dummy subroutine) d has an integer argument
> ? ? ? ? ? ?! but e's f expects a real argument
> end program RecursiveInterface
>
>
> interface
> ?elemental subroutine a() ?! Expected: Warning: ELEMENTAL procedure
> ? ? ? ? ? ? ? ? ? ? ? ? ? ?! without arguments
> ?! (Having ELEMENTAL does not make much sense without arguments, but
> ?! ?it is valid)
> ?end subroutine a
> ?subroutine sub(f)
> ? ?interface
> ? ? ?elemental subroutine f(a)
> ? ? ? ?integer,intent(IN) :: a
> ? ? ?end subroutine f
> ? ?end interface
> ! Invalid per 12.4.1.3?
> ! "an elemental intrinsic actual procedure may be associated with
> ! ?a dummy procedure (which is prohibited from being elemental)."
> ! ? ? ? ? ? ? ? ? ? ? ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
> ! Todo: Find it elsewhere in the standard - or in the corrigenda;
> ! ? ? ? other compilers accept it. However, the part above is normative
> ?end subroutine sub
> end interface
> end program elementalCheck
>
Index: gcc/testsuite/gfortran.dg/proc_decl_7.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_decl_7.f90	(revision 148430)
+++ gcc/testsuite/gfortran.dg/proc_decl_7.f90	(working copy)
@@ -16,6 +16,6 @@ end module m
 use m
 implicit none
 intrinsic cos
-call sub(cos) ! { dg-error "Type/rank mismatch in argument" }
+call sub(cos) ! { dg-error "wrong number of arguments" }
 end
 ! { dg-final { cleanup-modules "m" } }
Index: gcc/testsuite/gfortran.dg/proc_ptr_11.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_ptr_11.f90	(revision 148430)
+++ gcc/testsuite/gfortran.dg/proc_ptr_11.f90	(working copy)
@@ -27,7 +27,7 @@ program bsp
     end function p3
   end interface
 
-  pptr => add   ! { dg-error "Interfaces don't match" }
+  pptr => add   ! { dg-error "is not a subroutine" }
 
   q => add
 
@@ -40,11 +40,11 @@ program bsp
   p2 => p1
   p1 => p2
 
-  p1 => abs   ! { dg-error "Interfaces don't match" }
-  p2 => abs   ! { dg-error "Interfaces don't match" }
+  p1 => abs   ! { dg-error "Type/kind mismatch in return value" }
+  p2 => abs   ! { dg-error "Type/kind mismatch in return value" }
 
   p3 => dsin
-  p3 => sin   ! { dg-error "Interfaces don't match" }
+  p3 => sin   ! { dg-error "Type/kind mismatch in return value" }
 
   contains
 
Index: gcc/testsuite/gfortran.dg/interface_26.f90
===================================================================
--- gcc/testsuite/gfortran.dg/interface_26.f90	(revision 148430)
+++ gcc/testsuite/gfortran.dg/interface_26.f90	(working copy)
@@ -37,7 +37,7 @@ CONTAINS
     END INTERFACE
     INTEGER, EXTERNAL :: UserOp 
 
-    res = UserFunction( a,b, UserOp ) ! { dg-error "Type/rank mismatch in argument" }
+    res = UserFunction( a,b, UserOp ) ! { dg-error "Type/kind mismatch in return value" }
 
     if( res .lt. 10 ) then
        res = recSum( a, res, UserFunction, UserOp ) 
Index: gcc/testsuite/gfortran.dg/proc_ptr_15.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_ptr_15.f90	(revision 148430)
+++ gcc/testsuite/gfortran.dg/proc_ptr_15.f90	(working copy)
@@ -19,10 +19,10 @@ p4 => p2
 p6 => p1
 
 ! invalid
-p1 => iabs   ! { dg-error "Interfaces don't match" }
-p1 => p2     ! { dg-error "Interfaces don't match" }
-p1 => p5     ! { dg-error "Interfaces don't match" }
-p6 => iabs   ! { dg-error "Interfaces don't match" }
+p1 => iabs   ! { dg-error "Type/kind mismatch in return value" }
+p1 => p2     ! { dg-error "Type/kind mismatch in return value" }
+p1 => p5     ! { dg-error "Type/kind mismatch in return value" }
+p6 => iabs   ! { dg-error "Type/kind mismatch in return value" }
 
 contains
 
Index: gcc/testsuite/gfortran.dg/interface_28.f90
===================================================================
--- gcc/testsuite/gfortran.dg/interface_28.f90	(revision 148430)
+++ gcc/testsuite/gfortran.dg/interface_28.f90	(working copy)
@@ -2,7 +2,8 @@
 !
 ! PR 36947: Attributes not fully checked comparing actual vs dummy procedure
 !
-! Contributed by Walter Spector <w6ws@earthlink.net>
+! Original test case by Walter Spector <w6ws@earthlink.net>
+! Modified by Janus Weil <janus@gcc.gnu.org>
 
 module testsub
   contains
@@ -12,7 +13,6 @@ module testsub
         integer, intent(in), optional:: x
       end subroutine
     end interface
-    print *, "In test(), about to call sub()"
     call sub()
   end subroutine
 end module
@@ -20,9 +20,12 @@ end module
 module sub
   contains
   subroutine subActual(x)
-    ! actual subroutine's argment is different in intent and optional
-    integer, intent(inout):: x
-    print *, "In subActual():", x
+    ! actual subroutine's argment is different in intent
+    integer, intent(inout),optional:: x
+  end subroutine
+  subroutine subActual2(x)
+    ! actual subroutine's argment is missing OPTIONAL
+    integer, intent(in):: x
   end subroutine
 end module
 
@@ -32,7 +35,8 @@ program interfaceCheck
 
   integer :: a
 
-  call test(subActual)  ! { dg-error "Type/rank mismatch in argument" }
+  call test(subActual)  ! { dg-error "INTENT mismatch in argument" }
+  call test(subActual2)  ! { dg-error "OPTIONAL mismatch in argument" }
 end program
 
 ! { dg-final { cleanup-modules "sub testsub" } }
Index: gcc/testsuite/gfortran.dg/interface_21.f90
===================================================================
--- gcc/testsuite/gfortran.dg/interface_21.f90	(revision 148430)
+++ gcc/testsuite/gfortran.dg/interface_21.f90	(working copy)
@@ -18,5 +18,5 @@ end module m
 use m
 implicit none
 EXTERNAL foo  ! implicit interface is undefined
-call sub(foo) ! { dg-error "Type/rank mismatch in argument" }
+call sub(foo) ! { dg-error "is not a function" }
 end
Index: gcc/testsuite/gfortran.dg/proc_decl_8.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_decl_8.f90	(revision 148430)
+++ gcc/testsuite/gfortran.dg/proc_decl_8.f90	(working copy)
@@ -20,6 +20,6 @@ use m
 implicit none
 EXTERNAL foo  ! interface is undefined
 procedure(cos) :: foo ! { dg-error "Duplicate EXTERNAL attribute specified" }
-call sub(foo)         ! { dg-error "Type/rank mismatch in argument" }
+call sub(foo)         ! { dg-error "is not a function" }
 end
 ! { dg-final { cleanup-modules "m" } }
Index: gcc/testsuite/gfortran.dg/interface_27.f90
===================================================================
--- gcc/testsuite/gfortran.dg/interface_27.f90	(revision 148430)
+++ gcc/testsuite/gfortran.dg/interface_27.f90	(working copy)
@@ -31,8 +31,8 @@ subroutine caller
   end interface
   pointer :: p
 
-  call a(4.3,func)  ! { dg-error "Type/rank mismatch in argument" }
-  p => func         ! { dg-error "Interfaces don't match in procedure pointer assignment" }
+  call a(4.3,func)  ! { dg-error "INTENT mismatch in argument" }
+  p => func         ! { dg-error "INTENT mismatch in argument" }
 end subroutine
 
 end module 
Index: gcc/testsuite/gfortran.dg/dummy_procedure_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/dummy_procedure_1.f90	(revision 148430)
+++ gcc/testsuite/gfortran.dg/dummy_procedure_1.f90	(working copy)
@@ -21,6 +21,9 @@ contains
       end function f
     end interface
   end subroutine s1
+  subroutine s2(x)
+    integer :: x
+  end subroutine
 end module m1
 
   use m1
@@ -38,6 +41,7 @@ end module m1
   call s1(x) ! explicit interface
   call s1(y) ! declared external
   call s1(z) ! { dg-error "Expected a procedure for argument" }
+  call s2(x) ! { dg-error "Invalid procedure argument" }
 contains
   integer function w()
     w = 1
Index: gcc/testsuite/gfortran.dg/interface_20.f90
===================================================================
--- gcc/testsuite/gfortran.dg/interface_20.f90	(revision 148430)
+++ gcc/testsuite/gfortran.dg/interface_20.f90	(working copy)
@@ -16,5 +16,5 @@ end module m
 use m
 implicit none
 intrinsic cos
-call sub(cos) ! { dg-error "Type/rank mismatch in argument" }
+call sub(cos) ! { dg-error "wrong number of arguments" }
 end
Index: gcc/fortran/interface.c
===================================================================
--- gcc/fortran/interface.c	(revision 148430)
+++ gcc/fortran/interface.c	(working copy)
@@ -778,7 +778,7 @@ bad_repl:
    Since this test is asymmetric, it has to be called twice to make it
    symmetric.  Returns nonzero if the argument lists are incompatible
    by this test.  This subroutine implements rule 1 of section
-   14.1.2.3.  */
+   14.1.2.3 in the Fortran 95 standard.  */
 
 static int
 count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
@@ -869,45 +869,6 @@ count_types_test (gfc_formal_arglist *f1
 }
 
 
-/* Perform the abbreviated correspondence test for operators.  The
-   arguments cannot be optional and are always ordered correctly,
-   which makes this test much easier than that for generic tests.
-
-   This subroutine is also used when comparing a formal and actual
-   argument list when an actual parameter is a dummy procedure, and in
-   procedure pointer assignments. In these cases, two formal interfaces must be
-   compared for equality which is what happens here. 'intent_flag' specifies
-   whether the intents of the arguments are required to match, which is not the
-   case for ambiguity checks.  */
-
-static int
-operator_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
-			 int intent_flag)
-{
-  for (;;)
-    {
-      /* Check existence.  */
-      if (f1 == NULL && f2 == NULL)
-	break;
-      if (f1 == NULL || f2 == NULL)
-	return 1;
-
-      /* Check type and rank.  */
-      if (!compare_type_rank (f1->sym, f2->sym))
-	return 1;
-
-      /* Check intent.  */
-      if (intent_flag && (f1->sym->attr.intent != f2->sym->attr.intent))
-       return 1;
-
-      f1 = f1->next;
-      f2 = f2->next;
-    }
-
-  return 0;
-}
-
-
 /* Perform the correspondence test in rule 2 of section 14.1.2.3.
    Returns zero if no argument is found that satisfies rule 2, nonzero
    otherwise.
@@ -968,17 +929,29 @@ generic_correspondence (gfc_formal_argli
 
 /* 'Compare' two formal interfaces associated with a pair of symbols.
    We return nonzero if there exists an actual argument list that
-   would be ambiguous between the two interfaces, zero otherwise.  */
+   would be ambiguous between the two interfaces, zero otherwise.
+   'intent_flag' specifies whether INTENT and OPTIONAL of the arguments are
+   required to match, which is not the case for ambiguity checks.*/
 
 int
 gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag,
-			int intent_flag)
+			int intent_flag, char *errmsg, int err_len)
 {
   gfc_formal_arglist *f1, *f2;
 
-  if ((s1->attr.function && !s2->attr.function)
-      || (s1->attr.subroutine && s2->attr.function))
-    return 0;
+  if (s1->attr.function && !s2->attr.function)
+    {
+      if (errmsg != NULL)
+	snprintf (errmsg, err_len, "'%s' is not a function", s2->name);
+      return 0;
+    }
+
+  if (s1->attr.subroutine && s2->attr.function)
+    {
+      if (errmsg != NULL)
+	snprintf (errmsg, err_len, "'%s' is not a subroutine", s2->name);
+      return 0;
+    }
 
   /* If the arguments are functions, check type and kind
      (only for dummy procedures and procedure pointer assignments).  */
@@ -988,22 +961,25 @@ gfc_compare_interfaces (gfc_symbol *s1, 
       if (s1->ts.type == BT_UNKNOWN)
 	return 1;
       if ((s1->ts.type != s2->ts.type) || (s1->ts.kind != s2->ts.kind))
-	return 0;
+	{
+	  if (errmsg != NULL)
+	    snprintf (errmsg, err_len, "Type/kind mismatch in return value "
+		      "of '%s'", s2->name);
+	  return 0;
+	}
       if (s1->attr.if_source == IFSRC_DECL)
 	return 1;
     }
 
-  if (s1->attr.if_source == IFSRC_UNKNOWN)
+  if (s1->attr.if_source == IFSRC_UNKNOWN
+      || s2->attr.if_source == IFSRC_UNKNOWN)
     return 1;
 
   f1 = s1->formal;
   f2 = s2->formal;
 
   if (f1 == NULL && f2 == NULL)
-    return 1;			/* Special case.  */
-
-  if (count_types_test (f1, f2) || count_types_test (f2, f1))
-    return 0;
+    return 1;			/* Special case: No arguments.  */
 
   if (generic_flag)
     {
@@ -1011,9 +987,58 @@ gfc_compare_interfaces (gfc_symbol *s1, 
 	return 0;
     }
   else
+    /* Perform the abbreviated correspondence test for operators (the
+       arguments cannot be optional and are always ordered correctly).
+       This is also done when comparing interfaces for dummy procedures and in
+       procedure pointer assignments.  */
+
+    for (;;)
+      {
+	/* Check existence.  */
+	if (f1 == NULL && f2 == NULL)
+	  break;
+	if (f1 == NULL || f2 == NULL)
+	  {
+	    if (errmsg != NULL)
+	      snprintf (errmsg, err_len, "'%s' has the wrong number of "
+			"arguments", s2->name);
+	    return 0;
+	  }
+
+	/* Check type and rank.  */
+	if (!compare_type_rank (f1->sym, f2->sym))
+	  {
+	    if (errmsg != NULL)
+	      snprintf (errmsg, err_len, "Type/rank mismatch in argument '%s'",
+			f1->sym->name);
+	    return 0;
+	  }
+
+	/* Check INTENT.  */
+	if (intent_flag && (f1->sym->attr.intent != f2->sym->attr.intent))
+	  {
+	    snprintf (errmsg, err_len, "INTENT mismatch in argument '%s'",
+		      f1->sym->name);
+	    return 0;
+	  }
+
+	/* Check OPTIONAL.  */
+	if (intent_flag && (f1->sym->attr.optional != f2->sym->attr.optional))
+	  {
+	    snprintf (errmsg, err_len, "OPTIONAL mismatch in argument '%s'",
+		      f1->sym->name);
+	    return 0;
+	  }
+
+	f1 = f1->next;
+	f2 = f2->next;
+      }
+
+  if (count_types_test (f1, f2) || count_types_test (f2, f1))
     {
-      if (operator_correspondence (f1, f2, intent_flag))
-	return 0;
+      if (errmsg != NULL)
+	snprintf (errmsg, err_len, "Interface not matching");
+      return 0;
     }
 
   return 1;
@@ -1091,7 +1116,7 @@ check_interface1 (gfc_interface *p, gfc_
 	if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
 	  continue;
 
-	if (gfc_compare_interfaces (p->sym, q->sym, generic_flag, 0))
+	if (gfc_compare_interfaces (p->sym, q->sym, generic_flag, 0, NULL, 0))
 	  {
 	    if (referenced)
 	      {
@@ -1362,27 +1387,25 @@ compare_parameter (gfc_symbol *formal, g
 
   if (actual->ts.type == BT_PROCEDURE)
     {
-      if (formal->attr.flavor != FL_PROCEDURE)
-	goto proc_fail;
+      char err[200];
 
-      if (formal->attr.function
-	  && !compare_type_rank (formal, actual->symtree->n.sym))
-	goto proc_fail;
-
-      if (formal->attr.if_source == IFSRC_UNKNOWN
-	  || actual->symtree->n.sym->attr.external)
-	return 1;		/* Assume match.  */
+      if (formal->attr.flavor != FL_PROCEDURE)
+	{
+	  if (where)
+	    gfc_error ("Invalid procedure argument at %L", &actual->where);
+	  return 0;
+	}
 
-      if (!gfc_compare_interfaces (formal, actual->symtree->n.sym, 0, 1))
-	goto proc_fail;
+      if (!gfc_compare_interfaces (formal, actual->symtree->n.sym, 0, 1, err,
+				   sizeof(err)))
+	{
+	  if (where)
+	    gfc_error ("Interface mismatch in dummy procedure '%s' at %L: %s",
+		       formal->name, &actual->where, err);
+	  return 0;
+	}
 
       return 1;
-
-      proc_fail:
-	if (where)
-	  gfc_error ("Type/rank mismatch in argument '%s' at %L",
-		     formal->name, &actual->where);
-      return 0;
     }
 
   if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(revision 148430)
+++ gcc/fortran/gfortran.h	(working copy)
@@ -2568,7 +2568,7 @@ gfc_try gfc_ref_dimen_size (gfc_array_re
 void gfc_free_interface (gfc_interface *);
 int gfc_compare_derived_types (gfc_symbol *, gfc_symbol *);
 int gfc_compare_types (gfc_typespec *, gfc_typespec *);
-int gfc_compare_interfaces (gfc_symbol*, gfc_symbol*, int, int);
+int gfc_compare_interfaces (gfc_symbol*, gfc_symbol*, int, int, char *, int);
 void gfc_check_interfaces (gfc_namespace *);
 void gfc_procedure_use (gfc_symbol *, gfc_actual_arglist **, locus *);
 gfc_symbol *gfc_search_interface (gfc_interface *, int,
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c	(revision 148430)
+++ gcc/fortran/expr.c	(working copy)
@@ -3142,6 +3142,7 @@ gfc_check_pointer_assign (gfc_expr *lval
   /* Checks on rvalue for procedure pointer assignments.  */
   if (proc_pointer)
     {
+      char err[200];
       attr = gfc_expr_attr (rvalue);
       if (!((rvalue->expr_type == EXPR_NULL)
 	    || (rvalue->expr_type == EXPR_FUNCTION && attr.proc_pointer)
@@ -3181,10 +3182,11 @@ gfc_check_pointer_assign (gfc_expr *lval
 	return SUCCESS;
       if (rvalue->expr_type == EXPR_VARIABLE
 	  && !gfc_compare_interfaces (lvalue->symtree->n.sym,
-				      rvalue->symtree->n.sym, 0, 1))
+				      rvalue->symtree->n.sym, 0, 1, err,
+				      sizeof(err)))
 	{
-	  gfc_error ("Interfaces don't match "
-		     "in procedure pointer assignment at %L", &rvalue->where);
+	  gfc_error ("Interface mismatch in procedure pointer assignment "
+		     "at %L: %s", &rvalue->where, err);
 	  return FAILURE;
 	}
       return SUCCESS;
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 148430)
+++ gcc/fortran/resolve.c	(working copy)
@@ -8593,7 +8593,7 @@ check_generic_tbp_ambiguity (gfc_tbp_gen
     }
 
   /* Compare the interfaces.  */
-  if (gfc_compare_interfaces (sym1, sym2, 1, 0))
+  if (gfc_compare_interfaces (sym1, sym2, 1, 0, NULL, 0))
     {
       gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
 		 sym1->name, sym2->name, generic_name, &where);
! { dg-do compile }
!
! PR 36947: Attributes not fully checked comparing actual vs dummy procedure
!
! Contributed by Tobias Burnus <burnus@net-b.de>

module m
interface foo
  module procedure one, two
end interface foo
contains
subroutine one(op,op2)
    interface
      subroutine op(x, y)
        complex, intent(in)  :: x(:)
        complex, intent(out) :: y(:)
      end subroutine op
      subroutine op2(x, y)
        complex, intent(in)  :: x(:)
        complex, intent(out) :: y(:)
      end subroutine op2
    end interface
end subroutine one
subroutine two(ops,i,j)
    interface
      subroutine op(x, y)
        complex, intent(in)  :: x(:)
        complex, intent(out) :: y(:)
      end subroutine op
    end interface
    real :: i,j
end subroutine two
end module m

module test
contains
subroutine bar()
  use m
  call foo(precond_prop,prop2)
end subroutine bar
  subroutine precond_prop(x, y)
    complex, intent(in)  :: x(:)
    complex, intent(out) :: y(:)
  end subroutine
  subroutine prop2(x, y)
    complex, intent(in)  :: x(:)
    complex, intent(out) :: y(:)
  end subroutine
end module test

! { dg-final { cleanup-modules "m" } }


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]