diff options
author | Ed Schonberg <schonberg@adacore.com> | 2009-04-17 13:17:12 +0000 |
---|---|---|
committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2009-04-17 15:17:12 +0200 |
commit | 39f346aaa68081e3f68cb696d63e2898074d0645 (patch) | |
tree | 7e8338d0948f7ff0611cbd9b15ddfcc3aff692b0 /gcc/ada | |
parent | 8c64de1e7d8a53dc87dc64ccfe36124c0616faf2 (diff) | |
download | gcc-39f346aaa68081e3f68cb696d63e2898074d0645.zip gcc-39f346aaa68081e3f68cb696d63e2898074d0645.tar.gz gcc-39f346aaa68081e3f68cb696d63e2898074d0645.tar.bz2 |
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
Diffstat (limited to 'gcc/ada')
-rw-r--r-- | gcc/ada/ChangeLog | 22 | ||||
-rw-r--r-- | gcc/ada/einfo.adb | 16 | ||||
-rw-r--r-- | gcc/ada/einfo.ads | 12 | ||||
-rw-r--r-- | gcc/ada/exp_aggr.adb | 24 | ||||
-rw-r--r-- | gcc/ada/exp_ch3.adb | 37 | ||||
-rw-r--r-- | gcc/ada/exp_disp.adb | 20 | ||||
-rw-r--r-- | gcc/ada/sem_ch3.adb | 66 |
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 |