[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
This commit is contained in:
Javier Miranda
Pierre-Marie de Rodat
parent
4c19aa6904
commit
7225a47971
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 =>
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
@ -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;
|
||||
Loading…
Reference in New Issue