+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,
-- Stored_Constraint Elist23
-- Spec_PPC_List Node24
+ -- Underlying_Record_View Node24
-- Interface_Alias Node25
-- Interfaces Elist25
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));
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));
when Subprogram_Kind =>
Write_Str ("Spec_PPC_List");
+ when E_Record_Type =>
+ Write_Str ("Underlying record view");
+
when others =>
Write_Str ("???");
end case;
-- 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
-- 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)
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;
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);
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);
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);
-- 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?
(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;
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;
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;
-- 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;
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 :=
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.
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);
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
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;
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
projects / thirdparty / gcc.git / commitdiff
