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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 2fea88d42193ef04001cd87218414e9c36f80702..8a0b5ac6264b3c8cc8b46775aa4cafdd78f43b52 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+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.

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 7f7b2c631cb3adaf0c1709cab98b573d50afddd5..eafc419ef3ad50e12900f652a346bfbbd7f00fb9 100644 (file)
--- a/gcc/fortran/interface.c
+++ b/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;
        }
 

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 27201df4ef74e7b7ce169a1ff905fd4ad7b88a1a..ae6acb39deb7c279a70aa5bfae785fd9e329a2ec 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+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

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

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