From 382b0e9771d77d482f6765454ec884936b62b15b Mon Sep 17 00:00:00 2001 From: Bob Duff Date: Mon, 19 Aug 2019 08:37:09 +0000 Subject: [PATCH] [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 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 --- gcc/ada/ChangeLog | 14 ++++++ gcc/ada/exp_attr.adb | 56 ++++++++++++------------ gcc/ada/libgnat/a-except.adb | 1 + gcc/testsuite/ChangeLog | 4 ++ gcc/testsuite/gnat.dg/valid_scalars2.adb | 25 +++++++++++ 5 files changed, 73 insertions(+), 27 deletions(-) create mode 100644 gcc/testsuite/gnat.dg/valid_scalars2.adb diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 561e091f8f5..499a4896b90 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,17 @@ +2019-08-19 Bob Duff + + * 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 * libgnat/a-cgaaso.ads, libgnat/a-cgarso.ads, diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index d90dc29171f..306c1b56404 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 ebb76a72d8c..8b0a31c27f8 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 0f246bf7bd1..127a223f238 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2019-08-19 Bob Duff + + * gnat.dg/valid_scalars2.adb: New testcase. + 2019-08-19 Eric Botcazou * 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 00000000000..949cb836cae --- /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; -- 2.30.2