===================================================================
@@ -4439,20 +4439,28 @@
function Is_Subprogram_Call (N : Node_Id) return Traverse_Result is
begin
- -- 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.
+ -- Complex constructs are factored out by the expander and their
+ -- occurrences are replaced with references to temporaries. Due to
+ -- this expansion activity, inspect the original tree to detect
+ -- subprogram calls.
- if Nkind (N) = N_Identifier
- and then Nkind_In (Original_Node (N), N_Aggregate,
- N_Extension_Aggregate)
- then
+ if Nkind (N) = N_Identifier and then Original_Node (N) /= N then
Detect_Subprogram_Call (Original_Node (N));
- return OK;
- -- Detect a call to a function that returns on the secondary stack
+ -- The original construct contains a subprogram call, there is
+ -- no point in continuing the tree traversal.
+ if Must_Hook then
+ return Abandon;
+ else
+ return OK;
+ end if;
+
+ -- The original construct contains a subprogram call, there is no
+ -- point in continuing the tree traversal.
+
elsif Nkind (N) = N_Object_Declaration
+ and then Present (Expression (N))
and then Nkind (Original_Node (Expression (N))) = N_Function_Call
then
Must_Hook := True;
This patch corrects the transient object machinery to detect subprogram calls in constructs that have been heavily expanded. ------------ -- 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; subtype Zero is 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 enca" & 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 15 - slices"); Set_Calls (2); begin declare type Collection is array (Natural range 1 .. 5) of Natural; C : Collection := (others => 0); Value : Collection; begin Value (1 .. 3) := C (1 .. Ctrl_Encapsulator' (Controlled with Id => New_Id, Comp_1 => Make_Component, Comp_2 => Make_Component, Comp_3 => Make_Component).Comp_2.Data); Put_Line ("ERROR: Test 15: Bomb not raised"); end; exception when Bomb => null; when Not_Zero => Put_Line ("ERROR: Test 15: Not_Zero raised"); when others => Put_Line ("ERROR: Test 15: unexpected exception"); end; Put_Line ("Test 15 end"); end Aggregates; ---------------------------- -- Compilation and output -- ---------------------------- $ gnatmake -q aggregates.adb $ ./aggregates Test 15 - slices ini comp 1 adj comp 1 -> 100 fin comp 1 fin comp 100 Test 15 end Tested on x86_64-pc-linux-gnu, committed on trunk 2014-02-06 Hristian Kirtchev <kirtchev@adacore.com> * exp_ch7.adb (Is_Subprogram_Call): Inspect the original tree in certain cases where a construct has been factored out and replaced by a reference to a temporary.