No functional changes.
Tested on x86_64-pc-linux-gnu, committed on trunk
gcc/ada/
* exp_disp.ads (Expand_Interface_Thunk): Change type of Prim.
* exp_disp.adb (Expand_Interface_Thunk): Declare Is_Predef_Op
earlier, do not initialize Iface_Formal, use No idiom and tweaks
comments.
(Register_Primitive): Declare L earlier and tweak comments.
* sem_disp.adb (Check_Dispatching_Operation): Move tests out of
loop.diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -1731,26 +1731,26 @@ package body Exp_Disp is
----------------------------
procedure Expand_Interface_Thunk
- (Prim : Node_Id;
+ (Prim : Entity_Id;
Thunk_Id : out Entity_Id;
Thunk_Code : out Node_Id;
Iface : Entity_Id)
is
- Loc : constant Source_Ptr := Sloc (Prim);
- Actuals : constant List_Id := New_List;
- Decl : constant List_Id := New_List;
- Formals : constant List_Id := New_List;
- Target : constant Entity_Id := Ultimate_Alias (Prim);
+ Actuals : constant List_Id := New_List;
+ Decl : constant List_Id := New_List;
+ Formals : constant List_Id := New_List;
+ Loc : constant Source_Ptr := Sloc (Prim);
+ Target : constant Entity_Id := Ultimate_Alias (Prim);
+ Is_Predef_Op : constant Boolean :=
+ Is_Predefined_Dispatching_Operation (Prim)
+ or else Is_Predefined_Dispatching_Operation (Target);
Decl_1 : Node_Id;
Decl_2 : Node_Id;
Expr : Node_Id;
Formal : Node_Id;
Ftyp : Entity_Id;
- Iface_Formal : Node_Id := Empty; -- initialize to prevent warning
- Is_Predef_Op : constant Boolean :=
- Is_Predefined_Dispatching_Operation (Prim)
- or else Is_Predefined_Dispatching_Operation (Target);
+ Iface_Formal : Node_Id;
New_Arg : Node_Id;
Offset_To_Top : Node_Id;
Target_Formal : Entity_Id;
@@ -1764,16 +1764,17 @@ package body Exp_Disp is
if Is_Eliminated (Target) then
return;
- -- In case of primitives that are functions without formals and a
- -- controlling result there is no need to build the thunk.
+ -- No thunk needed if the primitive has no formals. In this case, this
+ -- must be a function with a controlling result.
- elsif not Present (First_Formal (Target)) then
+ elsif No (First_Formal (Target)) then
pragma Assert (Ekind (Target) = E_Function
and then Has_Controlling_Result (Target));
+
return;
end if;
- -- Duplicate the formals of the Target primitive. In the thunk, the type
+ -- Duplicate the formals of the target primitive. In the thunk, the type
-- of the controlling formal is the covered interface type (instead of
-- the target tagged type). Done to avoid problems with discriminated
-- tagged types because, if the controlling type has discriminants with
@@ -1785,14 +1786,14 @@ package body Exp_Disp is
-- because they don't have available the Interface_Alias attribute (see
-- Sem_Ch3.Add_Internal_Interface_Entities).
- if not Is_Predef_Op then
+ if Is_Predef_Op then
+ Iface_Formal := Empty;
+ else
Iface_Formal := First_Formal (Interface_Alias (Prim));
end if;
Formal := First_Formal (Target);
while Present (Formal) loop
- Ftyp := Etype (Formal);
-
-- Use the interface type as the type of the controlling formal (see
-- comment above).
@@ -1814,10 +1815,10 @@ package body Exp_Disp is
-- Sanity check performed to ensure the proper controlling type
-- when the thunk has exactly one controlling parameter and it
- -- comes first. In such case the GCC backend reuses the C++
+ -- comes first. In such a case, the GCC back end reuses the C++
-- thunks machinery which perform a computation equivalent to
-- the code generated by the expander; for other cases the GCC
- -- backend translates the expanded code unmodified. However, as
+ -- back end translates the expanded code unmodified. However, as
-- a generalization, the check is performed for all controlling
-- types.
@@ -7115,12 +7116,13 @@ package body Exp_Disp is
(Loc : Source_Ptr;
Prim : Entity_Id) return List_Id
is
+ L : constant List_Id := New_List;
+
DT_Ptr : Entity_Id;
Iface_Prim : Entity_Id;
Iface_Typ : Entity_Id;
Iface_DT_Ptr : Entity_Id;
Iface_DT_Elmt : Elmt_Id;
- L : constant List_Id := New_List;
Pos : Uint;
Tag : Entity_Id;
Tag_Typ : Entity_Id;
@@ -7130,7 +7132,7 @@ package body Exp_Disp is
begin
pragma Assert (not Restriction_Active (No_Dispatching_Calls));
- -- Do not register in the dispatch table eliminated primitives
+ -- Do not register eliminated primitives in the dispatch table
if not RTE_Available (RE_Tag)
or else Is_Eliminated (Ultimate_Alias (Prim))
@@ -7139,10 +7141,12 @@ package body Exp_Disp is
return L;
end if;
+ -- Primitive associated with a tagged type
+
if not Present (Interface_Alias (Prim)) then
Tag_Typ := Scope (DTC_Entity (Prim));
- Pos := DT_Position (Prim);
- Tag := First_Tag_Component (Tag_Typ);
+ Pos := DT_Position (Prim);
+ Tag := First_Tag_Component (Tag_Typ);
if Is_Predefined_Dispatching_Operation (Prim)
or else Is_Predefined_Dispatching_Alias (Prim)
diff --git a/gcc/ada/exp_disp.ads b/gcc/ada/exp_disp.ads
--- a/gcc/ada/exp_disp.ads
+++ b/gcc/ada/exp_disp.ads
@@ -234,7 +234,7 @@ package Exp_Disp is
-- dispatch table of the target type.
procedure Expand_Interface_Thunk
- (Prim : Node_Id;
+ (Prim : Entity_Id;
Thunk_Id : out Entity_Id;
Thunk_Code : out Node_Id;
Iface : Entity_Id);
diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb
--- a/gcc/ada/sem_disp.adb
+++ b/gcc/ada/sem_disp.adb
@@ -1728,7 +1728,11 @@ package body Sem_Disp is
-- emitted after those tables are built, to prevent access before
-- elaboration in gigi.
- if Body_Is_Last_Primitive and then Expander_Active then
+ if Body_Is_Last_Primitive
+ and then not Building_Static_DT (Tagged_Type)
+ and then Expander_Active
+ and then Tagged_Type_Expansion
+ then
declare
Subp_Body : constant Node_Id := Unit_Declaration_Node (Subp);
Elmt : Elmt_Id;
@@ -1739,13 +1743,9 @@ package body Sem_Disp is
while Present (Elmt) loop
Prim := Node (Elmt);
- -- No code required to register primitives in VM targets
-
if Present (Alias (Prim))
and then Present (Interface_Alias (Prim))
and then Alias (Prim) = Subp
- and then not Building_Static_DT (Tagged_Type)
- and then Tagged_Type_Expansion
then
Insert_Actions_After (Subp_Body,
Register_Primitive (Sloc (Subp_Body), Prim => Prim));
