From 4bfab79a72afbe0f6232668fdfa4b56a6aaea2e6 Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Fri, 24 Apr 2020 22:05:35 +0200 Subject: [PATCH] [Ada] Small cleanup in constraint checking code for allocators 2020-06-18 Eric Botcazou gcc/ada/ * exp_ch4.adb (Expand_Allocator_Expression): Apply constraint and predicate checks for the qualified expression on entry, followed by constraint and predicate checks for the allocator itself, and return early if this results in a static error. (Expand_N_Allocator): Do not do the same here. Instead apply constraint and predicate checks for arrays in the subtype indication case. * exp_ch5.adb (Expand_N_Assignment_Statement): Do not apply range checks to allocators here. --- gcc/ada/exp_ch4.adb | 101 +++++++++++++++++++++++++------------------- gcc/ada/exp_ch5.adb | 20 --------- 2 files changed, 58 insertions(+), 63 deletions(-) diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 2735a480bd4..d421a59591b 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -99,7 +99,7 @@ package body Exp_Ch4 is procedure Expand_Allocator_Expression (N : Node_Id); -- Subsidiary to Expand_N_Allocator, for the case when the expression - -- is a qualified expression or an aggregate. + -- is a qualified expression. procedure Expand_Array_Comparison (N : Node_Id); -- This routine handles expansion of the comparison operators (N_Op_Lt, @@ -781,10 +781,10 @@ package body Exp_Ch4 is -- Local variables - Aggr_In_Place : constant Boolean := Is_Delayed_Aggregate (Exp); Indic : constant Node_Id := Subtype_Mark (Expression (N)); T : constant Entity_Id := Entity (Indic); Adj_Call : Node_Id; + Aggr_In_Place : Boolean; Node : Node_Id; Tag_Assign : Node_Id; Temp : Entity_Id; @@ -808,6 +808,44 @@ package body Exp_Ch4 is return; end if; + -- If we have: + -- type A is access T1; + -- X : A := new T2'(...); + -- T1 and T2 can be different subtypes, and we might need to check + -- both constraints. First check against the type of the qualified + -- expression. + + Apply_Constraint_Check (Exp, T, No_Sliding => True); + + Apply_Predicate_Check (Exp, T); + + if Do_Range_Check (Exp) then + Generate_Range_Check (Exp, T, CE_Range_Check_Failed); + end if; + + -- A check is also needed in cases where the designated subtype is + -- constrained and differs from the subtype given in the qualified + -- expression. Note that the check on the qualified expression does + -- not allow sliding, but this check does (a relaxation from Ada 83). + + if Is_Constrained (DesigT) + and then not Subtypes_Statically_Match (T, DesigT) + then + Apply_Constraint_Check (Exp, DesigT, No_Sliding => False); + + Apply_Predicate_Check (Exp, DesigT); + + if Do_Range_Check (Exp) then + Generate_Range_Check (Exp, DesigT, CE_Range_Check_Failed); + end if; + end if; + + if Nkind (Exp) = N_Raise_Constraint_Error then + Rewrite (N, New_Copy (Exp)); + Set_Etype (N, PtrT); + return; + end if; + -- In the case of an Ada 2012 allocator whose initial value comes from a -- function call, pass "the accessibility level determined by the point -- of call" (AI05-0234) to the function. Conceptually, this belongs in @@ -837,6 +875,8 @@ package body Exp_Ch4 is end; end if; + Aggr_In_Place := Is_Delayed_Aggregate (Exp); + -- Case of tagged type or type requiring finalization if Is_Tagged_Type (T) or else Needs_Finalization (T) then @@ -1218,35 +1258,6 @@ package body Exp_Ch4 is else Build_Allocate_Deallocate_Proc (N, True); - -- If we have: - -- type A is access T1; - -- X : A := new T2'(...); - -- T1 and T2 can be different subtypes, and we might need to check - -- both constraints. First check against the type of the qualified - -- expression. - - Apply_Constraint_Check (Exp, T, No_Sliding => True); - - if Do_Range_Check (Exp) then - Generate_Range_Check (Exp, DesigT, CE_Range_Check_Failed); - end if; - - -- A check is also needed in cases where the designated subtype is - -- constrained and differs from the subtype given in the qualified - -- expression. Note that the check on the qualified expression does - -- not allow sliding, but this check does (a relaxation from Ada 83). - - if Is_Constrained (DesigT) - and then not Subtypes_Statically_Match (T, DesigT) - then - Apply_Constraint_Check - (Exp, DesigT, No_Sliding => False); - - if Do_Range_Check (Exp) then - Generate_Range_Check (Exp, DesigT, CE_Range_Check_Failed); - end if; - end if; - -- For an access to unconstrained packed array, GIGI needs to see an -- expression with a constrained subtype in order to compute the -- proper size for the allocator. @@ -4796,20 +4807,9 @@ package body Exp_Ch4 is New_Occurrence_Of (RTE (RE_Check_Standard_Allocator), Loc))); end if; - -- Handle case of qualified expression (other than optimization above). - -- First apply constraint checks, because the bounds or discriminants - -- in the aggregate might not match the subtype mark in the allocator. + -- Handle case of qualified expression (other than optimization above) if Nkind (Expression (N)) = N_Qualified_Expression then - declare - Exp : constant Node_Id := Expression (Expression (N)); - Typ : constant Entity_Id := Etype (Expression (N)); - - begin - Apply_Constraint_Check (Exp, Typ); - Apply_Predicate_Check (Exp, Typ); - end; - Expand_Allocator_Expression (N); return; end if; @@ -4842,6 +4842,21 @@ package body Exp_Ch4 is Temp_Type : Entity_Id; begin + -- Apply constraint checks against designated subtype (RM 4.8(10/2)). + -- Discriminant checks will be generated by the expansion below. + + if Is_Array_Type (Dtyp) then + Apply_Constraint_Check (Expression (N), Dtyp, No_Sliding => True); + + Apply_Predicate_Check (Expression (N), Dtyp); + + if Nkind (Expression (N)) = N_Raise_Constraint_Error then + Rewrite (N, New_Copy (Expression (N))); + Set_Etype (N, PtrT); + return; + end if; + end if; + if No_Initialization (N) then -- Even though this might be a simple allocation, create a custom diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index fd51dfa8704..db2ab18afb4 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -2447,26 +2447,6 @@ package body Exp_Ch5 is if Is_Constrained (Etype (Lhs)) then Apply_Length_Check (Rhs, Etype (Lhs)); end if; - - if Nkind (Rhs) = N_Allocator then - declare - Target_Typ : constant Entity_Id := Etype (Expression (Rhs)); - C_Es : Check_Result; - - begin - C_Es := - Get_Range_Checks - (Lhs, - Target_Typ, - Etype (Designated_Type (Etype (Lhs)))); - - Insert_Range_Checks - (C_Es, - N, - Target_Typ, - Sloc (Lhs)); - end; - end if; end if; -- Apply range check for access type case -- 2.30.2