This patch corrects the finalization machinery to properly handle a controlled
object that is initialized by an aggregate and acts as a transient. The object
is now considered fully initialized after the last component assignment takes
place. This avoids the finalization of uninitialized data that may lead to a
Segmentation_Fault.
------------
-- Source --
------------
-- types.ads
with Ada.Finalization; use Ada.Finalization;
package Types is
Bomb : exception;
Not_Zero : exception;
procedure Set_Calls (Bomb_On : Natural);
function New_Id return Natural;
type Zero is new Natural range 0 .. 0;
type Ctrl_Component is new Controlled with record
Id : Natural := 0;
Data : Zero := 0;
end record;
procedure Adjust (Obj : in out Ctrl_Component);
procedure Finalize (Obj : in out Ctrl_Component);
procedure Initialize (Obj : in out Ctrl_Component);
function Make_Component return Ctrl_Component;
type Ctrl_Encapsulator is new Controlled with record
Id : Natural := 0;
Comp_1 : Ctrl_Component;
Comp_2 : Ctrl_Component;
Comp_3 : Ctrl_Component;
end record;
procedure Adjust (Obj : in out Ctrl_Encapsulator);
procedure Finalize (Obj : in out Ctrl_Encapsulator);
procedure Initialize (Obj : in out Ctrl_Encapsulator);
type Encapsulator is record
Id : Natural := 0;
Comp_1 : Ctrl_Component;
Comp_2 : Ctrl_Component;
Comp_3 : Ctrl_Component;
end record;
type Super_Encapsulator is record
Id : Natural := 0;
Comp_1 : Ctrl_Encapsulator;
Comp_2 : Ctrl_Encapsulator;
Comp_3 : Ctrl_Encapsulator;
end record;
end Types;
-- types.adb
with Ada.Text_IO; use Ada.Text_IO;
package body Types is
Calls : Natural := 0;
Calls_To_Bomb : Natural := 0;
Id_Gen : Natural := 0;
procedure Adjust (Obj : in out Ctrl_Component) is
Old_Id : constant Natural := Obj.Id;
New_Id : constant Natural := Old_Id * 100;
begin
Put_Line (" adj comp" & Old_Id'Img & " ->" & New_Id'Img);
Obj.Id := New_Id;
end Adjust;
procedure Adjust (Obj : in out Ctrl_Encapsulator) is
Old_Id : constant Natural := Obj.Id;
New_Id : constant Natural := Old_Id * 100;
begin
Put_Line (" adj enca" & Old_Id'Img & " ->" & New_Id'Img);
Obj.Id := New_Id;
end Adjust;
procedure Finalize (Obj : in out Ctrl_Component) is
begin
Put_Line (" fin comp" & Obj.Id'Img);
if Obj.Data /= 0 then
raise Not_Zero;
end if;
end Finalize;
procedure Finalize (Obj : in out Ctrl_Encapsulator) is
begin
Put_Line (" fin enca" & Obj.Id'Img);
end Finalize;
procedure Initialize (Obj : in out Ctrl_Component) is
begin
Obj.Id := New_Id;
Put_Line (" ini comp" & Obj.Id'Img);
end Initialize;
procedure Initialize (Obj : in out Ctrl_Encapsulator) is
begin
Obj.Id := New_Id;
Put_Line (" ini comp" & Obj.Id'Img);
end Initialize;
function Make_Component return Ctrl_Component is
begin
if Calls = Calls_To_Bomb then
raise Bomb;
else
Calls := Calls + 1;
end if;
declare
Result : Ctrl_Component;
begin
return Result;
end;
end Make_Component;
function New_Id return Natural is
begin
Id_Gen := Id_Gen + 1;
return Id_Gen;
end New_Id;
procedure Set_Calls (Bomb_On : Natural) is
begin
Calls := 0;
if Bomb_On >= 1 then
Calls_To_Bomb := Bomb_On - 1;
else
Calls_To_Bomb := 0;
end if;
end Set_Calls;
end Types;
-- aggregates.adb
with Ada.Finalization; use Ada.Finalization;
with Ada.Text_IO; use Ada.Text_IO;
with Types; use Types;
procedure Aggregates is
begin
Put_Line ("Test 4");
Set_Calls (3);
begin
declare
function Make_Encapsulator return Ctrl_Encapsulator is
begin
return Result : Ctrl_Encapsulator :=
(Controlled with
Id => New_Id,
Comp_1 => Make_Component,
Comp_2 => Make_Component,
Comp_3 => Make_Component);
end Make_Encapsulator;
Obj : Ctrl_Encapsulator;
begin
Obj := Make_Encapsulator;
Put_Line ("ERROR: Test 4: Bomb not raised");
end;
exception
when Bomb => null;
when Not_Zero => Put_Line ("ERROR: Test 4: Not_Zero raised");
when others => Put_Line ("ERROR: Test 4: unexpected exception");
end;
Put_Line ("Test 4 end");
Put_Line ("Test 5");
Set_Calls (2);
begin
declare
procedure Do_Nothing (Obj : Ctrl_Encapsulator) is
begin
null;
end Do_Nothing;
begin
Do_Nothing
(Ctrl_Encapsulator'
(Controlled with
Id => New_Id,
Comp_1 => Make_Component,
Comp_2 => Make_Component,
Comp_3 => Make_Component));
Put_Line ("ERROR: Test 5: Bomb not raised");
end;
exception
when Bomb => null;
when Not_Zero => Put_Line ("ERROR: Test 5: Not_Zero raised");
when others => Put_Line ("ERROR: Test 5: unexpected exception");
end;
Put_Line ("Test 5 end");
Put_Line ("Test 6");
Set_Calls (2);
begin
declare
procedure Do_Nothing (Obj : out Ctrl_Encapsulator) is
begin
Obj := Ctrl_Encapsulator'
(Controlled with
Id => New_Id,
Comp_1 => Make_Component,
Comp_2 => Make_Component,
Comp_3 => Make_Component);
Put_Line ("ERROR: Test 6: Bomb not raised");
end Do_Nothing;
Obj : Ctrl_Encapsulator;
begin
Do_Nothing (Obj);
Put_Line ("ERROR: Test 6: Bomb not raised");
end;
exception
when Bomb => null;
when Not_Zero => Put_Line ("ERROR: Test 6: Not_Zero raised");
when others => Put_Line ("ERROR: Test 6: unexpected exception");
end;
Put_Line ("Test 6 end");
Put_Line ("Test 7");
Set_Calls (3);
begin
declare
Obj : Ctrl_Encapsulator;
begin
Obj := Ctrl_Encapsulator'
(Controlled with
Id => New_Id,
Comp_1 => Make_Component,
Comp_2 => Make_Component,
Comp_3 => Make_Component);
Put_Line ("ERROR: Test 7: Bomb not raised");
end;
exception
when Bomb => null;
when Not_Zero => Put_Line ("ERROR: Test 7: Not_Zero raised");
when others => Put_Line ("ERROR: Test 7: unexpected exception");
end;
Put_Line ("Test 7 end");
Put_Line ("Test 8");
Set_Calls (2);
begin
begin
if New_Id > 0
and then Ctrl_Encapsulator'
(Controlled with
Id => New_Id,
Comp_1 => Make_Component,
Comp_2 => Make_Component,
Comp_3 => Make_Component).Comp_3.Data > 0
then
Put_Line ("ERROR: Test 8: Bomb not raised");
else
Put_Line ("ERROR: Test 8: Bomb not raised");
end if;
end;
exception
when Bomb => null;
when Not_Zero => Put_Line ("ERROR: Test 8: Not_Zero raised");
when others => Put_Line ("ERROR: Test 8: unexpected exception");
end;
Put_Line ("Test 8 end");
Put_Line ("Test 9");
Set_Calls (3);
begin
begin
case Ctrl_Encapsulator'
(Controlled with
Id => New_Id,
Comp_1 => Make_Component,
Comp_2 => Make_Component,
Comp_3 => Make_Component).Comp_3.Data
is
when 0 =>
Put_Line ("ERROR: Test 9: Bomb not raised");
when others =>
Put_Line ("ERROR: Test 9: Bomb not raised");
end case;
end;
exception
when Bomb => null;
when Not_Zero => Put_Line ("ERROR: Test 9: Not_Zero raised");
when others => Put_Line ("ERROR: Test 9: unexpected exception");
end;
Put_Line ("Test 9 end");
end Aggregates;
----------------------------
-- Compilation and output --
----------------------------
$ gnatmake -q aggregates.adb
$ ./aggregates
Test 4
ini comp 1
ini comp 2
ini comp 3
ini comp 4
ini comp 5
adj comp 5 -> 500
fin comp 5
ini comp 6
adj comp 6 -> 600
fin comp 6
fin comp 600
fin comp 500
fin enca 4
fin comp 3
fin comp 2
fin comp 1
Test 4 end
Test 5
ini comp 7
adj comp 7 -> 700
fin comp 7
fin comp 700
Test 5 end
Test 6
ini comp 8
ini comp 9
ini comp 10
ini comp 11
ini comp 12
adj comp 12 -> 1200
fin comp 12
fin comp 1200
fin enca 11
fin comp 10
fin comp 9
fin comp 8
Test 6 end
Test 7
ini comp 13
ini comp 14
ini comp 15
ini comp 16
ini comp 17
adj comp 17 -> 1700
fin comp 17
ini comp 18
adj comp 18 -> 1800
fin comp 18
fin comp 1800
fin comp 1700
fin enca 16
fin comp 15
fin comp 14
fin comp 13
Test 7 end
Test 8
ini comp 30
adj comp 30 -> 3000
fin comp 30
fin comp 3000
Test 8 end
Test 9
ini comp 31
adj comp 31 -> 3100
fin comp 31
ini comp 32
adj comp 32 -> 3200
fin comp 32
fin comp 3200
fin comp 3100
Test 9 end
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-02-06 Hristian Kirtchev <kirtc...@adacore.com>
* exp_ch4.adb (Process_Transient_Object): Add local variable
Temp_Ins. When the transient object is initialized by an
aggregate, the hook must capture the object after the last
component assignment takes place.
* exp_ch7.adb (Detect_Subprogram_Call): Expose the subprogram to
routine Is_Subprogram_Call.
(Is_Subprogram_Call): Inspect an
aggregate that has been heavily expanded for subprogram calls.
(Process_Transient_Objects): Add local variables Expr, Ptr_Id
and Temp_Ins. Remove the nested declare block and adjust the
indentation. When the transient object is initialized by an
aggregate, the hook must capture the object after the last
component assignment takes place.
Index: exp_ch7.adb
===================================================================
--- exp_ch7.adb (revision 207533)
+++ exp_ch7.adb (working copy)
@@ -2454,12 +2454,23 @@
Expression => Make_Integer_Literal (Loc, Counter_Val));
-- Insert the counter after all initialization has been done. The
- -- place of insertion depends on the context. When dealing with a
- -- controlled function, the counter is inserted directly after the
- -- declaration because such objects lack init calls.
+ -- place of insertion depends on the context. If an object is being
+ -- initialized via an aggregate, then the counter must be inserted
+ -- after the last aggregate assignment.
- Find_Last_Init (Decl, Obj_Typ, Count_Ins, Body_Ins);
+ if Ekind (Obj_Id) = E_Variable
+ and then Present (Last_Aggregate_Assignment (Obj_Id))
+ then
+ Count_Ins := Last_Aggregate_Assignment (Obj_Id);
+ Body_Ins := Empty;
+ -- In all other cases the counter is inserted after the last call to
+ -- either [Deep_]Initialize or the type specific init proc.
+
+ else
+ Find_Last_Init (Decl, Obj_Typ, Count_Ins, Body_Ins);
+ end if;
+
Insert_After (Count_Ins, Inc_Decl);
Analyze (Inc_Decl);
@@ -4419,17 +4430,25 @@
function Is_Subprogram_Call (N : Node_Id) return Traverse_Result;
-- Determine whether an arbitrary node denotes a subprogram call
+ procedure Detect_Subprogram_Call is
+ new Traverse_Proc (Is_Subprogram_Call);
+
------------------------
-- Is_Subprogram_Call --
------------------------
function Is_Subprogram_Call (N : Node_Id) return Traverse_Result is
begin
- -- A regular procedure or function call
+ -- Aggregates are usually rewritten into component by component
+ -- assignments and replaced by a reference to a temporary in the
+ -- original tree. Peek in the aggregate to detect function calls.
- if Nkind (N) in N_Subprogram_Call then
- Must_Hook := True;
- return Abandon;
+ if Nkind (N) = N_Identifier
+ and then Nkind_In (Original_Node (N), N_Aggregate,
+ N_Extension_Aggregate)
+ then
+ Detect_Subprogram_Call (Original_Node (N));
+ return OK;
-- Detect a call to a function that returns on the secondary stack
@@ -4439,6 +4458,12 @@
Must_Hook := True;
return Abandon;
+ -- A regular procedure or function call
+
+ elsif Nkind (N) in N_Subprogram_Call then
+ Must_Hook := True;
+ return Abandon;
+
-- Keep searching
else
@@ -4446,13 +4471,11 @@
end if;
end Is_Subprogram_Call;
- procedure Detect_Subprogram_Call is
- new Traverse_Proc (Is_Subprogram_Call);
-
-- Local variables
Built : Boolean := False;
Desig_Typ : Entity_Id;
+ Expr : Node_Id;
Fin_Block : Node_Id;
Fin_Data : Finalization_Exception_Data;
Fin_Decls : List_Id;
@@ -4462,9 +4485,11 @@
Obj_Ref : Node_Id;
Obj_Typ : Entity_Id;
Prev_Fin : Node_Id := Empty;
+ Ptr_Id : Entity_Id;
Stmt : Node_Id;
Stmts : List_Id;
Temp_Id : Entity_Id;
+ Temp_Ins : Node_Id;
-- Start of processing for Process_Transient_Objects
@@ -4505,11 +4530,10 @@
-- time around.
if not Built then
+ Built := True;
Fin_Decls := New_List;
Build_Object_Declarations (Fin_Data, Fin_Decls, Loc);
-
- Built := True;
end if;
-- Transient variables associated with subprogram calls need
@@ -4524,69 +4548,80 @@
-- "hooks" are picked up by the finalization machinery.
if Must_Hook then
- declare
- Expr : Node_Id;
- Ptr_Id : Entity_Id;
- begin
- -- Step 1: Create an access type which provides a
- -- reference to the transient object. Generate:
+ -- Step 1: Create an access type which provides a reference
+ -- to the transient object. Generate:
- -- Ann : access [all] <Desig_Typ>;
+ -- Ann : access [all] <Desig_Typ>;
- Ptr_Id := Make_Temporary (Loc, 'A');
+ Ptr_Id := Make_Temporary (Loc, 'A');
- Insert_Action (Stmt,
- Make_Full_Type_Declaration (Loc,
- Defining_Identifier => Ptr_Id,
- Type_Definition =>
- Make_Access_To_Object_Definition (Loc,
- All_Present =>
- Ekind (Obj_Typ) = E_General_Access_Type,
- Subtype_Indication =>
- New_Reference_To (Desig_Typ, Loc))));
+ Insert_Action (Stmt,
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => Ptr_Id,
+ Type_Definition =>
+ Make_Access_To_Object_Definition (Loc,
+ All_Present =>
+ Ekind (Obj_Typ) = E_General_Access_Type,
+ Subtype_Indication =>
+ New_Reference_To (Desig_Typ, Loc))));
- -- Step 2: Create a temporary which acts as a hook to
- -- the transient object. Generate:
+ -- Step 2: Create a temporary which acts as a hook to the
+ -- transient object. Generate:
- -- Temp : Ptr_Id := null;
+ -- Temp : Ptr_Id := null;
- Temp_Id := Make_Temporary (Loc, 'T');
+ Temp_Id := Make_Temporary (Loc, 'T');
- Insert_Action (Stmt,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Temp_Id,
- Object_Definition =>
- New_Reference_To (Ptr_Id, Loc)));
+ Insert_Action (Stmt,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Temp_Id,
+ Object_Definition =>
+ New_Reference_To (Ptr_Id, Loc)));
- -- Mark the temporary as a transient hook. This signals
- -- the machinery in Build_Finalizer to recognize this
- -- special case.
+ -- Mark the temporary as a transient hook. This signals the
+ -- machinery in Build_Finalizer to recognize this special
+ -- case.
- Set_Status_Flag_Or_Transient_Decl (Temp_Id, Stmt);
+ Set_Status_Flag_Or_Transient_Decl (Temp_Id, Stmt);
- -- Step 3: Hook the transient object to the temporary
+ -- Step 3: Hook the transient object to the temporary
- if Is_Access_Type (Obj_Typ) then
- Expr :=
- Convert_To (Ptr_Id, New_Reference_To (Obj_Id, Loc));
- else
- Expr :=
- Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (Obj_Id, Loc),
- Attribute_Name => Name_Unrestricted_Access);
- end if;
+ if Is_Access_Type (Obj_Typ) then
+ Expr :=
+ Convert_To (Ptr_Id, New_Reference_To (Obj_Id, Loc));
+ else
+ Expr :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Obj_Id, Loc),
+ Attribute_Name => Name_Unrestricted_Access);
+ end if;
- -- Generate:
- -- Temp := Ptr_Id (Obj_Id);
- -- <or>
- -- Temp := Obj_Id'Unrestricted_Access;
+ -- Generate:
+ -- Temp := Ptr_Id (Obj_Id);
+ -- <or>
+ -- Temp := Obj_Id'Unrestricted_Access;
- Insert_After_And_Analyze (Stmt,
- Make_Assignment_Statement (Loc,
- Name => New_Reference_To (Temp_Id, Loc),
- Expression => Expr));
- end;
+ -- When the transient object is initialized by an aggregate,
+ -- the hook must capture the object after the last component
+ -- assignment takes place. Only then is the object fully
+ -- initialized.
+
+ if Ekind (Obj_Id) = E_Variable
+ and then Present (Last_Aggregate_Assignment (Obj_Id))
+ then
+ Temp_Ins := Last_Aggregate_Assignment (Obj_Id);
+
+ -- Otherwise the hook seizes the related object immediately
+
+ else
+ Temp_Ins := Stmt;
+ end if;
+
+ Insert_After_And_Analyze (Temp_Ins,
+ Make_Assignment_Statement (Loc,
+ Name => New_Reference_To (Temp_Id, Loc),
+ Expression => Expr));
end if;
Stmts := New_List;
Index: exp_ch4.adb
===================================================================
--- exp_ch4.adb (revision 207533)
+++ exp_ch4.adb (working copy)
@@ -12386,6 +12386,7 @@
Fin_Stmts : List_Id;
Ptr_Id : Entity_Id;
Temp_Id : Entity_Id;
+ Temp_Ins : Node_Id;
-- Start of processing for Process_Transient_Object
@@ -12463,7 +12464,22 @@
-- <or>
-- Temp := Obj_Id'Unrestricted_Access;
- Insert_After_And_Analyze (Decl,
+ -- When the transient object is initialized by an aggregate, the hook
+ -- must capture the object after the last component assignment takes
+ -- place. Only then is the object fully initialized.
+
+ if Ekind (Obj_Id) = E_Variable
+ and then Present (Last_Aggregate_Assignment (Obj_Id))
+ then
+ Temp_Ins := Last_Aggregate_Assignment (Obj_Id);
+
+ -- Otherwise the hook seizes the related object immediately
+
+ else
+ Temp_Ins := Decl;
+ end if;
+
+ Insert_After_And_Analyze (Temp_Ins,
Make_Assignment_Statement (Loc,
Name => New_Reference_To (Temp_Id, Loc),
Expression => Expr));
