re PR fortran/40869 ([F03] PPC assignment checking)

2009-08-27  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/40869
	* expr.c (gfc_check_pointer_assign): Enable interface check for
	pointer assignments involving procedure pointer components.
	* gfortran.h (gfc_compare_interfaces): Modified prototype.
	* interface.c (gfc_compare_interfaces): Add argument 'name2', to be
	used instead of s2->name. Don't rely on the proc_pointer attribute,
	but instead on the flags handed to this function.
	(check_interface1,compare_parameter): Add argument for
	gfc_compare_interfaces.
	* resolve.c (check_generic_tbp_ambiguity): Ditto.

2009-08-27  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/40869
	* gfortran.dg/proc_ptr_comp_20.f90: New.

From-SVN: r151147

gcc/fortran/ChangeLog

+2009-08-27  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/40869
+	* expr.c (gfc_check_pointer_assign): Enable interface check for
+	pointer assignments involving procedure pointer components.
+	* gfortran.h (gfc_compare_interfaces): Modified prototype.
+	* interface.c (gfc_compare_interfaces): Add argument 'name2', to be
+	used instead of s2->name. Don't rely on the proc_pointer attribute,
+	but instead on the flags handed to this function.
+	(check_interface1,compare_parameter): Add argument for
+	gfc_compare_interfaces.
+	* resolve.c (check_generic_tbp_ambiguity): Ditto.
+
 2009-08-27  Daniel Kraft  <d@domob.eu>
 
 	PR fortran/37425

gcc/fortran/expr.c

@@ -3149,6 +3149,10 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
   if (proc_pointer)
     {
       char err[200];
+      gfc_symbol *s1,*s2;
+      gfc_component *comp;
+      const char *name;
+
       attr = gfc_expr_attr (rvalue);
       if (!((rvalue->expr_type == EXPR_NULL)
 	    || (rvalue->expr_type == EXPR_FUNCTION && attr.proc_pointer)
@@ -3208,22 +3212,35 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
 	    }
 	}
 
-      /* TODO: Enable interface check for PPCs.  */
-      if (gfc_is_proc_ptr_comp (rvalue, NULL))
-	return SUCCESS;
-      if ((rvalue->expr_type == EXPR_VARIABLE
-	   && !gfc_compare_interfaces (lvalue->symtree->n.sym,
-				       rvalue->symtree->n.sym, 0, 1, err,
-				       sizeof(err)))
-	  || (rvalue->expr_type == EXPR_FUNCTION
-	      && !gfc_compare_interfaces (lvalue->symtree->n.sym,
-					  rvalue->symtree->n.sym->result, 0, 1,
-					  err, sizeof(err))))
+      if (gfc_is_proc_ptr_comp (lvalue, &comp))
+	s1 = comp->ts.interface;
+      else
+	s1 = lvalue->symtree->n.sym;
+
+      if (gfc_is_proc_ptr_comp (rvalue, &comp))
+	{
+	  s2 = comp->ts.interface;
+	  name = comp->name;
+	}
+      else if (rvalue->expr_type == EXPR_FUNCTION)
+	{
+	  s2 = rvalue->symtree->n.sym->result;
+	  name = rvalue->symtree->n.sym->result->name;
+	}
+      else
+	{
+	  s2 = rvalue->symtree->n.sym;
+	  name = rvalue->symtree->n.sym->name;
+	}
+
+      if (s1 && s2 && !gfc_compare_interfaces (s1, s2, name, 0, 1,
+					       err, sizeof(err)))
 	{
 	  gfc_error ("Interface mismatch in procedure pointer assignment "
 		     "at %L: %s", &rvalue->where, err);
 	  return FAILURE;
 	}
+
       return SUCCESS;
     }
 

gcc/fortran/gfortran.h

@@ -2650,7 +2650,8 @@ 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, char *, int);
+int gfc_compare_interfaces (gfc_symbol*, gfc_symbol*, const char *, int, int,
+			    char *, int);
 void gfc_check_interfaces (gfc_namespace *);
 void gfc_procedure_use (gfc_symbol *, gfc_actual_arglist **, locus *);
 void gfc_ppc_use (gfc_component *, gfc_actual_arglist **, locus *);

gcc/fortran/interface.c

@@ -943,31 +943,31 @@ generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
    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, char *errmsg, int err_len)
+gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
+			int generic_flag, int intent_flag,
+			char *errmsg, int err_len)
 {
   gfc_formal_arglist *f1, *f2;
 
   if (s1->attr.function && (s2->attr.subroutine
       || (!s2->attr.function && s2->ts.type == BT_UNKNOWN
-	  && gfc_get_default_type (s2->name, s2->ns)->type == BT_UNKNOWN)))
+	  && gfc_get_default_type (name2, s2->ns)->type == BT_UNKNOWN)))
     {
       if (errmsg != NULL)
-	snprintf (errmsg, err_len, "'%s' is not a function", s2->name);
+	snprintf (errmsg, err_len, "'%s' is not a function", name2);
       return 0;
     }
 
   if (s1->attr.subroutine && s2->attr.function)
     {
       if (errmsg != NULL)
-	snprintf (errmsg, err_len, "'%s' is not a subroutine", s2->name);
+	snprintf (errmsg, err_len, "'%s' is not a subroutine", name2);
       return 0;
     }
 
   /* If the arguments are functions, check type and kind
      (only for dummy procedures and procedure pointer assignments).  */
-  if ((s1->attr.dummy || s1->attr.proc_pointer)
-      && s1->attr.function && s2->attr.function)
+  if (!generic_flag && intent_flag && s1->attr.function && s2->attr.function)
     {
       if (s1->ts.type == BT_UNKNOWN)
 	return 1;
@@ -975,7 +975,7 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag,
 	{
 	  if (errmsg != NULL)
 	    snprintf (errmsg, err_len, "Type/kind mismatch in return value "
-		      "of '%s'", s2->name);
+		      "of '%s'", name2);
 	  return 0;
 	}
     }
@@ -1012,7 +1012,7 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag,
 	  {
 	    if (errmsg != NULL)
 	      snprintf (errmsg, err_len, "'%s' has the wrong number of "
-			"arguments", s2->name);
+			"arguments", name2);
 	    return 0;
 	  }
 
@@ -1120,7 +1120,8 @@ 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, NULL, 0))
+	if (gfc_compare_interfaces (p->sym, q->sym, NULL, generic_flag, 0,
+				    NULL, 0))
 	  {
 	    if (referenced)
 	      {
@@ -1403,7 +1404,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
 	  return 0;
 	}
 
-      if (!gfc_compare_interfaces (formal, act_sym, 0, 1, err,
+      if (!gfc_compare_interfaces (formal, act_sym, act_sym->name, 0, 1, err,
 				   sizeof(err)))
 	{
 	  if (where)

gcc/fortran/resolve.c

@@ -8851,7 +8851,7 @@ check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
     }
 
   /* Compare the interfaces.  */
-  if (gfc_compare_interfaces (sym1, sym2, 1, 0, NULL, 0))
+  if (gfc_compare_interfaces (sym1, sym2, NULL, 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-08-27  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/40869
+	* gfortran.dg/proc_ptr_comp_20.f90: New.
+
 2009-08-27  Janne Blomqvist  <jb@gcc.gnu.org>
 
 	PR libfortran/39667

gcc/testsuite/gfortran.dg/proc_ptr_comp_20.f90

+! { dg-do compile }
+!
+! PR 40869: [F03] PPC assignment checking
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+implicit none
+
+interface func
+  procedure f1,f2 ! { dg-error "Ambiguous interfaces" }
+end interface
+
+interface operator(.op.)
+  procedure f1,f2 ! { dg-error "Ambiguous interfaces" }
+end interface
+
+type :: t1
+  procedure(integer), pointer, nopass :: ppc
+end type
+
+type :: t2
+  procedure(real), pointer, nopass :: ppc
+end type
+
+type(t1) :: o1
+type(t2) :: o2
+procedure(logical),pointer :: pp1
+procedure(complex),pointer :: pp2
+
+pp1 => pp2        ! { dg-error "Type/kind mismatch" }
+pp2 => o2%ppc     ! { dg-error "Type/kind mismatch" }
+
+o1%ppc => pp1     ! { dg-error "Type/kind mismatch" }
+o1%ppc => o2%ppc  ! { dg-error "Type/kind mismatch" }
+
+contains
+
+  real function f1(a,b)
+    real,intent(in) :: a,b
+    f1 = a + b
+  end function
+
+  integer function f2(a,b)
+    real,intent(in) :: a,b
+    f2 = a - b
+  end function
+
+end
+