From: Ronan Desplanques <desplanques@adacore.com>
Date: Tue, 27 Feb 2024 14:46:14 +0000 (+0100)
Subject: ada: Fix missing length checks with case expressions
X-Git-Tag: basepoints/gcc-16~8989
X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=5c9205a4d729e6fe9b8c897f4eb3ccd86dcf1835;p=thirdparty%2Fgcc.git

ada: Fix missing length checks with case expressions

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.
---

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);