OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[Ada] Incorrect code for -gnateV switch

Browse Source 
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 2019-08-19 08:37:09 +00:00 committed by Pierre-Marie de Rodat
parent 27ebda1930
commit 382b0e9771
5 changed files with 73 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
gcc/ada/ChangeLog
View File

@ -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,

56
gcc/ada/exp_attr.adb
View File

@ -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);

1
gcc/ada/libgnat/a-except.adb
View File

@ -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) :=

4
gcc/testsuite/ChangeLog
View File

@ -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,

25
gcc/testsuite/gnat.dg/valid_scalars2.adb Normal file
View File

@ -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;