This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[Ada] Missing finalization of private protected type
- From: Pierre-Marie de Rodat <derodat at adacore dot com>
- To: gcc-patches at gcc dot gnu dot org
- Cc: Hristian Kirtchev <kirtchev at adacore dot com>
- Date: Thu, 11 Jul 2019 04:03:42 -0400
- Subject: [Ada] Missing finalization of private protected type
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.--- gcc/ada/exp_util.adb
+++ gcc/ada/exp_util.adb
@@ -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;
--- gcc/ada/exp_util.ads
+++ gcc/ada/exp_util.ads
@@ -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
--- gcc/ada/sem_ch9.adb
+++ gcc/ada/sem_ch9.adb
@@ -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;
----------------------------------------
--- gcc/ada/sem_util.adb
+++ gcc/ada/sem_util.adb
@@ -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 --
----------------------
--- gcc/ada/sem_util.ads
+++ gcc/ada/sem_util.ads
@@ -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