[Ada] Incorrect code for -gnateV switch

This patch corrects the code generated by the -gnateV switch in the case
of a private type whose full type is a modular type, removing spurious
run-time failures.

In addition, this corrects the initialization of exception occurrences
in exception handlers to avoid leaving data uninitialized, which caused
-gnateV to raise spurious errors.

2019-08-19  Bob Duff  <duff@adacore.com>

gcc/ada/

	* exp_attr.adb (Attribute_Valid): Correct the handling of
	private types where the full type is modular. System.Address is
	an example. Otherwise, we convert uncheckedly to a signed type,
	so we get an incorrect range 0 .. -1, for which all values will
	fail.  The 'Valid attribute is illegal for such types, but we
	generate such illegal attribute_references for 'Valid_Scalars,
	and we generate 'Valid_Scalars when the -gnateV switch is used.
	Rename Btyp --> PBtyp to avoid hiding the outer Btyp, which was
	confusing.
	* libgnat/a-except.adb: Set the Exception_Raised component.
	Otherwise, we have incorrect reads of invalid data.

gcc/testsuite/

	* gnat.dg/valid_scalars2.adb: New testcase.

From-SVN: r274660

5 files changed, 73 insertions, 27 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 561e091..499a489 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,17 @@
+2019-08-19  Bob Duff  <duff@adacore.com>
+
+	* exp_attr.adb (Attribute_Valid): Correct the handling of
+	private types where the full type is modular. System.Address is
+	an example. Otherwise, we convert uncheckedly to a signed type,
+	so we get an incorrect range 0 .. -1, for which all values will
+	fail.  The 'Valid attribute is illegal for such types, but we
+	generate such illegal attribute_references for 'Valid_Scalars,
+	and we generate 'Valid_Scalars when the -gnateV switch is used.
+	Rename Btyp --> PBtyp to avoid hiding the outer Btyp, which was
+	confusing.
+	* libgnat/a-except.adb: Set the Exception_Raised component.
+	Otherwise, we have incorrect reads of invalid data.
+
 2019-08-19  Pierre-Marie de Rodat  <derodat@adacore.com>
 
 	* libgnat/a-cgaaso.ads, libgnat/a-cgarso.ads,
diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index d90dc29..306c1b5 100644
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -6545,7 +6545,7 @@ package body Exp_Attr is
       --  See separate sections below for the generated code in each case.
 
       when Attribute_Valid => Valid : declare
-         Btyp : Entity_Id := Base_Type (Ptyp);
+         PBtyp : Entity_Id := Base_Type (Ptyp);
 
          Save_Validity_Checks_On : constant Boolean := Validity_Checks_On;
          --  Save the validity checking mode. We always turn off validity
@@ -6555,7 +6555,7 @@ package body Exp_Attr is
 
          function Make_Range_Test return Node_Id;
          --  Build the code for a range test of the form
-         --    Btyp!(Pref) in Btyp!(Ptyp'First) .. Btyp!(Ptyp'Last)
+         --    PBtyp!(Pref) in PBtyp!(Ptyp'First) .. PBtyp!(Ptyp'Last)
 
          ---------------------
          -- Make_Range_Test --
@@ -6594,16 +6594,16 @@ package body Exp_Attr is
 
             return
               Make_In (Loc,
-                Left_Opnd  => Unchecked_Convert_To (Btyp, Temp),
+                Left_Opnd  => Unchecked_Convert_To (PBtyp, Temp),
                 Right_Opnd =>
                   Make_Range (Loc,
                     Low_Bound  =>
-                      Unchecked_Convert_To (Btyp,
+                      Unchecked_Convert_To (PBtyp,
                         Make_Attribute_Reference (Loc,
                           Prefix         => New_Occurrence_Of (Ptyp, Loc),
                           Attribute_Name => Name_First)),
                     High_Bound =>
-                      Unchecked_Convert_To (Btyp,
+                      Unchecked_Convert_To (PBtyp,
                         Make_Attribute_Reference (Loc,
                           Prefix         => New_Occurrence_Of (Ptyp, Loc),
                           Attribute_Name => Name_Last))));
@@ -6631,8 +6631,8 @@ package body Exp_Attr is
          --  Retrieve the base type. Handle the case where the base type is a
          --  private enumeration type.
 
-         if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then
-            Btyp := Full_View (Btyp);
+         if Is_Private_Type (PBtyp) and then Present (Full_View (PBtyp)) then
+            PBtyp := Full_View (PBtyp);
          end if;
 
          --  Floating-point case. This case is handled by the Valid attribute
@@ -6665,7 +6665,7 @@ package body Exp_Attr is
             begin
                --  The C and AAMP back-ends handle Valid for fpt types
 
-               if Modify_Tree_For_C or else Float_Rep (Btyp) = AAMP then
+               if Modify_Tree_For_C or else Float_Rep (PBtyp) = AAMP then
                   Analyze_And_Resolve (Pref, Ptyp);
                   Set_Etype (N, Standard_Boolean);
                   Set_Analyzed (N);
@@ -6758,13 +6758,13 @@ package body Exp_Attr is
                --  The way we do the range check is simply to create the
                --  expression: Valid (N) and then Base_Type(Pref) in Typ.
 
-               if not Subtypes_Statically_Match (Ptyp, Btyp) then
+               if not Subtypes_Statically_Match (Ptyp, PBtyp) then
                   Rewrite (N,
                     Make_And_Then (Loc,
                       Left_Opnd  => Relocate_Node (N),
                       Right_Opnd =>
                         Make_In (Loc,
-                          Left_Opnd  => Convert_To (Btyp, Pref),
+                          Left_Opnd  => Convert_To (PBtyp, Pref),
                           Right_Opnd => New_Occurrence_Of (Ptyp, Loc))));
                end if;
             end Float_Valid;
@@ -6793,24 +6793,24 @@ package body Exp_Attr is
          --       (X >= type(X)'First and then type(X)'Last <= X)
 
          elsif Is_Enumeration_Type (Ptyp)
-           and then Present (Enum_Pos_To_Rep (Btyp))
+           and then Present (Enum_Pos_To_Rep (PBtyp))
          then
             Tst :=
               Make_Op_Ge (Loc,
                 Left_Opnd =>
                   Make_Function_Call (Loc,
                     Name =>
-                      New_Occurrence_Of (TSS (Btyp, TSS_Rep_To_Pos), Loc),
+                      New_Occurrence_Of (TSS (PBtyp, TSS_Rep_To_Pos), Loc),
                     Parameter_Associations => New_List (
                       Pref,
                       New_Occurrence_Of (Standard_False, Loc))),
                 Right_Opnd => Make_Integer_Literal (Loc, 0));
 
-            if Ptyp /= Btyp
+            if Ptyp /= PBtyp
               and then
-                (Type_Low_Bound (Ptyp) /= Type_Low_Bound (Btyp)
+                (Type_Low_Bound (Ptyp) /= Type_Low_Bound (PBtyp)
                   or else
-                 Type_High_Bound (Ptyp) /= Type_High_Bound (Btyp))
+                 Type_High_Bound (Ptyp) /= Type_High_Bound (PBtyp))
             then
                --  The call to Make_Range_Test will create declarations
                --  that need a proper insertion point, but Pref is now
@@ -6843,16 +6843,16 @@ package body Exp_Attr is
          --  test has to take this into account, and the proper form of the
          --  test is:
 
-         --    Btyp!(Pref) < Btyp!(Ptyp'Range_Length)
+         --    PBtyp!(Pref) < PBtyp!(Ptyp'Range_Length)
 
          elsif Has_Biased_Representation (Ptyp) then
-            Btyp := RTE (RE_Unsigned_32);
+            PBtyp := RTE (RE_Unsigned_32);
             Rewrite (N,
               Make_Op_Lt (Loc,
                 Left_Opnd =>
-                  Unchecked_Convert_To (Btyp, Duplicate_Subexpr (Pref)),
+                  Unchecked_Convert_To (PBtyp, Duplicate_Subexpr (Pref)),
                 Right_Opnd =>
-                  Unchecked_Convert_To (Btyp,
+                  Unchecked_Convert_To (PBtyp,
                     Make_Attribute_Reference (Loc,
                       Prefix => New_Occurrence_Of (Ptyp, Loc),
                       Attribute_Name => Name_Range_Length))));
@@ -6867,11 +6867,11 @@ package body Exp_Attr is
          --  the Valid attribute is exactly that this test does not work).
          --  What will work is:
 
-         --     Btyp!(X) >= Btyp!(type(X)'First)
+         --     PBtyp!(X) >= PBtyp!(type(X)'First)
          --       and then
-         --     Btyp!(X) <= Btyp!(type(X)'Last)
+         --     PBtyp!(X) <= PBtyp!(type(X)'Last)
 
-         --  where Btyp is an integer type large enough to cover the full
+         --  where PBtyp is an integer type large enough to cover the full
          --  range of possible stored values (i.e. it is chosen on the basis
          --  of the size of the type, not the range of the values). We write
          --  this as two tests, rather than a range check, so that static
@@ -6895,11 +6895,13 @@ package body Exp_Attr is
          --  correct, even though a value greater than 127 looks signed to a
          --  signed comparison.
 
-         elsif Is_Unsigned_Type (Ptyp) then
+         elsif Is_Unsigned_Type (Ptyp)
+           or else (Is_Private_Type (Ptyp) and then Is_Unsigned_Type (Btyp))
+         then
             if Esize (Ptyp) <= 32 then
-               Btyp := RTE (RE_Unsigned_32);
+               PBtyp := RTE (RE_Unsigned_32);
             else
-               Btyp := RTE (RE_Unsigned_64);
+               PBtyp := RTE (RE_Unsigned_64);
             end if;
 
             Rewrite (N, Make_Range_Test);
@@ -6908,9 +6910,9 @@ package body Exp_Attr is
 
          else
             if Esize (Ptyp) <= Esize (Standard_Integer) then
-               Btyp := Standard_Integer;
+               PBtyp := Standard_Integer;
             else
-               Btyp := Universal_Integer;
+               PBtyp := Universal_Integer;
             end if;
 
             Rewrite (N, Make_Range_Test);
diff --git a/gcc/ada/libgnat/a-except.adb b/gcc/ada/libgnat/a-except.adb
index ebb76a7..8b0a31c 100644
--- a/gcc/ada/libgnat/a-except.adb
+++ b/gcc/ada/libgnat/a-except.adb
@@ -1624,6 +1624,7 @@ package body Ada.Exceptions is
       Target.Machine_Occurrence := System.Null_Address;
       Target.Msg_Length         := Source.Msg_Length;
       Target.Num_Tracebacks     := Source.Num_Tracebacks;
+      Target.Exception_Raised   := Source.Exception_Raised;
       Target.Pid                := Source.Pid;
 
       Target.Msg (1 .. Target.Msg_Length) :=
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 0f246bf..127a223 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+2019-08-19  Bob Duff  <duff@adacore.com>
+
+	* gnat.dg/valid_scalars2.adb: New testcase.
+
 2019-08-19  Eric Botcazou  <ebotcazou@adacore.com>
 
 	* gnat.dg/generic_inst12.adb, gnat.dg/generic_inst12_pkg1.adb,
diff --git a/gcc/testsuite/gnat.dg/valid_scalars2.adb b/gcc/testsuite/gnat.dg/valid_scalars2.adb
new file mode 100644
index 0000000..949cb83
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/valid_scalars2.adb
@@ -0,0 +1,25 @@
+--  { dg-do run }
+--  { dg-options "-O0 -gnata -gnateV" }
+
+with Ada.Exceptions; use Ada.Exceptions;
+
+procedure Valid_Scalars2 is
+
+   Traced : Boolean := False;
+
+   procedure Trace (E : in Exception_Occurrence) is
+      pragma Assert (E'Valid_scalars);
+   begin
+      Traced := True;
+   end Trace;
+
+begin
+   raise Program_Error;
+exception
+   when E : others =>
+      pragma Assert (E'Valid_scalars);
+      Trace (E);
+      if not Traced then
+         raise Program_Error;
+      end if;
+end Valid_Scalars2;