[Ada] Do not generate useless length check for array initialization

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

gcc/ada/

	* checks.ads (Apply_Length_Check_On_Assignment): Declare.
	* checks.adb (Apply_Length_Check_On_Assignment): New procedure
	to apply a length check to an expression in an assignment.
	* exp_ch5.adb (Expand_Assign_Array): Call it instead of calling
	Apply_Length_Check to generate a length check.
	* sem_ch5.adb (Analyze_Assignment): Likewise.

4 files changed, 40 insertions, 3 deletions

diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb
index aab9e33..4382951 100644
--- a/gcc/ada/checks.adb
+++ b/gcc/ada/checks.adb
@@ -2220,6 +2220,34 @@ package body Checks is
         (Expr, Target_Typ, Source_Typ, Do_Static => False);
    end Apply_Length_Check;
 
+   --------------------------------------
+   -- Apply_Length_Check_On_Assignment --
+   --------------------------------------
+
+   procedure Apply_Length_Check_On_Assignment
+     (Expr       : Node_Id;
+      Target_Typ : Entity_Id;
+      Target     : Node_Id;
+      Source_Typ : Entity_Id := Empty)
+   is
+      Assign : constant Node_Id := Parent (Target);
+
+   begin
+      --  No check is needed for the initialization of an object whose
+      --  nominal subtype is unconstrained.
+
+      if Is_Constr_Subt_For_U_Nominal (Target_Typ)
+        and then Nkind (Parent (Assign)) = N_Freeze_Entity
+        and then Is_Entity_Name (Target)
+        and then Entity (Target) = Entity (Parent (Assign))
+      then
+         return;
+      end if;
+
+      Apply_Selected_Length_Checks
+        (Expr, Target_Typ, Source_Typ, Do_Static => False);
+   end Apply_Length_Check_On_Assignment;
+
    -------------------------------------
    -- Apply_Parameter_Aliasing_Checks --
    -------------------------------------
diff --git a/gcc/ada/checks.ads b/gcc/ada/checks.ads
index 6412686..79657c3 100644
--- a/gcc/ada/checks.ads
+++ b/gcc/ada/checks.ads
@@ -569,6 +569,15 @@ package Checks is
    --  processes it as described above for consistency with the other routines
    --  in this section.
 
+   procedure Apply_Length_Check_On_Assignment
+     (Expr       : Node_Id;
+      Target_Typ : Entity_Id;
+      Target     : Node_Id;
+      Source_Typ : Entity_Id := Empty);
+   --  Similar to Apply_Length_Check, but takes the target of an assignment for
+   --  which the check is to be done. Used to filter out specific cases where
+   --  the check is superfluous.
+
    procedure Apply_Range_Check
      (Expr       : Node_Id;
       Target_Typ : Entity_Id;
diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb
index 0634ffc..fd51dfa 100644
--- a/gcc/ada/exp_ch5.adb
+++ b/gcc/ada/exp_ch5.adb
@@ -441,7 +441,7 @@ package body Exp_Ch5 is
       --  respect to the right-hand side as given, not a possible underlying
       --  renamed object, since this would generate incorrect extra checks.
 
-      Apply_Length_Check (Rhs, L_Type);
+      Apply_Length_Check_On_Assignment (Rhs, L_Type, Lhs);
 
       --  We start by assuming that the move can be done in either direction,
       --  i.e. that the two sides are completely disjoint.
diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb
index 01f0b50..36633cb 100644
--- a/gcc/ada/sem_ch5.adb
+++ b/gcc/ada/sem_ch5.adb
@@ -995,7 +995,7 @@ package body Sem_Ch5 is
         and then (Nkind (Rhs) /= N_Function_Call
                    or else Nkind (N) /= N_Block_Statement)
       then
-         --  Assignment verifies that the length of the Lsh and Rhs are equal,
+         --  Assignment verifies that the length of the Lhs and Rhs are equal,
          --  but of course the indexes do not have to match. If the right-hand
          --  side is a type conversion to an unconstrained type, a length check
          --  is performed on the expression itself during expansion. In rare
@@ -1003,7 +1003,7 @@ package body Sem_Ch5 is
          --  with a different representation, triggering incorrect code in the
          --  back end.
 
-         Apply_Length_Check (Rhs, Etype (Lhs));
+         Apply_Length_Check_On_Assignment (Rhs, Etype (Lhs), Lhs);
 
       else
          --  Discriminant checks are applied in the course of expansion