From patchwork Sun Mar 5 20:21:41 2023 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Harald Anlauf X-Patchwork-Id: 66015 Return-Path: X-Original-To: patchwork@sourceware.org Delivered-To: patchwork@sourceware.org Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 905103854811 for ; Sun, 5 Mar 2023 20:22:21 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 905103854811 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1678047741; bh=QLho16yQjQEIl8BJKG52Foe8L6JBS07xP8VgEWA5oTU=; h=To:Subject:Date:References:In-Reply-To:Cc:List-Id: List-Unsubscribe:List-Archive:List-Post:List-Help:List-Subscribe: From:Reply-To:From; b=bwyMiG8ESKy2dbtoPzaBmZVIDP88j+mJXcU87Es78A8R3mQpB7oD/vuLhJPtlRW0a 2C0kSUWcV3wMJZLnTtjunHT7G6z3BqNRg0Imdu2zDO9jxzpB6wu+Yst5cUJtdMy7bI zLP6iED5Xuw4yaGktf+VlS1SYzJdSZ0Vx2x4knkU= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from ciao.gmane.io (ciao.gmane.io [116.202.254.214]) by sourceware.org (Postfix) with ESMTPS id A11AF3858D1E for ; Sun, 5 Mar 2023 20:21:49 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org A11AF3858D1E Received: from list by ciao.gmane.io with local (Exim 4.92) (envelope-from ) id 1pYurc-0003Wd-8e for gcc-patches@gcc.gnu.org; Sun, 05 Mar 2023 21:21:48 +0100 X-Injected-Via-Gmane: http://gmane.org/ To: gcc-patches@gcc.gnu.org Subject: [PATCH, v3] Fortran: fix CLASS attribute handling [PR106856] Date: Sun, 5 Mar 2023 21:21:41 +0100 Message-ID: References: <5b42f0b7-e217-555d-b1f2-4b623f3ae150@orange.fr> <5f1e8202-303e-5da2-c42b-8eab00a12a97@orange.fr> <48caf060-4349-b077-24da-8bf53ed4b650@gmx.de> <614d6385-49fe-4869-ef4b-8afa175d3693@orange.fr> <871e46b4-af10-c8fc-105c-9aec987e2cac@gmx.de> Mime-Version: 1.0 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:102.0) Gecko/20100101 Thunderbird/102.8.0 Content-Language: en-US In-Reply-To: Cc: fortran@gcc.gnu.org X-Spam-Status: No, score=-7.5 required=5.0 tests=BAYES_00, BODY_8BITS, FREEMAIL_FORGED_FROMDOMAIN, FREEMAIL_FROM, GIT_PATCH_0, HEADER_FROM_DIFFERENT_DOMAINS, KAM_DMARC_STATUS, KAM_SHORT, SPF_HELO_NONE, SPF_PASS, TXREP 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+patchwork=sourceware.org@gcc.gnu.org Sender: "Gcc-patches" Hi Mikael, Am 04.03.23 um 23:29 schrieb Mikael Morin: > 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. This fix is great. I've included it in the revised patch. > 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've added this variant to class_74.f90, so it won't break without noticing. > I suggest waiting for next stage 1, but it's your call, you have the > green light from Steve anyway. I've chosen to push patch v3 (attached) after a further round of regtesting as r13-6497-g6aa1f40a326374 . > Thanks for your work. Many thanks for your very helpful review! Harald From 6aa1f40a3263741d964ef4716e85a0df5cec83b6 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. (find_intrinsic_vtab): Ditto. * 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. * symbol.cc (free_old_symbol): Adjust management of symbol versions to not prematurely free array specs while working on the declation of CLASS variables. 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 | 25 +++- gcc/fortran/decl.cc | 56 ++++---- gcc/fortran/primary.cc | 1 - gcc/fortran/symbol.cc | 6 +- gcc/testsuite/gfortran.dg/class_74.f90 | 151 +++++++++++++++++++++ gcc/testsuite/gfortran.dg/class_75.f90 | 24 ++++ gcc/testsuite/gfortran.dg/interface_41.f90 | 2 +- 7 files changed, 229 insertions(+), 36 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..52235ab83e3 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; @@ -2723,6 +2740,7 @@ find_intrinsic_vtab (gfc_typespec *ts) 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); @@ -2801,6 +2819,7 @@ find_intrinsic_vtab (gfc_typespec *ts) c->tb = XCNEW (gfc_typebound_proc); c->tb->ppc = 1; + free (name); if (ts->type != BT_CHARACTER) name = xasprintf ("__copy_%s", tname); else diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc index eec0314cf4c..c8f0bb83c2c 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 (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,24 @@ 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 = NULL; + } + else if (sym->ts.type == BT_CLASS + && !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as)) + { + m = MATCH_ERROR; + goto cleanup; + } + 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/fortran/symbol.cc b/gcc/fortran/symbol.cc index 2ce0f3e4df7..221165d6dac 100644 --- a/gcc/fortran/symbol.cc +++ b/gcc/fortran/symbol.cc @@ -3761,7 +3761,11 @@ free_old_symbol (gfc_symbol *sym) if (sym->old_symbol == NULL) return; - if (sym->old_symbol->as != sym->as) + if (sym->old_symbol->as != NULL + && sym->old_symbol->as != sym->as + && !(sym->ts.type == BT_CLASS + && sym->ts.u.derived->attr.is_class + && sym->old_symbol->as == CLASS_DATA (sym)->as)) gfc_free_array_spec (sym->old_symbol->as); if (sym->old_symbol->value != sym->value) diff --git a/gcc/testsuite/gfortran.dg/class_74.f90 b/gcc/testsuite/gfortran.dg/class_74.f90 new file mode 100644 index 00000000000..2394ed918fc --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_74.f90 @@ -0,0 +1,151 @@ +! { 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 + + +subroutine s1 (x) + class(*) :: x + allocatable :: x + dimension :: x(:) + if (allocated (x)) print *, size (x) +end + +subroutine s2 (x) + class(*) :: x + allocatable :: x(:) + if (allocated (x)) print *, size (x) +end + +subroutine s3 (x) + class(*) :: x(:) + allocatable :: x + if (allocated (x)) print *, size (x) +end + +subroutine s4 (x) + class(*) :: x + dimension :: x(:) + allocatable :: x + if (allocated (x)) print *, size (x) +end + + +subroutine c0 (x) + class(*) :: x + allocatable :: x + codimension :: x[:] + dimension :: x(:) + if (allocated (x)) print *, size (x) +end + +subroutine c1 (x) + class(*) :: x(:) + allocatable :: x[:] + if (allocated (x)) print *, size (x) +end + +subroutine c2 (x) + class(*) :: x[:] + allocatable :: x(:) + if (allocated (x)) print *, size (x) +end + +subroutine c3 (x) + class(*) :: x(:)[:] + allocatable :: x + if (allocated (x)) print *, size (x) +end + +subroutine c4 (x) + class(*) :: x + dimension :: x(:) + codimension :: x[:] + allocatable :: x + if (allocated (x)) print *, size (x) +end + + +subroutine p1 (x) + class(*) :: x + pointer :: x + dimension :: x(:) + if (associated (x)) print *, size (x) +end + +subroutine p2 (x) + class(*) :: x + pointer :: x(:) + if (associated (x)) print *, size (x) +end + +subroutine p3 (x) + class(*) :: x(:) + pointer :: x + if (associated (x)) print *, size (x) +end + +subroutine p4 (x) + class(*) :: x + dimension :: x(:) + pointer :: x + if (associated (x)) print *, size (x) +end + + +! Testcase by Mikael Morin +subroutine mm () + pointer :: y + dimension :: y(:,:) + class(*) :: y + if (associated (y)) print *, size (y) +end + +! Testcase from pr53951 +subroutine pr53951 () + type t + end type t + class(t), pointer :: C + TARGET :: A + class(t), allocatable :: A, B + TARGET :: B + C => A ! Valid + C => B ! Valid, but was rejected +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