@@ -591,7 +591,7 @@ package Einfo is
-- never have a null value. Set for constant access values initialized to
-- a non-null value. This is also set for all access parameters in Ada 83
-- and Ada 95 modes, and for access parameters that explicitly exclude
+-- null in Ada 2005 mode.
--
-- This is used to avoid unnecessary resetting of the Is_Known_Non_Null
-- flag for such entities. In Ada 2005 mode, this is also used when
@@ -27,7 +27,6 @@ with Atree; use Atree;
with Einfo; use Einfo;
with Elists; use Elists;
with Exp_Disp; use Exp_Disp;
-with Exp_Util; use Exp_Util;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
@@ -159,118 +158,6 @@ package body Exp_Atag is
Make_Simple_Return_Statement (Loc))));
end Build_Common_Dispatching_Select_Statements;
- -------------------------
- -- Build_CW_Membership --
- -------------------------
-
- procedure Build_CW_Membership
- (Loc : Source_Ptr;
- 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_Temporary (Loc, 'D', Obj_Tag_Node);
- Obj_TSD : constant Entity_Id := Make_Temporary (Loc, 'D');
- Typ_TSD : constant Entity_Id := Make_Temporary (Loc, 'D');
- Index : constant Entity_Id := Make_Temporary (Loc, 'D');
-
- 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_Occurrence_Of (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_Occurrence_Of (RTE (RE_Type_Specific_Data_Ptr), Loc),
- Expression =>
- Build_TSD (Loc, New_Occurrence_Of (Tag_Addr, Loc))),
- Suppress => All_Checks);
-
- Insert_Action (Related_Nod,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Typ_TSD,
- Constant_Present => True,
- Object_Definition =>
- New_Occurrence_Of (RTE (RE_Type_Specific_Data_Ptr), Loc),
- Expression =>
- Build_TSD (Loc,
- Unchecked_Convert_To (RTE (RE_Address), Typ_Tag_Node))),
- Suppress => All_Checks);
-
- 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 =>
- Make_Explicit_Dereference (Loc,
- New_Occurrence_Of (Obj_TSD, Loc)),
- Selector_Name =>
- New_Occurrence_Of
- (RTE_Record_Component (RE_Idepth), Loc)),
-
- Right_Opnd =>
- Make_Selected_Component (Loc,
- Prefix =>
- Make_Explicit_Dereference (Loc,
- New_Occurrence_Of (Typ_TSD, Loc)),
- Selector_Name =>
- New_Occurrence_Of
- (RTE_Record_Component (RE_Idepth), Loc)))),
- Suppress => All_Checks);
-
- New_Node :=
- Make_And_Then (Loc,
- Left_Opnd =>
- Make_Op_Ge (Loc,
- Left_Opnd => New_Occurrence_Of (Index, Loc),
- Right_Opnd => Build_Val (Loc, Uint_0)),
-
- Right_Opnd =>
- Make_Op_Eq (Loc,
- Left_Opnd =>
- Make_Indexed_Component (Loc,
- Prefix =>
- Make_Selected_Component (Loc,
- Prefix =>
- Make_Explicit_Dereference (Loc,
- New_Occurrence_Of (Obj_TSD, Loc)),
- Selector_Name =>
- New_Occurrence_Of
- (RTE_Record_Component (RE_Tags_Table), Loc)),
- Expressions =>
- New_List (New_Occurrence_Of (Index, Loc))),
-
- Right_Opnd => Typ_Tag_Node));
- end Build_CW_Membership;
-
--------------
-- Build_DT --
--------------
@@ -41,24 +41,6 @@ package Exp_Atag is
-- timed, asynchronous, and conditional select and append them to Stmts.
-- Typ is the tagged type used for dispatching calls.
- procedure Build_CW_Membership
- (Loc : Source_Ptr;
- 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:
- --
- -- 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;
Tag_Node : Node_Id) return Node_Id;
@@ -6827,18 +6827,7 @@ package body Exp_Ch4 is
-- If the designated type is tagged, do tagged membership
-- operation.
- -- *** NOTE: we have to check not null before doing the
- -- tagged membership test (but maybe that can be done
- -- inside Tagged_Membership?).
-
if Is_Tagged_Type (Typ) then
- Rewrite (N,
- Make_And_Then (Loc,
- Left_Opnd => Relocate_Node (N),
- Right_Opnd =>
- Make_Op_Ne (Loc,
- Left_Opnd => Obj,
- Right_Opnd => Make_Null (Loc))));
-- No expansion will be performed for VM targets, as
-- the VM back ends will handle the membership tests
@@ -14969,6 +14958,9 @@ package body Exp_Ch4 is
-- usually implemented by looking in the ancestor tables contained in the
-- dispatch table pointed by Left_Expr.Tag for Typ'Tag
+ -- In both cases if Left_Expr is an access type, we first check whether it
+ -- is null.
+
-- Ada 2005 (AI-251): If it is a class-wide interface type we use the RT
-- function IW_Membership which is usually implemented by looking in the
-- table of abstract interface types plus the ancestor table contained in
@@ -14983,19 +14975,17 @@ package body Exp_Ch4 is
Right : constant Node_Id := Right_Opnd (N);
Loc : constant Source_Ptr := Sloc (N);
- Full_R_Typ : Entity_Id;
- Left_Type : Entity_Id;
- New_Node : Node_Id;
- Right_Type : Entity_Id;
- Obj_Tag : Node_Id;
+ -- Handle entities from the limited view
- begin
- SCIL_Node := Empty;
+ Orig_Right_Type : constant Entity_Id := Available_View (Etype (Right));
- -- Handle entities from the limited view
+ Full_R_Typ : Entity_Id;
+ Left_Type : Entity_Id := Available_View (Etype (Left));
+ Right_Type : Entity_Id := Orig_Right_Type;
+ Obj_Tag : Node_Id;
- Left_Type := Available_View (Etype (Left));
- Right_Type := Available_View (Etype (Right));
+ begin
+ SCIL_Node := Empty;
-- In the case where the type is an access type, the test is applied
-- using the designated types (needed in Ada 2012 for implicit anonymous
@@ -15069,7 +15059,7 @@ package body Exp_Ch4 is
or else Is_Interface (Left_Type)
then
-- Issue error if IW_Membership operation not available in a
- -- configurable run time setting.
+ -- configurable run-time setting.
if not RTE_Available (RE_IW_Membership) then
Error_Msg_CRT
@@ -15092,25 +15082,32 @@ package body Exp_Ch4 is
-- Ada 95: Normal case
else
- Build_CW_Membership (Loc,
- Obj_Tag_Node => Obj_Tag,
- Typ_Tag_Node =>
- New_Occurrence_Of (
- Node (First_Elmt (Access_Disp_Table (Full_R_Typ))), Loc),
- Related_Nod => N,
- New_Node => New_Node);
+ -- Issue error if CW_Membership operation not available in a
+ -- configurable run-time setting.
+
+ if not RTE_Available (RE_CW_Membership) then
+ Error_Msg_CRT
+ ("dynamic membership test on tagged types", N);
+ Result := Empty;
+ return;
+ end if;
+
+ Result :=
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (RTE (RE_CW_Membership), Loc),
+ Parameter_Associations => New_List (
+ Obj_Tag,
+ New_Occurrence_Of (
+ Node (First_Elmt (Access_Disp_Table (Full_R_Typ))),
+ Loc)));
-- 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
@@ -15130,6 +15127,29 @@ package body Exp_Ch4 is
(Node (First_Elmt (Access_Disp_Table (Full_R_Typ))), Loc));
end if;
end if;
+
+ -- if Left is an access object then generate test of the form:
+ -- * if Right_Type excludes null: Left /= null and then ...
+ -- * if Right_Type includes null: Left = null or else ...
+
+ if Is_Access_Type (Orig_Right_Type) then
+ if Can_Never_Be_Null (Orig_Right_Type) then
+ Result := Make_And_Then (Loc,
+ Left_Opnd =>
+ Make_Op_Ne (Loc,
+ Left_Opnd => Left,
+ Right_Opnd => Make_Null (Loc)),
+ Right_Opnd => Result);
+
+ else
+ Result := Make_Or_Else (Loc,
+ Left_Opnd =>
+ Make_Op_Eq (Loc,
+ Left_Opnd => Left,
+ Right_Opnd => Make_Null (Loc)),
+ Right_Opnd => Result);
+ end if;
+ end if;
end Tagged_Membership;
------------------------------
@@ -430,28 +430,21 @@ package body Exp_Intr is
-- the tag in the table of ancestor tags.
elsif not Is_Interface (Result_Typ) then
- declare
- Obj_Tag_Node : Node_Id := New_Copy_Tree (Tag_Arg);
- CW_Test_Node : Node_Id;
-
- begin
- Build_CW_Membership (Loc,
- Obj_Tag_Node => Obj_Tag_Node,
- Typ_Tag_Node =>
- New_Occurrence_Of (
- 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;
+ Insert_Action (N,
+ Make_Implicit_If_Statement (N,
+ Condition =>
+ Make_Op_Not (Loc,
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (RTE (RE_CW_Membership), Loc),
+ Parameter_Associations => New_List (
+ New_Copy_Tree (Tag_Arg),
+ New_Occurrence_Of (
+ Node (First_Elmt (Access_Disp_Table (
+ Root_Type (Result_Typ)))), Loc)))),
+ Then_Statements =>
+ New_List (
+ Make_Raise_Statement (Loc,
+ Name => New_Occurrence_Of (RTE (RE_Tag_Error), Loc)))));
-- Call IW_Membership test if the Result_Type is an abstract interface
-- to look for the tag in the table of interface tags.
@@ -49,10 +49,6 @@ package body Ada.Tags is
-- Local Subprograms --
-----------------------
- function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean;
- -- Given the tag of an object and the tag associated to a type, return
- -- true if Obj is in Typ'Class.
-
function Get_External_Tag (T : Tag) return System.Address;
-- Returns address of a null terminated string containing the external name
@@ -82,7 +78,6 @@ package body Ada.Tags is
-- Ada 2005 (AI-251): Given a pointer T to a dispatch Table, retrieves the
-- address of the record containing the Select Specific Data in T's TSD.
- pragma Inline_Always (CW_Membership);
pragma Inline_Always (Get_External_Tag);
pragma Inline_Always (Is_Primary_DT);
pragma Inline_Always (OSD);
@@ -501,6 +501,10 @@ private
-- dispatch table, return the tagged kind of a type in the context of
-- concurrency and limitedness.
+ function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean;
+ -- Given the tag of an object and the tag associated to a type, return
+ -- true if Obj is in Typ'Class.
+
function IW_Membership (This : System.Address; T : Tag) return Boolean;
-- Ada 2005 (AI-251): General routine that checks if a given object
-- implements a tagged type. Its common usage is to check if Obj is in
@@ -512,6 +512,7 @@ package Rtsfind is
RE_Check_Interface_Conversion, -- Ada.Tags
RE_Check_TSD, -- Ada.Tags
RE_Cstring_Ptr, -- Ada.Tags
+ RE_CW_Membership, -- Ada.Tags
RE_Descendant_Tag, -- Ada.Tags
RE_Dispatch_Table, -- Ada.Tags
RE_Dispatch_Table_Wrapper, -- Ada.Tags
@@ -1798,6 +1799,7 @@ package Rtsfind is
RE_Check_Interface_Conversion => Ada_Tags,
RE_Check_TSD => Ada_Tags,
RE_Cstring_Ptr => Ada_Tags,
+ RE_CW_Membership => Ada_Tags,
RE_Descendant_Tag => Ada_Tags,
RE_Dispatch_Table => Ada_Tags,
RE_Dispatch_Table_Wrapper => Ada_Tags,