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: 63600 Return-Path: Delivered-To: ouuuleilei@gmail.com Received: by 2002:a5d:5915:0:0:0:0:0 with SMTP id v21csp92578wrd; Thu, 2 Mar 2023 14:05:44 -0800 (PST) X-Google-Smtp-Source: AK7set8dsRnkqu2agdOniF36kZQCfeZ/A4U5+yBDqZhQi3AwAwxojcDKkgfpZr5dhX1jSvau2k80 X-Received: by 2002:aa7:c94c:0:b0:4af:6e95:7067 with SMTP id h12-20020aa7c94c000000b004af6e957067mr11680107edt.37.1677794744006; Thu, 02 Mar 2023 14:05:44 -0800 (PST) ARC-Seal: i=1; a=rsa-sha256; t=1677794743; cv=none; d=google.com; s=arc-20160816; b=YDEhBezAo56qkHZp1469v+nYd02jFKyhoY0yecFWp6BCH0bx7J7RB41b+yfvBDAI3o HiW1YljP9bjRHskmzzYK2/88G2/ly9oBy0laWTeCb6F01or4o3gDYAJsswj7Tc2956On FRK1VezOqG0o5sudtR62vhmkTSJyXkjl4ZvuDcDuAQrPI6j9avzIss/BEwyNox0T3wgD 15195ynDFmJGPxzH3LhtF8Qow07UQJ0RdFozXFDFAOf7SNJRoMTqNVxPaZmKGniwEvDA ijBhQ6v4vSHM52WhRGNPHtrqjmYPh3UpRzJJZy9rCigqDceJl+Ew+DNo5QN5Z7EQQSab lkug== ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=google.com; s=arc-20160816; h=sender:errors-to:reply-to:from:list-subscribe:list-help:list-post :list-archive:list-unsubscribe:list-id:precedence:ui-outboundreport :sensitivity:importance:date:subject:cc:to:message-id:mime-version :dmarc-filter:delivered-to:dkim-signature:dkim-filter; bh=zQ6fOYx84+L5ktvw2H5hqgl4jWla9MYa9b8qUhUIjiQ=; b=qfD9L8sck+koV9RVMnfXxi/L3266WadtPVO5Aa0+Kiz2IPCoJQYK6DUFkMI4LB0g90 LrYWQj1oP+X2Np9kNnLiNlB31KJVkUO0WdMtlCsCxS8gQtk1e+1YG1RRAlMpfF2T8Zu0 oxkWwd2rak210l8gRWfUuvSST1VbPT/+2AplnvJsMGhT72iG6IzUG2UsisCMu0kYO1/M 25yaK+aF3b9juUAabqoFmVL9xj5yf2sA0SG0Dn4TjR5+p9HMYOY3NKMOhqB6eFbtieeM 6CTkttc09ZVisGWJ2Z5b8MSut2xbXpzl3KYkG0Kl/OHu5Wl8iZckDyqqkrmmZKuZ3m4I e+pA== ARC-Authentication-Results: i=1; mx.google.com; dkim=pass header.i=@gcc.gnu.org header.s=default header.b="Q/LWJA+z"; spf=pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 2620:52:3:1:0:246e:9693:128c as permitted sender) smtp.mailfrom="gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org"; dmarc=pass (p=NONE sp=NONE dis=NONE) header.from=gnu.org Received: from sourceware.org ([2620:52:3:1:0:246e:9693:128c]) by mx.google.com with ESMTPS id g10-20020a17090613ca00b008cb24fbfaa9si372190ejc.682.2023.03.02.14.05.43 for (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Thu, 02 Mar 2023 14:05:43 -0800 (PST) Received-SPF: pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 2620:52:3:1:0:246e:9693:128c as permitted sender) client-ip=2620:52:3:1:0:246e:9693:128c; Authentication-Results: mx.google.com; dkim=pass header.i=@gcc.gnu.org header.s=default header.b="Q/LWJA+z"; spf=pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 2620:52:3:1:0:246e:9693:128c as permitted sender) smtp.mailfrom="gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org"; dmarc=pass (p=NONE sp=NONE dis=NONE) header.from=gnu.org Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 3ABD4384FB52 for ; Thu, 2 Mar 2023 22:05:00 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 3ABD4384FB52 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1677794700; 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=Q/LWJA+zlKQ8XAW/E6o9IftnVxTdTrD9hSgpz+ZRamDzQVuyF3BBJumfUGMsPs5nt CnGz3raEtKWk67vKDnoDvEa8Jfdylro3jD2ZFGfR3f45hWJCH3sWX9UdlGsg4N0xkG sw95MuOapwtuyUL6tBTRsbZa0NLn1r4RLwxvwg84= 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+ouuuleilei=gmail.com@gcc.gnu.org Sender: "Gcc-patches" X-getmail-retrieved-from-mailbox: =?utf-8?q?INBOX?= X-GMAIL-THRID: =?utf-8?q?1759295301588040863?= X-GMAIL-MSGID: =?utf-8?q?1759295301588040863?= 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