From: Ronan Desplanques <desplanq...@adacore.com> This fixes an issue where length checks were not generated when the right-hand side of an assigment involved a case expression.
gcc/ada/ * sem_res.adb (Resolve_Case_Expression): Add length check insertion. * exp_ch4.adb (Expand_N_Case_Expression): Add handling of nodes known to raise Constraint_Error. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_ch4.adb | 18 ++++++++++++++---- gcc/ada/sem_res.adb | 3 +++ 2 files changed, 17 insertions(+), 4 deletions(-) diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 7a2003691ec..448cd5c82b6 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -5098,10 +5098,20 @@ package body Exp_Ch4 is else if not Is_Copy_Type (Typ) then - Alt_Expr := - Make_Attribute_Reference (Alt_Loc, - Prefix => Relocate_Node (Alt_Expr), - Attribute_Name => Name_Unrestricted_Access); + -- It's possible that a call to Apply_Length_Check in + -- Resolve_Case_Expression rewrote the dependent expression + -- into a N_Raise_Constraint_Error. If that's the case, we + -- don't create a reference to Unrestricted_Access, but we + -- update the type of the N_Raise_Constraint_Error node. + + if Nkind (Alt_Expr) in N_Raise_Constraint_Error then + Set_Etype (Alt_Expr, Target_Typ); + else + Alt_Expr := + Make_Attribute_Reference (Alt_Loc, + Prefix => Relocate_Node (Alt_Expr), + Attribute_Name => Name_Unrestricted_Access); + end if; end if; LHS := New_Occurrence_Of (Target, Loc); diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 85795ba3a05..d2eca7c5459 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -7438,6 +7438,9 @@ package body Sem_Res is if Is_Scalar_Type (Alt_Typ) and then Alt_Typ /= Typ then Rewrite (Alt_Expr, Convert_To (Typ, Alt_Expr)); Analyze_And_Resolve (Alt_Expr, Typ); + + elsif Is_Array_Type (Typ) then + Apply_Length_Check (Alt_Expr, Typ); end if; Next (Alt); -- 2.43.2