diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 1519eaa0e53..f806a8b8371 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,17 @@ +2014-07-31 Ed Schonberg + + * sem_util.ads (Find_Specific_Type): Moved here from exp_disp.adb. + * sem_util.adb (Find_Specific_Type): If type is untagged private, + retrieve full view so that primitive operations can be located. + * exp_disp.adb Move Find_Specific_Type to sem_util. + * exp_ch4.adb (Expand_N_Op_Eq): If operands are class-wide, use + Find_Specific_Type to locate primitive equality. + * exp_util.adb (Make_CW_Equivalent_Type): A class_wide equivalent + type does not require initialization. + * exp_attr.adb (Compile_Stream_Body_In_Scope): Within an instance + body all visibility is established, and the enclosing package + declarations must not be installed. + 2014-07-31 Yannick Moy * sem_parg.adb, sem_prag.ads (Collect_Subprogram_Inputs_Outputs): diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 9bdf92fef01..97ed8874b51 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -106,6 +106,8 @@ package body Exp_Attr is -- We suppress checks for array/record reads, since the rule is that these -- are like assignments, out of range values due to uninitialized storage, -- or other invalid values do NOT cause a Constraint_Error to be raised. + -- If we are within an instance body all visibility has been established + -- already and there is no need to install the package. procedure Expand_Access_To_Protected_Op (N : Node_Id; @@ -630,6 +632,11 @@ package body Exp_Attr is if Is_Hidden (Arr) and then not In_Open_Scopes (Scop) and then Ekind (Scop) = E_Package + + -- If we are within an instance body, then all visibility has been + -- established already and there is no need to install the package. + + and then not In_Instance_Body then Push_Scope (Scop); Install_Visible_Declarations (Scop); diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 1fb35c11b0a..92bde0d8e53 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -7300,15 +7300,15 @@ package body Exp_Ch4 is Op_Name := Node (Prim); -- Find the type's predefined equality or an overriding - -- user- defined equality. The reason for not simply calling + -- user-defined equality. The reason for not simply calling -- Find_Prim_Op here is that there may be a user-defined - -- overloaded equality op that precedes the equality that we want, - -- so we have to explicitly search (e.g., there could be an - -- equality with two different parameter types). + -- overloaded equality op that precedes the equality that we + -- want, so we have to explicitly search (e.g., there could be + -- an equality with two different parameter types). else if Is_Class_Wide_Type (Typl) then - Typl := Root_Type (Typl); + Typl := Find_Specific_Type (Typl); end if; Prim := First_Elmt (Primitive_Operations (Typl)); diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 69feaa73232..99105e0ea4f 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -75,12 +75,6 @@ package body Exp_Disp is -- Ada 2005 (AI-251): Returns the fixed position in the dispatch table -- of the default primitive operations. - function Find_Specific_Type (CW : Entity_Id) return Entity_Id; - -- Find specific type of a class-wide type, and handle the case of an - -- incomplete type coming either from a limited_with clause or from an - -- incomplete type declaration. Shouldn't this be in Sem_Util? It seems - -- like a general purpose semantic routine ??? - function Has_DT (Typ : Entity_Id) return Boolean; pragma Inline (Has_DT); -- Returns true if we generate a dispatch table for tagged type Typ @@ -1987,25 +1981,6 @@ package body Exp_Disp is end if; end Expand_Interface_Thunk; - ------------------------ - -- Find_Specific_Type -- - ------------------------ - - function Find_Specific_Type (CW : Entity_Id) return Entity_Id is - Typ : Entity_Id := Root_Type (CW); - - begin - if Ekind (Typ) = E_Incomplete_Type then - if From_Limited_With (Typ) then - Typ := Non_Limited_View (Typ); - else - Typ := Full_View (Typ); - end if; - end if; - - return Typ; - end Find_Specific_Type; - -------------------------- -- Has_CPP_Constructors -- -------------------------- diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index c50a6cd2f4c..a61efab750d 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -5860,10 +5860,14 @@ package body Exp_Util is Set_Is_Class_Wide_Equivalent_Type (Equiv_Type); + -- A class_wide equivalent type does not require initialization + + Set_Suppress_Initialization (Equiv_Type); + if not Is_Interface (Root_Typ) then Append_To (Comp_List, Make_Component_Declaration (Loc, - Defining_Identifier => + Defining_Identifier => Make_Defining_Identifier (Loc, Name_uParent), Component_Definition => Make_Component_Definition (Loc, @@ -5882,9 +5886,9 @@ package body Exp_Util is Append_To (List_Def, Make_Full_Type_Declaration (Loc, Defining_Identifier => Equiv_Type, - Type_Definition => + Type_Definition => Make_Record_Definition (Loc, - Component_List => + Component_List => Make_Component_List (Loc, Component_Items => Comp_List, Variant_Part => Empty)))); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 8f24046042a..fb5068a3d4f 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -5932,6 +5932,32 @@ package body Sem_Util is end loop; end Find_Placement_In_State_Space; + ------------------------ + -- Find_Specific_Type -- + ------------------------ + + function Find_Specific_Type (CW : Entity_Id) return Entity_Id is + Typ : Entity_Id := Root_Type (CW); + + begin + if Ekind (Typ) = E_Incomplete_Type then + if From_Limited_With (Typ) then + Typ := Non_Limited_View (Typ); + else + Typ := Full_View (Typ); + end if; + end if; + + if Is_Private_Type (Typ) + and then not Is_Tagged_Type (Typ) + and then Present (Full_View (Typ)) + then + return Full_View (Typ); + else + return Typ; + end if; + end Find_Specific_Type; + ----------------------------- -- Find_Static_Alternative -- ----------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index cac0fecbfd1..c9dc734f747 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -568,6 +568,12 @@ package Sem_Util is -- Call is set to the node for the corresponding call. If the node N is not -- an actual parameter then Formal and Call are set to Empty. + function Find_Specific_Type (CW : Entity_Id) return Entity_Id; + -- Find specific type of a class-wide type, and handle the case of an + -- incomplete type coming either from a limited_with clause or from an + -- incomplete type declaration. If resulting type is private return its + -- full view. + function Find_Body_Discriminal (Spec_Discriminant : Entity_Id) return Entity_Id; -- Given a discriminant of the record type that implements a task or