diff options
| author | Janus Weil <janus@gcc.gnu.org> | 2018-06-11 20:44:38 +0200 |
|---|---|---|
| committer | Janus Weil <janus@gcc.gnu.org> | 2018-06-11 20:44:38 +0200 |
| commit | c7927c3bb8f3e21ed77b17bcb62b0125f10c5b29 (patch) | |
| tree | fb7de4b91b949d323991033e90af91994dd2c484 /gcc/fortran/interface.c | |
| parent | 46e318cff70c1adcb0895092975c72f41f82404c (diff) | |
| download | gcc-c7927c3bb8f3e21ed77b17bcb62b0125f10c5b29.zip gcc-c7927c3bb8f3e21ed77b17bcb62b0125f10c5b29.tar.gz gcc-c7927c3bb8f3e21ed77b17bcb62b0125f10c5b29.tar.bz2 | |
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
Diffstat (limited to 'gcc/fortran/interface.c')
| -rw-r--r-- | gcc/fortran/interface.c | 26 |
1 files changed, 22 insertions, 4 deletions
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 7f7b2c6..eafc419 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; } |