re PR fortran/45521 ([F08] GENERIC resolution with ALLOCATABLE/POINTER and PROCEDURE)

2018-06-11  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/45521
	* interface.c (compare_ptr_alloc): New function.
	(generic_correspondence): Call it.


2018-06-11  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/45521
	* gfortran.dg/generic_32.f90: New test.
	* gfortran.dg/generic_33.f90: New test.

From-SVN: r261448

gcc/fortran/ChangeLog

+2018-06-11  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/45521
+	* interface.c (compare_ptr_alloc): New function.
+	(generic_correspondence): Call it.
+
 2018-06-10  Thomas Koenig  <tkoenig@gcc.gnu.org>
 
 	* gfortran.h (gfc_expr): Add no_bounds_check field.

gcc/fortran/interface.c

@@ -1190,6 +1190,24 @@ count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
 }
 
 
+/* Returns true if two dummy arguments are distinguishable due to their POINTER
+   and ALLOCATABLE attributes according to F2018 section 15.4.3.4.5 (3).
+   The function is asymmetric wrt to the arguments s1 and s2 and should always
+   be called twice (with flipped arguments in the second call).  */
+
+static bool
+compare_ptr_alloc(gfc_symbol *s1, gfc_symbol *s2)
+{
+  /* Is s1 allocatable?  */
+  const bool a1 = s1->ts.type == BT_CLASS ?
+		  CLASS_DATA(s1)->attr.allocatable : s1->attr.allocatable;
+  /* Is s2 a pointer?  */
+  const bool p2 = s2->ts.type == BT_CLASS ?
+		  CLASS_DATA(s2)->attr.class_pointer : s2->attr.pointer;
+  return a1 && p2 && (s2->attr.intent != INTENT_IN);
+}
+
+
 /* Perform the correspondence test in rule (3) of F08:C1215.
    Returns zero if no argument is found that satisfies this rule,
    nonzero otherwise. 'p1' and 'p2' are the PASS arguments of both procedures
@@ -1233,8 +1251,8 @@ generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
       if (f2 != NULL && (compare_type_rank (f1->sym, f2->sym)
 			 || compare_type_rank (f2->sym, f1->sym))
 	  && !((gfc_option.allow_std & GFC_STD_F2008)
-	       && ((f1->sym->attr.allocatable && f2->sym->attr.pointer)
-		   || (f2->sym->attr.allocatable && f1->sym->attr.pointer))))
+	       && (compare_ptr_alloc(f1->sym, f2->sym)
+		   || compare_ptr_alloc(f2->sym, f1->sym))))
 	goto next;
 
       /* Now search for a disambiguating keyword argument starting at
@@ -1247,8 +1265,8 @@ generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
 	  sym = find_keyword_arg (g->sym->name, f2_save);
 	  if (sym == NULL || !compare_type_rank (g->sym, sym)
 	      || ((gfc_option.allow_std & GFC_STD_F2008)
-		  && ((sym->attr.allocatable && g->sym->attr.pointer)
-		      || (sym->attr.pointer && g->sym->attr.allocatable))))
+		  && (compare_ptr_alloc(sym, g->sym)
+		      || compare_ptr_alloc(g->sym, sym))))
 	    return true;
 	}
 

gcc/testsuite/ChangeLog

+2018-06-11  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/45521
+	* gfortran.dg/generic_32.f90: New test.
+	* gfortran.dg/generic_33.f90: New test.
+
 2018-06-11  Carl Love  <cel@us.ibm.com>
 	* gcc.target/powerpc/altivec-7.c (main): Remove tests
 	vec_unpackh(vecubi[0]) and vec_unpackl(vecubi[0]) returning

gcc/testsuite/gfortran.dg/generic_32.f90

+! { dg-do compile }
+!
+! PR 45521: [F08] GENERIC resolution with ALLOCATABLE/POINTER and PROCEDURE
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+
+  INTERFACE gen
+    SUBROUTINE suba(a)   ! { dg-error "Ambiguous interfaces" }
+      REAL,ALLOCATABLE :: a(:)
+    END SUBROUTINE
+    SUBROUTINE subp(p)   ! { dg-error "Ambiguous interfaces" }
+      REAL,POINTER,INTENT(IN) :: p(:)
+    END SUBROUTINE
+  END INTERFACE
+end

gcc/testsuite/gfortran.dg/generic_33.f90

+! { dg-do compile }
+!
+! PR 45521: [F08] GENERIC resolution with ALLOCATABLE/POINTER and PROCEDURE
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+  type :: t
+  end type
+
+  interface test
+    procedure testAlloc
+    procedure testPtr
+  end interface
+
+contains
+
+  logical function testAlloc(obj)
+    class(t), allocatable :: obj
+    testAlloc = .true.
+  end function
+
+  logical function testPtr(obj)
+    class(t), pointer :: obj
+    testPtr = .false.
+  end function
+
+end