mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-03-05 18:27:33 +08:00
Code Issues Packages Projects Releases Wiki Activity

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

Browse Source 
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
This commit is contained in:
Ed Schonberg 2009-04-17 13:17:12 +00:00 committed by Arnaud Charlet
parent 8c64de1e7d
commit 39f346aaa6
7 changed files with 187 additions and 10 deletions

22
gcc/ada/ChangeLog
View File

@ -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,

16
gcc/ada/einfo.adb
View File

@ -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;

12
gcc/ada/einfo.ads
View File

@ -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);

24
gcc/ada/exp_aggr.adb
View File

@ -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;

37
gcc/ada/exp_ch3.adb
View File

@ -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);

20
gcc/ada/exp_disp.adb
View File

@ -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

66
gcc/ada/sem_ch3.adb
View File

@ -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