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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@151147 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 23dce57..223f88c 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,16 @@
+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

diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 57582a9..970c259 100644 (file)
--- a/gcc/fortran/expr.c
+++ b/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;
     }
 

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 16c596b..514cc80 100644 (file)
--- a/gcc/fortran/gfortran.h
+++ b/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 *);

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 6d16fe1..132f10a 100644 (file)
--- a/gcc/fortran/interface.c
+++ b/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)

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index e1c931b..f10a412 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/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);

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index c9979ca..3b29417 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+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

diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_20.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_20.f90
new file mode 100644 (file)
index 0000000..d477368
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_20.f90
@@ -0,0 +1,49 @@
+! { 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
+