[Ada] Addition of SCIL node for class-wide membership test
Arnaud Charlet
charlet@adacore.com
Mon Nov 30 12:03:00 GMT 2009
This patch incorporates support to generate a new kind of SCIL node
associated with class-wide membership tests.
Tested on x86_64-pc-linux-gnu, committed on trunk
2009-11-30 Javier Miranda <miranda@adacore.com>
* exp_atag.adb (Build_TSD): Change argument name because the actual is
now the address of a tag (instead of the tag). Update implementation
accordingly.
(Build_CW_Membership): New implementation. Converted into a procedure
because it has an additional out mode parameter. Its implementation has
been rewritten to improve the generated code but also to facilitate
referencing the relocated object node in the caller.
* exp_atag.ads (Build_CW_Membership): Update profile and documentation.
* sinfo.ads (N_SCIL_Membership_Test) New_Node.
(SCIL_Tag_Value): New field of N_SCIL_Membership_Test nodes.
(Is_Syntactic_Field): Add entry of new node.
(SCIL_Tag_Value/Set_SCIL_Tag_Value): New subprograms.
* sinfo.adb (SCIL_Related_Node, SCIL_Entity): Update assertions to
handle N_SCIL_Membership_Test nodes.
(SCIL_Tag_Value/Set_SCIL_Tag_Value): New subprograms.
* sem.adb (Analyze): Add null management for new node.
* sem_scil.adb (Find_SCIL_Node): Add null management for new node.
(Check_SCIL_Node): Add checks of N_SCIL_Membership_Test nodes.
* exp_ch4.adb (Tagged_Membership): Change profile from function to
procedure. Add generation of SCIL node associated with class-wide
membership test.
(Expand_N_In): Complete decoration of SCIL nodes.
* exp_intr.adb (Expand_Dispatching_Constructor_Call): Tune call to
Build_CW_Membership because its profile has been changed.
* exp_util.adb (Insert_Actions): Add null management for new node.
* sprint.adb (Sprint_Node_Actual): Handle new node.
* gcc-interface/trans.c Add no processing for N_SCIL_Membership_Test
nodes.
-------------- next part --------------
Index: exp_atag.adb
===================================================================
--- exp_atag.adb (revision 154755)
+++ exp_atag.adb (working copy)
@@ -23,6 +23,7 @@
-- --
------------------------------------------------------------------------------
+with Atree; use Atree;
with Einfo; use Einfo;
with Elists; use Elists;
with Exp_Util; use Exp_Util;
@@ -53,12 +54,14 @@ package body Exp_Atag is
-- To_Dispatch_Table_Ptr
-- (To_Address (Tag_Node) - Tag_Node.Prims_Ptr'Position);
- function Build_TSD (Loc : Source_Ptr; Tag_Node : Node_Id) return Node_Id;
+ function Build_TSD
+ (Loc : Source_Ptr;
+ Tag_Node_Addr : Node_Id) return Node_Id;
-- Build code that retrieves the address of the record containing the Type
-- Specific Data generated by GNAT.
--
-- Generate: To_Type_Specific_Data_Ptr
- -- (To_Addr_Ptr (To_Address (Tag) - Typeinfo_Offset).all);
+ -- (To_Addr_Ptr (Tag_Node_Addr - Typeinfo_Offset).all);
------------------------------------------------
-- Build_Common_Dispatching_Select_Statements --
@@ -140,39 +143,90 @@ package body Exp_Atag is
-- Build_CW_Membership --
-------------------------
- function Build_CW_Membership
+ procedure Build_CW_Membership
(Loc : Source_Ptr;
- Obj_Tag_Node : Node_Id;
- Typ_Tag_Node : Node_Id) return Node_Id
- is
- function Build_Pos return Node_Id;
- -- Generate TSD (Obj_Tag).Idepth - TSD (Typ_Tag).Idepth;
+ Obj_Tag_Node : in out Node_Id;
+ Typ_Tag_Node : Node_Id;
+ Related_Nod : Node_Id;
+ New_Node : out Node_Id)
+ is
+ Tag_Addr : constant Entity_Id := Make_Defining_Identifier (Loc,
+ New_Internal_Name ('D'));
+ Obj_TSD : constant Entity_Id := Make_Defining_Identifier (Loc,
+ New_Internal_Name ('D'));
+ Typ_TSD : constant Entity_Id := Make_Defining_Identifier (Loc,
+ New_Internal_Name ('D'));
+ Index : constant Entity_Id := Make_Defining_Identifier (Loc,
+ New_Internal_Name ('D'));
- function Build_Pos return Node_Id is
- begin
- return
+ begin
+ -- Generate:
+
+ -- Tag_Addr : constant Tag := Address!(Obj_Tag);
+ -- Obj_TSD : constant Type_Specific_Data_Ptr
+ -- := Build_TSD (Tag_Addr);
+ -- Typ_TSD : constant Type_Specific_Data_Ptr
+ -- := Build_TSD (Address!(Typ_Tag));
+ -- Index : constant Integer := Obj_TSD.Idepth - Typ_TSD.Idepth
+ -- Index > 0 and then Obj_TSD.Tags_Table (Index) = Typ'Tag
+
+ Insert_Action (Related_Nod,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Tag_Addr,
+ Constant_Present => True,
+ Object_Definition => New_Reference_To (RTE (RE_Address), Loc),
+ Expression => Unchecked_Convert_To
+ (RTE (RE_Address), Obj_Tag_Node)));
+
+ -- Unchecked_Convert_To relocates Obj_Tag_Node and therefore we must
+ -- update it.
+
+ Obj_Tag_Node := Expression (Expression (Parent (Tag_Addr)));
+
+ Insert_Action (Related_Nod,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Obj_TSD,
+ Constant_Present => True,
+ Object_Definition => New_Reference_To
+ (RTE (RE_Type_Specific_Data_Ptr), Loc),
+ Expression => Build_TSD (Loc, New_Reference_To (Tag_Addr, Loc))));
+
+ Insert_Action (Related_Nod,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Typ_TSD,
+ Constant_Present => True,
+ Object_Definition => New_Reference_To
+ (RTE (RE_Type_Specific_Data_Ptr), Loc),
+ Expression => Build_TSD (Loc,
+ Unchecked_Convert_To (RTE (RE_Address),
+ Typ_Tag_Node))));
+
+ Insert_Action (Related_Nod,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Index,
+ Constant_Present => True,
+ Object_Definition => New_Occurrence_Of (Standard_Integer, Loc),
+ Expression =>
Make_Op_Subtract (Loc,
Left_Opnd =>
Make_Selected_Component (Loc,
- Prefix => Build_TSD (Loc, Duplicate_Subexpr (Obj_Tag_Node)),
- Selector_Name =>
- New_Reference_To (RTE_Record_Component (RE_Idepth), Loc)),
-
- Right_Opnd =>
- Make_Selected_Component (Loc,
- Prefix => Build_TSD (Loc, Duplicate_Subexpr (Typ_Tag_Node)),
+ Prefix => New_Reference_To (Obj_TSD, Loc),
Selector_Name =>
- New_Reference_To (RTE_Record_Component (RE_Idepth), Loc)));
- end Build_Pos;
+ New_Reference_To
+ (RTE_Record_Component (RE_Idepth), Loc)),
- -- Start of processing for Build_CW_Membership
+ Right_Opnd =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Reference_To (Typ_TSD, Loc),
+ Selector_Name =>
+ New_Reference_To
+ (RTE_Record_Component (RE_Idepth), Loc)))));
- begin
- return
+ New_Node :=
Make_And_Then (Loc,
Left_Opnd =>
Make_Op_Ge (Loc,
- Left_Opnd => Build_Pos,
+ Left_Opnd => New_Occurrence_Of (Index, Loc),
Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
Right_Opnd =>
@@ -181,12 +235,12 @@ package body Exp_Atag is
Make_Indexed_Component (Loc,
Prefix =>
Make_Selected_Component (Loc,
- Prefix => Build_TSD (Loc, Obj_Tag_Node),
+ Prefix => New_Reference_To (Obj_TSD, Loc),
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RE_Tags_Table), Loc)),
Expressions =>
- New_List (Build_Pos)),
+ New_List (New_Occurrence_Of (Index, Loc))),
Right_Opnd => Typ_Tag_Node));
end Build_CW_Membership;
@@ -197,7 +251,8 @@ package body Exp_Atag is
function Build_DT
(Loc : Source_Ptr;
- Tag_Node : Node_Id) return Node_Id is
+ Tag_Node : Node_Id) return Node_Id
+ is
begin
return
Make_Function_Call (Loc,
@@ -217,7 +272,9 @@ package body Exp_Atag is
begin
return
Make_Selected_Component (Loc,
- Prefix => Build_TSD (Loc, Tag_Node),
+ Prefix =>
+ Build_TSD (Loc,
+ Unchecked_Convert_To (RTE (RE_Address), Tag_Node)),
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RE_Access_Level), Loc));
@@ -390,7 +447,9 @@ package body Exp_Atag is
begin
return
Make_Selected_Component (Loc,
- Prefix => Build_TSD (Loc, Tag_Node),
+ Prefix =>
+ Build_TSD (Loc,
+ Unchecked_Convert_To (RTE (RE_Address), Tag_Node)),
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RE_Transportable), Loc));
@@ -529,7 +588,9 @@ package body Exp_Atag is
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
- Prefix => Build_TSD (Loc, Tag_Node),
+ Prefix =>
+ Build_TSD (Loc,
+ Unchecked_Convert_To (RTE (RE_Address), Tag_Node)),
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RE_Size_Func), Loc)),
@@ -572,7 +633,9 @@ package body Exp_Atag is
-- Build_TSD --
---------------
- function Build_TSD (Loc : Source_Ptr; Tag_Node : Node_Id) return Node_Id is
+ function Build_TSD
+ (Loc : Source_Ptr;
+ Tag_Node_Addr : Node_Id) return Node_Id is
begin
return
Unchecked_Convert_To (RTE (RE_Type_Specific_Data_Ptr),
@@ -590,9 +653,9 @@ package body Exp_Atag is
Chars => Name_Op_Subtract)),
Parameter_Associations => New_List (
- Unchecked_Convert_To (RTE (RE_Address), Tag_Node),
- New_Reference_To
- (RTE (RE_DT_Typeinfo_Ptr_Size), Loc))))));
+ Tag_Node_Addr,
+ New_Reference_To
+ (RTE (RE_DT_Typeinfo_Ptr_Size), Loc))))));
end Build_TSD;
end Exp_Atag;
Index: exp_atag.ads
===================================================================
--- exp_atag.ads (revision 154755)
+++ exp_atag.ads (working copy)
@@ -41,18 +41,23 @@ package Exp_Atag is
-- Ada 2005 (AI-345): Generate statements that are common between timed,
-- asynchronous, and conditional select expansion.
- function Build_CW_Membership
+ procedure Build_CW_Membership
(Loc : Source_Ptr;
- Obj_Tag_Node : Node_Id;
- Typ_Tag_Node : Node_Id) return Node_Id;
+ Obj_Tag_Node : in out Node_Id;
+ Typ_Tag_Node : Node_Id;
+ Related_Nod : Node_Id;
+ New_Node : out Node_Id);
-- Build code that returns true if Obj_Tag is in Typ_Tag'Class. Each DT
-- has a table of ancestors and its inheritance level (Idepth). Obj is in
-- Typ'Class if Typ'Tag is found in the table of ancestors referenced by
-- Obj'Tag. Knowing the level of inheritance of both types, this can be
-- computed in constant time by the formula:
--
- -- TSD (Obj'tag).Tags_Table (TSD (Obj'tag).Idepth - TSD (Typ'tag).Idepth)
- -- = Typ'tag
+ -- Index := TSD (Obj'Tag).Idepth - TSD (Typ'Tag).Idepth;
+ -- Index > 0 and then TSD (Obj'Tag).Tags_Table (Index) = Typ'Tag
+ --
+ -- Related_Nod is the node where the implicit declaration of variable Index
+ -- is inserted. Obj_Tag_Node is relocated.
function Build_Get_Access_Level
(Loc : Source_Ptr;
Index: exp_util.adb
===================================================================
--- exp_util.adb (revision 154755)
+++ exp_util.adb (working copy)
@@ -2761,6 +2761,7 @@ package body Exp_Util is
N_SCIL_Dispatch_Table_Object_Init |
N_SCIL_Dispatch_Table_Tag_Init |
N_SCIL_Dispatching_Call |
+ N_SCIL_Membership_Test |
N_SCIL_Tag_Init |
N_Selected_Component |
N_Signed_Integer_Type_Definition |
Index: sinfo.adb
===================================================================
--- sinfo.adb (revision 154755)
+++ sinfo.adb (working copy)
@@ -2556,6 +2556,7 @@ package body Sinfo is
or else NT (N).Nkind = N_SCIL_Dispatch_Table_Object_Init
or else NT (N).Nkind = N_SCIL_Dispatch_Table_Tag_Init
or else NT (N).Nkind = N_SCIL_Dispatching_Call
+ or else NT (N).Nkind = N_SCIL_Membership_Test
or else NT (N).Nkind = N_SCIL_Tag_Init);
return Node4 (N);
end SCIL_Entity;
@@ -2567,10 +2568,19 @@ package body Sinfo is
or else NT (N).Nkind = N_SCIL_Dispatch_Table_Object_Init
or else NT (N).Nkind = N_SCIL_Dispatch_Table_Tag_Init
or else NT (N).Nkind = N_SCIL_Dispatching_Call
+ or else NT (N).Nkind = N_SCIL_Membership_Test
or else NT (N).Nkind = N_SCIL_Tag_Init);
return Node1 (N);
end SCIL_Related_Node;
+ function SCIL_Tag_Value
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_SCIL_Membership_Test);
+ return Node5 (N);
+ end SCIL_Tag_Value;
+
function SCIL_Target_Prim
(N : Node_Id) return Node_Id is
begin
@@ -5416,6 +5426,7 @@ package body Sinfo is
or else NT (N).Nkind = N_SCIL_Dispatch_Table_Object_Init
or else NT (N).Nkind = N_SCIL_Dispatch_Table_Tag_Init
or else NT (N).Nkind = N_SCIL_Dispatching_Call
+ or else NT (N).Nkind = N_SCIL_Membership_Test
or else NT (N).Nkind = N_SCIL_Tag_Init);
Set_Node4 (N, Val); -- semantic field, no parent set
end Set_SCIL_Entity;
@@ -5427,10 +5438,19 @@ package body Sinfo is
or else NT (N).Nkind = N_SCIL_Dispatch_Table_Object_Init
or else NT (N).Nkind = N_SCIL_Dispatch_Table_Tag_Init
or else NT (N).Nkind = N_SCIL_Dispatching_Call
+ or else NT (N).Nkind = N_SCIL_Membership_Test
or else NT (N).Nkind = N_SCIL_Tag_Init);
Set_Node1 (N, Val); -- semantic field, no parent set
end Set_SCIL_Related_Node;
+ procedure Set_SCIL_Tag_Value
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_SCIL_Membership_Test);
+ Set_Node5 (N, Val); -- semantic field, no parent set
+ end Set_SCIL_Tag_Value;
+
procedure Set_SCIL_Target_Prim
(N : Node_Id; Val : Node_Id) is
begin
Index: sinfo.ads
===================================================================
--- sinfo.ads (revision 154755)
+++ sinfo.ads (working copy)
@@ -1608,6 +1608,10 @@ package Sinfo is
-- Present in N_SCIL_Dispatching_Call nodes. Used to reference the
-- controlling tag of a dispatching call.
+ -- SCIL_Tag_Value (Node5-Sem)
+ -- Present in N_SCIL_Membership_Test nodes. Used to reference the tag
+ -- value that is being tested.
+
-- SCIL_Target_Prim (Node2-Sem)
-- Present in N_SCIL_Dispatching_Call nodes. Used to reference the tagged
-- type primitive associated with the SCIL node.
@@ -6886,6 +6890,12 @@ package Sinfo is
-- SCIL_Entity (Node4-Sem)
-- SCIL_Controlling_Tag (Node5-Sem)
+ -- N_SCIL_Membership_Test
+ -- Sloc references the node of a membership test
+ -- SCIL_Related_Node (Node1-Sem)
+ -- SCIL_Tag_Value (Node5-Sem)
+ -- SCIL_Entity (Node4-Sem)
+
-- N_SCIL_Tag_Init
-- Sloc references the node of a tag component initialization
-- SCIL_Related_Node (Node1-Sem)
@@ -7333,6 +7343,7 @@ package Sinfo is
N_SCIL_Dispatch_Table_Object_Init,
N_SCIL_Dispatch_Table_Tag_Init,
N_SCIL_Dispatching_Call,
+ N_SCIL_Membership_Test,
N_SCIL_Tag_Init,
-- Other nodes (not part of any subtype class)
@@ -8390,6 +8401,9 @@ package Sinfo is
function SCIL_Related_Node
(N : Node_Id) return Node_Id; -- Node1
+ function SCIL_Tag_Value
+ (N : Node_Id) return Node_Id; -- Node5
+
function SCIL_Target_Prim
(N : Node_Id) return Node_Id; -- Node2
@@ -9302,6 +9316,9 @@ package Sinfo is
procedure Set_SCIL_Related_Node
(N : Node_Id; Val : Node_Id); -- Node1
+ procedure Set_SCIL_Tag_Value
+ (N : Node_Id; Val : Node_Id); -- Node5
+
procedure Set_SCIL_Target_Prim
(N : Node_Id; Val : Node_Id); -- Node2
@@ -11056,6 +11073,13 @@ package Sinfo is
4 => False, -- SCIL_Entity (Node4-Sem)
5 => False), -- SCIL_Controlling_Tag (Node5-Sem)
+ N_SCIL_Membership_Test =>
+ (1 => False, -- SCIL_Related_Node (Node1-Sem)
+ 2 => False, -- unused
+ 3 => False, -- unused
+ 4 => False, -- SCIL_Entity (Node4-Sem)
+ 5 => False), -- SCIL_Tag_Value (Node5-Sem)
+
N_SCIL_Tag_Init =>
(1 => False, -- SCIL_Related_Node (Node1-Sem)
2 => False, -- unused
@@ -11364,6 +11388,7 @@ package Sinfo is
pragma Inline (SCIL_Controlling_Tag);
pragma Inline (SCIL_Entity);
pragma Inline (SCIL_Related_Node);
+ pragma Inline (SCIL_Tag_Value);
pragma Inline (SCIL_Target_Prim);
pragma Inline (Scope);
pragma Inline (Select_Alternatives);
@@ -11664,6 +11689,7 @@ package Sinfo is
pragma Inline (Set_SCIL_Controlling_Tag);
pragma Inline (Set_SCIL_Entity);
pragma Inline (Set_SCIL_Related_Node);
+ pragma Inline (Set_SCIL_Tag_Value);
pragma Inline (Set_SCIL_Target_Prim);
pragma Inline (Set_Scope);
pragma Inline (Set_Select_Alternatives);
Index: sem_scil.adb
===================================================================
--- sem_scil.adb (revision 154755)
+++ sem_scil.adb (working copy)
@@ -101,15 +101,58 @@ package body Sem_SCIL is
-- Check_SCIL_Node --
---------------------
- -- Is this a good name for the function, given it only deals with
- -- N_SCIL_Dispatching_Call case ???
-
function Check_SCIL_Node (N : Node_Id) return Traverse_Result is
Ctrl_Tag : Node_Id;
Ctrl_Typ : Entity_Id;
begin
- if Nkind (N) = N_SCIL_Dispatching_Call then
+ if Nkind (N) = N_SCIL_Membership_Test then
+
+ -- Check contents of the boolean expression associated with the
+ -- membership test.
+
+ pragma Assert (Nkind (SCIL_Related_Node (N)) = N_Identifier
+ and then Etype (SCIL_Related_Node (N)) = Standard_Boolean);
+
+ -- Check the entity identifier of the associated tagged type (that
+ -- is, in testing for membership in T'Class, the entity id of the
+ -- specific type T).
+
+ -- Note: When the SCIL node is generated the private and full-view
+ -- of the tagged types may have been swapped and hence the node
+ -- referenced by attribute SCIL_Entity may be the private view.
+ -- Therefore, in order to uniformily locate the full-view we use
+ -- attribute Underlying_Type.
+
+ pragma Assert (Is_Tagged_Type (Underlying_Type (SCIL_Entity (N))));
+
+ -- Interface types are unsupported
+
+ pragma Assert (not Is_Interface (Underlying_Type (SCIL_Entity (N))));
+
+ -- Check the decoration of the expression that denotes the tag value
+ -- being tested
+
+ Ctrl_Tag := SCIL_Tag_Value (N);
+
+ case Nkind (Ctrl_Tag) is
+
+ -- For class-wide membership tests the SCIL tag value is the tag
+ -- of the tested object (i.e. Obj.Tag).
+
+ when N_Selected_Component =>
+ pragma Assert (Etype (Ctrl_Tag) = RTE (RE_Tag));
+ null;
+
+ when others =>
+ pragma Assert (False);
+ null;
+
+ end case;
+
+ return Skip;
+
+ elsif Nkind (N) = N_SCIL_Dispatching_Call then
Ctrl_Tag := SCIL_Controlling_Tag (N);
-- SCIL_Related_Node of SCIL dispatching call nodes MUST reference
@@ -452,6 +495,7 @@ package body Sem_SCIL is
N_SCIL_Dispatch_Table_Object_Init |
N_SCIL_Dispatch_Table_Tag_Init |
N_SCIL_Dispatching_Call |
+ N_SCIL_Membership_Test |
N_SCIL_Tag_Init
=>
pragma Assert (False);
Index: sem.adb
===================================================================
--- sem.adb (revision 154755)
+++ sem.adb (working copy)
@@ -612,6 +612,7 @@ package body Sem is
N_SCIL_Dispatch_Table_Object_Init |
N_SCIL_Dispatch_Table_Tag_Init |
N_SCIL_Dispatching_Call |
+ N_SCIL_Membership_Test |
N_SCIL_Tag_Init =>
null;
Index: exp_ch4.adb
===================================================================
--- exp_ch4.adb (revision 154786)
+++ exp_ch4.adb (working copy)
@@ -205,7 +205,10 @@ package body Exp_Ch4 is
-- its expression. If N is neither comparison nor a type conversion, the
-- call has no effect.
- function Tagged_Membership (N : Node_Id) return Node_Id;
+ procedure Tagged_Membership
+ (N : Node_Id;
+ SCIL_Node : out Node_Id;
+ Result : out Node_Id);
-- Construct the expression corresponding to the tagged membership test.
-- Deals with a second operand being (or not) a class-wide type.
@@ -4503,10 +4506,12 @@ package body Exp_Ch4 is
else
declare
- Typ : Entity_Id := Etype (Rop);
- Is_Acc : constant Boolean := Is_Access_Type (Typ);
- Obj : Node_Id := Lop;
- Cond : Node_Id := Empty;
+ Typ : Entity_Id := Etype (Rop);
+ Is_Acc : constant Boolean := Is_Access_Type (Typ);
+ Cond : Node_Id := Empty;
+ New_N : Node_Id;
+ Obj : Node_Id := Lop;
+ SCIL_Node : Node_Id;
begin
Remove_Side_Effects (Obj);
@@ -4521,8 +4526,19 @@ package body Exp_Ch4 is
-- normal tagged membership expansion is not what we want).
if Tagged_Type_Expansion then
- Rewrite (N, Tagged_Membership (N));
+ Tagged_Membership (N, SCIL_Node, New_N);
+ Rewrite (N, New_N);
Analyze_And_Resolve (N, Rtyp);
+
+ -- Update decoration of relocated node referenced by the
+ -- SCIL node.
+
+ if Generate_SCIL
+ and then Present (SCIL_Node)
+ then
+ Set_SCIL_Related_Node (SCIL_Node, N);
+ Insert_Action (N, SCIL_Node);
+ end if;
end if;
return;
@@ -9857,16 +9873,23 @@ package body Exp_Ch4 is
-- table of abstract interface types plus the ancestor table contained in
-- the dispatch table pointed by Left_Expr.Tag for Typ'Tag
- function Tagged_Membership (N : Node_Id) return Node_Id is
+ procedure Tagged_Membership
+ (N : Node_Id;
+ SCIL_Node : out Node_Id;
+ Result : out Node_Id)
+ is
Left : constant Node_Id := Left_Opnd (N);
Right : constant Node_Id := Right_Opnd (N);
Loc : constant Source_Ptr := Sloc (N);
Left_Type : Entity_Id;
+ New_Node : Node_Id;
Right_Type : Entity_Id;
Obj_Tag : Node_Id;
begin
+ SCIL_Node := Empty;
+
-- Handle entities from the limited view
Left_Type := Available_View (Etype (Left));
@@ -9914,7 +9937,8 @@ package body Exp_Ch4 is
(Typ => Left_Type,
Iface => Etype (Right_Type))))
then
- return New_Reference_To (Standard_True, Loc);
+ Result := New_Reference_To (Standard_True, Loc);
+ return;
end if;
-- Ada 2005 (AI-251): Class-wide applied to interfaces
@@ -9931,10 +9955,11 @@ package body Exp_Ch4 is
if not RTE_Available (RE_IW_Membership) then
Error_Msg_CRT
("dynamic membership test on interface types", N);
- return Empty;
+ Result := Empty;
+ return;
end if;
- return
+ Result :=
Make_Function_Call (Loc,
Name => New_Occurrence_Of (RTE (RE_IW_Membership), Loc),
Parameter_Associations => New_List (
@@ -9949,14 +9974,27 @@ package body Exp_Ch4 is
-- Ada 95: Normal case
else
- return
- Build_CW_Membership (Loc,
- Obj_Tag_Node => Obj_Tag,
- Typ_Tag_Node =>
- New_Reference_To (
- Node (First_Elmt
- (Access_Disp_Table (Root_Type (Right_Type)))),
- Loc));
+ Build_CW_Membership (Loc,
+ Obj_Tag_Node => Obj_Tag,
+ Typ_Tag_Node =>
+ New_Reference_To (
+ Node (First_Elmt
+ (Access_Disp_Table (Root_Type (Right_Type)))),
+ Loc),
+ Related_Nod => N,
+ New_Node => New_Node);
+
+ -- Generate the SCIL node for this class-wide membership test.
+ -- Done here because the previous call to Build_CW_Membership
+ -- relocates Obj_Tag.
+
+ if Generate_SCIL then
+ SCIL_Node := Make_SCIL_Membership_Test (Sloc (N));
+ Set_SCIL_Entity (SCIL_Node, Etype (Right_Type));
+ Set_SCIL_Tag_Value (SCIL_Node, Obj_Tag);
+ end if;
+
+ Result := New_Node;
end if;
-- Right_Type is not a class-wide type
@@ -9965,10 +10003,10 @@ package body Exp_Ch4 is
-- No need to check the tag of the object if Right_Typ is abstract
if Is_Abstract_Type (Right_Type) then
- return New_Reference_To (Standard_False, Loc);
+ Result := New_Reference_To (Standard_False, Loc);
else
- return
+ Result :=
Make_Op_Eq (Loc,
Left_Opnd => Obj_Tag,
Right_Opnd =>
Index: exp_intr.adb
===================================================================
--- exp_intr.adb (revision 154755)
+++ exp_intr.adb (working copy)
@@ -234,19 +234,28 @@ package body Exp_Intr is
-- the tag in the table of ancestor tags.
elsif not Is_Interface (Result_Typ) then
- Insert_Action (N,
- Make_Implicit_If_Statement (N,
- Condition =>
- Make_Op_Not (Loc,
- Build_CW_Membership (Loc,
- Obj_Tag_Node => Duplicate_Subexpr (Tag_Arg),
- Typ_Tag_Node =>
- New_Reference_To (
- Node (First_Elmt (Access_Disp_Table (
- Root_Type (Result_Typ)))), Loc))),
- Then_Statements =>
- New_List (Make_Raise_Statement (Loc,
- New_Occurrence_Of (RTE (RE_Tag_Error), Loc)))));
+ declare
+ Obj_Tag_Node : Node_Id := Duplicate_Subexpr (Tag_Arg);
+ CW_Test_Node : Node_Id;
+
+ begin
+ Build_CW_Membership (Loc,
+ Obj_Tag_Node => Obj_Tag_Node,
+ Typ_Tag_Node =>
+ New_Reference_To (
+ Node (First_Elmt (Access_Disp_Table (
+ Root_Type (Result_Typ)))), Loc),
+ Related_Nod => N,
+ New_Node => CW_Test_Node);
+
+ Insert_Action (N,
+ Make_Implicit_If_Statement (N,
+ Condition =>
+ Make_Op_Not (Loc, CW_Test_Node),
+ Then_Statements =>
+ New_List (Make_Raise_Statement (Loc,
+ New_Occurrence_Of (RTE (RE_Tag_Error), Loc)))));
+ end;
-- Call IW_Membership test if the Result_Type is an abstract interface
-- to look for the tag in the table of interface tags.
Index: sprint.adb
===================================================================
--- sprint.adb (revision 154786)
+++ sprint.adb (working copy)
@@ -2652,6 +2652,9 @@ package body Sprint is
when N_SCIL_Dispatching_Call =>
Write_Indent_Str ("[N_SCIL_Dispatching_Node]");
+ when N_SCIL_Membership_Test =>
+ Write_Indent_Str ("[N_SCIL_Membership_Test]");
+
when N_SCIL_Tag_Init =>
Write_Indent_Str ("[N_SCIL_Dispatch_Table_Tag_Init]");
Index: gcc-interface/trans.c
===================================================================
--- gcc-interface/trans.c (revision 154755)
+++ gcc-interface/trans.c (working copy)
@@ -5321,6 +5321,7 @@ gnat_to_gnu (Node_Id gnat_node)
case N_SCIL_Dispatch_Table_Object_Init:
case N_SCIL_Dispatch_Table_Tag_Init:
case N_SCIL_Dispatching_Call:
+ case N_SCIL_Membership_Test:
case N_SCIL_Tag_Init:
/* SCIL nodes require no processing for GCC. */
gnu_result = alloc_stmt_list ();
Index: gcc-interface/Make-lang.in
===================================================================
--- gcc-interface/Make-lang.in (revision 154788)
+++ gcc-interface/Make-lang.in (working copy)
@@ -1663,28 +1663,24 @@ ada/exp_aggr.o : ada/ada.ads ada/a-excep
ada/exp_atag.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \
- ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \
- ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \
- ada/errout.ads ada/erroutc.ads ada/exp_aggr.ads ada/exp_atag.ads \
- ada/exp_atag.adb ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_dist.ads \
- ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb ada/fname.ads \
- ada/fname-uf.ads ada/get_targ.ads ada/gnat.ads ada/g-htable.ads \
- ada/hostparm.ads ada/inline.ads ada/itypes.ads ada/lib.ads \
+ ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \
+ ada/elists.ads ada/elists.adb ada/err_vars.ads ada/errout.ads \
+ ada/erroutc.ads ada/exp_atag.ads ada/exp_atag.adb ada/exp_dist.ads \
+ ada/exp_tss.ads ada/exp_util.ads ada/fname.ads ada/fname-uf.ads \
+ ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/lib.ads \
ada/lib-load.ads ada/namet.ads ada/nlists.ads ada/nlists.adb \
ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \
ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb ada/sem.ads \
- ada/sem_aux.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_dist.ads \
- ada/sem_eval.ads ada/sem_res.ads ada/sem_scil.ads ada/sem_type.ads \
- ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \
- ada/snames.ads ada/stand.ads ada/stringt.ads ada/system.ads \
- ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \
- ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-soflin.ads \
- ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
- ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \
- ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \
- ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \
+ ada/sem_aux.ads ada/sem_ch7.ads ada/sem_dist.ads ada/sem_util.ads \
+ ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \
+ ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \
+ ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \
+ ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
+ ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \
+ ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \
+ ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/types.ads \
ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \
- ada/unchdeal.ads ada/urealp.ads ada/validsw.ads
+ ada/unchdeal.ads ada/urealp.ads
ada/exp_attr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \
More information about the Gcc-patches
mailing list