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.

6 files changed, 418 insertions, 151 deletions

diff --git a/gcc/ada/einfo-utils.adb b/gcc/ada/einfo-utils.adb
index 7fe5171..cb9a00d 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 d7690d9..9773928 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 db27a5f..04c3ad8 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 2e3a2b3..0d1f1fb 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 2eee892..95c5f18 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 4e64833..53011f4 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