[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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@274335 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 1cc1ef2850d6ecfdd55119029cb726b893f5504e..0c34ee8663cc120ec68cc4ac954de8acd682e17e 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,17 @@
+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

diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index 4fae37c491a079d84c8cc025688f819d4fd7d94c..8399c4c80daff91c5b9cb64722965265968c5e3b 100644 (file)
--- a/gcc/ada/exp_disp.adb
+++ b/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,16 +5587,22 @@ package body Exp_Disp is
 
                         pragma Assert (Present (Iface_Comp));
 
-                        Offset_To_Top :=
-                          Make_Op_Minus (Loc,
-                            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));
+                        if not
+                          Is_Variable_Size_Record (Etype (Scope (Iface_Comp)))
+                        then
+                           Offset_To_Top :=
+                             Make_Op_Minus (Loc,
+                               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));
+                        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 =>

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 839772170dec16fec4fca5d8a1f5e395f138352e..265d991154fa265c4b681661131ce7e7a08f7de0 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+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.

diff --git a/gcc/testsuite/gnat.dg/tag2.adb b/gcc/testsuite/gnat.dg/tag2.adb
new file mode 100644 (file)
index 0000000..77e4842
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/tag2.adb
@@ -0,0 +1,20 @@
+--  { 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;

diff --git a/gcc/testsuite/gnat.dg/tag2_pkg.ads b/gcc/testsuite/gnat.dg/tag2_pkg.ads
new file mode 100644 (file)
index 0000000..3fd5923
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/tag2_pkg.ads
@@ -0,0 +1,16 @@
+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;