Patchwork [Ada] Frontend cleanup

login
register
mail settings
Submitter Arnaud Charlet
Date Aug. 1, 2011, 3:17 p.m.
Message ID <20110801151748.GA11916@adacore.com>
Download mbox | patch
Permalink /patch/107770/
State New
Headers show

Comments

Arnaud Charlet - Aug. 1, 2011, 3:17 p.m.
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.

Patch

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)