sem_util.adb (Unique_Name): Reach through Unique_Entity to get the name of the entity.

2011-12-02  Yannick Moy  <moy@adacore.com>

	* 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  <moy@adacore.com>

	* sem_ch3.adb (Check_Initialization): Do not emit warning on
	initialization of limited type object in Alfa mode.

From-SVN: r181916

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index f4003ad..6a23bae 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,14 @@
+2011-12-02  Yannick Moy  <moy@adacore.com>
+
+       * 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  <moy@adacore.com>
+
+       * sem_ch3.adb (Check_Initialization): Do not emit warning on
+       initialization of limited type object in Alfa mode.
+
 2011-12-02  Robert Dewar  <dewar@adacore.com>
 
        * sinfo.ads: Minor reformatting.

diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 2a0f032..e708ee7 100644 (file)
--- 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 c1a7927..4fc88f2 100644 (file)
--- 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;