[Ada] Fix check for bounds in aggregate expansion of allocator

Message ID 20200619082834.GA31436@adacore.com
State New
Headers show
Series
  • [Ada] Fix check for bounds in aggregate expansion of allocator
Related show

Commit Message

Pierre-Marie de Rodat June 19, 2020, 8:28 a.m.
The predicate function In_Place_Assign_OK is responsible for finding
out whether the in-place assignment of an aggregate is possible; for
array aggregates, it checks among other things whether sliding will
occur during the assignment.

But, in an allocator context, it does so by comparing the bounds of
the aggregate with those of the qualified expression surrounding it.
Now Constraint_Error is already guaranteed to be raised if they do
not match, so there is no point in doing it and the check must be
made against the bounds of the designated type instead.

Tested on x86_64-pc-linux-gnu, committed on trunk

2020-06-19  Eric Botcazou  <ebotcazou@adacore.com>

gcc/ada/

	* exp_aggr.adb (In_Place_Assign_OK): In an allocator context,
	check the bounds of an array aggregate against those of the
	designated type, except if the latter is unconstrained.

Patch

--- gcc/ada/exp_aggr.adb
+++ gcc/ada/exp_aggr.adb
@@ -4429,15 +4429,26 @@  package body Exp_Aggr is
       then
          Aggr_In := First_Index (Etype (N));
 
+         --  Context is an assignment
+
          if Parent_Kind = N_Assignment_Statement then
             Obj_In := First_Index (Etype (Name (Parent_Node)));
 
-         else
-            --  Context is an allocator. Check bounds of aggregate against
-            --  given type in qualified expression.
+         --  Context is an allocator. Check the bounds of the aggregate against
+         --  those of the designated type, except in the case where the type is
+         --  unconstrained (and then we can directly return true, see below).
+
+         else pragma Assert (Parent_Kind = N_Allocator);
+            declare
+               Desig_Typ : constant Entity_Id :=
+                                         Designated_Type (Etype (Parent_Node));
+            begin
+               if not Is_Constrained (Desig_Typ) then
+                  return True;
+               end if;
 
-            pragma Assert (Parent_Kind = N_Allocator);
-            Obj_In := First_Index (Etype (Entity (Subtype_Mark (Parent (N)))));
+               Obj_In := First_Index (Desig_Typ);
+            end;
          end if;
 
          while Present (Aggr_In) loop