From: Eric Botcazou <ebotca...@adacore.com>
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);
--
2.45.1
