From patchwork Thu Mar 2 22:03:48 2023 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Harald Anlauf X-Patchwork-Id: 1751053 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=2620:52:3:1:0:246e:9693:128c; helo=sourceware.org; envelope-from=gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: legolas.ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.a=rsa-sha256 header.s=default header.b=W+/M9RXq; dkim-atps=neutral Received: from sourceware.org (unknown [IPv6:2620:52:3:1:0:246e:9693:128c]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature ECDSA (P-384) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4PSQBD50F0z1yWy for ; Fri, 3 Mar 2023 09:04:34 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 0BE83385B515 for ; Thu, 2 Mar 2023 22:04:32 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 0BE83385B515 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1677794672; bh=zQ6fOYx84+L5ktvw2H5hqgl4jWla9MYa9b8qUhUIjiQ=; h=To:Cc:Subject:Date:List-Id:List-Unsubscribe:List-Archive: List-Post:List-Help:List-Subscribe:From:Reply-To:From; b=W+/M9RXqJVC9gIsQ6ABE7ykTHulKINP9UkLtNsXVrY6VuvIA7DpVRnorOZsdxM6jk J2iX2kVwr5jM9v+rU/J/Z1jDCXmz2LekkNfsvvkkFAtmA7spPL0272wB5PTsTLIkk6 vaWBR1syhciBO8ZWtnORe2YAbj9/oC7XXnrmO3jM= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org 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 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: To: fortran , gcc-patches Cc: tobias@codesourcery.com Subject: [PATCH] Fortran: fix CLASS attribute handling [PR106856] 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 X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , X-Patchwork-Original-From: Harald Anlauf via Gcc-patches From: Harald Anlauf Reply-To: Harald Anlauf Errors-To: gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org Sender: "Gcc-patches" 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 From 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 --- 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