[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:
parent
6bc08721d0
commit
c8324fe7b1
|
@ -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
|
||||
|
|
|
@ -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;
|
||||
|
|
|
@ -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;
|
||||
|
|
|
@ -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.
|
||||
|
|
|
@ -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;
|
Loading…
Reference in New Issue