===================================================================
@@ -45,6 +45,7 @@
with Sem_Aux; use Sem_Aux;
with Sem_Cat; use Sem_Cat;
with Sem_Ch3; use Sem_Ch3;
+with Sem_Ch8; use Sem_Ch8;
with Sem_Ch13; use Sem_Ch13;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
@@ -2573,6 +2574,15 @@
and then Is_Type (Entity (A))
then
Check_SPARK_Restriction ("ancestor part cannot be a type mark", A);
+
+ -- AI05-0115: if the ancestor part is a subtype mark, the ancestor
+ -- must not have unknown discriminants.
+
+ if Has_Unknown_Discriminants (Root_Type (Typ)) then
+ Error_Msg_NE
+ ("aggregate not available for type& whose ancestor "
+ & "has unknown discriminants", N, Typ);
+ end if;
end if;
if not Is_Tagged_Type (Typ) then
@@ -3405,6 +3415,18 @@
Positional_Expr := Empty;
end if;
+ -- AI05-0115: if the ancestor part is a subtype mark, the ancestor
+ -- must npt have unknown discriminants.
+
+ if Is_Derived_Type (Typ)
+ and then Has_Unknown_Discriminants (Root_Type (Typ))
+ and then Nkind (N) /= N_Extension_Aggregate
+ then
+ Error_Msg_NE
+ ("aggregate not available for type& whose ancestor "
+ & "has unknown discriminants ", N, Typ);
+ end if;
+
if Has_Unknown_Discriminants (Typ)
and then Present (Underlying_Record_View (Typ))
then
@@ -3558,6 +3580,35 @@
Errors_Found : Boolean := False;
Dnode : Node_Id;
+ function Find_Private_Ancestor return Entity_Id;
+ -- AI05-0115: Find earlier ancestor in the derivation chain that is
+ -- derived from a private view. Whether the aggregate is legal
+ -- depends on the current visibility of the type as well as that
+ -- of the parent of the ancestor.
+
+ ---------------------------
+ -- Find_Private_Ancestor --
+ ---------------------------
+
+ function Find_Private_Ancestor return Entity_Id is
+ Par : Entity_Id;
+ begin
+ Par := Typ;
+ loop
+ if Has_Private_Ancestor (Par)
+ and then not Has_Private_Ancestor (Etype (Base_Type (Par)))
+ then
+ return Par;
+
+ elsif not Is_Derived_Type (Par) then
+ return Empty;
+
+ else
+ Par := Etype (Base_Type (Par));
+ end if;
+ end loop;
+ end Find_Private_Ancestor;
+
begin
if Is_Derived_Type (Typ) and then Is_Tagged_Type (Typ) then
Parent_Typ_List := New_Elmt_List;
@@ -3571,16 +3622,45 @@
Root_Typ := Base_Type (Etype (Ancestor_Part (N)));
else
+ -- AI05-0115: check legality of aggregate for type with
+ -- aa private ancestor.
+
Root_Typ := Root_Type (Typ);
+ if Has_Private_Ancestor (Typ) then
+ declare
+ Ancestor : constant Entity_Id :=
+ Find_Private_Ancestor;
+ Ancestor_Unit : constant Entity_Id :=
+ Cunit_Entity (Get_Source_Unit (Ancestor));
+ Parent_Unit : constant Entity_Id :=
+ Cunit_Entity
+ (Get_Source_Unit (Base_Type (Etype (Ancestor))));
+ begin
- if Nkind (Parent (Base_Type (Root_Typ))) =
- N_Private_Type_Declaration
- then
- Error_Msg_NE
- ("type of aggregate has private ancestor&!",
- N, Root_Typ);
- Error_Msg_N ("must use extension aggregate!", N);
- return;
+ -- check whether we are in a scope that has full view
+ -- over the private ancestor and its parent. This can
+ -- only happen if the derivation takes place in a child
+ -- unit of the unit that declares the parent, and we are
+ -- in the private part or body of that child unit, else
+ -- the aggregate is illegal.
+
+ if Is_Child_Unit (Ancestor_Unit)
+ and then Scope (Ancestor_Unit) = Parent_Unit
+ and then In_Open_Scopes (Scope (Ancestor))
+ and then
+ (In_Private_Part (Scope (Ancestor))
+ or else In_Package_Body (Scope (Ancestor)))
+ then
+ null;
+
+ else
+ Error_Msg_NE
+ ("type of aggregate has private ancestor&!",
+ N, Root_Typ);
+ Error_Msg_N ("must use extension aggregate!", N);
+ return;
+ end if;
+ end;
end if;
Dnode := Declaration_Node (Base_Type (Root_Typ));
===================================================================
@@ -7006,6 +7006,28 @@
Parent_Base := Base_Type (Parent_Type);
end if;
+ -- AI05-0115 : if this is a derivation from a private type in some
+ -- other scope that may lead to invisible components for the derived
+ -- type, mark it accordingly.
+
+ if Is_Private_Type (Parent_Type) then
+ if Scope (Parent_Type) = Scope (Derived_Type) then
+ null;
+
+ elsif In_Open_Scopes (Scope (Parent_Type))
+ and then In_Private_Part (Scope (Parent_Type))
+ then
+ null;
+
+ else
+ Set_Has_Private_Ancestor (Derived_Type);
+ end if;
+
+ else
+ Set_Has_Private_Ancestor
+ (Derived_Type, Has_Private_Ancestor (Parent_Type));
+ end if;
+
-- Before we start the previously documented transformations, here is
-- little fix for size and alignment of tagged types. Normally when we
-- derive type D from type P, we copy the size and alignment of P as the
===================================================================
@@ -409,6 +409,7 @@
-- Is_Compilation_Unit Flag149
-- Has_Pragma_Elaborate_Body Flag150
+ -- Has_Private_Ancestor Flag151
-- Entry_Accepted Flag152
-- Is_Obsolescent Flag153
-- Has_Per_Object_Constraint Flag154
@@ -1312,7 +1313,9 @@
function Has_Invariants (Id : E) return B is
begin
- pragma Assert (Is_Type (Id) or else Ekind (Id) = E_Procedure);
+ pragma Assert (Is_Type (Id)
+ or else Ekind (Id) = E_Procedure
+ or else Ekind (Id) = E_Generic_Procedure);
return Flag232 (Id);
end Has_Invariants;
@@ -1445,6 +1448,11 @@
return Flag120 (Base_Type (Id));
end Has_Primitive_Operations;
+ function Has_Private_Ancestor (Id : E) return B is
+ begin
+ return Flag151 (Id);
+ end Has_Private_Ancestor;
+
function Has_Private_Declaration (Id : E) return B is
begin
return Flag155 (Id);
@@ -3936,6 +3944,12 @@
Set_Flag120 (Id, V);
end Set_Has_Primitive_Operations;
+ procedure Set_Has_Private_Ancestor (Id : E; V : B := True) is
+ begin
+ pragma Assert (Is_Type (Id));
+ Set_Flag151 (Id, V);
+ end Set_Has_Private_Ancestor;
+
procedure Set_Has_Private_Declaration (Id : E; V : B := True) is
begin
Set_Flag155 (Id, V);
@@ -6100,25 +6114,6 @@
return False;
end Has_Interrupt_Handler;
- --------------------------
- -- Has_Private_Ancestor --
- --------------------------
-
- function Has_Private_Ancestor (Id : E) return B is
- R : constant Entity_Id := Root_Type (Id);
- T1 : Entity_Id := Id;
- begin
- loop
- if Is_Private_Type (T1) then
- return True;
- elsif T1 = R then
- return False;
- else
- T1 := Etype (T1);
- end if;
- end loop;
- end Has_Private_Ancestor;
-
--------------------
-- Has_Rep_Pragma --
--------------------
@@ -7461,6 +7456,7 @@
W ("Has_Pragma_Unreferenced_Objects", Flag212 (Id));
W ("Has_Predicates", Flag250 (Id));
W ("Has_Primitive_Operations", Flag120 (Id));
+ W ("Has_Private_Ancestor", Flag151 (Id));
W ("Has_Private_Declaration", Flag155 (Id));
W ("Has_Qualified_Name", Flag161 (Id));
W ("Has_RACW", Flag214 (Id));
===================================================================
@@ -1690,10 +1690,13 @@
-- Present in all type entities. Set if at least one primitive operation
-- is defined for the type.
+-- Has_Private_Ancestor (Flag151)
+-- Applies to type extensions. True if some ancestor is derived from a
+-- private type, making some components invisible and aggregates illegal.
+-- This flag is set at the point of derivation. The legality of the
+-- aggregate must be rechecked because it also depends on the visibility
+-- at the point the aggregate is resolved. See sem_aggr.adb.
+-- This is part of AI05-0115.
-- Has_Private_Declaration (Flag155)
-- Present in all entities. Returns True if it is the defining entity
@@ -4909,7 +4912,6 @@
-- Alignment_Clause (synth)
-- Base_Type (synth)
- -- Has_Private_Ancestor (synth)
-- Implementation_Base_Type (synth)
-- Invariant_Procedure (synth)
-- Is_Access_Protected_Subprogram_Type (synth)
@@ -5581,6 +5583,7 @@
-- Has_Dispatch_Table (Flag220) (base tagged type only)
-- Has_External_Tag_Rep_Clause (Flag110)
-- Has_Pragma_Pack (Flag121) (impl base type only)
+ -- Has_Private_Ancestor (Flag151)
-- Has_Record_Rep_Clause (Flag65) (base type only)
-- Has_Static_Discriminants (Flag211) (subtype only)
-- Is_Class_Wide_Equivalent_Type (Flag35)
@@ -5607,6 +5610,7 @@
-- Stored_Constraint (Elist23)
-- Interfaces (Elist25)
-- Has_Completion (Flag26)
+ -- Has_Private_Ancestor (Flag151)
-- Has_Record_Rep_Clause (Flag65) (base type only)
-- Has_External_Tag_Rep_Clause (Flag110)
-- Is_Concurrent_Record_Type (Flag20)
@@ -6119,6 +6123,7 @@
function Has_Pragma_Unreferenced_Objects (Id : E) return B;
function Has_Predicates (Id : E) return B;
function Has_Primitive_Operations (Id : E) return B;
+ function Has_Private_Ancestor (Id : E) return B;
function Has_Qualified_Name (Id : E) return B;
function Has_RACW (Id : E) return B;
function Has_Record_Rep_Clause (Id : E) return B;
@@ -6436,7 +6441,6 @@
function Has_Attach_Handler (Id : E) return B;
function Has_Entries (Id : E) return B;
function Has_Foreign_Convention (Id : E) return B;
- function Has_Private_Ancestor (Id : E) return B;
function Has_Private_Declaration (Id : E) return B;
function Implementation_Base_Type (Id : E) return E;
function Is_Base_Type (Id : E) return B;
@@ -6705,6 +6709,7 @@
procedure Set_Has_Pragma_Unreferenced_Objects (Id : E; V : B := True);
procedure Set_Has_Predicates (Id : E; V : B := True);
procedure Set_Has_Primitive_Operations (Id : E; V : B := True);
+ procedure Set_Has_Private_Ancestor (Id : E; V : B := True);
procedure Set_Has_Private_Declaration (Id : E; V : B := True);
procedure Set_Has_Qualified_Name (Id : E; V : B := True);
procedure Set_Has_RACW (Id : E; V : B := True);
@@ -7400,6 +7405,7 @@
pragma Inline (Has_Pragma_Unreferenced_Objects);
pragma Inline (Has_Predicates);
pragma Inline (Has_Primitive_Operations);
+ pragma Inline (Has_Private_Ancestor);
pragma Inline (Has_Private_Declaration);
pragma Inline (Has_Qualified_Name);
pragma Inline (Has_RACW);
@@ -7842,6 +7848,7 @@
pragma Inline (Set_Has_Pragma_Unreferenced_Objects);
pragma Inline (Set_Has_Predicates);
pragma Inline (Set_Has_Primitive_Operations);
+ pragma Inline (Set_Has_Private_Ancestor);
pragma Inline (Set_Has_Private_Declaration);
pragma Inline (Set_Has_Qualified_Name);
pragma Inline (Set_Has_RACW);
If a type has an ancestor derived from a private view of its parent, the type may have invisible components and aggregates cannot be written for it. This is an Ada2012 binding interpretation. Compilation of pak1-pak3.adb below must yield: predicatek1-pak3.adb:6:15: no selector "C1" for type "T3" defined at pak1-pak3.ads:3 pak1-pak3.adb:7:14: type of aggregate has private ancestor "T1" pak1-pak3.adb:7:14: must use extension aggregate pak1-pak3.adb:8:14: type of aggregate has private ancestor "T1" pak1-pak3.adb:8:14: must use extension aggregate pak1-pak3.adb:9:14: type of aggregate has private ancestor "T1" pak1-pak3.adb:9:14: must use extension aggregate --- package Pak1 is type T1 is tagged private; private type T1 is tagged record C1 : Integer; end record; end Pak1; --- with Pak1; package Pak2 is type T2 is new Pak1.T1 with record C2 : Integer; end record; end Pak2; --- with Pak2; package Pak1.Pak3 is type T3 is new Pak2.T2 with record C3 : Integer; end record; procedure Foo; end Pak1.Pak3; --- package body Pak1.Pak3 is procedure Foo is R : T3; N : Integer; begin N := R.C1; -- (A: Error.) R := (C1 => 1, C2 => 2, C3 => 3); -- (B: Legal? No.) R := (C2 => 2, C3 => 3, others => 1); -- (C: Legal? No.) R := (others => 4); -- (D: Legal? No.) end Foo; end Pak1.Pak3; ---- date: 2011/03/21 11:29:58; author: quinot; TN is J701-202 Tested on x86_64-pc-linux-gnu, committed on trunk 2011-08-04 Ed Schonberg <schonberg@adacore.com> * einfo.ads, einfo.adb (Has_Private_Ancestor): now a flag on types. Remove previous procedure with that name. * sem_ch3.adb (Build_Derived_Record_Type): set Has_Private_Ancestor when appropriate. * sem_aggr.adb (Resolve_Extension_Aggregate): if the ancestor part is a subtype mark, the ancestor cannot have unknown discriminants. (Resolve_Record_Aggregate): if the type has invisible components because of a private ancestor, the aggregate is illegal.