[Ada] Fix PR ada/112781 (2/2)
Checks
Commit Message
The problem occurs when this function call is the expression of a return in a
function returning the limited interface; in this peculiar case, there is a
mismatch between the callee, which has BIP formals but is not a BIP call, and
the caller, which is a BIP function, that is spotted by an assertion.
This is fixed by restoring the semantics of Is_Build_In_Place_Function_Call,
which returns again true only for calls to BIP functions, introducing the
Is_Function_Call_With_BIP_Formals predicate, which also returns true for calls
to functions with BIP formals that are not BIP functions, and moving down the
assertion in Expand_Simple_Function_Return.
Tested on SPARC64/Linux, applied on the mainline and 13 branch.
2024-01-09 Eric Botcazou <ebotcazou@adacore.com>
PR ada/112781
* exp_ch6.ads (Is_Build_In_Place_Function): Adjust description.
* exp_ch6.adb (Is_True_Build_In_Place_Function_Call): Delete.
(Is_Function_Call_With_BIP_Formals): New predicate.
(Is_Build_In_Place_Function_Call): Restore original semantics.
(Expand_Call_Helper): Adjust conditions guarding the calls to
Add_Dummy_Build_In_Place_Actuals to above renaming.
(Expand_N_Extended_Return_Statement): Adjust to above renaming.
(Expand_Simple_Function_Return): Likewise. Move the assertion
to after the transformation into an extended return statement.
(Make_Build_In_Place_Call_In_Allocator): Remove unreachable code.
(Make_Build_In_Place_Call_In_Assignment): Likewise.
2024-01-09 Eric Botcazou <ebotcazou@adacore.com>
* gnat.dg/bip_prim_func2.adb: New test.
* gnat.dg/bip_prim_func2_pkg.ads, gnat.dg/bip_prim_func2_pkg.adb:
New helper package.
@@ -316,11 +316,10 @@ 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_True_Build_In_Place_Function_Call (N : Node_Id) return Boolean;
+ function Is_Function_Call_With_BIP_Formals (N : Node_Id) return Boolean;
-- Ada 2005 (AI-318-02): Returns True if N denotes a call to a function
- -- that requires handling as a build-in-place call; returns False for
- -- non-BIP function calls and also for calls to functions with inherited
- -- BIP formals that do not require BIP formals. For example:
+ -- that requires handling as a build-in-place call, that is, BIP function
+ -- calls and calls to functions with inherited BIP formals. For example:
--
-- type Iface is limited interface;
-- function Get_Object return Iface;
@@ -330,15 +329,14 @@ package body Exp_Ch6 is
-- type T1 is new Root1 and Iface with ...
-- function Get_Object return T1;
-- -- This primitive requires the BIP formals, and the evaluation of
- -- -- Is_True_Build_In_Place_Function_Call returns True.
+ -- -- Is_Build_In_Place_Function_Call returns True.
--
-- type Root2 is tagged record ...
-- type T2 is new Root2 and Iface with ...
-- function Get_Object return T2;
-- -- This primitive inherits the BIP formals of the interface primitive
-- -- but, given that T2 is not a limited type, it does not require such
- -- -- formals; therefore Is_True_Build_In_Place_Function_Call returns
- -- -- False.
+ -- -- formals; therefore Is_Build_In_Place_Function_Call returns False.
procedure Replace_Renaming_Declaration_Id
(New_Decl : Node_Id;
@@ -4906,8 +4904,8 @@ package body Exp_Ch6 is
-- inherited the BIP extra actuals but does not require them.
if Nkind (Call_Node) = N_Function_Call
- and then Is_Build_In_Place_Function_Call (Call_Node)
- and then not Is_True_Build_In_Place_Function_Call (Call_Node)
+ and then Is_Function_Call_With_BIP_Formals (Call_Node)
+ and then not Is_Build_In_Place_Function_Call (Call_Node)
then
Add_Dummy_Build_In_Place_Actuals (Subp,
Num_Added_Extra_Actuals => Num_Extra_Actuals);
@@ -4918,8 +4916,8 @@ package body Exp_Ch6 is
-- inherited the BIP extra actuals but does not require them.
elsif Nkind (Call_Node) = N_Function_Call
- and then Is_Build_In_Place_Function_Call (Call_Node)
- and then not Is_True_Build_In_Place_Function_Call (Call_Node)
+ and then Is_Function_Call_With_BIP_Formals (Call_Node)
+ and then not Is_Build_In_Place_Function_Call (Call_Node)
then
Add_Dummy_Build_In_Place_Actuals (Subp);
end if;
@@ -5614,7 +5612,7 @@ package body Exp_Ch6 is
pragma Assert (Ekind (Current_Subprogram) = E_Function);
pragma Assert
(Is_Build_In_Place_Function (Current_Subprogram) =
- Is_True_Build_In_Place_Function_Call (Exp));
+ Is_Build_In_Place_Function_Call (Exp));
null;
end if;
@@ -6803,17 +6801,6 @@ package body Exp_Ch6 is
end if;
end if;
- -- Assert that if F says "return G(...);"
- -- then F and G are both b-i-p, or neither b-i-p.
-
- if Nkind (Exp) = N_Function_Call then
- pragma Assert (Ekind (Scope_Id) = E_Function);
- pragma Assert
- (Is_Build_In_Place_Function (Scope_Id) =
- Is_True_Build_In_Place_Function_Call (Exp));
- null;
- end if;
-
-- For the case of a simple return that does not come from an
-- extended return, in the case of build-in-place, we rewrite
-- "return <expression>;" to be:
@@ -6833,7 +6820,7 @@ package body Exp_Ch6 is
pragma Assert
(Comes_From_Extended_Return_Statement (N)
- or else not Is_True_Build_In_Place_Function_Call (Exp)
+ or else not Is_Build_In_Place_Function_Call (Exp)
or else Has_BIP_Formals (Scope_Id));
if not Comes_From_Extended_Return_Statement (N)
@@ -6868,6 +6855,17 @@ package body Exp_Ch6 is
end;
end if;
+ -- Assert that if F says "return G(...);"
+ -- then F and G are both b-i-p, or neither b-i-p.
+
+ if Nkind (Exp) = N_Function_Call then
+ pragma Assert (Ekind (Scope_Id) = E_Function);
+ pragma Assert
+ (Is_Build_In_Place_Function (Scope_Id) =
+ Is_Build_In_Place_Function_Call (Exp));
+ null;
+ end if;
+
-- Here we have a simple return statement that is part of the expansion
-- of an extended return statement (either written by the user, or
-- generated by the above code).
@@ -8155,64 +8153,90 @@ package body Exp_Ch6 is
raise Program_Error;
end if;
- if Is_Build_In_Place_Function (Function_Id) then
- return True;
-
- -- True also if the function has BIP Formals
-
- else
- declare
- Kind : constant Entity_Kind := Ekind (Function_Id);
-
- begin
- if (Kind in E_Function | E_Generic_Function
- or else (Kind = E_Subprogram_Type
- and then
- Etype (Function_Id) /= Standard_Void_Type))
- and then Has_BIP_Formals (Function_Id)
- then
- -- So we can stop here in the debugger
- return True;
- else
- return False;
- end if;
- end;
- end if;
+ declare
+ Result : constant Boolean := Is_Build_In_Place_Function (Function_Id);
+ -- So we can stop here in the debugger
+ begin
+ return Result;
+ end;
end Is_Build_In_Place_Function_Call;
- ------------------------------------------
- -- Is_True_Build_In_Place_Function_Call --
- ------------------------------------------
+ ---------------------------------------
+ -- Is_Function_Call_With_BIP_Formals --
+ ---------------------------------------
- function Is_True_Build_In_Place_Function_Call (N : Node_Id) return Boolean
- is
- Exp_Node : Node_Id;
+ function Is_Function_Call_With_BIP_Formals (N : Node_Id) return Boolean is
+ Exp_Node : constant Node_Id := Unqual_Conv (N);
Function_Id : Entity_Id;
begin
- -- No action needed if we know that this is not a BIP function call
+ -- Return False if the expander is currently inactive, since awareness
+ -- of build-in-place treatment is only relevant during expansion. Note
+ -- that Is_Build_In_Place_Function, which is called as part of this
+ -- function, is also conditioned this way, but we need to check here as
+ -- well to avoid blowing up on processing protected calls when expansion
+ -- is disabled (such as with -gnatc) since those would trip over the
+ -- raise of Program_Error below.
+
+ -- In SPARK mode, build-in-place calls are not expanded, so that we
+ -- may end up with a call that is neither resolved to an entity, nor
+ -- an indirect call.
- if not Is_Build_In_Place_Function_Call (N) then
+ if not Expander_Active or else Nkind (Exp_Node) /= N_Function_Call then
return False;
end if;
- Exp_Node := Unqual_Conv (N);
-
if Is_Entity_Name (Name (Exp_Node)) then
Function_Id := Entity (Name (Exp_Node));
+ -- In the case of an explicitly dereferenced call, use the subprogram
+ -- type generated for the dereference.
+
elsif Nkind (Name (Exp_Node)) = N_Explicit_Dereference then
Function_Id := Etype (Name (Exp_Node));
+ -- This may be a call to a protected function.
+
elsif Nkind (Name (Exp_Node)) = N_Selected_Component then
+ -- The selector in question might not have been analyzed due to a
+ -- previous error, so analyze it here to output the appropriate
+ -- error message instead of crashing when attempting to fetch its
+ -- entity.
+
+ if not Analyzed (Selector_Name (Name (Exp_Node))) then
+ Analyze (Selector_Name (Name (Exp_Node)));
+ end if;
+
Function_Id := Etype (Entity (Selector_Name (Name (Exp_Node))));
else
raise Program_Error;
end if;
- return Is_Build_In_Place_Function (Function_Id);
- end Is_True_Build_In_Place_Function_Call;
+ if Is_Build_In_Place_Function (Function_Id) then
+ return True;
+
+ -- True also if the function has BIP Formals
+
+ else
+ declare
+ Kind : constant Entity_Kind := Ekind (Function_Id);
+
+ begin
+ if (Kind in E_Function | E_Generic_Function
+ or else (Kind = E_Subprogram_Type
+ and then
+ Etype (Function_Id) /= Standard_Void_Type))
+ and then Has_BIP_Formals (Function_Id)
+ then
+ -- So we can stop here in the debugger
+ return True;
+ else
+ return False;
+ end if;
+ end;
+ end if;
+ end Is_Function_Call_With_BIP_Formals;
-----------------------------------
-- Is_Build_In_Place_Result_Type --
@@ -8368,14 +8392,6 @@ package body Exp_Ch6 is
Func_Call := Expression (Func_Call);
end if;
- -- No action needed if the called function inherited the BIP extra
- -- formals but it is not a true BIP function.
-
- if not Is_True_Build_In_Place_Function_Call (Func_Call) then
- pragma Assert (Is_Expanded_Build_In_Place_Call (Func_Call));
- return;
- end if;
-
-- Mark the call as processed as a build-in-place call
pragma Assert (not Is_Expanded_Build_In_Place_Call (Func_Call));
@@ -8781,14 +8797,6 @@ package body Exp_Ch6 is
Result_Subt : Entity_Id;
begin
- -- No action needed if the called function inherited the BIP extra
- -- formals but it is not a true BIP function.
-
- if not Is_True_Build_In_Place_Function_Call (Func_Call) then
- pragma Assert (Is_Expanded_Build_In_Place_Call (Func_Call));
- return;
- end if;
-
-- Mark the call as processed as a build-in-place call
pragma Assert (not Is_Expanded_Build_In_Place_Call (Func_Call));
@@ -159,8 +159,7 @@ package Exp_Ch6 is
function Is_Build_In_Place_Function_Call (N : Node_Id) return Boolean;
-- Ada 2005 (AI-318-02): Returns True if N denotes a call to a function
-- that requires handling as a build-in-place call (possibly qualified or
- -- converted); that is, BIP function calls, and calls to functions with
- -- inherited BIP formals.
+ -- converted).
function Is_Build_In_Place_Result_Type (Typ : Entity_Id) return Boolean;
-- Ada 2005 (AI-318-02): Returns True if functions returning the type use