Index: sem_ch3.adb =================================================================== --- sem_ch3.adb (revision 146237) +++ sem_ch3.adb (working copy) @@ -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 Index: einfo.adb =================================================================== --- einfo.adb (revision 146005) +++ einfo.adb (working copy) @@ -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; Index: einfo.ads =================================================================== --- einfo.ads (revision 146005) +++ einfo.ads (working copy) @@ -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); Index: exp_disp.adb =================================================================== --- exp_disp.adb (revision 146102) +++ exp_disp.adb (working copy) @@ -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 Index: exp_aggr.adb =================================================================== --- exp_aggr.adb (revision 146254) +++ exp_aggr.adb (working copy) @@ -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; Index: exp_ch3.adb =================================================================== --- exp_ch3.adb (revision 146254) +++ exp_ch3.adb (working copy) @@ -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);