This is a recent regression present on the mainline, 16 and 15 branches. The
compiler fails to implement the required sliding when an array aggregate with
specified bounds is assigned to an unconstrained formal parameter, because the
Must_Slide predicate considers only the case of an object declaration when the
object subtype is unconstrained.
Tested on x86-64/Linux, applied on the mainline, 16 and 15 branches.
2026-08-24 Eric Botcazou <[email protected]>
PR ada/127026
* exp_aggr.adb (Must_Slide): Reorder parameters, rename Obj_Type to
Ob_Typ and add Assign boolean parameter. Return Assign's value in
the case where Obj_Typ is unconstrained.
(Build_Array_Aggr_Code): Adjust call to Must_Slide.
(In_Place_Assign_OK): Likewise.
(Expand_Array_Aggregate): Likewise.
2026-08-24 Eric Botcazou <[email protected]>
* gnat.dg/array43.adb: New test.
--
Eric Botcazou
diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index ba8bf71912b..ab8bfce1607 100644
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -138,19 +138,22 @@ package body Exp_Aggr is
-- constants that are done in place.
function Must_Slide
- (Aggr : Node_Id;
- Obj_Type : Entity_Id;
- Typ : Entity_Id) return Boolean;
+ (Aggr : Node_Id;
+ Typ : Entity_Id;
+ Obj_Typ : Entity_Id;
+ Assign : Boolean) return Boolean;
+ -- Return whether an array aggregate Aggr whose subtype is Typ must slide
+ -- when assigned to an object whose (nominal) subtype is Obj_Typ. Assign
+ -- is True when the context is an assignment statement and False when it
+ -- is an object declaration or an allocator.
+
-- A static array aggregate in an object declaration can in most cases be
-- expanded in place. The one exception is when the aggregate is given
-- with component associations that specify different bounds from those of
-- the type definition in the object declaration. In this pathological
-- case the aggregate must slide, and we must introduce an intermediate
- -- temporary to hold it.
- --
- -- The same holds in an assignment to multi-dimensional arrays, when
- -- components may be given with bounds that differ from those of the
- -- component type.
+ -- temporary to hold it. The same holds in an assignment, when components
+ -- may be given with bounds that differ from those of the target.
function Number_Of_Choices (N : Node_Id) return Nat;
-- Returns the number of discrete choices (not including the others choice
@@ -1443,7 +1446,8 @@ package body Exp_Aggr is
if Nkind (Parent (N)) = N_Assignment_Statement
and then Is_Array_Type (Comp_Typ)
and then Present (Component_Associations (Expr_Q))
- and then Must_Slide (N, Comp_Typ, Etype (Expr_Q))
+ and then
+ Must_Slide (N, Etype (Expr_Q), Comp_Typ, Assign => True)
then
Set_Expansion_Delayed (Expr_Q, False);
Set_Analyzed (Expr_Q, False);
@@ -4251,7 +4255,8 @@ package body Exp_Aggr is
-- statically equal to those of the target.
if Is_Array
- and then Must_Slide (N, Etype (Name (Parent_Node)), Etype (N))
+ and then
+ Must_Slide (N, Etype (N), Etype (Name (Parent_Node)), Assign => True)
then
return False;
end if;
@@ -6276,8 +6281,9 @@ package body Exp_Aggr is
or else Needs_Finalization (Typ)
or else not Must_Slide
(N,
+ Typ,
Designated_Type (Etype (Parent_Node)),
- Typ)))
+ Assign => False)))
-- Object declaration (see Convert_Aggr_In_Object_Decl). Sliding
-- cannot be done in place for the time being.
@@ -6291,9 +6297,10 @@ package body Exp_Aggr is
(Defining_Identifier (Parent_Node))
or else not Must_Slide
(N,
+ Typ,
Etype
(Defining_Identifier (Parent_Node)),
- Typ)))
+ Assign => False)))
-- Safe assignment (see Convert_Aggr_In_Assignment). So far only the
-- assignments in init procs are taken into account, as well those
@@ -9610,9 +9617,10 @@ package body Exp_Aggr is
----------------
function Must_Slide
- (Aggr : Node_Id;
- Obj_Type : Entity_Id;
- Typ : Entity_Id) return Boolean
+ (Aggr : Node_Id;
+ Typ : Entity_Id;
+ Obj_Typ : Entity_Id;
+ Assign : Boolean) return Boolean
is
begin
-- No sliding if the type of the object is not established yet, if it is
@@ -9621,13 +9629,13 @@ package body Exp_Aggr is
-- an Others_Clause it gets its type from the context and no sliding
-- is involved either.
- if not Is_Array_Type (Obj_Type) then
+ if not Is_Array_Type (Obj_Typ) then
return False;
- elsif not Is_Constrained (Obj_Type) then
- return False;
+ elsif not Is_Constrained (Obj_Typ) then
+ return Assign;
- elsif Typ = Obj_Type then
+ elsif Typ = Obj_Typ then
return False;
elsif Is_Others_Aggregate (Aggr) then
@@ -9637,7 +9645,7 @@ package body Exp_Aggr is
else
declare
- Obj_Index : Node_Id := First_Index (Obj_Type);
+ Obj_Index : Node_Id := First_Index (Obj_Typ);
Obj_Bounds : Range_Nodes;
Typ_Index : Node_Id := First_Index (Typ);
Typ_Bounds : Range_Nodes;
-- { dg-do run }
procedure Array43 is
type Arr is array (Integer range <>) of Integer;
procedure Fill (B : out Arr; N : Integer) is
begin
B := (1 .. N => 7);
end Fill;
V : Arr (5 .. 8) := (others => 0);
begin
Fill (V, V'Length);
if V /= (V'First .. V'Last => 7) then
raise Program_Error;
end if;
end;
