This extends the support of static comparison of aggregates for string types
to all other discrete array types.
Tested on x86-64/Linux, applied on the mainline.
2026-09-29 Eric Botcazou <[email protected]>
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.
--
Eric Botcazoudiff --git a/gcc/ada/exp_pakd.adb b/gcc/ada/exp_pakd.adb
index e513dc8a787..44d1e007a95 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 50e9f454067..b321af67977 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 9803245a036..8a68e53972a 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 758d90cbfa5..272cd7bd8a4 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;
