From patchwork Mon Jul 8 13:51:11 2019 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Mark Eggleston X-Patchwork-Id: 1129096 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (mailfrom) smtp.mailfrom=gcc.gnu.org (client-ip=209.132.180.131; helo=sourceware.org; envelope-from=gcc-patches-return-504610-incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dmarc=fail (p=none dis=none) header.from=codethink.co.uk Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="eg4Hts4y"; dkim-atps=neutral Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 45j6Lh4kCfz9sNF for ; Mon, 8 Jul 2019 23:51:36 +1000 (AEST) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender :subject:from:to:cc:references:message-id:date:mime-version :in-reply-to:content-type; q=dns; s=default; b=lkUUVimJpe0AnZGrY n7GlOZWg+EpD71hdVqyS3gEq/yrgfn5tXaoK72D0Uw9slkvD/lpipJumANEIS9XI WuXeiNvRDpev9dFIAkvdaIkWEKNN2r98Jbo3LHoIHNOoEj8P/JQ7BL9ebYSi7coJ m1O1q53+a+VTiQTQPQ/G3VDpnk= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender :subject:from:to:cc:references:message-id:date:mime-version :in-reply-to:content-type; s=default; bh=WB1YLegHd43g7GvG2pD0JSF 6IWk=; b=eg4Hts4y/d9lnEJihK2Z/HYiaNPhzb7ZusDWMou/37GJPYYCeMnFTyr HYHYc8+bk6YQQFo4tnX+Eal5lHOh+QNrL3rtZBospWjDTkj5xSzmBm6cG72ysO8w 1TmYnn/fmHUZ6IVrXaVuz8yDVwMuDI6CrNmLJa1XwQhFseaS7HzU= Received: (qmail 111061 invoked by alias); 8 Jul 2019 13:51:22 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Received: (qmail 111047 invoked by uid 89); 8 Jul 2019 13:51:21 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-21.0 required=5.0 tests=AWL, BAYES_00, GIT_PATCH_0, GIT_PATCH_1, GIT_PATCH_2, GIT_PATCH_3, KAM_COUK, RCVD_IN_DNSWL_NONE, SPF_HELO_PASS, SPF_PASS autolearn=ham version=3.3.1 spammy=H*r:4.84_2, UD:co.uk, determining, 13177 X-HELO: imap1.codethink.co.uk Received: from imap1.codethink.co.uk (HELO imap1.codethink.co.uk) (176.9.8.82) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Mon, 08 Jul 2019 13:51:17 +0000 Received: from [167.98.27.226] (helo=[10.35.6.54]) by imap1.codethink.co.uk with esmtpsa (Exim 4.84_2 #1 (Debian)) id 1hkU2y-0003zY-81; Mon, 08 Jul 2019 14:51:12 +0100 Subject: **ping** Re: [PATCH] Automatics in equivalence statements From: Mark Eggleston To: Jeff Law , Bernhard Reutner-Fischer , Steve Kargl Cc: fortran , gcc-patches References: <01b19cf0-7854-90a7-a2cd-14750dfcf543@codethink.co.uk> <20190621141011.GB49159@troutmask.apl.washington.edu> <20190624101930.7cf804b1@nbbrfq.loc> <1cd500c2-14b6-b758-710a-b95c75c746f9@redhat.com> <0cc2093c-29f5-1c6b-07c5-c2f931c20674@codethink.co.uk> <8d987cfc-b9ff-491c-3453-eb8d1d8f3936@codethink.co.uk> Message-ID: <6ccc2e78-f99a-b31b-62e9-fcdf3f1b286a@codethink.co.uk> Date: Mon, 8 Jul 2019 14:51:11 +0100 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:60.0) Gecko/20100101 Thunderbird/60.7.2 MIME-Version: 1.0 In-Reply-To: <8d987cfc-b9ff-491c-3453-eb8d1d8f3936@codethink.co.uk> **ping** On 01/07/2019 10:35, Mark Eggleston wrote: > > On 25/06/2019 14:17, Mark Eggleston wrote: >> >> On 25/06/2019 00:17, Jeff Law wrote: >>> On 6/24/19 2:19 AM, Bernhard Reutner-Fischer wrote: >>>> On Fri, 21 Jun 2019 07:10:11 -0700 >>>> Steve Kargl wrote: >>>> >>>>> On Fri, Jun 21, 2019 at 02:31:51PM +0100, Mark Eggleston wrote: >>>>>> Currently variables with the AUTOMATIC attribute can not appear >>>>>> in an >>>>>> EQUIVALENCE statement. However its counterpart, STATIC, can be >>>>>> used in >>>>>> an EQUIVALENCE statement. >>>>>> >>>>>> Where there is a clear conflict in the attributes of variables in an >>>>>> EQUIVALENCE statement an error message will be issued as is >>>>>> currently >>>>>> the case. >>>>>> >>>>>> If there is no conflict e.g. a variable with a AUTOMATIC >>>>>> attribute and a >>>>>> variable(s) without attributes all variables in the EQUIVALENCE will >>>>>> become AUTOMATIC. >>>>>> >>>>>> Note: most of this patch was written by Jeff Law >>>>>> >>>>>> Please review. >>>>>> >>>>>> ChangeLogs: >>>>>> >>>>>> gcc/fortran >>>>>> >>>>>>       Jeff Law  >>>>>>       Mark Eggleston >>>>>> >>>>>>       * gfortran.h: Add check_conflict declaration. >>>>> This is wrong.  By convention a routine that is not static >>>>> has the gfc_ prefix. > Updated the code to use gfc_check_conflict instead. >>>>> >>>> Furthermore doesn't this export indicate that you're committing a >>>> layering violation somehow? >>> Possibly.  I'm the original author, but my experience in our fortran >>> front-end is minimal.  I fully expected this patch to need some >>> tweaking. >>> >>> We certainly don't want to recreate all the checking that's done in >>> check_conflict.  We just need to defer it to a later point -- >>> find_equivalence seemed like a good point since we've got the full >>> equivalence list handy and can accumulate the attributes across the >>> entire list, then check for conflicts. >>> >>> If there's a concrete place where you think we should be doing this, >>> I'm >>> all ears. >>> >> Any suggestions will be appreciate. >>>>>       * symbol.c (check_conflict): Remove automatic in equivalence >>>>> conflict >>>>>       check. >>>>>       * symbol.c (save_symbol): Add check for in equivalence to >>>>> stop the >>>>>       the save attribute being added. >>>>>       * trans-common.c (build_equiv_decl): Add is_auto parameter and >>>>>       add !is_auto to condition where TREE_STATIC (decl) is set. >>>>>       * trans-common.c (build_equiv_decl): Add local variable >>>>> is_auto, >>>>>       set it true if an atomatic attribute is encountered in the >>>>> variable >>>> atomatic? I read atomic but you mean automatic. >>> Yes. >>> >>>>>       list.  Call build_equiv_decl with is_auto as an additional >>>>> parameter. >>>>>       flag_dec_format_defaults is enabled. >>>>>       * trans-common.c (accumulate_equivalence_attributes) : New >>>>> subroutine. >>>>>       * trans-common.c (find_equivalence) : New local variable >>>>> dummy_symbol, >>>>>       accumulated equivalence attributes from each symbol then >>>>> check for >>>>>       conflicts. >>>> I'm just curious why you don't gfc_copy_attr for the most part of >>>> accumulate_equivalence_attributes? >>>> thanks, >>> Simply didn't know about it.  It could probably significantly simplify >>> the accumulation of attributes step. >> Using gfc_copy_attr causes a great many "Duplicate DIMENSION >> attribute specified at (1)" errors. This is because there is a great >> deal of checking done instead of simply keeping track of the >> attributes used which is all that is required for determining whether >> there is a conflict in the equivalence statement. >> >> Also, the final section of accumulate_equivalence_attributes >> involving SAVE, INTENT and ACCESS look suspect to me. I'll check and >> update the patch if necessary. > > No need to check intent as there is already a conflict with DUMMY and > INTENT can only be present for dummy variables. > > Please find attached an updated patch. Change logs: > > gcc/fortran > >     Jeff Law  >     Mark Eggleston  > >     * gfortran.h: Add gfc_check_conflict declaration. >     * symbol.c (check_conflict): Rename cfg_check_conflict and remove >     static. >     * symbol.c (cfg_check_conflict): Remove automatic in equivalence >     conflict check. >     * symbol.c (save_symbol): Add check for in equivalence to stop the >     the save attribute being added. >     * trans-common.c (build_equiv_decl): Add is_auto parameter and >     add !is_auto to condition where TREE_STATIC (decl) is set. >     * trans-common.c (build_equiv_decl): Add local variable is_auto, >     set it true if an atomatic attribute is encountered in the variable >     list.  Call build_equiv_decl with is_auto as an additional parameter. >     flag_dec_format_defaults is enabled. >     * trans-common.c (accumulate_equivalence_attributes) : New > subroutine. >     * trans-common.c (find_equivalence) : New local variable > dummy_symbol, >     accumulated equivalence attributes from each symbol then check for >     conflicts. > > gcc/testsuite > >     Mark Eggleston > >     * gfortran.dg/auto_in_equiv_1.f90: New test. >     * gfortran.dg/auto_in_equiv_2.f90: New test. >     * gfortran.dg/auto_in_equiv_3.f90: New test. > > If the updated patch is acceptable, please can someone with the > privileges commit the patch. > > Mark > >> >>> Jeff >>> >>> >>> From 321c7c84f9578e99ac0a1fa5f3ed1fd78b328d1f Mon Sep 17 00:00:00 2001 From: Mark Eggleston Date: Tue, 11 Sep 2018 12:50:11 +0100 Subject: [PATCH 1/6] Allow automatics in equivalence If a variable with an automatic attribute appears in an equivalence statement the storage should be allocated on the stack. Note: most of this patch was provided by Jeff Law . --- gcc/fortran/gfortran.h | 1 + gcc/fortran/symbol.c | 102 +++++++++++++------------- gcc/fortran/trans-common.c | 73 ++++++++++++++++-- gcc/testsuite/gfortran.dg/auto_in_equiv_1.f90 | 36 +++++++++ gcc/testsuite/gfortran.dg/auto_in_equiv_2.f90 | 38 ++++++++++ gcc/testsuite/gfortran.dg/auto_in_equiv_3.f90 | 63 ++++++++++++++++ 6 files changed, 257 insertions(+), 56 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/auto_in_equiv_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/auto_in_equiv_2.f90 create mode 100644 gcc/testsuite/gfortran.dg/auto_in_equiv_3.f90 diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index b1f7bd0604a..573ae6c3bf3 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -2996,6 +2996,7 @@ bool gfc_merge_new_implicit (gfc_typespec *); void gfc_set_implicit_none (bool, bool, locus *); void gfc_check_function_type (gfc_namespace *); bool gfc_is_intrinsic_typename (const char *); +bool gfc_check_conflict (symbol_attribute *, const char *, locus *); gfc_typespec *gfc_get_default_type (const char *, gfc_namespace *); bool gfc_set_default_type (gfc_symbol *, int, gfc_namespace *); diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index f4273633db7..fbe563cd39a 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -407,8 +407,8 @@ gfc_check_function_type (gfc_namespace *ns) goto conflict_std;\ } -static bool -check_conflict (symbol_attribute *attr, const char *name, locus *where) +bool +gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) { static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER", *target = "TARGET", *external = "EXTERNAL", *intent = "INTENT", @@ -544,7 +544,6 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (allocatable, elemental); conf (in_common, automatic); - conf (in_equivalence, automatic); conf (result, automatic); conf (use_assoc, automatic); conf (dummy, automatic); @@ -1004,7 +1003,7 @@ gfc_add_attribute (symbol_attribute *attr, locus *where) if (check_used (attr, NULL, where)) return false; - return check_conflict (attr, NULL, where); + return gfc_check_conflict (attr, NULL, where); } @@ -1030,7 +1029,7 @@ gfc_add_allocatable (symbol_attribute *attr, locus *where) } attr->allocatable = 1; - return check_conflict (attr, NULL, where); + return gfc_check_conflict (attr, NULL, where); } @@ -1045,7 +1044,7 @@ gfc_add_automatic (symbol_attribute *attr, const char *name, locus *where) return false; attr->automatic = 1; - return check_conflict (attr, name, where); + return gfc_check_conflict (attr, name, where); } @@ -1071,7 +1070,7 @@ gfc_add_codimension (symbol_attribute *attr, const char *name, locus *where) } attr->codimension = 1; - return check_conflict (attr, name, where); + return gfc_check_conflict (attr, name, where); } @@ -1097,7 +1096,7 @@ gfc_add_dimension (symbol_attribute *attr, const char *name, locus *where) } attr->dimension = 1; - return check_conflict (attr, name, where); + return gfc_check_conflict (attr, name, where); } @@ -1109,7 +1108,7 @@ gfc_add_contiguous (symbol_attribute *attr, const char *name, locus *where) return false; attr->contiguous = 1; - return check_conflict (attr, name, where); + return gfc_check_conflict (attr, name, where); } @@ -1134,7 +1133,7 @@ gfc_add_external (symbol_attribute *attr, locus *where) attr->external = 1; - return check_conflict (attr, NULL, where); + return gfc_check_conflict (attr, NULL, where); } @@ -1153,7 +1152,7 @@ gfc_add_intrinsic (symbol_attribute *attr, locus *where) attr->intrinsic = 1; - return check_conflict (attr, NULL, where); + return gfc_check_conflict (attr, NULL, where); } @@ -1171,7 +1170,7 @@ gfc_add_optional (symbol_attribute *attr, locus *where) } attr->optional = 1; - return check_conflict (attr, NULL, where); + return gfc_check_conflict (attr, NULL, where); } bool @@ -1184,7 +1183,7 @@ gfc_add_kind (symbol_attribute *attr, locus *where) } attr->pdt_kind = 1; - return check_conflict (attr, NULL, where); + return gfc_check_conflict (attr, NULL, where); } bool @@ -1197,7 +1196,7 @@ gfc_add_len (symbol_attribute *attr, locus *where) } attr->pdt_len = 1; - return check_conflict (attr, NULL, where); + return gfc_check_conflict (attr, NULL, where); } @@ -1222,7 +1221,7 @@ gfc_add_pointer (symbol_attribute *attr, locus *where) else attr->pointer = 1; - return check_conflict (attr, NULL, where); + return gfc_check_conflict (attr, NULL, where); } @@ -1234,7 +1233,7 @@ gfc_add_cray_pointer (symbol_attribute *attr, locus *where) return false; attr->cray_pointer = 1; - return check_conflict (attr, NULL, where); + return gfc_check_conflict (attr, NULL, where); } @@ -1253,7 +1252,7 @@ gfc_add_cray_pointee (symbol_attribute *attr, locus *where) } attr->cray_pointee = 1; - return check_conflict (attr, NULL, where); + return gfc_check_conflict (attr, NULL, where); } @@ -1272,7 +1271,7 @@ gfc_add_protected (symbol_attribute *attr, const char *name, locus *where) } attr->is_protected = 1; - return check_conflict (attr, name, where); + return gfc_check_conflict (attr, name, where); } @@ -1284,7 +1283,7 @@ gfc_add_result (symbol_attribute *attr, const char *name, locus *where) return false; attr->result = 1; - return check_conflict (attr, name, where); + return gfc_check_conflict (attr, name, where); } @@ -1317,7 +1316,7 @@ gfc_add_save (symbol_attribute *attr, save_state s, const char *name, } attr->save = s; - return check_conflict (attr, name, where); + return gfc_check_conflict (attr, name, where); } @@ -1337,7 +1336,7 @@ gfc_add_value (symbol_attribute *attr, const char *name, locus *where) } attr->value = 1; - return check_conflict (attr, name, where); + return gfc_check_conflict (attr, name, where); } @@ -1370,7 +1369,7 @@ gfc_add_volatile (symbol_attribute *attr, const char *name, locus *where) attr->volatile_ = 1; attr->volatile_ns = gfc_current_ns; - return check_conflict (attr, name, where); + return gfc_check_conflict (attr, name, where); } @@ -1389,7 +1388,7 @@ gfc_add_asynchronous (symbol_attribute *attr, const char *name, locus *where) attr->asynchronous = 1; attr->asynchronous_ns = gfc_current_ns; - return check_conflict (attr, name, where); + return gfc_check_conflict (attr, name, where); } @@ -1407,7 +1406,7 @@ gfc_add_threadprivate (symbol_attribute *attr, const char *name, locus *where) } attr->threadprivate = 1; - return check_conflict (attr, name, where); + return gfc_check_conflict (attr, name, where); } @@ -1423,7 +1422,7 @@ gfc_add_omp_declare_target (symbol_attribute *attr, const char *name, return true; attr->omp_declare_target = 1; - return check_conflict (attr, name, where); + return gfc_check_conflict (attr, name, where); } @@ -1439,7 +1438,7 @@ gfc_add_omp_declare_target_link (symbol_attribute *attr, const char *name, return true; attr->omp_declare_target_link = 1; - return check_conflict (attr, name, where); + return gfc_check_conflict (attr, name, where); } @@ -1454,7 +1453,7 @@ gfc_add_oacc_declare_create (symbol_attribute *attr, const char *name, return true; attr->oacc_declare_create = 1; - return check_conflict (attr, name, where); + return gfc_check_conflict (attr, name, where); } @@ -1469,7 +1468,7 @@ gfc_add_oacc_declare_copyin (symbol_attribute *attr, const char *name, return true; attr->oacc_declare_copyin = 1; - return check_conflict (attr, name, where); + return gfc_check_conflict (attr, name, where); } @@ -1484,7 +1483,7 @@ gfc_add_oacc_declare_deviceptr (symbol_attribute *attr, const char *name, return true; attr->oacc_declare_deviceptr = 1; - return check_conflict (attr, name, where); + return gfc_check_conflict (attr, name, where); } @@ -1499,7 +1498,7 @@ gfc_add_oacc_declare_device_resident (symbol_attribute *attr, const char *name, return true; attr->oacc_declare_device_resident = 1; - return check_conflict (attr, name, where); + return gfc_check_conflict (attr, name, where); } @@ -1517,7 +1516,7 @@ gfc_add_target (symbol_attribute *attr, locus *where) } attr->target = 1; - return check_conflict (attr, NULL, where); + return gfc_check_conflict (attr, NULL, where); } @@ -1530,7 +1529,7 @@ gfc_add_dummy (symbol_attribute *attr, const char *name, locus *where) /* Duplicate dummy arguments are allowed due to ENTRY statements. */ attr->dummy = 1; - return check_conflict (attr, name, where); + return gfc_check_conflict (attr, name, where); } @@ -1543,7 +1542,7 @@ gfc_add_in_common (symbol_attribute *attr, const char *name, locus *where) /* Duplicate attribute already checked for. */ attr->in_common = 1; - return check_conflict (attr, name, where); + return gfc_check_conflict (attr, name, where); } @@ -1553,7 +1552,7 @@ gfc_add_in_equivalence (symbol_attribute *attr, const char *name, locus *where) /* Duplicate attribute already checked for. */ attr->in_equivalence = 1; - if (!check_conflict (attr, name, where)) + if (!gfc_check_conflict (attr, name, where)) return false; if (attr->flavor == FL_VARIABLE) @@ -1571,7 +1570,7 @@ gfc_add_data (symbol_attribute *attr, const char *name, locus *where) return false; attr->data = 1; - return check_conflict (attr, name, where); + return gfc_check_conflict (attr, name, where); } @@ -1580,7 +1579,7 @@ gfc_add_in_namelist (symbol_attribute *attr, const char *name, locus *where) { attr->in_namelist = 1; - return check_conflict (attr, name, where); + return gfc_check_conflict (attr, name, where); } @@ -1592,7 +1591,7 @@ gfc_add_sequence (symbol_attribute *attr, const char *name, locus *where) return false; attr->sequence = 1; - return check_conflict (attr, name, where); + return gfc_check_conflict (attr, name, where); } @@ -1610,7 +1609,7 @@ gfc_add_elemental (symbol_attribute *attr, locus *where) } attr->elemental = 1; - return check_conflict (attr, NULL, where); + return gfc_check_conflict (attr, NULL, where); } @@ -1628,7 +1627,7 @@ gfc_add_pure (symbol_attribute *attr, locus *where) } attr->pure = 1; - return check_conflict (attr, NULL, where); + return gfc_check_conflict (attr, NULL, where); } @@ -1646,7 +1645,7 @@ gfc_add_recursive (symbol_attribute *attr, locus *where) } attr->recursive = 1; - return check_conflict (attr, NULL, where); + return gfc_check_conflict (attr, NULL, where); } @@ -1664,7 +1663,7 @@ gfc_add_entry (symbol_attribute *attr, const char *name, locus *where) } attr->entry = 1; - return check_conflict (attr, name, where); + return gfc_check_conflict (attr, name, where); } @@ -1677,7 +1676,7 @@ gfc_add_function (symbol_attribute *attr, const char *name, locus *where) return false; attr->function = 1; - return check_conflict (attr, name, where); + return gfc_check_conflict (attr, name, where); } @@ -1696,7 +1695,7 @@ gfc_add_subroutine (symbol_attribute *attr, const char *name, locus *where) compiler-generated), do not check. See PR 84394. */ if (name && *name != '_' && gfc_current_state () != COMP_BLOCK_DATA) - return check_conflict (attr, name, where); + return gfc_check_conflict (attr, name, where); else return true; } @@ -1711,7 +1710,7 @@ gfc_add_generic (symbol_attribute *attr, const char *name, locus *where) return false; attr->generic = 1; - return check_conflict (attr, name, where); + return gfc_check_conflict (attr, name, where); } @@ -1734,7 +1733,7 @@ gfc_add_proc (symbol_attribute *attr, const char *name, locus *where) attr->procedure = 1; - return check_conflict (attr, NULL, where); + return gfc_check_conflict (attr, NULL, where); } @@ -1749,7 +1748,7 @@ gfc_add_abstract (symbol_attribute* attr, locus* where) attr->abstract = 1; - return check_conflict (attr, NULL, where); + return gfc_check_conflict (attr, NULL, where); } @@ -1795,7 +1794,7 @@ gfc_add_flavor (symbol_attribute *attr, sym_flavor f, const char *name, attr->flavor = f; - return check_conflict (attr, name, where); + return gfc_check_conflict (attr, name, where); } @@ -1842,7 +1841,7 @@ gfc_add_procedure (symbol_attribute *attr, procedure_type t, || attr->dimension)) return false; - return check_conflict (attr, name, where); + return gfc_check_conflict (attr, name, where); } @@ -1856,7 +1855,7 @@ gfc_add_intent (symbol_attribute *attr, sym_intent intent, locus *where) if (attr->intent == INTENT_UNKNOWN) { attr->intent = intent; - return check_conflict (attr, NULL, where); + return gfc_check_conflict (attr, NULL, where); } if (where == NULL) @@ -1881,7 +1880,7 @@ gfc_add_access (symbol_attribute *attr, gfc_access access, || (attr->use_assoc && attr->access != ACCESS_PRIVATE)) { attr->access = access; - return check_conflict (attr, name, where); + return gfc_check_conflict (attr, name, where); } if (where == NULL) @@ -1913,7 +1912,7 @@ gfc_add_is_bind_c (symbol_attribute *attr, const char *name, locus *where, if (!gfc_notify_std (GFC_STD_F2003, "BIND(C) at %L", where)) return false; - return check_conflict (attr, name, where); + return gfc_check_conflict (attr, name, where); } @@ -4244,6 +4243,7 @@ save_symbol (gfc_symbol *sym) return; if (sym->attr.in_common + || sym->attr.in_equivalence || sym->attr.dummy || sym->attr.result || sym->attr.flavor != FL_VARIABLE) diff --git a/gcc/fortran/trans-common.c b/gcc/fortran/trans-common.c index debdbd98ac0..775bbf91b2b 100644 --- a/gcc/fortran/trans-common.c +++ b/gcc/fortran/trans-common.c @@ -339,7 +339,7 @@ build_field (segment_info *h, tree union_type, record_layout_info rli) /* Get storage for local equivalence. */ static tree -build_equiv_decl (tree union_type, bool is_init, bool is_saved) +build_equiv_decl (tree union_type, bool is_init, bool is_saved, bool is_auto) { tree decl; char name[18]; @@ -359,8 +359,8 @@ build_equiv_decl (tree union_type, bool is_init, bool is_saved) DECL_ARTIFICIAL (decl) = 1; DECL_IGNORED_P (decl) = 1; - if (!gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl)) - || is_saved) + if (!is_auto && (!gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl)) + || is_saved)) TREE_STATIC (decl) = 1; TREE_ADDRESSABLE (decl) = 1; @@ -611,6 +611,7 @@ create_common (gfc_common_head *com, segment_info *head, bool saw_equiv) tree decl; bool is_init = false; bool is_saved = false; + bool is_auto = false; /* Declare the variables inside the common block. If the current common block contains any equivalence object, then @@ -654,6 +655,10 @@ create_common (gfc_common_head *com, segment_info *head, bool saw_equiv) /* Has SAVE attribute. */ if (s->sym->attr.save) is_saved = true; + + /* Has AUTOMATIC attribute. */ + if (s->sym->attr.automatic) + is_auto = true; } finish_record_layout (rli, true); @@ -661,7 +666,7 @@ create_common (gfc_common_head *com, segment_info *head, bool saw_equiv) if (com) decl = build_common_decl (com, union_type, is_init); else - decl = build_equiv_decl (union_type, is_init, is_saved); + decl = build_equiv_decl (union_type, is_init, is_saved, is_auto); if (is_init) { @@ -948,6 +953,59 @@ add_condition (segment_info *f, gfc_equiv *eq1, gfc_equiv *eq2) confirm_condition (f, eq1, n, eq2); } +static void +accumulate_equivalence_attributes (symbol_attribute *dummy_symbol, gfc_equiv *e) +{ + symbol_attribute attr = e->expr->symtree->n.sym->attr; + + dummy_symbol->dummy |= attr.dummy; + dummy_symbol->pointer |= attr.pointer; + dummy_symbol->target |= attr.target; + dummy_symbol->external |= attr.external; + dummy_symbol->intrinsic |= attr.intrinsic; + dummy_symbol->allocatable |= attr.allocatable; + dummy_symbol->elemental |= attr.elemental; + dummy_symbol->recursive |= attr.recursive; + dummy_symbol->in_common |= attr.in_common; + dummy_symbol->result |= attr.result; + dummy_symbol->in_namelist |= attr.in_namelist; + dummy_symbol->optional |= attr.optional; + dummy_symbol->entry |= attr.entry; + dummy_symbol->function |= attr.function; + dummy_symbol->subroutine |= attr.subroutine; + dummy_symbol->dimension |= attr.dimension; + dummy_symbol->in_equivalence |= attr.in_equivalence; + dummy_symbol->use_assoc |= attr.use_assoc; + dummy_symbol->cray_pointer |= attr.cray_pointer; + dummy_symbol->cray_pointee |= attr.cray_pointee; + dummy_symbol->data |= attr.data; + dummy_symbol->value |= attr.value; + dummy_symbol->volatile_ |= attr.volatile_; + dummy_symbol->is_protected |= attr.is_protected; + dummy_symbol->is_bind_c |= attr.is_bind_c; + dummy_symbol->procedure |= attr.procedure; + dummy_symbol->proc_pointer |= attr.proc_pointer; + dummy_symbol->abstract |= attr.abstract; + dummy_symbol->asynchronous |= attr.asynchronous; + dummy_symbol->codimension |= attr.codimension; + dummy_symbol->contiguous |= attr.contiguous; + dummy_symbol->generic |= attr.generic; + dummy_symbol->automatic |= attr.automatic; + dummy_symbol->threadprivate |= attr.threadprivate; + dummy_symbol->omp_declare_target |= attr.omp_declare_target; + dummy_symbol->omp_declare_target_link |= attr.omp_declare_target_link; + dummy_symbol->oacc_declare_copyin |= attr.oacc_declare_copyin; + dummy_symbol->oacc_declare_create |= attr.oacc_declare_create; + dummy_symbol->oacc_declare_deviceptr |= attr.oacc_declare_deviceptr; + dummy_symbol->oacc_declare_device_resident + |= attr.oacc_declare_device_resident; + + /* Not strictly correct, but probably close enough. */ + if (attr.save > dummy_symbol->save) + dummy_symbol->save = attr.save; + if (attr.access > dummy_symbol->access) + dummy_symbol->access = attr.access; +} /* Given a segment element, search through the equivalence lists for unused conditions that involve the symbol. Add these rules to the segment. */ @@ -965,9 +1023,12 @@ find_equivalence (segment_info *n) eq = NULL; /* Search the equivalence list, including the root (first) element - for the symbol that owns the segment. */ + for the symbol that owns the segment. */ + symbol_attribute dummy_symbol; + memset (&dummy_symbol, 0, sizeof (dummy_symbol)); for (e2 = e1; e2; e2 = e2->eq) { + accumulate_equivalence_attributes (&dummy_symbol, e2); if (!e2->used && e2->expr->symtree->n.sym == n->sym) { eq = e2; @@ -975,6 +1036,8 @@ find_equivalence (segment_info *n) } } + gfc_check_conflict (&dummy_symbol, e1->expr->symtree->name, &e1->expr->where); + /* Go to the next root element. */ if (eq == NULL) continue; diff --git a/gcc/testsuite/gfortran.dg/auto_in_equiv_1.f90 b/gcc/testsuite/gfortran.dg/auto_in_equiv_1.f90 new file mode 100644 index 00000000000..61bfd0738c5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/auto_in_equiv_1.f90 @@ -0,0 +1,36 @@ +! { dg-compile } + +! Contributed by Mark Eggleston +program test + call suba(0) + call subb(0) + call suba(1) + +contains + subroutine suba(option) + integer, intent(in) :: option + integer, automatic :: a ! { dg-error "AUTOMATIC at \\(1\\) is a DEC extension" } + integer :: b + integer :: c + equivalence (a, b) + if (option.eq.0) then + ! initialise a and c + a = 9 + c = 99 + if (a.ne.b) stop 1 + if (loc(a).ne.loc(b)) stop 2 + else + ! a should've been overwritten + if (a.eq.9) stop 3 + end if + end subroutine suba + + subroutine subb(dummy) + integer, intent(in) :: dummy + integer, automatic :: x ! { dg-error "AUTOMATIC at \\(1\\) is a DEC extension" } + integer :: y + x = 77 + y = 7 + end subroutine subb + +end program test diff --git a/gcc/testsuite/gfortran.dg/auto_in_equiv_2.f90 b/gcc/testsuite/gfortran.dg/auto_in_equiv_2.f90 new file mode 100644 index 00000000000..406e718604a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/auto_in_equiv_2.f90 @@ -0,0 +1,38 @@ +! { dg-run } +! { dg-options "-fdec-static" } + +! Contributed by Mark Eggleston + +program test + call suba(0) + call subb(0) + call suba(1) + +contains + subroutine suba(option) + integer, intent(in) :: option + integer, automatic :: a + integer :: b + integer :: c + equivalence (a, b) + if (option.eq.0) then + ! initialise a and c + a = 9 + c = 99 + if (a.ne.b) stop 1 + if (loc(a).ne.loc(b)) stop 2 + else + ! a should've been overwritten + if (a.eq.9) stop 3 + end if + end subroutine suba + + subroutine subb(dummy) + integer, intent(in) :: dummy + integer, automatic :: x + integer :: y + x = 77 + y = 7 + end subroutine subb + +end program test diff --git a/gcc/testsuite/gfortran.dg/auto_in_equiv_3.f90 b/gcc/testsuite/gfortran.dg/auto_in_equiv_3.f90 new file mode 100644 index 00000000000..c67aa8c6ac1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/auto_in_equiv_3.f90 @@ -0,0 +1,63 @@ +! { dg-run } +! { dg-options "-fdec-static -fno-automatic" } + +! Contributed by Mark Eggleston + +! Storage is NOT on the static unless explicitly specified using the +! DEC extension "automatic". The address of the first local variable +! is used to determine that storage for the automatic local variable +! is different to that of a local variable with no attributes. The +! contents of the local variable in suba should be overwritten by the +! call to subb. +! +program test + integer :: dummy + integer, parameter :: address = kind(loc(dummy)) + integer(address) :: ad1 + integer(address) :: ad2 + integer(address) :: ad3 + logical :: ok + + call suba(0, ad1) + call subb(0, ad2) + call suba(1, ad1) + call subc(0, ad3) + ok = (ad1.eq.ad3).and.(ad1.ne.ad2) + if (.not.ok) stop 4 + +contains + subroutine suba(option, addr) + integer, intent(in) :: option + integer(address), intent(out) :: addr + integer, automatic :: a + integer :: b + equivalence (a, b) + addr = loc(a) + if (option.eq.0) then + ! initialise a and c + a = 9 + if (a.ne.b) stop 1 + if (loc(a).ne.loc(b)) stop 2 + else + ! a should've been overwritten + if (a.eq.9) stop 3 + end if + end subroutine suba + + subroutine subb(dummy, addr) + integer, intent(in) :: dummy + integer(address), intent(out) :: addr + integer :: x + addr = loc(x) + x = 77 + end subroutine subb + + subroutine subc(dummy, addr) + integer, intent(in) :: dummy + integer(address), intent(out) :: addr + integer, automatic :: y + addr = loc(y) + y = 77 + end subroutine subc + +end program test -- 2.11.0