This fixes a breach of privacy for types derived from private discriminated
record types whose full view has no discriminants, as well as factors out
the code doing the full derivation in the various cases into a single child
procedure of Build_Derived_Private_Type. As a consequence, this removes
obsolete code that was catching the privacy breach in some specific cases.
The following specs p1.ads, p2.ads, p3.ads and p4.ads must be rejected:
p1.ads:8:18: invalid prefix in selected component "A"
p2.ads:12:18: invalid prefix in selected component "A"
p3.ads:8:18: invalid prefix in selected component "A"
p4.ads:12:18: invalid prefix in selected component "A"
with Q;
package P1 is
type My_Data is new Q.Data;
A : My_Data;
B : Natural := A.Length;
end P1;
with Q;
package P2 is
type My_Data is private;
private
type My_Data is new Q.Data;
A : My_Data;
B : Natural := A.Length;
end P2;
package Q is
type Data is private;
private
type Small is range 1 .. 10;
type Data (D : Small := 1) is record
Length : Natural;
end record;
end Q;
with Q2;
package P3 is
type My_Data is new Q2.Data;
A : My_Data;
B : Natural := A.Length;
end P3;
with Q2;
package P4 is
type My_Data is limited private;
private
type My_Data is new Q2.Data;
A : My_Data;
B : Natural := A.Length;
end P4;
package Q2 is
type Data is limited private;
private
type Small is range 1 .. 10;
type Data (D : Small := 1) is tagged limited record
Length : Natural;
end record;
end Q2;
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-08-01 Eric Botcazou <ebotca...@adacore.com>
* einfo.ads (Has_Private_Ancestor): Remove obsolete usage.
* exp_ch4.adb (Expand_Composite_Equality): Add conversion
of the actuals in the case of untagged record types too.
* sem_ch3.adb (Build_Full_Derivation): New procedure to create the
full derivation of a derived private type, extracted from...
(Copy_And_Build): In the case of record types and most
enumeration types, copy the original declaration. Build the
full derivation according to the approach extracted from...
(Build_Derived_Private_Type): ...here. Call Build_Full_Derivation
to create the full derivation in all existing cases and also
create it in the no-discriminants/discriminants case instead of
deriving directly from the full view.
(Is_Visible_Component): Remove obsolete code.
* sem_aggr.adb (Resolve_Record_Aggregate): Likewise.
Index: sem_aggr.adb
===================================================================
--- sem_aggr.adb (revision 213458)
+++ sem_aggr.adb (working copy)
@@ -3984,21 +3984,6 @@
-- Typ is not a derived tagged type
else
- -- A type derived from an untagged private type whose full view
- -- has discriminants is constructed as a record type but there
- -- are no legal aggregates for it.
-
- if Is_Derived_Type (Typ)
- and then Has_Private_Ancestor (Typ)
- and then Nkind (N) /= N_Extension_Aggregate
- then
- Error_Msg_Node_2 := Base_Type (Etype (Typ));
- Error_Msg_NE
- ("no aggregate available for type& derived from "
- & "private type&", N, Typ);
- return;
- end if;
-
Record_Def := Type_Definition (Parent (Base_Type (Typ)));
if Null_Present (Record_Def) then
Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb (revision 213471)
+++ sem_ch3.adb (working copy)
@@ -6543,40 +6543,143 @@
Loc : constant Source_Ptr := Sloc (N);
Der_Base : Entity_Id;
Discr : Entity_Id;
- Full_Decl : Node_Id := Empty;
Full_Der : Entity_Id;
Full_P : Entity_Id;
Last_Discr : Entity_Id;
Par_Scope : constant Entity_Id := Scope (Base_Type (Parent_Type));
- Swapped : Boolean := False;
+ procedure Build_Full_Derivation;
+ -- Build full derivation, i.e. derive from the full view
+
procedure Copy_And_Build;
-- Copy derived type declaration, replace parent with its full view,
- -- and analyze new declaration.
+ -- and build derivation
+ ---------------------------
+ -- Build_Full_Derivation --
+ ---------------------------
+
+ procedure Build_Full_Derivation is
+ begin
+ -- If parent scope is not open, install the declarations
+
+ if not In_Open_Scopes (Par_Scope) then
+ Install_Private_Declarations (Par_Scope);
+ Install_Visible_Declarations (Par_Scope);
+ Copy_And_Build;
+ Uninstall_Declarations (Par_Scope);
+
+ -- If parent scope is open and in another unit, and parent has a
+ -- completion, then the derivation is taking place in the visible
+ -- part of a child unit. In that case retrieve the full view of
+ -- the parent momentarily.
+
+ elsif not In_Same_Source_Unit (N, Parent_Type) then
+ Full_P := Full_View (Parent_Type);
+ Exchange_Declarations (Parent_Type);
+ Copy_And_Build;
+ Exchange_Declarations (Full_P);
+
+ -- Otherwise it is a local derivation
+
+ else
+ Copy_And_Build;
+ end if;
+ end Build_Full_Derivation;
+
--------------------
-- Copy_And_Build --
--------------------
procedure Copy_And_Build is
- Full_N : Node_Id;
+ Full_N : Node_Id;
+ Full_Parent : Entity_Id := Parent_Type;
begin
- if Ekind (Parent_Type) in Record_Kind
+ -- If the parent is itself derived from another private type,
+ -- installing the private declarations has not affected its
+ -- privacy status, so use its own full view explicitly.
+
+ if Is_Private_Type (Full_Parent)
+ and then Present (Full_View (Full_Parent))
+ then
+ Full_Parent := Full_View (Full_Parent);
+ end if;
+
+ if Ekind (Full_Parent) in Record_Kind
or else
- (Ekind (Parent_Type) in Enumeration_Kind
- and then not Is_Standard_Character_Type (Parent_Type)
- and then not Is_Generic_Type (Root_Type (Parent_Type)))
+ (Ekind (Full_Parent) in Enumeration_Kind
+ and then not Is_Standard_Character_Type (Full_Parent)
+ and then not Is_Generic_Type (Root_Type (Full_Parent)))
then
+ -- Copy declaration to provide a completion for what is a private
+ -- declaration. Indicate that full view is internally generated.
+
Full_N := New_Copy_Tree (N);
+ Full_Der := New_Copy (Derived_Type);
+ Set_Comes_From_Source (Full_N, False);
+ Set_Comes_From_Source (Full_Der, False);
+ Set_Defining_Identifier (Full_N, Full_Der);
+ Set_Parent (Full_Der, Full_N);
Insert_After (N, Full_N);
- Build_Derived_Type (
- Full_N, Parent_Type, Full_Der, True, Derive_Subps => False);
+ -- Build full view of derived type from full view of parent which
+ -- is now installed. Subprograms have been derived on the partial
+ -- view, the completion does not derive them anew.
+
+ if Ekind (Full_Parent) in Record_Kind then
+ -- If parent type is tagged, the completion inherits the proper
+ -- primitive operations.
+
+ if Is_Tagged_Type (Parent_Type) then
+ Build_Derived_Record_Type (
+ Full_N, Full_Parent, Full_Der, Derive_Subps);
+ else
+ Build_Derived_Record_Type (
+ Full_N, Full_Parent, Full_Der, Derive_Subps => False);
+ end if;
+
+ else
+ Build_Derived_Enumeration_Type (Full_N, Full_Parent, Full_Der);
+ end if;
+
+ -- The full declaration has been introduced into the tree and
+ -- processed in the step above. It should not be analyzed again
+ -- (when encountered later in the current list of declarations)
+ -- to prevent spurious name conflicts. The full entity remains
+ -- invisible.
+
+ Set_Analyzed (Full_N);
+
else
+ Full_Der :=
+ Make_Defining_Identifier
+ (Sloc (Derived_Type), Chars (Derived_Type));
+ Set_Is_Itype (Full_Der);
+ Set_Associated_Node_For_Itype (Full_Der, N);
+ Set_Parent (Full_Der, N);
Build_Derived_Type (
- N, Parent_Type, Full_Der, True, Derive_Subps => False);
+ N, Full_Parent, Full_Der, True, Derive_Subps => False);
end if;
+
+ Set_Has_Private_Declaration (Full_Der);
+ Set_Has_Private_Declaration (Derived_Type);
+
+ Set_Scope (Full_Der, Scope (Derived_Type));
+ Set_Is_First_Subtype (Full_Der, Is_First_Subtype (Derived_Type));
+ Set_Has_Size_Clause (Full_Der, False);
+ Set_Has_Alignment_Clause (Full_Der, False);
+ Set_Has_Delayed_Freeze (Full_Der);
+ Set_Is_Frozen (Full_Der, False);
+ Set_Freeze_Node (Full_Der, Empty);
+ Set_Depends_On_Private (Full_Der, Has_Private_Component (Full_Der));
+ Set_Is_Public (Full_Der, Is_Public (Derived_Type));
+
+ -- The convention on the base type may be set in the private part
+ -- and not propagated to the subtype until later, so we obtain the
+ -- convention from the base type of the parent.
+
+ Set_Convention (Full_Der, Convention (Base_Type (Full_Parent)));
end Copy_And_Build;
-- Start of processing for Build_Derived_Private_Type
@@ -6688,19 +6791,11 @@
elsif Has_Discriminants (Parent_Type) then
if Present (Full_View (Parent_Type)) then
if not Is_Completion then
+ -- If this is not a completion, construct the implicit full
+ -- view by deriving from the full view of the parent type.
- -- Copy declaration for subsequent analysis, to provide a
- -- completion for what is a private declaration. Indicate that
- -- the full type is internally generated.
+ Build_Full_Derivation;
- Full_Decl := New_Copy_Tree (N);
- Full_Der := New_Copy (Derived_Type);
- Set_Comes_From_Source (Full_Decl, False);
- Set_Comes_From_Source (Full_Der, False);
- Set_Parent (Full_Der, Full_Decl);
-
- Insert_After (N, Full_Decl);
-
else
-- If this is a completion, the full view being built is itself
-- private. We build a subtype of the parent with the same
@@ -6736,59 +6831,8 @@
(N, Parent_Type, Derived_Type, Derive_Subps);
if Present (Full_View (Parent_Type)) and then not Is_Completion then
- if not In_Open_Scopes (Par_Scope)
- or else not In_Same_Source_Unit (N, Parent_Type)
- then
- -- Swap partial and full views temporarily
+ -- Install full view in derived type (base type and subtype)
- Install_Private_Declarations (Par_Scope);
- Install_Visible_Declarations (Par_Scope);
- Swapped := True;
- end if;
-
- -- Build full view of derived type from full view of parent which
- -- is now installed. Subprograms have been derived on the partial
- -- view, the completion does not derive them anew.
-
- if not Is_Tagged_Type (Parent_Type) then
-
- -- If the parent is itself derived from another private type,
- -- installing the private declarations has not affected its
- -- privacy status, so use its own full view explicitly.
-
- if Is_Private_Type (Parent_Type) then
- Build_Derived_Record_Type
- (Full_Decl, Full_View (Parent_Type), Full_Der, False);
- else
- Build_Derived_Record_Type
- (Full_Decl, Parent_Type, Full_Der, False);
- end if;
-
- else
- -- If full view of parent is tagged, the completion inherits
- -- the proper primitive operations.
-
- Set_Defining_Identifier (Full_Decl, Full_Der);
- Build_Derived_Record_Type
- (Full_Decl, Parent_Type, Full_Der, Derive_Subps);
- end if;
-
- -- The full declaration has been introduced into the tree and
- -- processed in the step above. It should not be analyzed again
- -- (when encountered later in the current list of declarations)
- -- to prevent spurious name conflicts. The full entity remains
- -- invisible.
-
- Set_Analyzed (Full_Decl);
-
- if Swapped then
- Uninstall_Declarations (Par_Scope);
-
- if In_Open_Scopes (Par_Scope) then
- Install_Visible_Declarations (Par_Scope);
- end if;
- end if;
-
Der_Base := Base_Type (Derived_Type);
Set_Full_View (Derived_Type, Full_Der);
Set_Full_View (Der_Base, Base_Type (Full_Der));
@@ -6815,18 +6859,10 @@
Set_First_Entity (Derived_Type, First_Entity (Der_Base));
Set_Last_Entity (Derived_Type, Last_Entity (Der_Base));
Set_Stored_Constraint (Full_Der, Stored_Constraint (Derived_Type));
-
- else
- -- If this is a completion, the derived type stays private and
- -- there is no need to create a further full view, except in the
- -- unusual case when the derivation is nested within a child unit,
- -- see below.
-
- null;
end if;
elsif Present (Full_View (Parent_Type))
- and then Has_Discriminants (Full_View (Parent_Type))
+ and then Has_Discriminants (Full_View (Parent_Type))
then
if Has_Unknown_Discriminants (Parent_Type)
and then Nkind (Subtype_Indication (Type_Definition (N))) =
@@ -6838,43 +6874,20 @@
return;
end if;
- -- If full view of parent is a record type, build full view as a
- -- derivation from the parent's full view. Partial view remains
- -- private. For code generation and linking, the full view must have
- -- the same public status as the partial one. This full view is only
- -- needed if the parent type is in an enclosing scope, so that the
- -- full view may actually become visible, e.g. in a child unit. This
- -- is both more efficient, and avoids order of freezing problems with
- -- the added entities.
+ if not Is_Completion then
+ -- If this is not a completion, construct the implicit full view
+ -- by deriving from the full view of the parent type.
- if not Is_Private_Type (Full_View (Parent_Type))
- and then (In_Open_Scopes (Scope (Parent_Type)))
- then
- Full_Der :=
- Make_Defining_Identifier (Sloc (Derived_Type),
- Chars => Chars (Derived_Type));
-
- Set_Is_Itype (Full_Der);
- Set_Has_Private_Declaration (Full_Der);
- Set_Has_Private_Declaration (Derived_Type);
- Set_Associated_Node_For_Itype (Full_Der, N);
- Set_Parent (Full_Der, Parent (Derived_Type));
+ Build_Full_Derivation;
Set_Full_View (Derived_Type, Full_Der);
- Set_Is_Public (Full_Der, Is_Public (Derived_Type));
- Full_P := Full_View (Parent_Type);
- Exchange_Declarations (Parent_Type);
- Copy_And_Build;
- Exchange_Declarations (Full_P);
else
- Build_Derived_Record_Type
- (N, Full_View (Parent_Type), Derived_Type,
- Derive_Subps => False);
+ -- If this is a completion, the full view being built is itself
+ -- private. Construct an underlying full view by deriving from
+ -- the full view of the parent type.
- -- Except in the context of the full view of the parent, there
- -- are no non-extension aggregates for the derived type.
-
- Set_Has_Private_Ancestor (Derived_Type);
+ Build_Full_Derivation;
+ Set_Underlying_Full_View (Derived_Type, Full_Der);
end if;
-- In any case, the primitive operations are inherited from the
@@ -6886,6 +6899,10 @@
Derive_Subprograms (Parent_Type, Derived_Type);
end if;
+ Set_Stored_Constraint (Derived_Type, No_Elist);
+ Set_Is_Constrained
+ (Derived_Type, Is_Constrained (Full_View (Parent_Type)));
+
else
-- Untagged type, No discriminants on either view
@@ -6917,9 +6934,8 @@
(Base_Type (Derived_Type), Finalize_Storage_Only (Parent_Type));
end if;
- -- Construct the implicit full view by deriving from full view of the
- -- parent type. In order to get proper visibility, we install the
- -- parent scope and its declarations.
+ -- If this is not a completion, construct the implicit full view by
+ -- deriving from the full view of the parent type.
-- ??? If the parent is untagged private and its completion is
-- tagged, this mechanism will not work because we cannot derive from
@@ -6929,51 +6945,8 @@
and then not Is_Tagged_Type (Full_View (Parent_Type))
and then not Is_Completion
then
- Full_Der :=
- Make_Defining_Identifier
- (Sloc (Derived_Type), Chars (Derived_Type));
- Set_Is_Itype (Full_Der);
- Set_Has_Private_Declaration (Full_Der);
- Set_Has_Private_Declaration (Derived_Type);
- Set_Associated_Node_For_Itype (Full_Der, N);
- Set_Parent (Full_Der, Parent (Derived_Type));
+ Build_Full_Derivation;
Set_Full_View (Derived_Type, Full_Der);
-
- if not In_Open_Scopes (Par_Scope) then
- Install_Private_Declarations (Par_Scope);
- Install_Visible_Declarations (Par_Scope);
- Copy_And_Build;
- Uninstall_Declarations (Par_Scope);
-
- -- If parent scope is open and in another unit, and parent has a
- -- completion, then the derivation is taking place in the visible
- -- part of a child unit. In that case retrieve the full view of
- -- the parent momentarily.
-
- elsif not In_Same_Source_Unit (N, Parent_Type) then
- Full_P := Full_View (Parent_Type);
- Exchange_Declarations (Parent_Type);
- Copy_And_Build;
- Exchange_Declarations (Full_P);
-
- -- Otherwise it is a local derivation
-
- else
- Copy_And_Build;
- end if;
-
- Set_Scope (Full_Der, Current_Scope);
- Set_Is_First_Subtype (Full_Der,
- Is_First_Subtype (Derived_Type));
- Set_Has_Size_Clause (Full_Der, False);
- Set_Has_Alignment_Clause (Full_Der, False);
- Set_Next_Entity (Full_Der, Empty);
- Set_Has_Delayed_Freeze (Full_Der);
- Set_Is_Frozen (Full_Der, False);
- Set_Freeze_Node (Full_Der, Empty);
- Set_Depends_On_Private (Full_Der,
- Has_Private_Component (Full_Der));
- Set_Public_Status (Full_Der);
end if;
end if;
@@ -7012,25 +6985,17 @@
-- underlying full view that will be installed when the enclosing
-- child body is compiled.
- Full_Der :=
- Make_Defining_Identifier
- (Sloc (Derived_Type), Chars (Derived_Type));
- Set_Is_Itype (Full_Der);
- Build_Itype_Reference (Full_Der, N);
+ if Present (Underlying_Full_View (Derived_Type)) then
+ Full_Der := Underlying_Full_View (Derived_Type);
+ else
+ Build_Full_Derivation;
+ Set_Underlying_Full_View (Derived_Type, Full_Der);
+ end if;
-- The full view will be used to swap entities on entry/exit to
-- the body, and must appear in the entity list for the package.
Append_Entity (Full_Der, Scope (Derived_Type));
- Set_Has_Private_Declaration (Full_Der);
- Set_Has_Private_Declaration (Derived_Type);
- Set_Associated_Node_For_Itype (Full_Der, N);
- Set_Parent (Full_Der, Parent (Derived_Type));
- Full_P := Full_View (Parent_Type);
- Exchange_Declarations (Parent_Type);
- Copy_And_Build;
- Exchange_Declarations (Full_P);
- Set_Underlying_Full_View (Derived_Type, Full_Der);
end if;
end if;
end Build_Derived_Private_Type;
@@ -16991,16 +16956,10 @@
Type_Scope := Scope (Base_Type (Scope (C)));
end if;
- -- For an untagged type derived from a private type, the only visible
- -- components are new discriminants. In an instance all components are
- -- visible (see Analyze_Selected_Component).
+ -- This test only concerns tagged types
if not Is_Tagged_Type (Original_Scope) then
- return not Has_Private_Ancestor (Original_Scope)
- or else In_Open_Scopes (Scope (Original_Scope))
- or else In_Instance
- or else (Ekind (Original_Comp) = E_Discriminant
- and then Original_Scope = Type_Scope);
+ return True;
-- If it is _Parent or _Tag, there is no visibility issue
Index: einfo.ads
===================================================================
--- einfo.ads (revision 213446)
+++ einfo.ads (working copy)
@@ -1799,14 +1799,12 @@
-- is defined for the type.
-- Has_Private_Ancestor (Flag151)
--- Applies to untagged derived types and to type extensions. True when
--- some ancestor is derived from a private type, making some components
--- invisible and aggregates illegal. Used to check the legality of
--- selected components and aggregates. The flag is set at the point of
--- derivation. The legality of an aggregate of a type with a private
--- ancestor must be checked because it also depends on the visibility
--- at the point the aggregate is resolved. See sem_aggr.adb. This is
--- part of AI05-0115.
+-- 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)
-- Defined in all entities. Set if it is the defining entity of a private
Index: exp_ch4.adb
===================================================================
--- exp_ch4.adb (revision 213471)
+++ exp_ch4.adb (working copy)
@@ -2829,10 +2829,17 @@
end;
else
- return
- Make_Function_Call (Loc,
- Name => New_Occurrence_Of (Eq_Op, Loc),
- Parameter_Associations => New_List (Lhs, Rhs));
+ declare
+ T : constant Entity_Id := Etype (First_Formal (Eq_Op));
+
+ begin
+ return
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (Eq_Op, Loc),
+ Parameter_Associations => New_List (
+ OK_Convert_To (T, Lhs),
+ OK_Convert_To (T, Rhs)));
+ end;
end if;
end if;
