[multiple changes]

2014-07-29  Robert Dewar  <dewar@adacore.com>

	* einfo.adb (Derived_Type_Link): New function
	(Set_Derived_Type_Link): New procedure.
	(Write_Field31_Name): Output Derived_Type_Link.
	* einfo.ads: New field Derived_Type_Link.
	* exp_ch6.adb (Expand_Call): Warn if change of representation
	needed on call.
	* sem_ch13.adb: Minor addition of ??? comment.
	(Rep_Item_Too_Late): Warn on case that is legal but could cause an
	expensive implicit conversion.
	* sem_ch3.adb (Build_Derived_Type): Set Derived_Type_Link if needed.

2014-07-29  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch3.adb (Build_Init_Procedure): Renamed Local_DF_Id
	to DF_Id. Add new local variable DF_Call. Do not perform any
	elaboration-related checks on the call to the partial finalization
	routine within an init proc to avoid generating bogus elaboration
	warnings on expansion-related code.
	* sem_elab.adb (Check_A_Call): Move constant Access_Case to
	the top level of the routine.  Ensure that Output_Calls takes
	into account flags -gnatel and -gnatwl when emitting warnings
	or info messages.
	(Check_Internal_Call_Continue): Update the call to Output_Calls.
	(Elab_Warning): Moved to the top level of routine Check_A_Call.
	(Emit): New routines.
	(Output_Calls): Add new formal parameter Check_Elab_Flag along with a
	comment on usage. Output all warnings or info messages only when the
	caller context demands it and the proper elaboration flag is set.

2014-07-29  Yannick Moy  <moy@adacore.com>

	* sem_attr.adb (Analyze_Attribute/Attribute_Old):
	Check rule about Old appearing in potentially unevaluated
	expression everywhere, not only in Post.

2014-07-29  Arnaud Charlet  <charlet@adacore.com>

	* sem_prag.adb: Update comment.
	* a-except.adb, a-except-2005.adb: Minor editing.

2014-07-29  Pierre-Marie Derodat  <derodat@adacore.com>

	* exp_dbug.adb (Debug_Renaming_Declaration):
	Do not create renaming entities for renamings of non-packed
	objects and for exceptions.

From-SVN: r213175

1 files changed, 144 insertions, 105 deletions

diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb
index e8f68e5..adf5fd1 100644
--- a/gcc/ada/sem_elab.adb
+++ b/gcc/ada/sem_elab.adb
@@ -263,11 +263,15 @@ package body Sem_Elab is
    function Is_Finalization_Procedure (Id : Entity_Id) return Boolean;
    --  Determine whether entity Id denotes a [Deep_]Finalize procedure
 
-   procedure Output_Calls (N : Node_Id);
+   procedure Output_Calls
+     (N               : Node_Id;
+      Check_Elab_Flag : Boolean);
    --  Outputs chain of calls stored in the Elab_Call table. The caller has
    --  already generated the main warning message, so the warnings generated
    --  are all continuation messages. The argument is the call node at which
-   --  the messages are to be placed.
+   --  the messages are to be placed. When Check_Elab_Flag is set, calls are
+   --  enumerated only when flag Elab_Warning is set for the dynamic case or
+   --  when flag Elab_Info_Messages is set for the statis case.
 
    function Same_Elaboration_Scope (Scop1, Scop2 : Entity_Id) return Boolean;
    --  Given two scopes, determine whether they are the same scope from an
@@ -497,6 +501,48 @@ package body Sem_Elab is
       Generate_Warnings : Boolean := True;
       In_Init_Proc      : Boolean := False)
    is
+      Access_Case : constant Boolean := Nkind (N) = N_Attribute_Reference;
+      --  Indicates if we have Access attribute case
+
+      procedure Elab_Warning
+        (Msg_D : String;
+         Msg_S : String;
+         Ent   : Node_Or_Entity_Id);
+       --  Generate a call to Error_Msg_NE with parameters Msg_D or Msg_S (for
+       --  dynamic or static elaboration model), N and Ent. Msg_D is a real
+       --  warning (output if Msg_D is non-null and Elab_Warnings is set),
+       --  Msg_S is an info message (output if Elab_Info_Messages is set.
+
+      ------------------
+      -- Elab_Warning --
+      ------------------
+
+      procedure Elab_Warning
+        (Msg_D : String;
+         Msg_S : String;
+         Ent   : Node_Or_Entity_Id)
+      is
+      begin
+         --  Dynamic elaboration checks, real warning
+
+         if Dynamic_Elaboration_Checks then
+            if not Access_Case then
+               if Msg_D /= "" and then Elab_Warnings then
+                  Error_Msg_NE (Msg_D, N, Ent);
+               end if;
+            end if;
+
+         --  Static elaboration checks, info message
+
+         else
+            if Elab_Info_Messages then
+               Error_Msg_NE (Msg_S, N, Ent);
+            end if;
+         end if;
+      end Elab_Warning;
+
+      --  Local variables
+
       Loc  : constant Source_Ptr := Sloc (N);
       Ent  : Entity_Id;
       Decl : Node_Id;
@@ -525,9 +571,6 @@ package body Sem_Elab is
       Inst_Case : constant Boolean := Nkind (N) in N_Generic_Instantiation;
       --  Indicates if we have instantiation case
 
-      Access_Case : constant Boolean := Nkind (N) = N_Attribute_Reference;
-      --  Indicates if we have Access attribute case
-
       Caller_Unit_Internal : Boolean;
       Callee_Unit_Internal : Boolean;
 
@@ -544,6 +587,8 @@ package body Sem_Elab is
       --  warnings on the scope are also suppressed. For the internal case,
       --  we ignore this flag.
 
+   --  Start of processing for Check_A_Call
+
    begin
       --  If the call is known to be within a local Suppress Elaboration
       --  pragma, nothing to check. This can happen in task bodies. But
@@ -873,101 +918,64 @@ package body Sem_Elab is
            and then (Elab_Warnings or Elab_Info_Messages)
            and then Generate_Warnings
          then
-            Generate_Elab_Warnings : declare
-               procedure Elab_Warning
-                 (Msg_D : String;
-                  Msg_S : String;
-                  Ent   : Node_Or_Entity_Id);
-               --  Generate a call to Error_Msg_NE with parameters Msg_D or
-               --  Msg_S (for dynamic or static elaboration model), N and Ent.
-               --  Msg_D is a real warning (output if Msg_D is non-null and
-               --  Elab_Warnings is set), Msg_S is an info message (output if
-               --  Elab_Info_Messages is set.
-
-               ------------------
-               -- Elab_Warning --
-               ------------------
-
-               procedure Elab_Warning
-                 (Msg_D : String;
-                  Msg_S : String;
-                  Ent   : Node_Or_Entity_Id)
-               is
-               begin
-                  --  Dynamic elaboration checks, real warning
-
-                  if Dynamic_Elaboration_Checks then
-                     if not Access_Case then
-                        if Msg_D /= "" and then Elab_Warnings then
-                           Error_Msg_NE (Msg_D, N, Ent);
-                        end if;
-                     end if;
+            --  Instantiation case
 
-                  --  Static elaboration checks, info message
-
-                  else
-                     if Elab_Info_Messages then
-                        Error_Msg_NE (Msg_S, N, Ent);
-                     end if;
-                  end if;
-               end Elab_Warning;
-
-            --  Start of processing for Generate_Elab_Warnings
+            if Inst_Case then
+               Elab_Warning
+                 ("instantiation of& may raise Program_Error?l?",
+                  "info: instantiation of& during elaboration?$?", Ent);
 
-            begin
-               --  Instantiation case
+            --  Indirect call case, info message only in static elaboration
+            --  case, because the attribute reference itself cannot raise an
+            --  exception.
 
-               if Inst_Case then
-                  Elab_Warning
-                    ("instantiation of& may raise Program_Error?l?",
-                     "info: instantiation of& during elaboration?$?", Ent);
+            elsif Access_Case then
+               Elab_Warning
+                 ("", "info: access to& during elaboration?$?", Ent);
 
-               --  Indirect call case, info message only in static elaboration
-               --  case, because the attribute reference itself cannot raise
-               --  an exception.
+            --  Subprogram call case
 
-               elsif Access_Case then
+            else
+               if Nkind (Name (N)) in N_Has_Entity
+                 and then Is_Init_Proc (Entity (Name (N)))
+                 and then Comes_From_Source (Ent)
+               then
                   Elab_Warning
-                    ("", "info: access to& during elaboration?$?", Ent);
-
-               --  Subprogram call case
+                    ("implicit call to & may raise Program_Error?l?",
+                     "info: implicit call to & during elaboration?$?",
+                     Ent);
 
                else
-                  if Nkind (Name (N)) in N_Has_Entity
-                    and then Is_Init_Proc (Entity (Name (N)))
-                    and then Comes_From_Source (Ent)
-                  then
-                     Elab_Warning
-                       ("implicit call to & may raise Program_Error?l?",
-                        "info: implicit call to & during elaboration?$?",
-                        Ent);
-
-                  else
-                     Elab_Warning
-                       ("call to & may raise Program_Error?l?",
-                        "info: call to & during elaboration?$?",
-                        Ent);
-                  end if;
+                  Elab_Warning
+                    ("call to & may raise Program_Error?l?",
+                     "info: call to & during elaboration?$?",
+                     Ent);
                end if;
+            end if;
 
-               Error_Msg_Qual_Level := Nat'Last;
+            Error_Msg_Qual_Level := Nat'Last;
 
-               if Nkind (N) in N_Subprogram_Instantiation then
-                  Elab_Warning
-                    ("\missing pragma Elaborate for&?l?",
-                     "\implicit pragma Elaborate for& generated?$?",
-                     W_Scope);
+            if Nkind (N) in N_Subprogram_Instantiation then
+               Elab_Warning
+                 ("\missing pragma Elaborate for&?l?",
+                  "\implicit pragma Elaborate for& generated?$?",
+                  W_Scope);
 
-               else
-                  Elab_Warning
-                    ("\missing pragma Elaborate_All for&?l?",
-                     "\implicit pragma Elaborate_All for & generated?$?",
-                     W_Scope);
-               end if;
-            end Generate_Elab_Warnings;
+            else
+               Elab_Warning
+                 ("\missing pragma Elaborate_All for&?l?",
+                  "\implicit pragma Elaborate_All for & generated?$?",
+                  W_Scope);
+            end if;
 
             Error_Msg_Qual_Level := 0;
-            Output_Calls (N);
+
+            --  Take into account the flags related to elaboration warning
+            --  messages when enumerating the various calls involved. This
+            --  ensures the proper pairing of the main warning and the
+            --  clarification messages generated by Output_Calls.
+
+            Output_Calls (N, Check_Elab_Flag => True);
 
             --  Set flag to prevent further warnings for same unit unless in
             --  All_Errors_Mode.
@@ -2316,7 +2324,12 @@ package body Sem_Elab is
 
             Error_Msg_N ("\Program_Error ]<l<", N);
 
-            Output_Calls (N);
+            --  There is no need to query the elaboration warning message flags
+            --  because the main message is an error, not a warning, therefore
+            --  all the clarification messages produces by Output_Calls must be
+            --  emitted unconditionally.
+
+            Output_Calls (N, Check_Elab_Flag => False);
          end if;
       end if;
 
@@ -3053,8 +3066,13 @@ package body Sem_Elab is
    -- Output_Calls --
    ------------------
 
-   procedure Output_Calls (N : Node_Id) is
-      Ent : Entity_Id;
+   procedure Output_Calls
+     (N               : Node_Id;
+      Check_Elab_Flag : Boolean)
+   is
+      function Emit (Flag : Boolean) return Boolean;
+      --  Determine whether to emit an error message based on the combination
+      --  of flags Check_Elab_Flag and Flag.
 
       function Is_Printable_Error_Name (Nm : Name_Id) return Boolean;
       --  An internal function, used to determine if a name, Nm, is either
@@ -3062,6 +3080,19 @@ package body Sem_Elab is
       --  by the error message circuits (i.e. it has a single upper
       --  case letter at the end).
 
+      ----------
+      -- Emit --
+      ----------
+
+      function Emit (Flag : Boolean) return Boolean is
+      begin
+         if Check_Elab_Flag then
+            return Flag;
+         else
+            return True;
+         end if;
+      end Emit;
+
       -----------------------------
       -- Is_Printable_Error_Name --
       -----------------------------
@@ -3080,6 +3111,10 @@ package body Sem_Elab is
          end if;
       end Is_Printable_Error_Name;
 
+      --  Local variables
+
+      Ent : Entity_Id;
+
    --  Start of processing for Output_Calls
 
    begin
@@ -3091,27 +3126,31 @@ package body Sem_Elab is
          --  Dynamic elaboration model, warnings controlled by -gnatwl
 
          if Dynamic_Elaboration_Checks then
-            if Is_Generic_Unit (Ent) then
-               Error_Msg_NE ("\\?l?& instantiated #", N, Ent);
-            elsif Is_Init_Proc (Ent) then
-               Error_Msg_N ("\\?l?initialization procedure called #", N);
-            elsif Is_Printable_Error_Name (Chars (Ent)) then
-               Error_Msg_NE ("\\?l?& called #", N, Ent);
-            else
-               Error_Msg_N ("\\?l?called #", N);
+            if Emit (Elab_Warnings) then
+               if Is_Generic_Unit (Ent) then
+                  Error_Msg_NE ("\\?l?& instantiated #", N, Ent);
+               elsif Is_Init_Proc (Ent) then
+                  Error_Msg_N ("\\?l?initialization procedure called #", N);
+               elsif Is_Printable_Error_Name (Chars (Ent)) then
+                  Error_Msg_NE ("\\?l?& called #", N, Ent);
+               else
+                  Error_Msg_N ("\\?l?called #", N);
+               end if;
             end if;
 
          --  Static elaboration model, info messages controlled by -gnatel
 
          else
-            if Is_Generic_Unit (Ent) then
-               Error_Msg_NE ("\\?$?& instantiated #", N, Ent);
-            elsif Is_Init_Proc (Ent) then
-               Error_Msg_N ("\\?$?initialization procedure called #", N);
-            elsif Is_Printable_Error_Name (Chars (Ent)) then
-               Error_Msg_NE ("\\?$?& called #", N, Ent);
-            else
-               Error_Msg_N ("\\?$?called #", N);
+            if Emit (Elab_Info_Messages) then
+               if Is_Generic_Unit (Ent) then
+                  Error_Msg_NE ("\\?$?& instantiated #", N, Ent);
+               elsif Is_Init_Proc (Ent) then
+                  Error_Msg_N ("\\?$?initialization procedure called #", N);
+               elsif Is_Printable_Error_Name (Chars (Ent)) then
+                  Error_Msg_NE ("\\?$?& called #", N, Ent);
+               else
+                  Error_Msg_N ("\\?$?called #", N);
+               end if;
             end if;
          end if;
       end loop;