From patchwork Thu Jun 20 08:53:06 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: =?utf-8?q?Marc_Poulhi=C3=A8s?= X-Patchwork-Id: 1950011 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=adacore.com header.i=@adacore.com header.a=rsa-sha256 header.s=google header.b=UNb9QHEf; dkim-atps=neutral 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=server2.sourceware.org; envelope-from=gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.sourceware.org (server2.sourceware.org [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 (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4W4ZWF3Fyvz20X8 for ; Thu, 20 Jun 2024 19:12:09 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 1B66C3891C13 for ; Thu, 20 Jun 2024 09:12:07 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wr1-x434.google.com (mail-wr1-x434.google.com [IPv6:2a00:1450:4864:20::434]) by sourceware.org (Postfix) with ESMTPS id E085D3889831 for ; Thu, 20 Jun 2024 08:53:44 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org E085D3889831 Authentication-Results: sourceware.org; dmarc=pass (p=quarantine dis=none) header.from=adacore.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=adacore.com ARC-Filter: OpenARC Filter v1.0.0 sourceware.org E085D3889831 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::434 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1718873638; cv=none; b=GiiH9PGZhEHnfXB4VuvsznTUlrMahCQN9ckf8xFPiY9fWch6xlSOpH5pk3qebNMgDjZUO+lfXGcc6N4OkWzEZtGX95HeNuZF1+JRvOoOoyf+gCwSkFvOx+uBoTWgWn3x4+xRKTKZccJTU4F6aMGzeCkHFczZVvdsJJso/WnEF1M= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1718873638; c=relaxed/simple; bh=ltn8Fz7bDCgRuyOsm7xMPqBu1PWaFSJJfVm5kmvEbSg=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=erUyw0x7gqGsbNg3FJDXpzXLcDJSXbH5tR54dAD7vavft6uo+DJoGF31HWlbjtqbMRO5b78e4A1N8+47k1QyxdUJ5zxp0UxCEyhRuBJOE4Z+qXDSLSxynYCtlr0vOIdOevxFq8LScnkJ1J2Zw+zpi7F8b5zRUV49b20VNMAWx8I= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wr1-x434.google.com with SMTP id ffacd0b85a97d-363826fbcdeso535153f8f.0 for ; Thu, 20 Jun 2024 01:53:44 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1718873623; x=1719478423; darn=gcc.gnu.org; h=content-transfer-encoding:mime-version:references:in-reply-to :message-id:date:subject:cc:to:from:from:to:cc:subject:date :message-id:reply-to; bh=oOvWLKCzCNWmLFwye6dOLYScV3mZ04wvPSN/OkN+VnU=; b=UNb9QHEfZ40M7kwx/EJCprybpsRaeBhBYhLSQGXU3tRhhf+pXCIMKXFeG9UsfKk/wl Srr9BYz2/PMDj4fcpeHmiod/S7wu7QkyJbujaeCh9uiMJzL/7CDXlPCOCuyCZ0MsVC7v zXQZ7vFJFIGnGI/0yjvjKPx0jfl6ZwfSyviWaa6+xtBpk//Fa90Qd5yycedeO8h8WYBj zEoLXlikClWvBd35izQ1R8fgKm+KyXxQiHSfwjTKtbt6qhQo9SiuphFYi6k8J6PtXgSF eoSBa7ki/8Evyr/nRTCc0iH3+tFjY0aujkogpMMZdfarCydQLXEe1SPOCHASMxOtApc4 zDcg== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1718873623; x=1719478423; h=content-transfer-encoding:mime-version:references:in-reply-to :message-id:date:subject:cc:to:from:x-gm-message-state:from:to:cc :subject:date:message-id:reply-to; bh=oOvWLKCzCNWmLFwye6dOLYScV3mZ04wvPSN/OkN+VnU=; b=OYJEJ3JaFtvERRm/Kk7GE6sAjQvCYKAoRLLCxu/hdx1ds9/WaDd7ZpDGibsKE0JNsv 8iHRzlJCo5Mj/YDZz29M5NgCsGmTeXHZwLry7xt53DhTWwHgqW6nZ1vVzO3pci9bVnR7 h/EmywJ/vZBxTSQknHd/LbWPWGUHXU5qTiRJLgRjSPM2GnvEsDMkBjKYnfAojqaI6p5x cx79txMt4+YVLeZ4amsP4VjqVBN7FMQ0n12AxxnFbaJZ0S3mVuyJTCxtHQW9YnFDAwRo IUbKIO5ET7hFHGFt+yp2jDVqKMbkllLJUHD6h1RjB9YTd+1B+4iJdx5lz8G/iPg4dsp4 Hopg== X-Gm-Message-State: AOJu0Yz7sYg0XM94O0G+pX0Om8/Z598HTlcnYxVTEP07pjvCfbQwp7/l +ANj0WedFkBJqpiMZ1A4tbz3A/UvuRkTQuEx786GGvapozol+X5TSprJKhbNWmSdSv3UqulyQzA = X-Google-Smtp-Source: AGHT+IE0HsEXLxB/lqmza4MS372BVD52jejXYnQGqa34KZEN8953JBNoU9VLeEuxlgKj2Uad8QJeow== X-Received: by 2002:adf:a3ca:0:b0:362:ebf5:3fd with SMTP id ffacd0b85a97d-36317b786e4mr3208585f8f.30.1718873623656; Thu, 20 Jun 2024 01:53:43 -0700 (PDT) Received: from poulhies-Precision-5550.telnowedge.local (lmontsouris-659-1-24-67.w81-250.abo.wanadoo.fr. [81.250.175.67]) by smtp.gmail.com with ESMTPSA id ffacd0b85a97d-363c795febfsm3305522f8f.104.2024.06.20.01.53.42 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Thu, 20 Jun 2024 01:53:43 -0700 (PDT) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Eric Botcazou Subject: [COMMITTED 16/30] ada: Streamline propagation of controlled flags on types Date: Thu, 20 Jun 2024 10:53:06 +0200 Message-ID: <20240620085321.2412421-16-poulhies@adacore.com> X-Mailer: git-send-email 2.45.1 In-Reply-To: <20240620085321.2412421-1-poulhies@adacore.com> References: <20240620085321.2412421-1-poulhies@adacore.com> MIME-Version: 1.0 X-Spam-Status: No, score=-13.3 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, GIT_PATCH_0, KAM_ASCII_DIVIDERS, RCVD_IN_DNSWL_NONE, SPF_HELO_NONE, SPF_PASS, TXREP, T_SCC_BODY_TEXT_LINE 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.30 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org From: Eric Botcazou The front-end maintains a set of 4 flags on (base) types that are used to parameterize the implementation of controlled operations, and these flags need to be propagated through composition and derivation. This is done on a per-flag basis in the current implementation with a few loopholes. This introduces a Propagate_Controlled_Flags routine to that effect, which is modeled on the existing Propagate_Concurrent_Flags routine, and is used in most cases to do the propagation. This also removes the handling of the Finalize_Storage_Only flag from Inherit_Aspects_At_Freeze_Point, since the associated aspect does not exist (only the pragma does). gcc/ada/ * freeze.adb (Freeze_Array_Type): Call Propagate_Controlled_Flags to propagate the controlled flags from the component to the array. (Freeze_Record_Type): Propagate the Finalize_Storage_Only flag from the components to the record. * sem_ch3.adb (Analyze_Private_Extension_Declaration): Do not call Propagate_Concurrent_Flags here but... (Array_Type_Declaration): Tidy and call Propagate_Controlled_Flags to propagate the controlled flags from the component to the array. (Build_Derived_Private_Type): Do not propagate the controlled flags manually here but... (Build_Derived_Record_Type): ...call Propagate_Controlled_Flags to propagate the controlled flags from parent to derived type. (Build_Derived_Type): Likewise. (Copy_Array_Base_Type_Attributes): Call Propagate_Controlled_Flags to copy the controlled flags. (Record_Type_Definition): Streamline the propagation of the Finalize_Storage_Only flag from the components to the record. * sem_ch7.adb (Preserve_Full_Attributes): Use Full_Base and call Propagate_Controlled_Flags to copy the controlled flags. * sem_ch9.adb (Analyze_Protected_Definition): Use canonical idiom to compute Has_Controlled_Component. (Analyze_Protected_Type_Declaration): Minor tweak. * sem_ch13.adb (Inherit_Aspects_At_Freeze_Point): Do not deal with Finalize_Storage_Only here. * sem_util.ads (Propagate_Controlled_Flags): New declaration. * sem_util.adb (Propagate_Controlled_Flags): New procedure. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/freeze.adb | 22 ++++++--- gcc/ada/sem_ch13.adb | 7 --- gcc/ada/sem_ch3.adb | 108 +++++++++++++------------------------------ gcc/ada/sem_ch7.adb | 11 ++--- gcc/ada/sem_ch9.adb | 7 +-- gcc/ada/sem_util.adb | 48 +++++++++++++++++++ gcc/ada/sem_util.ads | 11 +++++ 7 files changed, 113 insertions(+), 101 deletions(-) diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 2a0a59f5b03..d0dd1de087d 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -3661,12 +3661,7 @@ package body Freeze is -- Propagate flags from component type Propagate_Concurrent_Flags (Arr, Ctyp); - - if Is_Controlled (Ctyp) - or else Has_Controlled_Component (Ctyp) - then - Set_Has_Controlled_Component (Arr); - end if; + Propagate_Controlled_Flags (Arr, Ctyp, Comp => True); if Has_Unchecked_Union (Ctyp) then Set_Has_Unchecked_Union (Arr); @@ -5083,6 +5078,9 @@ package body Freeze is -- Accumulates total Esize values of all elementary components. Used -- for processing of Implicit_Packing. + Final_Storage_Only : Boolean := True; + -- Used to compute the Finalize_Storage_Only flag + Placed_Component : Boolean := False; -- Set True if we find at least one component with a component -- clause (used to warn about useless Bit_Order pragmas, and also @@ -5708,6 +5706,9 @@ package body Freeze is (Corresponding_Record_Type (Etype (Comp))))) then Set_Has_Controlled_Component (Rec); + Final_Storage_Only := + Final_Storage_Only + and then Finalize_Storage_Only (Etype (Comp)); end if; if Has_Unchecked_Union (Etype (Comp)) then @@ -5739,6 +5740,15 @@ package body Freeze is Next_Component (Comp); end loop; + + -- For a type that is not directly controlled but has controlled + -- components, Finalize_Storage_Only is set if all the controlled + -- components are Finalize_Storage_Only. + + if not Is_Controlled (Rec) and then Has_Controlled_Component (Rec) + then + Set_Finalize_Storage_Only (Rec, Final_Storage_Only); + end if; end if; -- Enforce the restriction that access attributes with a current diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index d81b7412313..4012932a6f2 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -14097,13 +14097,6 @@ package body Sem_Ch13 is Set_Has_Volatile_Components (Imp_Bas_Typ); end if; - -- Finalize_Storage_Only - - Rep := Get_Inherited_Rep_Item (Typ, Name_Finalize_Storage_Only); - if Present (Rep) then - Set_Finalize_Storage_Only (Bas_Typ); - end if; - -- Universal_Aliasing Rep := Get_Inherited_Rep_Item (Typ, Name_Universal_Aliasing); diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 76e5cdcbf5d..0e951c1b6b8 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -5485,10 +5485,7 @@ package body Sem_Ch3 is Reinit_Size_Align (T); Set_Default_SSO (T); Set_No_Reordering (T, No_Component_Reordering); - - Set_Etype (T, Parent_Base); - Propagate_Concurrent_Flags (T, Parent_Base); - + Set_Etype (T, Parent_Base); Set_Convention (T, Convention (Parent_Type)); Set_First_Rep_Item (T, First_Rep_Item (Parent_Type)); Set_Is_First_Subtype (T); @@ -6567,14 +6564,16 @@ package body Sem_Ch3 is end if; if Nkind (Def) = N_Constrained_Array_Definition then + Index := First (Discrete_Subtype_Definitions (Def)); + -- Establish Implicit_Base as unconstrained base type Implicit_Base := Create_Itype (E_Array_Type, P, Related_Id, 'B'); Set_Etype (Implicit_Base, Implicit_Base); Set_Scope (Implicit_Base, Current_Scope); + Set_First_Index (Implicit_Base, Index); Set_Has_Delayed_Freeze (Implicit_Base); - Set_Default_SSO (Implicit_Base); -- The constrained array type is a subtype of the unconstrained one @@ -6582,27 +6581,9 @@ package body Sem_Ch3 is Reinit_Size_Align (T); Set_Etype (T, Implicit_Base); Set_Scope (T, Current_Scope); - Set_Is_Constrained (T); - Set_First_Index (T, - First (Discrete_Subtype_Definitions (Def))); + Set_First_Index (T, Index); Set_Has_Delayed_Freeze (T); - - -- Complete setup of implicit base type - - pragma Assert (not Known_Component_Size (Implicit_Base)); - Set_Component_Type (Implicit_Base, Element_Type); - Set_Finalize_Storage_Only - (Implicit_Base, - Finalize_Storage_Only (Element_Type)); - Set_First_Index (Implicit_Base, First_Index (T)); - Set_Has_Controlled_Component - (Implicit_Base, - Has_Controlled_Component (Element_Type) - or else Is_Controlled (Element_Type)); - Set_Packed_Array_Impl_Type - (Implicit_Base, Empty); - - Propagate_Concurrent_Flags (Implicit_Base, Element_Type); + Set_Is_Constrained (T); -- Unconstrained array case @@ -6611,26 +6592,15 @@ package body Sem_Ch3 is Reinit_Size_Align (T); Set_Etype (T, T); Set_Scope (T, Current_Scope); - pragma Assert (not Known_Component_Size (T)); - Set_Is_Constrained (T, False); + Set_First_Index (T, First (Subtype_Marks (Def))); + Set_Has_Delayed_Freeze (T); Set_Is_Fixed_Lower_Bound_Array_Subtype (T, Has_FLB_Index); - Set_First_Index (T, First (Subtype_Marks (Def))); - Set_Has_Delayed_Freeze (T, True); - Propagate_Concurrent_Flags (T, Element_Type); - Set_Has_Controlled_Component (T, Has_Controlled_Component - (Element_Type) - or else - Is_Controlled (Element_Type)); - Set_Finalize_Storage_Only (T, Finalize_Storage_Only - (Element_Type)); - Set_Default_SSO (T); end if; -- Common attributes for both cases - Set_Component_Type (Base_Type (T), Element_Type); - Set_Packed_Array_Impl_Type (T, Empty); + Set_Component_Type (Etype (T), Element_Type); if Aliased_Present (Component_Definition (Def)) then Set_Has_Aliased_Components (Etype (T)); @@ -6641,6 +6611,13 @@ package body Sem_Ch3 is Set_Has_Independent_Components (Etype (T)); end if; + pragma Assert (not Known_Component_Size (Etype (T))); + + Propagate_Concurrent_Flags (Etype (T), Element_Type); + Propagate_Controlled_Flags (Etype (T), Element_Type, Comp => True); + + Set_Default_SSO (Etype (T)); + -- Ada 2005 (AI-231): Propagate the null-excluding attribute to the -- array type to ensure that objects of this type are initialized. @@ -8516,22 +8493,6 @@ package body Sem_Ch3 is Set_Stored_Constraint (Derived_Type, No_Elist); Set_Is_Constrained (Derived_Type, Is_Constrained (Parent_Type)); - Set_Is_Controlled_Active - (Derived_Type, Is_Controlled_Active (Parent_Type)); - - Set_Disable_Controlled - (Derived_Type, Disable_Controlled (Parent_Type)); - - Set_Has_Controlled_Component - (Derived_Type, Has_Controlled_Component (Parent_Type)); - - -- Direct controlled types do not inherit Finalize_Storage_Only flag - - if not Is_Controlled (Parent_Type) then - Set_Finalize_Storage_Only - (Base_Type (Derived_Type), Finalize_Storage_Only (Parent_Type)); - end if; - -- If this is not a completion, construct the implicit full view by -- deriving from the full view of the parent type. But if this is a -- completion, the derived private type being built is a full view @@ -9848,8 +9809,9 @@ package body Sem_Ch3 is -- Fields inherited from the Parent_Base - Set_Has_Controlled_Component - (Derived_Type, Has_Controlled_Component (Parent_Base)); + Propagate_Concurrent_Flags (Derived_Type, Parent_Base); + Propagate_Controlled_Flags (Derived_Type, Parent_Base, Deriv => True); + Set_Has_Non_Standard_Rep (Derived_Type, Has_Non_Standard_Rep (Parent_Base)); Set_Has_Primitive_Operations @@ -9914,9 +9876,6 @@ package body Sem_Ch3 is and then Scope (Scope (Scope (Derived_Type))) = Standard_Standard then Set_Is_Controlled_Active (Derived_Type); - else - Set_Is_Controlled_Active - (Derived_Type, Is_Controlled_Active (Parent_Base)); end if; -- Minor optimization: there is no need to generate the class-wide @@ -10194,17 +10153,15 @@ package body Sem_Ch3 is Set_Scope (Derived_Type, Current_Scope); Set_Etype (Derived_Type, Parent_Base); Mutate_Ekind (Derived_Type, Ekind (Parent_Base)); - Propagate_Concurrent_Flags (Derived_Type, Parent_Base); + + Propagate_Concurrent_Flags (Derived_Type, Parent_Base); + Propagate_Controlled_Flags (Derived_Type, Parent_Base, Deriv => True); Set_Size_Info (Derived_Type, Parent_Type); Copy_RM_Size (To => Derived_Type, From => Parent_Type); - Set_Is_Controlled_Active - (Derived_Type, Is_Controlled_Active (Parent_Type)); - - Set_Disable_Controlled (Derived_Type, Disable_Controlled (Parent_Type)); - Set_Is_Tagged_Type (Derived_Type, Is_Tagged_Type (Parent_Type)); - Set_Is_Volatile (Derived_Type, Is_Volatile (Parent_Type)); + Set_Is_Tagged_Type (Derived_Type, Is_Tagged_Type (Parent_Type)); + Set_Is_Volatile (Derived_Type, Is_Volatile (Parent_Type)); if Is_Tagged_Type (Derived_Type) then Set_No_Tagged_Streams_Pragma @@ -15272,9 +15229,9 @@ package body Sem_Ch3 is Set_Component_Alignment (T1, Component_Alignment (T2)); Set_Component_Type (T1, Component_Type (T2)); Set_Component_Size (T1, Component_Size (T2)); - Set_Has_Controlled_Component (T1, Has_Controlled_Component (T2)); Set_Has_Non_Standard_Rep (T1, Has_Non_Standard_Rep (T2)); Propagate_Concurrent_Flags (T1, T2); + Propagate_Controlled_Flags (T1, T2); Set_Is_Packed (T1, Is_Packed (T2)); Set_Has_Aliased_Components (T1, Has_Aliased_Components (T2)); Set_Has_Atomic_Components (T1, Has_Atomic_Components (T2)); @@ -22950,8 +22907,7 @@ package body Sem_Ch3 is procedure Record_Type_Definition (Def : Node_Id; Prev_T : Entity_Id) is Component : Entity_Id; - Ctrl_Components : Boolean := False; - Final_Storage_Only : Boolean; + Final_Storage_Only : Boolean := True; T : Entity_Id; begin @@ -22963,8 +22919,6 @@ package body Sem_Ch3 is Set_Is_Not_Self_Hidden (T); - Final_Storage_Only := not Is_Controlled (T); - -- Ada 2005: Check whether an explicit "limited" is present in a derived -- type declaration. @@ -23020,20 +22974,20 @@ package body Sem_Ch3 is or else (Chars (Component) /= Name_uParent and then Is_Controlled (Etype (Component)))) then - Set_Has_Controlled_Component (T, True); + Set_Has_Controlled_Component (T); Final_Storage_Only := Final_Storage_Only and then Finalize_Storage_Only (Etype (Component)); - Ctrl_Components := True; end if; Next_Entity (Component); end loop; - -- A Type is Finalize_Storage_Only only if all its controlled components - -- are also. + -- For a type that is not directly controlled but has controlled + -- components, Finalize_Storage_Only is set if all the controlled + -- components are Finalize_Storage_Only. - if Ctrl_Components then + if not Is_Controlled (T) and then Has_Controlled_Component (T) then Set_Finalize_Storage_Only (T, Final_Storage_Only); end if; diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 0f0fc90ad6b..28031b5dbc2 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -2919,6 +2919,7 @@ package body Sem_Ch7 is (Priv, Has_Pragma_Unreferenced_Objects (Full)); Set_Predicates_Ignored (Priv, Predicates_Ignored (Full)); + if Is_Unchecked_Union (Full) then Set_Is_Unchecked_Union (Base_Type (Priv)); end if; @@ -2928,14 +2929,8 @@ package body Sem_Ch7 is end if; if Priv_Is_Base_Type then - Set_Is_Controlled_Active - (Priv, Is_Controlled_Active (Full_Base)); - Set_Finalize_Storage_Only - (Priv, Finalize_Storage_Only (Full_Base)); - Set_Has_Controlled_Component - (Priv, Has_Controlled_Component (Full_Base)); - - Propagate_Concurrent_Flags (Priv, Base_Type (Full)); + Propagate_Concurrent_Flags (Priv, Full_Base); + Propagate_Controlled_Flags (Priv, Full_Base); end if; -- As explained in Freeze_Entity, private types are required to point diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index 5172b62f2fc..391cbeb02a9 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -2011,8 +2011,9 @@ package body Sem_Ch9 is else Propagate_Concurrent_Flags (Prot_Typ, Etype (Item_Id)); - if Chars (Item_Id) /= Name_uParent - and then Needs_Finalization (Etype (Item_Id)) + if Has_Controlled_Component (Etype (Item_Id)) + or else (Chars (Item_Id) /= Name_uParent + and then Is_Controlled (Etype (Item_Id))) then Set_Has_Controlled_Component (Prot_Typ); end if; @@ -2167,7 +2168,7 @@ package body Sem_Ch9 is or else Has_Interrupt_Handler (T) or else Has_Attach_Handler (T)) then - Set_Has_Controlled_Component (T, True); + Set_Has_Controlled_Component (T); end if; -- The Ekind of components is E_Void during analysis for historical diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 7f5d70245dd..8425359e052 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -26238,6 +26238,54 @@ package body Sem_Util is end if; end Propagate_Concurrent_Flags; + -------------------------------- + -- Propagate_Controlled_Flags -- + -------------------------------- + + procedure Propagate_Controlled_Flags + (Typ : Entity_Id; + From_Typ : Entity_Id; + Comp : Boolean := False; + Deriv : Boolean := False) + is + begin + -- It does not make sense to have both Comp and Deriv set True + + pragma Assert (not Comp or else not Deriv); + + -- This implementation only supports array types for the component case. + -- Disregard Is_Controlled_Active and Disable_Controlled in this case. + + if Comp then + pragma Assert (Is_Array_Type (Typ)); + + else + if Is_Controlled_Active (From_Typ) then + Set_Is_Controlled_Active (Typ); + end if; + + if Disable_Controlled (From_Typ) then + Set_Disable_Controlled (Typ); + end if; + end if; + + -- Direct controlled types do not inherit Finalize_Storage_Only + + if not (Deriv and then Is_Controlled (From_Typ)) then + if Finalize_Storage_Only (From_Typ) then + Set_Finalize_Storage_Only (Typ); + end if; + end if; + + -- Is_Controlled yields Has_Controlled_Component for component + + if Has_Controlled_Component (From_Typ) + or else (Comp and then Is_Controlled (From_Typ)) + then + Set_Has_Controlled_Component (Typ); + end if; + end Propagate_Controlled_Flags; + ------------------------------ -- Propagate_DIC_Attributes -- ------------------------------ diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index bda295f0a7f..7363ad96bd8 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -2914,6 +2914,17 @@ package Sem_Util is -- by one of these flags. This procedure can only set flags for Typ, and -- never clear them. Comp_Typ is the type of a component or a parent. + procedure Propagate_Controlled_Flags + (Typ : Entity_Id; + From_Typ : Entity_Id; + Comp : Boolean := False; + Deriv : Boolean := False); + -- Set Disable_Controlled, Finalize_Storage_Only, Has_Controlled_Component, + -- and Is_Controlled_Active on Typ when the flags are set on From_Typ. If + -- Comp is True, From_Typ is the type of a component of Typ while, if Deriv + -- is True, From_Typ is the parent type of Typ. This procedure can only set + -- flags for Typ, and never clear them. + procedure Propagate_DIC_Attributes (Typ : Entity_Id; From_Typ : Entity_Id);