2017-09-08 Arnaud Charlet <charlet@adacore.com>

	* exp_intr.adb (Append_Entity_Name): Move to ...
	* sem_util.ads, sem_util.adb: ... here to share it.
	(Subprogram_Name): New subprogram, to compute the name of the enclosing
	subprogram/entity.
	* errutil.adb (Error_Msg): Fill new field Node.
	* erroutc.ads (Subprogram_Name_Ptr): New.
	(Error_Msg_Object): New field Node.
	* erroutc.adb (dmsg, Output_Msg_Text): Take new field Node into account.
	* errout.adb (Error_Msg): New variant with node id parameter.
	Fill new parameter Node when emitting messages. Revert previous
	changes for Include_Subprogram_In_Messages.
	* sem_ch5.adb (Check_Unreachable_Code): Supply Node parameter when
	generating warning message.

2017-09-08  Ed Schonberg  <schonberg@adacore.com>

	* par-ch4.adb (P_Iterated_Component_Association): Place construct
	under -gnat2020 flag, given that it is a future feature of
	the language.
	* sem_aggr.adb (Resolve_Iterated_Component_Association): Mark
	defining identifier as referenced to prevent spurious warnings:
	corresponding loop is expanded into one or more loops whose
	variable has the same name, and the expression uses those names
	and not the original one.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@251883 138bc75d-0d04-0410-961f-82ee72b054a4

16 files changed, 372 insertions, 243 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 98e2678a13b..7c9adb795f3 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,30 @@
+2017-09-08  Arnaud Charlet  <charlet@adacore.com>
+
+	* exp_intr.adb (Append_Entity_Name): Move to ...
+	* sem_util.ads, sem_util.adb: ... here to share it.
+	(Subprogram_Name): New subprogram, to compute the name of the enclosing
+	subprogram/entity.
+	* errutil.adb (Error_Msg): Fill new field Node.
+	* erroutc.ads (Subprogram_Name_Ptr): New.
+	(Error_Msg_Object): New field Node.
+	* erroutc.adb (dmsg, Output_Msg_Text): Take new field Node into account.
+	* errout.adb (Error_Msg): New variant with node id parameter.
+	Fill new parameter Node when emitting messages. Revert previous
+	changes for Include_Subprogram_In_Messages.
+	* sem_ch5.adb (Check_Unreachable_Code): Supply Node parameter when
+	generating warning message.
+
+2017-09-08  Ed Schonberg  <schonberg@adacore.com>
+
+	* par-ch4.adb (P_Iterated_Component_Association): Place construct
+	under -gnat2020 flag, given that it is a future feature of
+	the language.
+	* sem_aggr.adb (Resolve_Iterated_Component_Association): Mark
+	defining identifier as referenced to prevent spurious warnings:
+	corresponding loop is expanded into one or more loops whose
+	variable has the same name, and the expression uses those names
+	and not the original one.
+
 2017-09-08  Hristian Kirtchev  <kirtchev@adacore.com>
 
 	* sem_elab.adb (Check_A_Call): Do not consider
diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb
index 664d36e0842..ce99fd842d0 100644
--- a/gcc/ada/errout.adb
+++ b/gcc/ada/errout.adb
@@ -100,7 +100,8 @@ package body Errout is
      (Msg      : String;
       Sptr     : Source_Ptr;
       Optr     : Source_Ptr;
-      Msg_Cont : Boolean);
+      Msg_Cont : Boolean;
+      Node     : Node_Id);
    --  This is the low level routine used to post messages after dealing with
    --  the issue of messages placed on instantiations (which get broken up
    --  into separate calls in Error_Msg). Sptr is the location on which the
@@ -111,7 +112,9 @@ package body Errout is
    --  copy. So typically we can see Optr pointing to the template location
    --  in an instantiation copy when Sptr points to the source location of
    --  the actual instantiation (i.e the line with the new). Msg_Cont is
-   --  set true if this is a continuation message.
+   --  set true if this is a continuation message. Node is the relevant
+   --  Node_Id for this message, to be used to compute the enclosing entity if
+   --  Opt.Include_Subprogram_In_Messages is set.
 
    function No_Warnings (N : Node_Or_Entity_Id) return Boolean;
    --  Determines if warnings should be suppressed for the given node
@@ -303,6 +306,15 @@ package body Errout is
    --  referencing the generic declaration.
 
    procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr) is
+   begin
+      Error_Msg (Msg, Flag_Location, Empty);
+   end Error_Msg;
+
+   procedure Error_Msg
+     (Msg           : String;
+      Flag_Location : Source_Ptr;
+      N             : Node_Id)
+   is
       Sindex : Source_File_Index;
       --  Source index for flag location
 
@@ -310,8 +322,6 @@ package body Errout is
       --  Original location of Flag_Location (i.e. location in original
       --  template in instantiation case, otherwise unchanged).
 
-      Entity : Bounded_String;
-
    begin
       --  Return if all errors are to be ignored
 
@@ -338,18 +348,6 @@ package body Errout is
       Prescan_Message (Msg);
       Orig_Loc := Original_Location (Flag_Location);
 
-      if Include_Subprogram_In_Messages then
-         declare
-            Ent : constant Entity_Id := Current_Subprogram_Ptr.all;
-         begin
-            if Present (Ent) then
-               Append_Unqualified_Decoded (Entity, Chars (Ent));
-            else
-               Append (Entity, "unknown subprogram");
-            end if;
-         end;
-      end if;
-
       --  If the current location is in an instantiation, the issue arises of
       --  whether to post the message on the template or the instantiation.
 
@@ -419,14 +417,7 @@ package body Errout is
       --  Error_Msg_Internal to place the message in the requested location.
 
       if Instantiation (Sindex) = No_Location then
-         if Include_Subprogram_In_Messages then
-            Append (Entity, ": ");
-            Append (Entity, Msg);
-            Error_Msg_Internal (+Entity, Flag_Location, Flag_Location, False);
-         else
-            Error_Msg_Internal (Msg, Flag_Location, Flag_Location, False);
-         end if;
-
+         Error_Msg_Internal (Msg, Flag_Location, Flag_Location, False, N);
          return;
       end if;
 
@@ -521,23 +512,35 @@ package body Errout is
                if Inlined_Body (X) then
                   if Is_Info_Msg then
                      Error_Msg_Internal
-                       ("info: in inlined body #",
-                        Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
+                       (Msg      => "info: in inlined body #",
+                        Sptr     => Actual_Error_Loc,
+                        Optr     => Flag_Location,
+                        Msg_Cont => Msg_Cont_Status,
+                        Node     => N);
 
                   elsif Is_Warning_Msg then
                      Error_Msg_Internal
-                       (Warn_Insertion & "in inlined body #",
-                        Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
+                       (Msg      => Warn_Insertion & "in inlined body #",
+                        Sptr     => Actual_Error_Loc,
+                        Optr     => Flag_Location,
+                        Msg_Cont => Msg_Cont_Status,
+                        Node     => N);
 
                   elsif Is_Style_Msg then
                      Error_Msg_Internal
-                       ("style: in inlined body #",
-                        Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
+                       (Msg      => "style: in inlined body #",
+                        Sptr     => Actual_Error_Loc,
+                        Optr     => Flag_Location,
+                        Msg_Cont => Msg_Cont_Status,
+                        Node     => N);
 
                   else
                      Error_Msg_Internal
-                       ("error in inlined body #",
-                        Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
+                       (Msg      => "error in inlined body #",
+                        Sptr     => Actual_Error_Loc,
+                        Optr     => Flag_Location,
+                        Msg_Cont => Msg_Cont_Status,
+                        Node     => N);
                   end if;
 
                --  Case of generic instantiation
@@ -545,23 +548,35 @@ package body Errout is
                else
                   if Is_Info_Msg then
                      Error_Msg_Internal
-                       ("info: in instantiation #",
-                        Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
+                       (Msg      => "info: in instantiation #",
+                        Sptr     => Actual_Error_Loc,
+                        Optr     => Flag_Location,
+                        Msg_Cont => Msg_Cont_Status,
+                        Node     => N);
 
                   elsif Is_Warning_Msg then
                      Error_Msg_Internal
-                       (Warn_Insertion & "in instantiation #",
-                        Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
+                       (Msg      => Warn_Insertion & "in instantiation #",
+                        Sptr     => Actual_Error_Loc,
+                        Optr     => Flag_Location,
+                        Msg_Cont => Msg_Cont_Status,
+                        Node     => N);
 
                   elsif Is_Style_Msg then
                      Error_Msg_Internal
-                       ("style: in instantiation #",
-                        Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
+                       (Msg      => "style: in instantiation #",
+                        Sptr     => Actual_Error_Loc,
+                        Optr     => Flag_Location,
+                        Msg_Cont => Msg_Cont_Status,
+                        Node     => N);
 
                   else
                      Error_Msg_Internal
-                       ("instantiation error #",
-                        Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
+                       (Msg      => "instantiation error #",
+                        Sptr     => Actual_Error_Loc,
+                        Optr     => Flag_Location,
+                        Msg_Cont => Msg_Cont_Status,
+                        Node     => N);
                   end if;
                end if;
             end if;
@@ -576,15 +591,12 @@ package body Errout is
 
          --  Here we output the original message on the outer instantiation
 
-         if Include_Subprogram_In_Messages then
-            Append (Entity, ": ");
-            Append (Entity, Msg);
-            Error_Msg_Internal
-              (+Entity, Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
-         else
-            Error_Msg_Internal
-              (Msg, Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
-         end if;
+         Error_Msg_Internal
+           (Msg      => Msg,
+            Sptr     => Actual_Error_Loc,
+            Optr     => Flag_Location,
+            Msg_Cont => Msg_Cont_Status,
+            Node     => N);
       end;
    end Error_Msg;
 
@@ -798,7 +810,8 @@ package body Errout is
      (Msg      : String;
       Sptr     : Source_Ptr;
       Optr     : Source_Ptr;
-      Msg_Cont : Boolean)
+      Msg_Cont : Boolean;
+      Node     : Node_Id)
    is
       Next_Msg : Error_Msg_Id;
       --  Pointer to next message at insertion point
@@ -1080,7 +1093,8 @@ package body Errout is
           Serious  => Is_Serious_Error,
           Uncond   => Is_Unconditional_Msg,
           Msg_Cont => Continuation,
-          Deleted  => False));
+          Deleted  => False,
+          Node     => Node));
       Cur_Msg := Errors.Last;
 
       --  Test if warning to be treated as error
@@ -1369,7 +1383,7 @@ package body Errout is
       then
          Debug_Output (N);
          Error_Msg_Node_1 := E;
-         Error_Msg (Msg, Flag_Location);
+         Error_Msg (Msg, Flag_Location, N);
 
       else
          Last_Killed := True;
diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads
index ad33673cdff..e9c4eb47f7f 100644
--- a/gcc/ada/errout.ads
+++ b/gcc/ada/errout.ads
@@ -68,11 +68,6 @@ package Errout is
    --  error message tag. The -gnatw.d switch sets this flag True, -gnatw.D
    --  sets this flag False.
 
-   type Current_Subprogram_Type is access function return Entity_Id;
-   Current_Subprogram_Ptr : Current_Subprogram_Type := null;
-   --  Indirect call to Sem_Util.Current_Subprogram to break circular
-   --  dependency with the static elaboration model.
-
    -----------------------------------
    -- Suppression of Error Messages --
    -----------------------------------
@@ -691,9 +686,13 @@ package Errout is
    --  Output list of messages, including messages giving number of detected
    --  errors and warnings.
 
-   procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr);
+   procedure Error_Msg
+     (Msg : String; Flag_Location : Source_Ptr);
+   procedure Error_Msg
+     (Msg : String; Flag_Location : Source_Ptr; N : Node_Id);
    --  Output a message at specified location. Can be called from the parser
-   --  or the semantic analyzer.
+   --  or the semantic analyzer. If N is set, points to the relevant node for
+   --  this message.
 
    procedure Error_Msg_S (Msg : String);
    --  Output a message at current scan pointer location. This routine can be
diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb
index 464c64efc15..f81d337a0a7 100644
--- a/gcc/ada/erroutc.adb
+++ b/gcc/ada/erroutc.adb
@@ -299,6 +299,7 @@ package body Erroutc is
       w ("  Uncond   = ", E.Uncond);
       w ("  Msg_Cont = ", E.Msg_Cont);
       w ("  Deleted  = ", E.Deleted);
+      w ("  Node     = ", Int (E.Node));
 
       Write_Eol;
    end dmsg;
@@ -632,7 +633,22 @@ package body Erroutc is
          --  Postfix warning tag to message if needed
 
          if Tag /= "" and then Warning_Doc_Switch then
-            Txt := new String'(Text.all & ' ' & Tag);
+            if Include_Subprogram_In_Messages then
+               Txt :=
+                 new String'
+                   (Subprogram_Name_Ptr (Errors.Table (E).Node) &
+                    ": " & Text.all & ' ' & Tag);
+            else
+               Txt := new String'(Text.all & ' ' & Tag);
+            end if;
+
+         elsif Include_Subprogram_In_Messages
+           and then (Errors.Table (E).Warn or else Errors.Table (E).Style)
+         then
+            Txt :=
+              new String'
+                (Subprogram_Name_Ptr (Errors.Table (E).Node) &
+                 ": " & Text.all);
          else
             Txt := Text;
          end if;
diff --git a/gcc/ada/erroutc.ads b/gcc/ada/erroutc.ads
index 9aa44e91e98..a8fc4f99aa2 100644
--- a/gcc/ada/erroutc.ads
+++ b/gcc/ada/erroutc.ads
@@ -132,6 +132,11 @@ package Erroutc is
    --  output. This is used for internal processing for the case of an
    --  illegal instantiation. See Error_Msg routine for further details.
 
+   type Subprogram_Name_Type is access function (N : Node_Id) return String;
+   Subprogram_Name_Ptr : Subprogram_Name_Type;
+   --  Indirect call to Sem_Util.Subprogram_Name to break circular
+   --  dependency with the static elaboration model.
+
    ----------------------------
    -- Message ID Definitions --
    ----------------------------
@@ -251,6 +256,11 @@ package Erroutc is
       Deleted : Boolean;
       --  If this flag is set, the message is not printed. This is used
       --  in the circuit for deleting duplicate/redundant error messages.
+
+      Node : Node_Id;
+      --  If set, points to the node relevant for this message which will be
+      --  used to compute the enclosing subprogram name if
+      --  Opt.Include_Subprogram_In_Messages is set.
    end record;
 
    package Errors is new Table.Table (
diff --git a/gcc/ada/errutil.adb b/gcc/ada/errutil.adb
index 498833abf41..ed7412a680f 100644
--- a/gcc/ada/errutil.adb
+++ b/gcc/ada/errutil.adb
@@ -220,7 +220,8 @@ package body Errutil is
             Serious  => Is_Serious_Error,
             Uncond   => Is_Unconditional_Msg,
             Msg_Cont => Continuation,
-            Deleted  => False));
+            Deleted  => False,
+            Node     => Empty));
 
       Cur_Msg  := Errors.Last;
       Prev_Msg := No_Error_Msg;
diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index d6d806941b5..6719f2e6b6e 100644
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -1204,7 +1204,7 @@ package body Exp_Disp is
 
    procedure Expand_Interface_Conversion (N : Node_Id) is
       function Underlying_Record_Type (Typ : Entity_Id) return Entity_Id;
-      --  Return the underlying record type of Typ.
+      --  Return the underlying record type of Typ
 
       ----------------------------
       -- Underlying_Record_Type --
diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb
index fde0617aa83..1d3a321604a 100644
--- a/gcc/ada/exp_intr.adb
+++ b/gcc/ada/exp_intr.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2016, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2017, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -27,7 +27,6 @@ with Atree;    use Atree;
 with Checks;   use Checks;
 with Einfo;    use Einfo;
 with Elists;   use Elists;
-with Errout;   use Errout;
 with Expander; use Expander;
 with Exp_Atag; use Exp_Atag;
 with Exp_Ch4;  use Exp_Ch4;
@@ -111,12 +110,6 @@ package body Exp_Intr is
    --  GNAT.Source_Info; see g-souinf.ads for documentation of these
    --  intrinsics.
 
-   procedure Append_Entity_Name (Buf : in out Bounded_String; E : Entity_Id);
-   --  Recursive procedure to construct string for qualified name of enclosing
-   --  program unit. The qualification stops at an enclosing scope has no
-   --  source name (block or loop). If entity is a subprogram instance, skip
-   --  enclosing wrapper package. The name is appended to Buf.
-
    ---------------------
    -- Add_Source_Info --
    ---------------------
@@ -189,98 +182,6 @@ package body Exp_Intr is
       end case;
    end Add_Source_Info;
 
-   -----------------------
-   -- Append_Entity_Name --
-   -----------------------
-
-   procedure Append_Entity_Name (Buf : in out Bounded_String; E : Entity_Id) is
-      Temp : Bounded_String;
-
-      procedure Inner (E : Entity_Id);
-      --  Inner recursive routine, keep outer routine nonrecursive to ease
-      --  debugging when we get strange results from this routine.
-
-      -----------
-      -- Inner --
-      -----------
-
-      procedure Inner (E : Entity_Id) is
-      begin
-         --  If entity has an internal name, skip by it, and print its scope.
-         --  Note that we strip a final R from the name before the test; this
-         --  is needed for some cases of instantiations.
-
-         declare
-            E_Name : Bounded_String;
-
-         begin
-            Append (E_Name, Chars (E));
-
-            if E_Name.Chars (E_Name.Length) = 'R' then
-               E_Name.Length := E_Name.Length - 1;
-            end if;
-
-            if Is_Internal_Name (E_Name) then
-               Inner (Scope (E));
-               return;
-            end if;
-         end;
-
-         --  Just print entity name if its scope is at the outer level
-
-         if Scope (E) = Standard_Standard then
-            null;
-
-         --  If scope comes from source, write scope and entity
-
-         elsif Comes_From_Source (Scope (E)) then
-            Append_Entity_Name (Temp, Scope (E));
-            Append (Temp, '.');
-
-         --  If in wrapper package skip past it
-
-         elsif Is_Wrapper_Package (Scope (E)) then
-            Append_Entity_Name (Temp, Scope (Scope (E)));
-            Append (Temp, '.');
-
-         --  Otherwise nothing to output (happens in unnamed block statements)
-
-         else
-            null;
-         end if;
-
-         --  Output the name
-
-         declare
-            E_Name : Bounded_String;
-
-         begin
-            Append_Unqualified_Decoded (E_Name, Chars (E));
-
-            --  Remove trailing upper-case letters from the name (useful for
-            --  dealing with some cases of internal names generated in the case
-            --  of references from within a generic).
-
-            while E_Name.Length > 1
-              and then E_Name.Chars (E_Name.Length) in 'A' .. 'Z'
-            loop
-               E_Name.Length := E_Name.Length - 1;
-            end loop;
-
-            --  Adjust casing appropriately (gets name from source if possible)
-
-            Adjust_Name_Case (E_Name, Sloc (E));
-            Append (Temp, E_Name);
-         end;
-      end Inner;
-
-   --  Start of processing for Append_Entity_Name
-
-   begin
-      Inner (E);
-      Append (Buf, Temp);
-   end Append_Entity_Name;
-
    ---------------------------------
    -- Expand_Binary_Operator_Call --
    ---------------------------------
diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb
index dbb9d3ee3ef..57f60cd90eb 100644
--- a/gcc/ada/exp_prag.adb
+++ b/gcc/ada/exp_prag.adb
@@ -338,17 +338,22 @@ package body Exp_Prag is
       ------------------------------------------
 
       procedure Replace_Discriminals_Of_Protected_Op (Expr : Node_Id) is
-         function Find_Corresponding_Discriminal (E : Entity_Id)
-           return Entity_Id;
-         --  Find the local entity that renames a discriminant of the
-         --  enclosing protected type, and has a matching name.
+         function Find_Corresponding_Discriminal
+           (E : Entity_Id) return Entity_Id;
+         --  Find the local entity that renames a discriminant of the enclosing
+         --  protected type, and has a matching name.
+
+         function Replace_Discr_Ref (N : Node_Id) return Traverse_Result;
+         --  Replace a reference to a discriminant of the original protected
+         --  type by the local renaming declaration of the discriminant of
+         --  the target object.
 
          ------------------------------------
-         -- find_Corresponding_Discriminal --
+         -- Find_Corresponding_Discriminal --
          ------------------------------------
 
-         function Find_Corresponding_Discriminal (E : Entity_Id)
-           return Entity_Id
+         function Find_Corresponding_Discriminal
+           (E : Entity_Id) return Entity_Id
          is
             R : Entity_Id;
 
@@ -369,35 +374,35 @@ package body Exp_Prag is
             return Empty;
          end Find_Corresponding_Discriminal;
 
-         function  Replace_Discr_Ref (N : Node_Id) return Traverse_Result;
-         --  Replace a reference to a discriminant of the original protected
-         --  type by the local renaming declaration of the discriminant of
-         --  the target object.
-
          -----------------------
          -- Replace_Discr_Ref --
          -----------------------
 
-         function  Replace_Discr_Ref (N : Node_Id) return Traverse_Result is
+         function Replace_Discr_Ref (N : Node_Id) return Traverse_Result is
             R : Entity_Id;
 
          begin
             if Is_Entity_Name (N)
-               and then Present (Discriminal_Link (Entity (N)))
+              and then Present (Discriminal_Link (Entity (N)))
             then
                R := Find_Corresponding_Discriminal (Entity (N));
                Rewrite (N, New_Occurrence_Of (R, Sloc (N)));
             end if;
+
             return OK;
          end Replace_Discr_Ref;
 
          procedure Replace_Discriminant_References is
            new Traverse_Proc (Replace_Discr_Ref);
 
+      --  Start of processing for Replace_Discriminals_Of_Protected_Op
+
       begin
          Replace_Discriminant_References (Expr);
       end Replace_Discriminals_Of_Protected_Op;
 
+   --  Start of processing for Expand_Pragma_Check
+
    begin
       --  Nothing to do if pragma is ignored
 
diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb
index 2844b4ea03d..fd0373e420e 100644
--- a/gcc/ada/par-ch4.adb
+++ b/gcc/ada/par-ch4.adb
@@ -3317,6 +3317,12 @@ package body Ch4 is
       Set_Discrete_Choices (Assoc_Node, P_Discrete_Choice_List);
       TF_Arrow;
       Set_Expression (Assoc_Node, P_Expression);
+
+      if Ada_Version < Ada_2020 then
+         Error_Msg_SC ("Iterated component  is an Ada 2020 extension");
+         Error_Msg_SC ("\compile with -gnatX");
+      end if;
+
       return Assoc_Node;
    end P_Iterated_Component_Association;
 
diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb
index a7269048246..7a37bdd02e5 100644
--- a/gcc/ada/sem_aggr.adb
+++ b/gcc/ada/sem_aggr.adb
@@ -1694,13 +1694,16 @@ package body Sem_Aggr is
          --  may have several choices, each one leading to a loop, so we create
          --  this variable only once to prevent homonyms in this scope.
          --  The expression has to be analyzed once the index variable is
-         --  directly visible.
+         --  directly visible. Mark the variable as referenced to prevent
+         --  spurious warnings, given that subsequent uses of its name in the
+         --  expression will reference the internal (synonym) loop variable.
 
          if No (Scope (Id)) then
             Enter_Name (Id);
             Set_Etype (Id, Index_Typ);
             Set_Ekind (Id, E_Variable);
             Set_Scope (Id, Ent);
+            Set_Referenced (Id);
          end if;
 
          Push_Scope (Ent);
diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb
index 64c5dc7b446..135ecd82a6b 100644
--- a/gcc/ada/sem_ch5.adb
+++ b/gcc/ada/sem_ch5.adb
@@ -3745,7 +3745,8 @@ package body Sem_Ch5 is
                      Check_SPARK_05_Restriction
                        ("unreachable code is not allowed", Error_Node);
                   else
-                     Error_Msg ("??unreachable code!", Sloc (Error_Node));
+                     Error_Msg
+                       ("??unreachable code!", Sloc (Error_Node), Error_Node);
                   end if;
                end if;
 
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 37459f80382..3c6f36331fd 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -343,7 +343,6 @@ package body Sem_Ch6 is
          ----------------------
 
          function Freeze_Type_Refs (Node : Node_Id) return Traverse_Result is
-
             procedure Check_And_Freeze_Type (Typ : Entity_Id);
             --  Check that Typ is fully declared and freeze it if so
 
@@ -371,8 +370,7 @@ package body Sem_Ch6 is
                   if Has_Private_Component (Typ)
                     and then not Is_Private_Type (Typ)
                   then
-                     Error_Msg_NE
-                       ("\type& has private component", Node, Typ);
+                     Error_Msg_NE ("\type& has private component", Node, Typ);
                   end if;
 
                else
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 1f4eb1b8fdb..b013755a88e 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -29,65 +29,66 @@
 --  to complete the syntax checks. Certain pragmas are handled partially or
 --  completely by the parser (see Par.Prag for further details).
 
-with Aspects;          use Aspects;
-with Atree;            use Atree;
-with Casing;           use Casing;
-with Checks;           use Checks;
-with Contracts;        use Contracts;
-with Csets;            use Csets;
-with Debug;            use Debug;
-with Einfo;            use Einfo;
-with Elists;           use Elists;
-with Errout;           use Errout;
-with Exp_Dist;         use Exp_Dist;
-with Exp_Util;         use Exp_Util;
-with Freeze;           use Freeze;
-with Ghost;            use Ghost;
-with Gnatvsn;          use Gnatvsn;
-with Lib;              use Lib;
-with Lib.Writ;         use Lib.Writ;
-with Lib.Xref;         use Lib.Xref;
-with Namet.Sp;         use Namet.Sp;
-with Nlists;           use Nlists;
-with Nmake;            use Nmake;
-with Output;           use Output;
-with Par_SCO;          use Par_SCO;
-with Restrict;         use Restrict;
-with Rident;           use Rident;
-with Rtsfind;          use Rtsfind;
-with Sem;              use Sem;
-with Sem_Aux;          use Sem_Aux;
-with Sem_Ch3;          use Sem_Ch3;
-with Sem_Ch6;          use Sem_Ch6;
-with Sem_Ch8;          use Sem_Ch8;
-with Sem_Ch12;         use Sem_Ch12;
-with Sem_Ch13;         use Sem_Ch13;
-with Sem_Disp;         use Sem_Disp;
-with Sem_Dist;         use Sem_Dist;
-with Sem_Elim;         use Sem_Elim;
-with Sem_Eval;         use Sem_Eval;
-with Sem_Intr;         use Sem_Intr;
-with Sem_Mech;         use Sem_Mech;
-with Sem_Res;          use Sem_Res;
-with Sem_Type;         use Sem_Type;
-with Sem_Util;         use Sem_Util;
-with Sem_Warn;         use Sem_Warn;
-with Stand;            use Stand;
-with Sinfo;            use Sinfo;
-with Sinfo.CN;         use Sinfo.CN;
-with Sinput;           use Sinput;
-with Stringt;          use Stringt;
-with Stylesw;          use Stylesw;
-with System.Case_Util;
+with Aspects;   use Aspects;
+with Atree;     use Atree;
+with Casing;    use Casing;
+with Checks;    use Checks;
+with Contracts; use Contracts;
+with Csets;     use Csets;
+with Debug;     use Debug;
+with Einfo;     use Einfo;
+with Elists;    use Elists;
+with Errout;    use Errout;
+with Exp_Dist;  use Exp_Dist;
+with Exp_Util;  use Exp_Util;
+with Freeze;    use Freeze;
+with Ghost;     use Ghost;
+with Gnatvsn;   use Gnatvsn;
+with Lib;       use Lib;
+with Lib.Writ;  use Lib.Writ;
+with Lib.Xref;  use Lib.Xref;
+with Namet.Sp;  use Namet.Sp;
+with Nlists;    use Nlists;
+with Nmake;     use Nmake;
+with Output;    use Output;
+with Par_SCO;   use Par_SCO;
+with Restrict;  use Restrict;
+with Rident;    use Rident;
+with Rtsfind;   use Rtsfind;
+with Sem;       use Sem;
+with Sem_Aux;   use Sem_Aux;
+with Sem_Ch3;   use Sem_Ch3;
+with Sem_Ch6;   use Sem_Ch6;
+with Sem_Ch8;   use Sem_Ch8;
+with Sem_Ch12;  use Sem_Ch12;
+with Sem_Ch13;  use Sem_Ch13;
+with Sem_Disp;  use Sem_Disp;
+with Sem_Dist;  use Sem_Dist;
+with Sem_Elim;  use Sem_Elim;
+with Sem_Eval;  use Sem_Eval;
+with Sem_Intr;  use Sem_Intr;
+with Sem_Mech;  use Sem_Mech;
+with Sem_Res;   use Sem_Res;
+with Sem_Type;  use Sem_Type;
+with Sem_Util;  use Sem_Util;
+with Sem_Warn;  use Sem_Warn;
+with Stand;     use Stand;
+with Sinfo;     use Sinfo;
+with Sinfo.CN;  use Sinfo.CN;
+with Sinput;    use Sinput;
+with Stringt;   use Stringt;
+with Stylesw;   use Stylesw;
 with Table;
-with Targparm;         use Targparm;
-with Tbuild;           use Tbuild;
+with Targparm;  use Targparm;
+with Tbuild;    use Tbuild;
 with Ttypes;
-with Uintp;            use Uintp;
-with Uname;            use Uname;
-with Urealp;           use Urealp;
-with Validsw;          use Validsw;
-with Warnsw;           use Warnsw;
+with Uintp;     use Uintp;
+with Uname;     use Uname;
+with Urealp;    use Urealp;
+with Validsw;   use Validsw;
+with Warnsw;    use Warnsw;
+
+with System.Case_Util;
 
 package body Sem_Prag is
 
@@ -17924,8 +17925,8 @@ package body Sem_Prag is
                                                   Name_Increases)
                then
                   declare
-                     Name : String :=
-                              Get_Name_String (Chars (Variant));
+                     Name : String := Get_Name_String (Chars (Variant));
+
                   begin
                      --  It is a common mistake to write "Increasing" for
                      --  "Increases" or "Decreasing" for "Decreases". Recognize
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index a153e9a04df..5e74d20c093 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -32,6 +32,7 @@ with Checks;   use Checks;
 with Debug;    use Debug;
 with Elists;   use Elists;
 with Errout;   use Errout;
+with Erroutc;  use Erroutc;
 with Exp_Ch11; use Exp_Ch11;
 with Exp_Disp; use Exp_Disp;
 with Exp_Util; use Exp_Util;
@@ -137,6 +138,10 @@ package body Sem_Util is
    --  becomes Requires_Transient_Scope and Old_Requires_Transient_Scope is
    --  eliminated.
 
+   function Subprogram_Name (N : Node_Id) return String;
+   --  Return the fully qualified name of the enclosing subprogram for the
+   --  given node N.
+
    ------------------------------
    --  Abstract_Interface_List --
    ------------------------------
@@ -572,6 +577,98 @@ package body Sem_Util is
       end case;
    end All_Composite_Constraints_Static;
 
+   ------------------------
+   -- Append_Entity_Name --
+   ------------------------
+
+   procedure Append_Entity_Name (Buf : in out Bounded_String; E : Entity_Id) is
+      Temp : Bounded_String;
+
+      procedure Inner (E : Entity_Id);
+      --  Inner recursive routine, keep outer routine nonrecursive to ease
+      --  debugging when we get strange results from this routine.
+
+      -----------
+      -- Inner --
+      -----------
+
+      procedure Inner (E : Entity_Id) is
+      begin
+         --  If entity has an internal name, skip by it, and print its scope.
+         --  Note that we strip a final R from the name before the test; this
+         --  is needed for some cases of instantiations.
+
+         declare
+            E_Name : Bounded_String;
+
+         begin
+            Append (E_Name, Chars (E));
+
+            if E_Name.Chars (E_Name.Length) = 'R' then
+               E_Name.Length := E_Name.Length - 1;
+            end if;
+
+            if Is_Internal_Name (E_Name) then
+               Inner (Scope (E));
+               return;
+            end if;
+         end;
+
+         --  Just print entity name if its scope is at the outer level
+
+         if Scope (E) = Standard_Standard then
+            null;
+
+         --  If scope comes from source, write scope and entity
+
+         elsif Comes_From_Source (Scope (E)) then
+            Append_Entity_Name (Temp, Scope (E));
+            Append (Temp, '.');
+
+         --  If in wrapper package skip past it
+
+         elsif Is_Wrapper_Package (Scope (E)) then
+            Append_Entity_Name (Temp, Scope (Scope (E)));
+            Append (Temp, '.');
+
+         --  Otherwise nothing to output (happens in unnamed block statements)
+
+         else
+            null;
+         end if;
+
+         --  Output the name
+
+         declare
+            E_Name : Bounded_String;
+
+         begin
+            Append_Unqualified_Decoded (E_Name, Chars (E));
+
+            --  Remove trailing upper-case letters from the name (useful for
+            --  dealing with some cases of internal names generated in the case
+            --  of references from within a generic).
+
+            while E_Name.Length > 1
+              and then E_Name.Chars (E_Name.Length) in 'A' .. 'Z'
+            loop
+               E_Name.Length := E_Name.Length - 1;
+            end loop;
+
+            --  Adjust casing appropriately (gets name from source if possible)
+
+            Adjust_Name_Case (E_Name, Sloc (E));
+            Append (Temp, E_Name);
+         end;
+      end Inner;
+
+   --  Start of processing for Append_Entity_Name
+
+   begin
+      Inner (E);
+      Append (Buf, Temp);
+   end Append_Entity_Name;
+
    ---------------------------------
    -- Append_Inherited_Subprogram --
    ---------------------------------
@@ -21663,11 +21760,12 @@ package body Sem_Util is
    -- Set_Rep_Info --
    ------------------
 
-   procedure Set_Rep_Info (T1, T2 : Entity_Id) is
+   procedure Set_Rep_Info (T1 : Entity_Id; T2 : Entity_Id) is
    begin
       Set_Is_Atomic               (T1, Is_Atomic (T2));
       Set_Is_Independent          (T1, Is_Independent (T2));
       Set_Is_Volatile_Full_Access (T1, Is_Volatile_Full_Access (T2));
+
       if Is_Base_Type (T1) then
          Set_Is_Volatile          (T1, Is_Volatile (T2));
       end if;
@@ -21855,6 +21953,49 @@ package body Sem_Util is
       end if;
    end Subprogram_Access_Level;
 
+   ---------------------
+   -- Subprogram_Name --
+   ---------------------
+
+   function Subprogram_Name (N : Node_Id) return String is
+      Buf : Bounded_String;
+      Ent : Node_Id := N;
+
+   begin
+      while Present (Ent) loop
+         case Nkind (Ent) is
+            when N_Subprogram_Body =>
+               Ent := Defining_Unit_Name (Specification (Ent));
+               exit;
+
+            when N_Package_Body
+               | N_Package_Specification
+               | N_Subprogram_Specification
+            =>
+               Ent := Defining_Unit_Name (Ent);
+               exit;
+
+            when N_Protected_Body
+               | N_Protected_Type_Declaration
+               | N_Task_Body
+            =>
+               exit;
+
+            when others =>
+               null;
+         end case;
+
+         Ent := Parent (Ent);
+      end loop;
+
+      if No (Ent) then
+         return "unknown subprogram";
+      end if;
+
+      Append_Entity_Name (Buf, Ent);
+      return +Buf;
+   end Subprogram_Name;
+
    -------------------------------
    -- Support_Atomic_Primitives --
    -------------------------------
@@ -23188,5 +23329,5 @@ package body Sem_Util is
    end Yields_Universal_Type;
 
 begin
-   Errout.Current_Subprogram_Ptr := Current_Subprogram'Access;
+   Erroutc.Subprogram_Name_Ptr := Subprogram_Name'Access;
 end Sem_Util;
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index d0c3a26e553..7279c639180 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -105,6 +105,12 @@ package Sem_Util is
    --  irrelevant. Also called for array aggregates, but only named notation,
    --  because those are the only dynamic cases.
 
+   procedure Append_Entity_Name (Buf : in out Bounded_String; E : Entity_Id);
+   --  Recursive procedure to construct string for qualified name of enclosing
+   --  program unit. The qualification stops at an enclosing scope has no
+   --  source name (block or loop). If entity is a subprogram instance, skip
+   --  enclosing wrapper package. The name is appended to Buf.
+
    procedure Append_Inherited_Subprogram (S : Entity_Id);
    --  If the parent of the operation is declared in the visible part of
    --  the current scope, the inherited operation is visible even though the
@@ -2473,7 +2479,7 @@ package Sem_Util is
    --  (Referenced_As_LHS if Out_Param is False, Referenced_As_Out_Parameter
    --  if Out_Param is True) is set True, and the other flag set False.
 
-   procedure Set_Rep_Info (T1, T2 : Entity_Id);
+   procedure Set_Rep_Info (T1 : Entity_Id; T2 : Entity_Id);
    pragma Inline (Set_Rep_Info);
    --  Copies the Is_Atomic, Is_Independent and Is_Volatile_Full_Access flags
    --  from sub(type) entity T2 to (sub)type entity T1, as well as Is_Volatile