===================================================================
@@ -911,7 +911,9 @@ package body Exp_Ch7 is
-- Otherwise record the outermost one and continue looking
- elsif Res = Empty or else Is_Ancestor (Res_Scop, Comp_Scop) then
+ elsif Res = Empty
+ or else Is_Ancestor (Res_Scop, Comp_Scop, Use_Full_View => True)
+ then
Res := Comp;
Res_Scop := Comp_Scop;
end if;
===================================================================
@@ -2564,7 +2564,11 @@ package body Sem_Type is
-- Is_Ancestor --
-----------------
- function Is_Ancestor (T1, T2 : Entity_Id) return Boolean is
+ function Is_Ancestor
+ (T1 : Entity_Id;
+ T2 : Entity_Id;
+ Use_Full_View : Boolean := False) return Boolean
+ is
BT1 : Entity_Id;
BT2 : Entity_Id;
Par : Entity_Id;
@@ -2624,14 +2628,14 @@ package body Sem_Type is
then
return True;
+ -- Climb to the ancestor type
+
elsif Etype (Par) /= Par then
- -- If this is a private type and its parent is an interface
- -- then use the parent of the full view (which is a type that
- -- implements such interface)
+ -- Use the full-view of private types (if allowed)
- if Is_Private_Type (Par)
- and then Is_Interface (Etype (Par))
+ if Use_Full_View
+ and then Is_Private_Type (Par)
and then Present (Full_View (Par))
then
Par := Etype (Full_View (Par));
===================================================================
@@ -217,9 +217,23 @@ package Sem_Type is
-- but conceptually the resolution of the actual takes place in the
-- enclosing context and no special disambiguation rules should be applied.
- function Is_Ancestor (T1, T2 : Entity_Id) return Boolean;
+ function Is_Ancestor
+ (T1 : Entity_Id;
+ T2 : Entity_Id;
+ Use_Full_View : Boolean := False) return Boolean;
-- T1 is a tagged type (not class-wide). Verify that it is one of the
- -- ancestors of type T2 (which may or not be class-wide).
+ -- ancestors of type T2 (which may or not be class-wide). If Use_Full_View
+ -- is True then the full-view of private parents is used when climbing
+ -- through the parents of T2.
+ --
+ -- Note: For analysis purposes the flag Use_Full_View must be set to False
+ -- (otherwise we break the privacy contract since this routine returns true
+ -- for hidden ancestors of private types). For expansion purposes this flag
+ -- is generally set to True since the expander must know with precision the
+ -- ancestors of a tagged type. For example, if a private type derives from
+ -- an interface type then the interface may not be an ancestor of its full
+ -- view since the full-view is only required to cover the interface (RM 7.3
+ -- (7.3/2))) and this knowledge affects construction of dispatch tables.
function Is_Progenitor
(Iface : Entity_Id;
===================================================================
@@ -1501,7 +1501,7 @@ package body Exp_Util is
(not Is_Class_Wide_Type (Typ)
and then Ekind (Typ) /= E_Incomplete_Type);
- if Is_Ancestor (Iface, Typ) then
+ if Is_Ancestor (Iface, Typ, Use_Full_View => True) then
return First_Elmt (Access_Disp_Table (Typ));
else
@@ -1510,7 +1510,8 @@ package body Exp_Util is
while Present (ADT)
and then Present (Related_Type (Node (ADT)))
and then Related_Type (Node (ADT)) /= Iface
- and then not Is_Ancestor (Iface, Related_Type (Node (ADT)))
+ and then not Is_Ancestor (Iface, Related_Type (Node (ADT)),
+ Use_Full_View => True)
loop
Next_Elmt (ADT);
end loop;
@@ -1576,7 +1577,9 @@ package body Exp_Util is
while Present (AI_Elmt) loop
AI := Node (AI_Elmt);
- if AI = Iface or else Is_Ancestor (Iface, AI) then
+ if AI = Iface
+ or else Is_Ancestor (Iface, AI, Use_Full_View => True)
+ then
Found := True;
return;
end if;
@@ -1628,7 +1631,7 @@ package body Exp_Util is
-- If the interface is an ancestor of the type, then it shared the
-- primary dispatch table.
- if Is_Ancestor (Iface, Typ) then
+ if Is_Ancestor (Iface, Typ, Use_Full_View => True) then
pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
return First_Tag_Component (Typ);
===================================================================
@@ -1687,7 +1687,7 @@ package body Sem_Util is
-- Associate the primary tag component and the primary dispatch table
-- with all the interfaces that are parents of T
- if Is_Ancestor (Iface, T) then
+ if Is_Ancestor (Iface, T, Use_Full_View => True) then
Append_Elmt (First_Tag_Component (T), Components_List);
Append_Elmt (Node (First_Elmt (Access_Disp_Table (T))), Tags_List);
@@ -1700,7 +1700,7 @@ package body Sem_Util is
Comp_Iface := Related_Type (Node (Comp_Elmt));
if Comp_Iface = Iface
- or else Is_Ancestor (Iface, Comp_Iface)
+ or else Is_Ancestor (Iface, Comp_Iface, Use_Full_View => True)
then
Append_Elmt (Node (Comp_Elmt), Components_List);
Append_Elmt (Search_Tag (Comp_Iface), Tags_List);
@@ -5504,7 +5504,7 @@ package body Sem_Util is
Elmt := First_Elmt (Ifaces_List);
while Present (Elmt) loop
- if Is_Ancestor (Node (Elmt), Typ)
+ if Is_Ancestor (Node (Elmt), Typ, Use_Full_View => True)
and then Exclude_Parents
then
null;
===================================================================
@@ -8628,7 +8628,8 @@ package body Exp_Ch4 is
if Is_Class_Wide_Type (Actual_Op_Typ)
and then Actual_Op_Typ /= Actual_Targ_Typ
and then Root_Op_Typ /= Actual_Targ_Typ
- and then Is_Ancestor (Root_Op_Typ, Actual_Targ_Typ)
+ and then Is_Ancestor (Root_Op_Typ, Actual_Targ_Typ,
+ Use_Full_View => True)
then
Make_Tag_Check (Class_Wide_Type (Actual_Targ_Typ));
Make_Conversion := True;
@@ -10461,7 +10462,8 @@ package body Exp_Ch4 is
-- Obj1 in Iface'Class; -- Compile time error
if not Is_Class_Wide_Type (Left_Type)
- and then (Is_Ancestor (Etype (Right_Type), Left_Type)
+ and then (Is_Ancestor (Etype (Right_Type), Left_Type,
+ Use_Full_View => True)
or else (Is_Interface (Etype (Right_Type))
and then Interface_Present_In_Ancestor
(Typ => Left_Type,
===================================================================
@@ -1435,7 +1435,9 @@ package body Exp_Disp is
-- a parent of the type of the actual because in this case the
-- interface primitives are located in the primary dispatch table.
- elsif Is_Ancestor (Formal_Typ, Actual_Typ) then
+ elsif Is_Ancestor (Formal_Typ, Actual_Typ,
+ Use_Full_View => True)
+ then
null;
-- Implicit conversion to the class-wide formal type to force
@@ -1494,7 +1496,9 @@ package body Exp_Disp is
-- a parent of the type of the actual because in this case the
-- interface primitives are located in the primary dispatch table.
- elsif Is_Ancestor (Formal_DDT, Actual_DDT) then
+ elsif Is_Ancestor (Formal_DDT, Actual_DDT,
+ Use_Full_View => True)
+ then
null;
else
@@ -4090,7 +4094,8 @@ package body Exp_Disp is
-- Tagged_Type. Otherwise the DT associated with the
-- interface is the primary DT.
- and then not Is_Ancestor (Iface, Typ)
+ and then not Is_Ancestor (Iface, Typ,
+ Use_Full_View => True)
then
if not Build_Thunks then
Prim_Pos :=
@@ -5087,7 +5092,7 @@ package body Exp_Disp is
begin
AI := First_Elmt (Typ_Ifaces);
while Present (AI) loop
- if Is_Ancestor (Node (AI), Typ) then
+ if Is_Ancestor (Node (AI), Typ, Use_Full_View => True) then
Sec_DT_Tag :=
New_Reference_To (DT_Ptr, Loc);
else
@@ -5098,7 +5103,8 @@ package body Exp_Disp is
while Is_Tag (Node (Elmt))
and then not
- Is_Ancestor (Node (AI), Related_Type (Node (Elmt)))
+ Is_Ancestor (Node (AI), Related_Type (Node (Elmt)),
+ Use_Full_View => True)
loop
pragma Assert (Has_Thunks (Node (Elmt)));
Next_Elmt (Elmt);
@@ -6182,7 +6188,8 @@ package body Exp_Disp is
if Present (Interface_Alias (Prim))
and then not
Is_Ancestor
- (Find_Dispatching_Type (Interface_Alias (Prim)), Typ)
+ (Find_Dispatching_Type (Interface_Alias (Prim)), Typ,
+ Use_Full_View => True)
and then not Examined (UI_To_Int (DT_Position (Alias (Prim))))
then
Prim_Pos := DT_Position (Alias (Prim));
@@ -6983,7 +6990,7 @@ package body Exp_Disp is
-- No action needed for interfaces that are ancestors of Typ because
-- their primitives are located in the primary dispatch table.
- if Is_Ancestor (Iface_Typ, Tag_Typ) then
+ if Is_Ancestor (Iface_Typ, Tag_Typ, Use_Full_View => True) then
return L;
-- No action needed for primitives located in the C++ part of the
@@ -6999,7 +7006,7 @@ package body Exp_Disp is
Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
- if not Is_Ancestor (Iface_Typ, Tag_Typ)
+ if not Is_Ancestor (Iface_Typ, Tag_Typ, Use_Full_View => True)
and then Present (Thunk_Code)
then
-- Generate the code necessary to fill the appropriate entry of
@@ -7357,7 +7364,8 @@ package body Exp_Disp is
elsif Present (Interface_Alias (Prim))
and then Is_Ancestor
- (Find_Dispatching_Type (Interface_Alias (Prim)), Typ)
+ (Find_Dispatching_Type (Interface_Alias (Prim)), Typ,
+ Use_Full_View => True)
then
pragma Assert (DT_Position (Prim) = No_Uint
and then Present (DTC_Entity (Interface_Alias (Prim))));
@@ -7379,7 +7387,8 @@ package body Exp_Disp is
and then Chars (Prim) = Chars (Alias (Prim))
and then Find_Dispatching_Type (Alias (Prim)) /= Typ
and then Is_Ancestor
- (Find_Dispatching_Type (Alias (Prim)), Typ)
+ (Find_Dispatching_Type (Alias (Prim)), Typ,
+ Use_Full_View => True)
and then Present (DTC_Entity (Alias (Prim)))
then
E := Alias (Prim);
@@ -7445,7 +7454,8 @@ package body Exp_Disp is
-- Check if this entry will be placed in the primary DT
if Is_Ancestor
- (Find_Dispatching_Type (Interface_Alias (Prim)), Typ)
+ (Find_Dispatching_Type (Interface_Alias (Prim)), Typ,
+ Use_Full_View => True)
then
pragma Assert (DT_Position (Alias (Prim)) /= No_Uint);
Set_DT_Position (Prim, DT_Position (Alias (Prim)));
===================================================================
@@ -231,7 +231,9 @@ package body Exp_Intr is
-- If the result type is not parent of Tag_Arg then we need to
-- locate the tag of the secondary dispatch table.
- if not Is_Ancestor (Etype (Result_Typ), Etype (Tag_Arg)) then
+ if not Is_Ancestor (Etype (Result_Typ), Etype (Tag_Arg),
+ Use_Full_View => True)
+ then
pragma Assert (not Is_Interface (Etype (Tag_Arg)));
Iface_Tag :=
===================================================================
@@ -478,7 +478,8 @@ package body Exp_CG is
and then
Is_Ancestor
(Find_Dispatching_Type (Ultimate_Alias (Prim)),
- Root_Type (Ctrl_Typ))
+ Root_Type (Ctrl_Typ),
+ Use_Full_View => True)
then
-- This is a special case in which we generate in the ci file the
-- slot number of the renaming primitive (i.e. Base2) but instead of
@@ -616,7 +617,8 @@ package body Exp_CG is
if Present (Overridden_Operation (Prim))
and then
Is_Ancestor
- (Find_Dispatching_Type (Overridden_Operation (Prim)), Typ)
+ (Find_Dispatching_Type (Overridden_Operation (Prim)), Typ,
+ Use_Full_View => True)
then
Write_Char (',');
Write_Int
@@ -642,7 +644,8 @@ package body Exp_CG is
if Present (Int_Alias)
and then
- not Is_Ancestor (Find_Dispatching_Type (Int_Alias), Typ)
+ not Is_Ancestor (Find_Dispatching_Type (Int_Alias), Typ,
+ Use_Full_View => True)
and then (Alias (Prim_Op)) = Prim
then
Write_Char (',');
===================================================================
@@ -2087,7 +2087,7 @@ package body Sem_Disp is
and then Etype (Tagged_Type) /= Tagged_Type
and then Is_Interface (Find_Dispatching_Type (Alias (Prev_Op)))
and then not Is_Ancestor (Find_Dispatching_Type (Alias (Prev_Op)),
- Tagged_Type)
+ Tagged_Type, Use_Full_View => True)
and then not Implements_Interface
(Etype (Tagged_Type),
Find_Dispatching_Type (Alias (Prev_Op)))
===================================================================
@@ -2220,7 +2220,9 @@ package body Exp_Ch3 is
-- If the interface is a parent of Rec_Type it shares the primary
-- dispatch table and hence there is no need to build the function
- if not Is_Ancestor (Related_Type (Iface_Comp), Rec_Type) then
+ if not Is_Ancestor (Related_Type (Iface_Comp), Rec_Type,
+ Use_Full_View => True)
+ then
Build_Offset_To_Top_Function (Iface_Comp);
end if;
@@ -7297,7 +7299,7 @@ package body Exp_Ch3 is
-- Initialize the pointer to the secondary DT associated with the
-- interface.
- if not Is_Ancestor (Iface, Typ) then
+ if not Is_Ancestor (Iface, Typ, Use_Full_View => True) then
Append_To (Stmts_List,
Make_Assignment_Statement (Loc,
Name =>
@@ -7394,7 +7396,7 @@ package body Exp_Ch3 is
-- Don't need to set any value if this interface shares
-- the primary dispatch table.
- if not Is_Ancestor (Iface, Typ) then
+ if not Is_Ancestor (Iface, Typ, Use_Full_View => True) then
Append_To (Stmts_List,
Build_Set_Static_Offset_To_Top (Loc,
Iface_Tag => New_Reference_To (Iface_Tag, Loc),
The compiler does not reject a type conversion of an object of of a private type that is derived from an interface type if the target type of the conversion is one of the parents of the full type declaration of the private type (which breaks the privacy contract imposed by the private type). The following test must compile with one error: package Types_1 is type Iface is interface; type A_Root is tagged null record; type Typ1 is new A_Root and Iface with null record; type Typ1_Access is access all Typ1'Class; end; with Types_1; use Types_1; package Types_2 is type Typ2 is new Iface with private; -- [1] type Typ2_Access is access all Typ2'Class; private type Typ2 is new Typ1 with null record; -- [2] end; with Types_1; use Types_1; with Types_2; use Types_2; procedure Main is M : Typ2_Access := new Typ2; Bug : Typ1_Access := Typ1_Access (M); -- [3]: Error begin null; end Main; At [1] the private type declaration of Typ2 does not provide information Gindicating that its full view (at [2]) is a derivation of Typ1. Hence, the type conversion (at [3]) must be rejected by the compiler. Command: gcc -c -gnat05 main.adb Output: invalid tagged conversion, not compatible with type "Typ2'Class" defined at types_2.ads:3 Tested on x86_64-pc-linux-gnu, committed on trunk 2011-08-02 Javier Miranda <miranda@adacore.com> * sem_type.ads, sem_type.adb (Is_Ancestor): Addition of a new formal (Use_Full_View) which permits this routine to climb through the ancestors using the full-view of private parents. * sem_util.adb (Collect_Interfaces_Info, Implements_Interface): Set Use_Full_View to true in calls to Is_Ancestor. * sem_disp.adb (Override_Dispatching_Operation): Set Use_Full_View to true in call to Is_Ancestor. * exp_ch3.adb (Build_Offset_To_Top_Functions, Initialize_Tag): Set Use_Full_View to true in call to Is_Ancestor. * exp_ch7.adb (Controller_Component): Set Use_Full_View to true in call to Is_Ancestor. * exp_ch4.adb (Expand_N_Type_Conversion, Tagged_Membership): Set Use_Full_View to true in calls to Is_Ancestor. * exp_disp.adb (Expand_Interface_Actuals, Make_Secondary_DT, Make_DT, Make_Select_Specific_Data_Table, Register_Primitive, Set_All_DT_Position): Set Use_Full_View to true in calls to Is_Ancestor. * exp_intr.adb (Expand_Dispatching_Constructor_Call): Set Use_Full_View to true in call to Is_Ancestor. * exp_util.adb (Find_Interface_ADT, Find_Interface_Tag): Set Use_Full_View to true in calls to Is_Ancestor. * exp_cg.adb (Write_Call_Info): Set Use_Full_View to true in call to Is_Ancestor. (Write_Type_Info): Set Use_Full_View to true in call to Is_Ancestor.