[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
This commit is contained in:
Bob Duff
Pierre-Marie de Rodat
parent
27ebda1930
commit
382b0e9771
|
|
@ -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,
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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) :=
|
||||
|
|
|
|||
|
|
@ -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,
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
Loading…
Reference in New Issue