aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorRonan Desplanques <desplanques@adacore.com>2024-02-23 13:07:17 +0100
committerMarc Poulhiès <poulhies@adacore.com>2024-05-16 10:49:32 +0200
commita802cb3c5f530e77dabcb6343d79cb7a24f96ed3 (patch)
treec048ad520d78db4ad71f44ead309ea65005e4d30
parent8e22376d8e2f2dd97e364aaf81a2b4260847e308 (diff)
downloadgcc-a802cb3c5f530e77dabcb6343d79cb7a24f96ed3.zip
gcc-a802cb3c5f530e77dabcb6343d79cb7a24f96ed3.tar.gz
gcc-a802cb3c5f530e77dabcb6343d79cb7a24f96ed3.tar.bz2
ada: Fix reason code for length check
This patch fixes the reason code used by Apply_Selected_Length_Checks, which was wrong in some cases when the check could be determined to always fail at compile time. gcc/ada/ * checks.adb (Apply_Selected_Length_Checks): Fix reason code.
-rw-r--r--gcc/ada/checks.adb13
1 files changed, 8 insertions, 5 deletions
diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb
index 4e3eb50..6af392e 100644
--- a/gcc/ada/checks.adb
+++ b/gcc/ada/checks.adb
@@ -322,7 +322,8 @@ package body Checks is
-- that the access value is non-null, since the checks do not
-- not apply to null access values.
- procedure Install_Static_Check (R_Cno : Node_Id; Loc : Source_Ptr);
+ procedure Install_Static_Check
+ (R_Cno : Node_Id; Loc : Source_Ptr; Reason : RT_Exception_Code);
-- Called by Apply_{Length,Range}_Checks to rewrite the tree with the
-- Constraint_Error node.
@@ -3001,7 +3002,7 @@ package body Checks is
Insert_Action (Insert_Node, R_Cno);
else
- Install_Static_Check (R_Cno, Loc);
+ Install_Static_Check (R_Cno, Loc, CE_Range_Check_Failed);
end if;
end loop;
end Apply_Range_Check;
@@ -3469,7 +3470,7 @@ package body Checks is
end if;
else
- Install_Static_Check (R_Cno, Loc);
+ Install_Static_Check (R_Cno, Loc, CE_Length_Check_Failed);
end if;
end loop;
end Apply_Selected_Length_Checks;
@@ -8692,14 +8693,16 @@ package body Checks is
-- Install_Static_Check --
--------------------------
- procedure Install_Static_Check (R_Cno : Node_Id; Loc : Source_Ptr) is
+ procedure Install_Static_Check
+ (R_Cno : Node_Id; Loc : Source_Ptr; Reason : RT_Exception_Code)
+ is
Stat : constant Boolean := Is_OK_Static_Expression (R_Cno);
Typ : constant Entity_Id := Etype (R_Cno);
begin
Rewrite (R_Cno,
Make_Raise_Constraint_Error (Loc,
- Reason => CE_Range_Check_Failed));
+ Reason => Reason));
Set_Analyzed (R_Cno);
Set_Etype (R_Cno, Typ);
Set_Raises_Constraint_Error (R_Cno);