re PR fortran/47710 ([OOP] Improve ambiguity check for GENERIC TBP w/ PASS and NOPASS)

2012-06-22  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/47710
	PR fortran/53328
	* interface.c (count_types_test, generic_correspondence,
	gfc_compare_interfaces): Ignore PASS arguments.
	(check_interface1, compare_parameter): Pass NULL arguments to
	gfc_compare_interfaces.
	* gfortran.h (gfc_compare_interfaces): Modified prototype.
	* expr.c (gfc_check_pointer_assign): Pass NULL arguments to
	gfc_compare_interfaces.
	* resolve.c (resolve_structure_cons): Ditto.
	(check_generic_tbp_ambiguity): Determine PASS arguments and pass them
	to gfc_compare_interfaces.


2012-06-22  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/47710
	PR fortran/53328
	* gfortran.dg/typebound_generic_12.f03: New.
	* gfortran.dg/typebound_generic_13.f03: New.

From-SVN: r188902

8 files changed, 135 insertions, 30 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index f326572..a804e26 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,18 @@
+2012-06-22  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/47710
+	PR fortran/53328
+	* interface.c (count_types_test, generic_correspondence,
+	gfc_compare_interfaces): Ignore PASS arguments.
+	(check_interface1, compare_parameter): Pass NULL arguments to
+	gfc_compare_interfaces.
+	* gfortran.h (gfc_compare_interfaces): Modified prototype.
+	* expr.c (gfc_check_pointer_assign): Pass NULL arguments to
+	gfc_compare_interfaces.
+	* resolve.c (resolve_structure_cons): Ditto.
+	(check_generic_tbp_ambiguity): Determine PASS arguments and pass them
+	to gfc_compare_interfaces.
+
 2012-06-21  Janne Blomqvist  <jb@gcc.gnu.org>
 
 	PR fortran/39654
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 4765afa..0b38cac 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -3498,7 +3498,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
 	}
 
       if (s1 && s2 && !gfc_compare_interfaces (s1, s2, name, 0, 1,
-					       err, sizeof(err)))
+					       err, sizeof(err), NULL, NULL))
 	{
 	  gfc_error ("Interface mismatch in procedure pointer assignment "
 		     "at %L: %s", &rvalue->where, err);
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 759074a..43904e9 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2842,7 +2842,7 @@ 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*, const char *, int, int,
-			    char *, int);
+			    char *, int, const char *, const char *);
 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 95439c1..7a63f69 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -826,12 +826,13 @@ bad_repl:
    a given type/rank in f1 and seeing if there are less then that
    number of those arguments in f2 (including optional arguments).
    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 in the Fortran 95 standard.  */
+   symmetric. Returns nonzero if the argument lists are incompatible
+   by this test. This subroutine implements rule 1 of section F03:16.2.3.
+   'p1' and 'p2' are the PASS arguments of both procedures (if applicable).  */
 
 static int
-count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
+count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
+		  const char *p1, const char *p2)
 {
   int rc, ac1, ac2, i, j, k, n1;
   gfc_formal_arglist *f;
@@ -868,14 +869,17 @@ count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
       if (arg[i].flag != -1)
 	continue;
 
-      if (arg[i].sym && arg[i].sym->attr.optional)
-	continue;		/* Skip optional arguments.  */
+      if (arg[i].sym && (arg[i].sym->attr.optional
+			 || (p1 && strcmp (arg[i].sym->name, p1) == 0)))
+	continue;		/* Skip OPTIONAL and PASS arguments.  */
 
       arg[i].flag = k;
 
-      /* Find other nonoptional arguments of the same type/rank.  */
+      /* Find other non-optional, non-pass arguments of the same type/rank.  */
       for (j = i + 1; j < n1; j++)
-	if ((arg[j].sym == NULL || !arg[j].sym->attr.optional)
+	if ((arg[j].sym == NULL
+	     || !(arg[j].sym->attr.optional
+		  || (p1 && strcmp (arg[j].sym->name, p1) == 0)))
 	    && (compare_type_rank_if (arg[i].sym, arg[j].sym)
 	        || compare_type_rank_if (arg[j].sym, arg[i].sym)))
 	  arg[j].flag = k;
@@ -897,13 +901,14 @@ count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
 	if (arg[j].flag == k)
 	  ac1++;
 
-      /* Count the number of arguments in f2 with that type, including
-	 those that are optional.  */
+      /* Count the number of non-pass arguments in f2 with that type,
+	 including those that are optional.  */
       ac2 = 0;
 
       for (f = f2; f; f = f->next)
-	if (compare_type_rank_if (arg[i].sym, f->sym)
-	    || compare_type_rank_if (f->sym, arg[i].sym))
+	if ((!p2 || strcmp (f->sym->name, p2) != 0)
+	    && (compare_type_rank_if (arg[i].sym, f->sym)
+		|| compare_type_rank_if (f->sym, arg[i].sym)))
 	  ac2++;
 
       if (ac1 > ac2)
@@ -921,9 +926,10 @@ count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
 }
 
 
-/* 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.
+/* Perform the correspondence test in rule 3 of section F03:16.2.3.
+   Returns zero if no argument is found that satisfies rule 3, nonzero
+   otherwise. 'p1' and 'p2' are the PASS arguments of both procedures
+   (if applicable).
 
    This test is also not symmetric in f1 and f2 and must be called
    twice.  This test finds problems caused by sorting the actual
@@ -942,7 +948,8 @@ count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
    At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous.  */
 
 static int
-generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
+generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
+			const char *p1, const char *p2)
 {
   gfc_formal_arglist *f2_save, *g;
   gfc_symbol *sym;
@@ -954,6 +961,11 @@ generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
       if (f1->sym->attr.optional)
 	goto next;
 
+      if (p1 && strcmp (f1->sym->name, p1) == 0)
+	f1 = f1->next;
+      if (f2 && p2 && strcmp (f2->sym->name, p2) == 0)
+	f2 = f2->next;
+
       if (f2 != NULL && (compare_type_rank (f1->sym, f2->sym)
 			 || compare_type_rank (f2->sym, f1->sym)))
 	goto next;
@@ -962,7 +974,7 @@ generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
 	 the current non-match.  */
       for (g = f1; g; g = g->next)
 	{
-	  if (g->sym->attr.optional)
+	  if (g->sym->attr.optional || (p1 && strcmp (g->sym->name, p1) == 0))
 	    continue;
 
 	  sym = find_keyword_arg (g->sym->name, f2_save);
@@ -971,7 +983,8 @@ generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
 	}
 
     next:
-      f1 = f1->next;
+      if (f1 != NULL)
+	f1 = f1->next;
       if (f2 != NULL)
 	f2 = f2->next;
     }
@@ -1129,12 +1142,14 @@ check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
    We return nonzero if there exists an actual argument list that
    would be ambiguous between the two interfaces, zero otherwise.
    'strict_flag' specifies whether all the characteristics are
-   required to match, which is not the case for ambiguity checks.*/
+   required to match, which is not the case for ambiguity checks.
+   'p1' and 'p2' are the PASS arguments of both procedures (if applicable).  */
 
 int
 gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
 			int generic_flag, int strict_flag,
-			char *errmsg, int err_len)
+			char *errmsg, int err_len,
+			const char *p1, const char *p2)
 {
   gfc_formal_arglist *f1, *f2;
 
@@ -1200,9 +1215,11 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
 
   if (generic_flag)
     {
-      if (count_types_test (f1, f2) || count_types_test (f2, f1))
+      if (count_types_test (f1, f2, p1, p2)
+	  || count_types_test (f2, f1, p2, p1))
 	return 0;
-      if (generic_correspondence (f1, f2) || generic_correspondence (f2, f1))
+      if (generic_correspondence (f1, f2, p1, p2)
+	  || generic_correspondence (f2, f1, p2, p1))
 	return 0;
     }
   else
@@ -1349,7 +1366,7 @@ check_interface1 (gfc_interface *p, gfc_interface *q0,
 	if (p->sym->attr.flavor != FL_DERIVED
 	    && q->sym->attr.flavor != FL_DERIVED
 	    && gfc_compare_interfaces (p->sym, q->sym, q->sym->name,
-				       generic_flag, 0, NULL, 0))
+				       generic_flag, 0, NULL, 0, NULL, NULL))
 	  {
 	    if (referenced)
 	      gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
@@ -1676,7 +1693,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
 	}
 
       if (!gfc_compare_interfaces (formal, act_sym, act_sym->name, 0, 1, err,
-				   sizeof(err)))
+				   sizeof(err), NULL, NULL))
 	{
 	  if (where)
 	    gfc_error ("Interface mismatch in dummy procedure '%s' at %L: %s",
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index d09cb11..4595f76 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -1152,7 +1152,7 @@ resolve_structure_cons (gfc_expr *expr, int init)
 	    }
 
 	  if (s2 && !gfc_compare_interfaces (comp->ts.interface, s2, name, 0, 1,
-					     err, sizeof (err)))
+					     err, sizeof (err), NULL, NULL))
 	    {
 	      gfc_error ("Interface mismatch for procedure-pointer component "
 			 "'%s' in structure constructor at %L: %s",
@@ -11020,8 +11020,8 @@ static gfc_try
 check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
 			     const char* generic_name, locus where)
 {
-  gfc_symbol* sym1;
-  gfc_symbol* sym2;
+  gfc_symbol *sym1, *sym2;
+  const char *pass1, *pass2;
 
   gcc_assert (t1->specific && t2->specific);
   gcc_assert (!t1->specific->is_generic);
@@ -11045,8 +11045,20 @@ check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
     }
 
   /* Compare the interfaces.  */
+  if (t1->specific->nopass)
+    pass1 = NULL;
+  else if (t1->specific->pass_arg)
+    pass1 = t1->specific->pass_arg;
+  else
+    pass1 = t1->specific->u.specific->n.sym->formal->sym->name;
+  if (t2->specific->nopass)
+    pass2 = NULL;
+  else if (t2->specific->pass_arg)
+    pass2 = t2->specific->pass_arg;
+  else
+    pass2 = t2->specific->u.specific->n.sym->formal->sym->name;  
   if (gfc_compare_interfaces (sym1, sym2, sym2->name, !t1->is_operator, 0,
-			      NULL, 0))
+			      NULL, 0, pass1, pass2))
     {
       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 fe32345..0e67aa0 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+2012-06-22  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/47710
+	PR fortran/53328
+	* gfortran.dg/typebound_generic_12.f03: New.
+	* gfortran.dg/typebound_generic_13.f03: New.
+
 2012-06-22  Eric Botcazou  <ebotcazou@adacore.com>
 
 	* gnat.dg/lto15.ad[sb]: New test.
diff --git a/gcc/testsuite/gfortran.dg/typebound_generic_12.f03 b/gcc/testsuite/gfortran.dg/typebound_generic_12.f03
new file mode 100644
index 0000000..061a41a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/typebound_generic_12.f03
@@ -0,0 +1,26 @@
+! { dg-do compile }
+!
+! PR 53328: [OOP] Ambiguous check for type-bound GENERIC shall ignore PASSed arguments
+!
+! Contributed by Salvatore Filippone <filippone.salvatore@gmail.com>
+
+module m
+  type t
+  contains
+    procedure, pass(this) :: sub1
+    procedure, pass(this) :: sub2
+    generic :: gen => sub1, sub2   ! { dg-error "are ambiguous" }
+  end type t
+contains
+  subroutine sub1 (x, this)
+    integer :: i
+    class(t) :: this
+  end subroutine sub1
+
+  subroutine sub2 (this, y)
+    integer :: i
+    class(t) :: this
+  end subroutine sub2
+end module m 
+
+! { dg-final { cleanup-modules "m" } }
diff --git a/gcc/testsuite/gfortran.dg/typebound_generic_13.f03 b/gcc/testsuite/gfortran.dg/typebound_generic_13.f03
new file mode 100644
index 0000000..c2116e9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/typebound_generic_13.f03
@@ -0,0 +1,28 @@
+! { dg-do compile }
+!
+! PR 47710: [OOP] Improve ambiguity check for GENERIC TBP w/ PASS and NOPASS
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+module m
+
+  type base_t
+  contains
+    procedure, nopass :: baseproc_nopass => baseproc1
+    procedure, pass   :: baseproc_pass => baseproc2
+    generic           :: some_proc => baseproc_pass, baseproc_nopass   ! { dg-error "are ambiguous" }
+  end type
+
+contains
+
+  subroutine baseproc1 (this)
+    class(base_t) :: this
+  end subroutine
+
+  subroutine baseproc2 (this, that)
+    class(base_t) :: this, that
+  end subroutine
+
+end module
+
+! { dg-final { cleanup-modules "m" } }