+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.
+
2011-08-02 Robert Dewar <dewar@adacore.com>
* gnat_rm.texi: Minor reformatting.
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
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
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 (',');
-- 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;
-- 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 =>
-- 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),
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;
-- 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,
-- 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;
-- 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
-- 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
-- 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 :=
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
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);
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));
-- 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
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
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))));
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);
-- 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)));
-- 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 :=
(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
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;
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;
-- 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);
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)))
-- 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;
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));
-- 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;
-- 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);
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);
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;
projects / gcc.git / commitdiff