From: Javier Miranda Date: Tue, 2 Aug 2011 07:46:39 +0000 (+0000) Subject: sem_type.ads, [...] (Is_Ancestor): Addition of a new formal (Use_Full_View) which... X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=4ac2477e65c5b506eda0f3cef1696478270a1f97;p=gcc.git sem_type.ads, [...] (Is_Ancestor): Addition of a new formal (Use_Full_View) which permits this routine to climb... 2011-08-02 Javier Miranda * 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. From-SVN: r177087 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 8702efb41f2..8a82c451515 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,29 @@ +2011-08-02 Javier Miranda + + * 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 * gnat_rm.texi: Minor reformatting. diff --git a/gcc/ada/exp_cg.adb b/gcc/ada/exp_cg.adb index 4f9666476fe..e5f618f4f9f 100644 --- a/gcc/ada/exp_cg.adb +++ b/gcc/ada/exp_cg.adb @@ -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 (','); diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index c1e83bbb42a..7eb6c99f272 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -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), diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index a0c4104b331..c8ba5e57c79 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -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, diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index b6b8c8510e8..97ec568e0e9 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -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; diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index f2d5ccd88d5..07444e7d4ae 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -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))); diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index 977e335567d..4a300b80199 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -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 := diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 48e22831799..74e916f9314 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -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); diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index 450716bd9e6..55c1d329fc5 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -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))) diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index 08d273e37fe..2e0eb7a621f 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -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)); diff --git a/gcc/ada/sem_type.ads b/gcc/ada/sem_type.ads index 83d4bb98e32..40e4c606df3 100644 --- a/gcc/ada/sem_type.ads +++ b/gcc/ada/sem_type.ads @@ -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; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index f401f9441ae..6645688c1f4 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -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;