public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc r14-2847] ada: Fix unsupported dispatching constructor call
@ 2023-07-28 7:31 Marc Poulhi?s
0 siblings, 0 replies; only message in thread
From: Marc Poulhi?s @ 2023-07-28 7:31 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:358e289d37b011ff113f5c70dee777c15679743a
commit r14-2847-g358e289d37b011ff113f5c70dee777c15679743a
Author: Javier Miranda <miranda@adacore.com>
Date: Sun Jul 9 17:34:18 2023 +0000
ada: Fix unsupported dispatching constructor call
Add dummy build-in-place parameters when a BIP function does not
require the BIP parameters but it is a dispatching operation that
inherited them.
gcc/ada/
* einfo-utils.adb (Underlying_Type): Protect recursion call
against non-available attribute Etype.
* einfo.ads (Protected_Subprogram): Fix typo in documentation.
* exp_ch3.adb (BIP_Function_Call_Id): New subprogram.
(Expand_N_Object_Declaration): Improve code that evaluates if the
object is initialized with a BIP function call.
* exp_ch6.adb (Is_True_Build_In_Place_Function_Call): New
subprogram.
(Add_Task_Actuals_To_Build_In_Place_Call): Add dummy actuals if
the function does not require the BIP task actuals but it is a
dispatching operation that inherited them.
(Build_In_Place_Formal): Improve code to avoid never-ending loop
if the BIP formal is not found.
(Add_Dummy_Build_In_Place_Actuals): New subprogram.
(Expand_Call_Helper): Add calls to
Add_Dummy_Build_In_Place_Actuals.
(Expand_N_Extended_Return_Statement): Adjust assertion.
(Expand_Simple_Function_Return): Adjust assertion.
(Make_Build_In_Place_Call_In_Allocator): No action needed if the
called function inherited the BIP extra formals but it is not a
true BIP function.
(Make_Build_In_Place_Call_In_Assignment): Ditto.
* exp_intr.adb (Expand_Dispatching_Constructor_Call): Remove code
reporting unsupported case (since this patch adds support for it).
* sem_ch6.adb (Analyze_Subprogram_Body_Helper): Adding assertion
to ensure matching of BIP formals when setting the
Protected_Formal field of a protected subprogram to reference the
corresponding extra formal of the subprogram that implements it.
(Might_Need_BIP_Task_Actuals): New subprogram.
(Create_Extra_Formals): Improve code adding inherited extra
formals.
Diff:
---
gcc/ada/einfo-utils.adb | 2 +-
gcc/ada/einfo.ads | 2 +-
gcc/ada/exp_ch3.adb | 101 ++++++++++++++++++---
gcc/ada/exp_ch6.adb | 234 ++++++++++++++++++++++++++++++++++++++++++++----
gcc/ada/exp_intr.adb | 45 ----------
gcc/ada/sem_ch6.adb | 185 ++++++++++++++++++++++----------------
6 files changed, 418 insertions(+), 151 deletions(-)
diff --git a/gcc/ada/einfo-utils.adb b/gcc/ada/einfo-utils.adb
index 7fe517124d9..cb9a00dc4bb 100644
--- a/gcc/ada/einfo-utils.adb
+++ b/gcc/ada/einfo-utils.adb
@@ -3019,7 +3019,7 @@ package body Einfo.Utils is
-- Otherwise check for the case where we have a derived type or
-- subtype, and if so get the Underlying_Type of the parent type.
- elsif Etype (Id) /= Id then
+ elsif Present (Etype (Id)) and then Etype (Id) /= Id then
return Underlying_Type (Etype (Id));
-- Otherwise we have an incomplete or private type that has no full
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index d7690d9f88a..977392899f9 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -4112,7 +4112,7 @@ package Einfo is
-- Protected_Subprogram
-- Defined in functions and procedures. Set for the pair of subprograms
-- which emulate the runtime semantics of a protected subprogram. Denotes
--- the entity of the origial protected subprogram.
+-- the entity of the original protected subprogram.
-- Protection_Object
-- Applies to protected entries, entry families and subprograms. Denotes
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index db27a5f68b6..04c3ad8c631 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -6256,6 +6256,11 @@ package body Exp_Ch3 is
-- temporary. Func_Id is the enclosing function. Ret_Typ is the return
-- type of Func_Id. Alloc_Expr is the actual allocator.
+ function BIP_Function_Call_Id return Entity_Id;
+ -- If the object initialization expression is a call to a build-in-place
+ -- function, return the id of the called function; otherwise return
+ -- Empty.
+
procedure Count_Default_Sized_Task_Stacks
(Typ : Entity_Id;
Pri_Stacks : out Int;
@@ -6592,6 +6597,67 @@ package body Exp_Ch3 is
end if;
end Build_Heap_Or_Pool_Allocator;
+ --------------------------
+ -- BIP_Function_Call_Id --
+ --------------------------
+
+ function BIP_Function_Call_Id return Entity_Id is
+
+ function Func_Call_Id (Function_Call : Node_Id) return Entity_Id;
+ -- Return the id of the called function.
+
+ function Func_Call_Id (Function_Call : Node_Id) return Entity_Id is
+ Call_Node : constant Node_Id := Unqual_Conv (Function_Call);
+
+ begin
+ if Is_Entity_Name (Name (Call_Node)) then
+ return Entity (Name (Call_Node));
+
+ elsif Nkind (Name (Call_Node)) = N_Explicit_Dereference then
+ return Etype (Name (Call_Node));
+
+ else
+ pragma Assert (Nkind (Name (Call_Node)) = N_Selected_Component);
+ return Etype (Entity (Selector_Name (Name (Call_Node))));
+ end if;
+ end Func_Call_Id;
+
+ -- Local declarations
+
+ BIP_Func_Call : Node_Id;
+ Expr_Q : constant Node_Id := Unqual_Conv (Expr);
+
+ -- Start of processing for BIP_Function_Call_Id
+
+ begin
+ if Is_Build_In_Place_Function_Call (Expr_Q) then
+ return Func_Call_Id (Expr_Q);
+ end if;
+
+ BIP_Func_Call := Unqual_BIP_Iface_Function_Call (Expr_Q);
+
+ if Present (BIP_Func_Call) then
+
+ -- In the case of an explicitly dereferenced call, return the
+ -- subprogram type.
+
+ if Nkind (Name (BIP_Func_Call)) = N_Explicit_Dereference then
+ return Etype (Name (BIP_Func_Call));
+ else
+ pragma Assert (Is_Entity_Name (Name (BIP_Func_Call)));
+ return Entity (Name (BIP_Func_Call));
+ end if;
+
+ elsif Nkind (Expr_Q) = N_Reference
+ and then Is_Build_In_Place_Function_Call (Prefix (Expr_Q))
+ then
+ return Func_Call_Id (Prefix (Expr_Q));
+
+ else
+ return Empty;
+ end if;
+ end BIP_Function_Call_Id;
+
-------------------------------------
-- Count_Default_Sized_Task_Stacks --
-------------------------------------
@@ -7272,6 +7338,9 @@ package body Exp_Ch3 is
-- which case the init proc call must be inserted only after the bodies
-- of the shared variable procedures have been seen.
+ Has_BIP_Init_Expr : Boolean := False;
+ -- Whether the object is initialized with a BIP function call
+
Rewrite_As_Renaming : Boolean := False;
-- Whether to turn the declaration into a renaming at the end
@@ -7319,12 +7388,29 @@ package body Exp_Ch3 is
Init_After := Make_Shared_Var_Procs (N);
end if;
+ -- Determine whether the object is initialized with a BIP function call
+
+ if Present (Expr) then
+ Expr_Q := Unqualify (Expr);
+
+ Has_BIP_Init_Expr :=
+ Is_Build_In_Place_Function_Call (Expr_Q)
+ or else Present (Unqual_BIP_Iface_Function_Call (Expr_Q))
+ or else (Nkind (Expr_Q) = N_Reference
+ and then
+ Is_Build_In_Place_Function_Call (Prefix (Expr_Q)));
+ end if;
+
-- If tasks are being declared, make sure we have an activation chain
-- defined for the tasks (has no effect if we already have one), and
-- also that a Master variable is established (and that the appropriate
-- enclosing construct is established as a task master).
- if Has_Task (Typ) or else Might_Have_Tasks (Typ) then
+ if Has_Task (Typ)
+ or else Might_Have_Tasks (Typ)
+ or else (Has_BIP_Init_Expr
+ and then Needs_BIP_Task_Actuals (BIP_Function_Call_Id))
+ then
Build_Activation_Chain_Entity (N);
if Has_Task (Typ) then
@@ -7332,17 +7418,8 @@ package body Exp_Ch3 is
-- Handle objects initialized with BIP function calls
- elsif Present (Expr) then
- Expr_Q := Unqualify (Expr);
-
- if Is_Build_In_Place_Function_Call (Expr_Q)
- or else Present (Unqual_BIP_Iface_Function_Call (Expr_Q))
- or else (Nkind (Expr_Q) = N_Reference
- and then
- Is_Build_In_Place_Function_Call (Prefix (Expr_Q)))
- then
- Build_Master_Entity (Def_Id);
- end if;
+ elsif Has_BIP_Init_Expr then
+ Build_Master_Entity (Def_Id);
end if;
end if;
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 2e3a2b3edcc..0d1f1fb1c3b 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -312,6 +312,30 @@ 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;
+ -- 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:
+ --
+ -- type Iface is limited interface;
+ -- function Get_Object return Iface;
+ -- -- This function has BIP extra formals
+ --
+ -- type Root1 is limited tagged record ...
+ -- 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.
+ --
+ -- 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.
+
procedure Replace_Renaming_Declaration_Id
(New_Decl : Node_Id;
Orig_Decl : Node_Id);
@@ -481,6 +505,8 @@ package body Exp_Ch6 is
Desig_Typ : Entity_Id;
begin
+ pragma Assert (Present (Formal));
+
-- If there is a finalization master actual, such as the implicit
-- finalization master of an enclosing build-in-place function,
-- then this must be added as an extra actual of the call.
@@ -621,6 +647,27 @@ package body Exp_Ch6 is
-- No such extra parameters are needed if there are no tasks
if not Needs_BIP_Task_Actuals (Function_Id) then
+
+ -- However we must add dummy extra actuals if the function is
+ -- a dispatching operation that inherited these extra formals.
+
+ if Is_Dispatching_Operation (Function_Id)
+ and then Has_BIP_Extra_Formal (Function_Id, BIP_Task_Master)
+ then
+ Master_Formal :=
+ Build_In_Place_Formal (Function_Id, BIP_Task_Master);
+ Actual := Make_Integer_Literal (Loc, Uint_0);
+ Analyze_And_Resolve (Actual, Etype (Master_Formal));
+ Add_Extra_Actual_To_Call (Function_Call, Master_Formal, Actual);
+
+ Chain_Formal :=
+ Build_In_Place_Formal (Function_Id, BIP_Activation_Chain);
+ Chain_Actual := Make_Null (Loc);
+ Analyze_And_Resolve (Chain_Actual, Etype (Chain_Formal));
+ Add_Extra_Actual_To_Call
+ (Function_Call, Chain_Formal, Chain_Actual);
+ end if;
+
return;
end if;
@@ -894,8 +941,7 @@ package body Exp_Ch6 is
-- the Alias of an instance, which will cause the formals to have
-- "incorrect" names.
- loop
- pragma Assert (Present (Extra_Formal));
+ while Present (Extra_Formal) loop
declare
Name : constant String := Get_Name_String (Chars (Extra_Formal));
begin
@@ -907,6 +953,10 @@ package body Exp_Ch6 is
Next_Formal_With_Extras (Extra_Formal);
end loop;
+ if No (Extra_Formal) then
+ raise Program_Error;
+ end if;
+
return Extra_Formal;
end Build_In_Place_Formal;
@@ -2995,6 +3045,13 @@ package body Exp_Ch6 is
-- actuals and must be handled in a recursive fashion since they can
-- be embedded within each other.
+ procedure Add_Dummy_Build_In_Place_Actuals
+ (Function_Id : Entity_Id;
+ Num_Added_Extra_Actuals : Nat := 0);
+ -- Adds dummy actuals for the BIP extra formals of the called function.
+ -- Num_Added_Extra_Actuals is the number of non-BIP extra actuals added
+ -- to the actuals immediately before calling this subprogram.
+
procedure Add_Extra_Actual (Expr : Node_Id; EF : Entity_Id);
-- Adds an extra actual to the list of extra actuals. Expr is the
-- expression for the value of the actual, EF is the entity for the
@@ -3253,6 +3310,83 @@ package body Exp_Ch6 is
EF => Extra_Accessibility (Formal));
end Add_Cond_Expression_Extra_Actual;
+ --------------------------------------
+ -- Add_Dummy_Build_In_Place_Actuals --
+ --------------------------------------
+
+ procedure Add_Dummy_Build_In_Place_Actuals
+ (Function_Id : Entity_Id;
+ Num_Added_Extra_Actuals : Nat := 0)
+ is
+ Loc : constant Source_Ptr := Sloc (Call_Node);
+ Formal : Entity_Id := Extra_Formals (Function_Id);
+ Actual : Node_Id;
+ Skip_Extra : Nat;
+
+ begin
+ -- We never generate extra formals if expansion is not active because
+ -- we don't need them unless we are generating code. No action needed
+ -- for thunks since they propagate all their extra actuals.
+
+ if not Expander_Active
+ or else Is_Thunk (Current_Scope)
+ then
+ return;
+ end if;
+
+ -- Skip already-added non-BIP extra actuals
+
+ Skip_Extra := Num_Added_Extra_Actuals;
+ while Skip_Extra > 0 loop
+ pragma Assert (not Is_Build_In_Place_Entity (Formal));
+ Formal := Extra_Formal (Formal);
+ Skip_Extra := Skip_Extra - 1;
+ end loop;
+
+ -- Append the dummy BIP extra actuals
+
+ while Present (Formal) loop
+ pragma Assert (Is_Build_In_Place_Entity (Formal));
+
+ -- BIPalloc
+
+ if Etype (Formal) = Standard_Natural then
+ Actual := Make_Integer_Literal (Loc, Uint_0);
+ Analyze_And_Resolve (Actual, Standard_Natural);
+ Add_Extra_Actual_To_Call (N, Formal, Actual);
+
+ -- BIPtaskmaster
+
+ elsif Etype (Formal) = Standard_Integer then
+ Actual := Make_Integer_Literal (Loc, Uint_0);
+ Analyze_And_Resolve (Actual, Standard_Integer);
+ Add_Extra_Actual_To_Call (N, Formal, Actual);
+
+ -- BIPstoragepool, BIPfinalizationmaster, BIPactivationchain,
+ -- and BIPaccess.
+
+ elsif Is_Access_Type (Etype (Formal)) then
+ Actual := Make_Null (Loc);
+ Analyze_And_Resolve (Actual, Etype (Formal));
+ Add_Extra_Actual_To_Call (N, Formal, Actual);
+
+ else
+ pragma Assert (False);
+ raise Program_Error;
+ end if;
+
+ Formal := Extra_Formal (Formal);
+ end loop;
+
+ -- Mark the call as processed build-in-place call; required
+ -- to avoid adding the extra formals twice.
+
+ Set_Is_Expanded_Build_In_Place_Call (Call_Node);
+
+ pragma Assert (Check_Number_Of_Actuals (Call_Node, Function_Id));
+ pragma Assert (Check_BIP_Actuals (Call_Node, Function_Id));
+ end Add_Dummy_Build_In_Place_Actuals;
+
----------------------
-- Add_Extra_Actual --
----------------------
@@ -4698,10 +4832,35 @@ package body Exp_Ch6 is
-- During that loop we gathered the extra actuals (the ones that
-- correspond to Extra_Formals), so now they can be appended.
- else
- while Is_Non_Empty_List (Extra_Actuals) loop
- Add_Actual_Parameter (Remove_Head (Extra_Actuals));
- end loop;
+ elsif Is_Non_Empty_List (Extra_Actuals) then
+ declare
+ Num_Extra_Actuals : constant Nat := List_Length (Extra_Actuals);
+
+ begin
+ while Is_Non_Empty_List (Extra_Actuals) loop
+ Add_Actual_Parameter (Remove_Head (Extra_Actuals));
+ end loop;
+
+ -- Add dummy extra BIP actuals if we are calling a function that
+ -- 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)
+ then
+ Add_Dummy_Build_In_Place_Actuals (Subp,
+ Num_Added_Extra_Actuals => Num_Extra_Actuals);
+ end if;
+ end;
+
+ -- Add dummy extra BIP actuals if we are calling a function that
+ -- 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)
+ then
+ Add_Dummy_Build_In_Place_Actuals (Subp);
end if;
-- At this point we have all the actuals, so this is the point at which
@@ -5428,7 +5587,7 @@ package body Exp_Ch6 is
pragma Assert (Ekind (Current_Subprogram) = E_Function);
pragma Assert
(Is_Build_In_Place_Function (Current_Subprogram) =
- Is_Build_In_Place_Function_Call (Exp));
+ Is_True_Build_In_Place_Function_Call (Exp));
null;
end if;
@@ -6623,14 +6782,9 @@ package body Exp_Ch6 is
if Nkind (Exp) = N_Function_Call then
pragma Assert (Ekind (Scope_Id) = E_Function);
-
- -- This assertion works fine because Is_Build_In_Place_Function_Call
- -- returns True for BIP function calls but also for function calls
- -- that have BIP formals.
-
pragma Assert
- (Has_BIP_Formals (Scope_Id) =
- Is_Build_In_Place_Function_Call (Exp));
+ (Is_Build_In_Place_Function (Scope_Id) =
+ Is_True_Build_In_Place_Function_Call (Exp));
null;
end if;
@@ -6653,7 +6807,7 @@ package body Exp_Ch6 is
pragma Assert
(Comes_From_Extended_Return_Statement (N)
- or else not Is_Build_In_Place_Function_Call (Exp)
+ or else not Is_True_Build_In_Place_Function_Call (Exp)
or else Has_BIP_Formals (Scope_Id));
if not Comes_From_Extended_Return_Statement (N)
@@ -8000,6 +8154,40 @@ package body Exp_Ch6 is
end if;
end Is_Build_In_Place_Function_Call;
+ ------------------------------------------
+ -- Is_True_Build_In_Place_Function_Call --
+ ------------------------------------------
+
+ function Is_True_Build_In_Place_Function_Call (N : Node_Id) return Boolean
+ is
+ Exp_Node : Node_Id;
+ Function_Id : Entity_Id;
+
+ begin
+ -- No action needed if we know that this is not a BIP function call
+
+ if not Is_Build_In_Place_Function_Call (N) then
+ return False;
+ end if;
+
+ Exp_Node := Unqual_Conv (N);
+
+ if Is_Entity_Name (Name (Exp_Node)) then
+ Function_Id := Entity (Name (Exp_Node));
+
+ elsif Nkind (Name (Exp_Node)) = N_Explicit_Dereference then
+ Function_Id := Etype (Name (Exp_Node));
+
+ elsif Nkind (Name (Exp_Node)) = N_Selected_Component then
+ 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;
+
-----------------------------------
-- Is_Build_In_Place_Result_Type --
-----------------------------------
@@ -8154,6 +8342,14 @@ 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));
@@ -8559,6 +8755,14 @@ 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));
diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb
index 2eee892605e..95c5f18587e 100644
--- a/gcc/ada/exp_intr.adb
+++ b/gcc/ada/exp_intr.adb
@@ -24,16 +24,13 @@
------------------------------------------------------------------------------
with Atree; use Atree;
-with Aspects; use Aspects;
with Checks; use Checks;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Elists; use Elists;
-with Errout; use Errout;
with Expander; use Expander;
with Exp_Atag; use Exp_Atag;
-with Exp_Ch6; use Exp_Ch6;
with Exp_Ch7; use Exp_Ch7;
with Exp_Ch11; use Exp_Ch11;
with Exp_Code; use Exp_Code;
@@ -288,48 +285,6 @@ package body Exp_Intr is
begin
pragma Assert (Is_Class_Wide_Type (Etype (Entity (Name (N)))));
- -- Report case where we know that the generated code is wrong; that
- -- is a dispatching constructor call whose controlling type has tasks
- -- but its root type does not have tasks. In such case the constructor
- -- subprogram of the root type does not have extra formals but the
- -- constructor of the derivation must have extra formals.
-
- if not Global_No_Tasking
- and then not No_Run_Time_Mode
- and then Is_Build_In_Place_Function (Entity (Name (N)))
- and then not Has_Task (Root_Type (Etype (Entity (Name (N)))))
- and then not Has_Aspect (Root_Type (Etype (Entity (Name (N)))),
- Aspect_No_Task_Parts)
- then
- -- Case 1: Explicit tag reference (which allows static check)
-
- if Nkind (Tag_Arg) = N_Identifier
- and then Present (Entity (Tag_Arg))
- and then Is_Tag (Entity (Tag_Arg))
- then
- if Has_Task (Related_Type (Entity (Tag_Arg))) then
- Error_Msg_N ("unsupported dispatching constructor call", N);
- Error_Msg_NE
- ("\work around this problem by defining task component "
- & "type& using access-to-task-type",
- N, Related_Type (Entity (Tag_Arg)));
- end if;
-
- -- Case 2: Dynamic tag which may fail at run time
-
- else
- Error_Msg_N
- ("unsupported dispatching constructor call if the type "
- & "of the built object has task components??", N);
-
- Error_Msg_Sloc := Sloc (Root_Type (Etype (Entity (Name (N)))));
- Error_Msg_NE
- ("\work around this by adding ''with no_task_parts'' to "
- & "the declaration of the root type& defined#???",
- N, Root_Type (Etype (Entity (Name (N)))));
- end if;
- end if;
-
-- Remove side effects from tag argument early, before rewriting
-- the dispatching constructor call, as Remove_Side_Effects relies
-- on Tag_Arg's Parent link properly attached to the tree (once the
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 4e64833b3f7..53011f465a8 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -53,6 +53,7 @@ with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
with Output; use Output;
+with Restrict; use Restrict;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
@@ -4457,6 +4458,10 @@ package body Sem_Ch6 is
begin
while Present (Prot_Ext_Formal) loop
pragma Assert (Present (Impl_Ext_Formal));
+ pragma Assert (not Is_Build_In_Place_Entity (Prot_Ext_Formal)
+ or else BIP_Suffix_Kind (Impl_Ext_Formal)
+ = BIP_Suffix_Kind (Prot_Ext_Formal));
+
Set_Protected_Formal (Prot_Ext_Formal, Impl_Ext_Formal);
Next_Formal_With_Extras (Prot_Ext_Formal);
Next_Formal_With_Extras (Impl_Ext_Formal);
@@ -8581,6 +8586,11 @@ package body Sem_Ch6 is
function Has_Extra_Formals (E : Entity_Id) return Boolean;
-- Determines if E has its extra formals
+ function Might_Need_BIP_Task_Actuals (E : Entity_Id) return Boolean;
+ -- Determines if E is a dispatching primitive returning a limited tagged
+ -- type object since some descendant might return an object with tasks
+ -- (and therefore need the BIP task extra actuals).
+
function Needs_Accessibility_Check_Extra
(E : Entity_Id;
Formal : Node_Id) return Boolean;
@@ -8656,6 +8666,58 @@ package body Sem_Ch6 is
and then Present (Extra_Accessibility_Of_Result (E)));
end Has_Extra_Formals;
+ ---------------------------------
+ -- Might_Need_BIP_Task_Actuals --
+ ---------------------------------
+
+ function Might_Need_BIP_Task_Actuals (E : Entity_Id) return Boolean is
+ Subp_Id : Entity_Id;
+ Func_Typ : Entity_Id;
+
+ begin
+ if Global_No_Tasking or else No_Run_Time_Mode then
+ return False;
+ end if;
+
+ -- No further check needed if we know that BIP task actuals are
+ -- required.
+
+ if Needs_BIP_Task_Actuals (E) then
+ return True;
+ end if;
+
+ -- For thunks we must rely on their target entity
+
+ if Is_Thunk (E) then
+ Subp_Id := Thunk_Target (E);
+
+ -- For protected subprograms we rely on the subprogram which
+ -- implements the body of the operation (since it is the entity
+ -- that may be a dispatching operation).
+
+ elsif Is_Protected_Type (Scope (E))
+ and then Present (Protected_Body_Subprogram (E))
+ then
+ Subp_Id := Protected_Body_Subprogram (E);
+
+ else
+ Subp_Id := E;
+ end if;
+
+ -- We check the root type of the return type since the same
+ -- decision must be taken for all descendants overriding a
+ -- dispatching operation.
+
+ Func_Typ := Root_Type (Underlying_Type (Etype (Subp_Id)));
+
+ return Ekind (Subp_Id) = E_Function
+ and then not Has_Foreign_Convention (Func_Typ)
+ and then Is_Dispatching_Operation (Subp_Id)
+ and then Is_Tagged_Type (Func_Typ)
+ and then Is_Limited_Type (Func_Typ)
+ and then not Has_Aspect (Func_Typ, Aspect_No_Task_Parts);
+ end Might_Need_BIP_Task_Actuals;
+
-------------------------------------
-- Needs_Accessibility_Check_Extra --
-------------------------------------
@@ -8790,7 +8852,8 @@ package body Sem_Ch6 is
then
return;
- -- Initialization procedures don't have extra formals
+ -- Extra formals of Initialization procedures are added by the function
+ -- Exp_Ch3.Init_Formals
elsif Is_Init_Proc (E) then
return;
@@ -9076,20 +9139,16 @@ package body Sem_Ch6 is
begin
Ada_Version := Ada_2022;
- if Needs_Result_Accessibility_Level (Ref_E) then
- pragma Assert (No (Parent_Subp)
- or else Needs_Result_Accessibility_Level (Parent_Subp));
- pragma Assert (No (Alias_Subp)
- or else Needs_Result_Accessibility_Level (Alias_Subp));
-
+ if Needs_Result_Accessibility_Level (Ref_E)
+ or else
+ (Present (Parent_Subp)
+ and then Needs_Result_Accessibility_Level (Parent_Subp))
+ or else
+ (Present (Alias_Subp)
+ and then Needs_Result_Accessibility_Level (Alias_Subp))
+ then
Set_Extra_Accessibility_Of_Result (E,
Add_Extra_Formal (E, Standard_Natural, E, "L"));
-
- else
- pragma Assert (No (Parent_Subp)
- or else not Needs_Result_Accessibility_Level (Parent_Subp));
- pragma Assert (No (Alias_Subp)
- or else not Needs_Result_Accessibility_Level (Alias_Subp));
end if;
Ada_Version := Save_Ada_Version;
@@ -9124,14 +9183,16 @@ package body Sem_Ch6 is
-- dispatching context and such calls must be handled like calls
-- to a class-wide function.
- if Needs_BIP_Alloc_Form (Ref_E) then
- pragma Assert (No (Parent_Subp)
- or else Has_BIP_Extra_Formal (Parent_Subp, BIP_Alloc_Form,
- Must_Be_Frozen => False));
- pragma Assert (No (Alias_Subp)
- or else Has_BIP_Extra_Formal (Alias_Subp, BIP_Alloc_Form,
- Must_Be_Frozen => False));
-
+ if Needs_BIP_Alloc_Form (Ref_E)
+ or else
+ (Present (Parent_Subp)
+ and then Has_BIP_Extra_Formal (Parent_Subp, BIP_Alloc_Form,
+ Must_Be_Frozen => False))
+ or else
+ (Present (Alias_Subp)
+ and then Has_BIP_Extra_Formal (Alias_Subp, BIP_Alloc_Form,
+ Must_Be_Frozen => False))
+ then
Discard :=
Add_Extra_Formal
(E, Standard_Natural,
@@ -9147,87 +9208,57 @@ package body Sem_Ch6 is
(E, RTE (RE_Root_Storage_Pool_Ptr),
E, BIP_Formal_Suffix (BIP_Storage_Pool));
end if;
-
- else
- pragma Assert (No (Parent_Subp)
- or else not
- Has_BIP_Extra_Formal (Parent_Subp, BIP_Alloc_Form,
- Must_Be_Frozen => False));
- pragma Assert (No (Alias_Subp)
- or else not
- Has_BIP_Extra_Formal (Alias_Subp, BIP_Alloc_Form,
- Must_Be_Frozen => False));
end if;
-- In the case of functions whose result type needs finalization,
-- add an extra formal which represents the finalization master.
- if Needs_BIP_Finalization_Master (Ref_E) then
- pragma Assert (No (Parent_Subp)
- or else Has_BIP_Extra_Formal (Parent_Subp,
- Kind => BIP_Finalization_Master,
- Must_Be_Frozen => False));
- pragma Assert (No (Alias_Subp)
- or else Has_BIP_Extra_Formal (Alias_Subp,
- Kind => BIP_Finalization_Master,
- Must_Be_Frozen => False));
-
+ if Needs_BIP_Finalization_Master (Ref_E)
+ or else
+ (Present (Parent_Subp)
+ and then Has_BIP_Extra_Formal (Parent_Subp,
+ Kind => BIP_Finalization_Master,
+ Must_Be_Frozen => False))
+ or else
+ (Present (Alias_Subp)
+ and then Has_BIP_Extra_Formal (Alias_Subp,
+ Kind => BIP_Finalization_Master,
+ Must_Be_Frozen => False))
+ then
Discard :=
Add_Extra_Formal
(E, RTE (RE_Finalization_Master_Ptr),
E, BIP_Formal_Suffix (BIP_Finalization_Master));
-
- else
- pragma Assert (No (Parent_Subp)
- or else not
- Has_BIP_Extra_Formal (Parent_Subp,
- Kind => BIP_Finalization_Master,
- Must_Be_Frozen => False));
- pragma Assert (No (Alias_Subp)
- or else not
- Has_BIP_Extra_Formal (Alias_Subp,
- Kind => BIP_Finalization_Master,
- Must_Be_Frozen => False));
end if;
-- When the result type contains tasks, add two extra formals: the
-- master of the tasks to be created, and the caller's activation
-- chain.
- if Needs_BIP_Task_Actuals (Ref_E) then
- pragma Assert (No (Parent_Subp)
- or else Has_BIP_Extra_Formal (Parent_Subp, BIP_Task_Master,
- Must_Be_Frozen => False));
- pragma Assert (No (Alias_Subp)
- or else Has_BIP_Extra_Formal (Alias_Subp, BIP_Task_Master,
- Must_Be_Frozen => False)
- or else
- (Is_Abstract_Subprogram (Ref_E)
- and then Is_Predefined_Dispatching_Operation (Ref_E)
- and then Is_Interface
- (Find_Dispatching_Type (Alias_Subp))));
-
+ if Needs_BIP_Task_Actuals (Ref_E)
+ or else Might_Need_BIP_Task_Actuals (Ref_E)
+ or else
+ (Present (Parent_Subp)
+ and then Has_BIP_Extra_Formal (Parent_Subp, BIP_Task_Master,
+ Must_Be_Frozen => False))
+ or else
+ (Present (Alias_Subp)
+ and then Has_BIP_Extra_Formal (Alias_Subp, BIP_Task_Master,
+ Must_Be_Frozen => False))
+ then
Discard :=
Add_Extra_Formal
(E, Standard_Integer,
E, BIP_Formal_Suffix (BIP_Task_Master));
- Set_Has_Master_Entity (E);
+ if Needs_BIP_Task_Actuals (Ref_E) then
+ Set_Has_Master_Entity (E);
+ end if;
Discard :=
Add_Extra_Formal
(E, RTE (RE_Activation_Chain_Access),
E, BIP_Formal_Suffix (BIP_Activation_Chain));
-
- else
- pragma Assert (No (Parent_Subp)
- or else not
- Has_BIP_Extra_Formal (Parent_Subp, BIP_Task_Master,
- Must_Be_Frozen => False));
- pragma Assert (No (Alias_Subp)
- or else not
- Has_BIP_Extra_Formal (Alias_Subp, BIP_Task_Master,
- Must_Be_Frozen => False));
end if;
-- All build-in-place functions get an extra formal that will be
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2023-07-28 7:31 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2023-07-28 7:31 [gcc r14-2847] ada: Fix unsupported dispatching constructor call Marc Poulhi?s
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).