From 426908f87ab8ea423221533f456be986f470d555 Mon Sep 17 00:00:00 2001 From: Robert Dewar Date: Fri, 10 Jul 2009 11:11:16 +0200 Subject: [PATCH] exp_ch4.adb (Raise_Accessibility_Error): New procedure 2009-07-10 Robert Dewar * exp_ch4.adb (Raise_Accessibility_Error): New procedure From-SVN: r149463 --- gcc/ada/exp_ch4.adb | 32 +++++++++++++++++++++++--------- 1 file changed, 23 insertions(+), 9 deletions(-) diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 22179e0b588..880d4a02f71 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -7519,6 +7519,11 @@ package body Exp_Ch4 is -- assignment to temporary. If there is no change of representation, -- then the conversion node is unchanged. + procedure Raise_Accessibility_Error; + -- Called when we know that an accessibility check will fail. Rewrites + -- node N to an appropriate raise statement and outputs warning msgs. + -- The Etype of the raise node is set to Target_Type. + procedure Real_Range_Check; -- Handles generation of range check for real target value @@ -7648,6 +7653,22 @@ package body Exp_Ch4 is end if; end Handle_Changed_Representation; + ------------------------------- + -- Raise_Accessibility_Error -- + ------------------------------- + + procedure Raise_Accessibility_Error is + begin + Rewrite (N, + Make_Raise_Program_Error (Sloc (N), + Reason => PE_Accessibility_Check_Failed)); + Set_Etype (N, Target_Type); + + Error_Msg_N ("?accessibility check failure", N); + Error_Msg_NE + ("\?& will be raised at run time", N, Standard_Program_Error); + end Raise_Accessibility_Error; + ---------------------- -- Real_Range_Check -- ---------------------- @@ -7884,10 +7905,7 @@ package body Exp_Ch4 is and then Type_Access_Level (Operand_Type) > Type_Access_Level (Target_Type) then - Rewrite (N, - Make_Raise_Program_Error (Sloc (N), - Reason => PE_Accessibility_Check_Failed)); - Set_Etype (N, Target_Type); + Raise_Accessibility_Error; -- When the operand is a selected access discriminant the check needs -- to be made against the level of the object denoted by the prefix @@ -7901,11 +7919,7 @@ package body Exp_Ch4 is and then Object_Access_Level (Operand) > Type_Access_Level (Target_Type) then - Rewrite (N, - Make_Raise_Program_Error (Sloc (N), - Reason => PE_Accessibility_Check_Failed)); - Set_Etype (N, Target_Type); - + Raise_Accessibility_Error; return; end if; end if; -- 2.30.2