ada: Use static references to tag in more cases for interface objects
This extends the use of static references to the interface tag in more cases for (class-wide) interface objects, e.g. for initialization expressions that are qualified aggregates or nondispatching calls returning a specific tagged type implementing the interface. gcc/ada/ * exp_util.ads (Has_Tag_Of_Type): Declare. * exp_util.adb (Has_Tag_Of_Type): Move to package level. Recurse on qualified expressions. * exp_ch3.adb (Expand_N_Object_Declaration): Use a static reference to the interface tag in more cases for class-wide interface objects.
This commit is contained in:
Eric Botcazou
Marc Poulhiès
parent
b7ed6c43a8
commit
39a7b60338
3 changed files with 95 additions and 93 deletions
|
|
@ -7564,7 +7564,7 @@ package body Exp_Ch3 is
|
|||
Expr_Q := Expr;
|
||||
end if;
|
||||
|
||||
-- We may use a renaming if the initializing expression is a
|
||||
-- We may use a renaming if the initialization expression is a
|
||||
-- captured function call that meets a few conditions.
|
||||
|
||||
Rewrite_As_Renaming := Is_Renamable_Function_Call (Expr_Q);
|
||||
|
|
@ -7621,41 +7621,6 @@ package body Exp_Ch3 is
|
|||
|
||||
Obj_Id := Make_Temporary (Loc, 'D', Expr_Q);
|
||||
|
||||
-- Replace
|
||||
-- CW : I'Class := Obj;
|
||||
-- by
|
||||
-- Dnn : Typ := Obj;
|
||||
-- type Ityp is not null access I'Class;
|
||||
-- Rnn : constant Ityp := Ityp (Dnn.I_Tag'Address);
|
||||
-- CW : I'Class renames Rnn.all;
|
||||
|
||||
if Comes_From_Source (Expr_Q)
|
||||
and then Is_Entity_Name (Expr_Q)
|
||||
and then not Is_Interface (Expr_Typ)
|
||||
and then Interface_Present_In_Ancestor (Expr_Typ, Typ)
|
||||
and then (Expr_Typ = Etype (Expr_Typ)
|
||||
or else not
|
||||
Is_Variable_Size_Record (Etype (Expr_Typ)))
|
||||
then
|
||||
-- Copy the object
|
||||
|
||||
Insert_Action (N,
|
||||
Make_Object_Declaration (Loc,
|
||||
Defining_Identifier => Obj_Id,
|
||||
Object_Definition =>
|
||||
New_Occurrence_Of (Expr_Typ, Loc),
|
||||
Expression => Relocate_Node (Expr_Q)));
|
||||
|
||||
-- Statically reference the tag associated with the
|
||||
-- interface
|
||||
|
||||
Tag_Comp :=
|
||||
Make_Selected_Component (Loc,
|
||||
Prefix => New_Occurrence_Of (Obj_Id, Loc),
|
||||
Selector_Name =>
|
||||
New_Occurrence_Of
|
||||
(Find_Interface_Tag (Expr_Typ, Iface), Loc));
|
||||
|
||||
-- Replace
|
||||
-- IW : I'Class := Expr;
|
||||
-- by
|
||||
|
|
@ -7665,7 +7630,7 @@ package body Exp_Ch3 is
|
|||
-- Ityp!(Displace (Dnn'Address, I'Tag));
|
||||
-- IW : I'Class renames Rnn.all;
|
||||
|
||||
elsif Rewrite_As_Renaming then
|
||||
if Rewrite_As_Renaming then
|
||||
New_Expr :=
|
||||
Make_Explicit_Dereference (Loc,
|
||||
Unchecked_Convert_To (RTE (RE_Tag_Ptr),
|
||||
|
|
@ -7697,6 +7662,37 @@ package body Exp_Ch3 is
|
|||
(Node (First_Elmt (Access_Disp_Table (Iface))),
|
||||
Loc)));
|
||||
|
||||
-- Replace
|
||||
-- IW : I'Class := Expr;
|
||||
-- by
|
||||
-- Dnn : Typ := Expr;
|
||||
-- type Ityp is not null access I'Class;
|
||||
-- Rnn : constant Ityp := Ityp (Dnn.I_Tag'Address);
|
||||
-- IW : I'Class renames Rnn.all;
|
||||
|
||||
elsif Has_Tag_Of_Type (Expr_Q)
|
||||
and then Interface_Present_In_Ancestor (Expr_Typ, Typ)
|
||||
and then (Expr_Typ = Etype (Expr_Typ)
|
||||
or else not
|
||||
Is_Variable_Size_Record (Etype (Expr_Typ)))
|
||||
then
|
||||
Insert_Action (N,
|
||||
Make_Object_Declaration (Loc,
|
||||
Defining_Identifier => Obj_Id,
|
||||
Object_Definition =>
|
||||
New_Occurrence_Of (Expr_Typ, Loc),
|
||||
Expression => Relocate_Node (Expr_Q)));
|
||||
|
||||
-- Statically reference the tag associated with the
|
||||
-- interface
|
||||
|
||||
Tag_Comp :=
|
||||
Make_Selected_Component (Loc,
|
||||
Prefix => New_Occurrence_Of (Obj_Id, Loc),
|
||||
Selector_Name =>
|
||||
New_Occurrence_Of
|
||||
(Find_Interface_Tag (Expr_Typ, Iface), Loc));
|
||||
|
||||
-- Replace
|
||||
-- IW : I'Class := Expr;
|
||||
-- by
|
||||
|
|
@ -7977,7 +7973,7 @@ package body Exp_Ch3 is
|
|||
and then not (Is_Array_Type (Typ)
|
||||
and then Is_Constr_Subt_For_UN_Aliased (Typ))
|
||||
|
||||
-- We may use a renaming if the initializing expression is a
|
||||
-- We may use a renaming if the initialization expression is a
|
||||
-- captured function call that meets a few conditions.
|
||||
|
||||
and then
|
||||
|
|
|
|||
|
|
@ -7186,6 +7186,63 @@ package body Exp_Util is
|
|||
end if;
|
||||
end Has_Access_Constraint;
|
||||
|
||||
---------------------
|
||||
-- Has_Tag_Of_Type --
|
||||
---------------------
|
||||
|
||||
function Has_Tag_Of_Type (Exp : Node_Id) return Boolean is
|
||||
Typ : constant Entity_Id := Etype (Exp);
|
||||
|
||||
begin
|
||||
pragma Assert (Is_Tagged_Type (Typ));
|
||||
|
||||
-- The tag of an object of a class-wide type is that of its
|
||||
-- initialization expression.
|
||||
|
||||
if Is_Class_Wide_Type (Typ) then
|
||||
return False;
|
||||
end if;
|
||||
|
||||
-- The tag of a stand-alone object of a specific tagged type T
|
||||
-- identifies T.
|
||||
|
||||
if Is_Entity_Name (Exp)
|
||||
and then Ekind (Entity (Exp)) in E_Constant | E_Variable
|
||||
then
|
||||
return True;
|
||||
|
||||
else
|
||||
case Nkind (Exp) is
|
||||
-- The tag of a component or an aggregate of a specific tagged
|
||||
-- type T identifies T.
|
||||
|
||||
when N_Indexed_Component
|
||||
| N_Selected_Component
|
||||
| N_Aggregate
|
||||
=>
|
||||
return True;
|
||||
|
||||
-- The tag of the result returned by a function whose result
|
||||
-- type is a specific tagged type T identifies T.
|
||||
|
||||
when N_Function_Call =>
|
||||
return True;
|
||||
|
||||
when N_Explicit_Dereference =>
|
||||
return Is_Captured_Function_Call (Exp);
|
||||
|
||||
-- For a tagged type, the operand of a qualified expression
|
||||
-- shall resolve to be of the type of the expression.
|
||||
|
||||
when N_Qualified_Expression =>
|
||||
return Has_Tag_Of_Type (Expression (Exp));
|
||||
|
||||
when others =>
|
||||
return False;
|
||||
end case;
|
||||
end if;
|
||||
end Has_Tag_Of_Type;
|
||||
|
||||
--------------------
|
||||
-- Homonym_Number --
|
||||
--------------------
|
||||
|
|
@ -9491,61 +9548,6 @@ package body Exp_Util is
|
|||
Size_Attr : Node_Id;
|
||||
Size_Expr : Node_Id;
|
||||
|
||||
function Has_Tag_Of_Type (Exp : Node_Id) return Boolean;
|
||||
-- Return True if expression Exp of a tagged type is known to statically
|
||||
-- have the tag of this tagged type as specified by RM 3.9(19-25).
|
||||
|
||||
---------------------
|
||||
-- Has_Tag_Of_Type --
|
||||
---------------------
|
||||
|
||||
function Has_Tag_Of_Type (Exp : Node_Id) return Boolean is
|
||||
Typ : constant Entity_Id := Etype (Exp);
|
||||
|
||||
begin
|
||||
pragma Assert (Is_Tagged_Type (Typ));
|
||||
|
||||
-- The tag of an object of a class-wide type is that of its
|
||||
-- initialization expression.
|
||||
|
||||
if Is_Class_Wide_Type (Typ) then
|
||||
return False;
|
||||
end if;
|
||||
|
||||
-- The tag of a stand-alone object of a specific tagged type T
|
||||
-- identifies T.
|
||||
|
||||
if Is_Entity_Name (Exp)
|
||||
and then Ekind (Entity (Exp)) in E_Constant | E_Variable
|
||||
then
|
||||
return True;
|
||||
|
||||
else
|
||||
case Nkind (Exp) is
|
||||
-- The tag of a component or an aggregate of a specific tagged
|
||||
-- type T identifies T.
|
||||
|
||||
when N_Indexed_Component
|
||||
| N_Selected_Component
|
||||
| N_Aggregate
|
||||
=>
|
||||
return True;
|
||||
|
||||
-- The tag of the result returned by a function whose result
|
||||
-- type is a specific tagged type T identifies T.
|
||||
|
||||
when N_Function_Call =>
|
||||
return True;
|
||||
|
||||
when N_Explicit_Dereference =>
|
||||
return Is_Captured_Function_Call (Exp);
|
||||
|
||||
when others =>
|
||||
return False;
|
||||
end case;
|
||||
end if;
|
||||
end Has_Tag_Of_Type;
|
||||
|
||||
begin
|
||||
-- If the root type is already constrained, there are no discriminants
|
||||
-- in the expression.
|
||||
|
|
|
|||
|
|
@ -732,6 +732,10 @@ package Exp_Util is
|
|||
function Has_Access_Constraint (E : Entity_Id) return Boolean;
|
||||
-- Given object or type E, determine if a discriminant is of an access type
|
||||
|
||||
function Has_Tag_Of_Type (Exp : Node_Id) return Boolean;
|
||||
-- Return True if expression Exp of a tagged type is known to statically
|
||||
-- have the tag of this tagged type as specified by RM 3.9(19-25).
|
||||
|
||||
function Homonym_Number (Subp : Entity_Id) return Pos;
|
||||
-- Here subp is the entity for a subprogram. This routine returns the
|
||||
-- homonym number used to disambiguate overloaded subprograms in the same
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue