From: Javier Miranda Date: Tue, 5 May 2020 17:22:47 +0000 (-0400) Subject: [Ada] Ada2020: AI12-0198 potentially unevaluated array components X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=0fc1b4ad1d2015fd464f4c843945b1919c666c94;p=gcc.git [Ada] Ada2020: AI12-0198 potentially unevaluated array components gcc/ada/ * sem_util.ads (Interval_Lists.Aggregate_Intervals): New subprogram. * sem_util.adb (Has_Null_Others_Choice, Non_Static_Or_Null_Range, Interval_Lists.Aggregate_Intervals): New subprograms. (Is_Potentially_Unevaluated): Adding support to detect potentially unevaluated components of array aggregates. --- diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 7ce78a2451c..36efebb8aa7 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -17694,9 +17694,81 @@ package body Sem_Util is -------------------------------- function Is_Potentially_Unevaluated (N : Node_Id) return Boolean is + function Has_Null_Others_Choice (Aggr : Node_Id) return Boolean; + -- Aggr is an array aggregate with static bounds and an others clause; + -- return True if the others choice of the given array aggregate does + -- not cover any component (i.e. is null). + + function Non_Static_Or_Null_Range (N : Node_Id) return Boolean; + -- Return True if the given range is nonstatic or null + + ---------------------------- + -- Has_Null_Others_Choice -- + ---------------------------- + + function Has_Null_Others_Choice (Aggr : Node_Id) return Boolean is + Idx : constant Node_Id := First_Index (Etype (Aggr)); + Hiv : constant Uint := Expr_Value (Type_High_Bound (Etype (Idx))); + Lov : constant Uint := Expr_Value (Type_Low_Bound (Etype (Idx))); + + begin + declare + Intervals : constant Interval_Lists.Discrete_Interval_List := + Interval_Lists.Aggregate_Intervals (Aggr); + + begin + -- The others choice is null if, after normalization, we + -- have a single interval covering the whole aggregate. + + return Intervals'Length = 1 + and then + Intervals (Intervals'First).Low = Lov + and then + Intervals (Intervals'First).High = Hiv; + end; + + -- If the aggregate is malformed (that is, indexes are not disjoint) + -- then no action is needed at this stage; the error will be reported + -- later by the frontend. + + exception + when Interval_Lists.Intervals_Error => + return False; + end Has_Null_Others_Choice; + + ------------------------------ + -- Non_Static_Or_Null_Range -- + ------------------------------ + + function Non_Static_Or_Null_Range (N : Node_Id) return Boolean is + Low, High : Node_Id; + + begin + Get_Index_Bounds (N, Low, High); + + -- Check static bounds + + if not Compile_Time_Known_Value (Low) + or else not Compile_Time_Known_Value (High) + then + return True; + + -- Check null range + + elsif Expr_Value (High) < Expr_Value (Low) then + return True; + end if; + + return False; + end Non_Static_Or_Null_Range; + + -- Local variables + Par : Node_Id; Expr : Node_Id; + -- Start of processing for Is_Potentially_Unevaluated + begin Expr := N; Par := N; @@ -17732,6 +17804,8 @@ package body Sem_Util is N_Not_In, N_Or_Else, N_Quantified_Expression) + and then not (Nkind (Par) = N_Aggregate + and then Is_Array_Type (Etype (Par))) loop Expr := Par; Par := Parent (Par); @@ -17776,6 +17850,55 @@ package body Sem_Util is elsif Nkind (Par) = N_Quantified_Expression then return Expr = Condition (Par); + elsif Nkind (Par) = N_Aggregate + and then Is_Array_Type (Etype (Par)) + and then Nkind (Expr) = N_Component_Association + then + declare + Choice : Node_Id; + In_Others_Choice : Boolean := False; + + begin + -- The expression of an array_component_association is potentially + -- unevaluated if the associated choice is a subtype_indication or + -- range that defines a nonstatic or null range. + + Choice := First (Choices (Expr)); + while Present (Choice) loop + if Nkind (Choice) = N_Range + and then Non_Static_Or_Null_Range (Choice) + then + return True; + + elsif Nkind (Choice) = N_Identifier + and then Present (Scalar_Range (Etype (Choice))) + and then + Non_Static_Or_Null_Range (Scalar_Range (Etype (Choice))) + then + return True; + + elsif Nkind (Choice) = N_Others_Choice then + In_Others_Choice := True; + end if; + + Next (Choice); + end loop; + + -- It is also potentially unevaluated if the associated choice + -- is an others choice and the applicable index constraint is + -- nonstatic or null. + + if In_Others_Choice then + if not Compile_Time_Known_Bounds (Etype (Par)) then + return True; + else + return Has_Null_Others_Choice (Par); + end if; + end if; + end; + + return False; + else return False; end if; @@ -28770,10 +28893,97 @@ package body Sem_Util is package body Interval_Lists is + procedure Check_Consistency (Intervals : Discrete_Interval_List); + -- Check that list is sorted, lacks null intervals, and has gaps + -- between intervals. + function In_Interval (Value : Uint; Interval : Discrete_Interval) return Boolean; -- Does the given value lie within the given interval? + procedure Normalize_Interval_List + (List : in out Discrete_Interval_List; Last : out Nat); + -- Perform sorting and merging as required by Check_Consistency. + + ------------------------- + -- Aggregate_Intervals -- + ------------------------- + + function Aggregate_Intervals (N : Node_Id) return Discrete_Interval_List + is + pragma Assert (Nkind (N) = N_Aggregate + and then Is_Array_Type (Etype (N))); + + function Unmerged_Intervals_Count return Nat; + -- Count the number of intervals given in the aggregate N; the others + -- choice (if present) is not taken into account. + + function Unmerged_Intervals_Count return Nat is + Count : Nat := 0; + Choice : Node_Id; + Comp : Node_Id; + begin + Comp := First (Component_Associations (N)); + while Present (Comp) loop + Choice := First (Choices (Comp)); + + while Present (Choice) loop + if Nkind (Choice) /= N_Others_Choice then + Count := Count + 1; + end if; + + Next (Choice); + end loop; + + Next (Comp); + end loop; + + return Count; + end Unmerged_Intervals_Count; + + -- Local variables + + Comp : Node_Id; + Max_I : constant Nat := Unmerged_Intervals_Count; + Intervals : Discrete_Interval_List (1 .. Max_I); + Num_I : Nat := 0; + + begin + -- No action needed if there are no intervals + + if Max_I = 0 then + return Intervals; + end if; + + -- Internally store all the unsorted intervals + + Comp := First (Component_Associations (N)); + while Present (Comp) loop + declare + Choice_Intervals : constant Discrete_Interval_List + := Choice_List_Intervals (Choices (Comp)); + begin + for J in Choice_Intervals'Range loop + Num_I := Num_I + 1; + Intervals (Num_I) := Choice_Intervals (J); + end loop; + end; + + Next (Comp); + end loop; + + -- Normalize the lists sorting and merging the intervals + + declare + Aggr_Intervals : Discrete_Interval_List (1 .. Num_I) + := Intervals (1 .. Num_I); + begin + Normalize_Interval_List (Aggr_Intervals, Num_I); + Check_Consistency (Aggr_Intervals (1 .. Num_I)); + return Aggr_Intervals (1 .. Num_I); + end; + end Aggregate_Intervals; + ----------------- -- In_Interval -- ----------------- @@ -28783,10 +28993,6 @@ package body Sem_Util is 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 -- ------------------------ @@ -28896,10 +29102,6 @@ package body Sem_Util is 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 -- ----------------------------- @@ -29009,6 +29211,10 @@ package body Sem_Util is List (Idx) := Null_Interval; Null_Interval_Count := Null_Interval_Count + 1; else + if List (Idx).Low <= List (Not_Null).High then + raise Intervals_Error; + end if; + pragma Assert (List (Idx).Low > List (Not_Null).High); Not_Null := Idx; end if; diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index df7e62c923c..22be399488e 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -3116,6 +3116,12 @@ package Sem_Util is -- successive intervals (i.e., mergeable intervals are merged). -- Low bound is one; high bound is nonnegative. + function Aggregate_Intervals (N : Node_Id) return Discrete_Interval_List; + -- Given an array aggregate N, returns the (unique) interval list + -- representing the values of the aggregate choices; if all the array + -- components are covered by the others choice then the length of the + -- result is zero. + 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. @@ -3138,5 +3144,9 @@ package Sem_Util is -- rules that reference "is statically compatible" pertain to -- discriminants and therefore do require support for real types; -- the exception is 12.5.1(8). + + Intervals_Error : exception; + -- Raised when the list of non-empty pair-wise disjoint intervals cannot + -- be built. end Interval_Lists; end Sem_Util;