From c8324fe7b12851c16c867f16ce248c95d2dbae7d Mon Sep 17 00:00:00 2001 From: Steve Baird Date: Wed, 18 Sep 2019 08:33:02 +0000 Subject: [PATCH] [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 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 --- gcc/ada/ChangeLog | 19 + gcc/ada/sem_util.adb | 509 +++++++++++++++++++- gcc/ada/sem_util.ads | 36 ++ gcc/testsuite/ChangeLog | 4 + gcc/testsuite/gnat.dg/ai12_0086_example.adb | 24 + 5 files changed, 571 insertions(+), 21 deletions(-) create mode 100644 gcc/testsuite/gnat.dg/ai12_0086_example.adb diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 07638f14a50..452243a9589 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,22 @@ +2019-09-18 Steve Baird + + * 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 * exp_ch4.adb (Expand_N_Op_Eq): The frontend assumes that we can diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index eac0c972e02..13555a56cbe 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -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 (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; - -- 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 Discrim_Value_Status = Bad then - 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); - end if; + -- 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. - Report_Errors := True; - return; + 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; diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 2d1bcf05194..c77f4414a74 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -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; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 8951eb63c81..fd0efb176e6 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2019-09-18 Steve Baird + + * gnat.dg/ai12_0086_example.adb: New testcase. + 2019-09-18 Nicolas Roche * gnat.dg/float_value2.adb: New testcase. diff --git a/gcc/testsuite/gnat.dg/ai12_0086_example.adb b/gcc/testsuite/gnat.dg/ai12_0086_example.adb new file mode 100644 index 00000000000..4ea6f6a88a5 --- /dev/null +++ b/gcc/testsuite/gnat.dg/ai12_0086_example.adb @@ -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; \ No newline at end of file -- 2.30.2