re PR fortran/36947 (Attributes not fully checked comparing actual vs dummy procedure)

2009-06-16  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-16  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.

From-SVN: r148519

gcc/fortran/ChangeLog

+2009-06-16  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-16  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/40383

gcc/fortran/expr.c

@@ -3142,6 +3142,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
   /* 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 *lvalue, gfc_expr *rvalue)
 	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;

gcc/fortran/gfortran.h

@@ -2567,7 +2567,7 @@ gfc_try gfc_ref_dimen_size (gfc_array_ref *, int dimen, mpz_t *);
 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,

gcc/fortran/interface.c

@@ -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, gfc_formal_arglist *f2)
 }
 
 
-/* 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_arglist *f1, gfc_formal_arglist *f2)
 
 /* '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, gfc_symbol *s2, int generic_flag,
       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, gfc_symbol *s2, int generic_flag,
 	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_interface *q0,
 	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, gfc_expr *actual,
 
   if (actual->ts.type == BT_PROCEDURE)
     {
-      if (formal->attr.flavor != FL_PROCEDURE)
-	goto proc_fail;
-
-      if (formal->attr.function
-	  && !compare_type_rank (formal, actual->symtree->n.sym))
-	goto proc_fail;
+      char err[200];
 
-      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)

gcc/fortran/resolve.c

@@ -8593,7 +8593,7 @@ check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
     }
 
   /* 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);

gcc/testsuite/ChangeLog

+2009-06-16  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.
+
 2009-06-16  Ira Rosen  <irar@il.ibm.com>
 
 	* gcc.dg/vect/vect-outer-4g.c: Don't look for pattern not allowed 

gcc/testsuite/gfortran.dg/dummy_procedure_1.f90

@@ -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

gcc/testsuite/gfortran.dg/interface_20.f90

@@ -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

gcc/testsuite/gfortran.dg/interface_21.f90

@@ -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

gcc/testsuite/gfortran.dg/interface_26.f90

@@ -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 ) 

gcc/testsuite/gfortran.dg/interface_27.f90

@@ -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 

gcc/testsuite/gfortran.dg/interface_28.f90

@@ -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" } }

gcc/testsuite/gfortran.dg/interface_29.f90

+! { 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" } }
+

gcc/testsuite/gfortran.dg/proc_decl_7.f90

@@ -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" } }

gcc/testsuite/gfortran.dg/proc_decl_8.f90

@@ -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" } }

gcc/testsuite/gfortran.dg/proc_ptr_11.f90

@@ -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
 

gcc/testsuite/gfortran.dg/proc_ptr_15.f90

@@ -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