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 \