From 85be939ea97a39df3c15f2dac34da0cb1d55fc1d Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Fri, 28 Apr 2017 15:37:44 +0200 Subject: [PATCH] [multiple changes] 2017-04-28 Bob Duff * sem_util.ads, sem_util.adb (Might_Raise): New function that replaces Is_Exception_Safe, but has the opposite sense. Is_Exception_Safe was missing various cases -- calls inside a pragma Debug, calls inside an 'if' or assignment statement, etc. Might_Raise now walks the entire subtree looking for things that can raise. * exp_ch9.adb (Is_Exception_Safe): Remove. (Build_Protected_Subprogram_Body): Replace call to Is_Exception_Safe with "not Might_Raise". Misc cleanup (use constants where possible). * exp_ch7.adb: Rename Is_Protected_Body --> Is_Protected_Subp_Body. A protected_body is something different in the grammar. 2017-04-28 Eric Botcazou * inline.adb (Expand_Inlined_Call): Initialize Targ1 variable. * par-ch3.adb (P_Component_Items): Initialize Decl_Node variable. (P_Discrete_Choice_List): Initialize Expr_Node variable. * par-ch9.adb (P_Task): Initialize Aspect_Sloc variable. (P_Protected): Likewise. * sem_case.adb (Check_Duplicates): Add pragma Warnings on variable. * sem_ch12.adb (Preanalyze_Actuals): Initialize Vis variable. * sem_ch4.adb (List_Operand_Interps): Add pragma Warnings on variable. * sem_ch5.adb (Analyze_Assignment): Initialize Save_Full_Analysis. (Analyze_Exit_Statement): Initialize Scope_Id variable. (Analyze_Iterator_Specification): Initialize Bas variable. * sem_ch9.adb (Allows_Lock_Free_Implementation): Initialize Error_Count (Satisfies_Lock_Free_Requirements): Likewise. (Analyze_Accept_Statement): Initialize Task_Nam. 2017-04-28 Hristian Kirtchev * checks.adb (Install_Primitive_Elaboration_Check): Do not generate an elaboration check if all checks have been suppressed. 2017-04-28 Ed Schonberg * sem_ch13.adb (Analyze_Aspect_Specifications, case Interrupt_Handler and Attach_Handler): Generate reference to protected operation to prevent spurious warnings about unreferenced entities. Previous scheme failed with style checks enabled. 2017-04-28 Ed Schonberg * sem_prag.adb (Relocate_Pragmas_To_Body): A pragma Warnings that follows an expression function must not be relocated to the generated body, because it applies to the code that follows. From-SVN: r247387 --- gcc/ada/ChangeLog | 54 ++++++++++++++++++ gcc/ada/checks.adb | 10 +++- gcc/ada/exp_ch7.adb | 62 ++++++++++---------- gcc/ada/exp_ch9.adb | 131 +++++-------------------------------------- gcc/ada/inline.adb | 2 +- gcc/ada/par-ch3.adb | 4 +- gcc/ada/par-ch9.adb | 6 +- gcc/ada/sem_case.adb | 3 +- gcc/ada/sem_ch12.adb | 2 +- gcc/ada/sem_ch13.adb | 11 ++-- gcc/ada/sem_ch4.adb | 1 + gcc/ada/sem_ch5.adb | 6 +- gcc/ada/sem_ch9.adb | 6 +- gcc/ada/sem_prag.adb | 12 +++- gcc/ada/sem_util.adb | 57 +++++++++++++++++++ gcc/ada/sem_util.ads | 5 ++ 16 files changed, 200 insertions(+), 172 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 6126ee70623..a52d9b460cf 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,57 @@ +2017-04-28 Bob Duff + + * sem_util.ads, sem_util.adb (Might_Raise): New function + that replaces Is_Exception_Safe, but has the opposite + sense. Is_Exception_Safe was missing various cases -- calls inside + a pragma Debug, calls inside an 'if' or assignment statement, + etc. Might_Raise now walks the entire subtree looking for things + that can raise. + * exp_ch9.adb (Is_Exception_Safe): Remove. + (Build_Protected_Subprogram_Body): Replace call to + Is_Exception_Safe with "not Might_Raise". Misc cleanup (use + constants where possible). + * exp_ch7.adb: Rename Is_Protected_Body --> + Is_Protected_Subp_Body. A protected_body is something different + in the grammar. + +2017-04-28 Eric Botcazou + + * inline.adb (Expand_Inlined_Call): Initialize Targ1 variable. + * par-ch3.adb (P_Component_Items): Initialize Decl_Node variable. + (P_Discrete_Choice_List): Initialize Expr_Node variable. + * par-ch9.adb (P_Task): Initialize Aspect_Sloc variable. + (P_Protected): Likewise. + * sem_case.adb (Check_Duplicates): + Add pragma Warnings on variable. + * sem_ch12.adb (Preanalyze_Actuals): Initialize Vis variable. + * sem_ch4.adb (List_Operand_Interps): Add pragma Warnings on variable. + * sem_ch5.adb (Analyze_Assignment): Initialize Save_Full_Analysis. + (Analyze_Exit_Statement): Initialize Scope_Id variable. + (Analyze_Iterator_Specification): Initialize Bas variable. + * sem_ch9.adb (Allows_Lock_Free_Implementation): Initialize + Error_Count (Satisfies_Lock_Free_Requirements): Likewise. + (Analyze_Accept_Statement): Initialize Task_Nam. + +2017-04-28 Hristian Kirtchev + + * checks.adb (Install_Primitive_Elaboration_Check): + Do not generate an elaboration check if all checks have been + suppressed. + +2017-04-28 Ed Schonberg + + * sem_ch13.adb (Analyze_Aspect_Specifications, case + Interrupt_Handler and Attach_Handler): Generate reference + to protected operation to prevent spurious warnings about + unreferenced entities. Previous scheme failed with style checks + enabled. + +2017-04-28 Ed Schonberg + + * sem_prag.adb (Relocate_Pragmas_To_Body): A pragma Warnings + that follows an expression function must not be relocated to + the generated body, because it applies to the code that follows. + 2017-04-28 Gary Dismukes * sem_util.adb (Is_Dependent_Component_Of_Mutable_Object): Test diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index fa55615db7f..90d70ab9ed6 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -7795,9 +7795,10 @@ package body Checks is if ASIS_Mode or GNATprove_Mode then return; - -- Do not generate an elaboration check if such code is not desirable + -- Do not generate an elaboration check if all checks have been + -- suppressed. - elsif Restriction_Active (No_Elaboration_Code) then + elsif Suppress_Checks then return; -- Do not generate an elaboration check if the related subprogram is @@ -7806,6 +7807,11 @@ package body Checks is elsif Elaboration_Checks_Suppressed (Subp_Id) then return; + -- Do not generate an elaboration check if such code is not desirable + + elsif Restriction_Active (No_Elaboration_Code) then + return; + -- Do not consider subprograms which act as compilation units, because -- they cannot be the target of a dispatching call. diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 0a9bc0ed828..4baca7cca3e 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -4176,37 +4176,37 @@ package body Exp_Ch7 is procedure Expand_Cleanup_Actions (N : Node_Id) is Scop : constant Entity_Id := Current_Scope; - Is_Asynchronous_Call : constant Boolean := - Nkind (N) = N_Block_Statement - and then Is_Asynchronous_Call_Block (N); - Is_Master : constant Boolean := - Nkind (N) /= N_Entry_Body - and then Is_Task_Master (N); - Is_Protected_Body : constant Boolean := - Nkind (N) = N_Subprogram_Body - and then Is_Protected_Subprogram_Body (N); - Is_Task_Allocation : constant Boolean := - Nkind (N) = N_Block_Statement - and then Is_Task_Allocation_Block (N); - Is_Task_Body : constant Boolean := - Nkind (Original_Node (N)) = N_Task_Body; - Needs_Sec_Stack_Mark : constant Boolean := - Uses_Sec_Stack (Scop) - and then - not Sec_Stack_Needed_For_Return (Scop); - Needs_Custom_Cleanup : constant Boolean := - Nkind (N) = N_Block_Statement - and then Present (Cleanup_Actions (N)); - - Actions_Required : constant Boolean := - Requires_Cleanup_Actions (N, True) - or else Is_Asynchronous_Call - or else Is_Master - or else Is_Protected_Body - or else Is_Task_Allocation - or else Is_Task_Body - or else Needs_Sec_Stack_Mark - or else Needs_Custom_Cleanup; + Is_Asynchronous_Call : constant Boolean := + Nkind (N) = N_Block_Statement + and then Is_Asynchronous_Call_Block (N); + Is_Master : constant Boolean := + Nkind (N) /= N_Entry_Body + and then Is_Task_Master (N); + Is_Protected_Subp_Body : constant Boolean := + Nkind (N) = N_Subprogram_Body + and then Is_Protected_Subprogram_Body (N); + Is_Task_Allocation : constant Boolean := + Nkind (N) = N_Block_Statement + and then Is_Task_Allocation_Block (N); + Is_Task_Body : constant Boolean := + Nkind (Original_Node (N)) = N_Task_Body; + Needs_Sec_Stack_Mark : constant Boolean := + Uses_Sec_Stack (Scop) + and then + not Sec_Stack_Needed_For_Return (Scop); + Needs_Custom_Cleanup : constant Boolean := + Nkind (N) = N_Block_Statement + and then Present (Cleanup_Actions (N)); + + Actions_Required : constant Boolean := + Requires_Cleanup_Actions (N, True) + or else Is_Asynchronous_Call + or else Is_Master + or else Is_Protected_Subp_Body + or else Is_Task_Allocation + or else Is_Task_Body + or else Needs_Sec_Stack_Mark + or else Needs_Custom_Cleanup; HSS : Node_Id := Handled_Statement_Sequence (N); Loc : Source_Ptr; diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index d10ae744583..28244c36c97 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -24,7 +24,6 @@ ------------------------------------------------------------------------------ with Atree; use Atree; -with Checks; use Checks; with Einfo; use Einfo; with Elists; use Elists; with Errout; use Errout; @@ -421,9 +420,6 @@ package body Exp_Ch9 is -- the Task_Body_Procedure of Spec_Id. The returned entity denotes formal -- parameter _E. - function Is_Exception_Safe (Subprogram : Node_Id) return Boolean; - -- Tell whether a given subprogram cannot raise an exception - function Is_Potentially_Large_Family (Base_Index : Entity_Id; Conctyp : Entity_Id; @@ -3889,30 +3885,28 @@ package body Exp_Ch9 is Pid : Node_Id; N_Op_Spec : Node_Id) return Node_Id is - Loc : constant Source_Ptr := Sloc (N); - Op_Spec : Node_Id; - P_Op_Spec : Node_Id; - Uactuals : List_Id; - Pformal : Node_Id; - Unprot_Call : Node_Id; - Sub_Body : Node_Id; + Exc_Safe : constant Boolean := not Might_Raise (N); + -- True if N cannot raise an exception + + Loc : constant Source_Ptr := Sloc (N); + Op_Spec : constant Node_Id := Specification (N); + P_Op_Spec : constant Node_Id := + Build_Protected_Sub_Specification (N, Pid, Protected_Mode); + + Lock_Kind : RE_Id; Lock_Name : Node_Id; Lock_Stmt : Node_Id; + Object_Parm : Node_Id; + Pformal : Node_Id; R : Node_Id; Return_Stmt : Node_Id := Empty; -- init to avoid gcc 3 warning Pre_Stmts : List_Id := No_List; -- init to avoid gcc 3 warning Stmts : List_Id; - Object_Parm : Node_Id; - Exc_Safe : Boolean; - Lock_Kind : RE_Id; + Sub_Body : Node_Id; + Uactuals : List_Id; + Unprot_Call : Node_Id; begin - Op_Spec := Specification (N); - Exc_Safe := Is_Exception_Safe (N); - - P_Op_Spec := - Build_Protected_Sub_Specification (N, Pid, Protected_Mode); - -- Build a list of the formal parameters of the protected version of -- the subprogram to use as the actual parameters of the unprotected -- version. @@ -13545,103 +13539,6 @@ package body Exp_Ch9 is end if; end Install_Private_Data_Declarations; - ----------------------- - -- Is_Exception_Safe -- - ----------------------- - - function Is_Exception_Safe (Subprogram : Node_Id) return Boolean is - - function Has_Side_Effect (N : Node_Id) return Boolean; - -- Return True whenever encountering a subprogram call or raise - -- statement of any kind in the sequence of statements - - --------------------- - -- Has_Side_Effect -- - --------------------- - - -- What is this doing buried two levels down in exp_ch9. It seems like a - -- generally useful function, and indeed there may be code duplication - -- going on here ??? - - function Has_Side_Effect (N : Node_Id) return Boolean is - Stmt : Node_Id; - Expr : Node_Id; - - function Is_Call_Or_Raise (N : Node_Id) return Boolean; - -- Indicate whether N is a subprogram call or a raise statement - - ---------------------- - -- Is_Call_Or_Raise -- - ---------------------- - - function Is_Call_Or_Raise (N : Node_Id) return Boolean is - begin - return Nkind_In (N, N_Procedure_Call_Statement, - N_Function_Call, - N_Raise_Statement, - N_Raise_Constraint_Error, - N_Raise_Program_Error, - N_Raise_Storage_Error); - end Is_Call_Or_Raise; - - -- Start of processing for Has_Side_Effect - - begin - Stmt := N; - while Present (Stmt) loop - if Is_Call_Or_Raise (Stmt) then - return True; - end if; - - -- An object declaration can also contain a function call or a - -- raise statement. - - if Nkind (Stmt) = N_Object_Declaration then - Expr := Expression (Stmt); - - if Present (Expr) and then Is_Call_Or_Raise (Expr) then - return True; - end if; - end if; - - Next (Stmt); - end loop; - - return False; - end Has_Side_Effect; - - -- Start of processing for Is_Exception_Safe - - begin - -- When exceptions can't be propagated, the subprogram returns normally - - if No_Exception_Handlers_Set then - return True; - end if; - - -- If the checks handled by the back end are not disabled, we cannot - -- ensure that no exception will be raised. - - if not Access_Checks_Suppressed (Empty) - or else not Discriminant_Checks_Suppressed (Empty) - or else not Range_Checks_Suppressed (Empty) - or else not Index_Checks_Suppressed (Empty) - or else Opt.Stack_Checking_Enabled - then - return False; - end if; - - if Has_Side_Effect (First (Declarations (Subprogram))) - or else - Has_Side_Effect - (First (Statements (Handled_Statement_Sequence (Subprogram)))) - then - return False; - else - return True; - end if; - end Is_Exception_Safe; - --------------------------------- -- Is_Potentially_Large_Family -- --------------------------------- diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index a5b1d98bc10..ac19c9d2c45 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -2301,7 +2301,7 @@ package body Inline is -- this is the left-hand side of the assignment, else it is a temporary -- to which the return value is assigned prior to rewriting the call. - Targ1 : Node_Id; + Targ1 : Node_Id := Empty; -- A separate target used when the return type is unconstrained Temp : Entity_Id; diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb index 529c501f26d..6553a954eb1 100644 --- a/gcc/ada/par-ch3.adb +++ b/gcc/ada/par-ch3.adb @@ -3494,7 +3494,7 @@ package body Ch3 is procedure P_Component_Items (Decls : List_Id) is Aliased_Present : Boolean := False; CompDef_Node : Node_Id; - Decl_Node : Node_Id; + Decl_Node : Node_Id := Empty; -- initialize to prevent warning Scan_State : Saved_Scan_State; Not_Null_Present : Boolean := False; Num_Idents : Nat; @@ -3754,7 +3754,7 @@ package body Ch3 is function P_Discrete_Choice_List return List_Id is Choices : List_Id; - Expr_Node : Node_Id; + Expr_Node : Node_Id := Empty; -- initialize to prevent warning Choice_Node : Node_Id; begin diff --git a/gcc/ada/par-ch9.adb b/gcc/ada/par-ch9.adb index 11b6542e54d..9e4ac07426f 100644 --- a/gcc/ada/par-ch9.adb +++ b/gcc/ada/par-ch9.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -79,7 +79,7 @@ package body Ch9 is -- Error recovery: cannot raise Error_Resync function P_Task return Node_Id is - Aspect_Sloc : Source_Ptr; + Aspect_Sloc : Source_Ptr := No_Location; Name_Node : Node_Id; Task_Node : Node_Id; Task_Sloc : Source_Ptr; @@ -425,7 +425,7 @@ package body Ch9 is -- Error recovery: cannot raise Error_Resync function P_Protected return Node_Id is - Aspect_Sloc : Source_Ptr; + Aspect_Sloc : Source_Ptr := No_Location; Name_Node : Node_Id; Protected_Node : Node_Id; Protected_Sloc : Source_Ptr; diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb index 3b3820e46b9..187a98baafc 100644 --- a/gcc/ada/sem_case.adb +++ b/gcc/ada/sem_case.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1996-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2017, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -459,6 +459,7 @@ package body Sem_Case is Choice_Hi : Uint; Choice_Lo : Uint; Prev_Choice : Node_Id; + pragma Warnings (Off, Prev_Choice); Prev_Hi : Uint; begin diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 14314419345..093a2bdf81c 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -13620,7 +13620,7 @@ package body Sem_Ch12 is Cur : Entity_Id := Empty; -- Current homograph of the instance name - Vis : Boolean; + Vis : Boolean := False; -- Saved visibility status of the current homograph begin diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index b4eda29bcae..2b92afd8a77 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -1968,15 +1968,12 @@ package body Sem_Ch13 is if A_Id = Aspect_Attach_Handler or else A_Id = Aspect_Interrupt_Handler then - -- Decorate the reference as comming from the sources and force - -- its reanalysis to generate the reference to E; required to - -- avoid reporting spurious warning on E as unreferenced entity - -- (because aspects are not fully analyzed). - Set_Comes_From_Source (Ent, Comes_From_Source (Id)); - Set_Entity (Ent, Empty); + -- Treat the specification as a reference to the protected + -- operation, which might otherwise appear unreferenced and + -- generate spurious warnings. - Analyze (Ent); + Generate_Reference (E, Id); end if; -- Check for duplicate aspect. Note that the Comes_From_Source diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 21ab45478ae..a7362a74a68 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -340,6 +340,7 @@ package body Sem_Ch4 is procedure List_Operand_Interps (Opnd : Node_Id) is Nam : Node_Id; + pragma Warnings (Off, Nam); Err : Node_Id := N; begin diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 27c3a530915..6ef90955102 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -107,7 +107,7 @@ package body Sem_Ch5 is T1 : Entity_Id; T2 : Entity_Id; - Save_Full_Analysis : Boolean; + Save_Full_Analysis : Boolean := False; -- initialize to prevent warning procedure Diagnose_Non_Variable_Lhs (N : Node_Id); -- N is the node for the left hand side of an assignment, and it is not @@ -1387,7 +1387,7 @@ package body Sem_Ch5 is procedure Analyze_Exit_Statement (N : Node_Id) is Target : constant Node_Id := Name (N); Cond : constant Node_Id := Condition (N); - Scope_Id : Entity_Id; + Scope_Id : Entity_Id := Empty; -- initialize to prevent warning U_Name : Entity_Id; Kind : Entity_Kind; @@ -1864,7 +1864,7 @@ package body Sem_Ch5 is Loc : constant Source_Ptr := Sloc (N); Subt : constant Node_Id := Subtype_Indication (N); - Bas : Entity_Id; + Bas : Entity_Id := Empty; -- initialize to prevent warning Typ : Entity_Id; -- Start of processing for Analyze_Iterator_Specification diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index 25e9cbd0a88..184fe43e50c 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -127,7 +127,7 @@ package body Sem_Ch9 is (N : Node_Id; Lock_Free_Given : Boolean := False) return Boolean is - Errors_Count : Nat; + Errors_Count : Nat := 0; -- Errors_Count is a count of errors detected by the compiler so far -- when Lock_Free_Given is True. @@ -257,7 +257,7 @@ package body Sem_Ch9 is Comp : Entity_Id := Empty; -- Track the current component which the body references - Errors_Count : Nat; + Errors_Count : Nat := 0; -- Errors_Count is a count of errors detected by the compiler -- so far when Lock_Free_Given is True. @@ -772,7 +772,7 @@ package body Sem_Ch9 is Entry_Nam : Entity_Id; E : Entity_Id; Kind : Entity_Kind; - Task_Nam : Entity_Id; + Task_Nam : Entity_Id := Empty; -- initialize to prevent warning begin Tasking_Used := True; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 9cbd2242641..6d0ecb67c7d 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -29959,7 +29959,17 @@ package body Sem_Prag is if Nkind (Stmt) = N_Pragma and then Pragma_On_Body_Or_Stub_OK (Get_Pragma_Id (Stmt)) then - Relocate_Pragma (Stmt); + + -- If a source pragma Warnings follows the body, it applies to + -- following statements and does not belong in the body. + + if Get_Pragma_Id (Stmt) = Pragma_Warnings + and then Comes_From_Source (Stmt) + then + null; + else + Relocate_Pragma (Stmt); + end if; -- Skip internally generated code diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 7a50fd2ba48..e8fc7288b3d 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -16869,6 +16869,63 @@ package body Sem_Util is Mark_Allocators (Root_Nod); end Mark_Coextensions; + ----------------- + -- Might_Raise -- + ----------------- + + function Might_Raise (N : Node_Id) return Boolean is + Result : Boolean := False; + + function Process (N : Node_Id) return Traverse_Result; + -- Set Result to True if we find something that could raise an exception + + ------------- + -- Process -- + ------------- + + function Process (N : Node_Id) return Traverse_Result is + begin + if Nkind_In (N, N_Procedure_Call_Statement, + N_Function_Call, + N_Raise_Statement, + N_Raise_Constraint_Error, + N_Raise_Program_Error, + N_Raise_Storage_Error) + then + Result := True; + return Abandon; + else + return OK; + end if; + end Process; + + procedure Set_Result is new Traverse_Proc (Process); + + -- Start of processing for Might_Raise + + begin + -- False if exceptions can't be propagated + + if No_Exception_Handlers_Set then + return False; + end if; + + -- If the checks handled by the back end are not disabled, we cannot + -- ensure that no exception will be raised. + + if not Access_Checks_Suppressed (Empty) + or else not Discriminant_Checks_Suppressed (Empty) + or else not Range_Checks_Suppressed (Empty) + or else not Index_Checks_Suppressed (Empty) + or else Opt.Stack_Checking_Enabled + then + return True; + end if; + + Set_Result (N); + return Result; + end Might_Raise; + -------------------------------- -- Nearest_Enclosing_Instance -- -------------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 3cc3df4a332..9df64228f18 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1984,6 +1984,11 @@ package Sem_Util is -- to guarantee this in all cases. Note that it is more possible to give -- correct answer if the tree is fully analyzed. + function Might_Raise (N : Node_Id) return Boolean; + -- True if evaluation of N might raise an exception. This is conservative; + -- if we're not sure, we return True. If N is a subprogram body, this is + -- about whether execution of that body can raise. + function Nearest_Enclosing_Instance (E : Entity_Id) return Entity_Id; -- Return the entity of the nearest enclosing instance which encapsulates -- entity E. If no such instance exits, return Empty. -- 2.30.2