* [COMMITTED] ada: Use static references to tag in more cases for interface objects
@ 2023-01-16 14:49 Marc Poulhiès
0 siblings, 0 replies; only message in thread
From: Marc Poulhiès @ 2023-01-16 14:49 UTC (permalink / raw)
To: gcc-patches; +Cc: Eric Botcazou
From: Eric Botcazou <ebotcazou@adacore.com>
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.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/exp_ch3.adb | 72 +++++++++++++---------------
gcc/ada/exp_util.adb | 112 ++++++++++++++++++++++---------------------
gcc/ada/exp_util.ads | 4 ++
3 files changed, 95 insertions(+), 93 deletions(-)
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index bbb53fc6e49..6bc76aec5d1 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -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
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index f6d91ca4a0e..80c01bf40fd 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -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.
diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads
index 32f9c24814b..3dd10d77cea 100644
--- a/gcc/ada/exp_util.ads
+++ b/gcc/ada/exp_util.ads
@@ -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
--
2.34.1
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2023-01-16 14:49 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2023-01-16 14:49 [COMMITTED] ada: Use static references to tag in more cases for interface objects Marc Poulhiès
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).