===================================================================
@@ -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)))
===================================================================
@@ -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);
-
- -- Construct the name of formal BIPaccess. It is much easier
- -- to extract the name of the function using an arbitrary
- -- formal's scope rather than the Name field of Call.
-
- if Access_Nam = No_Name
- and then Present (Entity (Formal))
- then
- Access_Nam :=
- New_External_Name
- (Chars (Scope (Entity (Formal))),
- BIP_Formal_Suffix (BIP_Object_Access));
- end if;
-
- -- A match for BIPaccess => null has been found
-
- if Chars (Formal) = Access_Nam
- and then Nkind (Actual) = N_Null
- then
- return True;
- end if;
- end if;
-
- Next (Param);
- end loop;
- end;
- end if;
-
- return False;
- end Is_Null_Access_BIP_Func_Call;
-
--------------------------
-- Is_Non_BIP_Func_Call --
--------------------------
@@ -4949,6 +4881,75 @@
end if;
end Is_Renamed_Object;
+ --------------------------------------
+ -- Is_Secondary_Stack_BIP_Func_Call --
+ --------------------------------------
+
+ function Is_Secondary_Stack_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);
+
+ -- Construct the name of formal BIPalloc. It is much easier
+ -- to extract the name of the function using an arbitrary
+ -- formal's scope rather than the Name field of Call.
+
+ if Access_Nam = No_Name
+ and then Present (Entity (Formal))
+ then
+ Access_Nam :=
+ New_External_Name
+ (Chars (Scope (Entity (Formal))),
+ BIP_Formal_Suffix (BIP_Alloc_Form));
+ end if;
+
+ -- A match for BIPalloc => 2 has been found
+
+ if Chars (Formal) = Access_Nam
+ and then Nkind (Actual) = N_Integer_Literal
+ and then Intval (Actual) = Uint_2
+ then
+ return True;
+ end if;
+ end if;
+
+ Next (Param);
+ end loop;
+ end;
+ end if;
+
+ return False;
+ end Is_Secondary_Stack_BIP_Func_Call;
+
-------------------------------------
-- Is_Tag_To_Class_Wide_Conversion --
-------------------------------------
@@ -7123,18 +7124,17 @@
-- 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)
- or else
- (Is_Non_BIP_Func_Call (Expr)
- and then not Is_Related_To_Func_Return (Obj_Id)))
+ (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)))
then
return True;
===================================================================
@@ -548,13 +548,20 @@
-- Return True if Typ is a library level tagged type. Currently we use
-- this information to build statically allocated dispatch tables.
- function Is_Null_Access_BIP_Func_Call (Expr : Node_Id) return Boolean;
- -- Determine whether node Expr denotes a build-in-place function call with
- -- a value of "null" for extra formal BIPaccess.
-
function Is_Non_BIP_Func_Call (Expr : Node_Id) return Boolean;
-- Determine whether node Expr denotes a non build-in-place function call
+ function Is_Possibly_Unaligned_Object (N : Node_Id) return Boolean;
+ -- Node N is an object reference. This function returns True if it is
+ -- possible that the object may not be aligned according to the normal
+ -- default alignment requirement for its type (e.g. if it appears in a
+ -- packed record, or as part of a component that has a component clause.)
+
+ function Is_Possibly_Unaligned_Slice (N : Node_Id) return Boolean;
+ -- Determine whether the node P is a slice of an array where the slice
+ -- result may cause alignment problems because it has an alignment that
+ -- is not compatible with the type. Return True if so.
+
function Is_Ref_To_Bit_Packed_Array (N : Node_Id) return Boolean;
-- Determine whether the node P is a reference to a bit packed array, i.e.
-- whether the designated object is a component of a bit packed array, or a
@@ -571,17 +578,6 @@
-- Determine whether object Id is related to an expanded return statement.
-- The case concerned is "return Id.all;".
- function Is_Possibly_Unaligned_Slice (N : Node_Id) return Boolean;
- -- Determine whether the node P is a slice of an array where the slice
- -- result may cause alignment problems because it has an alignment that
- -- is not compatible with the type. Return True if so.
-
- function Is_Possibly_Unaligned_Object (N : Node_Id) return Boolean;
- -- Node N is an object reference. This function returns True if it is
- -- possible that the object may not be aligned according to the normal
- -- default alignment requirement for its type (e.g. if it appears in a
- -- packed record, or as part of a component that has a component clause.)
-
function Is_Renamed_Object (N : Node_Id) return Boolean;
-- Returns True if the node N is a renamed object. An expression is
-- considered to be a renamed object if either it is the Name of an object
@@ -593,6 +589,10 @@
-- We consider that a (1 .. 2) is a renamed object since it is the prefix
-- of the name in the renaming declaration.
+ function Is_Secondary_Stack_BIP_Func_Call (Expr : Node_Id) return Boolean;
+ -- Determine whether Expr denotes a build-in-place function which returns
+ -- its result on the secondary stack.
+
function Is_Tag_To_Class_Wide_Conversion
(Obj_Id : Entity_Id) return Boolean;
-- Determine whether object Obj_Id is the result of a tag-to-class-wide
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 <kirtchev@adacore.com> * 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.