This prevents the compiler from generating a length check that can
never fail for the initialization of an array whose nominal subtype
is unconstrained and which is subject to an address clause.
Tested on x86_64-pc-linux-gnu, committed on trunk
2020-06-17 Eric Botcazou <ebotca...@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.--- gcc/ada/checks.adb
+++ 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 --
-------------------------------------
--- gcc/ada/checks.ads
+++ 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;
--- gcc/ada/exp_ch5.adb
+++ 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.
--- gcc/ada/sem_ch5.adb
+++ 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
