einfo.ads, einfo.adb: New attribute Underlying_Record_View...

2009-04-17  Ed Schonberg  <schonberg@adacore.com>

	* einfo.ads, einfo.adb: New attribute Underlying_Record_View, to handle
	type extensions whose parent is a type with unknown discriminants.

	* exp_aggr.adb (Expand_Record_Aggregate): If the type of an extension
	aggregate has unknown discriminants, use the Underlying_Record_View to
	obtain the discriminants of the ancestor part.

	* exp_disp.adb (Build_Dispatch_Tables): Types that are
	Underlying_Record_Views share the dispatching information of the
	original record extension.

	* exp_ch3.adb (Expand_Record_Extension): If the type inherits unknown
	discriminants, propagate dispach table information to the
	Underlying_Record_View.

	* sem_ch3.adb (Build_Derived_Private_Type): If parent type has unknown
	discriminants and declaration is not a completion, generate
	Underlying_Record_View to provide proper discriminant information to
	the front-end and to gigi.

From-SVN: r146264

7 files changed, 187 insertions, 10 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 732023b..3ace58e 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,25 @@
+2009-04-17  Ed Schonberg  <schonberg@adacore.com>
+
+	* einfo.ads, einfo.adb: New attribute Underlying_Record_View, to handle
+	type extensions whose parent is a type with unknown discriminants.
+
+	* exp_aggr.adb (Expand_Record_Aggregate): If the type of an extension
+	aggregate has unknown discriminants, use the Underlying_Record_View to
+	obtain the discriminants of the ancestor part.
+
+	* exp_disp.adb (Build_Dispatch_Tables): Types that are
+	Underlying_Record_Views share the dispatching information of the
+	original record extension.
+
+	* exp_ch3.adb (Expand_Record_Extension): If the type inherits unknown
+	discriminants, propagate dispach table information to the
+	Underlying_Record_View.
+
+	* sem_ch3.adb (Build_Derived_Private_Type): If parent type has unknown
+	discriminants and declaration is not a completion, generate
+	Underlying_Record_View to provide proper discriminant information to
+	the front-end and to gigi.
+
 2009-04-17  Robert Dewar  <dewar@adacore.com>
 
 	* s-conca5.adb, g-sercom.adb, s-conca5.ads, s-conca7.adb, exp_imgv.adb,
diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb
index 72db40f..92d9ce2 100644
--- a/gcc/ada/einfo.adb
+++ b/gcc/ada/einfo.adb
@@ -206,6 +206,7 @@ package body Einfo is
    --    Stored_Constraint               Elist23
 
    --    Spec_PPC_List                   Node24
+   --    Underlying_Record_View          Node24
 
    --    Interface_Alias                 Node25
    --    Interfaces                      Elist25
@@ -2672,6 +2673,12 @@ package body Einfo is
       return Node19 (Id);
    end Underlying_Full_View;
 
+   function Underlying_Record_View (Id : E) return E is
+   begin
+      pragma Assert (Ekind (Id) = E_Record_Type);
+      return Node24 (Id);
+   end Underlying_Record_View;
+
    function Universal_Aliasing (Id : E) return B is
    begin
       pragma Assert (Is_Type (Id));
@@ -5152,6 +5159,12 @@ package body Einfo is
       Set_Node19 (Id, V);
    end Set_Underlying_Full_View;
 
+   procedure Set_Underlying_Record_View (Id : E; V : E) is
+   begin
+      pragma Assert (Ekind (Id) = E_Record_Type);
+      Set_Node24 (Id, V);
+   end Set_Underlying_Record_View;
+
    procedure Set_Universal_Aliasing (Id : E; V : B := True) is
    begin
       pragma Assert (Is_Type (Id) and then Id = Base_Type (Id));
@@ -7909,6 +7922,9 @@ package body Einfo is
          when Subprogram_Kind                              =>
             Write_Str ("Spec_PPC_List");
 
+         when E_Record_Type                                =>
+            Write_Str ("Underlying record view");
+
          when others                                       =>
             Write_Str ("???");
       end case;
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index 9486135..91883e7 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -3558,6 +3558,13 @@ package Einfo is
 --       private completion. If Td is already constrained, then its full view
 --       can serve directly as the full view of T.
 
+--    Underlying_Record_View (Node24)
+--       Present in record types. Set for record types that are extensions of
+--       types with unknown discriminants. Such types do not have a completion,
+--       but they cannot be used without having some discriminated view at
+--       hand. This view is a record type with the same structure, whose parent
+--       type is the full view of the parent in the original type extension.
+
 --    Underlying_Type (synthesized)
 --       Applies to all entities. This is the identity function except in the
 --       case where it is applied to an incomplete or private type, in which
@@ -5246,6 +5253,7 @@ package Einfo is
    --    Discriminant_Constraint             (Elist21)
    --    Corresponding_Remote_Type           (Node22)
    --    Stored_Constraint                   (Elist23)
+   --    Underlying_Record_View              (Node24)   (base type only)
    --    Interfaces                          (Elist25)
    --    Component_Alignment                 (special)  (base type only)
    --    C_Pass_By_Copy                      (Flag125)  (base type only)
@@ -5983,6 +5991,7 @@ package Einfo is
    function Task_Body_Procedure                 (Id : E) return N;
    function Treat_As_Volatile                   (Id : E) return B;
    function Underlying_Full_View                (Id : E) return E;
+   function Underlying_Record_View              (Id : E) return E;
    function Universal_Aliasing                  (Id : E) return B;
    function Unset_Reference                     (Id : E) return N;
    function Used_As_Generic_Actual              (Id : E) return B;
@@ -6534,6 +6543,7 @@ package Einfo is
    procedure Set_Task_Body_Procedure             (Id : E; V : N);
    procedure Set_Treat_As_Volatile               (Id : E; V : B := True);
    procedure Set_Underlying_Full_View            (Id : E; V : E);
+   procedure Set_Underlying_Record_View          (Id : E; V : E);
    procedure Set_Universal_Aliasing              (Id : E; V : B := True);
    procedure Set_Unset_Reference                 (Id : E; V : N);
    procedure Set_Used_As_Generic_Actual          (Id : E; V : B := True);
@@ -7226,6 +7236,7 @@ package Einfo is
    pragma Inline (Task_Body_Procedure);
    pragma Inline (Treat_As_Volatile);
    pragma Inline (Underlying_Full_View);
+   pragma Inline (Underlying_Record_View);
    pragma Inline (Universal_Aliasing);
    pragma Inline (Unset_Reference);
    pragma Inline (Used_As_Generic_Actual);
@@ -7610,6 +7621,7 @@ package Einfo is
    pragma Inline (Set_Task_Body_Procedure);
    pragma Inline (Set_Treat_As_Volatile);
    pragma Inline (Set_Underlying_Full_View);
+   pragma Inline (Set_Underlying_Record_View);
    pragma Inline (Set_Universal_Aliasing);
    pragma Inline (Set_Unset_Reference);
    pragma Inline (Set_Used_As_Generic_Actual);
diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index 0ed20d0..bd9fb0d 100644
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -2550,6 +2550,9 @@ package body Exp_Aggr is
             --  in the limited case, the ancestor part must be either a
             --  function call (possibly qualified, or wrapped in an unchecked
             --  conversion) or aggregate (definitely qualified).
+            --  The ancestor part can also be a function call (that may be
+            --  transformed into an explicit dereference) or a qualification
+            --  of one such.
 
             elsif Is_Limited_Type (Etype (A))
               and then Nkind (Unqualify (A)) /= N_Function_Call --  aggregate?
@@ -2557,6 +2560,7 @@ package body Exp_Aggr is
                 (Nkind (Unqualify (A)) /= N_Unchecked_Type_Conversion
                    or else
                  Nkind (Expression (Unqualify (A))) /= N_Function_Call)
+              and then Nkind (Unqualify (A)) /= N_Explicit_Dereference
             then
                Ancestor_Is_Expression := True;
 
@@ -3420,6 +3424,7 @@ package body Exp_Aggr is
 
    procedure Convert_To_Assignments (N : Node_Id; Typ : Entity_Id) is
       Loc  : constant Source_Ptr := Sloc (N);
+      T    : Entity_Id;
       Temp : Entity_Id;
 
       Instr       : Node_Id;
@@ -3524,18 +3529,29 @@ package body Exp_Aggr is
       else
          Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
 
+         --  If the type inherits unknown discriminants, use the view with
+         --  known discriminants if available.
+
+         if Has_Unknown_Discriminants (Typ)
+            and then Present (Underlying_Record_View (Typ))
+         then
+            T := Underlying_Record_View (Typ);
+         else
+            T := Typ;
+         end if;
+
          Instr :=
            Make_Object_Declaration (Loc,
              Defining_Identifier => Temp,
-             Object_Definition   => New_Occurrence_Of (Typ, Loc));
+             Object_Definition   => New_Occurrence_Of (T, Loc));
 
          Set_No_Initialization (Instr);
          Insert_Action (N, Instr);
-         Initialize_Discriminants (Instr, Typ);
+         Initialize_Discriminants (Instr, T);
          Target_Expr := New_Occurrence_Of (Temp, Loc);
-         Insert_Actions (N, Build_Record_Aggr_Code (N, Typ, Target_Expr));
+         Insert_Actions (N, Build_Record_Aggr_Code (N, T, Target_Expr));
          Rewrite (N, New_Occurrence_Of (Temp, Loc));
-         Analyze_And_Resolve (N, Typ);
+         Analyze_And_Resolve (N, T);
       end if;
    end Convert_To_Assignments;
 
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 242e5c4..4442a78 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -3007,7 +3007,9 @@ package body Exp_Ch3 is
          --  If it is a type derived from a type with unknown discriminants,
          --  we cannot build an initialization procedure for it.
 
-         if Has_Unknown_Discriminants (Rec_Id) then
+         if Has_Unknown_Discriminants (Rec_Id)
+           or else Has_Unknown_Discriminants (Etype (Rec_Id))
+         then
             return False;
          end if;
 
@@ -3890,6 +3892,16 @@ package body Exp_Ch3 is
          Par_Subtype := Process_Subtype (New_Copy_Tree (Indic), Def);
       end if;
 
+      --  If this is an extension of a type with unknown discriminants, use
+      --  full view to provide proper discriminants to gigi.
+
+      if Has_Unknown_Discriminants (Par_Subtype)
+        and then Is_Private_Type (Par_Subtype)
+        and then Present (Full_View (Par_Subtype))
+      then
+         Par_Subtype := Full_View (Par_Subtype);
+      end if;
+
       Set_Parent_Subtype (T, Par_Subtype);
 
       Comp_Decl :=
@@ -5732,6 +5744,27 @@ package body Exp_Ch3 is
                end if;
             end if;
 
+            --  If the type has unknown discriminants, propagate dispatching
+            --  information to its underlying record view, which does not get
+            --  its own dispatch table.
+
+            if Is_Derived_Type (Def_Id)
+              and then Has_Unknown_Discriminants (Def_Id)
+              and then Present (Underlying_Record_View (Def_Id))
+            then
+               declare
+                  Rep : constant Entity_Id :=
+                           Underlying_Record_View (Def_Id);
+               begin
+                  Set_Access_Disp_Table
+                    (Rep, Access_Disp_Table       (Def_Id));
+                  Set_Dispatch_Table_Wrappers
+                    (Rep, Dispatch_Table_Wrappers (Def_Id));
+                  Set_Primitive_Operations
+                    (Rep, Primitive_Operations    (Def_Id));
+               end;
+            end if;
+
             --  Make sure that the primitives Initialize, Adjust and Finalize
             --  are Frozen before other TSS subprograms. We don't want them
             --  Frozen inside.
@@ -7526,7 +7559,7 @@ package body Exp_Ch3 is
                        Null_Exclusion_Present =>
                          Null_Exclusion_Present (Parent (Formal)),
                        Parameter_Type =>
-                         New_Reference_To (Etype (Formal), Loc),
+                         New_Occurrence_Of (Etype (Formal), Loc),
                        Expression =>
                          New_Copy_Tree (Expression (Parent (Formal)))),
                      Formal_List);
diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index 3d9a4ad..6a125ec 100644
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -170,8 +170,24 @@ package body Exp_Disp is
               and then Ekind (Defining_Entity (D)) /= E_Record_Subtype
               and then not Is_Private_Type (Defining_Entity (D))
             then
-               Insert_List_After_And_Analyze (Last (Target_List),
-                 Make_DT (Defining_Entity (D)));
+
+               --  We do not generate dispatch tables for the internal type
+               --  created for a type extension with unknown discriminants
+               --  The needed information is shared with the source type,
+               --  See Expand_N_Record_Extension.
+
+               if not Comes_From_Source (Defining_Entity (D))
+                 and then
+                   Has_Unknown_Discriminants (Etype (Defining_Entity (D)))
+                 and then
+                    not Comes_From_Source (First_Subtype (Defining_Entity (D)))
+               then
+                  null;
+
+               else
+                  Insert_List_After_And_Analyze (Last (Target_List),
+                    Make_DT (Defining_Entity (D)));
+               end if;
 
             --  Handle private types of library level tagged types. We must
             --  exchange the private and full-view to ensure the correct
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 243c9f7..11c6491 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -5462,6 +5462,7 @@ package body Sem_Ch3 is
       Is_Completion : Boolean;
       Derive_Subps  : Boolean := True)
    is
+      Loc         : constant Source_Ptr := Sloc (N);
       Der_Base    : Entity_Id;
       Discr       : Entity_Id;
       Full_Decl   : Node_Id := Empty;
@@ -5504,8 +5505,69 @@ package body Sem_Ch3 is
 
    begin
       if Is_Tagged_Type (Parent_Type) then
-         Build_Derived_Record_Type
-           (N, Parent_Type, Derived_Type, Derive_Subps);
+
+         --  A type extension of a type with unknown discriminants is an
+         --  indefinite type that the back-end cannot handle directly.
+         --  We treat it as a private type, and build a completion that is
+         --  derived from the full view of the parent, and hopefully has
+         --  known discriminants.  The implementation of more complex chains
+         --  of derivation with unknown discriminants is left to the more
+         --  enterprising reader.
+
+         if Has_Unknown_Discriminants (Parent_Type)
+           and then Present (Full_View (Parent_Type))
+           and then not In_Open_Scopes (Par_Scope)
+           and then not Is_Completion
+           and then Expander_Active
+         then
+            declare
+               Full_Der : constant Entity_Id :=
+                 Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
+               Decl : Node_Id;
+               New_Ext : constant Node_Id :=
+                           Copy_Separate_Tree
+                             (Record_Extension_Part (Type_Definition (N)));
+
+            begin
+               Build_Derived_Record_Type
+                 (N, Parent_Type, Derived_Type, Derive_Subps);
+
+               --  Build anonymous completion, as a derivation from the full
+               --  view of the parent.
+
+               Decl :=
+                 Make_Full_Type_Declaration (Loc,
+                   Defining_Identifier => Full_Der,
+                   Type_Definition     =>
+                     Make_Derived_Type_Definition (Loc,
+                       Subtype_Indication =>
+                         New_Copy_Tree
+                           (Subtype_Indication (Type_Definition (N))),
+                       Record_Extension_Part => New_Ext));
+               Set_Has_Private_Declaration (Full_Der);
+               Set_Has_Private_Declaration (Derived_Type);
+
+               Install_Private_Declarations (Par_Scope);
+               Install_Visible_Declarations (Par_Scope);
+               Insert_Before (N, Decl);
+               Analyze (Decl);
+               Uninstall_Declarations (Par_Scope);
+
+               --  Freeze the underlying record view, to prevent generation
+               --  of useless dispatching information, which is simply shared
+               --  with the real derived type.
+
+               Set_Is_Frozen (Full_Der);
+               Set_Underlying_Record_View (Derived_Type, Full_Der);
+            end;
+
+         --  if discriminants are known, build derived record.
+
+         else
+            Build_Derived_Record_Type
+              (N, Parent_Type, Derived_Type, Derive_Subps);
+         end if;
+
          return;
 
       elsif Has_Discriminants (Parent_Type) then