ada: Streamline propagation of controlled flags on types

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.

diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index 2a0a59f5b0303cda6438dba9b601ed1223b5ea2e..d0dd1de087d83ff58b55dee8fc88b274b2de41e5 100644 (file)
--- 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 d81b741231302d8724e95abd07f722e830e430c9..4012932a6f21fb294351a621cb82ccb31155e095 100644 (file)
--- 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 76e5cdcbf5d0220415a4d5e78efb60dae0ba93d2..0e951c1b6b876a83f634f93a8638261c62729d3a 100644 (file)
--- 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 0f0fc90ad6b735b3e3691188b1bb82fd4414dc94..28031b5dbc27eb02011070eec267b127f0a09cd1 100644 (file)
--- 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 5172b62f2fcff3cae60fae8d6c0024bf04ab41ad..391cbeb02a93b5c5b7dc90fe78227b15a156b85d 100644 (file)
--- 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 7f5d70245dd9ad05026486756fd5ff85705cf6e9..8425359e052fba3e556a037c1577936cb0a5f034 100644 (file)
--- 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 bda295f0a7f8dc2dffb36f558e635888a2b94124..7363ad96bd87a1f2c9720b586cfad7dfb300fcaf 100644 (file)
--- 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);