This patch fixes the regressions introduced in CodePeer (caused by
missing support for thunks) and enforces checks on BIP formals in the
frontend to avoid mismatch when their values are passed as actuals of
BIP calls.
Tested on x86_64-pc-linux-gnu, committed on trunk
2020-06-16 Javier Miranda <mira...@adacore.com>
gcc/ada/
* exp_ch6.adb (BIP_Suffix_Kind, Check_BIP_Actuals,
Is_Build_In_Place_Entity): New subprograms.
(Make_Build_In_Place_Call_In_Allocator,
Make_Build_In_Place_Call_In_Anonymous_Context,
Make_Build_In_Place_Call_In_Assignment,
Make_Build_In_Place_Call_In_Object_Declaration): Add assertions.
(Needs_BIP_Task_Actuals): Add missing support for thunks.
(Expand_Actuals): Ensure that the BIP call has available an
activation chain and the _master variable.
* exp_ch9.adb (Find_Enclosing_Context): Initialize the list of
declarations of empty blocks when the _master variable must be
declared and the list was not available.--- gcc/ada/exp_ch6.adb
+++ gcc/ada/exp_ch6.adb
@@ -78,6 +78,15 @@ with Validsw; use Validsw;
package body Exp_Ch6 is
+ -- Suffix for BIP formals
+
+ BIP_Alloc_Suffix : constant String := "BIPalloc";
+ BIP_Storage_Pool_Suffix : constant String := "BIPstoragepool";
+ BIP_Finalization_Master_Suffix : constant String := "BIPfinalizationmaster";
+ BIP_Task_Master_Suffix : constant String := "BIPtaskmaster";
+ BIP_Activation_Chain_Suffix : constant String := "BIPactivationchain";
+ BIP_Object_Access_Suffix : constant String := "BIPaccess";
+
-----------------------
-- Local Subprograms --
-----------------------
@@ -147,6 +156,9 @@ package body Exp_Ch6 is
-- level is known not to be statically deeper than the result type of the
-- function.
+ function BIP_Suffix_Kind (E : Entity_Id) return BIP_Formal_Kind;
+ -- Ada 2005 (AI-318-02): Returns the kind of the given extra formal.
+
function Caller_Known_Size
(Func_Call : Node_Id;
Result_Subt : Entity_Id) return Boolean;
@@ -156,6 +168,12 @@ package body Exp_Ch6 is
-- access discriminants do not require secondary stack use. Note we must
-- always use the secondary stack for dispatching-on-result calls.
+ function Check_BIP_Actuals
+ (Subp_Call : Node_Id;
+ Subp_Id : Entity_Id) return Boolean;
+ -- Given a subprogram call to the given subprogram return True if the
+ -- names of BIP extra actual and formal parameters match.
+
function Check_Number_Of_Actuals
(Subp_Call : Node_Id;
Subp_Id : Entity_Id) return Boolean;
@@ -258,6 +276,9 @@ package body Exp_Ch6 is
-- Insert the Post_Call list previously produced by routine Expand_Actuals
-- or Expand_Call_Helper into the tree.
+ function Is_Build_In_Place_Entity (E : Entity_Id) return Boolean;
+ -- Ada 2005 (AI-318-02): Returns True if E is a BIP entity.
+
procedure Replace_Renaming_Declaration_Id
(New_Decl : Node_Id;
Orig_Decl : Node_Id);
@@ -737,25 +758,68 @@ package body Exp_Ch6 is
begin
case Kind is
when BIP_Alloc_Form =>
- return "BIPalloc";
+ return BIP_Alloc_Suffix;
when BIP_Storage_Pool =>
- return "BIPstoragepool";
+ return BIP_Storage_Pool_Suffix;
when BIP_Finalization_Master =>
- return "BIPfinalizationmaster";
+ return BIP_Finalization_Master_Suffix;
when BIP_Task_Master =>
- return "BIPtaskmaster";
+ return BIP_Task_Master_Suffix;
when BIP_Activation_Chain =>
- return "BIPactivationchain";
+ return BIP_Activation_Chain_Suffix;
when BIP_Object_Access =>
- return "BIPaccess";
+ return BIP_Object_Access_Suffix;
end case;
end BIP_Formal_Suffix;
+ ---------------------
+ -- BIP_Suffix_Kind --
+ ---------------------
+
+ function BIP_Suffix_Kind (E : Entity_Id) return BIP_Formal_Kind is
+ Nam : constant String := Get_Name_String (Chars (E));
+
+ function Has_Suffix (Suffix : String) return Boolean;
+ -- Return True if Nam has suffix Suffix
+
+ function Has_Suffix (Suffix : String) return Boolean is
+ Len : constant Natural := Suffix'Length;
+ begin
+ return Nam'Length > Len
+ and then Nam (Nam'Last - Len + 1 .. Nam'Last) = Suffix;
+ end Has_Suffix;
+
+ -- Start of processing for BIP_Suffix_Kind
+
+ begin
+ if Has_Suffix (BIP_Alloc_Suffix) then
+ return BIP_Alloc_Form;
+
+ elsif Has_Suffix (BIP_Storage_Pool_Suffix) then
+ return BIP_Storage_Pool;
+
+ elsif Has_Suffix (BIP_Finalization_Master_Suffix) then
+ return BIP_Finalization_Master;
+
+ elsif Has_Suffix (BIP_Task_Master_Suffix) then
+ return BIP_Task_Master;
+
+ elsif Has_Suffix (BIP_Activation_Chain_Suffix) then
+ return BIP_Activation_Chain;
+
+ elsif Has_Suffix (BIP_Object_Access_Suffix) then
+ return BIP_Object_Access;
+
+ else
+ raise Program_Error;
+ end if;
+ end BIP_Suffix_Kind;
+
---------------------------
-- Build_In_Place_Formal --
---------------------------
@@ -987,6 +1051,42 @@ package body Exp_Ch6 is
or else not Requires_Transient_Scope (Underlying_Type (Result_Subt));
end Caller_Known_Size;
+ -----------------------
+ -- Check_BIP_Actuals --
+ -----------------------
+
+ function Check_BIP_Actuals
+ (Subp_Call : Node_Id;
+ Subp_Id : Entity_Id) return Boolean
+ is
+ Formal : Entity_Id;
+ Actual : Node_Id;
+
+ begin
+ pragma Assert (Nkind_In (Subp_Call, N_Entry_Call_Statement,
+ N_Function_Call,
+ N_Procedure_Call_Statement));
+
+ Formal := First_Formal_With_Extras (Subp_Id);
+ Actual := First_Actual (Subp_Call);
+
+ while Present (Formal) and then Present (Actual) loop
+ if Is_Build_In_Place_Entity (Formal)
+ and then Nkind (Actual) = N_Identifier
+ and then Is_Build_In_Place_Entity (Entity (Actual))
+ and then BIP_Suffix_Kind (Formal)
+ /= BIP_Suffix_Kind (Entity (Actual))
+ then
+ return False;
+ end if;
+
+ Next_Formal_With_Extras (Formal);
+ Next_Actual (Actual);
+ end loop;
+
+ return No (Formal) and then No (Actual);
+ end Check_BIP_Actuals;
+
-----------------------------
-- Check_Number_Of_Actuals --
-----------------------------
@@ -2160,13 +2260,18 @@ package body Exp_Ch6 is
-- Ada 2005 (AI-318-02): If the actual parameter is a call to a
-- build-in-place function, then a temporary return object needs
- -- to be created and access to it must be passed to the function.
+ -- to be created and access to it must be passed to the function
+ -- (and ensure that we have an activation chain defined for tasks
+ -- and a Master variable).
+
-- Currently we limit such functions to those with inherently
-- limited result subtypes, but eventually we plan to expand the
-- functions that are treated as build-in-place to include other
-- composite result types.
if Is_Build_In_Place_Function_Call (Actual) then
+ Build_Activation_Chain_Entity (N);
+ Build_Master_Entity (Etype (Actual));
Make_Build_In_Place_Call_In_Anonymous_Context (Actual);
-- Ada 2005 (AI-318-02): Specialization of the previous case for
@@ -2174,6 +2279,8 @@ package body Exp_Ch6 is
-- object covers interface types.
elsif Present (Unqual_BIP_Iface_Function_Call (Actual)) then
+ Build_Activation_Chain_Entity (N);
+ Build_Master_Entity (Etype (Actual));
Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Actual);
end if;
@@ -3359,6 +3466,8 @@ package body Exp_Ch6 is
Expand_Actuals (Call_Node, Subp, Post_Call);
pragma Assert (Is_Empty_List (Post_Call));
+ pragma Assert (Check_Number_Of_Actuals (Call_Node, Subp));
+ pragma Assert (Check_BIP_Actuals (Call_Node, Subp));
return;
end;
end if;
@@ -8291,6 +8400,34 @@ package body Exp_Ch6 is
end if;
end Is_Build_In_Place_Result_Type;
+ ------------------------------
+ -- Is_Build_In_Place_Entity --
+ ------------------------------
+
+ function Is_Build_In_Place_Entity (E : Entity_Id) return Boolean is
+ Nam : constant String := Get_Name_String (Chars (E));
+
+ function Has_Suffix (Suffix : String) return Boolean;
+ -- Return True if Nam has suffix Suffix
+
+ function Has_Suffix (Suffix : String) return Boolean is
+ Len : constant Natural := Suffix'Length;
+ begin
+ return Nam'Length > Len
+ and then Nam (Nam'Last - Len + 1 .. Nam'Last) = Suffix;
+ end Has_Suffix;
+
+ -- Start of processing for Is_Build_In_Place_Entity
+
+ begin
+ return Has_Suffix (BIP_Alloc_Suffix)
+ or else Has_Suffix (BIP_Storage_Pool_Suffix)
+ or else Has_Suffix (BIP_Finalization_Master_Suffix)
+ or else Has_Suffix (BIP_Task_Master_Suffix)
+ or else Has_Suffix (BIP_Activation_Chain_Suffix)
+ or else Has_Suffix (BIP_Object_Access_Suffix);
+ end Is_Build_In_Place_Entity;
+
--------------------------------
-- Is_Build_In_Place_Function --
--------------------------------
@@ -8699,6 +8836,7 @@ package body Exp_Ch6 is
Analyze_And_Resolve (Allocator, Acc_Type);
pragma Assert (Check_Number_Of_Actuals (Func_Call, Function_Id));
+ pragma Assert (Check_BIP_Actuals (Func_Call, Function_Id));
end Make_Build_In_Place_Call_In_Allocator;
---------------------------------------------------
@@ -8821,6 +8959,7 @@ package body Exp_Ch6 is
(Func_Call, Function_Id, New_Occurrence_Of (Return_Obj_Id, Loc));
pragma Assert (Check_Number_Of_Actuals (Func_Call, Function_Id));
+ pragma Assert (Check_BIP_Actuals (Func_Call, Function_Id));
-- When the result subtype is unconstrained, the function must allocate
-- the return object in the secondary stack, so appropriate implicit
@@ -8847,6 +8986,7 @@ package body Exp_Ch6 is
(Func_Call, Function_Id, Empty);
pragma Assert (Check_Number_Of_Actuals (Func_Call, Function_Id));
+ pragma Assert (Check_BIP_Actuals (Func_Call, Function_Id));
end if;
end Make_Build_In_Place_Call_In_Anonymous_Context;
@@ -8953,6 +9093,7 @@ package body Exp_Ch6 is
Rewrite (Assign, Make_Null_Statement (Loc));
pragma Assert (Check_Number_Of_Actuals (Func_Call, Func_Id));
+ pragma Assert (Check_BIP_Actuals (Func_Call, Func_Id));
end Make_Build_In_Place_Call_In_Assignment;
----------------------------------------------------
@@ -9396,6 +9537,7 @@ package body Exp_Ch6 is
end if;
pragma Assert (Check_Number_Of_Actuals (Func_Call, Function_Id));
+ pragma Assert (Check_BIP_Actuals (Func_Call, Function_Id));
end Make_Build_In_Place_Call_In_Object_Declaration;
-------------------------------------------------
@@ -9686,8 +9828,26 @@ package body Exp_Ch6 is
function Needs_BIP_Task_Actuals (Func_Id : Entity_Id) return Boolean is
pragma Assert (Is_Build_In_Place_Function (Func_Id));
- Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id));
+ Subp_Id : Entity_Id;
+ Func_Typ : Entity_Id;
+
begin
+ -- For thunks we must rely on their target entity; otherwise, given that
+ -- the profile of thunks for functions returning a limited interface
+ -- type returns a class-wide type, we would erroneously add these extra
+ -- formals.
+
+ if Is_Thunk (Func_Id) then
+ Subp_Id := Thunk_Entity (Func_Id);
+
+ -- Common case
+
+ else
+ Subp_Id := Func_Id;
+ end if;
+
+ Func_Typ := Underlying_Type (Etype (Subp_Id));
+
return not Global_No_Tasking
and then (Has_Task (Func_Typ) or else Might_Have_Tasks (Func_Typ));
end Needs_BIP_Task_Actuals;
--- gcc/ada/exp_ch9.adb
+++ gcc/ada/exp_ch9.adb
@@ -13327,6 +13327,10 @@ package body Exp_Ch9 is
if Nkind (Context) = N_Block_Statement then
Context_Id := Entity (Identifier (Context));
+ if No (Declarations (Context)) then
+ Set_Declarations (Context, New_List);
+ end if;
+
elsif Nkind (Context) = N_Entry_Body then
Context_Id := Defining_Identifier (Context);
