From c7927c3bb8f3e21ed77b17bcb62b0125f10c5b29 Mon Sep 17 00:00:00 2001 From: Janus Weil Date: Mon, 11 Jun 2018 20:44:38 +0200 Subject: [PATCH] re PR fortran/45521 ([F08] GENERIC resolution with ALLOCATABLE/POINTER and PROCEDURE) 2018-06-11 Janus Weil PR fortran/45521 * interface.c (compare_ptr_alloc): New function. (generic_correspondence): Call it. 2018-06-11 Janus Weil PR fortran/45521 * gfortran.dg/generic_32.f90: New test. * gfortran.dg/generic_33.f90: New test. From-SVN: r261448 --- gcc/fortran/ChangeLog | 6 ++++++ gcc/fortran/interface.c | 26 +++++++++++++++++++---- gcc/testsuite/ChangeLog | 6 ++++++ gcc/testsuite/gfortran.dg/generic_32.f90 | 16 ++++++++++++++ gcc/testsuite/gfortran.dg/generic_33.f90 | 27 ++++++++++++++++++++++++ 5 files changed, 77 insertions(+), 4 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/generic_32.f90 create mode 100644 gcc/testsuite/gfortran.dg/generic_33.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 2fea88d4219..8a0b5ac6264 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,9 @@ +2018-06-11 Janus Weil + + PR fortran/45521 + * interface.c (compare_ptr_alloc): New function. + (generic_correspondence): Call it. + 2018-06-10 Thomas Koenig * gfortran.h (gfc_expr): Add no_bounds_check field. diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 7f7b2c631cb..eafc419ef3a 100644 --- 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 27201df4ef7..ae6acb39deb 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2018-06-11 Janus Weil + + PR fortran/45521 + * gfortran.dg/generic_32.f90: New test. + * gfortran.dg/generic_33.f90: New test. + 2018-06-11 Carl Love * 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 index 00000000000..61e8a2ab123 --- /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 + + + 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 index 00000000000..540d73b23f0 --- /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 + + 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 -- 2.30.2