diff options
author | Ronan Desplanques <desplanques@adacore.com> | 2024-02-23 13:07:17 +0100 |
---|---|---|
committer | Marc Poulhiès <poulhies@adacore.com> | 2024-05-16 10:49:32 +0200 |
commit | a802cb3c5f530e77dabcb6343d79cb7a24f96ed3 (patch) | |
tree | c048ad520d78db4ad71f44ead309ea65005e4d30 | |
parent | 8e22376d8e2f2dd97e364aaf81a2b4260847e308 (diff) | |
download | gcc-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.adb | 13 |
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); |