Message ID | trinity-b92172eb-3e6e-401c-82e2-f5e1b3cee6b2-1677794628453@3c-app-gmx-bs40 |
---|---|
State | New |
Headers | show |
Series | Fortran: fix CLASS attribute handling [PR106856] | expand |
On Thu, Mar 02, 2023 at 11:03:48PM +0100, Harald Anlauf via Fortran wrote: > - if (attr->class_ok) > - /* Class container has already been built. */ > + /* Class container has already been built with same name. */ > + if (attr->class_ok > + && ts->u.derived->components->attr.dimension >= attr->dimension > + && ts->u.derived->components->attr.codimension >= attr->codimension > + && ts->u.derived->components->attr.class_pointer >= attr->pointer > + && ts->u.derived->components->attr.allocatable >= attr->allocatable) I suppose I'm a bit confused here. dimension, codimension, pointer and allocatable are 1-bit bitfields in the attr struct. These can have the values 0 and 1, so the above conditionals are always true. The rest of the patch looks reasonable. If Tobias has no objections or comments, it's ok to commit once the above is explained.
Hi Steve, Am 03.03.23 um 20:57 schrieb Steve Kargl via Gcc-patches: > On Thu, Mar 02, 2023 at 11:03:48PM +0100, Harald Anlauf via Fortran wrote: >> - if (attr->class_ok) >> - /* Class container has already been built. */ >> + /* Class container has already been built with same name. */ >> + if (attr->class_ok >> + && ts->u.derived->components->attr.dimension >= attr->dimension >> + && ts->u.derived->components->attr.codimension >= attr->codimension >> + && ts->u.derived->components->attr.class_pointer >= attr->pointer >> + && ts->u.derived->components->attr.allocatable >= attr->allocatable) > > I suppose I'm a bit confused here. dimension, codimension, > pointer and allocatable are 1-bit bitfields in the attr > struct. These can have the values 0 and 1, so the above > conditionals are always true. thanks for looking into it. The above part is from the original draft. I thought I could generate testcases that allow to exercise this part, and found a new case that is not covered by the patch and still ICEs: subroutine bar (x) class(*) :: x dimension :: x(:) allocatable :: x end :-( We'll need to revisit the logic... > The rest of the patch looks reasonable. If Tobias has no > objections or comments, it's ok to commit once the above > is explained. > Thanks, Harald
Hello, Le 03/03/2023 à 20:57, Steve Kargl via Fortran a écrit : > On Thu, Mar 02, 2023 at 11:03:48PM +0100, Harald Anlauf via Fortran wrote: >> - if (attr->class_ok) >> - /* Class container has already been built. */ >> + /* Class container has already been built with same name. */ >> + if (attr->class_ok >> + && ts->u.derived->components->attr.dimension >= attr->dimension >> + && ts->u.derived->components->attr.codimension >= attr->codimension >> + && ts->u.derived->components->attr.class_pointer >= attr->pointer >> + && ts->u.derived->components->attr.allocatable >= attr->allocatable) > > I suppose I'm a bit confused here. dimension, codimension, > pointer and allocatable are 1-bit bitfields in the attr > struct. These can have the values 0 and 1, so the above > conditionals are always true. > as I understand it, they aren't if attr has attributes that aren't already set in the class container's first component. a >= b == !(a < b) and if a and b are boolean-valued, a < b == !a && b. Admittedly, I haven't tested the logic like Harald has. > The rest of the patch looks reasonable. If Tobias has no > objections or comments, it's ok to commit once the above > is explained. > I have two comments, one about the handling of as and sym->as, which I quite don't understand, but I haven't had time to write something about it. The other is about this: > + else if (sym->ts.type == BT_CLASS > + && sym->ts.u.derived->attr.is_class > + && sym->old_symbol && sym->old_symbol->as == CLASS_DATA (sym)->as) > + sym->old_symbol->as = NULL; Can this be avoided? The management of symbol versions should not need any manual change. In principle, either the modified symbols are committed, or (in case of error) the previous symbols are restored, but there shouldn't be any need for restoring a modified previous symbol. I guess it's a matter of memory management, because gfc_build_class_symbol copies the AS pointer to the class descriptor, but I think using gfc_copy_array_spec there or adding the condition above to free_old_symbol would be preferable.
On Fri, Mar 03, 2023 at 10:24:07PM +0100, Mikael Morin wrote: > Hello, > > Le 03/03/2023 à 20:57, Steve Kargl via Fortran a écrit : > > On Thu, Mar 02, 2023 at 11:03:48PM +0100, Harald Anlauf via Fortran wrote: > > > - if (attr->class_ok) > > > - /* Class container has already been built. */ > > > + /* Class container has already been built with same name. */ > > > + if (attr->class_ok > > > + && ts->u.derived->components->attr.dimension >= attr->dimension > > > + && ts->u.derived->components->attr.codimension >= attr->codimension > > > + && ts->u.derived->components->attr.class_pointer >= attr->pointer > > > + && ts->u.derived->components->attr.allocatable >= attr->allocatable) > > > > I suppose I'm a bit confused here. dimension, codimension, > > pointer and allocatable are 1-bit bitfields in the attr > > struct. These can have the values 0 and 1, so the above > > conditionals are always true. > > > as I understand it, they aren't if attr has attributes that aren't already > set in the class container's first component. > a >= b == !(a < b) and if a and b are boolean-valued, a < b == !a && b. > Admittedly, I haven't tested the logic like Harald has. > Mikael, thanks for smacking me with the clue stick. I had to do a quick test to see the trees. % cc -o z a.c && ./z a.i = 0, b.i = 0, a.i >= b.i = 1 a.i = 1, b.i = 0, a.i >= b.i = 1 a.i = 1, b.i = 1, a.i >= b.i = 1 a.i = 0, b.i = 1, a.i >= b.i = 0 I was overlooking the last case. So, the above is an all or nothing test.
Le 03/03/2023 à 22:24, Mikael Morin a écrit : > > I have two comments, one about the handling of as and sym->as, which I > quite don't understand, but I haven't had time to write something about it. I have found the time finally. It's not as bad as it seemed. See below. > diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc > index eec0314cf4c..72d8c6f1c14 100644 > --- a/gcc/fortran/decl.cc > +++ b/gcc/fortran/decl.cc > @@ -8740,45 +8740,23 @@ attr_decl1 (void) > } > } > > - /* Update symbol table. DIMENSION attribute is set in > - gfc_set_array_spec(). For CLASS variables, this must be applied > - to the first component, or '_data' field. */ > if (sym->ts.type == BT_CLASS > && sym->ts.u.derived > && sym->ts.u.derived->attr.is_class) > { > - /* gfc_set_array_spec sets sym->attr not CLASS_DATA(sym)->attr. Check > - for duplicate attribute here. */ > - if (CLASS_DATA(sym)->attr.dimension == 1 && as) > - { > - gfc_error ("Duplicate DIMENSION attribute at %C"); > - m = MATCH_ERROR; > - goto cleanup; > - } > - > - if (!gfc_copy_attr (&CLASS_DATA(sym)->attr, ¤t_attr, &var_locus)) > - { > - m = MATCH_ERROR; > - goto cleanup; > - } > + sym->attr.pointer = CLASS_DATA(sym)->attr.class_pointer; > + sym->attr.allocatable = CLASS_DATA(sym)->attr.allocatable; > + sym->attr.dimension = CLASS_DATA(sym)->attr.dimension; > + sym->attr.codimension = CLASS_DATA(sym)->attr.codimension; > + if (as && CLASS_DATA (sym)->as) > + sym->as = gfc_copy_array_spec (CLASS_DATA (sym)->as); Here the condition on 'CLASS_DATA(sym)->as' makes obviously sense, but I don't see why there is also a condition on 'as'. For example, if the array spec has been previously set on the class container's first component, and there is no array spec information in the current statement (i.e. as == NULL), sym->as will remain NULL, and a non-array class container will be built in gfc_build_class_symbol below. > } > - else > - { > - if (current_attr.dimension == 0 && current_attr.codimension == 0 > - && !gfc_copy_attr (&sym->attr, ¤t_attr, &var_locus)) > - { > - m = MATCH_ERROR; > - goto cleanup; > - } > - } > - > - if (sym->ts.type == BT_CLASS > - && !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as)) > + if (current_attr.dimension == 0 && current_attr.codimension == 0 > + && !gfc_copy_attr (&sym->attr, ¤t_attr, &var_locus)) > { > m = MATCH_ERROR; > goto cleanup; > } > - > if (!gfc_set_array_spec (sym, as, &var_locus)) > { > m = MATCH_ERROR; > @@ -8807,6 +8785,27 @@ attr_decl1 (void) > goto cleanup; > } > > + if (sym->ts.type == BT_CLASS && sym->ts.u.derived->attr.is_class > + && !as && !current_attr.pointer && !current_attr.allocatable > + && !current_attr.external) > + { > + sym->attr.pointer = 0; > + sym->attr.allocatable = 0; > + sym->attr.dimension = 0; > + sym->attr.codimension = 0; > + gfc_free_array_spec (sym->as); sym->as should probably be reset to NULL here. Maybe both calls to gfc_free_array_spec here and to gfc_copy_array_spec above can be avoided by doing a simple pointer copy? > + } > + else if (sym->ts.type == BT_CLASS > + && !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as)) > + { > + m = MATCH_ERROR; > + goto cleanup; > + } > + else if (sym->ts.type == BT_CLASS > + && sym->ts.u.derived->attr.is_class > + && sym->old_symbol && sym->old_symbol->as == CLASS_DATA (sym)->as) > + sym->old_symbol->as = NULL; > + > add_hidden_procptr_result (sym); > > return MATCH_YES;
Hi Mikael! Am 04.03.23 um 14:56 schrieb Mikael Morin: > I have found the time finally. It's not as bad as it seemed. See below. > >> diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc >> index eec0314cf4c..72d8c6f1c14 100644 >> --- a/gcc/fortran/decl.cc >> +++ b/gcc/fortran/decl.cc >> + sym->attr.pointer = CLASS_DATA(sym)->attr.class_pointer; >> + sym->attr.allocatable = CLASS_DATA(sym)->attr.allocatable; >> + sym->attr.dimension = CLASS_DATA(sym)->attr.dimension; >> + sym->attr.codimension = CLASS_DATA(sym)->attr.codimension; >> + if (as && CLASS_DATA (sym)->as) >> + sym->as = gfc_copy_array_spec (CLASS_DATA (sym)->as); > > Here the condition on 'CLASS_DATA(sym)->as' makes obviously sense, but I > don't see why there is also a condition on 'as'. > > For example, if the array spec has been previously set on the class > container's first component, and there is no array spec information in > the current statement (i.e. as == NULL), sym->as will remain NULL, and a > non-array class container will be built in gfc_build_class_symbol below. Very good catch! Indeed, this fixes the testcase variations. >> @@ -8807,6 +8785,27 @@ attr_decl1 (void) >> goto cleanup; >> } >> >> + if (sym->ts.type == BT_CLASS && sym->ts.u.derived->attr.is_class >> + && !as && !current_attr.pointer && !current_attr.allocatable >> + && !current_attr.external) >> + { >> + sym->attr.pointer = 0; >> + sym->attr.allocatable = 0; >> + sym->attr.dimension = 0; >> + sym->attr.codimension = 0; > >> + gfc_free_array_spec (sym->as); > sym->as should probably be reset to NULL here. Done. > Maybe both calls to gfc_free_array_spec here and to gfc_copy_array_spec > above can be avoided by doing a simple pointer copy? I tried that, but this produced a crash with a double-free. The attached revised version uses the above proven changes, and extends the new testcase class_74.f90 by variations of the failures remaining with version 1 so that different codepaths are tested. Regtested again on x86_64-pc-linux-gnu. Any further comments? Thanks for your very helpful review! Harald
Hi Mikael! Am 04.03.23 um 14:56 schrieb Mikael Morin: > I have found the time finally. It's not as bad as it seemed. See below. > >> diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc >> index eec0314cf4c..72d8c6f1c14 100644 >> --- a/gcc/fortran/decl.cc >> +++ b/gcc/fortran/decl.cc >> + sym->attr.pointer = CLASS_DATA(sym)->attr.class_pointer; >> + sym->attr.allocatable = CLASS_DATA(sym)->attr.allocatable; >> + sym->attr.dimension = CLASS_DATA(sym)->attr.dimension; >> + sym->attr.codimension = CLASS_DATA(sym)->attr.codimension; >> + if (as && CLASS_DATA (sym)->as) >> + sym->as = gfc_copy_array_spec (CLASS_DATA (sym)->as); > > Here the condition on 'CLASS_DATA(sym)->as' makes obviously sense, but I > don't see why there is also a condition on 'as'. > > For example, if the array spec has been previously set on the class > container's first component, and there is no array spec information in > the current statement (i.e. as == NULL), sym->as will remain NULL, and a > non-array class container will be built in gfc_build_class_symbol below. Very good catch! Indeed, this fixes the testcase variations. >> @@ -8807,6 +8785,27 @@ attr_decl1 (void) >> goto cleanup; >> } >> >> + if (sym->ts.type == BT_CLASS && sym->ts.u.derived->attr.is_class >> + && !as && !current_attr.pointer && !current_attr.allocatable >> + && !current_attr.external) >> + { >> + sym->attr.pointer = 0; >> + sym->attr.allocatable = 0; >> + sym->attr.dimension = 0; >> + sym->attr.codimension = 0; > >> + gfc_free_array_spec (sym->as); > sym->as should probably be reset to NULL here. Done. > Maybe both calls to gfc_free_array_spec here and to gfc_copy_array_spec > above can be avoided by doing a simple pointer copy? I tried that, but this produced a crash with a double-free. The attached revised version uses the above proven changes, and extends the new testcase class_74.f90 by variations of the failures remaining with version 1 so that different codepaths are tested. Regtested again on x86_64-pc-linux-gnu. Any further comments? Thanks for your very helpful review! Harald
Sorry, attached the wrong patch. Here's the correct one. Harald Am 04.03.23 um 17:02 schrieb Harald Anlauf via Gcc-patches: > The attached revised version uses the above proven changes, > and extends the new testcase class_74.f90 by variations of > the failures remaining with version 1 so that different > codepaths are tested. > > Regtested again on x86_64-pc-linux-gnu. > > Any further comments? > > Thanks for your very helpful review! > > Harald
Le 04/03/2023 à 17:06, Harald Anlauf a écrit : > Sorry, attached the wrong patch. > > Here's the correct one. > > Harald > > Am 04.03.23 um 17:02 schrieb Harald Anlauf via Gcc-patches: > >> The attached revised version uses the above proven changes, >> and extends the new testcase class_74.f90 by variations of >> the failures remaining with version 1 so that different >> codepaths are tested. >> >> Regtested again on x86_64-pc-linux-gnu. >> >> Any further comments? >> There was a comment about the old_symbol thing at the end of my previous message: https://gcc.gnu.org/pipermail/gcc-patches/2023-March/613354.html
Hi Mikael, Am 04.03.23 um 18:09 schrieb Mikael Morin: > There was a comment about the old_symbol thing at the end of my previous > message: > https://gcc.gnu.org/pipermail/gcc-patches/2023-March/613354.html I think Tobias might be the better person to answer this. But when playing with variations of that else-branch, I always hit an issue with class_74.f90, where the class variables are not dummy arguments but local variables. E.g. take the following reduced testcase: subroutine foo class(*) :: y dimension :: y(:,:) pointer :: y end subroutine foo So when we see the dimension but haven't seen the pointer (or allocatable) declaration, we appear to generate an error with bad consequences (ICE). If this is a resolution issue, maybe it can be fixed differently, but likely needs digging deeper. With the patch as-is at least I do not see a memory leak in that context. Cheers, Harald
Le 04/03/2023 à 22:20, Harald Anlauf a écrit : > Hi Mikael, > > Am 04.03.23 um 18:09 schrieb Mikael Morin: >> There was a comment about the old_symbol thing at the end of my previous >> message: >> https://gcc.gnu.org/pipermail/gcc-patches/2023-March/613354.html > > I think Tobias might be the better person to answer this. > But when playing with variations of that else-branch, > I always hit an issue with class_74.f90, where the class > variables are not dummy arguments but local variables. > > E.g. take the following reduced testcase: > > subroutine foo > class(*) :: y > dimension :: y(:,:) > pointer :: y > end subroutine foo > > So when we see the dimension but haven't seen the > pointer (or allocatable) declaration, we appear to > generate an error with bad consequences (ICE). > > If this is a resolution issue, maybe it can be fixed > differently, but likely needs digging deeper. With > the patch as-is at least I do not see a memory leak > in that context. > One of my suggestions was to fix it as attached. It is probably more clear with an actual patch to look at. It seems to work on your example and class_74 as well. It seems to also fix some valgrind errors on this example: subroutine foo pointer :: y dimension :: y(:,:) class(*) :: y end subroutine foo I'm fine with that fix if it works for you. I suggest waiting for next stage 1, but it's your call, you have the green light from Steve anyway. Thanks for your work.
From 4600577e3ecceb2525618685f47c8a979cf9d244 Mon Sep 17 00:00:00 2001 From: Harald Anlauf <anlauf@gmx.de> Date: Thu, 2 Mar 2023 22:37:14 +0100 Subject: [PATCH] Fortran: fix CLASS attribute handling [PR106856] gcc/fortran/ChangeLog: PR fortran/106856 * class.cc (gfc_build_class_symbol): Handle update of attributes of existing class container. (gfc_find_derived_vtab): Fix several memory leaks. * decl.cc (attr_decl1): Manage update of symbol attributes from CLASS attributes. * primary.cc (gfc_variable_attr): OPTIONAL shall not be taken or updated from the class container. gcc/testsuite/ChangeLog: PR fortran/106856 * gfortran.dg/interface_41.f90: Remove dg-pattern from valid testcase. * gfortran.dg/class_74.f90: New test. * gfortran.dg/class_75.f90: New test. Co-authored-by: Tobias Burnus <tobias@codesourcery.com> --- gcc/fortran/class.cc | 23 +++++++-- gcc/fortran/decl.cc | 59 +++++++++++----------- gcc/fortran/primary.cc | 1 - gcc/testsuite/gfortran.dg/class_74.f90 | 41 +++++++++++++++ gcc/testsuite/gfortran.dg/class_75.f90 | 24 +++++++++ gcc/testsuite/gfortran.dg/interface_41.f90 | 2 +- 6 files changed, 115 insertions(+), 35 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/class_74.f90 create mode 100644 gcc/testsuite/gfortran.dg/class_75.f90 diff --git a/gcc/fortran/class.cc b/gcc/fortran/class.cc index ae653e74437..2eebdd4a3bb 100644 --- a/gcc/fortran/class.cc +++ b/gcc/fortran/class.cc @@ -638,6 +638,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, { char tname[GFC_MAX_SYMBOL_LEN+1]; char *name; + gfc_typespec *orig_ts = ts; gfc_symbol *fclass; gfc_symbol *vtab; gfc_component *c; @@ -646,9 +647,21 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, gcc_assert (as); - if (attr->class_ok) - /* Class container has already been built. */ + /* Class container has already been built with same name. */ + if (attr->class_ok + && ts->u.derived->components->attr.dimension >= attr->dimension + && ts->u.derived->components->attr.codimension >= attr->codimension + && ts->u.derived->components->attr.class_pointer >= attr->pointer + && ts->u.derived->components->attr.allocatable >= attr->allocatable) return true; + if (attr->class_ok) + { + attr->dimension |= ts->u.derived->components->attr.dimension; + attr->codimension |= ts->u.derived->components->attr.codimension; + attr->pointer |= ts->u.derived->components->attr.class_pointer; + attr->allocatable |= ts->u.derived->components->attr.allocatable; + ts = &ts->u.derived->components->ts; + } attr->class_ok = attr->dummy || attr->pointer || attr->allocatable || attr->select_type_temporary || attr->associate_var; @@ -790,7 +803,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, } fclass->attr.is_class = 1; - ts->u.derived = fclass; + orig_ts->u.derived = fclass; attr->allocatable = attr->pointer = attr->dimension = attr->codimension = 0; (*as) = NULL; free (name); @@ -2344,6 +2357,7 @@ gfc_find_derived_vtab (gfc_symbol *derived) vtab->attr.vtab = 1; vtab->attr.access = ACCESS_PUBLIC; gfc_set_sym_referenced (vtab); + free (name); name = xasprintf ("__vtype_%s", tname); gfc_find_symbol (name, ns, 0, &vtype); @@ -2447,6 +2461,7 @@ gfc_find_derived_vtab (gfc_symbol *derived) else { /* Construct default initialization variable. */ + free (name); name = xasprintf ("__def_init_%s", tname); gfc_get_symbol (name, ns, &def_init); def_init->attr.target = 1; @@ -2480,6 +2495,7 @@ gfc_find_derived_vtab (gfc_symbol *derived) ns->contained = sub_ns; sub_ns->resolved = 1; /* Set up procedure symbol. */ + free (name); name = xasprintf ("__copy_%s", tname); gfc_get_symbol (name, sub_ns, ©); sub_ns->proc_name = copy; @@ -2558,6 +2574,7 @@ gfc_find_derived_vtab (gfc_symbol *derived) ns->contained = sub_ns; sub_ns->resolved = 1; /* Set up procedure symbol. */ + free (name); name = xasprintf ("__deallocate_%s", tname); gfc_get_symbol (name, sub_ns, &dealloc); sub_ns->proc_name = dealloc; diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc index eec0314cf4c..72d8c6f1c14 100644 --- a/gcc/fortran/decl.cc +++ b/gcc/fortran/decl.cc @@ -8740,45 +8740,23 @@ attr_decl1 (void) } } - /* Update symbol table. DIMENSION attribute is set in - gfc_set_array_spec(). For CLASS variables, this must be applied - to the first component, or '_data' field. */ if (sym->ts.type == BT_CLASS && sym->ts.u.derived && sym->ts.u.derived->attr.is_class) { - /* gfc_set_array_spec sets sym->attr not CLASS_DATA(sym)->attr. Check - for duplicate attribute here. */ - if (CLASS_DATA(sym)->attr.dimension == 1 && as) - { - gfc_error ("Duplicate DIMENSION attribute at %C"); - m = MATCH_ERROR; - goto cleanup; - } - - if (!gfc_copy_attr (&CLASS_DATA(sym)->attr, ¤t_attr, &var_locus)) - { - m = MATCH_ERROR; - goto cleanup; - } + sym->attr.pointer = CLASS_DATA(sym)->attr.class_pointer; + sym->attr.allocatable = CLASS_DATA(sym)->attr.allocatable; + sym->attr.dimension = CLASS_DATA(sym)->attr.dimension; + sym->attr.codimension = CLASS_DATA(sym)->attr.codimension; + if (as && CLASS_DATA (sym)->as) + sym->as = gfc_copy_array_spec (CLASS_DATA (sym)->as); } - else - { - if (current_attr.dimension == 0 && current_attr.codimension == 0 - && !gfc_copy_attr (&sym->attr, ¤t_attr, &var_locus)) - { - m = MATCH_ERROR; - goto cleanup; - } - } - - if (sym->ts.type == BT_CLASS - && !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as)) + if (current_attr.dimension == 0 && current_attr.codimension == 0 + && !gfc_copy_attr (&sym->attr, ¤t_attr, &var_locus)) { m = MATCH_ERROR; goto cleanup; } - if (!gfc_set_array_spec (sym, as, &var_locus)) { m = MATCH_ERROR; @@ -8807,6 +8785,27 @@ attr_decl1 (void) goto cleanup; } + if (sym->ts.type == BT_CLASS && sym->ts.u.derived->attr.is_class + && !as && !current_attr.pointer && !current_attr.allocatable + && !current_attr.external) + { + sym->attr.pointer = 0; + sym->attr.allocatable = 0; + sym->attr.dimension = 0; + sym->attr.codimension = 0; + gfc_free_array_spec (sym->as); + } + else if (sym->ts.type == BT_CLASS + && !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as)) + { + m = MATCH_ERROR; + goto cleanup; + } + else if (sym->ts.type == BT_CLASS + && sym->ts.u.derived->attr.is_class + && sym->old_symbol && sym->old_symbol->as == CLASS_DATA (sym)->as) + sym->old_symbol->as = NULL; + add_hidden_procptr_result (sym); return MATCH_YES; diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc index 1bea17d44fe..00d35a71770 100644 --- a/gcc/fortran/primary.cc +++ b/gcc/fortran/primary.cc @@ -2640,7 +2640,6 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts) codimension = CLASS_DATA (sym)->attr.codimension; pointer = CLASS_DATA (sym)->attr.class_pointer; allocatable = CLASS_DATA (sym)->attr.allocatable; - optional |= CLASS_DATA (sym)->attr.optional; } else { diff --git a/gcc/testsuite/gfortran.dg/class_74.f90 b/gcc/testsuite/gfortran.dg/class_74.f90 new file mode 100644 index 00000000000..cd169375356 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_74.f90 @@ -0,0 +1,41 @@ +! { dg-do compile } +! { dg-additional-options "-fcoarray=single" } +! +! PR fortran/106856 +! +! Contributed by G. Steinmetz +! +subroutine foo + interface + subroutine bar(x) + type(*) :: x + end subroutine bar + end interface + class(*) :: x, y + allocatable :: x + dimension :: x(:), y(:,:) + codimension :: x[:] + pointer :: y + y => null() + if (allocated(x)) then + call bar(x(2)[1]) + end if + if (associated(y)) then + call bar(y(2,2)) + end if +end subroutine foo + + +program p + class(*), allocatable :: x, y + y = 'abc' + call s1(x, y) +contains + subroutine s1(x, y) + class(*) :: x, y + end + subroutine s2(x, y) + class(*), allocatable :: x, y + optional :: x + end +end diff --git a/gcc/testsuite/gfortran.dg/class_75.f90 b/gcc/testsuite/gfortran.dg/class_75.f90 new file mode 100644 index 00000000000..eb29ad51c85 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_75.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! { dg-additional-options "-fcoarray=single" } +! +! PR fortran/106856 +! +! +! +subroutine foo(x,y) + class(*), optional :: x, y + optional :: x ! { dg-error "Duplicate OPTIONAL attribute" } + target :: x + allocatable :: x + target :: x ! { dg-error "Duplicate TARGET attribute" } + allocatable :: x ! { dg-error "Duplicate ALLOCATABLE attribute" } + pointer :: y + contiguous :: y + pointer :: y ! { dg-error "Duplicate POINTER attribute" } + contiguous :: y ! { dg-error "Duplicate CONTIGUOUS attribute" } + codimension :: x[:] + dimension :: x(:,:) + dimension :: y(:,:,:) + codimension :: x[:] ! { dg-error "Duplicate CODIMENSION attribute" } + dimension :: y(:) ! { dg-error "Duplicate DIMENSION attribute" } +end diff --git a/gcc/testsuite/gfortran.dg/interface_41.f90 b/gcc/testsuite/gfortran.dg/interface_41.f90 index b5ea8af189d..2fec01e3cf9 100644 --- a/gcc/testsuite/gfortran.dg/interface_41.f90 +++ b/gcc/testsuite/gfortran.dg/interface_41.f90 @@ -14,6 +14,6 @@ contains subroutine s type(t) :: x(2) real :: z - z = f(x) ! { dg-error "Rank mismatch in argument" } + z = f(x) end end -- 2.35.3