* [Ada] Frontend cleanup
@ 2011-08-01 15:18 Arnaud Charlet
0 siblings, 0 replies; only message in thread
From: Arnaud Charlet @ 2011-08-01 15:18 UTC (permalink / raw)
To: gcc-patches; +Cc: Javier Miranda
[-- Attachment #1: Type: text/plain, Size: 1421 bytes --]
This patch does not change the behavior of the compiler. It removes
useless code and enforces the assertions associated with attributes
Access_Disp_Table and Dispatch_Table_Wrappers to follow their
documentation and thus ensure that these attributes are always read
from the entity associated with the full view of private types.
No test required.
Tested on x86_64-pc-linux-gnu, committed on trunk
2011-08-01 Javier Miranda <miranda@adacore.com>
* sem_ch7.adb (Uninstall_Declarations): Remove useless code.
* einfo.ads (Access_Disp_Table): Fix documentation.
(Dispatch_Table_Wrappers): Fix documentation.
* einfo.adb (Access_Disp_Table, Dispatch_Table_Wrappers,
Set_Access_Disp_Table, Set_Dispatch_Table_Wrappers): Fix the assertions
to enforce the documentation of this attribute.
(Set_Is_Interface): Cleanup the assertion.
* exp_ch4.adb (Expand_Allocator_Expression, Tagged_Membership): Locate
the Underlying_Type entity before reading attribute Access_Disp_Table.
* exp_disp.adb (Expand_Dispatching_Call, Expand_Interface_Conversion):
Locate the Underlying_Type before reading attribute Access_Disp_Table.
* exp_aggr.adb (Build_Array_Aggr_Code, Build_Record_Aggr_Code): Locate
the Underlying_Type entity before reading attribute Access_Disp_Table.
* exp_ch3.adb (Build_Record_Init_Proc, Expand_N_Object_Declaration):
Locate the Underlying_Type entity before reading attribute
Access_Disp_Table.
[-- Attachment #2: difs --]
[-- Type: text/plain, Size: 16165 bytes --]
Index: sem_ch7.adb
===================================================================
--- sem_ch7.adb (revision 177027)
+++ sem_ch7.adb (working copy)
@@ -2069,39 +2069,6 @@
and then Is_Tagged_Type (Full)
and then not Error_Posted (Full)
then
- if Priv_Is_Base_Type then
-
- -- Ada 2005 (AI-345): The full view of a type implementing an
- -- interface can be a task type.
-
- -- type T is new I with private;
- -- private
- -- task type T is new I with ...
-
- if Is_Interface (Etype (Priv))
- and then Is_Concurrent_Type (Base_Type (Full))
- then
- -- Protect the frontend against previous errors
-
- if Present (Corresponding_Record_Type
- (Base_Type (Full)))
- then
- Set_Access_Disp_Table
- (Priv, Access_Disp_Table
- (Corresponding_Record_Type (Base_Type (Full))));
-
- -- Generic context, or previous errors
-
- else
- null;
- end if;
-
- else
- Set_Access_Disp_Table
- (Priv, Access_Disp_Table (Base_Type (Full)));
- end if;
- end if;
-
if Is_Tagged_Type (Priv) then
-- If the type is tagged, the tag itself must be available on
Index: einfo.adb
===================================================================
--- einfo.adb (revision 177028)
+++ einfo.adb (working copy)
@@ -573,7 +573,8 @@
function Access_Disp_Table (Id : E) return L is
begin
- pragma Assert (Is_Tagged_Type (Id));
+ pragma Assert (Ekind_In (Id, E_Record_Type,
+ E_Record_Subtype));
return Elist16 (Implementation_Base_Type (Id));
end Access_Disp_Table;
@@ -882,7 +883,8 @@
function Dispatch_Table_Wrappers (Id : E) return L is
begin
- pragma Assert (Is_Tagged_Type (Id));
+ pragma Assert (Ekind_In (Id, E_Record_Type,
+ E_Record_Subtype));
return Elist26 (Implementation_Base_Type (Id));
end Dispatch_Table_Wrappers;
@@ -2996,7 +2998,9 @@
procedure Set_Access_Disp_Table (Id : E; V : L) is
begin
- pragma Assert (Is_Tagged_Type (Id) and then Is_Base_Type (Id));
+ pragma Assert (Ekind (Id) = E_Record_Type
+ and then Id = Implementation_Base_Type (Id));
+ pragma Assert (V = No_Elist or else Is_Tagged_Type (Id));
Set_Elist16 (Id, V);
end Set_Access_Disp_Table;
@@ -3302,12 +3306,9 @@
procedure Set_Dispatch_Table_Wrappers (Id : E; V : L) is
begin
- pragma Assert (Is_Tagged_Type (Id)
- and then Is_Base_Type (Id)
- and then Ekind_In (Id, E_Record_Type,
- E_Record_Subtype,
- E_Record_Type_With_Private,
- E_Record_Subtype_With_Private));
+ pragma Assert (Ekind (Id) = E_Record_Type
+ and then Id = Implementation_Base_Type (Id));
+ pragma Assert (V = No_Elist or else Is_Tagged_Type (Id));
Set_Elist26 (Id, V);
end Set_Dispatch_Table_Wrappers;
@@ -4312,13 +4313,7 @@
procedure Set_Is_Interface (Id : E; V : B := True) is
begin
- pragma Assert
- (Ekind_In (Id, E_Record_Type,
- E_Record_Subtype,
- E_Record_Type_With_Private,
- E_Record_Subtype_With_Private,
- E_Class_Wide_Type,
- E_Class_Wide_Subtype));
+ pragma Assert (Is_Record_Type (Id));
Set_Flag186 (Id, V);
end Set_Is_Interface;
Index: einfo.ads
===================================================================
--- einfo.ads (revision 177031)
+++ einfo.ads (working copy)
@@ -338,8 +338,8 @@
-- statements referencing the same entry.
-- Access_Disp_Table (Elist16) [implementation base type only]
--- Present in record type entities. For a tagged type, points to the
--- dispatch tables associated with the tagged type. The first two
+-- Present in record types and subtypes. Set in tagged types to point to
+-- the dispatch tables associated with the tagged type. The first two
-- entities correspond with the primary dispatch table: 1) primary
-- dispatch table with user-defined primitives, 2) primary dispatch table
-- with predefined primitives. For each interface type covered by the
@@ -349,7 +349,7 @@
-- dispatch table with user-defined primitives, and 6) secondary dispatch
-- table with predefined primitives. The last entity of this list is an
-- access type declaration used to expand dispatching calls through the
--- primary dispatch table. For a non-tagged record, contains Empty.
+-- primary dispatch table. For a non-tagged record, contains No_Elist.
-- Actual_Subtype (Node17)
-- Present in variables, constants, and formal parameters. This is the
@@ -855,11 +855,10 @@
-- index starting at 1 and ranging up to number of discriminants.
-- Dispatch_Table_Wrappers (Elist26) [implementation base type only]
--- Present in record type [with private] entities. Set in library level
--- record type entities if we are generating statically allocated
--- dispatch tables. For a tagged type, points to the list of dispatch
--- table wrappers associated with the tagged type. For a non-tagged
--- record, contains No_Elist.
+-- Present in record types and subtypes. Set in library level tagged type
+-- entities if we are generating statically allocated dispatch tables.
+-- Points to the list of dispatch table wrappers associated with the
+-- tagged type. For a non-tagged record, contains No_Elist.
-- DTC_Entity (Node16)
-- Present in function and procedure entities. Set to Empty unless
@@ -5513,7 +5512,6 @@
-- E_Record_Type_With_Private
-- E_Record_Subtype_With_Private
-- Direct_Primitive_Operations (Elist10)
- -- Access_Disp_Table (Elist16) (base type only)
-- First_Entity (Node17)
-- Private_Dependents (Elist18)
-- Underlying_Full_View (Node19)
@@ -5522,7 +5520,6 @@
-- Private_View (Node22)
-- Stored_Constraint (Elist23)
-- Interfaces (Elist25)
- -- Dispatch_Table_Wrappers (Elist26) (base type only)
-- Has_Completion (Flag26)
-- Has_Record_Rep_Clause (Flag65) (base type only)
-- Has_External_Tag_Rep_Clause (Flag110)
Index: exp_ch4.adb
===================================================================
--- exp_ch4.adb (revision 177023)
+++ exp_ch4.adb (working copy)
@@ -874,19 +874,23 @@
end if;
if Present (TagT) then
- Tag_Assign :=
- Make_Assignment_Statement (Loc,
- Name =>
- Make_Selected_Component (Loc,
- Prefix => TagR,
- Selector_Name =>
- New_Reference_To (First_Tag_Component (TagT), Loc)),
+ declare
+ Full_T : constant Entity_Id := Underlying_Type (TagT);
- Expression =>
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Reference_To
- (Elists.Node (First_Elmt (Access_Disp_Table (TagT))),
- Loc)));
+ begin
+ Tag_Assign :=
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Selected_Component (Loc,
+ Prefix => TagR,
+ Selector_Name =>
+ New_Reference_To (First_Tag_Component (Full_T), Loc)),
+ Expression =>
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To
+ (Elists.Node
+ (First_Elmt (Access_Disp_Table (Full_T))), Loc)));
+ end;
-- The previous assignment has to be done in any case
@@ -10397,6 +10401,7 @@
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;
@@ -10414,6 +10419,12 @@
Left_Type := Root_Type (Left_Type);
end if;
+ if Is_Class_Wide_Type (Right_Type) then
+ Full_R_Typ := Underlying_Type (Root_Type (Right_Type));
+ else
+ Full_R_Typ := Underlying_Type (Right_Type);
+ end if;
+
Obj_Tag :=
Make_Selected_Component (Loc,
Prefix => Relocate_Node (Left),
@@ -10482,8 +10493,7 @@
Prefix => Obj_Tag,
Attribute_Name => Name_Address),
New_Reference_To (
- Node (First_Elmt
- (Access_Disp_Table (Root_Type (Right_Type)))),
+ Node (First_Elmt (Access_Disp_Table (Full_R_Typ))),
Loc)));
-- Ada 95: Normal case
@@ -10493,9 +10503,7 @@
Obj_Tag_Node => Obj_Tag,
Typ_Tag_Node =>
New_Reference_To (
- Node (First_Elmt
- (Access_Disp_Table (Root_Type (Right_Type)))),
- Loc),
+ Node (First_Elmt (Access_Disp_Table (Full_R_Typ))), Loc),
Related_Nod => N,
New_Node => New_Node);
@@ -10526,7 +10534,7 @@
Left_Opnd => Obj_Tag,
Right_Opnd =>
New_Reference_To
- (Node (First_Elmt (Access_Disp_Table (Right_Type))), Loc));
+ (Node (First_Elmt (Access_Disp_Table (Full_R_Typ))), Loc));
end if;
end if;
end Tagged_Membership;
Index: exp_disp.adb
===================================================================
--- exp_disp.adb (revision 176998)
+++ exp_disp.adb (working copy)
@@ -919,7 +919,7 @@
else
Build_Get_Prim_Op_Address (Loc,
- Typ => Find_Dispatching_Type (Subp),
+ Typ => Underlying_Type (Find_Dispatching_Type (Subp)),
Tag_Node => Controlling_Tag,
Position => DT_Position (Subp),
New_Node => New_Node);
@@ -1107,6 +1107,10 @@
Iface_Typ := Corresponding_Record_Type (Iface_Typ);
end if;
+ -- Handle private types
+
+ Iface_Typ := Underlying_Type (Iface_Typ);
+
-- Freeze the entity associated with the target interface to have
-- available the attribute Access_Disp_Table.
Index: exp_aggr.adb
===================================================================
--- exp_aggr.adb (revision 177035)
+++ exp_aggr.adb (working copy)
@@ -1211,22 +1211,27 @@
and then Is_Tagged_Type (Comp_Type)
and then Tagged_Type_Expansion
then
- A :=
- Make_OK_Assignment_Statement (Loc,
- Name =>
- Make_Selected_Component (Loc,
- Prefix => New_Copy_Tree (Indexed_Comp),
- Selector_Name =>
- New_Reference_To
- (First_Tag_Component (Comp_Type), Loc)),
+ declare
+ Full_Typ : constant Entity_Id := Underlying_Type (Comp_Type);
- Expression =>
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Reference_To
- (Node (First_Elmt (Access_Disp_Table (Comp_Type))),
- Loc)));
+ begin
+ A :=
+ Make_OK_Assignment_Statement (Loc,
+ Name =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Copy_Tree (Indexed_Comp),
+ Selector_Name =>
+ New_Reference_To
+ (First_Tag_Component (Full_Typ), Loc)),
- Append_To (L, A);
+ Expression =>
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To
+ (Node (First_Elmt (Access_Disp_Table (Full_Typ))),
+ Loc)));
+
+ Append_To (L, A);
+ end;
end if;
-- Adjust and attach the component to the proper final list, which
@@ -2982,7 +2987,7 @@
Gen_Ctrl_Actions_For_Aggr;
end if;
- Comp_Type := Etype (Selector);
+ Comp_Type := Underlying_Type (Etype (Selector));
Comp_Expr :=
Make_Selected_Component (Loc,
Prefix => New_Copy_Tree (Target),
Index: exp_ch3.adb
===================================================================
--- exp_ch3.adb (revision 176998)
+++ exp_ch3.adb (working copy)
@@ -1917,7 +1917,10 @@
Expression =>
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To
- (Node (First_Elmt (Access_Disp_Table (Typ))), Loc))));
+ (Node
+ (First_Elmt
+ (Access_Disp_Table (Underlying_Type (Typ)))),
+ Loc))));
end if;
-- Adjust the component if controlled except if it is an aggregate
@@ -5055,27 +5058,32 @@
and then Tagged_Type_Expansion
and then Nkind (Expr) /= N_Aggregate
then
- -- The re-assignment of the tag has to be done even if the
- -- object is a constant.
+ declare
+ Full_Typ : constant Entity_Id := Underlying_Type (Typ);
- New_Ref :=
- Make_Selected_Component (Loc,
- Prefix => New_Reference_To (Def_Id, Loc),
- Selector_Name =>
- New_Reference_To (First_Tag_Component (Typ), Loc));
+ begin
+ -- The re-assignment of the tag has to be done even if the
+ -- object is a constant.
- Set_Assignment_OK (New_Ref);
+ New_Ref :=
+ Make_Selected_Component (Loc,
+ Prefix => New_Reference_To (Def_Id, Loc),
+ Selector_Name =>
+ New_Reference_To (First_Tag_Component (Full_Typ),
+ Loc));
+ Set_Assignment_OK (New_Ref);
- Insert_After (Init_After,
- Make_Assignment_Statement (Loc,
- Name => New_Ref,
- Expression =>
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Reference_To
- (Node
- (First_Elmt
- (Access_Disp_Table (Base_Type (Typ)))),
- Loc))));
+ Insert_After (Init_After,
+ Make_Assignment_Statement (Loc,
+ Name => New_Ref,
+ Expression =>
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To
+ (Node
+ (First_Elmt
+ (Access_Disp_Table (Full_Typ))),
+ Loc))));
+ end;
elsif Is_Tagged_Type (Typ)
and then Is_CPP_Constructor_Call (Expr)
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2011-08-01 15:18 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2011-08-01 15:18 [Ada] Frontend cleanup Arnaud Charlet
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).