diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index f4003ad70fe..6a23baed9da 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,14 @@ +2011-12-02 Yannick Moy + + * sem_util.adb (Unique_Name): Reach through Unique_Entity to + get the name of the entity. + (Unique_Entity): Correct case for subprogram stubs. + +2011-12-02 Yannick Moy + + * sem_ch3.adb (Check_Initialization): Do not emit warning on + initialization of limited type object in Alfa mode. + 2011-12-02 Robert Dewar * sinfo.ads: Minor reformatting. diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 2a0f032df10..e708ee7d6f6 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -9704,9 +9704,25 @@ package body Sem_Ch3 is ("?cannot initialize entities of limited type!", Exp); elsif Ada_Version < Ada_2005 then - Error_Msg_N - ("cannot initialize entities of limited type", Exp); - Explain_Limited_Type (T, Exp); + + -- The side effect removal machinery may generate illegal Ada + -- code to avoid the usage of access types and 'reference in + -- Alfa mode. Since this is legal code with respect to theorem + -- proving, do not emit the error. + + if Alfa_Mode + and then Nkind (Exp) = N_Function_Call + and then Nkind (Parent (Exp)) = N_Object_Declaration + and then not Comes_From_Source + (Defining_Identifier (Parent (Exp))) + then + null; + + else + Error_Msg_N + ("cannot initialize entities of limited type", Exp); + Explain_Limited_Type (T, Exp); + end if; else -- Specialize error message according to kind of illegal diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index c1a79275e4e..4fc88f2e0e0 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -3045,7 +3045,8 @@ package body Sem_Util is function Effectively_Has_Constrained_Partial_View (Typ : Entity_Id; - Scop : Entity_Id := Current_Scope) return Boolean is + Scop : Entity_Id := Current_Scope) return Boolean + is begin return Has_Constrained_Partial_View (Typ) or else (In_Generic_Body (Scop) @@ -6111,9 +6112,12 @@ package body Sem_Util is --------------------- function In_Generic_Body (Id : Entity_Id) return Boolean is - S : Entity_Id := Id; + S : Entity_Id; begin + -- Climb scopes looking for generic body + + S := Id; while Present (S) and then S /= Standard_Standard loop -- Generic package body @@ -6135,6 +6139,8 @@ package body Sem_Util is S := Scope (S); end loop; + -- False if top of scope stack without finding a generic body + return False; end In_Generic_Body; @@ -12905,7 +12911,12 @@ package body Sem_Util is if Nkind (P) = N_Subprogram_Body_Stub then if Present (Library_Unit (P)) then - U := Get_Body_From_Stub (P); + + -- Get to the function or procedure (generic) entity through + -- the body entity. + + U := + Unique_Entity (Defining_Entity (Get_Body_From_Stub (P))); end if; else U := Corresponding_Spec (P); @@ -12929,6 +12940,11 @@ package body Sem_Util is function Unique_Name (E : Entity_Id) return String is + -- Names of E_Subprogram_Body or E_Package_Body entities are not + -- reliable, as they may not include the overloading suffix. Instead, + -- when looking for the name of E or one of its enclosing scope, we get + -- the name of the corresponding Unique_Entity. + function Get_Scoped_Name (E : Entity_Id) return String; -- Return the name of E prefixed by all the names of the scopes to which -- E belongs, except for Standard. @@ -12945,7 +12961,7 @@ package body Sem_Util is then return Name; else - return Get_Scoped_Name (Scope (E)) & "__" & Name; + return Get_Scoped_Name (Unique_Entity (Scope (E))) & "__" & Name; end if; end Get_Scoped_Name; @@ -12965,7 +12981,7 @@ package body Sem_Util is return Unique_Name (Etype (E)) & "__" & Get_Name_String (Chars (E)); else - return Get_Scoped_Name (E); + return Get_Scoped_Name (Unique_Entity (E)); end if; end Unique_Name;