From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mout.gmx.net (mout.gmx.net [212.227.15.18]) by sourceware.org (Postfix) with ESMTPS id 891FB3858CDB; Thu, 2 Mar 2023 22:03:52 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 891FB3858CDB Authentication-Results: sourceware.org; dmarc=pass (p=none dis=none) header.from=gmx.de Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=gmx.de DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/simple; d=gmx.de; s=s31663417; t=1677794628; i=anlauf@gmx.de; bh=vkq8+oitRFHG2vr8XIzRljmi0cMbdDQPP7liJYeVzq8=; h=X-UI-Sender-Class:From:To:Cc:Subject:Date; b=fRgCmGgArj+Ey5cBvUcAUVxhlmbhqk/Rh3psO59DAAGyk5z6mjs2rek9wj4I9wgtx YVbcRzzV8MOwzDtlo3ZrOXlLDpuwdsvH9NMAwF6G1/y4MISXRRBCQmUBkhpTfvpG8H SepyYpTewHGl7A5rPmfEz/fuQssq7j6p+lHCkfFs7bRKov1hmMljNvEkU4q9Okx4gj jSEFYIxhqX8Z/axsQvm5fSncxE8mVH4+Z9N+mrjh1+5Cy0djpIsdYUp4y6YOiksxSF vVXYpCr21ugbLC1yuZdubQusjWoovVxCXixfx3bzPR6JWqzFSL2jRlTETwy63W1BKl WuGXQKEcjqUNw== X-UI-Sender-Class: 724b4f7f-cbec-4199-ad4e-598c01a50d3a Received: from [79.251.13.120] ([79.251.13.120]) by web-mail.gmx.net (3c-app-gmx-bs40.server.lan [172.19.170.92]) (via HTTP); Thu, 2 Mar 2023 23:03:48 +0100 MIME-Version: 1.0 Message-ID: From: Harald Anlauf To: fortran , gcc-patches Cc: tobias@codesourcery.com Subject: [PATCH] Fortran: fix CLASS attribute handling [PR106856] Content-Type: multipart/mixed; boundary=refeik-268c6584-2a61-48aa-8499-ca4e34d4cc7a Date: Thu, 2 Mar 2023 23:03:48 +0100 Importance: normal Sensitivity: Normal X-Priority: 3 X-Provags-ID: V03:K1:92gRYdvKusQcEC8ir2btbvpIaYr3DuedIpc2hWZAhA0rKSyblhnAIBbimAy2gQjW8ywu+ 8DsTyqQ2GI/ikFmuBcPo+017L8e5QU0L5k3Km2pKfl49tHp0HxNMGxJ6yxHBcUEkid67k4eA7fUr bOSb87ywIDtC7xgXh4K1yrs1qe42IHpNTpmye1WJcMPMtG+0yogFi5rDB3o6LccfKySrjaME5xZu SQk0GFdiYi9OzDzPCtHYesk0wEgFmfVHoizzprLqS779it5CpSBFk5coTXbY227ns9IjhIX5Ofz3 s0= UI-OutboundReport: notjunk:1;M01:P0:r16ZseeI+Gw=;7j74lQl2THHQSK2AymJr0LlOdrV NWXwEWr9FyYoTDSw5W9P01OC0abpwufoyWdiVRivndSYSfp0CeQdTbCPJa/kHrVH2u7zUWUjc pD8wal4qFs0roJsEfKksJuMS19RAuX2hitpee5Kx755cqrkFNHZpIKu8JouxST4oW9fRKhY8Q soXZOJ0hUAfDEInmPiIf0ql3mHqZv5+qlABjjB81L9nTDGnUN44Tn5FhXvbYZdCtHAQDU/axZ +UrlRIkMwXsUqwIqBDzhPRMUXxh/hP0XpceVl7vs91CdU5HNXWCEdT4n1dy/YoG9wcFjxCYi8 JFkJtzfhUm8ERxayYPbejbmYSfGWXkUtGuuCX0pRvIEJ7tXOMdaGPOPxMIDGWbGcaCVZAxuNM vNPA8szUcyUY4e8muzjV+Bfh8Wqbjc6+sqNBqRpdCo3U8RpgRYFpHJOZMk7wj3JtHDqrUyTI7 MHSqsHgspC+mhAjNcbOFsSnc3ZYLYrX1w/Pg/ERYgSn7YiyKHn06JV7sgVRbTbnXCyhafUgZI V8iPu972AO0tSyOwtmxiqjMqngLxURZNWlYRHh0H40jKiBV1zAnCr2fmwfT3xH5bhvILMu8Xj Px4IKQC+ad5r9eRmgw7Xakv3+lD7xG4urlGj164qhYlUFuaI/CB99+Iv4nJAQc7Tl3Uut9Le3 serrqNNr9ZmB4EUACxPKGLYIJMtlGWKJDSQdkxOAbeJ0faMQY427s12oPpm4eWW02ZcowWGLi MeJGiM8NQjAPFwcLPTguQDLcSjk/9udB6Sj6d6rr/yKsQO/6yzU1vay/dL+BwcX4OrRxIHtJ8 F4g1dwakxejGiL2u0kc6tkdX0zXKf9FyDll6fzLP6THz0= X-Spam-Status: No, score=-12.8 required=5.0 tests=BAYES_00,DKIM_SIGNED,DKIM_VALID,DKIM_VALID_AU,DKIM_VALID_EF,FREEMAIL_FROM,GIT_PATCH_0,RCVD_IN_DNSWL_LOW,RCVD_IN_MSPIKE_H2,SPF_HELO_NONE,SPF_PASS,TXREP,T_FILL_THIS_FORM_SHORT autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on server2.sourceware.org List-Id: --refeik-268c6584-2a61-48aa-8499-ca4e34d4cc7a Content-Type: text/plain; charset=UTF-8 Dear all, the attached patch fixes a long-standing issue with CLASS attributes when a declaration is scattered over multiple statements. The major part ("draft") of the patch is by Tobias, which I took up before it started to bit-rot too much, see PR. It is mainly about a proper updating and book-keeping of symbol attributes. While debugging the draft patch, I fixed a few disturbing memleaks in class.cc that showed up when looking at intermediate fallout. This patch also addresses issues reported in a few other PRs: pr53951, pr101101, pr104229, pr107380. These are mostly duplicates at some level. Regtested on x86_64-pc-linux-gnu. OK for mainline? Thanks, Harald --refeik-268c6584-2a61-48aa-8499-ca4e34d4cc7a Content-Type: text/x-patch Content-Disposition: attachment; filename=pr106856.diff Content-Transfer-Encoding: quoted-printable =46rom 4600577e3ecceb2525618685f47c8a979cf9d244 Mon Sep 17 00:00:00 2001 From: Harald Anlauf 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 =2D-- 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 =2D-- a/gcc/fortran/class.cc +++ b/gcc/fortran/class.cc @@ -638,6 +638,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attri= bute *attr, { char tname[GFC_MAX_SYMBOL_LEN+1]; char *name; + gfc_typespec *orig_ts =3D ts; gfc_symbol *fclass; gfc_symbol *vtab; gfc_component *c; @@ -646,9 +647,21 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attr= ibute *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 >=3D attr->dimension + && ts->u.derived->components->attr.codimension >=3D attr->codimensi= on + && ts->u.derived->components->attr.class_pointer >=3D attr->pointer + && ts->u.derived->components->attr.allocatable >=3D attr->allocatab= le) return true; + if (attr->class_ok) + { + attr->dimension |=3D ts->u.derived->components->attr.dimension; + attr->codimension |=3D ts->u.derived->components->attr.codimension; + attr->pointer |=3D ts->u.derived->components->attr.class_pointer; + attr->allocatable |=3D ts->u.derived->components->attr.allocatable; + ts =3D &ts->u.derived->components->ts; + } attr->class_ok =3D 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_attri= bute *attr, } fclass->attr.is_class =3D 1; - ts->u.derived =3D fclass; + orig_ts->u.derived =3D fclass; attr->allocatable =3D attr->pointer =3D attr->dimension =3D attr->codim= ension =3D 0; (*as) =3D NULL; free (name); @@ -2344,6 +2357,7 @@ gfc_find_derived_vtab (gfc_symbol *derived) vtab->attr.vtab =3D 1; vtab->attr.access =3D ACCESS_PUBLIC; gfc_set_sym_referenced (vtab); + free (name); name =3D 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 =3D xasprintf ("__def_init_%s", tname); gfc_get_symbol (name, ns, &def_init); def_init->attr.target =3D 1; @@ -2480,6 +2495,7 @@ gfc_find_derived_vtab (gfc_symbol *derived) ns->contained =3D sub_ns; sub_ns->resolved =3D 1; /* Set up procedure symbol. */ + free (name); name =3D xasprintf ("__copy_%s", tname); gfc_get_symbol (name, sub_ns, ©); sub_ns->proc_name =3D copy; @@ -2558,6 +2574,7 @@ gfc_find_derived_vtab (gfc_symbol *derived) ns->contained =3D sub_ns; sub_ns->resolved =3D 1; /* Set up procedure symbol. */ + free (name); name =3D xasprintf ("__deallocate_%s", tname); gfc_get_symbol (name, sub_ns, &dealloc); sub_ns->proc_name =3D dealloc; diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc index eec0314cf4c..72d8c6f1c14 100644 =2D-- 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 =3D=3D 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. Ch= eck - for duplicate attribute here. */ - if (CLASS_DATA(sym)->attr.dimension =3D=3D 1 && as) - { - gfc_error ("Duplicate DIMENSION attribute at %C"); - m =3D MATCH_ERROR; - goto cleanup; - } - - if (!gfc_copy_attr (&CLASS_DATA(sym)->attr, ¤t_attr, &var_loc= us)) - { - m =3D MATCH_ERROR; - goto cleanup; - } + sym->attr.pointer =3D CLASS_DATA(sym)->attr.class_pointer; + sym->attr.allocatable =3D CLASS_DATA(sym)->attr.allocatable; + sym->attr.dimension =3D CLASS_DATA(sym)->attr.dimension; + sym->attr.codimension =3D CLASS_DATA(sym)->attr.codimension; + if (as && CLASS_DATA (sym)->as) + sym->as =3D gfc_copy_array_spec (CLASS_DATA (sym)->as); } - else - { - if (current_attr.dimension =3D=3D 0 && current_attr.codimension =3D= =3D 0 - && !gfc_copy_attr (&sym->attr, ¤t_attr, &var_locus)) - { - m =3D MATCH_ERROR; - goto cleanup; - } - } - - if (sym->ts.type =3D=3D BT_CLASS - && !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as)) + if (current_attr.dimension =3D=3D 0 && current_attr.codimension =3D=3D = 0 + && !gfc_copy_attr (&sym->attr, ¤t_attr, &var_locus)) { m =3D MATCH_ERROR; goto cleanup; } - if (!gfc_set_array_spec (sym, as, &var_locus)) { m =3D MATCH_ERROR; @@ -8807,6 +8785,27 @@ attr_decl1 (void) goto cleanup; } + if (sym->ts.type =3D=3D BT_CLASS && sym->ts.u.derived->attr.is_class + && !as && !current_attr.pointer && !current_attr.allocatable + && !current_attr.external) + { + sym->attr.pointer =3D 0; + sym->attr.allocatable =3D 0; + sym->attr.dimension =3D 0; + sym->attr.codimension =3D 0; + gfc_free_array_spec (sym->as); + } + else if (sym->ts.type =3D=3D BT_CLASS + && !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as)) + { + m =3D MATCH_ERROR; + goto cleanup; + } + else if (sym->ts.type =3D=3D BT_CLASS + && sym->ts.u.derived->attr.is_class + && sym->old_symbol && sym->old_symbol->as =3D=3D CLASS_DATA (sym)->as= ) + sym->old_symbol->as =3D 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 =2D-- a/gcc/fortran/primary.cc +++ b/gcc/fortran/primary.cc @@ -2640,7 +2640,6 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts) codimension =3D CLASS_DATA (sym)->attr.codimension; pointer =3D CLASS_DATA (sym)->attr.class_pointer; allocatable =3D CLASS_DATA (sym)->attr.allocatable; - optional |=3D CLASS_DATA (sym)->attr.optional; } else { diff --git a/gcc/testsuite/gfortran.dg/class_74.f90 b/gcc/testsuite/gfortr= an.dg/class_74.f90 new file mode 100644 index 00000000000..cd169375356 =2D-- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_74.f90 @@ -0,0 +1,41 @@ +! { dg-do compile } +! { dg-additional-options "-fcoarray=3Dsingle" } +! +! 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 =3D> 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 =3D '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/gfortr= an.dg/class_75.f90 new file mode 100644 index 00000000000..eb29ad51c85 =2D-- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_75.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! { dg-additional-options "-fcoarray=3Dsingle" } +! +! 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/gf= ortran.dg/interface_41.f90 index b5ea8af189d..2fec01e3cf9 100644 =2D-- 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 =3D f(x) ! { dg-error "Rank mismatch in argument" } + z =3D f(x) end end =2D- 2.35.3 --refeik-268c6584-2a61-48aa-8499-ca4e34d4cc7a--