[Ada] Wrong initialization of Offset_To_Top in secondary DT

The compiler does not initialize well the runtime information required
to perform at runtime interface conversions on derivations of tagged
types that implement interfaces and have variable size components.

2019-08-13  Javier Miranda  <miranda@adacore.com>

gcc/ada/

	* exp_disp.adb (Make_Secondary_DT): Handle record type
	derivations that have interface components located at fixed
	positions and interface components located at variable offset.
	The offset of components located at fixed positions is computed
	using the dummy object (similar to the case where all the
	interface components are located at fixed positions).
	(Make_DT): Build the dummy object for all tagged types that
	implement interface types (that is, build it also for types with
	variable size components), and use the dummy object to compute
	the offset of all tag components located at fixed positions when
	initializing the Interface_Table object.

gcc/testsuite/

	* gnat.dg/tag2.adb, gnat.dg/tag2_pkg.ads: New testcase.

From-SVN: r274335

gcc/ada/ChangeLog

+2019-08-13  Javier Miranda  <miranda@adacore.com>
+
+	* exp_disp.adb (Make_Secondary_DT): Handle record type
+	derivations that have interface components located at fixed
+	positions and interface components located at variable offset.
+	The offset of components located at fixed positions is computed
+	using the dummy object (similar to the case where all the
+	interface components are located at fixed positions).
+	(Make_DT): Build the dummy object for all tagged types that
+	implement interface types (that is, build it also for types with
+	variable size components), and use the dummy object to compute
+	the offset of all tag components located at fixed positions when
+	initializing the Interface_Table object.
+
 2019-08-13  Justin Squirek  <squirek@adacore.com>
 
 	* gnatcmd.adb (GNATCmd): Add constant for new compiler switch

gcc/ada/exp_disp.adb

@@ -3764,7 +3764,7 @@ package body Exp_Disp is
       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.
+      --  Used to compute the offset of components located at fixed position.
 
       procedure Check_Premature_Freezing
         (Subp        : Entity_Id;
@@ -4191,14 +4191,16 @@ package body Exp_Disp is
              Prefix         => New_Occurrence_Of (Predef_Prims, Loc),
              Attribute_Name => Name_Address));
 
-         --  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.
+         --  Interface component located at variable offset; the value of
+         --  Offset_To_Top will be set by the init subprogram.
 
-         if No (Dummy_Object) then
+         if No (Dummy_Object)
+           or else Is_Variable_Size_Record (Etype (Scope (Iface_Comp)))
+         then
             Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0));
 
+         --  Interface component located at fixed offset
+
          else
             Append_To (DT_Aggr_List,
               Make_Op_Minus (Loc,
@@ -4444,7 +4446,7 @@ package body Exp_Disp is
            Make_Object_Declaration (Loc,
              Defining_Identifier => Iface_DT,
              Aliased_Present     => True,
-             Constant_Present    => Present (Dummy_Object),
+             Constant_Present    => Building_Static_Secondary_DT (Typ),
 
              Object_Definition   =>
                Make_Subtype_Indication (Loc,
@@ -4723,9 +4725,10 @@ package body Exp_Disp is
          end;
       end if;
 
-      if Building_Static_Secondary_DT (Typ) then
+      if not Is_Interface (Typ) and then Has_Interfaces (Typ) then
          declare
             Cannot_Have_Null_Disc : Boolean := False;
+            Dummy_Object_Typ      : constant Entity_Id := Typ;
             Name_Dummy_Object     : constant Name_Id :=
                                       New_External_Name (Tname,
                                         'P', Suffix_Index => -1);
@@ -4754,19 +4757,20 @@ package body Exp_Disp is
 
             Set_Is_Internal (Dummy_Object);
 
-            if not Has_Discriminants (Typ) then
+            if not Has_Discriminants (Dummy_Object_Typ) then
                Append_To (Result,
                  Make_Object_Declaration (Loc,
                    Defining_Identifier => Dummy_Object,
                    Constant_Present    => True,
-                   Object_Definition   => New_Occurrence_Of (Typ, Loc)));
+                   Object_Definition   => New_Occurrence_Of
+                                           (Dummy_Object_Typ, Loc)));
             else
                declare
                   Constr_List  : constant List_Id := New_List;
                   Discrim      : Node_Id;
 
                begin
-                  Discrim := First_Discriminant (Typ);
+                  Discrim := First_Discriminant (Dummy_Object_Typ);
                   while Present (Discrim) loop
                      if Is_Discrete_Type (Etype (Discrim)) then
                         Append_To (Constr_List,
@@ -4792,7 +4796,8 @@ package body Exp_Disp is
                       Constant_Present    => True,
                       Object_Definition   =>
                         Make_Subtype_Indication (Loc,
-                          Subtype_Mark => New_Occurrence_Of (Typ, Loc),
+                          Subtype_Mark =>
+                            New_Occurrence_Of (Dummy_Object_Typ, Loc),
                           Constraint   =>
                             Make_Index_Or_Discriminant_Constraint (Loc,
                               Constraints => Constr_List))));
@@ -5500,19 +5505,23 @@ package body Exp_Disp is
             declare
                TSD_Ifaces_List  : constant List_Id := New_List;
                Elmt             : Elmt_Id;
-               Ifaces_List      : Elist_Id := No_Elist;
-               Ifaces_Comp_List : Elist_Id := No_Elist;
-               Ifaces_Tag_List  : Elist_Id;
                Offset_To_Top    : Node_Id;
                Sec_DT_Tag       : Node_Id;
 
+               Dummy_Object_Ifaces_List      : Elist_Id := No_Elist;
+               Dummy_Object_Ifaces_Comp_List : Elist_Id := No_Elist;
+               Dummy_Object_Ifaces_Tag_List  : Elist_Id := No_Elist;
+               --  Interfaces information of the dummy object
+
             begin
                --  Collect interfaces information if we need to compute the
                --  offset to the top using the dummy object.
 
                if Present (Dummy_Object) then
                   Collect_Interfaces_Info (Typ,
-                    Ifaces_List, Ifaces_Comp_List, Ifaces_Tag_List);
+                    Ifaces_List     => Dummy_Object_Ifaces_List,
+                    Components_List => Dummy_Object_Ifaces_Comp_List,
+                    Tags_List       => Dummy_Object_Ifaces_Tag_List);
                end if;
 
                AI := First_Elmt (Typ_Ifaces);
@@ -5550,8 +5559,8 @@ package body Exp_Disp is
                          (Node (Next_Elmt (Next_Elmt (Elmt))), Loc);
                   end if;
 
-                  --  For static dispatch tables compute Offset_To_Top using
-                  --  the dummy object.
+                  --  Use the dummy object to compute Offset_To_Top of
+                  --  components located at fixed position.
 
                   if Present (Dummy_Object) then
                      declare
@@ -5561,8 +5570,10 @@ package body Exp_Disp is
                         Iface_Elmt       : Elmt_Id;
 
                      begin
-                        Iface_Elmt      := First_Elmt (Ifaces_List);
-                        Iface_Comp_Elmt := First_Elmt (Ifaces_Comp_List);
+                        Iface_Elmt :=
+                          First_Elmt (Dummy_Object_Ifaces_List);
+                        Iface_Comp_Elmt :=
+                          First_Elmt (Dummy_Object_Ifaces_Comp_List);
 
                         while Present (Iface_Elmt) loop
                            if Node (Iface_Elmt) = Iface then
@@ -5576,6 +5587,9 @@ package body Exp_Disp is
 
                         pragma Assert (Present (Iface_Comp));
 
+                        if not
+                          Is_Variable_Size_Record (Etype (Scope (Iface_Comp)))
+                        then
                            Offset_To_Top :=
                              Make_Op_Minus (Loc,
                                Make_Attribute_Reference (Loc,
@@ -5586,6 +5600,9 @@ package body Exp_Disp is
                                      Selector_Name =>
                                        New_Occurrence_Of (Iface_Comp, Loc)),
                                  Attribute_Name => Name_Position));
+                        else
+                           Offset_To_Top := Make_Integer_Literal (Loc, 0);
+                        end if;
                      end;
                   else
                      Offset_To_Top := Make_Integer_Literal (Loc, 0);
@@ -5634,7 +5651,7 @@ package body Exp_Disp is
                  Make_Object_Declaration (Loc,
                    Defining_Identifier => ITable,
                    Aliased_Present     => True,
-                   Constant_Present    => Present (Dummy_Object),
+                   Constant_Present    => Building_Static_Secondary_DT (Typ),
                    Object_Definition   =>
                      Make_Subtype_Indication (Loc,
                        Subtype_Mark =>

gcc/testsuite/ChangeLog

+2019-08-13  Javier Miranda  <miranda@adacore.com>
+
+	* gnat.dg/tag2.adb, gnat.dg/tag2_pkg.ads: New testcase.
+
 2019-08-13  Martin Liska  <mliska@suse.cz>
 
 	* gcc.dg/tree-prof/ic-misattribution-1.c: Use -fdump-ipa-profile-node.

gcc/testsuite/gnat.dg/tag2.adb

+--  { dg-do run }
+
+with Ada.Tags; use Ada.Tags;
+with Tag2_Pkg; use Tag2_Pkg;
+
+procedure Tag2 is
+
+   procedure Do_Add_Monitor (Monitor : in out Synchronous_Monitor) is
+      Name : constant String :=
+        Expanded_Name (Monitor_Interface'Class (Monitor)'Tag);
+   begin
+      if Name /= "TAG2_PKG.VIRTUAL_INTEGER_REGISTER_REFRESHER" then
+         raise Program_Error;
+      end if;
+   end;
+
+   Obj : Virtual_Integer_Register_Refresher (20);
+begin
+   Do_Add_Monitor (Synchronous_Monitor (Obj));
+end;

gcc/testsuite/gnat.dg/tag2_pkg.ads

+package Tag2_Pkg is
+   type Monitor_Interface is interface;
+
+   type Root is abstract tagged null record;
+
+   type Monitor_Type is abstract new Root
+      and Monitor_Interface with null record;
+
+   type Synchronous_Monitor (Size : Positive) is new Monitor_Type with
+   record
+      Queue : String (1 .. Size);
+   end record;
+
+   type Virtual_Integer_Register_Refresher (Size : Positive) is
+          new Synchronous_Monitor (Size) with null record;
+end;