This patch updates the mechanism which detects build-in-place function calls
returning controlled results on the secondary stack.
-- Source --
-- types.ads
with Ada.Finalization; use Ada.Finalization;
package Types is
type Ctrl_Comp is new Limited_Controlled with null record;
procedure Finalize (Obj : in out Ctrl_Comp);
type Root is tagged limited null record;
type Root_Ptr is access all Root'Class;
function Create (Ctrl : Boolean) return Root'Class;
type Empty_Child is new Root with null record;
type Ctrl_Child is new Root with record
Comp : Ctrl_Comp;
end record;
end Types;
-- types.adb
with Ada.Text_IO; use Ada.Text_IO;
package body Types is
function Create (Ctrl : Boolean) return Root'Class is
begin
if Ctrl then
return Result : Ctrl_Child;
else
return Result : Empty_Child;
end if;
end Create;
procedure Finalize (Obj : in out Ctrl_Comp) is
begin
Put_Line (" Finalize");
end Finalize;
end Types;
-- main.adb
with Ada.Text_IO; use Ada.Text_IO;
with Types; use Types;
procedure Main is
pragma Suppress (Accessibility_Check);
begin
Put_Line ("Empty child");
declare
Obj : Root_Ptr := new Root'Class'(Create (False));
begin
Put_Line ("Empty child allocated");
end;
Put_Line ("Ctrl child");
declare
Obj : Root_Ptr := new Root'Class'(Create (True));
begin
Put_Line ("Ctrl child allocated");
end;
Put_Line ("End");
end Main;
-
-- Compilation and expected output --
-
$ gnatmake -q -gnat05 main.adb
$ ./main
Empty child
Empty child allocated
Ctrl child
Ctrl child allocated
End
Finalize
Tested on x86_64-pc-linux-gnu, committed on trunk
2012-03-30 Hristian Kirtchev
* exp_ch7.adb (Process_Declarations): Replace
the call to Is_Null_Access_BIP_Func_Call with
Is_Secondary_Stack_BIP_Func_Call. Update the related comment.
* exp_util.adb (Is_Null_Access_BIP_Func_Call): Removed.
(Is_Secondary_Stack_BIP_Func_Call): New routine.
(Requires_Cleanup_Actions): Replace
the call to Is_Null_Access_BIP_Func_Call with
Is_Secondary_Stack_BIP_Func_Call. Update the related comment.
* exp_util.ads (Is_Null_Access_BIP_Func_Call): Removed.
(Is_Secondary_Stack_BIP_Func_Call): New routine.
Index: exp_ch7.adb
===
--- exp_ch7.adb (revision 185995)
+++ exp_ch7.adb (working copy)
@@ -1824,15 +1824,14 @@
--Obj : Access_Typ := Non_BIP_Function_Call'reference;
--Obj : Access_Typ :=
- --BIP_Function_Call
- -- (..., BIPaccess => null, ...)'reference;
+ --BIP_Function_Call (BIPalloc => 2, ...)'reference;
elsif Is_Access_Type (Obj_Typ)
and then Needs_Finalization
(Available_View (Designated_Type (Obj_Typ)))
and then Present (Expr)
and then
- (Is_Null_Access_BIP_Func_Call (Expr)
+ (Is_Secondary_Stack_BIP_Func_Call (Expr)
or else
(Is_Non_BIP_Func_Call (Expr)
and then not Is_Related_To_Func_Return (Obj_Id)))
Index: exp_util.adb
===
--- exp_util.adb(revision 185995)
+++ exp_util.adb(working copy)
@@ -4475,74 +4475,6 @@
and then Is_Library_Level_Entity (Typ);
end Is_Library_Level_Tagged_Type;
- --
- -- Is_Null_Access_BIP_Func_Call --
- --
-
- function Is_Null_Access_BIP_Func_Call (Expr : Node_Id) return Boolean is
- Call : Node_Id := Expr;
-
- begin
- -- Build-in-place calls usually appear in 'reference format
-
- if Nkind (Call) = N_Reference then
- Call := Prefix (Call);
- end if;
-
- if Nkind_In (Call, N_Qualified_Expression,
- N_Unchecked_Type_Conversion)
- then
- Call := Expression (Call);
- end if;
-
- if Is_Build_In_Place_Function_Call (Call) then
- declare
-Access_Nam : Name_Id := No_Name;
-Actual : Node_Id;
-Param : Node_Id;
-Formal : Node_Id;
-
- begin
--- Examine all parameter associations of the function call
-
-Param := First (Parameter_Associations (Call));
-while Present (Param) loop
- if Nkind (Param) = N_Parameter_Association
- and then Nkind (Selector_Name (Param)) = N_Identifier
- then
- Formal := Selector_Name (Param);
- Actual := Explicit_Actual_Parameter (Param);
-
-
