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_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;