https://gcc.gnu.org/g:e566a03e17cee6d346c1d57e6198e4b712709e75
commit r17-4760-ge566a03e17cee6d346c1d57e6198e4b712709e75 Author: Eric Botcazou <[email protected]> Date: Tue Sep 29 12:01:12 2026 +0200 Ada: Add support for static comparison of aggregates of discrete array types This extends the support of static comparison of aggregates for string types to all other discrete array types. gcc/ada/ * exp_pakd.adb (Expand_Bit_Packed_Element_Set): Check that the type of the RHS is discrete before calling Expr_Rep_Value on it. * sem_eval.ads (Expr_Value_A): New function. * sem_eval.adb (Compile_Time_Compare): Filter string types and deal with other discrete array types. (Compile_Time_Known_Value): Return True for aggregates with the Compile_Time_Known_Aggregate flag set and not of a string type. (Eval_Logical_Op): Filter boolean types. (Eval_Op_Not): Likewise. (Eval_Qualified_Expression): Filter string types. (Expr_Value_A): New function. (Test_Expression_Is_Foldable): Do not apply boolean logic to arrays. * sem_res.adb (Resolve_Expression_With_Actions.Get_Literal): Adjust. (Resolve_Expression_With_Actions): Remove useless assertion and fold local constant. Diff: --- gcc/ada/exp_pakd.adb | 4 +- gcc/ada/sem_eval.adb | 124 +++++++++++++++++++++++++++++++++++++++++---------- gcc/ada/sem_eval.ads | 6 +++ gcc/ada/sem_res.adb | 18 +++----- 4 files changed, 115 insertions(+), 37 deletions(-) diff --git a/gcc/ada/exp_pakd.adb b/gcc/ada/exp_pakd.adb index e513dc8a7876..44d1e007a955 100644 --- a/gcc/ada/exp_pakd.adb +++ b/gcc/ada/exp_pakd.adb @@ -1242,7 +1242,9 @@ package body Exp_Pakd is -- Determine if right side is all 0 bits or all 1 bits - if Compile_Time_Known_Value (Rhs) then + if Compile_Time_Known_Value (Rhs) + and then Is_Discrete_Type (Etype (Rhs)) + then Rhs_Val := Expr_Rep_Value (Rhs); -- The following test catches the case of an unchecked conversion of diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 50e9f4540672..b321af679775 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -1330,9 +1330,9 @@ package body Sem_Eval is end; -- For string types, we have two string literals and we proceed to - -- compare them using the Ada style dictionary string comparison. + -- compare them using the lexicographic order (RM 4.5.2(26)). - elsif not Is_Scalar_Type (Ltyp) then + elsif Is_String_Type (Ltyp) then declare Lstring : constant String_Id := Strval (Expr_Value_S (L)); Rstring : constant String_Id := Strval (Expr_Value_S (R)); @@ -1362,6 +1362,63 @@ package body Sem_Eval is end if; end; + -- Likewise for other discrete array types, i.e. 1-dimensional array + -- types whose component type is discrete. + + elsif Is_Composite_Type (Ltyp) then + declare + Laggr : constant Node_Id := Expr_Value_A (L); + Raggr : constant Node_Id := Expr_Value_A (R); + Lbnds : constant Node_Id := Aggregate_Bounds (Laggr); + Rbnds : constant Node_Id := Aggregate_Bounds (Raggr); + + Lexp : Node_Id; + Rexp : Node_Id; + Llen : Uint; + Rlen : Uint; + Res : Compare_Result; + + begin + if Is_Array_Type (Ltyp) + and then Number_Dimensions (Ltyp) = 1 + and then Is_Discrete_Type (Component_Type (Ltyp)) + and then Present (Lbnds) + and then Present (Rbnds) + then + Llen := UI_Max (Expr_Value (High_Bound (Lbnds)) - + Expr_Value (Low_Bound (Lbnds)) + 1, 0); + Rlen := UI_Max (Expr_Value (High_Bound (Rbnds)) - + Expr_Value (Low_Bound (Rbnds)) + 1, 0); + + Lexp := First (Expressions (Laggr)); + Rexp := First (Expressions (Raggr)); + + for J in 1 .. UI_To_Int (UI_Min (Llen, Rlen)) loop + Res := + Compile_Time_Compare (Lexp, Rexp, Assume_Valid => True); + case Res is + when LT | GT | NE => return Res; + when LE | GE | Unknown => return Unknown; + when EQ => null; + end case; + + Next (Lexp); + Next (Rexp); + end loop; + + if Llen < Rlen then + return LT; + elsif Llen > Rlen then + return GT; + else + return EQ; + end if; + + else + return Unknown; + end if; + end; + -- For remaining scalar cases we know exactly (note that this does -- include the fixed-point case, where we know the run time integer -- values now). @@ -1881,6 +1938,15 @@ package body Sem_Eval is then return True; + -- Compile-time known aggregates, but not for string types since + -- we cannot rewrite them as string literals for the time being. + + elsif K = N_Aggregate + and then Compile_Time_Known_Aggregate (Op) + and then not Is_String_Type (Etype (Op)) + then + return True; + -- Evaluate static discriminants, to eliminate dead paths and -- redundant discriminant checks. @@ -2986,9 +3052,7 @@ package body Sem_Eval is Fold_Uint (N, From_Bits (Left_Bits, Etype (N)), Stat); end; - else - pragma Assert (Is_Boolean_Type (Etype (N))); - + elsif Is_Boolean_Type (Etype (N)) then if Compile_Time_Known_Value (Left) and then Compile_Time_Known_Value (Right) then @@ -3231,7 +3295,8 @@ package body Sem_Eval is -- static if the operand is potentially static (RM 4.9(7), 4.9(20)). procedure Eval_Op_Not (N : Node_Id) is - Right : constant Node_Id := Right_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + Typ : constant Entity_Id := Etype (N); Stat : Boolean; Fold : Boolean; @@ -3244,26 +3309,19 @@ package body Sem_Eval is return; end if; - -- Fold not operation + -- Negation is equivalent to subtracting from the modulus minus one. + -- For a binary modulus this is equivalent to the ones-complement of + -- the original value. For a nonbinary modulus this is an arbitrary + -- but consistent definition. - declare - Rint : constant Uint := Expr_Value (Right); - Typ : constant Entity_Id := Etype (N); - - begin - -- Negation is equivalent to subtracting from the modulus minus one. - -- For a binary modulus this is equivalent to the ones-complement of - -- the original value. For a nonbinary modulus this is an arbitrary - -- but consistent definition. - - if Has_Modular_Operations (Typ) then - Fold_Uint (N, Modulus (Typ) - 1 - Rint, Stat); - else pragma Assert (Is_Boolean_Type (Typ)); - Fold_Uint (N, Test (not Is_True (Rint)), Stat); - end if; + if Has_Modular_Operations (Typ) then + Fold_Uint (N, Modulus (Typ) - 1 - Expr_Value (Right), Stat); + Set_Is_Static_Expression (N, Stat); + elsif Is_Boolean_Type (Typ) then + Fold_Uint (N, Test (not Is_True (Expr_Value (Right))), Stat); Set_Is_Static_Expression (N, Stat); - end; + end if; end Eval_Op_Not; ------------------------------- @@ -3346,7 +3404,7 @@ package body Sem_Eval is elsif Is_Real_Type (Target_Type) then Fold_Ureal (N, Expr_Value_R (Operand), Stat); - else + elsif Is_String_Type (Target_Type) then Fold_Str (N, Strval (Get_String_Val (Operand)), Stat); if not Stat then @@ -3356,6 +3414,9 @@ package body Sem_Eval is end if; return; + + else + return; end if; -- The expression may be foldable but not static @@ -4665,6 +4726,20 @@ package body Sem_Eval is return Val; end Expr_Value; + ------------------ + -- Expr_Value_A -- + ------------------ + + function Expr_Value_A (N : Node_Id) return Node_Id is + begin + if Nkind (N) = N_Aggregate then + return N; + else + pragma Assert (Ekind (Entity (N)) = E_Constant); + return Expr_Value_A (Constant_Value (Entity (N))); + end if; + end Expr_Value_A; + ------------------ -- Expr_Value_E -- ------------------ @@ -7294,6 +7369,7 @@ package body Sem_Eval is if not Fold and then not Has_Modular_Operations (Etype (N)) + and then not Is_Array_Type (Etype (N)) then case Nkind (N) is when N_Op_And => diff --git a/gcc/ada/sem_eval.ads b/gcc/ada/sem_eval.ads index 9803245a036a..8a68e53972a5 100644 --- a/gcc/ada/sem_eval.ads +++ b/gcc/ada/sem_eval.ads @@ -292,6 +292,12 @@ package Sem_Eval is -- also be used for the Null access value, as well as for the result of an -- unchecked conversion of the aforementioned handled values. + function Expr_Value_A (N : Node_Id) return Node_Id; + -- Returns the folded value of the expression. This function is called + -- in instances where it has already been determined that the expression + -- is known at compile time. This version is used for composite types and + -- returns the corresponding N_Aggregate node. + function Expr_Value_E (N : Node_Id) return Entity_Id; -- Returns the folded value of the expression. This function is called in -- instances where it has already been determined that the expression is diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 758d90cbfa5d..272cd7bd8a46 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -9389,6 +9389,7 @@ package body Sem_Res is function Get_Literal (Expr : Node_Id) return Node_Id is pragma Assert (Compile_Time_Known_Value (Expr)); Result : Node_Id; + begin case Nkind (Expr) is when N_Has_Entity => @@ -9397,31 +9398,24 @@ package body Sem_Res is else Result := Constant_Value (Entity (Expr)); end if; - when N_Numeric_Or_String_Literal => + when N_Aggregate | N_Numeric_Or_String_Literal => Result := Expr; when others => raise Program_Error; end case; pragma Assert - (Nkind (Result) in N_Numeric_Or_String_Literal - or else Ekind (Entity (Result)) = E_Enumeration_Literal); + (Nkind (Result) in N_Aggregate | N_Numeric_Or_String_Literal + or else Ekind (Entity (Result)) = E_Enumeration_Literal); + return Result; end Get_Literal; - -- Local variables - - Loc : constant Source_Ptr := Sloc (N); - -- Start of processing for Resolve_Expression_With_Actions begin Set_Etype (N, Typ); - if Is_Empty_List (Actions (N)) then - pragma Assert (All_OK_For_Static); null; - end if; - -- If the value of the expression is known at compile time, and all -- of the actions (if any) are suitable, then replace the declare -- expression with its expression. This allows the declare expression @@ -9433,7 +9427,7 @@ package body Sem_Res is elsif All_OK_For_Static then Rewrite (N, New_Copy_Tree - (Get_Literal (Expression (N)), New_Sloc => Loc)); + (Get_Literal (Expression (N)), New_Sloc => Sloc (N))); end if; end if; end Resolve_Expression_With_Actions;
