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

[Ada] Implement AI12-0086's rules for discriminants in aggregates 

In Ada2012, a discriminant value that governs an active variant part in
an aggregate had to be static. AI12-0086 relaxes this restriction - if
the subtype of the discriminant value is a static subtype all of whose
values select the same variant, then that is good enough.

2019-09-18  Steve Baird  <baird@adacore.com>

gcc/ada/

	* sem_util.ads (Interval_Lists): A new visible package. This
	package is visible because it is also intended for eventual use
	in Sem_Eval.Subtypes_Statically_Compatible when that function is
	someday upgraded to handle static predicates correctly.  This
	new package doesn't really need to be visible for now, but it
	still seems like a good idea.
	* sem_util.adb (Gather_Components): Implement AI12-0086 via the
	following strategy. The existing code knows how to take a static
	discriminant value and identify the corresponding variant; in
	the newly-permitted case of a non-static value of a static
	subtype, we arbitrarily select a value of the subtype and find
	the corresponding variant using the existing code. Subsequently,
	we check that every other value of the discriminant's subtype
	corresponds to the same variant; this is done using the newly
	introduced Interval_Lists package.
	(Interval_Lists): Provide a body for the new package.

gcc/testsuite/

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

From-SVN: r275857
This commit is contained in:
Steve Baird 2019-09-18 08:33:02 +00:00 committed by Pierre-Marie de Rodat
parent 6bc08721d0
commit c8324fe7b1
5 changed files with 571 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
gcc/ada/ChangeLog
View File

@ -1,3 +1,22 @@
2019-09-18 Steve Baird <baird@adacore.com>
* sem_util.ads (Interval_Lists): A new visible package. This
package is visible because it is also intended for eventual use
in Sem_Eval.Subtypes_Statically_Compatible when that function is
someday upgraded to handle static predicates correctly. This
new package doesn't really need to be visible for now, but it
still seems like a good idea.
* sem_util.adb (Gather_Components): Implement AI12-0086 via the
following strategy. The existing code knows how to take a static
discriminant value and identify the corresponding variant; in
the newly-permitted case of a non-static value of a static
subtype, we arbitrarily select a value of the subtype and find
the corresponding variant using the existing code. Subsequently,
we check that every other value of the discriminant's subtype
corresponds to the same variant; this is done using the newly
introduced Interval_Lists package.
(Interval_Lists): Provide a body for the new package.
2019-09-18 Javier Miranda <miranda@adacore.com>
* exp_ch4.adb (Expand_N_Op_Eq): The frontend assumes that we can

509
gcc/ada/sem_util.adb
View File

@ -68,6 +68,7 @@ with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
with Uname; use Uname;
with GNAT.Heap_Sort_G;
with GNAT.HTable; use GNAT.HTable;
package body Sem_Util is
@ -8885,11 +8886,17 @@ package body Sem_Util is
Variant : Node_Id;
Discrete_Choice : Node_Id;
Comp_Item : Node_Id;
Discrim : Entity_Id;
Discrim_Name : Node_Id;
Discrim : Entity_Id;
Discrim_Name : Node_Id;
Discrim_Value : Node_Id;
type Discriminant_Value_Status is
(Static_Expr, Static_Subtype, Bad);
subtype Good_Discrim_Value_Status is Discriminant_Value_Status
range Static_Expr .. Static_Subtype; -- range excludes Bad
Discrim_Value : Node_Id;
Discrim_Value_Subtype : Node_Id;
Discrim_Value_Status : Discriminant_Value_Status := Bad;
begin
Report_Errors := False;
@ -9022,26 +9029,73 @@ package body Sem_Util is
end loop Find_Constraint;
Discrim_Value := Expression (Assoc);
if Is_OK_Static_Expression (Discrim_Value) then
Discrim_Value_Status := Static_Expr;
else
if Ada_Version >= Ada_2020 then
if Original_Node (Discrim_Value) /= Discrim_Value
and then Nkind (Discrim_Value) = N_Type_Conversion
and then Etype (Original_Node (Discrim_Value))
= Etype (Expression (Discrim_Value))
then
Discrim_Value_Subtype := Etype (Original_Node (Discrim_Value));
-- An unhelpful (for this code) type conversion may be
-- introduced in some cases; deal with it.
else
Discrim_Value_Subtype := Etype (Discrim_Value);
end if;
if not Is_OK_Static_Expression (Discrim_Value) then
if Is_OK_Static_Subtype (Discrim_Value_Subtype) and then
not Is_Null_Range (Type_Low_Bound (Discrim_Value_Subtype),
Type_High_Bound (Discrim_Value_Subtype))
then
-- Is_Null_Range test doesn't account for predicates, as in
-- subtype Null_By_Predicate is Natural
-- with Static_Predicate => Null_By_Predicate < 0;
-- so test for that null case separately.
-- If the variant part is governed by a discriminant of the type
-- this is an error. If the variant part and the discriminant are
-- inherited from an ancestor this is legal (AI05-120) unless the
-- components are being gathered for an aggregate, in which case
-- the caller must check Report_Errors.
if Scope (Original_Record_Component
((Entity (First (Choices (Assoc)))))) = Typ
then
Error_Msg_FE
("value for discriminant & must be static!",
Discrim_Value, Discrim);
Why_Not_Static (Discrim_Value);
if (not Has_Static_Predicate (Discrim_Value_Subtype))
or else Present (First (Static_Discrete_Predicate
(Discrim_Value_Subtype)))
then
Discrim_Value_Status := Static_Subtype;
end if;
end if;
end if;
Report_Errors := True;
return;
if Discrim_Value_Status = Bad then
-- If the variant part is governed by a discriminant of the type
-- this is an error. If the variant part and the discriminant are
-- inherited from an ancestor this is legal (AI05-220) unless the
-- components are being gathered for an aggregate, in which case
-- the caller must check Report_Errors.
--
-- In Ada2020 the above rules are relaxed. A non-static governing
-- discriminant is ok as long as it has a static subtype and
-- every value of that subtype (and there must be at least one)
-- selects the same variant.
if Scope (Original_Record_Component
((Entity (First (Choices (Assoc)))))) = Typ
then
if Ada_Version >= Ada_2020 then
Error_Msg_FE
("value for discriminant & must be static or " &
"discriminant's nominal subtype must be static " &
"and non-null!",
Discrim_Value, Discrim);
else
Error_Msg_FE
("value for discriminant & must be static!",
Discrim_Value, Discrim);
end if;
Why_Not_Static (Discrim_Value);
end if;
Report_Errors := True;
return;
end if;
end if;
Search_For_Discriminant_Value : declare
@ -9050,9 +9104,36 @@ package body Sem_Util is
UI_High : Uint;
UI_Low : Uint;
UI_Discrim_Value : constant Uint := Expr_Value (Discrim_Value);
UI_Discrim_Value : Uint;
begin
case Good_Discrim_Value_Status'(Discrim_Value_Status) is
when Static_Expr =>
UI_Discrim_Value := Expr_Value (Discrim_Value);
when Static_Subtype =>
-- Arbitrarily pick one value of the subtype and look
-- for the variant associated with that value; we will
-- check later that the same variant is associated with
-- all of the other values of the subtype.
if Has_Static_Predicate (Discrim_Value_Subtype) then
declare
Range_Or_Expr : constant Node_Id :=
First (Static_Discrete_Predicate
(Discrim_Value_Subtype));
begin
if Nkind (Range_Or_Expr) = N_Range then
UI_Discrim_Value :=
Expr_Value (Low_Bound (Range_Or_Expr));
else
UI_Discrim_Value := Expr_Value (Range_Or_Expr);
end if;
end;
else
UI_Discrim_Value
:= Expr_Value (Type_Low_Bound (Discrim_Value_Subtype));
end if;
end case;
Find_Discrete_Value : while Present (Variant) loop
-- If a choice is a subtype with a static predicate, it must
@ -9085,7 +9166,7 @@ package body Sem_Util is
-- The case statement must include a variant that corresponds to the
-- value of the discriminant, unless the discriminant type has a
-- static predicate. In that case the absence of an others_choice that
-- would cover this value becomes a run-time error (3.8,1 (21.1/2)).
-- would cover this value becomes a run-time error (3.8.1 (21.1/2)).
if No (Variant)
and then not Has_Static_Predicate (Etype (Discrim_Name))
@ -9101,6 +9182,31 @@ package body Sem_Util is
-- the same record type.
if Present (Variant) then
if Discrim_Value_Status = Static_Subtype then
declare
Discrim_Value_Subtype_Intervals
: constant Interval_Lists.Discrete_Interval_List
:= Interval_Lists.Type_Intervals (Discrim_Value_Subtype);
Variant_Intervals
: constant Interval_Lists.Discrete_Interval_List
:= Interval_Lists.Choice_List_Intervals
(Discrete_Choices => Discrete_Choices (Variant));
begin
if not Interval_Lists.Is_Subset
(Subset => Discrim_Value_Subtype_Intervals,
Of_Set => Variant_Intervals)
then
Error_Msg_NE
("no single variant is associated with all values of " &
"the subtype of discriminant value &",
Discrim_Value, Discrim);
Report_Errors := True;
return;
end if;
end;
end if;
Gather_Components
(Typ, Component_List (Variant), Governed_By, Into, Report_Errors);
end if;
@ -27117,6 +27223,367 @@ package body Sem_Util is
end if;
end Yields_Universal_Type;
package body Interval_Lists is
function In_Interval
(Value : Uint; Interval : Discrete_Interval) return Boolean;
-- Does the given value lie within the given interval?
-----------------
-- In_Interval --
-----------------
function In_Interval
(Value : Uint; Interval : Discrete_Interval) return Boolean is
begin
return Value >= Interval.Low and then Value <= Interval.High;
end In_Interval;
procedure Check_Consistency (Intervals : Discrete_Interval_List);
-- Check that list is sorted, lacks null intervals, and has gaps
-- between intervals.
------------------------
-- Check_Consistency --
------------------------
procedure Check_Consistency (Intervals : Discrete_Interval_List) is
begin
if Serious_Errors_Detected > 0 then
return;
end if;
-- low bound is 1 and high bound equals length
pragma Assert (Intervals'First = 1 and Intervals'Last >= 0);
for Idx in Intervals'Range loop
-- each interval is non-null
pragma Assert (Intervals (Idx).Low <= Intervals (Idx).High);
if Idx /= Intervals'First then
-- intervals are sorted with non-empty gaps between them
pragma Assert
(Intervals (Idx - 1).High < (Intervals (Idx).Low - 1));
null;
end if;
end loop;
end Check_Consistency;
function Chosen_Interval (Choice : Node_Id) return Discrete_Interval;
-- Given an element of a Discrete_Choices list, a
-- Static_Discrete_Predicate list, or an Others_Discrete_Choices
-- list (but not an N_Others_Choice node) return the corresponding
-- interval. If an element that does not represent a single
-- contiguous interval due to a static predicate (or which
-- represents a single contiguous interval whose bounds depend on
-- a static predicate) is encountered, then that is an error on the
-- part of whoever built the list in question.
---------------------
-- Chosen_Interval --
---------------------
function Chosen_Interval (Choice : Node_Id) return Discrete_Interval is
begin
case Nkind (Choice) is
when N_Range =>
return (Low => Expr_Value (Low_Bound (Choice)),
High => Expr_Value (High_Bound (Choice)));
when N_Subtype_Indication =>
declare
Range_Exp : constant Node_Id
:= Range_Expression (Constraint (Choice));
begin
return (Low => Expr_Value (Low_Bound (Range_Exp)),
High => Expr_Value (High_Bound (Range_Exp)));
end;
when N_Others_Choice =>
raise Program_Error;
when others =>
if Is_Entity_Name (Choice) and then Is_Type (Entity (Choice))
then
return
(Low => Expr_Value (Type_Low_Bound (Entity (Choice))),
High => Expr_Value (Type_High_Bound (Entity (Choice))));
else
-- an expression
return (Low | High => Expr_Value (Choice));
end if;
end case;
end Chosen_Interval;
--------------------
-- Type_Intervals --
--------------------
function Type_Intervals
(Typ : Entity_Id) return Discrete_Interval_List
is
begin
if Has_Static_Predicate (Typ) then
declare
-- No sorting or merging needed
SDP_List : constant List_Id := Static_Discrete_Predicate (Typ);
Range_Or_Expr : Node_Id := First (SDP_List);
Result :
Discrete_Interval_List (1 .. List_Length (SDP_List));
begin
for Idx in Result'Range loop
Result (Idx) := Chosen_Interval (Range_Or_Expr);
Range_Or_Expr := Next (Range_Or_Expr);
end loop;
pragma Assert (not Present (Range_Or_Expr));
Check_Consistency (Result);
return Result;
end;
else
declare
Low : constant Uint := Expr_Value (Type_Low_Bound (Typ));
High : constant Uint := Expr_Value (Type_High_Bound (Typ));
begin
if Low > High then
declare
Null_Array : Discrete_Interval_List (1 .. 0);
begin
return Null_Array;
end;
else
return (1 => (Low => Low, High => High));
end if;
end;
end if;
end Type_Intervals;
procedure Normalize_Interval_List
(List : in out Discrete_Interval_List; Last : out Nat);
-- Perform sorting and merging as required by Check_Consistency.
-----------------------------
-- Normalize_Interval_List --
-----------------------------
procedure Normalize_Interval_List
(List : in out Discrete_Interval_List; Last : out Nat) is
procedure Move_Interval (From, To : Natural);
-- Copy interval from one location to another
function Lt_Interval (Idx1, Idx2 : Natural) return Boolean;
-- Compare two list elements
Temp_0 : Discrete_Interval := (others => Uint_0);
-- cope with Heap_Sort_G idiosyncrasies.
function Read_Interval (From : Natural) return Discrete_Interval;
-- Normal array indexing unless From = 0
-------------------
-- Read_Interval --
-------------------
function Read_Interval (From : Natural) return Discrete_Interval is
begin
if From = 0 then
return Temp_0;
else
return List (Pos (From));
end if;
end Read_Interval;
-------------------
-- Move_Interval --
-------------------
procedure Move_Interval (From, To : Natural) is
Rhs : constant Discrete_Interval := Read_Interval (From);
begin
if To = 0 then
Temp_0 := Rhs;
else
List (Pos (To)) := Rhs;
end if;
end Move_Interval;
-----------------
-- Lt_Interval --
-----------------
function Lt_Interval (Idx1, Idx2 : Natural) return Boolean is
Elem1 : constant Discrete_Interval := Read_Interval (Idx1);
Elem2 : constant Discrete_Interval := Read_Interval (Idx2);
Null_1 : constant Boolean := Elem1.Low > Elem1.High;
Null_2 : constant Boolean := Elem2.Low > Elem2.High;
begin
if Null_1 /= Null_2 then
-- So that sorting moves null intervals to high end
return Null_2;
elsif Elem1.Low /= Elem2.Low then
return Elem1.Low < Elem2.Low;
else
return Elem1.High < Elem2.High;
end if;
end Lt_Interval;
package Interval_Sorting is
new Gnat.Heap_Sort_G (Move_Interval, Lt_Interval);
function Is_Null (Idx : Pos) return Boolean;
-- True iff List (Idx) defines a null range
function Is_Null (Idx : Pos) return Boolean is
begin
return List (Idx).Low > List (Idx).High;
end Is_Null;
procedure Merge_Intervals (Null_Interval_Count : out Nat);
-- Merge contiguous ranges by replacing one with merged range
-- and the other with a null value. Return a count of the
-- null intervals, both preexisting and those introduced by
-- merging.
---------------------
-- Merge_Intervals --
---------------------
procedure Merge_Intervals (Null_Interval_Count : out Nat) is
Not_Null : Pos range List'Range;
-- Index of the most recently examined non-null interval
Null_Interval : constant Discrete_Interval
:= (Low => Uint_1, High => Uint_0); -- any null range ok here
begin
if List'Length = 0 or else Is_Null (List'First) then
Null_Interval_Count := List'Length;
-- no non-null elements, so no merge candidates
return;
end if;
Null_Interval_Count := 0;
Not_Null := List'First;
for Idx in List'First + 1 .. List'Last loop
if Is_Null (Idx) then
-- all remaining elements are null
Null_Interval_Count :=
Null_Interval_Count + List (Idx .. List'Last)'Length;
return;
elsif List (Idx).Low = List (Not_Null).High + 1 then
-- Merge the two intervals into one; discard the other
List (Not_Null).High := List (Idx).High;
List (Idx) := Null_Interval;
Null_Interval_Count := Null_Interval_Count + 1;
else
pragma Assert (List (Idx).Low > List (Not_Null).High);
Not_Null := Idx;
end if;
end loop;
end Merge_Intervals;
begin
Interval_Sorting.Sort (Natural (List'Last));
declare
Null_Interval_Count : Nat;
begin
Merge_Intervals (Null_Interval_Count);
Last := List'Last - Null_Interval_Count;
if Null_Interval_Count /= 0 then
-- Move null intervals introduced during merging to high end
Interval_Sorting.Sort (Natural (List'Last));
end if;
end;
end Normalize_Interval_List;
---------------------------
-- Choice_List_Intervals --
---------------------------
function Choice_List_Intervals
(Discrete_Choices : List_Id) return Discrete_Interval_List
is
function Unmerged_Choice_Count return Nat;
-- The number of intervals before adjacent intervals are merged.
---------------------------
-- Unmerged_Choice_Count --
---------------------------
function Unmerged_Choice_Count return Nat is
Choice : Node_Id := First (Discrete_Choices);
Count : Nat := 0;
begin
while Present (Choice) loop
-- Non-contiguous choices involving static predicates
-- have already been normalized away.
if Nkind (Choice) = N_Others_Choice then
Count :=
Count + List_Length (Others_Discrete_Choices (Choice));
else
Count := Count + 1; -- an ordinary expression or range
end if;
Choice := Next (Choice);
end loop;
return Count;
end Unmerged_Choice_Count;
Choice : Node_Id := First (Discrete_Choices);
Result : Discrete_Interval_List (1 .. Unmerged_Choice_Count);
Count : Nat := 0;
begin
while Present (Choice) loop
if Nkind (Choice) = N_Others_Choice then
declare
Others_Choice : Node_Id
:= First (Others_Discrete_Choices (Choice));
begin
while Present (Others_Choice) loop
Count := Count + 1;
Result (Count) := Chosen_Interval (Others_Choice);
Others_Choice := Next (Others_Choice);
end loop;
end;
else
Count := Count + 1;
Result (Count) := Chosen_Interval (Choice);
end if;
Choice := Next (Choice);
end loop;
pragma Assert (Count = Result'Last);
Normalize_Interval_List (Result, Count);
Check_Consistency (Result (1 .. Count));
return Result (1 .. Count);
end Choice_List_Intervals;
---------------
-- Is_Subset --
---------------
function Is_Subset
(Subset, Of_Set : Discrete_Interval_List) return Boolean
is
-- Returns True iff for each interval of Subset we can find
-- a single interval of Of_Set which contains the Subset interval.
begin
if Of_Set'Length = 0 then
return Subset'Length = 0;
end if;
declare
Set_Index : Pos range Of_Set'Range := Of_Set'First;
begin
for Ss_Idx in Subset'Range loop
while not In_Interval
(Value => Subset (Ss_Idx).Low,
Interval => Of_Set (Set_Index))
loop
if Set_Index = Of_Set'Last then
return False;
end if;
Set_Index := Set_Index + 1;
end loop;
if not In_Interval
(Value => Subset (Ss_Idx).High,
Interval => Of_Set (Set_Index))
then
return False;
end if;
end loop;
end;
return True;
end Is_Subset;
end Interval_Lists;
begin
Erroutc.Subprogram_Name_Ptr := Subprogram_Name'Access;
end Sem_Util;

36
gcc/ada/sem_util.ads
View File

@ -2965,4 +2965,40 @@ package Sem_Util is
function Yields_Universal_Type (N : Node_Id) return Boolean;
-- Determine whether unanalyzed node N yields a universal type
package Interval_Lists is
type Discrete_Interval is
record
Low, High : Uint;
end record;
type Discrete_Interval_List is
array (Pos range <>) of Discrete_Interval;
-- A sorted (in ascending order) list of non-empty pairwise-disjoint
-- intervals, always with a gap of at least one value between
-- successive intervals (i.e., mergeable intervals are merged).
-- Low bound is one; high bound is nonnegative.
function Type_Intervals (Typ : Entity_Id) return Discrete_Interval_List;
-- Given a static discrete type or subtype, returns the (unique)
-- interval list representing the values of the type/subtype.
-- If no static predicates are involved, the length of the result
-- will be at most one.
function Choice_List_Intervals (Discrete_Choices : List_Id)
return Discrete_Interval_List;
-- Given a discrete choice list, returns the (unique) interval
-- list representing the chosen values..
function Is_Subset (Subset, Of_Set : Discrete_Interval_List)
return Boolean;
-- Returns True iff every value belonging to some interval of
-- Subset also belongs to some interval of Of_Set.
-- TBD: When we get around to implementing "is statically compatible"
-- correctly for real types with static predicates, we may need
-- an analogous Real_Interval_List type. Most of the language
-- rules that reference "is statically compatible" pertain to
-- discriminants and therefore do require support for real types;
-- the exception is 12.5.1(8).
end Interval_Lists;
end Sem_Util;

4
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,7 @@
2019-09-18 Steve Baird <baird@adacore.com>
* gnat.dg/ai12_0086_example.adb: New testcase.
2019-09-18 Nicolas Roche <roche@adacore.com>
* gnat.dg/float_value2.adb: New testcase.

24
gcc/testsuite/gnat.dg/ai12_0086_example.adb Normal file
View File

@ -0,0 +1,24 @@
-- { dg-do compile }
-- { dg-options "-gnatX" }
procedure AI12_0086_Example is
type Enum is (Aa, Bb, Cc, Dd, Ee, Ff, Gg, Hh, Ii, Jj, Kk, Ll, MM,
Nn, Oo, Pp, Qq, Rr, Ss, Tt, Uu, Vv, Ww, Xx, Yy, Zz);
subtype S is Enum range Dd .. Hh;
type Rec (D : Enum) is record
case D is
when S => Foo, Bar : Integer;
when others => null;
end case;
end record;
function Make (D : S) return Rec is
begin
return (D => D, Foo => 123, Bar => 456); -- legal
end;
begin
if Make (Ff).Bar /= 456 then
raise Program_Error;
end if;
end AI12_0086_Example;