+2017-04-28 Bob Duff <duff@adacore.com>
+
+ * 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 <ebotcazou@adacore.com>
+
+ * 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 <kirtchev@adacore.com>
+
+ * checks.adb (Install_Primitive_Elaboration_Check):
+ Do not generate an elaboration check if all checks have been
+ suppressed.
+
+2017-04-28 Ed Schonberg <schonberg@adacore.com>
+
+ * 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 <schonberg@adacore.com>
+
+ * 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 <dismukes@adacore.com>
* sem_util.adb (Is_Dependent_Component_Of_Mutable_Object): Test
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
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.
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;
------------------------------------------------------------------------------
with Atree; use Atree;
-with Checks; use Checks;
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
-- 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;
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.
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 --
---------------------------------
-- 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;
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;
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
-- --
-- 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- --
-- 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;
-- 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;
-- --
-- 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- --
Choice_Hi : Uint;
Choice_Lo : Uint;
Prev_Choice : Node_Id;
+ pragma Warnings (Off, Prev_Choice);
Prev_Hi : Uint;
begin
Cur : Entity_Id := Empty;
-- Current homograph of the instance name
- Vis : Boolean;
+ Vis : Boolean := False;
-- Saved visibility status of the current homograph
begin
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
procedure List_Operand_Interps (Opnd : Node_Id) is
Nam : Node_Id;
+ pragma Warnings (Off, Nam);
Err : Node_Id := N;
begin
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
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;
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
(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.
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.
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;
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
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 --
--------------------------------
-- 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.
projects / gcc.git / commitdiff