[multiple changes]

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

	* gnat_rm.texi: Change theta to @ in documentation of aspect
	Dimension_System.

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

	* sem_attr.adb (Uneval_Old_Msg): Flags Uneval_Old_Accept/Warn
	are now on pragma.
	* sem_ch13.adb (Analyze_Aspect_Specifications): Remove setting
	of Uneval_Old_*
	* sem_prag.adb (Analyze_Pragma): Set Uneval_Old_* flags
	* sinfo.ads, sinfo.adb: Move Uneval_Old_Accept/Warn to N_Pragma node.

2014-07-29  Javier Miranda  <miranda@adacore.com>

	* types.ads Update documentation on how to add new reason codes
	for exceptions.
	(RT_Exception_Code): Keep values ordered by their
	reason code.  Required by the .NET backend.
	(RT_CE_Exceptions): Subtype declaration removed.
	(RT_PE_Exceptions): Subtype declaration removed.
	(RT_SE_Exceptions): Subtype declaration removed.
	(Kind): New mapping table of RT_Exception_Codes.
	* exp_ch11.adb (Get_RT_Exception_Entity): Updated to use the
	new mapping table.
	* tbuild.adb (Make_Raise_Storage_Error): Updated to use the new
	mapping table.	(Make_Raise_Program_Error): Updated to use the
	new mapping table.
	(Make_Raise_Storage_Error): Updated to use the new mapping table.
	* a-except.adb Keep Rcheck_CE_xxx entities ordered according to
	their reason code.

From-SVN: r213194

11 files changed, 207 insertions, 142 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 3354841..7644f9c 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,36 @@
+2014-07-29  Robert Dewar  <dewar@adacore.com>
+
+	* gnat_rm.texi: Change theta to @ in documentation of aspect
+	Dimension_System.
+
+2014-07-29  Robert Dewar  <dewar@adacore.com>
+
+	* sem_attr.adb (Uneval_Old_Msg): Flags Uneval_Old_Accept/Warn
+	are now on pragma.
+	* sem_ch13.adb (Analyze_Aspect_Specifications): Remove setting
+	of Uneval_Old_*
+	* sem_prag.adb (Analyze_Pragma): Set Uneval_Old_* flags
+	* sinfo.ads, sinfo.adb: Move Uneval_Old_Accept/Warn to N_Pragma node.
+
+2014-07-29  Javier Miranda  <miranda@adacore.com>
+
+	* types.ads Update documentation on how to add new reason codes
+	for exceptions.
+	(RT_Exception_Code): Keep values ordered by their
+	reason code.  Required by the .NET backend.
+	(RT_CE_Exceptions): Subtype declaration removed.
+	(RT_PE_Exceptions): Subtype declaration removed.
+	(RT_SE_Exceptions): Subtype declaration removed.
+	(Kind): New mapping table of RT_Exception_Codes.
+	* exp_ch11.adb (Get_RT_Exception_Entity): Updated to use the
+	new mapping table.
+	* tbuild.adb (Make_Raise_Storage_Error): Updated to use the new
+	mapping table.	(Make_Raise_Program_Error): Updated to use the
+	new mapping table.
+	(Make_Raise_Storage_Error): Updated to use the new mapping table.
+	* a-except.adb Keep Rcheck_CE_xxx entities ordered according to
+	their reason code.
+
 2014-07-29  Thomas Quinot  <quinot@adacore.com>
 
 	* gnat_rm.texi: Document internal attributes used for PolyORB/DSA
diff --git a/gcc/ada/a-except.adb b/gcc/ada/a-except.adb
index 5d26790..2d496fb 100644
--- a/gcc/ada/a-except.adb
+++ b/gcc/ada/a-except.adb
@@ -365,90 +365,86 @@ package body Ada.Exceptions is
    --  the normal approach is to keep them in the same order as declarations
    --  in Types.
 
-   --  This section is an IMPORTANT EXCEPTION. It is essential that the
-   --  routines in this section be declared in the same order as the Rmsg_xx
-   --  constants in the following section. This is required by the .Net runtime
-   --  which uses the exceptmsg.awk script to generate require exception data,
-   --  and this script requires and expects that this ordering rule holds.
+   --  This section is an IMPORTANT EXCEPTION. It is required by the .Net
+   --  runtime that the routine Rcheck_PE_Finalize_Raise_Exception is at the
+   --  end of the list (for reasons that are documented in the exceptmsg.awk
+   --  script which takes care of generating the required exception data).
 
-   --  The one exception is that Rcheck_PE_Finalize_Raise_Exception is at the
-   --  end of the list (for reasons that are documented with this routine). The
-   --  script (exceptmsg.awk) has this special exception built in.
-
-   procedure Rcheck_CE_Access_Check
+   procedure Rcheck_CE_Access_Check                   -- 00
      (File : System.Address; Line : Integer);
-   procedure Rcheck_CE_Null_Access_Parameter
+   procedure Rcheck_CE_Null_Access_Parameter          -- 01
      (File : System.Address; Line : Integer);
-   procedure Rcheck_CE_Discriminant_Check
+   procedure Rcheck_CE_Discriminant_Check             -- 02
      (File : System.Address; Line : Integer);
-   procedure Rcheck_CE_Divide_By_Zero
+   procedure Rcheck_CE_Divide_By_Zero                 -- 03
      (File : System.Address; Line : Integer);
-   procedure Rcheck_CE_Explicit_Raise
+   procedure Rcheck_CE_Explicit_Raise                 -- 04
      (File : System.Address; Line : Integer);
-   procedure Rcheck_CE_Index_Check
+   procedure Rcheck_CE_Index_Check                    -- 05
      (File : System.Address; Line : Integer);
-   procedure Rcheck_CE_Invalid_Data
+   procedure Rcheck_CE_Invalid_Data                   -- 06
      (File : System.Address; Line : Integer);
-   procedure Rcheck_CE_Length_Check
+   procedure Rcheck_CE_Length_Check                   -- 07
      (File : System.Address; Line : Integer);
-   procedure Rcheck_CE_Null_Exception_Id
+   procedure Rcheck_CE_Null_Exception_Id              -- 08
      (File : System.Address; Line : Integer);
-   procedure Rcheck_CE_Null_Not_Allowed
+   procedure Rcheck_CE_Null_Not_Allowed               -- 09
      (File : System.Address; Line : Integer);
-   procedure Rcheck_CE_Overflow_Check
+   procedure Rcheck_CE_Overflow_Check                 -- 10
      (File : System.Address; Line : Integer);
-   procedure Rcheck_CE_Partition_Check
+   procedure Rcheck_CE_Partition_Check                -- 11
      (File : System.Address; Line : Integer);
-   procedure Rcheck_CE_Range_Check
+   procedure Rcheck_CE_Range_Check                    -- 12
      (File : System.Address; Line : Integer);
-   procedure Rcheck_CE_Tag_Check
+   procedure Rcheck_CE_Tag_Check                      -- 13
      (File : System.Address; Line : Integer);
-   procedure Rcheck_PE_Access_Before_Elaboration
+   procedure Rcheck_PE_Access_Before_Elaboration      -- 14
      (File : System.Address; Line : Integer);
-   procedure Rcheck_PE_Accessibility_Check
+   procedure Rcheck_PE_Accessibility_Check            -- 15
      (File : System.Address; Line : Integer);
-   procedure Rcheck_PE_Address_Of_Intrinsic
+   procedure Rcheck_PE_Address_Of_Intrinsic           -- 16
      (File : System.Address; Line : Integer);
-   procedure Rcheck_PE_Aliased_Parameters
+   procedure Rcheck_PE_Aliased_Parameters             -- 17
      (File : System.Address; Line : Integer);
-   procedure Rcheck_PE_All_Guards_Closed
+   procedure Rcheck_PE_All_Guards_Closed              -- 18
      (File : System.Address; Line : Integer);
-   procedure Rcheck_PE_Bad_Predicated_Generic_Type
+   procedure Rcheck_PE_Bad_Predicated_Generic_Type    -- 19
      (File : System.Address; Line : Integer);
-   procedure Rcheck_PE_Current_Task_In_Entry_Body
+   procedure Rcheck_PE_Current_Task_In_Entry_Body     -- 20
      (File : System.Address; Line : Integer);
-   procedure Rcheck_PE_Duplicated_Entry_Address
+   procedure Rcheck_PE_Duplicated_Entry_Address       -- 21
      (File : System.Address; Line : Integer);
-   procedure Rcheck_PE_Explicit_Raise
+   procedure Rcheck_PE_Explicit_Raise                 -- 22
      (File : System.Address; Line : Integer);
-   procedure Rcheck_PE_Implicit_Return
+
+   procedure Rcheck_PE_Implicit_Return                -- 24
      (File : System.Address; Line : Integer);
-   procedure Rcheck_PE_Misaligned_Address_Value
+   procedure Rcheck_PE_Misaligned_Address_Value       -- 25
      (File : System.Address; Line : Integer);
-   procedure Rcheck_PE_Missing_Return
+   procedure Rcheck_PE_Missing_Return                 -- 26
      (File : System.Address; Line : Integer);
-   procedure Rcheck_PE_Non_Transportable_Actual
+   procedure Rcheck_PE_Overlaid_Controlled_Object     -- 27
      (File : System.Address; Line : Integer);
-   procedure Rcheck_PE_Overlaid_Controlled_Object
+   procedure Rcheck_PE_Potentially_Blocking_Operation -- 28
      (File : System.Address; Line : Integer);
-   procedure Rcheck_PE_Potentially_Blocking_Operation
+   procedure Rcheck_PE_Stubbed_Subprogram_Called      -- 29
      (File : System.Address; Line : Integer);
-   procedure Rcheck_PE_Stubbed_Subprogram_Called
+   procedure Rcheck_PE_Unchecked_Union_Restriction    -- 30
      (File : System.Address; Line : Integer);
-   procedure Rcheck_PE_Unchecked_Union_Restriction
+   procedure Rcheck_PE_Non_Transportable_Actual       -- 31
      (File : System.Address; Line : Integer);
-   procedure Rcheck_SE_Empty_Storage_Pool
+   procedure Rcheck_SE_Empty_Storage_Pool             -- 32
      (File : System.Address; Line : Integer);
-   procedure Rcheck_SE_Explicit_Raise
+   procedure Rcheck_SE_Explicit_Raise                 -- 33
      (File : System.Address; Line : Integer);
-   procedure Rcheck_SE_Infinite_Recursion
+   procedure Rcheck_SE_Infinite_Recursion             -- 34
      (File : System.Address; Line : Integer);
-   procedure Rcheck_SE_Object_Too_Large
+   procedure Rcheck_SE_Object_Too_Large               -- 35
      (File : System.Address; Line : Integer);
-   procedure Rcheck_PE_Stream_Operation_Not_Allowed
+   procedure Rcheck_PE_Stream_Operation_Not_Allowed   -- 36
      (File : System.Address; Line : Integer);
 
-   procedure Rcheck_PE_Finalize_Raised_Exception
+   procedure Rcheck_PE_Finalize_Raised_Exception      -- 23
      (File : System.Address; Line : Integer);
    --  This routine is separated out because it has quite different behavior
    --  from the others. This is the "finalize/adjust raised exception". This
@@ -1380,13 +1376,6 @@ package body Ada.Exceptions is
       Raise_Program_Error_Msg (File, Line, Rmsg_26'Address);
    end Rcheck_PE_Missing_Return;
 
-   procedure Rcheck_PE_Non_Transportable_Actual
-     (File : System.Address; Line : Integer)
-   is
-   begin
-      Raise_Program_Error_Msg (File, Line, Rmsg_31'Address);
-   end Rcheck_PE_Non_Transportable_Actual;
-
    procedure Rcheck_PE_Overlaid_Controlled_Object
      (File : System.Address; Line : Integer)
    is
@@ -1401,13 +1390,6 @@ package body Ada.Exceptions is
       Raise_Program_Error_Msg (File, Line, Rmsg_28'Address);
    end Rcheck_PE_Potentially_Blocking_Operation;
 
-   procedure Rcheck_PE_Stream_Operation_Not_Allowed
-     (File : System.Address; Line : Integer)
-   is
-   begin
-      Raise_Program_Error_Msg (File, Line, Rmsg_36'Address);
-   end Rcheck_PE_Stream_Operation_Not_Allowed;
-
    procedure Rcheck_PE_Stubbed_Subprogram_Called
      (File : System.Address; Line : Integer)
    is
@@ -1422,6 +1404,13 @@ package body Ada.Exceptions is
       Raise_Program_Error_Msg (File, Line, Rmsg_30'Address);
    end Rcheck_PE_Unchecked_Union_Restriction;
 
+   procedure Rcheck_PE_Non_Transportable_Actual
+     (File : System.Address; Line : Integer)
+   is
+   begin
+      Raise_Program_Error_Msg (File, Line, Rmsg_31'Address);
+   end Rcheck_PE_Non_Transportable_Actual;
+
    procedure Rcheck_SE_Empty_Storage_Pool
      (File : System.Address; Line : Integer)
    is
@@ -1450,6 +1439,13 @@ package body Ada.Exceptions is
       Raise_Storage_Error_Msg (File, Line, Rmsg_35'Address);
    end Rcheck_SE_Object_Too_Large;
 
+   procedure Rcheck_PE_Stream_Operation_Not_Allowed
+     (File : System.Address; Line : Integer)
+   is
+   begin
+      Raise_Program_Error_Msg (File, Line, Rmsg_36'Address);
+   end Rcheck_PE_Stream_Operation_Not_Allowed;
+
    procedure Rcheck_PE_Finalize_Raised_Exception
      (File : System.Address; Line : Integer)
    is
diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb
index e9e1232..819abce 100644
--- a/gcc/ada/exp_ch11.adb
+++ b/gcc/ada/exp_ch11.adb
@@ -2068,10 +2068,10 @@ package body Exp_Ch11 is
 
    function Get_RT_Exception_Entity (R : RT_Exception_Code) return Entity_Id is
    begin
-      case R is
-         when RT_CE_Exceptions => return Standard_Constraint_Error;
-         when RT_PE_Exceptions => return Standard_Program_Error;
-         when RT_SE_Exceptions => return Standard_Storage_Error;
+      case Kind (R) is
+         when CE_Reason => return Standard_Constraint_Error;
+         when PE_Reason => return Standard_Program_Error;
+         when SE_Reason => return Standard_Storage_Error;
       end case;
    end Get_RT_Exception_Entity;
 
diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi
index 9b5e7d0..658cb1e 100644
--- a/gcc/ada/gnat_rm.texi
+++ b/gcc/ada/gnat_rm.texi
@@ -8246,19 +8246,22 @@ between values in different systems. The MKS system is characterized by the
 following aspect:
 
 @smallexample @c ada
-   type Mks_Type is new Long_Long_Float
-     with
-      Dimension_System => (
-        (Unit_Name => Meter,    Unit_Symbol => 'm',   Dim_Symbol => 'L'),
-        (Unit_Name => Kilogram, Unit_Symbol => "kg",  Dim_Symbol => 'M'),
-        (Unit_Name => Second,   Unit_Symbol => 's',   Dim_Symbol => 'T'),
-        (Unit_Name => Ampere,   Unit_Symbol => 'A',   Dim_Symbol => 'I'),
-        (Unit_Name => Kelvin,   Unit_Symbol => 'K',   Dim_Symbol => "Theta"),
-        (Unit_Name => Mole,     Unit_Symbol => "mol", Dim_Symbol => 'N'),
-        (Unit_Name => Candela,  Unit_Symbol => "cd",  Dim_Symbol => 'J'));
+   type Mks_Type is new Long_Long_Float with
+     Dimension_System => (
+       (Unit_Name => Meter,    Unit_Symbol => 'm',   Dim_Symbol => 'L'),
+       (Unit_Name => Kilogram, Unit_Symbol => "kg",  Dim_Symbol => 'M'),
+       (Unit_Name => Second,   Unit_Symbol => 's',   Dim_Symbol => 'T'),
+       (Unit_Name => Ampere,   Unit_Symbol => 'A',   Dim_Symbol => 'I'),
+       (Unit_Name => Kelvin,   Unit_Symbol => 'K',   Dim_Symbol => '@'),
+       (Unit_Name => Mole,     Unit_Symbol => "mol", Dim_Symbol => 'N'),
+       (Unit_Name => Candela,  Unit_Symbol => "cd",  Dim_Symbol => 'J'));
 @end smallexample
 
 @noindent
+Note that in the above type definition, we use the symbol @code{@@} to
+represent a theta character (avoiding the use of extended Latin-1
+characters in this context).
+
 See section ``Performing Dimensionality Analysis in GNAT'' in the GNAT Users
 Guide for detailed examples of use of the dimension system.
 
@@ -9325,13 +9328,13 @@ statically matching subtypes.
 @unnumberedsec Attribute Old
 @findex Old
 @noindent
-In addition to the usage of Old defined in the Ada 2012 RM (usage
+In addition to the usage of @code{Old} defined in the Ada 2012 RM (usage
 within @code{Post} aspect), GNAT also permits the use of this attribute
 in implementation defined pragmas @code{Postcondition},
-@code{Loop_Entry}, and @code{Contract_Cases}. Also usages of
+@code{Contract_Cases} and @code{Test_Case}. Also usages of
 @code{Old} which would be illegal according to the Ada 2012 RM
 definition are allowed under control of
-implementation defined pragma @code{Allow_Unevaluated_Use_Of_Old}.
+implementation defined pragma @code{Unevaluated_Use_Of_Old}.
 
 @node Attribute Passed_By_Reference
 @unnumberedsec Attribute Passed_By_Reference
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index 6d0301c..f35170f 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -2276,7 +2276,7 @@ package body Sem_Attr is
       --------------------
 
       procedure Uneval_Old_Msg is
-         Uneval_Old_Setting : Character := Opt.Uneval_Old;
+         Uneval_Old_Setting : Character;
          Prag               : Node_Id;
 
       begin
@@ -2293,18 +2293,20 @@ package body Sem_Attr is
             exit when No (Prag) or else Nkind (Prag) = N_Pragma;
          end loop;
 
-         --  If we did not find the pragma, that's odd, just consider it a
-         --  case where we use Opt.Uneval_Old for further processing. Perhaps
-         --  this can come from some previous error.
-
-         if Present (Prag) and then From_Aspect_Specification (Prag) then
-            if Uneval_Old_Accept (Corresponding_Aspect (Prag)) then
+         if Present (Prag) then
+            if Uneval_Old_Accept (Prag) then
                Uneval_Old_Setting := 'A';
-            elsif Uneval_Old_Warn (Corresponding_Aspect (Prag)) then
+            elsif Uneval_Old_Warn (Prag) then
                Uneval_Old_Setting := 'W';
             else
                Uneval_Old_Setting := 'E';
             end if;
+
+         --  If we did not find the pragma, that's odd, just use the setting
+         --  from Opt.Uneval_Old. Perhaps this is due to a previous error?
+
+         else
+            Uneval_Old_Setting := Opt.Uneval_Old;
          end if;
 
          --  Processing depends on the setting of Uneval_Old
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index 16ce674..6510372 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -1544,19 +1544,6 @@ package body Sem_Ch13 is
             Set_Entity (Aspect, E);
             Ent := New_Occurrence_Of (E, Sloc (Id));
 
-            --  Capture setting of Opt.Uneval_Old
-
-            case Opt.Uneval_Old is
-               when 'A' =>
-                  Set_Uneval_Old_Accept (Aspect);
-               when 'E' =>
-                  null;
-               when 'W' =>
-                  Set_Uneval_Old_Warn (Aspect);
-               when others =>
-                  raise Program_Error;
-            end case;
-
             --  Check for duplicate aspect. Note that the Comes_From_Source
             --  test allows duplicate Pre/Post's that we generate internally
             --  to escape being flagged here.
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 9f69c00..dee225b 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -10033,6 +10033,19 @@ package body Sem_Prag is
       Prag_Id := Get_Pragma_Id (Pname);
       Pname := Original_Aspect_Name (N);
 
+      --  Capture setting of Opt.Uneval_Old
+
+      case Opt.Uneval_Old is
+         when 'A' =>
+            Set_Uneval_Old_Accept (N);
+         when 'E' =>
+            null;
+         when 'W' =>
+            Set_Uneval_Old_Warn (N);
+         when others =>
+            raise Program_Error;
+      end case;
+
       --  Check applicable policy. We skip this if Is_Checked or Is_Ignored
       --  is already set, indicating that we have already checked the policy
       --  at the right point. This happens for example in the case of a pragma
diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb
index aca92b3..19ccec4 100644
--- a/gcc/ada/sinfo.adb
+++ b/gcc/ada/sinfo.adb
@@ -3168,15 +3168,15 @@ package body Sinfo is
      (N : Node_Id) return Boolean is
    begin
       pragma Assert (False
-        or else NT (N).Nkind = N_Aspect_Specification);
-      return Flag13 (N);
+        or else NT (N).Nkind = N_Pragma);
+      return Flag7 (N);
    end Uneval_Old_Accept;
 
    function Uneval_Old_Warn
      (N : Node_Id) return Boolean is
    begin
       pragma Assert (False
-        or else NT (N).Nkind = N_Aspect_Specification);
+        or else NT (N).Nkind = N_Pragma);
       return Flag18 (N);
    end Uneval_Old_Warn;
 
@@ -6367,15 +6367,15 @@ package body Sinfo is
      (N : Node_Id; Val : Boolean := True) is
    begin
       pragma Assert (False
-        or else NT (N).Nkind = N_Aspect_Specification);
-      Set_Flag13 (N, Val);
+        or else NT (N).Nkind = N_Pragma);
+      Set_Flag7 (N, Val);
    end Set_Uneval_Old_Accept;
 
    procedure Set_Uneval_Old_Warn
      (N : Node_Id; Val : Boolean := True) is
    begin
       pragma Assert (False
-        or else NT (N).Nkind = N_Aspect_Specification);
+        or else NT (N).Nkind = N_Pragma);
       Set_Flag18 (N, Val);
    end Set_Uneval_Old_Warn;
 
diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads
index dc1d1c5..41307a0 100644
--- a/gcc/ada/sinfo.ads
+++ b/gcc/ada/sinfo.ads
@@ -2098,20 +2098,19 @@ package Sinfo is
    --    if there are no type support subprograms for the type or if the freeze
    --    node is not for a type.
 
-   --  Uneval_Old_Accept (Flag13-Sem)
-   --    Present in N_Aspect_Specification nodes. Set if Opt.Uneval_Old is set
-   --    to 'A' (accept) at the point where the aspect specification node is
-   --    encountered. It is this setting that is relevant, rather than the
-   --    setting at the point where a contract is finally analyzed after the
-   --    usual delay till the freeze point.
+   --  Uneval_Old_Accept (Flag7-Sem)
+   --    Present in N_Pragma nodes. Set True if Opt.Uneval_Old is set to 'A'
+   --    (accept) at the point where the pragma is encountered (including the
+   --    case of a pragma generated from an aspect specification). It is this
+   --    setting that is relevant, rather than the setting at the point where
+   --    a contract is finally analyzed after the delay till the freeze point.
 
    --  Uneval_Old_Warn (Flag18-Sem)
-   --    Present in N_Aspect_Specification nodes. Set if Opt.Uneval_Old is set
-   --    to 'W' (warn) at the point where the aspect specification node is
-   --    encountered. It is this setting that is relevant, rather than the
-   --    setting at the point where a contract is finally analyzed after the
-   --    usual delay till the freeze point. If neither Uneval_Old_Accept nor
-   --    Uneval_Old_Warn is set, then the default Error mode applies.
+   --    Present in N_Pragma nodes. Set True if Opt.Uneval_Old is set to 'W'
+   --    (warn) at the point where the pragma is encountered (including the
+   --    case of a pragma generated from an aspect specification). It is this
+   --    setting that is relevant, rather than the setting at the point where
+   --    a contract is finally analyzed after the delay till the freeze point.
 
    --  Unreferenced_In_Spec (Flag7-Sem)
    --    Present in N_With_Clause nodes. Set if the with clause is on the
@@ -2405,6 +2404,8 @@ package Sinfo is
       --  Is_Checked (Flag11-Sem)
       --  Import_Interface_Present (Flag16-Sem)
       --  Split_PPC (Flag17) set if corresponding aspect had Split_PPC set
+      --  Uneval_Old_Accept (Flag7-Sem)
+      --  Uneval_Old_Warn (Flag18-Sem)
 
       --  Note: we should have a section on what pragmas are passed on to
       --  the back end to be processed. This section should note that pragma
@@ -7145,12 +7146,10 @@ package Sinfo is
       --  Class_Present (Flag6) Set if 'Class present
       --  Is_Ignored (Flag9-Sem)
       --  Is_Checked (Flag11-Sem)
-      --  Uneval_Old_Accept (Flag13-Sem)
       --  Is_Delayed_Aspect (Flag14-Sem)
       --  Is_Disabled (Flag15-Sem)
       --  Is_Boolean_Aspect (Flag16-Sem)
       --  Split_PPC (Flag17) Set if split pre/post attribute
-      --  Uneval_Old_Warn (Flag18-Sem)
 
       --  Note: Aspect_Specification is an Ada 2012 feature
 
@@ -9640,7 +9639,7 @@ package Sinfo is
      (N : Node_Id) return Node_Id;    -- Node3
 
    function Uneval_Old_Accept
-     (N : Node_Id) return Boolean;    -- Flag13
+     (N : Node_Id) return Boolean;    -- Flag7
 
    function Uneval_Old_Warn
      (N : Node_Id) return Boolean;    -- Flag18
@@ -10663,7 +10662,7 @@ package Sinfo is
      (N : Node_Id; Val : Node_Id);            -- Node3
 
    procedure Set_Uneval_Old_Accept
-     (N : Node_Id; Val : Boolean := True);    -- Flag13
+     (N : Node_Id; Val : Boolean := True);    -- Flag7
 
    procedure Set_Uneval_Old_Warn
      (N : Node_Id; Val : Boolean := True);    -- Flag18
diff --git a/gcc/ada/tbuild.adb b/gcc/ada/tbuild.adb
index 3378dc7..6b3a18d 100644
--- a/gcc/ada/tbuild.adb
+++ b/gcc/ada/tbuild.adb
@@ -434,7 +434,7 @@ package body Tbuild is
       Reason    : RT_Exception_Code) return Node_Id
    is
    begin
-      pragma Assert (Reason in RT_CE_Exceptions);
+      pragma Assert (Kind (Reason) = CE_Reason);
       return
         Make_Raise_Constraint_Error (Sloc,
           Condition => Condition,
@@ -451,7 +451,7 @@ package body Tbuild is
       Reason    : RT_Exception_Code) return Node_Id
    is
    begin
-      pragma Assert (Reason in RT_PE_Exceptions);
+      pragma Assert (Kind (Reason) = PE_Reason);
       return
         Make_Raise_Program_Error (Sloc,
           Condition => Condition,
@@ -468,7 +468,7 @@ package body Tbuild is
       Reason    : RT_Exception_Code) return Node_Id
    is
    begin
-      pragma Assert (Reason in RT_SE_Exceptions);
+      pragma Assert (Kind (Reason) = SE_Reason);
       return
         Make_Raise_Storage_Error (Sloc,
           Condition => Condition,
diff --git a/gcc/ada/types.ads b/gcc/ada/types.ads
index a8d2f5b..c228740 100644
--- a/gcc/ada/types.ads
+++ b/gcc/ada/types.ads
@@ -820,12 +820,12 @@ package Types is
 
    --  To add a new code, you need to do the following:
 
-   --    1. Modify the type and subtype declarations below appropriately,
-   --       keeping things in alphabetical order.
+   --    1. Assign a new number to the reason. Do not renumber existing codes,
+   --       since this causes compatibility/bootstrap issues, and problems in
+   --       the CIL/JVM backends. So always add the new code at the end of the
+   --       list.
 
-   --    2. Assign a new number to the reason. Do not renumber existing codes,
-   --       this causes compatibility/bootstrap issues. So always add the new
-   --       code at the end of the existing range.
+   --    2. Update the contents of the array Kind
 
    --    3. Modify the corresponding definitions in types.h, including the
    --       definition of last_reason_code.
@@ -873,31 +873,63 @@ package Types is
       PE_Implicit_Return,                -- 24
       PE_Misaligned_Address_Value,       -- 25
       PE_Missing_Return,                 -- 26
-      PE_Non_Transportable_Actual,       -- 31
       PE_Overlaid_Controlled_Object,     -- 27
       PE_Potentially_Blocking_Operation, -- 28
-      PE_Stream_Operation_Not_Allowed,   -- 36
       PE_Stubbed_Subprogram_Called,      -- 29
       PE_Unchecked_Union_Restriction,    -- 30
+      PE_Non_Transportable_Actual,       -- 31
 
       SE_Empty_Storage_Pool,             -- 32
       SE_Explicit_Raise,                 -- 33
       SE_Infinite_Recursion,             -- 34
-      SE_Object_Too_Large);              -- 35
+      SE_Object_Too_Large,               -- 35
+
+      PE_Stream_Operation_Not_Allowed);  -- 36
 
    Last_Reason_Code : constant := 36;
    --  Last reason code
 
-   subtype RT_CE_Exceptions is RT_Exception_Code range
-     CE_Access_Check_Failed ..
-     CE_Tag_Check_Failed;
-
-   subtype RT_PE_Exceptions is RT_Exception_Code range
-     PE_Access_Before_Elaboration ..
-     PE_Unchecked_Union_Restriction;
-
-   subtype RT_SE_Exceptions is RT_Exception_Code range
-     SE_Empty_Storage_Pool ..
-     SE_Object_Too_Large;
+   type Reason_Kind is (CE_Reason, PE_Reason, SE_Reason);
+
+   Kind : array (RT_Exception_Code range <>) of Reason_Kind :=
+     (CE_Access_Check_Failed            => CE_Reason,
+      CE_Access_Parameter_Is_Null       => CE_Reason,
+      CE_Discriminant_Check_Failed      => CE_Reason,
+      CE_Divide_By_Zero                 => CE_Reason,
+      CE_Explicit_Raise                 => CE_Reason,
+      CE_Index_Check_Failed             => CE_Reason,
+      CE_Invalid_Data                   => CE_Reason,
+      CE_Length_Check_Failed            => CE_Reason,
+      CE_Null_Exception_Id              => CE_Reason,
+      CE_Null_Not_Allowed               => CE_Reason,
+      CE_Overflow_Check_Failed          => CE_Reason,
+      CE_Partition_Check_Failed         => CE_Reason,
+      CE_Range_Check_Failed             => CE_Reason,
+      CE_Tag_Check_Failed               => CE_Reason,
+
+      PE_Access_Before_Elaboration      => PE_Reason,
+      PE_Accessibility_Check_Failed     => PE_Reason,
+      PE_Address_Of_Intrinsic           => PE_Reason,
+      PE_Aliased_Parameters             => PE_Reason,
+      PE_All_Guards_Closed              => PE_Reason,
+      PE_Bad_Predicated_Generic_Type    => PE_Reason,
+      PE_Current_Task_In_Entry_Body     => PE_Reason,
+      PE_Duplicated_Entry_Address       => PE_Reason,
+      PE_Explicit_Raise                 => PE_Reason,
+      PE_Finalize_Raised_Exception      => PE_Reason,
+      PE_Implicit_Return                => PE_Reason,
+      PE_Misaligned_Address_Value       => PE_Reason,
+      PE_Missing_Return                 => PE_Reason,
+      PE_Overlaid_Controlled_Object     => PE_Reason,
+      PE_Potentially_Blocking_Operation => PE_Reason,
+      PE_Stubbed_Subprogram_Called      => PE_Reason,
+      PE_Unchecked_Union_Restriction    => PE_Reason,
+      PE_Non_Transportable_Actual       => PE_Reason,
+      PE_Stream_Operation_Not_Allowed   => PE_Reason,
+
+      SE_Empty_Storage_Pool             => SE_Reason,
+      SE_Explicit_Raise                 => SE_Reason,
+      SE_Infinite_Recursion             => SE_Reason,
+      SE_Object_Too_Large               => SE_Reason);
 
 end Types;