MatCat.OpenSource/8sa1-gcc
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[Ada] ACATS 4.1K - C452003

Browse Source 
gcc/ada/

	* exp_ch4.adb (Tagged_Membership): Generate a call to
	CW_Membership instead of using Build_CW_Membership.
	(Expand_N_In): Remove wrong handling of null access types and
	corresponding comment.
	* exp_intr.adb (Expand_Dispatching_Constructor_Call): Generate a
	call to CW_Membership instead of using Build_CW_Membership.
	* rtsfind.ads: Add CW_Membership.
	* exp_atag.ads, exp_atag.adb (Build_CW_Membership): Removed.
	* einfo.ads: Fix typo.
	* libgnat/a-tags.ads, libgnat/a-tags.adb (CW_Membership): Moved
	back to spec.
This commit is contained in:
Arnaud Charlet 2020-05-13 04:41:03 -04:00 committed by Pierre-Marie de Rodat
parent 9b501e59d1
commit ead7594ff5
8 changed files with 75 additions and 192 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
gcc/ada/einfo.ads
View File

@ -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
-- exclude null in Ada 2005 mode.
-- 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

113
gcc/ada/exp_atag.adb
View File

@ -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 --
--------------

18
gcc/ada/exp_atag.ads
View File

@ -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;

86
gcc/ada/exp_ch4.adb
View File

@ -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,20 +14975,18 @@ 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
Orig_Right_Type : constant Entity_Id := Available_View (Etype (Right));
Full_R_Typ : Entity_Id;
Left_Type : Entity_Id := Available_View (Etype (Left));
Right_Type : Entity_Id := Orig_Right_Type;
Obj_Tag : Node_Id;
begin
SCIL_Node := Empty;
-- Handle entities from the limited view
Left_Type := Available_View (Etype (Left));
Right_Type := Available_View (Etype (Right));
-- 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
-- access conversions, for AI05-0149).
@ -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;
------------------------------

37
gcc/ada/exp_intr.adb
View File

@ -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.

5
gcc/ada/libgnat/a-tags.adb
View File

@ -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);

4
gcc/ada/libgnat/a-tags.ads
View File

@ -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

2
gcc/ada/rtsfind.ads
View File

@ -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,