[multiple changes]

2017-09-08  Yannick Moy  <moy@adacore.com>

	* sem_prag.adb: Use System.Case_Util.To_Lower to simplify code.

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

	* opt.ads (Include_Subprogram_In_Messages): New variable.
	* errout.ads (Current_Subprogram_Ptr): New variable.
	* errout.adb (Error_Msg): Prepend current subprogram info
	in messages if Include_Subprogram_In_Messages is set.
	* sem_util.adb (elab code): Initialize Current_Subprogram_Ptr to
	Current_Subprogram.
	* gnat1drv.adb (Adjust_Global_Switches): Set
	Include_Subprogram_In_Messages when -gnatdJ is set.
	* debug.adb: Document and reserve -gnatdJ.

2017-09-08  Georges-Axel Jaloyan  <jaloyan@adacore.com>

	* g-dynhta.adb, g-dynhta.ads (Get_First_Key, Get_Next_Key): New
	functions to iterate over simple hastables.
	(Load_Factor_HTable): Remove obsolete and inefficient implementation.

2017-09-08  Javier Miranda  <miranda@adacore.com>

	* exp_ch6.adb (Unqual_BIP_Function_Call): Adding
	missing checks on the presence of Entity() before checking the
	entity attributes.

2017-09-08  Eric Botcazou  <ebotcazou@adacore.com>

	* sem_ch6.adb (Analyze_Expression_Function): Reorder some
	statements, use local variable and remove unnecessary processing.

From-SVN: r251880

13 files changed, 216 insertions, 566 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index c3c48a5..3e030fe 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,36 @@
+2017-09-08  Yannick Moy  <moy@adacore.com>
+
+	* sem_prag.adb: Use System.Case_Util.To_Lower to simplify code.
+
+2017-09-08  Arnaud Charlet  <charlet@adacore.com>
+
+	* opt.ads (Include_Subprogram_In_Messages): New variable.
+	* errout.ads (Current_Subprogram_Ptr): New variable.
+	* errout.adb (Error_Msg): Prepend current subprogram info
+	in messages if Include_Subprogram_In_Messages is set.
+	* sem_util.adb (elab code): Initialize Current_Subprogram_Ptr to
+	Current_Subprogram.
+	* gnat1drv.adb (Adjust_Global_Switches): Set
+	Include_Subprogram_In_Messages when -gnatdJ is set.
+	* debug.adb: Document and reserve -gnatdJ.
+
+2017-09-08  Georges-Axel Jaloyan  <jaloyan@adacore.com>
+
+	* g-dynhta.adb, g-dynhta.ads (Get_First_Key, Get_Next_Key): New
+	functions to iterate over simple hastables.
+	(Load_Factor_HTable): Remove obsolete and inefficient implementation.
+
+2017-09-08  Javier Miranda  <miranda@adacore.com>
+
+	* exp_ch6.adb (Unqual_BIP_Function_Call): Adding
+	missing checks on the presence of Entity() before checking the
+	entity attributes.
+
+2017-09-08  Eric Botcazou  <ebotcazou@adacore.com>
+
+	* sem_ch6.adb (Analyze_Expression_Function): Reorder some
+	statements, use local variable and remove unnecessary processing.
+
 2017-09-08  Javier Miranda  <miranda@adacore.com>
 
 	* exp_ch6.ads (Make_Build_In_Place_Iface_Call_In_Allocator): New
diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb
index f5a7e25..c45a188 100644
--- a/gcc/ada/debug.adb
+++ b/gcc/ada/debug.adb
@@ -73,7 +73,7 @@ package body Debug is
    --  dG   Generate all warnings including those normally suppressed
    --  dH   Hold (kill) call to gigi
    --  dI   Inhibit internal name numbering in gnatG listing
-   --  dJ
+   --  dJ   Prepend subprogram name in messages
    --  dK   Kill all error messages
    --  dL   Output trace information on elaboration checking
    --  dM   Assume all variables are modified (no current values)
@@ -400,6 +400,11 @@ package body Debug is
    --       is used in the fixed bugs run to minimize system and version
    --       dependency in filed -gnatD or -gnatG output.
 
+   --  dJ   Prepend the name of the enclosing subprogram in compiler messages
+   --       (errors, warnings, style checks). This is useful in particular to
+   --       integrate compiler warnings in static analysis tools such as
+   --       CodePeer.
+
    --  dK   Kill all error messages. This debug flag suppresses the output
    --       of all error messages. It is used in regression tests where the
    --       error messages are target dependent and irrelevant.
diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb
index a04df94..664d36e 100644
--- a/gcc/ada/errout.adb
+++ b/gcc/ada/errout.adb
@@ -310,6 +310,8 @@ 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
 
@@ -336,6 +338,18 @@ 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.
 
@@ -405,7 +419,14 @@ package body Errout is
       --  Error_Msg_Internal to place the message in the requested location.
 
       if Instantiation (Sindex) = No_Location then
-         Error_Msg_Internal (Msg, Flag_Location, Flag_Location, False);
+         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;
+
          return;
       end if;
 
@@ -555,8 +576,15 @@ package body Errout is
 
          --  Here we output the original message on the outer instantiation
 
-         Error_Msg_Internal
-           (Msg, Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
+         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;
       end;
    end Error_Msg;
 
diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads
index a8e4d6c..ad33673 100644
--- a/gcc/ada/errout.ads
+++ b/gcc/ada/errout.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          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- --
@@ -68,6 +68,11 @@ 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 --
    -----------------------------------
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index a36e51f..d04bbb1 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -9100,6 +9100,7 @@ package body Exp_Ch6 is
          --  Recurse on object renamings
 
          elsif Nkind (Expr) = N_Identifier
+           and then Present (Entity (Expr))
            and then Ekind_In (Entity (Expr), E_Constant, E_Variable)
            and then Nkind (Parent (Entity (Expr))) =
                       N_Object_Renaming_Declaration
@@ -9112,6 +9113,7 @@ package body Exp_Ch6 is
 
          elsif not On_Object_Declaration
            and then Nkind (Expr) = N_Identifier
+           and then Present (Entity (Expr))
            and then Ekind_In (Entity (Expr), E_Constant, E_Variable)
            and then Nkind (Parent (Entity (Expr))) = N_Object_Declaration
            and then Present (Expression (Parent (Entity (Expr))))
@@ -9125,6 +9127,7 @@ package body Exp_Ch6 is
 
          elsif Nkind (Expr) = N_Function_Call
            and then Nkind (Name (Expr)) in N_Has_Entity
+           and then Present (Entity (Name (Expr)))
            and then RTU_Loaded (Ada_Tags)
            and then RTE_Available (RE_Displace)
            and then Is_RTE (Entity (Name (Expr)), RE_Displace)
diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb
index c60f75a..dbb9d3e 100644
--- a/gcc/ada/exp_prag.adb
+++ b/gcc/ada/exp_prag.adb
@@ -324,7 +324,7 @@ package body Exp_Prag is
       --  Discriminants of the enclosing protected object may be referenced
       --  in the expression of a precondition of a protected operation.
       --  In the body of the operation these references must be replaced by
-      --  the discriminal created for them, which area renamings of the
+      --  the discriminal created for them, which are renamings of the
       --  discriminants of the object that is the target of the operation.
       --  This replacement is done by visibility when the references appear
       --  in the subprogram body, but in the case of a condition which appears
diff --git a/gcc/ada/g-dynhta.adb b/gcc/ada/g-dynhta.adb
index 10931cc..05ef901 100644
--- a/gcc/ada/g-dynhta.adb
+++ b/gcc/ada/g-dynhta.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---                     Copyright (C) 2002-2016, AdaCore                     --
+--                     Copyright (C) 2002-2017, AdaCore                     --
 --                                                                          --
 -- 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- --
@@ -256,6 +256,20 @@ package body GNAT.Dynamic_HTables is
          end if;
       end Get_First;
 
+      -------------------
+      -- Get_First_Key --
+      -------------------
+
+      function Get_First_Key (T : Instance) return access constant Key is
+         Tmp : aliased constant Elmt_Ptr := Tab.Get_First (Tab.Instance (T));
+      begin
+         if Tmp = null then
+            return null;
+         else
+            return Tmp.all.K'Access;
+         end if;
+      end Get_First_Key;
+
       -------------
       -- Get_Key --
       -------------
@@ -279,6 +293,20 @@ package body GNAT.Dynamic_HTables is
          end if;
       end Get_Next;
 
+      ------------------
+      -- Get_Next_Key --
+      ------------------
+
+      function Get_Next_Key (T : Instance) return access constant Key is
+         Tmp : aliased constant Elmt_Ptr := Tab.Get_Next (Tab.Instance (T));
+      begin
+         if Tmp = null then
+            return null;
+         else
+            return Tmp.all.K'Access;
+         end if;
+      end Get_Next_Key;
+
       ----------
       -- Next --
       ----------
@@ -347,364 +375,4 @@ package body GNAT.Dynamic_HTables is
 
    end Simple_HTable;
 
-   ------------------------
-   -- Load_Factor_HTable --
-   ------------------------
-
-   package body Load_Factor_HTable is
-
-      Min_Size_Increase : constant := 5;
-      --  The minimum increase expressed as number of buckets. This value is
-      --  used to determine the new size of small tables and/or small growth
-      --  percentages.
-
-      procedure Attach
-        (Elmt  : not null Element_Ptr;
-         Chain : not null Element_Ptr);
-      --  Prepend an element to a bucket chain. Elmt is inserted after the
-      --  dummy head of Chain.
-
-      function Create_Buckets (Size : Positive) return Buckets_Array_Ptr;
-      --  Allocate and initialize a new set of buckets. The buckets are created
-      --  in the range Range_Type'First .. Range_Type'First + Size - 1.
-
-      procedure Detach (Elmt : not null Element_Ptr);
-      --  Remove an element from an arbitrary bucket chain
-
-      function Find
-        (Key   : Key_Type;
-         Chain : not null Element_Ptr) return Element_Ptr;
-      --  Try to locate the element which contains a particular key within a
-      --  bucket chain. If no such element exists, return No_Element.
-
-      procedure Free is
-        new Ada.Unchecked_Deallocation (Buckets_Array, Buckets_Array_Ptr);
-
-      procedure Free is
-        new Ada.Unchecked_Deallocation (Element, Element_Ptr);
-
-      function Is_Empty_Chain (Chain : not null Element_Ptr) return Boolean;
-      --  Determine whether a bucket chain contains only one element, namely
-      --  the dummy head.
-
-      ------------
-      -- Attach --
-      ------------
-
-      procedure Attach
-        (Elmt  : not null Element_Ptr;
-         Chain : not null Element_Ptr)
-      is
-      begin
-         Chain.Next.Prev := Elmt;
-         Elmt.Next  := Chain.Next;
-         Chain.Next := Elmt;
-         Elmt.Prev  := Chain;
-      end Attach;
-
-      --------------------
-      -- Create_Buckets --
-      --------------------
-
-      function Create_Buckets (Size : Positive) return Buckets_Array_Ptr is
-         Low_Bound : constant Range_Type := Range_Type'First;
-         Buckets   : Buckets_Array_Ptr;
-
-      begin
-         Buckets :=
-           new Buckets_Array (Low_Bound .. Low_Bound + Range_Type (Size) - 1);
-
-         --  Ensure that the dummy head of each bucket chain points to itself
-         --  in both directions.
-
-         for Index in Buckets'Range loop
-            declare
-               Bucket : Element renames Buckets (Index);
-
-            begin
-               Bucket.Prev := Bucket'Unchecked_Access;
-               Bucket.Next := Bucket'Unchecked_Access;
-            end;
-         end loop;
-
-         return Buckets;
-      end Create_Buckets;
-
-      ------------------
-      -- Current_Size --
-      ------------------
-
-      function Current_Size (T : Table) return Positive is
-      begin
-         --  The table should have been properly initialized during object
-         --  elaboration.
-
-         if T.Buckets = null then
-            raise Program_Error;
-
-         --  The size of the table is determined by the number of buckets
-
-         else
-            return T.Buckets'Length;
-         end if;
-      end Current_Size;
-
-      ------------
-      -- Detach --
-      ------------
-
-      procedure Detach (Elmt : not null Element_Ptr) is
-      begin
-         if Elmt.Prev /= null and Elmt.Next /= null then
-            Elmt.Prev.Next := Elmt.Next;
-            Elmt.Next.Prev := Elmt.Prev;
-            Elmt.Prev := null;
-            Elmt.Next := null;
-         end if;
-      end Detach;
-
-      --------------
-      -- Finalize --
-      --------------
-
-      procedure Finalize (T : in out Table) is
-         Bucket : Element_Ptr;
-         Elmt   : Element_Ptr;
-
-      begin
-         --  Inspect the buckets and deallocate bucket chains
-
-         for Index in T.Buckets'Range loop
-            Bucket := T.Buckets (Index)'Unchecked_Access;
-
-            --  The current bucket chain contains an element other than the
-            --  dummy head.
-
-            while not Is_Empty_Chain (Bucket) loop
-
-               --  Skip the dummy head, remove and deallocate the element
-
-               Elmt := Bucket.Next;
-               Detach (Elmt);
-               Free   (Elmt);
-            end loop;
-         end loop;
-
-         --  Deallocate the buckets
-
-         Free (T.Buckets);
-      end Finalize;
-
-      ----------
-      -- Find --
-      ----------
-
-      function Find
-        (Key   : Key_Type;
-         Chain : not null Element_Ptr) return Element_Ptr
-      is
-         Elmt : Element_Ptr;
-
-      begin
-         --  Skip the dummy head, inspect the bucket chain for an element whose
-         --  key matches the requested key. Since each bucket chain is circular
-         --  the search must stop once the dummy head is encountered.
-
-         Elmt := Chain.Next;
-         while Elmt /= Chain loop
-            if Equal (Elmt.Key, Key) then
-               return Elmt;
-            end if;
-
-            Elmt := Elmt.Next;
-         end loop;
-
-         return No_Element;
-      end Find;
-
-      ---------
-      -- Get --
-      ---------
-
-      function Get (T : Table; Key : Key_Type) return Value_Type is
-         Bucket : Element_Ptr;
-         Elmt   : Element_Ptr;
-
-      begin
-         --  Obtain the bucket chain where the (key, value) pair should reside
-         --  by calculating the proper hash location.
-
-         Bucket := T.Buckets (Hash (Key, Current_Size (T)))'Unchecked_Access;
-
-         --  Try to find an element whose key matches the requested key
-
-         Elmt := Find (Key, Bucket);
-
-         --  The hash table does not contain a matching (key, value) pair
-
-         if Elmt = No_Element then
-            return No_Value;
-         else
-            return Elmt.Val;
-         end if;
-      end Get;
-
-      ----------------
-      -- Initialize --
-      ----------------
-
-      procedure Initialize (T : in out Table) is
-      begin
-         pragma Assert (T.Buckets = null);
-
-         T.Buckets       := Create_Buckets (Initial_Size);
-         T.Element_Count := 0;
-      end Initialize;
-
-      --------------------
-      -- Is_Empty_Chain --
-      --------------------
-
-      function Is_Empty_Chain (Chain : not null Element_Ptr) return Boolean is
-      begin
-         return Chain.Next = Chain and Chain.Prev = Chain;
-      end Is_Empty_Chain;
-
-      ------------
-      -- Remove --
-      ------------
-
-      procedure Remove (T : in out Table; Key : Key_Type) is
-         Bucket : Element_Ptr;
-         Elmt   : Element_Ptr;
-
-      begin
-         --  Obtain the bucket chain where the (key, value) pair should reside
-         --  by calculating the proper hash location.
-
-         Bucket := T.Buckets (Hash (Key, Current_Size (T)))'Unchecked_Access;
-
-         --  Try to find an element whose key matches the requested key
-
-         Elmt := Find (Key, Bucket);
-
-         --  Remove and deallocate the (key, value) pair
-
-         if Elmt /= No_Element then
-            Detach (Elmt);
-            Free   (Elmt);
-         end if;
-      end Remove;
-
-      ---------
-      -- Set --
-      ---------
-
-      procedure Set
-        (T   : in out Table;
-         Key : Key_Type;
-         Val : Value_Type)
-      is
-         Curr_Size : constant Positive := Current_Size (T);
-
-         procedure Grow;
-         --  Grow the table to a new size according to the desired percentage
-         --  and relocate all existing elements to the new buckets.
-
-         ----------
-         -- Grow --
-         ----------
-
-         procedure Grow is
-            Buckets     : Buckets_Array_Ptr;
-            Elmt        : Element_Ptr;
-            Hash_Loc    : Range_Type;
-            Old_Bucket  : Element_Ptr;
-            Old_Buckets : Buckets_Array_Ptr := T.Buckets;
-            Size        : Positive;
-
-         begin
-            --  Calculate the new size and allocate a new set of buckets. Note
-            --  that a table with a small size or a small growth percentage may
-            --  not always grow (for example, 10 buckets and 3% increase). In
-            --  that case, enforce a minimum increase.
-
-            Size :=
-              Positive'Max (Curr_Size * ((100 + Growth_Percentage) / 100),
-                            Min_Size_Increase);
-            Buckets := Create_Buckets (Size);
-
-            --  Inspect the old buckets and transfer all elements by rehashing
-            --  all (key, value) pairs in the new buckets.
-
-            for Index in Old_Buckets'Range loop
-               Old_Bucket := Old_Buckets (Index)'Unchecked_Access;
-
-               --  The current bucket chain contains an element other than the
-               --  dummy head.
-
-               while not Is_Empty_Chain (Old_Bucket) loop
-
-                  --  Skip the dummy head and find the new hash location
-
-                  Elmt     := Old_Bucket.Next;
-                  Hash_Loc := Hash (Elmt.Key, Size);
-
-                  --  Remove the element from the old buckets and insert it
-                  --  into the new buckets. Note that there is no need to check
-                  --  for duplicates because the hash table did not have any to
-                  --  begin with.
-
-                  Detach (Elmt);
-                  Attach
-                    (Elmt  => Elmt,
-                     Chain => Buckets (Hash_Loc)'Unchecked_Access);
-               end loop;
-            end loop;
-
-            --  Associate the new buckets with the table and reclaim the
-            --  storage occupied by the old buckets.
-
-            T.Buckets := Buckets;
-
-            Free (Old_Buckets);
-         end Grow;
-
-         --  Local variables
-
-         subtype LLF is Long_Long_Float;
-
-         Count    : Natural renames T.Element_Count;
-         Bucket   : Element_Ptr;
-         Hash_Loc : Range_Type;
-
-      --  Start of processing for Set
-
-      begin
-         --  Find the bucket where the (key, value) pair should be inserted by
-         --  computing the proper hash location.
-
-         Hash_Loc := Hash (Key, Curr_Size);
-         Bucket   := T.Buckets (Hash_Loc)'Unchecked_Access;
-
-         --  Ensure that the key is not already present in the bucket in order
-         --  to avoid duplicates.
-
-         if Find (Key, Bucket) = No_Element then
-            Attach
-              (Elmt  => new Element'(Key, Val, null, null),
-               Chain => Bucket);
-            Count := Count + 1;
-
-            --  Multiple insertions may cause long bucket chains and decrease
-            --  the performance of basic operations. If this is the case, grow
-            --  the table and rehash all existing elements.
-
-            if (LLF (Count) / LLF (Curr_Size)) > LLF (Load_Factor) then
-               Grow;
-            end if;
-         end if;
-      end Set;
-   end Load_Factor_HTable;
-
 end GNAT.Dynamic_HTables;
diff --git a/gcc/ada/g-dynhta.ads b/gcc/ada/g-dynhta.ads
index d1dedae..e80dfdf 100644
--- a/gcc/ada/g-dynhta.ads
+++ b/gcc/ada/g-dynhta.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---                     Copyright (C) 1995-2014, AdaCore                     --
+--                     Copyright (C) 1995-2017, AdaCore                     --
 --                                                                          --
 -- 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- --
@@ -48,8 +48,6 @@
 --  GNAT.HTable to keep as much coherency as possible between these two
 --  related units.
 
-private with Ada.Finalization;
-
 package GNAT.Dynamic_HTables is
 
    -------------------
@@ -124,11 +122,11 @@ package GNAT.Dynamic_HTables is
 
       function Get_First (T : Instance) return Elmt_Ptr;
       --  Returns Null_Ptr if the Htable is empty, otherwise returns one
-      --  non specified element. There is no guarantee that 2 calls to this
+      --  unspecified element. There is no guarantee that 2 calls to this
       --  function will return the same element.
 
       function Get_Next (T : Instance) return Elmt_Ptr;
-      --  Returns a non-specified element that has not been returned by the
+      --  Returns an unspecified element that has not been returned by the
       --  same function since the last call to Get_First or Null_Ptr if
       --  there is no such element or Get_First has never been called. If
       --  there is no call to 'Set' in between Get_Next calls, all the
@@ -189,12 +187,18 @@ package GNAT.Dynamic_HTables is
 
       function Get_First (T : Instance) return Element;
       --  Returns No_Element if the Htable is empty, otherwise returns one
-      --  non specified element. There is no guarantee that two calls to this
+      --  unspecified element. There is no guarantee that two calls to this
       --  function will return the same element, if the Htable has been
       --  modified between the two calls.
 
+      function Get_First_Key (T : Instance) return access constant Key;
+      --  Returns Null if the Htable is empty, otherwise returns one
+      --  unspecified key. There is no guarantee that two calls to this
+      --  function will return the same key, if the Htable has been modified
+      --  between the two calls.
+
       function Get_Next (T : Instance) return Element;
-      --  Returns a non-specified element that has not been returned by the
+      --  Returns an unspecified element that has not been returned by the
       --  same function since the last call to Get_First or No_Element if
       --  there is no such element. If there is no call to 'Set' in between
       --  Get_Next calls, all the elements of the Htable will be traversed.
@@ -203,12 +207,18 @@ package GNAT.Dynamic_HTables is
       --  between a call to Get_First and subsequent consecutive calls to
       --  Get_Next, until one of these calls returns No_Element.
 
+      function Get_Next_Key (T : Instance) return access constant Key;
+      --  Same as Get_Next except that this returns an unspecified access
+      --  to constant key that has not been returned by either Get_First_Key
+      --  or this very same function (or null if there is none). The same
+      --  restrictions apply as Get_Next.
+
    private
 
       type Element_Wrapper;
       type Elmt_Ptr is access all Element_Wrapper;
       type Element_Wrapper is record
-         K    : Key;
+         K    : aliased Key;
          E    : Element;
          Next : Elmt_Ptr;
       end record;
@@ -234,116 +244,4 @@ package GNAT.Dynamic_HTables is
 
    end Simple_HTable;
 
-   ------------------------
-   -- Load_Factor_HTable --
-   ------------------------
-
-   --  A simple hash table abstraction capable of growing once a threshold has
-   --  been exceeded. Collisions are resolved by chaining elements onto lists
-   --  hanging from individual buckets. This implementation does not make any
-   --  effort to minimize the number of necessary rehashes once the table has
-   --  been expanded, hence the term "simple".
-
-   --  WARNING: This hash table implementation utilizes dynamic allocation.
-   --  Storage reclamation is performed by the hash table.
-
-   --  WARNING: This hash table implementation is not thread-safe. To achieve
-   --  proper concurrency and synchronization, wrap an instance of a table in
-   --  a protected object.
-
-   generic
-      type Range_Type is range <>;
-      --  The underlying range of the hash table. Note that this type must be
-      --  large enough to accommodate multiple expansions of the table.
-
-      type Key_Type is private;
-      type Value_Type is private;
-      --  The types of the (key, value) pair stored in the hash table
-
-      No_Value : Value_Type;
-      --  A predefined value denoting a non-existent value
-
-      Initial_Size : Positive;
-      --  The starting size of the hash table. The hash table must contain at
-      --  least one bucket.
-
-      Growth_Percentage : Positive;
-      --  The amount of increase expressed as a percentage. The hash table must
-      --  grow by at least 1%. To illustrate, a value of 100 will increase the
-      --  table by 100%, effectively doubling its size.
-
-      Load_Factor : Float;
-      --  The ratio of the elements stored within the hash table divided by the
-      --  current size of the table. This value acts as the growth threshold.
-      --  If exceeded, the hash table is expanded by Growth_Percentage.
-
-      with function Equal
-        (Left  : Key_Type;
-         Right : Key_Type) return Boolean;
-
-      with function Hash
-        (Key  : Key_Type;
-         Size : Positive) return Range_Type;
-      --  Parameter Size denotes the current size of the hash table
-
-   package Load_Factor_HTable is
-      type Table is tagged limited private;
-
-      function Current_Size (T : Table) return Positive;
-      --  Obtain the current size of the table
-
-      function Get (T : Table; Key : Key_Type) return Value_Type;
-      --  Obtain the value associated with a key. This routine returns No_Value
-      --  if the key is not present in the hash table.
-
-      procedure Remove (T : in out Table; Key : Key_Type);
-      --  Remove the value associated with the given key. This routine has no
-      --  effect if the key is not present in the hash table.
-
-      procedure Set
-        (T   : in out Table;
-         Key : Key_Type;
-         Val : Value_Type);
-      --  Associate a value with a given key. This routine has no effect if the
-      --  the (key, value) pair is already present in the hash table. Note that
-      --  this action may cause the table to grow.
-
-   private
-      --  The following types model a bucket chain. Note that the key is also
-      --  stored for rehashing purposes.
-
-      type Element;
-      type Element_Ptr is access all Element;
-      type Element is record
-         Key  : Key_Type;
-         Val  : Value_Type;
-         Prev : Element_Ptr := null;
-         Next : Element_Ptr := null;
-      end record;
-
-      No_Element : constant Element_Ptr := null;
-
-      --  The following types model the buckets of the hash table. Each bucket
-      --  has a dummy head to facilitate insertion and deletion of elements.
-
-      type Buckets_Array is array (Range_Type range <>) of aliased Element;
-      type Buckets_Array_Ptr is access all Buckets_Array;
-
-      type Table is new Ada.Finalization.Limited_Controlled with record
-         Buckets : Buckets_Array_Ptr := null;
-
-         Element_Count : Natural := 0;
-         --  The number of (key, value) pairs stored in the hash table
-      end record;
-
-      procedure Finalize (T : in out Table);
-      --  Destroy the contents of a hash table by reclaiming all storage used
-      --  by buckets and their respective chains.
-
-      procedure Initialize (T : in out Table);
-      --  Create a hash table with buckets within the range Range_Type'First ..
-      --  Range_Type'First + Initial_Size - 1.
-
-   end Load_Factor_HTable;
-
 end GNAT.Dynamic_HTables;
diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb
index 8a974c9..e60d912 100644
--- a/gcc/ada/gnat1drv.adb
+++ b/gcc/ada/gnat1drv.adb
@@ -178,6 +178,13 @@ procedure Gnat1drv is
          Error_To_Warning := True;
       end if;
 
+      --  -gnatdJ sets Include_Subprogram_In_Messages, adding the related
+      --  subprogram as part of the error and warning messages.
+
+      if Debug_Flag_JJ then
+         Include_Subprogram_In_Messages := True;
+      end if;
+
       --  Disable CodePeer_Mode in Check_Syntax, since we need front-end
       --  expansion.
 
diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads
index aef84ed..1c7c0a0 100644
--- a/gcc/ada/opt.ads
+++ b/gcc/ada/opt.ads
@@ -848,6 +848,10 @@ package Opt is
    --  cause implicit packing instead of generating an error message. Set by
    --  use of pragma Implicit_Packing.
 
+   Include_Subprogram_In_Messages : Boolean := False;
+   --  GNAT
+   --  Set True to include the enclosing subprogram in compiler messages.
+
    Ineffective_Inline_Warnings : Boolean := False;
    --  GNAT
    --  Set True to activate warnings if front-end inlining (-gnatN) is not able
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 54b02e4..37459f8 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -672,6 +672,15 @@ package body Sem_Ch6 is
          end if;
 
          Def_Id := Defining_Entity (N);
+         Set_Is_Inlined (Def_Id);
+
+         --  Establish the linkages between the spec and the body. These are
+         --  used when the expression function acts as the prefix of attribute
+         --  'Access in order to freeze the original expression which has been
+         --  moved to the generated body.
+
+         Set_Corresponding_Body (N, Defining_Entity (New_Body));
+         Set_Corresponding_Spec (New_Body, Def_Id);
 
          --  Within a generic pre-analyze the original expression for name
          --  capture. The body is also generated but plays no role in
@@ -685,16 +694,6 @@ package body Sem_Ch6 is
             End_Scope;
          end if;
 
-         Set_Is_Inlined (Defining_Entity (N));
-
-         --  Establish the linkages between the spec and the body. These are
-         --  used when the expression function acts as the prefix of attribute
-         --  'Access in order to freeze the original expression which has been
-         --  moved to the generated body.
-
-         Set_Corresponding_Body (N, Defining_Entity (New_Body));
-         Set_Corresponding_Spec (New_Body, Defining_Entity (N));
-
          --  To prevent premature freeze action, insert the new body at the end
          --  of the current declarations, or at the end of the package spec.
          --  However, resolve usage names now, to prevent spurious visibility
@@ -716,7 +715,7 @@ package body Sem_Ch6 is
             --  the enclosing instance is analyzed.
 
             if GNATprove_Mode
-              and then Is_Generic_Actual_Subprogram (Defining_Entity (N))
+              and then Is_Generic_Actual_Subprogram (Def_Id)
             then
                Insert_After (N, New_Body);
 
@@ -735,16 +734,13 @@ package body Sem_Ch6 is
                --  instance, where this has been done during generic analysis,
                --  and will be redone when analyzing the body.
 
-               Set_Parent (Expr, Ret);
-               Push_Scope (Def_Id);
-               Install_Formals (Def_Id);
-
                if not In_Instance then
+                  Push_Scope (Def_Id);
+                  Install_Formals (Def_Id);
                   Preanalyze_Spec_Expression (Expr, Typ);
                   Check_Limited_Return (Original_Node (N), Expr, Typ);
+                  End_Scope;
                end if;
-
-               End_Scope;
             end if;
          end;
       end if;
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 0dc5f08..1f4eb1b 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -29,64 +29,65 @@
 --  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 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 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;
 
 package body Sem_Prag is
 
@@ -17923,24 +17924,24 @@ package body Sem_Prag is
                                                   Name_Increases)
                then
                   declare
-                     Name : constant String :=
+                     Name : String :=
                               Get_Name_String (Chars (Variant));
                   begin
                      --  It is a common mistake to write "Increasing" for
                      --  "Increases" or "Decreasing" for "Decreases". Recognize
-                     --  specially names starting with "Incr" or "Decr" to
+                     --  specially names starting with "incr" or "decr" to
                      --  suggest the corresponding name.
 
+                     System.Case_Util.To_Lower (Name);
+
                      if Name'Length >= 4
-                       and then (Name (1 .. 4) = "Incr"
-                                   or else Name (1 .. 4) = "incr")
+                       and then Name (1 .. 4) = "incr"
                      then
                         Error_Pragma_Arg_Ident
                           ("expect name `Increases`", Variant);
 
                      elsif Name'Length >= 4
-                       and then (Name (1 .. 4) = "Decr"
-                                   or else Name (1 .. 4) = "decr")
+                       and then Name (1 .. 4) = "decr"
                      then
                         Error_Pragma_Arg_Ident
                           ("expect name `Decreases`", Variant);
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index b03926b..a399be0 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -23173,4 +23173,6 @@ package body Sem_Util is
       end if;
    end Yields_Universal_Type;
 
+begin
+   Errout.Current_Subprogram_Ptr := Current_Subprogram'Access;
 end Sem_Util;