exp_ch6.adb: (Make_Build_In_Place_Call_In_Object_Declaration): Remove the code at the end of...

gcc/ada/

2017-10-09  Bob Duff  <duff@adacore.com>

	* exp_ch6.adb: (Make_Build_In_Place_Call_In_Object_Declaration): Remove
	the code at the end of this procedure that was setting the type of a
	class-wide object to the specific type returned by a function call.
	Treat this case as indefinite instead.

2017-10-09  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch4.adb (Try_Class_Wide_Operation, Traverse_Homonyms):
	Suppress spurious ambiguity error when two traversals of the homonym
	chain (first directly, and then through an examination of relevant
	interfaces) retrieve the same operation, when other irrelevant homonyms
	of the operatioh are also present.

2017-10-09  Ed Schonberg  <schonberg@adacore.com>

	* sem_util.adb (Object_Access_Level): If the object is the return
	statement of an expression function, return the level of the function.
	This is relevant when the object involves an implicit conversion
	between access types and the expression function is a completion, which
	forces the analysis of the expression before rewriting it as a body, so
	that freeze nodes can appear in the proper scope.

2017-10-09  Bob Duff  <duff@adacore.com>

	* atree.adb: Make nnd apply to everything "interesting", including
	Rewrite.  Remove rrd.

2017-10-09  Javier Miranda  <miranda@adacore.com>

	* exp_ch3.adb (Expand_N_Object_Declaration): Avoid never-ending loop
	processing the declaration of the dummy object internally created by
	Make_DT to compute the offset to the top of components referencing
	secondary dispatch tables.
	(Initialize_Tag): Do not initialize the offset-to-top field if it has
	been initialized initialized.
	* exp_disp.ads (Building_Static_Secondary_DT): New subprogram.
	* exp_disp.adb (Building_Static_Secondary_DT): New subprogram.
	(Make_DT): Create a dummy constant object if we can statically build
	secondary dispatch tables.
	(Make_Secondary_DT): For statically allocated secondary dispatch tables
	use the dummy object to compute the offset-to-top field value by means
	of the attribute 'Position.

gcc/testsuite/

2017-10-09  Ed Schonberg  <schonberg@adacore.com>

	* gnat.dg/class_wide3.adb, gnat.dg/class_wide3_pkg.ads: New testcase.

From-SVN: r253550

gcc/ada/ChangeLog

 2017-10-09  Bob Duff  <duff@adacore.com>
 
+	* exp_ch6.adb: (Make_Build_In_Place_Call_In_Object_Declaration): Remove
+	the code at the end of this procedure that was setting the type of a
+	class-wide object to the specific type returned by a function call.
+	Treat this case as indefinite instead.
+
+2017-10-09  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_ch4.adb (Try_Class_Wide_Operation, Traverse_Homonyms):
+	Suppress spurious ambiguity error when two traversals of the homonym
+	chain (first directly, and then through an examination of relevant
+	interfaces) retrieve the same operation, when other irrelevant homonyms
+	of the operatioh are also present.
+
+2017-10-09  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_util.adb (Object_Access_Level): If the object is the return
+	statement of an expression function, return the level of the function.
+	This is relevant when the object involves an implicit conversion
+	between access types and the expression function is a completion, which
+	forces the analysis of the expression before rewriting it as a body, so
+	that freeze nodes can appear in the proper scope.
+
+2017-10-09  Bob Duff  <duff@adacore.com>
+
+	* atree.adb: Make nnd apply to everything "interesting", including
+	Rewrite.  Remove rrd.
+
+2017-10-09  Javier Miranda  <miranda@adacore.com>
+
+	* exp_ch3.adb (Expand_N_Object_Declaration): Avoid never-ending loop
+	processing the declaration of the dummy object internally created by
+	Make_DT to compute the offset to the top of components referencing
+	secondary dispatch tables.
+	(Initialize_Tag): Do not initialize the offset-to-top field if it has
+	been initialized initialized.
+	* exp_disp.ads (Building_Static_Secondary_DT): New subprogram.
+	* exp_disp.adb (Building_Static_Secondary_DT): New subprogram.
+	(Make_DT): Create a dummy constant object if we can statically build
+	secondary dispatch tables.
+	(Make_Secondary_DT): For statically allocated secondary dispatch tables
+	use the dummy object to compute the offset-to-top field value by means
+	of the attribute 'Position.
+
+2017-10-09  Bob Duff  <duff@adacore.com>
+
 	* exp_ch6.adb (Expand_N_Extended_Return_Statement): Add self-checking
 	code so if BIPAlloc is not passed in, it will likely raise
 	Program_Error instead of cause miscellaneous chaos.

gcc/ada/atree.adb

@@ -73,11 +73,12 @@ package body Atree is
    --     ww := 12345
    --  and set a breakpoint on New_Node_Breakpoint (nickname "nn"). Continue.
 
-   --  Either way, gnat1 will stop when node 12345 is created
+   --  Either way, gnat1 will stop when node 12345 is created, or certain other
+   --  interesting operations are performed, such as Rewrite. To see exactly
+   --  which operations, search for "pragma Debug" below.
 
-   --  The second method is much faster
-
-   --  Similarly, rr and rrd allow breaking on rewriting of a given node
+   --  The second method is much faster if the amount of Ada code being
+   --  compiled is large.
 
    ww : Node_Id'Base := Node_Id'First - 1;
    pragma Export (Ada, ww); --  trick the optimizer
@@ -103,24 +104,8 @@ package body Atree is
    --  If Node = Watch_Node, this prints out the new node and calls
    --  New_Node_Breakpoint. Otherwise, does nothing.
 
-   procedure rr;
-   pragma Export (Ada, rr);
-   procedure Rewrite_Breakpoint renames rr;
-   --  This doesn't do anything interesting; it's just for setting breakpoint
-   --  on as explained above.
-
-   procedure rrd (Old_Node, New_Node : Node_Id);
-   pragma Export (Ada, rrd);
-   procedure Rewrite_Debugging_Output
-     (Old_Node, New_Node : Node_Id) renames rrd;
-   --  For debugging. If debugging is turned on, Rewrite calls this. If debug
-   --  flag N is turned on, this prints out the new node.
-   --
-   --  If Old_Node = Watch_Node, this prints out the old and new nodes and
-   --  calls Rewrite_Breakpoint. Otherwise, does nothing.
-
    procedure Node_Debug_Output (Op : String; N : Node_Id);
-   --  Common code for nnd and rrd, writes Op followed by information about N
+   --  Called by nnd; writes Op followed by information about N
 
    procedure Print_Statistics;
    pragma Export (Ada, Print_Statistics);
@@ -751,6 +736,8 @@ package body Atree is
       Save_Link    : constant Union_Id := Nodes.Table (Destination).Link;
 
    begin
+      pragma Debug (New_Node_Debugging_Output (Source));
+      pragma Debug (New_Node_Debugging_Output (Destination));
       Nodes.Table (Destination)         := Nodes.Table (Source);
       Nodes.Table (Destination).In_List := Save_In_List;
       Nodes.Table (Destination).Link    := Save_Link;
@@ -1348,6 +1335,8 @@ package body Atree is
       Temp_Flg : Flags_Byte;
 
    begin
+      pragma Debug (New_Node_Debugging_Output (E1));
+      pragma Debug (New_Node_Debugging_Output (E2));
       pragma Assert (True
         and then Has_Extension (E1)
         and then Has_Extension (E2)
@@ -1746,7 +1735,6 @@ package body Atree is
    begin
       Write_Str ("Watched node ");
       Write_Int (Int (Watch_Node));
-      Write_Str (" created");
       Write_Eol;
    end nn;
 
@@ -1759,7 +1747,7 @@ package body Atree is
 
    begin
       if Debug_Flag_N or else Node_Is_Watched then
-         Node_Debug_Output ("Allocate", N);
+         Node_Debug_Output ("Node", N);
 
          if Node_Is_Watched then
             New_Node_Breakpoint;
@@ -2163,6 +2151,8 @@ package body Atree is
         (not Has_Extension (Old_Node)
           and not Has_Extension (New_Node)
           and not Nodes.Table (New_Node).In_List);
+      pragma Debug (New_Node_Debugging_Output (Old_Node));
+      pragma Debug (New_Node_Debugging_Output (New_Node));
 
       --  Do copy, preserving link and in list status and required flags
 
@@ -2214,7 +2204,8 @@ package body Atree is
         (not Has_Extension (Old_Node)
           and not Has_Extension (New_Node)
           and not Nodes.Table (New_Node).In_List);
-      pragma Debug (Rewrite_Debugging_Output (Old_Node, New_Node));
+      pragma Debug (New_Node_Debugging_Output (Old_Node));
+      pragma Debug (New_Node_Debugging_Output (New_Node));
 
       if Nkind (Old_Node) in N_Subexpr then
          Old_Paren_Count     := Paren_Count (Old_Node);
@@ -2264,36 +2255,6 @@ package body Atree is
       end if;
    end Rewrite;
 
-   -------------------------
-   -- Rewrite_Breakpoint --
-   -------------------------
-
-   procedure rr is
-   begin
-      Write_Str ("Watched node ");
-      Write_Int (Int (Watch_Node));
-      Write_Str (" rewritten");
-      Write_Eol;
-   end rr;
-
-   ------------------------------
-   -- Rewrite_Debugging_Output --
-   ------------------------------
-
-   procedure rrd (Old_Node, New_Node : Node_Id) is
-      Node_Is_Watched : constant Boolean := Old_Node = Watch_Node;
-
-   begin
-      if Debug_Flag_N or else Node_Is_Watched then
-         Node_Debug_Output ("Rewrite", Old_Node);
-         Node_Debug_Output ("into",    New_Node);
-
-         if Node_Is_Watched then
-            Rewrite_Breakpoint;
-         end if;
-      end if;
-   end rrd;
-
    ------------------
    -- Set_Analyzed --
    ------------------

gcc/ada/exp_ch3.adb

@@ -6138,6 +6138,19 @@ package body Exp_Ch3 is
          return;
       end if;
 
+      --  No action needed for the internal imported dummy object added by
+      --  Make_DT to compute the offset of the components that reference
+      --  secondary dispatch tables; required to avoid never-ending loop
+      --  processing this internal object declaration.
+
+      if Tagged_Type_Expansion
+        and then Is_Internal (Def_Id)
+        and then Is_Imported (Def_Id)
+        and then Related_Type (Def_Id) = Implementation_Base_Type (Typ)
+      then
+         return;
+      end if;
+
       --  First we do special processing for objects of a tagged type where
       --  this is the point at which the type is frozen. The creation of the
       --  dispatch table and the initialization procedure have to be deferred
@@ -8384,10 +8397,13 @@ package body Exp_Ch3 is
          --  Normal case: No discriminants in the parent type
 
          else
-            --  Don't need to set any value if this interface shares the
-            --  primary dispatch table.
+            --  Don't need to set any value if the offset-to-top field is
+            --  statically set or if this interface shares the primary
+            --  dispatch table.
 
-            if not Is_Ancestor (Iface, Typ, Use_Full_View => True) then
+            if not Building_Static_Secondary_DT (Typ)
+              and then not Is_Ancestor (Iface, Typ, Use_Full_View => True)
+            then
                Append_To (Stmts_List,
                  Build_Set_Static_Offset_To_Top (Loc,
                    Iface_Tag    => New_Occurrence_Of (Iface_Tag, Loc),

gcc/ada/exp_ch6.adb

@@ -5024,16 +5024,15 @@ package body Exp_Ch6 is
                --  existing object for use as the return object. If the value
                --  is two, then the return object must be allocated on the
                --  secondary stack. Otherwise, the object must be allocated in
-               --  a storage pool (currently only supported for the global
-               --  heap, user-defined storage pools TBD ???). We generate an
-               --  if statement to test the implicit allocation formal and
-               --  initialize a local access value appropriately, creating
-               --  allocators in the secondary stack and global heap cases.
-               --  The special formal also exists and must be tested when the
-               --  function has a tagged result, even when the result subtype
-               --  is constrained, because in general such functions can be
-               --  called in dispatching contexts and must be handled similarly
-               --  to functions with a class-wide result.
+               --  a storage pool. We generate an if statement to test the
+               --  implicit allocation formal and initialize a local access
+               --  value appropriately, creating allocators in the secondary
+               --  stack and global heap cases.  The special formal also exists
+               --  and must be tested when the function has a tagged result,
+               --  even when the result subtype is constrained, because in
+               --  general such functions can be called in dispatching contexts
+               --  and must be handled similarly to functions with a class-wide
+               --  result.
 
                if not Is_Constrained (Ret_Typ)
                  or else Is_Tagged_Type (Underlying_Type (Ret_Typ))
@@ -8192,7 +8191,28 @@ package body Exp_Ch6 is
      (Obj_Decl      : Node_Id;
       Function_Call : Node_Id)
    is
+      function Get_Function_Id (Func_Call : Node_Id) return Entity_Id;
+      --  Get the value of Function_Id, below
+
+      function Get_Function_Id (Func_Call : Node_Id) return Entity_Id is
+      begin
+         if Is_Entity_Name (Name (Func_Call)) then
+            return Entity (Name (Func_Call));
+
+         elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then
+            return Etype (Name (Func_Call));
+
+         else
+            raise Program_Error;
+         end if;
+      end Get_Function_Id;
+
+      Func_Call       : constant Node_Id   := Unqual_Conv (Function_Call);
+      Function_Id     : constant Entity_Id := Get_Function_Id (Func_Call);
+      Result_Subt     : constant Entity_Id := Etype (Function_Id);
+
       Obj_Def_Id : constant Entity_Id  := Defining_Identifier (Obj_Decl);
+      Obj_Typ    : constant Entity_Id  := Etype (Obj_Def_Id);
       Encl_Func  : constant Entity_Id  := Enclosing_Subprogram (Obj_Def_Id);
       Loc        : constant Source_Ptr := Sloc (Function_Call);
       Obj_Loc    : constant Source_Ptr := Sloc (Obj_Decl);
@@ -8201,15 +8221,21 @@ package body Exp_Ch6 is
       Caller_Object   : Node_Id;
       Def_Id          : Entity_Id;
       Fmaster_Actual  : Node_Id := Empty;
-      Func_Call       : constant Node_Id := Unqual_Conv (Function_Call);
-      Function_Id     : Entity_Id;
       Pool_Actual     : Node_Id;
       Designated_Type : Entity_Id;
       Ptr_Typ         : Entity_Id;
       Ptr_Typ_Decl    : Node_Id;
       Pass_Caller_Acc : Boolean := False;
       Res_Decl        : Node_Id;
-      Result_Subt     : Entity_Id;
+
+      Definite : constant Boolean :=
+                   Caller_Known_Size (Func_Call, Result_Subt)
+                   and then not Is_Class_Wide_Type (Obj_Typ);
+      --  In the case of "X : T'Class := F(...);", where F returns a
+      --  Caller_Known_Size (specific) tagged type, we treat it as
+      --  indefinite, because the code for the Definite case below sets the
+      --  initialization expression of the object to Empty, which would be
+      --  illegal Ada, and would cause gigi to mis-allocate X.
 
    begin
       --  Mark the call as processed as a build-in-place call
@@ -8217,345 +8243,311 @@ package body Exp_Ch6 is
       pragma Assert (not Is_Expanded_Build_In_Place_Call (Func_Call));
       Set_Is_Expanded_Build_In_Place_Call (Func_Call);
 
-      if Is_Entity_Name (Name (Func_Call)) then
-         Function_Id := Entity (Name (Func_Call));
+      --  Create an access type designating the function's result subtype.
+      --  We use the type of the original call because it may be a call to an
+      --  inherited operation, which the expansion has replaced with the parent
+      --  operation that yields the parent type. Note that this access type
+      --  must be declared before we establish a transient scope, so that it
+      --  receives the proper accessibility level.
 
-      elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then
-         Function_Id := Etype (Name (Func_Call));
+      if Is_Class_Wide_Type (Obj_Typ)
+        and then not Is_Interface (Obj_Typ)
+        and then not Is_Class_Wide_Type (Etype (Function_Call))
+      then
+         Designated_Type := Obj_Typ;
+      else
+         Designated_Type := Etype (Function_Call);
+      end if;
 
+      Ptr_Typ := Make_Temporary (Loc, 'A');
+      Ptr_Typ_Decl :=
+        Make_Full_Type_Declaration (Loc,
+          Defining_Identifier => Ptr_Typ,
+          Type_Definition     =>
+            Make_Access_To_Object_Definition (Loc,
+              All_Present        => True,
+              Subtype_Indication =>
+                New_Occurrence_Of (Designated_Type, Loc)));
+
+      --  The access type and its accompanying object must be inserted after
+      --  the object declaration in the constrained case, so that the function
+      --  call can be passed access to the object. In the indefinite case, or
+      --  if the object declaration is for a return object, the access type and
+      --  object must be inserted before the object, since the object
+      --  declaration is rewritten to be a renaming of a dereference of the
+      --  access object. Note: we need to freeze Ptr_Typ explicitly, because
+      --  the result object is in a different (transient) scope, so won't cause
+      --  freezing.
+
+      if Definite
+        and then not Is_Return_Object (Obj_Def_Id)
+      then
+         Insert_After_And_Analyze (Obj_Decl, Ptr_Typ_Decl);
       else
-         raise Program_Error;
+         Insert_Action (Obj_Decl, Ptr_Typ_Decl);
       end if;
 
-      Result_Subt := Etype (Function_Id);
+      --  Force immediate freezing of Ptr_Typ because Res_Decl will be
+      --  elaborated in an inner (transient) scope and thus won't cause
+      --  freezing by itself. It's not an itype, but it needs to be frozen
+      --  inside the current subprogram (see Freeze_Outside in freeze.adb).
+
+      Freeze_Itype (Ptr_Typ, Ptr_Typ_Decl);
+
+      --  If the object is a return object of an enclosing build-in-place
+      --  function, then the implicit build-in-place parameters of the
+      --  enclosing function are simply passed along to the called function.
+      --  (Unfortunately, this won't cover the case of extension aggregates
+      --  where the ancestor part is a build-in-place indefinite function
+      --  call that should be passed along the caller's parameters.
+      --  Currently those get mishandled by reassigning the result of the
+      --  call to the aggregate return object, when the call result should
+      --  really be directly built in place in the aggregate and not in a
+      --  temporary. ???)
+
+      if Is_Return_Object (Obj_Def_Id) then
+         Pass_Caller_Acc := True;
+
+         --  When the enclosing function has a BIP_Alloc_Form formal then we
+         --  pass it along to the callee (such as when the enclosing
+         --  function has an unconstrained or tagged result type).
+
+         if Needs_BIP_Alloc_Form (Encl_Func) then
+            if RTE_Available (RE_Root_Storage_Pool_Ptr) then
+               Pool_Actual :=
+                 New_Occurrence_Of
+                   (Build_In_Place_Formal
+                     (Encl_Func, BIP_Storage_Pool), Loc);
 
-      declare
-         Definite : constant Boolean :=
-                      Caller_Known_Size (Func_Call, Result_Subt);
+            --  The build-in-place pool formal is not built on e.g. ZFP
 
-      begin
-         --  Create an access type designating the function's result subtype.
-         --  We use the type of the original call because it may be a call to
-         --  an inherited operation, which the expansion has replaced with the
-         --  parent operation that yields the parent type. Note that this
-         --  access type must be declared before we establish a transient
-         --  scope, so that it receives the proper accessibility level.
-
-         if Is_Class_Wide_Type (Etype (Defining_Identifier (Obj_Decl)))
-           and then not Is_Interface (Etype (Defining_Identifier (Obj_Decl)))
-           and then not Is_Class_Wide_Type (Etype (Function_Call))
-         then
-            Designated_Type := Etype (Defining_Identifier (Obj_Decl));
-         else
-            Designated_Type := Etype (Function_Call);
-         end if;
+            else
+               Pool_Actual := Empty;
+            end if;
+
+            Add_Unconstrained_Actuals_To_Build_In_Place_Call
+              (Function_Call  => Func_Call,
+               Function_Id    => Function_Id,
+               Alloc_Form_Exp =>
+                 New_Occurrence_Of
+                   (Build_In_Place_Formal (Encl_Func, BIP_Alloc_Form), Loc),
+               Pool_Actual    => Pool_Actual);
+
+         --  Otherwise, if enclosing function has a definite result subtype,
+         --  then caller allocation will be used.
 
-         Ptr_Typ := Make_Temporary (Loc, 'A');
-         Ptr_Typ_Decl :=
-           Make_Full_Type_Declaration (Loc,
-             Defining_Identifier => Ptr_Typ,
-             Type_Definition     =>
-               Make_Access_To_Object_Definition (Loc,
-                 All_Present        => True,
-                 Subtype_Indication =>
-                   New_Occurrence_Of (Designated_Type, Loc)));
-
-         --  The access type and its accompanying object must be inserted after
-         --  the object declaration in the constrained case, so that the
-         --  function call can be passed access to the object. In the
-         --  indefinite case, or if the object declaration is for a return
-         --  object, the access type and object must be inserted before the
-         --  object, since the object declaration is rewritten to be a renaming
-         --  of a dereference of the access object. Note: we need to freeze
-         --  Ptr_Typ explicitly, because the result object is in a different
-         --  (transient) scope, so won't cause freezing.
-
-         if Definite
-           and then not Is_Return_Object (Defining_Identifier (Obj_Decl))
-         then
-            Insert_After_And_Analyze (Obj_Decl, Ptr_Typ_Decl);
          else
-            Insert_Action (Obj_Decl, Ptr_Typ_Decl);
+            Add_Unconstrained_Actuals_To_Build_In_Place_Call
+              (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
          end if;
 
-         --  Force immediate freezing of Ptr_Typ because Res_Decl will be
-         --  elaborated in an inner (transient) scope and thus won't cause
-         --  freezing by itself. It's not an itype, but it needs to be frozen
-         --  inside the current subprogram (see Freeze_Outside in freeze.adb).
-
-         Freeze_Itype (Ptr_Typ, Ptr_Typ_Decl);
+         if Needs_BIP_Finalization_Master (Encl_Func) then
+            Fmaster_Actual :=
+              New_Occurrence_Of
+                (Build_In_Place_Formal
+                   (Encl_Func, BIP_Finalization_Master), Loc);
+         end if;
 
-         --  If the object is a return object of an enclosing build-in-place
-         --  function, then the implicit build-in-place parameters of the
-         --  enclosing function are simply passed along to the called function.
-         --  (Unfortunately, this won't cover the case of extension aggregates
-         --  where the ancestor part is a build-in-place indefinite function
-         --  call that should be passed along the caller's parameters.
-         --  Currently those get mishandled by reassigning the result of the
-         --  call to the aggregate return object, when the call result should
-         --  really be directly built in place in the aggregate and not in a
-         --  temporary. ???)
+         --  Retrieve the BIPacc formal from the enclosing function and convert
+         --  it to the access type of the callee's BIP_Object_Access formal.
 
-         if Is_Return_Object (Defining_Identifier (Obj_Decl)) then
-            Pass_Caller_Acc := True;
+         Caller_Object :=
+           Make_Unchecked_Type_Conversion (Loc,
+             Subtype_Mark =>
+               New_Occurrence_Of
+                 (Etype
+                    (Build_In_Place_Formal
+                      (Function_Id, BIP_Object_Access)),
+                  Loc),
+             Expression   =>
+               New_Occurrence_Of
+                 (Build_In_Place_Formal (Encl_Func, BIP_Object_Access),
+                  Loc));
 
-            --  When the enclosing function has a BIP_Alloc_Form formal then we
-            --  pass it along to the callee (such as when the enclosing
-            --  function has an unconstrained or tagged result type).
+      --  In the definite case, add an implicit actual to the function call
+      --  that provides access to the declared object. An unchecked conversion
+      --  to the (specific) result type of the function is inserted to handle
+      --  the case where the object is declared with a class-wide type.
 
-            if Needs_BIP_Alloc_Form (Encl_Func) then
-               if RTE_Available (RE_Root_Storage_Pool_Ptr) then
-                  Pool_Actual :=
-                    New_Occurrence_Of
-                      (Build_In_Place_Formal
-                        (Encl_Func, BIP_Storage_Pool), Loc);
+      elsif Definite then
+         Caller_Object :=
+            Make_Unchecked_Type_Conversion (Loc,
+              Subtype_Mark => New_Occurrence_Of (Result_Subt, Loc),
+              Expression   => New_Occurrence_Of (Obj_Def_Id, Loc));
 
-               --  The build-in-place pool formal is not built on e.g. ZFP
+         --  When the function has a controlling result, an allocation-form
+         --  parameter must be passed indicating that the caller is allocating
+         --  the result object. This is needed because such a function can be
+         --  called as a dispatching operation and must be treated similarly to
+         --  functions with indefinite result subtypes.
 
-               else
-                  Pool_Actual := Empty;
-               end if;
+         Add_Unconstrained_Actuals_To_Build_In_Place_Call
+           (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
 
-               Add_Unconstrained_Actuals_To_Build_In_Place_Call
-                 (Function_Call  => Func_Call,
-                  Function_Id    => Function_Id,
-                  Alloc_Form_Exp =>
-                    New_Occurrence_Of
-                      (Build_In_Place_Formal (Encl_Func, BIP_Alloc_Form), Loc),
-                  Pool_Actual    => Pool_Actual);
+      --  The allocation for indefinite library-level objects occurs on the
+      --  heap as opposed to the secondary stack. This accommodates DLLs where
+      --  the secondary stack is destroyed after each library unload. This is a
+      --  hybrid mechanism where a stack-allocated object lives on the heap.
 
-            --  Otherwise, if enclosing function has a definite result subtype,
-            --  then caller allocation will be used.
+      elsif Is_Library_Level_Entity (Obj_Def_Id)
+        and then not Restriction_Active (No_Implicit_Heap_Allocations)
+      then
+         Add_Unconstrained_Actuals_To_Build_In_Place_Call
+           (Func_Call, Function_Id, Alloc_Form => Global_Heap);
+         Caller_Object := Empty;
 
-            else
-               Add_Unconstrained_Actuals_To_Build_In_Place_Call
-                 (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
-            end if;
+         --  Create a finalization master for the access result type to ensure
+         --  that the heap allocation can properly chain the object and later
+         --  finalize it when the library unit goes out of scope.
 
-            if Needs_BIP_Finalization_Master (Encl_Func) then
-               Fmaster_Actual :=
-                 New_Occurrence_Of
-                   (Build_In_Place_Formal
-                      (Encl_Func, BIP_Finalization_Master), Loc);
-            end if;
+         if Needs_Finalization (Etype (Func_Call)) then
+            Build_Finalization_Master
+              (Typ            => Ptr_Typ,
+               For_Lib_Level  => True,
+               Insertion_Node => Ptr_Typ_Decl);
 
-            --  Retrieve the BIPacc formal from the enclosing function and
-            --  convert it to the access type of the callee's BIP_Object_Access
-            --  formal.
-
-            Caller_Object :=
-              Make_Unchecked_Type_Conversion (Loc,
-                Subtype_Mark =>
-                  New_Occurrence_Of
-                    (Etype
-                       (Build_In_Place_Formal
-                         (Function_Id, BIP_Object_Access)),
-                     Loc),
-                Expression   =>
-                  New_Occurrence_Of
-                    (Build_In_Place_Formal (Encl_Func, BIP_Object_Access),
-                     Loc));
-
-         --  In the definite case, add an implicit actual to the function call
-         --  that provides access to the declared object. An unchecked
-         --  conversion to the (specific) result type of the function is
-         --  inserted to handle the case where the object is declared with a
-         --  class-wide type.
-
-         elsif Definite then
-            Caller_Object :=
-               Make_Unchecked_Type_Conversion (Loc,
-                 Subtype_Mark => New_Occurrence_Of (Result_Subt, Loc),
-                 Expression   => New_Occurrence_Of (Obj_Def_Id, Loc));
-
-            --  When the function has a controlling result, an allocation-form
-            --  parameter must be passed indicating that the caller is
-            --  allocating the result object. This is needed because such a
-            --  function can be called as a dispatching operation and must be
-            --  treated similarly to functions with indefinite result subtypes.
+            Fmaster_Actual :=
+              Make_Attribute_Reference (Loc,
+                Prefix         =>
+                  New_Occurrence_Of (Finalization_Master (Ptr_Typ), Loc),
+                Attribute_Name => Name_Unrestricted_Access);
+         end if;
 
-            Add_Unconstrained_Actuals_To_Build_In_Place_Call
-              (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
+      --  In other indefinite cases, pass an indication to do the allocation on
+      --  the secondary stack and set Caller_Object to Empty so that a null
+      --  value will be passed for the caller's object address. A transient
+      --  scope is established to ensure eventual cleanup of the result.
 
-         --  The allocation for indefinite library-level objects occurs on the
-         --  heap as opposed to the secondary stack. This accommodates DLLs
-         --  where the secondary stack is destroyed after each library
-         --  unload. This is a hybrid mechanism where a stack-allocated object
-         --  lives on the heap.
+      else
+         Add_Unconstrained_Actuals_To_Build_In_Place_Call
+           (Func_Call, Function_Id, Alloc_Form => Secondary_Stack);
+         Caller_Object := Empty;
 
-         elsif Is_Library_Level_Entity (Defining_Identifier (Obj_Decl))
-           and then not Restriction_Active (No_Implicit_Heap_Allocations)
-         then
-            Add_Unconstrained_Actuals_To_Build_In_Place_Call
-              (Func_Call, Function_Id, Alloc_Form => Global_Heap);
-            Caller_Object := Empty;
+         Establish_Transient_Scope (Obj_Decl, Sec_Stack => True);
+      end if;
 
-            --  Create a finalization master for the access result type to
-            --  ensure that the heap allocation can properly chain the object
-            --  and later finalize it when the library unit goes out of scope.
+      --  Pass along any finalization master actual, which is needed in the
+      --  case where the called function initializes a return object of an
+      --  enclosing build-in-place function.
 
-            if Needs_Finalization (Etype (Func_Call)) then
-               Build_Finalization_Master
-                 (Typ            => Ptr_Typ,
-                  For_Lib_Level  => True,
-                  Insertion_Node => Ptr_Typ_Decl);
+      Add_Finalization_Master_Actual_To_Build_In_Place_Call
+        (Func_Call  => Func_Call,
+         Func_Id    => Function_Id,
+         Master_Exp => Fmaster_Actual);
 
-               Fmaster_Actual :=
-                 Make_Attribute_Reference (Loc,
-                   Prefix         =>
-                     New_Occurrence_Of (Finalization_Master (Ptr_Typ), Loc),
-                   Attribute_Name => Name_Unrestricted_Access);
-            end if;
+      if Nkind (Parent (Obj_Decl)) = N_Extended_Return_Statement
+        and then Has_Task (Result_Subt)
+      then
+         --  Here we're passing along the master that was passed in to this
+         --  function.
 
-         --  In other indefinite cases, pass an indication to do the allocation
-         --  on the secondary stack and set Caller_Object to Empty so that a
-         --  null value will be passed for the caller's object address. A
-         --  transient scope is established to ensure eventual cleanup of the
-         --  result.
+         Add_Task_Actuals_To_Build_In_Place_Call
+           (Func_Call, Function_Id,
+            Master_Actual =>
+              New_Occurrence_Of
+                (Build_In_Place_Formal (Encl_Func, BIP_Task_Master), Loc));
 
-         else
-            Add_Unconstrained_Actuals_To_Build_In_Place_Call
-              (Func_Call, Function_Id, Alloc_Form => Secondary_Stack);
-            Caller_Object := Empty;
+      else
+         Add_Task_Actuals_To_Build_In_Place_Call
+           (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster));
+      end if;
 
-            Establish_Transient_Scope (Obj_Decl, Sec_Stack => True);
-         end if;
+      Add_Access_Actual_To_Build_In_Place_Call
+        (Func_Call,
+         Function_Id,
+         Caller_Object,
+         Is_Access => Pass_Caller_Acc);
 
-         --  Pass along any finalization master actual, which is needed in the
-         --  case where the called function initializes a return object of an
-         --  enclosing build-in-place function.
+      --  Finally, create an access object initialized to a reference to the
+      --  function call. We know this access value cannot be null, so mark the
+      --  entity accordingly to suppress the access check.
 
-         Add_Finalization_Master_Actual_To_Build_In_Place_Call
-           (Func_Call  => Func_Call,
-            Func_Id    => Function_Id,
-            Master_Exp => Fmaster_Actual);
+      Def_Id := Make_Temporary (Loc, 'R', Func_Call);
+      Set_Etype (Def_Id, Ptr_Typ);
+      Set_Is_Known_Non_Null (Def_Id);
 
-         if Nkind (Parent (Obj_Decl)) = N_Extended_Return_Statement
-           and then Has_Task (Result_Subt)
-         then
-            --  Here we're passing along the master that was passed in to this
-            --  function.
+      if Nkind (Function_Call) = N_Type_Conversion then
+         Res_Decl :=
+           Make_Object_Declaration (Loc,
+             Defining_Identifier => Def_Id,
+             Constant_Present    => True,
+             Object_Definition   => New_Occurrence_Of (Ptr_Typ, Loc),
+             Expression          =>
+             Make_Unchecked_Type_Conversion (Loc,
+                New_Occurrence_Of (Ptr_Typ, Loc),
+                Make_Reference (Loc, Relocate_Node (Func_Call))));
+      else
+         Res_Decl :=
+           Make_Object_Declaration (Loc,
+             Defining_Identifier => Def_Id,
+             Constant_Present    => True,
+             Object_Definition   => New_Occurrence_Of (Ptr_Typ, Loc),
+             Expression          =>
+               Make_Reference (Loc, Relocate_Node (Func_Call)));
+      end if;
 
-            Add_Task_Actuals_To_Build_In_Place_Call
-              (Func_Call, Function_Id,
-               Master_Actual =>
-                 New_Occurrence_Of
-                   (Build_In_Place_Formal (Encl_Func, BIP_Task_Master), Loc));
+      Insert_After_And_Analyze (Ptr_Typ_Decl, Res_Decl);
 
-         else
-            Add_Task_Actuals_To_Build_In_Place_Call
-              (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster));
-         end if;
+      --  If the result subtype of the called function is definite and is not
+      --  itself the return expression of an enclosing BIP function, then mark
+      --  the object as having no initialization.
 
-         Add_Access_Actual_To_Build_In_Place_Call
-           (Func_Call,
-            Function_Id,
-            Caller_Object,
-            Is_Access => Pass_Caller_Acc);
+      if Definite
+        and then not Is_Return_Object (Obj_Def_Id)
+      then
+         --  The related object declaration is encased in a transient block
+         --  because the build-in-place function call contains at least one
+         --  nested function call that produces a controlled transient
+         --  temporary:
 
-         --  Finally, create an access object initialized to a reference to the
-         --  function call. We know this access value cannot be null, so mark
-         --  the entity accordingly to suppress the access check.
+         --    Obj : ... := BIP_Func_Call (Ctrl_Func_Call);
 
-         Def_Id := Make_Temporary (Loc, 'R', Func_Call);
-         Set_Etype (Def_Id, Ptr_Typ);
-         Set_Is_Known_Non_Null (Def_Id);
+         --  Since the build-in-place expansion decouples the call from the
+         --  object declaration, the finalization machinery lacks the context
+         --  which prompted the generation of the transient block. To resolve
+         --  this scenario, store the build-in-place call.
 
-         if Nkind (Function_Call) = N_Type_Conversion then
-            Res_Decl :=
-              Make_Object_Declaration (Loc,
-                Defining_Identifier => Def_Id,
-                Constant_Present    => True,
-                Object_Definition   => New_Occurrence_Of (Ptr_Typ, Loc),
-                Expression          =>
-                Make_Unchecked_Type_Conversion (Loc,
-                   New_Occurrence_Of (Ptr_Typ, Loc),
-                   Make_Reference (Loc, Relocate_Node (Func_Call))));
-         else
-            Res_Decl :=
-              Make_Object_Declaration (Loc,
-                Defining_Identifier => Def_Id,
-                Constant_Present    => True,
-                Object_Definition   => New_Occurrence_Of (Ptr_Typ, Loc),
-                Expression          =>
-                  Make_Reference (Loc, Relocate_Node (Func_Call)));
+         if Scope_Is_Transient and then Node_To_Be_Wrapped = Obj_Decl then
+            Set_BIP_Initialization_Call (Obj_Def_Id, Res_Decl);
          end if;
 
-         Insert_After_And_Analyze (Ptr_Typ_Decl, Res_Decl);
-
-         --  If the result subtype of the called function is definite and is
-         --  not itself the return expression of an enclosing BIP function,
-         --  then mark the object as having no initialization.
-
-         if Definite
-           and then not Is_Return_Object (Defining_Identifier (Obj_Decl))
-         then
-            --  The related object declaration is encased in a transient block
-            --  because the build-in-place function call contains at least one
-            --  nested function call that produces a controlled transient
-            --  temporary:
-
-            --    Obj : ... := BIP_Func_Call (Ctrl_Func_Call);
-
-            --  Since the build-in-place expansion decouples the call from the
-            --  object declaration, the finalization machinery lacks the
-            --  context which prompted the generation of the transient
-            --  block. To resolve this scenario, store the build-in-place call.
-
-            if Scope_Is_Transient and then Node_To_Be_Wrapped = Obj_Decl then
-               Set_BIP_Initialization_Call (Obj_Def_Id, Res_Decl);
-            end if;
-
-            Set_Expression (Obj_Decl, Empty);
-            Set_No_Initialization (Obj_Decl);
-
-         --  In case of an indefinite result subtype, or if the call is the
-         --  return expression of an enclosing BIP function, rewrite the object
-         --  declaration as an object renaming where the renamed object is a
-         --  dereference of <function_Call>'reference:
-         --
-         --      Obj : Subt renames <function_call>'Ref.all;
+         Set_Expression (Obj_Decl, Empty);
+         Set_No_Initialization (Obj_Decl);
 
-         else
-            Call_Deref :=
-              Make_Explicit_Dereference (Obj_Loc,
-                Prefix => New_Occurrence_Of (Def_Id, Obj_Loc));
-
-            Rewrite (Obj_Decl,
-              Make_Object_Renaming_Declaration (Obj_Loc,
-                Defining_Identifier => Make_Temporary (Obj_Loc, 'D'),
-                Subtype_Mark =>
-                  New_Occurrence_Of (Designated_Type, Obj_Loc),
-                Name => Call_Deref));
-
-            Set_Renamed_Object (Defining_Identifier (Obj_Decl), Call_Deref);
-
-            --  If the original entity comes from source, then mark the new
-            --  entity as needing debug information, even though it's defined
-            --  by a generated renaming that does not come from source, so that
-            --  the Materialize_Entity flag will be set on the entity when
-            --  Debug_Renaming_Declaration is called during analysis.
-
-            if Comes_From_Source (Obj_Def_Id) then
-               Set_Debug_Info_Needed (Defining_Identifier (Obj_Decl));
-            end if;
+      --  In case of an indefinite result subtype, or if the call is the
+      --  return expression of an enclosing BIP function, rewrite the object
+      --  declaration as an object renaming where the renamed object is a
+      --  dereference of <function_Call>'reference:
+      --
+      --      Obj : Subt renames <function_call>'Ref.all;
 
-            Analyze (Obj_Decl);
-            Replace_Renaming_Declaration_Id
-              (Obj_Decl, Original_Node (Obj_Decl));
+      else
+         Call_Deref :=
+           Make_Explicit_Dereference (Obj_Loc,
+             Prefix => New_Occurrence_Of (Def_Id, Obj_Loc));
+
+         Rewrite (Obj_Decl,
+           Make_Object_Renaming_Declaration (Obj_Loc,
+             Defining_Identifier => Make_Temporary (Obj_Loc, 'D'),
+             Subtype_Mark =>
+               New_Occurrence_Of (Designated_Type, Obj_Loc),
+             Name => Call_Deref));
+
+         Set_Renamed_Object (Obj_Def_Id, Call_Deref);
+
+         --  If the original entity comes from source, then mark the new
+         --  entity as needing debug information, even though it's defined
+         --  by a generated renaming that does not come from source, so that
+         --  the Materialize_Entity flag will be set on the entity when
+         --  Debug_Renaming_Declaration is called during analysis.
+
+         if Comes_From_Source (Obj_Def_Id) then
+            Set_Debug_Info_Needed (Obj_Def_Id);
          end if;
-      end;
-
-      --  If the object entity has a class-wide Etype, then we need to change
-      --  it to the result subtype of the function call, because otherwise the
-      --  object will be class-wide without an explicit initialization and
-      --  won't be allocated properly by the back end. It seems unclean to make
-      --  such a revision to the type at this point, and we should try to
-      --  improve this treatment when build-in-place functions with class-wide
-      --  results are implemented. ???
 
-      if Is_Class_Wide_Type (Etype (Defining_Identifier (Obj_Decl))) then
-         Set_Etype (Defining_Identifier (Obj_Decl), Result_Subt);
+         Analyze (Obj_Decl);
+         Replace_Renaming_Declaration_Id
+           (Obj_Decl, Original_Node (Obj_Decl));
       end if;
    end Make_Build_In_Place_Call_In_Object_Declaration;
 

gcc/ada/exp_disp.adb

@@ -29,6 +29,7 @@ with Debug;    use Debug;
 with Einfo;    use Einfo;
 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_CG;   use Exp_CG;
@@ -300,6 +301,32 @@ package body Exp_Disp is
    end Building_Static_DT;
 
    ----------------------------------
+   -- Building_Static_Secondary_DT --
+   ----------------------------------
+
+   function Building_Static_Secondary_DT (Typ : Entity_Id) return Boolean is
+      Full_Typ : Entity_Id := Typ;
+      Root_Typ : Entity_Id := Root_Type (Typ);
+
+   begin
+      --  Handle private types
+
+      if Present (Full_View (Typ)) then
+         Full_Typ := Full_View (Typ);
+      end if;
+
+      if Present (Full_View (Root_Typ)) then
+         Root_Typ := Full_View (Root_Typ);
+      end if;
+
+      return Building_Static_DT (Full_Typ)
+        and then not Is_Interface (Full_Typ)
+        and then Has_Interfaces (Full_Typ)
+        and then (Full_Typ = Root_Typ
+                    or else not Is_Variable_Size_Record (Etype (Full_Typ)));
+   end Building_Static_Secondary_DT;
+
+   ----------------------------------
    -- Build_Static_Dispatch_Tables --
    ----------------------------------
 
@@ -1693,11 +1720,10 @@ package body Exp_Disp is
 
                if From_Limited_With (Actual_Typ) then
 
-                  --  If the type of the actual parameter comes from a
-                  --  limited with-clause and the non-limited view is already
-                  --  available, we replace the anonymous access type by
-                  --  a duplicate declaration whose designated type is the
-                  --  non-limited view.
+                  --  If the type of the actual parameter comes from a limited
+                  --  with_clause and the nonlimited view is already available,
+                  --  we replace the anonymous access type by a duplicate
+                  --  declaration whose designated type is the nonlimited view.
 
                   if Has_Non_Limited_View (Actual_DDT) then
                      Anon := New_Copy (Actual_Typ);
@@ -3755,6 +3781,11 @@ package body Exp_Disp is
       DT_Aggr : constant Elist_Id := New_Elmt_List;
       --  Entities marked with attribute Is_Dispatch_Table_Entity
 
+      Dummy_Object : Entity_Id := Empty;
+      --  Extra nonexistent object of type Typ internally used to compute the
+      --  offset to the components that reference secondary dispatch tables.
+      --  Used to statically allocate secondary dispatch tables.
+
       procedure Check_Premature_Freezing
         (Subp        : Entity_Id;
          Tagged_Type : Entity_Id;
@@ -3783,6 +3814,7 @@ package body Exp_Disp is
       procedure Make_Secondary_DT
         (Typ              : Entity_Id;
          Iface            : Entity_Id;
+         Iface_Comp       : Node_Id;
          Suffix_Index     : Int;
          Num_Iface_Prims  : Nat;
          Iface_DT_Ptr     : Entity_Id;
@@ -3941,6 +3973,7 @@ package body Exp_Disp is
       procedure Make_Secondary_DT
         (Typ              : Entity_Id;
          Iface            : Entity_Id;
+         Iface_Comp       : Node_Id;
          Suffix_Index     : Int;
          Num_Iface_Prims  : Nat;
          Iface_DT_Ptr     : Entity_Id;
@@ -4179,10 +4212,25 @@ package body Exp_Disp is
              Prefix         => New_Occurrence_Of (Predef_Prims, Loc),
              Attribute_Name => Name_Address));
 
-         --  Note: The correct value of Offset_To_Top will be set by the init
-         --  subprogram
+         --  If the location of the component that references this secondary
+         --  dispatch table is variable then we have not declared the internal
+         --  dummy object; the value of Offset_To_Top will be set by the init
+         --  subprogram.
 
-         Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0));
+         if No (Dummy_Object) then
+            Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0));
+
+         else
+            Append_To (DT_Aggr_List,
+              Make_Attribute_Reference (Loc,
+                Prefix         =>
+                  Make_Selected_Component (Loc,
+                    Prefix        =>
+                      New_Occurrence_Of (Dummy_Object, Loc),
+                    Selector_Name =>
+                      New_Occurrence_Of (Iface_Comp, Loc)),
+                Attribute_Name => Name_Position));
+         end if;
 
          --  Generate the Object Specific Data table required to dispatch calls
          --  through synchronized interfaces.
@@ -4407,15 +4455,16 @@ package body Exp_Disp is
 
          Append_Elmt (New_Node, DT_Aggr);
 
-         --  Note: Secondary dispatch tables cannot be declared constant
-         --  because the component Offset_To_Top is currently initialized
-         --  by the IP routine.
+         --  Note: Secondary dispatch tables are declared constant only if
+         --  we can compute their offset field by means of the extra dummy
+         --  object; otherwise they cannot be declared constant and the
+         --  Offset_To_Top component is initialized by the IP routine.
 
          Append_To (Result,
            Make_Object_Declaration (Loc,
              Defining_Identifier => Iface_DT,
              Aliased_Present     => True,
-             Constant_Present    => False,
+             Constant_Present    => Present (Dummy_Object),
 
              Object_Definition   =>
                Make_Subtype_Indication (Loc,
@@ -4678,6 +4727,93 @@ package body Exp_Disp is
          end;
       end if;
 
+      if Building_Static_Secondary_DT (Typ) then
+         declare
+            Cannot_Have_Null_Disc : Boolean := False;
+            Name_Dummy_Object     : constant Name_Id :=
+                                      New_External_Name (Tname,
+                                        'P', Suffix_Index => -1);
+         begin
+            Dummy_Object := Make_Defining_Identifier (Loc, Name_Dummy_Object);
+
+            --  Define the extra object imported and constant to avoid linker
+            --  errors (since this object is never declared). Required because
+            --  we implement RM 13.3(19) for exported and imported (variable)
+            --  objects by making them volatile.
+
+            Set_Is_Imported      (Dummy_Object);
+            Set_Ekind            (Dummy_Object, E_Constant);
+            Set_Is_True_Constant (Dummy_Object);
+            Set_Related_Type     (Dummy_Object, Typ);
+
+            --  The scope must be set now to call Get_External_Name
+
+            Set_Scope (Dummy_Object, Current_Scope);
+
+            Get_External_Name (Dummy_Object);
+            Set_Interface_Name (Dummy_Object,
+              Make_String_Literal (Loc, Strval => String_From_Name_Buffer));
+
+            --  Ensure proper Sprint output of this implicit importation
+
+            Set_Is_Internal (Dummy_Object);
+
+            if not Has_Discriminants (Typ) then
+               Append_To (Result,
+                 Make_Object_Declaration (Loc,
+                   Defining_Identifier => Dummy_Object,
+                   Constant_Present    => True,
+                   Object_Definition   => New_Occurrence_Of (Typ, Loc)));
+            else
+               declare
+                  Constr_List  : constant List_Id := New_List;
+                  Discrim      : Node_Id;
+
+               begin
+                  Discrim := First_Discriminant (Typ);
+                  while Present (Discrim) loop
+                     if Is_Discrete_Type (Etype (Discrim)) then
+                        Append_To (Constr_List,
+                          Make_Attribute_Reference (Loc,
+                            Prefix => New_Occurrence_Of (Etype (Discrim), Loc),
+                            Attribute_Name => Name_First));
+
+                     else
+                        pragma Assert (Is_Access_Type (Etype (Discrim)));
+                        Cannot_Have_Null_Disc :=
+                          Cannot_Have_Null_Disc
+                            or else Can_Never_Be_Null (Etype (Discrim));
+                        Append_To (Constr_List, Make_Null (Loc));
+                     end if;
+
+                     Next_Discriminant (Discrim);
+                  end loop;
+
+                  Append_To (Result,
+                    Make_Object_Declaration (Loc,
+                      Defining_Identifier => Dummy_Object,
+                      Constant_Present    => True,
+                      Object_Definition   =>
+                        Make_Subtype_Indication (Loc,
+                          Subtype_Mark => New_Occurrence_Of (Typ, Loc),
+                          Constraint   =>
+                            Make_Index_Or_Discriminant_Constraint (Loc,
+                              Constraints => Constr_List))));
+               end;
+            end if;
+
+            --  Given that the dummy object will not be declared at run time,
+            --  analyze its declaration with expansion disabled and warnings
+            --  and error messages ignored.
+
+            Expander_Mode_Save_And_Set (False);
+            Ignore_Errors_Enable := Ignore_Errors_Enable + 1;
+            Analyze (Last (Result), Suppress => All_Checks);
+            Ignore_Errors_Enable := Ignore_Errors_Enable - 1;
+            Expander_Mode_Restore;
+         end;
+      end if;
+
       --  Ada 2005 (AI-251): Build the secondary dispatch tables
 
       if Has_Interfaces (Typ) then
@@ -4704,6 +4840,7 @@ package body Exp_Disp is
              (Typ              => Typ,
               Iface            => Base_Type
                                     (Related_Type (Node (AI_Tag_Comp))),
+              Iface_Comp       => Node (AI_Tag_Comp),
               Suffix_Index     => Suffix_Index,
               Num_Iface_Prims  => UI_To_Int
                                     (DT_Entry_Count (Node (AI_Tag_Comp))),
@@ -4731,6 +4868,7 @@ package body Exp_Disp is
               (Typ              => Typ,
                Iface            => Base_Type
                                      (Related_Type (Node (AI_Tag_Comp))),
+               Iface_Comp       => Node (AI_Tag_Comp),
                Suffix_Index     => -1,
                Num_Iface_Prims  => UI_To_Int
                                      (DT_Entry_Count (Node (AI_Tag_Comp))),

gcc/ada/exp_disp.ads

@@ -174,6 +174,11 @@ package Exp_Disp is
    pragma Inline (Building_Static_DT);
    --  Returns true when building statically allocated dispatch tables
 
+   function Building_Static_Secondary_DT (Typ : Entity_Id) return Boolean;
+   pragma Inline (Building_Static_Secondary_DT);
+   --  Returns true when building statically allocated secondary dispatch
+   --  tables
+
    procedure Build_Static_Dispatch_Tables (N : Node_Id);
    --  N is a library level package declaration or package body. Build the
    --  static dispatch table of the tagged types defined at library level. In

gcc/ada/sem_ch4.adb

@@ -8860,7 +8860,7 @@ package body Sem_Ch4 is
             while Present (Hom) loop
                if Ekind_In (Hom, E_Procedure, E_Function)
                  and then (not Is_Hidden (Hom) or else In_Instance)
-                 and then Scope (Hom) = Scope (Anc_Type)
+                 and then Scope (Hom) = Scope (Base_Type (Anc_Type))
                  and then Present (First_Formal (Hom))
                  and then
                    (Base_Type (Etype (First_Formal (Hom))) = Cls_Type
@@ -8921,8 +8921,13 @@ package body Sem_Ch4 is
                         Success    => Success,
                         Skip_First => True);
 
+                     --  The same operation may be encountered on two homonym
+                     --  traversals, before and after looking at interfaces.
+                     --  Check for this case before reporting a real ambiguity.
+
                      if Present (Valid_Candidate (Success, Call_Node, Hom))
                        and then Nkind (Call_Node) /= N_Function_Call
+                       and then Hom /= Matching_Op
                      then
                         Error_Msg_NE ("ambiguous call to&", N, Hom);
                         Report_Ambiguity (Matching_Op);

gcc/ada/sem_util.adb

@@ -20383,6 +20383,17 @@ package body Sem_Util is
                                     (Nearest_Dynamic_Scope
                                        (Defining_Entity (Node_Par)));
 
+                        --  For a return statement within a function, return
+                        --  the depth of the function itself. This is not just
+                        --  a small optimization, but matters when analyzing
+                        --  the expression in an expression function before
+                        --  the body is created.
+
+                        when N_Simple_Return_Statement =>
+                           if Ekind (Current_Scope) = E_Function then
+                              return Scope_Depth (Current_Scope);
+                           end if;
+
                         when others =>
                            null;
                      end case;

gcc/testsuite/gnat.dg/class_wide3.adb

+with Ada.Text_IO; use Ada.Text_IO;
+with Class_Wide3_Pkg; use Class_Wide3_Pkg;
+
+procedure Class_Wide3 is
+   DC : Disc_Child := (N => 1, I => 3, J => 5);
+begin
+   DC.Put_Line;
+end Class_Wide3;

gcc/testsuite/gnat.dg/class_wide3_pkg.ads

+package Class_Wide3_Pkg is
+
+   type Iface is interface;
+   type Iface_Ptr is access all Iface'Class;
+
+   procedure Put_Line (I : Iface'Class);
+
+   type Root is tagged record
+      I : Integer;
+   end record;
+
+   type Disc_Child (N : Integer) is new Root and Iface with record
+      J : Integer;
+   end record;
+
+end Class_Wide3_Pkg;