[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:
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>
|
2019-08-19 Pierre-Marie de Rodat <derodat@adacore.com>
|
||||||
|
|
||||||
* libgnat/a-cgaaso.ads, libgnat/a-cgarso.ads,
|
* 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.
|
-- See separate sections below for the generated code in each case.
|
||||||
|
|
||||||
when Attribute_Valid => Valid : declare
|
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_Validity_Checks_On : constant Boolean := Validity_Checks_On;
|
||||||
-- Save the validity checking mode. We always turn off validity
|
-- 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;
|
function Make_Range_Test return Node_Id;
|
||||||
-- Build the code for a range test of the form
|
-- 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 --
|
-- Make_Range_Test --
|
||||||
|
@ -6594,16 +6594,16 @@ package body Exp_Attr is
|
||||||
|
|
||||||
return
|
return
|
||||||
Make_In (Loc,
|
Make_In (Loc,
|
||||||
Left_Opnd => Unchecked_Convert_To (Btyp, Temp),
|
Left_Opnd => Unchecked_Convert_To (PBtyp, Temp),
|
||||||
Right_Opnd =>
|
Right_Opnd =>
|
||||||
Make_Range (Loc,
|
Make_Range (Loc,
|
||||||
Low_Bound =>
|
Low_Bound =>
|
||||||
Unchecked_Convert_To (Btyp,
|
Unchecked_Convert_To (PBtyp,
|
||||||
Make_Attribute_Reference (Loc,
|
Make_Attribute_Reference (Loc,
|
||||||
Prefix => New_Occurrence_Of (Ptyp, Loc),
|
Prefix => New_Occurrence_Of (Ptyp, Loc),
|
||||||
Attribute_Name => Name_First)),
|
Attribute_Name => Name_First)),
|
||||||
High_Bound =>
|
High_Bound =>
|
||||||
Unchecked_Convert_To (Btyp,
|
Unchecked_Convert_To (PBtyp,
|
||||||
Make_Attribute_Reference (Loc,
|
Make_Attribute_Reference (Loc,
|
||||||
Prefix => New_Occurrence_Of (Ptyp, Loc),
|
Prefix => New_Occurrence_Of (Ptyp, Loc),
|
||||||
Attribute_Name => Name_Last))));
|
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
|
-- Retrieve the base type. Handle the case where the base type is a
|
||||||
-- private enumeration type.
|
-- private enumeration type.
|
||||||
|
|
||||||
if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then
|
if Is_Private_Type (PBtyp) and then Present (Full_View (PBtyp)) then
|
||||||
Btyp := Full_View (Btyp);
|
PBtyp := Full_View (PBtyp);
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
-- Floating-point case. This case is handled by the Valid attribute
|
-- Floating-point case. This case is handled by the Valid attribute
|
||||||
|
@ -6665,7 +6665,7 @@ package body Exp_Attr is
|
||||||
begin
|
begin
|
||||||
-- The C and AAMP back-ends handle Valid for fpt types
|
-- 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);
|
Analyze_And_Resolve (Pref, Ptyp);
|
||||||
Set_Etype (N, Standard_Boolean);
|
Set_Etype (N, Standard_Boolean);
|
||||||
Set_Analyzed (N);
|
Set_Analyzed (N);
|
||||||
|
@ -6758,13 +6758,13 @@ package body Exp_Attr is
|
||||||
-- The way we do the range check is simply to create the
|
-- The way we do the range check is simply to create the
|
||||||
-- expression: Valid (N) and then Base_Type(Pref) in Typ.
|
-- 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,
|
Rewrite (N,
|
||||||
Make_And_Then (Loc,
|
Make_And_Then (Loc,
|
||||||
Left_Opnd => Relocate_Node (N),
|
Left_Opnd => Relocate_Node (N),
|
||||||
Right_Opnd =>
|
Right_Opnd =>
|
||||||
Make_In (Loc,
|
Make_In (Loc,
|
||||||
Left_Opnd => Convert_To (Btyp, Pref),
|
Left_Opnd => Convert_To (PBtyp, Pref),
|
||||||
Right_Opnd => New_Occurrence_Of (Ptyp, Loc))));
|
Right_Opnd => New_Occurrence_Of (Ptyp, Loc))));
|
||||||
end if;
|
end if;
|
||||||
end Float_Valid;
|
end Float_Valid;
|
||||||
|
@ -6793,24 +6793,24 @@ package body Exp_Attr is
|
||||||
-- (X >= type(X)'First and then type(X)'Last <= X)
|
-- (X >= type(X)'First and then type(X)'Last <= X)
|
||||||
|
|
||||||
elsif Is_Enumeration_Type (Ptyp)
|
elsif Is_Enumeration_Type (Ptyp)
|
||||||
and then Present (Enum_Pos_To_Rep (Btyp))
|
and then Present (Enum_Pos_To_Rep (PBtyp))
|
||||||
then
|
then
|
||||||
Tst :=
|
Tst :=
|
||||||
Make_Op_Ge (Loc,
|
Make_Op_Ge (Loc,
|
||||||
Left_Opnd =>
|
Left_Opnd =>
|
||||||
Make_Function_Call (Loc,
|
Make_Function_Call (Loc,
|
||||||
Name =>
|
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 (
|
Parameter_Associations => New_List (
|
||||||
Pref,
|
Pref,
|
||||||
New_Occurrence_Of (Standard_False, Loc))),
|
New_Occurrence_Of (Standard_False, Loc))),
|
||||||
Right_Opnd => Make_Integer_Literal (Loc, 0));
|
Right_Opnd => Make_Integer_Literal (Loc, 0));
|
||||||
|
|
||||||
if Ptyp /= Btyp
|
if Ptyp /= PBtyp
|
||||||
and then
|
and then
|
||||||
(Type_Low_Bound (Ptyp) /= Type_Low_Bound (Btyp)
|
(Type_Low_Bound (Ptyp) /= Type_Low_Bound (PBtyp)
|
||||||
or else
|
or else
|
||||||
Type_High_Bound (Ptyp) /= Type_High_Bound (Btyp))
|
Type_High_Bound (Ptyp) /= Type_High_Bound (PBtyp))
|
||||||
then
|
then
|
||||||
-- The call to Make_Range_Test will create declarations
|
-- The call to Make_Range_Test will create declarations
|
||||||
-- that need a proper insertion point, but Pref is now
|
-- 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 has to take this into account, and the proper form of the
|
||||||
-- test is:
|
-- test is:
|
||||||
|
|
||||||
-- Btyp!(Pref) < Btyp!(Ptyp'Range_Length)
|
-- PBtyp!(Pref) < PBtyp!(Ptyp'Range_Length)
|
||||||
|
|
||||||
elsif Has_Biased_Representation (Ptyp) then
|
elsif Has_Biased_Representation (Ptyp) then
|
||||||
Btyp := RTE (RE_Unsigned_32);
|
PBtyp := RTE (RE_Unsigned_32);
|
||||||
Rewrite (N,
|
Rewrite (N,
|
||||||
Make_Op_Lt (Loc,
|
Make_Op_Lt (Loc,
|
||||||
Left_Opnd =>
|
Left_Opnd =>
|
||||||
Unchecked_Convert_To (Btyp, Duplicate_Subexpr (Pref)),
|
Unchecked_Convert_To (PBtyp, Duplicate_Subexpr (Pref)),
|
||||||
Right_Opnd =>
|
Right_Opnd =>
|
||||||
Unchecked_Convert_To (Btyp,
|
Unchecked_Convert_To (PBtyp,
|
||||||
Make_Attribute_Reference (Loc,
|
Make_Attribute_Reference (Loc,
|
||||||
Prefix => New_Occurrence_Of (Ptyp, Loc),
|
Prefix => New_Occurrence_Of (Ptyp, Loc),
|
||||||
Attribute_Name => Name_Range_Length))));
|
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).
|
-- the Valid attribute is exactly that this test does not work).
|
||||||
-- What will work is:
|
-- What will work is:
|
||||||
|
|
||||||
-- Btyp!(X) >= Btyp!(type(X)'First)
|
-- PBtyp!(X) >= PBtyp!(type(X)'First)
|
||||||
-- and then
|
-- 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
|
-- 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
|
-- 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
|
-- 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
|
-- correct, even though a value greater than 127 looks signed to a
|
||||||
-- signed comparison.
|
-- 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
|
if Esize (Ptyp) <= 32 then
|
||||||
Btyp := RTE (RE_Unsigned_32);
|
PBtyp := RTE (RE_Unsigned_32);
|
||||||
else
|
else
|
||||||
Btyp := RTE (RE_Unsigned_64);
|
PBtyp := RTE (RE_Unsigned_64);
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
Rewrite (N, Make_Range_Test);
|
Rewrite (N, Make_Range_Test);
|
||||||
|
@ -6908,9 +6910,9 @@ package body Exp_Attr is
|
||||||
|
|
||||||
else
|
else
|
||||||
if Esize (Ptyp) <= Esize (Standard_Integer) then
|
if Esize (Ptyp) <= Esize (Standard_Integer) then
|
||||||
Btyp := Standard_Integer;
|
PBtyp := Standard_Integer;
|
||||||
else
|
else
|
||||||
Btyp := Universal_Integer;
|
PBtyp := Universal_Integer;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
Rewrite (N, Make_Range_Test);
|
Rewrite (N, Make_Range_Test);
|
||||||
|
|
|
@ -1624,6 +1624,7 @@ package body Ada.Exceptions is
|
||||||
Target.Machine_Occurrence := System.Null_Address;
|
Target.Machine_Occurrence := System.Null_Address;
|
||||||
Target.Msg_Length := Source.Msg_Length;
|
Target.Msg_Length := Source.Msg_Length;
|
||||||
Target.Num_Tracebacks := Source.Num_Tracebacks;
|
Target.Num_Tracebacks := Source.Num_Tracebacks;
|
||||||
|
Target.Exception_Raised := Source.Exception_Raised;
|
||||||
Target.Pid := Source.Pid;
|
Target.Pid := Source.Pid;
|
||||||
|
|
||||||
Target.Msg (1 .. Target.Msg_Length) :=
|
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>
|
2019-08-19 Eric Botcazou <ebotcazou@adacore.com>
|
||||||
|
|
||||||
* gnat.dg/generic_inst12.adb, gnat.dg/generic_inst12_pkg1.adb,
|
* 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