@@ -10554,94 +10554,6 @@ package body Exp_Util is
end if;
end Needs_Constant_Address;
- ------------------------
- -- Needs_Finalization --
- ------------------------
-
- function Needs_Finalization (Typ : Entity_Id) return Boolean is
- function Has_Some_Controlled_Component
- (Input_Typ : Entity_Id) return Boolean;
- -- Determine whether type Input_Typ has at least one controlled
- -- component.
-
- -----------------------------------
- -- Has_Some_Controlled_Component --
- -----------------------------------
-
- function Has_Some_Controlled_Component
- (Input_Typ : Entity_Id) return Boolean
- is
- Comp : Entity_Id;
-
- begin
- -- When a type is already frozen and has at least one controlled
- -- component, or is manually decorated, it is sufficient to inspect
- -- flag Has_Controlled_Component.
-
- if Has_Controlled_Component (Input_Typ) then
- return True;
-
- -- Otherwise inspect the internals of the type
-
- elsif not Is_Frozen (Input_Typ) then
- if Is_Array_Type (Input_Typ) then
- return Needs_Finalization (Component_Type (Input_Typ));
-
- elsif Is_Record_Type (Input_Typ) then
- Comp := First_Component (Input_Typ);
- while Present (Comp) loop
- if Needs_Finalization (Etype (Comp)) then
- return True;
- end if;
-
- Next_Component (Comp);
- end loop;
- end if;
- end if;
-
- return False;
- end Has_Some_Controlled_Component;
-
- -- Start of processing for Needs_Finalization
-
- begin
- -- Certain run-time configurations and targets do not provide support
- -- for controlled types.
-
- if Restriction_Active (No_Finalization) then
- return False;
-
- -- C++ types are not considered controlled. It is assumed that the non-
- -- Ada side will handle their clean up.
-
- elsif Convention (Typ) = Convention_CPP then
- return False;
-
- -- Class-wide types are treated as controlled because derivations from
- -- the root type may introduce controlled components.
-
- elsif Is_Class_Wide_Type (Typ) then
- return True;
-
- -- Concurrent types are controlled as long as their corresponding record
- -- is controlled.
-
- elsif Is_Concurrent_Type (Typ)
- and then Present (Corresponding_Record_Type (Typ))
- and then Needs_Finalization (Corresponding_Record_Type (Typ))
- then
- return True;
-
- -- Otherwise the type is controlled when it is either derived from type
- -- [Limited_]Controlled and not subject to aspect Disable_Controlled, or
- -- contains at least one controlled component.
-
- else
- return
- Is_Controlled (Typ) or else Has_Some_Controlled_Component (Typ);
- end if;
- end Needs_Finalization;
-
----------------------------
-- New_Class_Wide_Subtype --
----------------------------
@@ -12170,9 +12082,7 @@ package body Exp_Util is
Typ : Entity_Id;
begin
- if No (L)
- or else Is_Empty_List (L)
- then
+ if No (L) or else Is_Empty_List (L) then
return False;
end if;
@@ -944,10 +944,6 @@ package Exp_Util is
-- consist of constants, when the object has a nontrivial initialization
-- or is controlled.
- function Needs_Finalization (Typ : Entity_Id) return Boolean;
- -- Determine whether type Typ is controlled and this requires finalization
- -- actions.
-
function Non_Limited_Designated_Type (T : Entity_Id) return Entity_Id;
-- An anonymous access type may designate a limited view. Check whether
-- non-limited view is available during expansion, to examine components
@@ -1897,9 +1897,6 @@ package body Sem_Ch9 is
----------------------------------
procedure Analyze_Protected_Definition (N : Node_Id) is
- E : Entity_Id;
- L : Entity_Id;
-
procedure Undelay_Itypes (T : Entity_Id);
-- Itypes created for the private components of a protected type
-- do not receive freeze nodes, because there is no scope in which
@@ -1932,9 +1929,7 @@ package body Sem_Ch9 is
end if;
while Present (Comp) loop
- if Is_Type (Comp)
- and then Is_Itype (Comp)
- then
+ if Is_Type (Comp) and then Is_Itype (Comp) then
Set_Has_Delayed_Freeze (Comp, False);
Set_Is_Frozen (Comp);
@@ -1942,9 +1937,7 @@ package body Sem_Ch9 is
Layout_Type (Comp);
end if;
- if Is_Record_Type (Comp)
- or else Is_Protected_Type (Comp)
- then
+ if Is_Record_Type (Comp) or else Is_Protected_Type (Comp) then
Undelay_Itypes (Comp);
end if;
end if;
@@ -1953,6 +1946,12 @@ package body Sem_Ch9 is
end loop;
end Undelay_Itypes;
+ -- Local variables
+
+ Prot_Typ : constant Entity_Id := Current_Scope;
+ Item_Id : Entity_Id;
+ Last_Id : Entity_Id;
+
-- Start of processing for Analyze_Protected_Definition
begin
@@ -1963,32 +1962,37 @@ package body Sem_Ch9 is
if Present (Private_Declarations (N))
and then not Is_Empty_List (Private_Declarations (N))
then
- L := Last_Entity (Current_Scope);
+ Last_Id := Last_Entity (Prot_Typ);
Analyze_Declarations (Private_Declarations (N));
- if Present (L) then
- Set_First_Private_Entity (Current_Scope, Next_Entity (L));
+ if Present (Last_Id) then
+ Set_First_Private_Entity (Prot_Typ, Next_Entity (Last_Id));
else
- Set_First_Private_Entity (Current_Scope,
- First_Entity (Current_Scope));
+ Set_First_Private_Entity (Prot_Typ, First_Entity (Prot_Typ));
end if;
end if;
- E := First_Entity (Current_Scope);
- while Present (E) loop
- if Ekind_In (E, E_Function, E_Procedure) then
- Set_Convention (E, Convention_Protected);
+ Item_Id := First_Entity (Prot_Typ);
+ while Present (Item_Id) loop
+ if Ekind_In (Item_Id, E_Function, E_Procedure) then
+ Set_Convention (Item_Id, Convention_Protected);
else
- Propagate_Concurrent_Flags (Current_Scope, Etype (E));
+ Propagate_Concurrent_Flags (Prot_Typ, Etype (Item_Id));
+
+ if Chars (Item_Id) /= Name_uParent
+ and then Needs_Finalization (Etype (Item_Id))
+ then
+ Set_Has_Controlled_Component (Prot_Typ);
+ end if;
end if;
- Next_Entity (E);
+ Next_Entity (Item_Id);
end loop;
- Undelay_Itypes (Current_Scope);
+ Undelay_Itypes (Prot_Typ);
Check_Max_Entries (N, Max_Protected_Entries);
- Process_End_Label (N, 'e', Current_Scope);
+ Process_End_Label (N, 'e', Prot_Typ);
end Analyze_Protected_Definition;
----------------------------------------
@@ -19418,6 +19418,94 @@ package body Sem_Util is
return Empty;
end Nearest_Enclosing_Instance;
+ ------------------------
+ -- Needs_Finalization --
+ ------------------------
+
+ function Needs_Finalization (Typ : Entity_Id) return Boolean is
+ function Has_Some_Controlled_Component
+ (Input_Typ : Entity_Id) return Boolean;
+ -- Determine whether type Input_Typ has at least one controlled
+ -- component.
+
+ -----------------------------------
+ -- Has_Some_Controlled_Component --
+ -----------------------------------
+
+ function Has_Some_Controlled_Component
+ (Input_Typ : Entity_Id) return Boolean
+ is
+ Comp : Entity_Id;
+
+ begin
+ -- When a type is already frozen and has at least one controlled
+ -- component, or is manually decorated, it is sufficient to inspect
+ -- flag Has_Controlled_Component.
+
+ if Has_Controlled_Component (Input_Typ) then
+ return True;
+
+ -- Otherwise inspect the internals of the type
+
+ elsif not Is_Frozen (Input_Typ) then
+ if Is_Array_Type (Input_Typ) then
+ return Needs_Finalization (Component_Type (Input_Typ));
+
+ elsif Is_Record_Type (Input_Typ) then
+ Comp := First_Component (Input_Typ);
+ while Present (Comp) loop
+ if Needs_Finalization (Etype (Comp)) then
+ return True;
+ end if;
+
+ Next_Component (Comp);
+ end loop;
+ end if;
+ end if;
+
+ return False;
+ end Has_Some_Controlled_Component;
+
+ -- Start of processing for Needs_Finalization
+
+ begin
+ -- Certain run-time configurations and targets do not provide support
+ -- for controlled types.
+
+ if Restriction_Active (No_Finalization) then
+ return False;
+
+ -- C++ types are not considered controlled. It is assumed that the non-
+ -- Ada side will handle their clean up.
+
+ elsif Convention (Typ) = Convention_CPP then
+ return False;
+
+ -- Class-wide types are treated as controlled because derivations from
+ -- the root type may introduce controlled components.
+
+ elsif Is_Class_Wide_Type (Typ) then
+ return True;
+
+ -- Concurrent types are controlled as long as their corresponding record
+ -- is controlled.
+
+ elsif Is_Concurrent_Type (Typ)
+ and then Present (Corresponding_Record_Type (Typ))
+ and then Needs_Finalization (Corresponding_Record_Type (Typ))
+ then
+ return True;
+
+ -- Otherwise the type is controlled when it is either derived from type
+ -- [Limited_]Controlled and not subject to aspect Disable_Controlled, or
+ -- contains at least one controlled component.
+
+ else
+ return
+ Is_Controlled (Typ) or else Has_Some_Controlled_Component (Typ);
+ end if;
+ end Needs_Finalization;
+
----------------------
-- Needs_One_Actual --
----------------------
@@ -2220,6 +2220,10 @@ package Sem_Util is
-- Return the entity of the nearest enclosing instance which encapsulates
-- entity E. If no such instance exits, return Empty.
+ function Needs_Finalization (Typ : Entity_Id) return Boolean;
+ -- Determine whether type Typ is controlled and this requires finalization
+ -- actions.
+
function Needs_One_Actual (E : Entity_Id) return Boolean;
-- Returns True if a function has defaults for all but its first formal,
-- which is a controlling formal. Used in Ada 2005 mode to solve the
This patch updates the analysis of protected types to properly mark the type as having controlled components when it contains at least one such component. This in turn marks a potential partial view as requiring finalization actions. ------------ -- Source -- ------------ -- types.ads with Ada.Finalization; use Ada.Finalization; package Types is type Ctrl_Typ is new Controlled with null record; procedure Finalize (Obj : in out Ctrl_Typ); type Prot_Typ is limited private; private protected type Prot_Typ is private Comp : Ctrl_Typ; end Prot_Typ; end Types; -- types.adb with Ada.Text_IO; use Ada.Text_IO; package body Types is procedure Finalize (Obj : in out Ctrl_Typ) is begin Put_Line ("finalize"); end Finalize; protected body Prot_Typ is end Prot_Typ; end Types; -- main.adb with Types; use Types; procedure Main is Obj : Prot_Typ; begin null; end Main; Tested on x86_64-pc-linux-gnu, committed on trunk 2019-07-11 Hristian Kirtchev <kirtchev@adacore.com> gcc/ada/ * exp_util.ads, exp_util.adb (Needs_Finalization): Move to Sem_Util. * sem_ch9.adb (Analyze_Protected_Definition): Code cleanup. Mark the protected type as having controlled components when it contains at least one such component. * sem_util.ads, sem_util.adb (Needs_Finalization): New function.