@@ -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 =>
new file mode 100644
@@ -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;
new file mode 100644
@@ -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;