Commit 13230c68 by Arnaud Charlet

[multiple changes]

2017-01-23  Eric Botcazou  <ebotcazou@adacore.com>

	* checks.adb: Minor fix in comment.

2017-01-23  Philippe Gil  <gil@adacore.com>

	* g-debpoo.adb (Do_Report) remove freed chunks from chunks
	count in Sort = Memory_Usage or Allocations_Count

2017-01-23  Justin Squirek  <squirek@adacore.com>

	* sem_ch3.adb: Code cleanup.

2017-01-23  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_prag.adb (Analyze_Refined_Depends_In_Decl_Part): Move all global
	variables to the local variable section. Update the profile
	of various nested routine that previously had visibility
	of those globals. One the matching phase has completed,
	remove certain classes of clauses which are considered noise.
	(Check_Dependency_Clause): Properly detect a match between two
	'Result attributes. Update the various post-match cases to use
	Is_Already_Matched as this routine now automatically recognizes
	a previously matched 'Result attribute.
	(Is_Already_Matched): New routine.
	(Remove_Extra_Clauses): New routine.
	(Report_Extra_Clauses): Remove the detection of ... => null
	clauses as this is now done in Remove_Extra_Clauses.

From-SVN: r244782
parent 0d1e3cc9
2017-01-23 Eric Botcazou <ebotcazou@adacore.com>
* checks.adb: Minor fix in comment.
2017-01-23 Philippe Gil <gil@adacore.com>
* g-debpoo.adb (Do_Report) remove freed chunks from chunks
count in Sort = Memory_Usage or Allocations_Count
2017-01-23 Justin Squirek <squirek@adacore.com>
* sem_ch3.adb: Code cleanup.
2017-01-23 Hristian Kirtchev <kirtchev@adacore.com>
* sem_prag.adb (Analyze_Refined_Depends_In_Decl_Part): Move all global
variables to the local variable section. Update the profile
of various nested routine that previously had visibility
of those globals. One the matching phase has completed,
remove certain classes of clauses which are considered noise.
(Check_Dependency_Clause): Properly detect a match between two
'Result attributes. Update the various post-match cases to use
Is_Already_Matched as this routine now automatically recognizes
a previously matched 'Result attribute.
(Is_Already_Matched): New routine.
(Remove_Extra_Clauses): New routine.
(Report_Extra_Clauses): Remove the detection of ... => null
clauses as this is now done in Remove_Extra_Clauses.
2017-01-23 Ed Schonberg <schonberg@adacore.com> 2017-01-23 Ed Schonberg <schonberg@adacore.com>
* sem_aggr.adb (Resolve_Array_Aggregate): In ASIS mode do not * sem_aggr.adb (Resolve_Array_Aggregate): In ASIS mode do not
......
...@@ -826,10 +826,10 @@ package body Checks is ...@@ -826,10 +826,10 @@ package body Checks is
-- Apply_Arithmetic_Overflow_Strict -- -- Apply_Arithmetic_Overflow_Strict --
-------------------------------------- --------------------------------------
-- This routine is called only if the type is an integer type, and a -- This routine is called only if the type is an integer type and an
-- software arithmetic overflow check may be needed for op (add, subtract, -- arithmetic overflow check may be needed for op (add, subtract, or
-- or multiply). This check is performed only if Software_Overflow_Checking -- multiply). This check is performed if Backend_Overflow_Checks_On_Target
-- is enabled and Do_Overflow_Check is set. In this case we expand the -- is not enabled and Do_Overflow_Check is set. In this case we expand the
-- operation into a more complex sequence of tests that ensures that -- operation into a more complex sequence of tests that ensures that
-- overflow is properly caught. -- overflow is properly caught.
......
...@@ -2028,14 +2028,23 @@ package body GNAT.Debug_Pools is ...@@ -2028,14 +2028,23 @@ package body GNAT.Debug_Pools is
P := Percent (100.0 * Float (Total) / Grand_Total); P := Percent (100.0 * Float (Total) / Grand_Total);
if Sort = Marked_Blocks then case Sort is
when Memory_Usage | Allocations_Count | All_Reports =>
declare
Count : constant Natural :=
Max (M).Count - Max (M).Frees;
begin
Put (P'Img & "%:" & Total'Img & " bytes in"
& Count'Img & " chunks at");
end;
when Sort_Total_Allocs =>
Put (P'Img & "%:" & Total'Img & " bytes in"
& Max (M).Count'Img & " chunks at");
when Marked_Blocks =>
Put (P'Img & "%:" Put (P'Img & "%:"
& Max (M).Count'Img & " chunks /" & Max (M).Count'Img & " chunks /"
& Integer (Grand_Total)'Img & " at"); & Integer (Grand_Total)'Img & " at");
else end case;
Put (P'Img & "%:" & Total'Img & " bytes in"
& Max (M).Count'Img & " chunks at");
end if;
end; end;
for J in Max (M).Traceback'Range loop for J in Max (M).Traceback'Range loop
......
...@@ -2634,10 +2634,12 @@ package body Sem_Ch3 is ...@@ -2634,10 +2634,12 @@ package body Sem_Ch3 is
elsif not Analyzed (Next_Decl) and then Is_Body (Next_Decl) then elsif not Analyzed (Next_Decl) and then Is_Body (Next_Decl) then
-- If there is an array type that uses a private type from an -- Check for an edge case that may cause premature freezing of a
-- enclosing package which is in the same scope as an expression -- private type.
-- function that is not a completion then we cannot freeze here.
-- So identify the case here and delay freezing. -- If there is an array type which uses a private type from an
-- enclosing package that is in the same scope as a non-completing
-- expression function then we cannot freeze here.
Ignore_Freezing := False; Ignore_Freezing := False;
...@@ -2646,9 +2648,9 @@ package body Sem_Ch3 is ...@@ -2646,9 +2648,9 @@ package body Sem_Ch3 is
and then not Is_Compilation_Unit (Current_Scope) and then not Is_Compilation_Unit (Current_Scope)
and then not Is_Generic_Instance (Current_Scope) and then not Is_Generic_Instance (Current_Scope)
then then
-- Loop through all entities in the current scope to identify -- Loop through all entities in the current scope to identify
-- an instance of the edge case outlined above. -- an instance of the edge-case outlined above and ignore
-- freezeing if it is detected.
declare declare
Curr : Entity_Id := First_Entity (Current_Scope); Curr : Entity_Id := First_Entity (Current_Scope);
...@@ -2691,7 +2693,8 @@ package body Sem_Ch3 is ...@@ -2691,7 +2693,8 @@ package body Sem_Ch3 is
-- ??? A cleaner approach may be possible and/or this solution -- ??? A cleaner approach may be possible and/or this solution
-- could be extended to general-purpose late primitives, TBD. -- could be extended to general-purpose late primitives, TBD.
if not ASIS_Mode and then not Body_Seen if not ASIS_Mode
and then not Body_Seen
and then not Is_Body (Decl) and then not Is_Body (Decl)
then then
Body_Seen := True; Body_Seen := True;
......
...@@ -23772,45 +23772,35 @@ package body Sem_Prag is ...@@ -23772,45 +23772,35 @@ package body Sem_Prag is
------------------------------------------ ------------------------------------------
procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
Body_Inputs : Elist_Id := No_Elist;
Body_Outputs : Elist_Id := No_Elist;
-- The inputs and outputs of the subprogram body synthesized from pragma
-- Refined_Depends.
Dependencies : List_Id := No_List;
Depends : Node_Id;
-- The corresponding Depends pragma along with its clauses
Matched_Items : Elist_Id := No_Elist;
-- A list containing the entities of all successfully matched items
-- found in pragma Depends.
Refinements : List_Id := No_List;
-- The clauses of pragma Refined_Depends
Spec_Id : Entity_Id;
-- The entity of the subprogram subject to pragma Refined_Depends
Spec_Inputs : Elist_Id := No_Elist;
Spec_Outputs : Elist_Id := No_Elist;
-- The inputs and outputs of the subprogram spec synthesized from pragma
-- Depends.
procedure Check_Dependency_Clause procedure Check_Dependency_Clause
(States : Elist_Id; (Spec_Id : Entity_Id;
Dep_Clause : Node_Id); Dep_Clause : Node_Id;
Dep_States : Elist_Id;
Refinements : List_Id;
Matched_Items : in out Elist_Id);
-- Try to match a single dependency clause Dep_Clause against one or -- Try to match a single dependency clause Dep_Clause against one or
-- more refinement clauses found in list Refinements. Each successful -- more refinement clauses found in list Refinements. Each successful
-- match eliminates at least one refinement clause from Refinements. -- match eliminates at least one refinement clause from Refinements.
-- States is a list of states appearing in dependencies obtained by -- Spec_Id denotes the entity of the related subprogram. Dep_States
-- calling Get_States_Seen. -- denotes the entities of all abstract states which appear in pragma
-- Depends. Matched_Items contains the entities of all successfully
procedure Check_Output_States; -- matched items found in pragma Depends.
procedure Check_Output_States
(Spec_Id : Entity_Id;
Spec_Inputs : Elist_Id;
Spec_Outputs : Elist_Id;
Body_Inputs : Elist_Id;
Body_Outputs : Elist_Id);
-- Determine whether pragma Depends contains an output state with a -- Determine whether pragma Depends contains an output state with a
-- visible refinement and if so, ensure that pragma Refined_Depends -- visible refinement and if so, ensure that pragma Refined_Depends
-- mentions all its constituents as outputs. -- mentions all its constituents as outputs. Spec_Id is the entity of
-- the related subprograms. Spec_Inputs and Spec_Outputs denote the
-- inputs and outputs of the subprogram spec synthesized from pragma
-- Depends. Body_Inputs and Body_Outputs denote the inputs and outputs
-- of the subprogram body synthesized from pragma Refined_Depends.
function Get_States_Seen (Dependencies : List_Id) return Elist_Id; function Collect_States (Clauses : List_Id) return Elist_Id;
-- Given a normalized list of dependencies obtained from calling -- Given a normalized list of dependencies obtained from calling
-- Normalize_Clauses, return a list containing the entities of all -- Normalize_Clauses, return a list containing the entities of all
-- states appearing in dependencies. It helps in checking refinements -- states appearing in dependencies. It helps in checking refinements
...@@ -23822,20 +23812,38 @@ package body Sem_Prag is ...@@ -23822,20 +23812,38 @@ package body Sem_Prag is
-- each clause by creating multiple dependencies with exactly one input -- each clause by creating multiple dependencies with exactly one input
-- and one output. -- and one output.
procedure Report_Extra_Clauses; procedure Remove_Extra_Clauses
-- Emit an error for each extra clause found in list Refinements (Clauses : List_Id;
Matched_Items : Elist_Id);
-- Given a list of refinement clauses Clauses, remove all clauses whose
-- inputs and/or outputs have been previously matched. See the body for
-- all special cases. Matched_Items contains the entities of all matched
-- items found in pragma Depends.
procedure Report_Extra_Clauses
(Spec_Id : Entity_Id;
Clauses : List_Id);
-- Emit an error for each extra clause found in list Clauses. Spec_Id
-- denotes the entity of the related subprogram.
----------------------------- -----------------------------
-- Check_Dependency_Clause -- -- Check_Dependency_Clause --
----------------------------- -----------------------------
procedure Check_Dependency_Clause procedure Check_Dependency_Clause
(States : Elist_Id; (Spec_Id : Entity_Id;
Dep_Clause : Node_Id) Dep_Clause : Node_Id;
Dep_States : Elist_Id;
Refinements : List_Id;
Matched_Items : in out Elist_Id)
is is
Dep_Input : constant Node_Id := Expression (Dep_Clause); Dep_Input : constant Node_Id := Expression (Dep_Clause);
Dep_Output : constant Node_Id := First (Choices (Dep_Clause)); Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
function Is_Already_Matched (Dep_Item : Node_Id) return Boolean;
-- Determine whether dependency item Dep_Item has been matched in a
-- previous clause.
function Is_In_Out_State_Clause return Boolean; function Is_In_Out_State_Clause return Boolean;
-- Determine whether dependence clause Dep_Clause denotes an abstract -- Determine whether dependence clause Dep_Clause denotes an abstract
-- state that depends on itself (State => State). -- state that depends on itself (State => State).
...@@ -23874,6 +23882,28 @@ package body Sem_Prag is ...@@ -23874,6 +23882,28 @@ package body Sem_Prag is
procedure Record_Item (Item_Id : Entity_Id); procedure Record_Item (Item_Id : Entity_Id);
-- Store the entity of an item denoted by Item_Id in Matched_Items -- Store the entity of an item denoted by Item_Id in Matched_Items
------------------------
-- Is_Already_Matched --
------------------------
function Is_Already_Matched (Dep_Item : Node_Id) return Boolean is
Item_Id : Entity_Id := Empty;
begin
-- When the dependency item denotes attribute 'Result, check for
-- the entity of the related subprogram.
if Is_Attribute_Result (Dep_Item) then
Item_Id := Spec_Id;
elsif Is_Entity_Name (Dep_Item) then
Item_Id := Available_View (Entity_Of (Dep_Item));
end if;
return
Present (Item_Id) and then Contains (Matched_Items, Item_Id);
end Is_Already_Matched;
---------------------------- ----------------------------
-- Is_In_Out_State_Clause -- -- Is_In_Out_State_Clause --
---------------------------- ----------------------------
...@@ -23950,9 +23980,14 @@ package body Sem_Prag is ...@@ -23950,9 +23980,14 @@ package body Sem_Prag is
-- Attribute 'Result matches attribute 'Result -- Attribute 'Result matches attribute 'Result
-- ??? this is incorrect, Ref_Item should be checked as well elsif Is_Attribute_Result (Dep_Item)
and then Is_Attribute_Result (Ref_Item)
then
-- Put the entity of the related function on the list of
-- matched items because attribute 'Result does not carry
-- an entity similar to states and constituents.
elsif Is_Attribute_Result (Dep_Item) then Record_Item (Spec_Id);
Matched := True; Matched := True;
-- Abstract states, current instances of concurrent types, -- Abstract states, current instances of concurrent types,
...@@ -23988,7 +24023,7 @@ package body Sem_Prag is ...@@ -23988,7 +24023,7 @@ package body Sem_Prag is
E_Variable) E_Variable)
and then Present (Encapsulating_State (Ref_Item_Id)) and then Present (Encapsulating_State (Ref_Item_Id))
and then Find_Encapsulating_State and then Find_Encapsulating_State
(States, Ref_Item_Id) = Dep_Item_Id (Dep_States, Ref_Item_Id) = Dep_Item_Id
then then
Record_Item (Dep_Item_Id); Record_Item (Dep_Item_Id);
Matched := True; Matched := True;
...@@ -24029,9 +24064,11 @@ package body Sem_Prag is ...@@ -24029,9 +24064,11 @@ package body Sem_Prag is
procedure Record_Item (Item_Id : Entity_Id) is procedure Record_Item (Item_Id : Entity_Id) is
begin begin
if not Contains (Matched_Items, Item_Id) then if No (Matched_Items) then
Append_New_Elmt (Item_Id, Matched_Items); Matched_Items := New_Elmt_List;
end if; end if;
Append_Unique_Elmt (Item_Id, Matched_Items);
end Record_Item; end Record_Item;
-- Local variables -- Local variables
...@@ -24130,8 +24167,8 @@ package body Sem_Prag is ...@@ -24130,8 +24167,8 @@ package body Sem_Prag is
-- Depending on the order or composition of refinement clauses, an -- Depending on the order or composition of refinement clauses, an
-- In_Out state clause may not be directly refinable. -- In_Out state clause may not be directly refinable.
-- Depends => ((Output, State) => (Input, State))
-- Refined_State => (State => (Constit_1, Constit_2)) -- Refined_State => (State => (Constit_1, Constit_2))
-- Depends => ((Output, State) => (Input, State))
-- Refined_Depends => (Constit_1 => Input, Output => Constit_2) -- Refined_Depends => (Constit_1 => Input, Output => Constit_2)
-- Matching normalized clause (State => State) fails because there is -- Matching normalized clause (State => State) fails because there is
...@@ -24143,25 +24180,24 @@ package body Sem_Prag is ...@@ -24143,25 +24180,24 @@ package body Sem_Prag is
if not Clause_Matched if not Clause_Matched
and then Is_In_Out_State_Clause and then Is_In_Out_State_Clause
and then and then Is_Already_Matched (Dep_Input)
Contains (Matched_Items, Available_View (Entity_Of (Dep_Input)))
then then
Clause_Matched := True; Clause_Matched := True;
end if; end if;
-- A clause where the input is an abstract state with visible null -- A clause where the input is an abstract state with visible null
-- refinement is implicitly matched when the output has already been -- refinement or a 'Result attribute is implicitly matched when the
-- matched in a previous clause. -- output has already been matched in a previous clause.
-- Depends => (Output => State) -- implicitly OK
-- Refined_State => (State => null) -- Refined_State => (State => null)
-- Depends => (Output => State) -- implicitly OK
-- Refined_Depends => (Output => ...) -- Refined_Depends => (Output => ...)
-- Depends => (...'Result => State) -- implicitly OK
-- Refined_Depends => (...'Result => ...)
if not Clause_Matched if not Clause_Matched
and then Is_Null_Refined_State (Dep_Input) and then Is_Null_Refined_State (Dep_Input)
and then Is_Entity_Name (Dep_Output) and then Is_Already_Matched (Dep_Output)
and then
Contains (Matched_Items, Available_View (Entity_Of (Dep_Output)))
then then
Clause_Matched := True; Clause_Matched := True;
end if; end if;
...@@ -24170,15 +24206,13 @@ package body Sem_Prag is ...@@ -24170,15 +24206,13 @@ package body Sem_Prag is
-- refinement is implicitly matched when the input has already been -- refinement is implicitly matched when the input has already been
-- matched in a previous clause. -- matched in a previous clause.
-- Depends => (State => Input) -- implicitly OK
-- Refined_State => (State => null) -- Refined_State => (State => null)
-- Depends => (State => Input) -- implicitly OK
-- Refined_Depends => (... => Input) -- Refined_Depends => (... => Input)
if not Clause_Matched if not Clause_Matched
and then Is_Null_Refined_State (Dep_Output) and then Is_Null_Refined_State (Dep_Output)
and then Is_Entity_Name (Dep_Input) and then Is_Already_Matched (Dep_Input)
and then
Contains (Matched_Items, Available_View (Entity_Of (Dep_Input)))
then then
Clause_Matched := True; Clause_Matched := True;
end if; end if;
...@@ -24187,8 +24221,8 @@ package body Sem_Prag is ...@@ -24187,8 +24221,8 @@ package body Sem_Prag is
-- pragma Refined_Depends contains a solitary null. Only an abstract -- pragma Refined_Depends contains a solitary null. Only an abstract
-- state with null refinement can possibly match these cases. -- state with null refinement can possibly match these cases.
-- Depends => (State => null)
-- Refined_State => (State => null) -- Refined_State => (State => null)
-- Depends => (State => null)
-- Refined_Depends => null -- OK -- Refined_Depends => null -- OK
if not Clause_Matched then if not Clause_Matched then
...@@ -24220,7 +24254,13 @@ package body Sem_Prag is ...@@ -24220,7 +24254,13 @@ package body Sem_Prag is
-- Check_Output_States -- -- Check_Output_States --
------------------------- -------------------------
procedure Check_Output_States is procedure Check_Output_States
(Spec_Id : Entity_Id;
Spec_Inputs : Elist_Id;
Spec_Outputs : Elist_Id;
Body_Inputs : Elist_Id;
Body_Outputs : Elist_Id)
is
procedure Check_Constituent_Usage (State_Id : Entity_Id); procedure Check_Constituent_Usage (State_Id : Entity_Id);
-- Determine whether all constituents of state State_Id with full -- Determine whether all constituents of state State_Id with full
-- visible refinement are used as outputs in pragma Refined_Depends. -- visible refinement are used as outputs in pragma Refined_Depends.
...@@ -24350,54 +24390,63 @@ package body Sem_Prag is ...@@ -24350,54 +24390,63 @@ package body Sem_Prag is
end if; end if;
end Check_Output_States; end Check_Output_States;
--------------------- --------------------
-- Get_States_Seen -- -- Collect_States --
--------------------- --------------------
function Get_States_Seen (Dependencies : List_Id) return Elist_Id is
States_Seen : Elist_Id := No_Elist;
procedure Get_State (Glob_Item : Node_Id); function Collect_States (Clauses : List_Id) return Elist_Id is
-- Add global item to States_Seen when it corresponds to a state procedure Collect_State
(Item : Node_Id;
States : in out Elist_Id);
-- Add the entity of Item to list States when it denotes to a state
--------------- -------------------
-- Get_State -- -- Collect_State --
--------------- -------------------
procedure Get_State (Glob_Item : Node_Id) is procedure Collect_State
(Item : Node_Id;
States : in out Elist_Id)
is
Id : Entity_Id; Id : Entity_Id;
begin begin
if Is_Entity_Name (Glob_Item) then if Is_Entity_Name (Item) then
Id := Entity_Of (Glob_Item); Id := Entity_Of (Item);
if Ekind (Id) = E_Abstract_State then if Ekind (Id) = E_Abstract_State then
Append_New_Elmt (Id, States_Seen); if No (States) then
States := New_Elmt_List;
end if;
Append_Unique_Elmt (Id, States);
end if; end if;
end if; end if;
end Get_State; end Collect_State;
-- Local variables -- Local variables
Dep_Clause : Node_Id; Clause : Node_Id;
Dep_Input : Node_Id; Input : Node_Id;
Dep_Output : Node_Id; Output : Node_Id;
States : Elist_Id := No_Elist;
-- Start of processing for Get_States_Seen -- Start of processing for Collect_States
begin begin
Dep_Clause := First (Dependencies); Clause := First (Clauses);
while Present (Dep_Clause) loop while Present (Clause) loop
Dep_Input := Expression (Dep_Clause); Input := Expression (Clause);
Dep_Output := First (Choices (Dep_Clause)); Output := First (Choices (Clause));
Get_State (Dep_Input); Collect_State (Input, States);
Get_State (Dep_Output); Collect_State (Output, States);
Next (Dep_Clause); Next (Clause);
end loop; end loop;
return States_Seen; return States;
end Get_States_Seen; end Collect_States;
----------------------- -----------------------
-- Normalize_Clauses -- -- Normalize_Clauses --
...@@ -24565,10 +24614,90 @@ package body Sem_Prag is ...@@ -24565,10 +24614,90 @@ package body Sem_Prag is
end Normalize_Clauses; end Normalize_Clauses;
-------------------------- --------------------------
-- Remove_Extra_Clauses --
--------------------------
procedure Remove_Extra_Clauses
(Clauses : List_Id;
Matched_Items : Elist_Id)
is
Clause : Node_Id;
Input : Node_Id;
Input_Id : Entity_Id;
Next_Clause : Node_Id;
Output : Node_Id;
State_Id : Entity_Id;
begin
Clause := First (Clauses);
while Present (Clause) loop
Next_Clause := Next (Clause);
Input := Expression (Clause);
Output := First (Choices (Clause));
-- Recognize a clause of the form
-- null => Input
-- where Input is a constituent of a state which was already
-- successfully matched. This clause must be removed because it
-- simply indicates that some of the constituents of the state
-- are not used.
-- Refined_State => (State => (Constit_1, Constit_2))
-- Depends => (Output => State)
-- Refined_Depends => ((Output => Constit_1), -- State matched
-- (null => Constit_2)) -- OK
if Nkind (Output) = N_Null and then Is_Entity_Name (Input) then
-- Handle abstract views generated for limited with clauses
Input_Id := Available_View (Entity_Of (Input));
-- The input must be a constituent of a state
if Ekind_In (Input_Id, E_Abstract_State,
E_Constant,
E_Variable)
and then Present (Encapsulating_State (Input_Id))
then
State_Id := Encapsulating_State (Input_Id);
-- The state must have a non-null visible refinement and be
-- matched in a previous clause.
if Has_Non_Null_Visible_Refinement (State_Id)
and then Contains (Matched_Items, State_Id)
then
Remove (Clause);
end if;
end if;
-- Recognize a clause of the form
-- Output => null
-- where Output is an arbitrary item. This clause must be removed
-- because a null input legitimately matches anything.
elsif Nkind (Input) = N_Null then
Remove (Clause);
end if;
Clause := Next_Clause;
end loop;
end Remove_Extra_Clauses;
--------------------------
-- Report_Extra_Clauses -- -- Report_Extra_Clauses --
-------------------------- --------------------------
procedure Report_Extra_Clauses is procedure Report_Extra_Clauses
(Spec_Id : Entity_Id;
Clauses : List_Id)
is
Clause : Node_Id; Clause : Node_Id;
begin begin
...@@ -24578,23 +24707,12 @@ package body Sem_Prag is ...@@ -24578,23 +24707,12 @@ package body Sem_Prag is
if Is_Generic_Instance (Spec_Id) then if Is_Generic_Instance (Spec_Id) then
null; null;
elsif Present (Refinements) then elsif Present (Clauses) then
Clause := First (Refinements); Clause := First (Clauses);
while Present (Clause) loop while Present (Clause) loop
-- Do not complain about a null input refinement, since a null
-- input legitimately matches anything.
if Nkind (Clause) = N_Component_Association
and then Nkind (Expression (Clause)) = N_Null
then
null;
else
SPARK_Msg_N SPARK_Msg_N
("unmatched or extra clause in dependence refinement", ("unmatched or extra clause in dependence refinement",
Clause); Clause);
end if;
Next (Clause); Next (Clause);
end loop; end loop;
...@@ -24606,10 +24724,40 @@ package body Sem_Prag is ...@@ -24606,10 +24724,40 @@ package body Sem_Prag is
Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N); Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
Body_Id : constant Entity_Id := Defining_Entity (Body_Decl); Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
Errors : constant Nat := Serious_Errors_Detected; Errors : constant Nat := Serious_Errors_Detected;
Clause : Node_Id;
Deps : Node_Id; Deps : Node_Id;
Dummy : Boolean; Dummy : Boolean;
Refs : Node_Id; Refs : Node_Id;
Body_Inputs : Elist_Id := No_Elist;
Body_Outputs : Elist_Id := No_Elist;
-- The inputs and outputs of the subprogram body synthesized from pragma
-- Refined_Depends.
Dependencies : List_Id := No_List;
Depends : Node_Id;
-- The corresponding Depends pragma along with its clauses
Matched_Items : Elist_Id := No_Elist;
-- A list containing the entities of all successfully matched items
-- found in pragma Depends.
Refinements : List_Id := No_List;
-- The clauses of pragma Refined_Depends
Spec_Id : Entity_Id;
-- The entity of the subprogram subject to pragma Refined_Depends
Spec_Inputs : Elist_Id := No_Elist;
Spec_Outputs : Elist_Id := No_Elist;
-- The inputs and outputs of the subprogram spec synthesized from pragma
-- Depends.
States : Elist_Id := No_Elist;
-- A list containing the entities of all states whose constituents
-- appear in pragma Depends.
-- Start of processing for Analyze_Refined_Depends_In_Decl_Part -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
begin begin
...@@ -24690,7 +24838,12 @@ package body Sem_Prag is ...@@ -24690,7 +24838,12 @@ package body Sem_Prag is
-- For an output state with a visible refinement, ensure that all -- For an output state with a visible refinement, ensure that all
-- constituents appear as outputs in the dependency refinement. -- constituents appear as outputs in the dependency refinement.
Check_Output_States; Check_Output_States
(Spec_Id => Spec_Id,
Spec_Inputs => Spec_Inputs,
Spec_Outputs => Spec_Outputs,
Body_Inputs => Body_Inputs,
Body_Outputs => Body_Outputs);
end if; end if;
-- Matching is disabled in ASIS because clauses are not normalized as -- Matching is disabled in ASIS because clauses are not normalized as
...@@ -24708,6 +24861,10 @@ package body Sem_Prag is ...@@ -24708,6 +24861,10 @@ package body Sem_Prag is
Dependencies := New_Copy_List_Tree (Component_Associations (Deps)); Dependencies := New_Copy_List_Tree (Component_Associations (Deps));
Normalize_Clauses (Dependencies); Normalize_Clauses (Dependencies);
-- Gather all states which appear in Depends
States := Collect_States (Dependencies);
Refs := Expression (Get_Argument (N, Spec_Id)); Refs := Expression (Get_Argument (N, Spec_Id));
if Nkind (Refs) = N_Null then if Nkind (Refs) = N_Null then
...@@ -24727,20 +24884,33 @@ package body Sem_Prag is ...@@ -24727,20 +24884,33 @@ package body Sem_Prag is
-- and one input. Examine all clauses of pragma Depends looking for -- and one input. Examine all clauses of pragma Depends looking for
-- matching clauses in pragma Refined_Depends. -- matching clauses in pragma Refined_Depends.
declare
States_Seen : constant Elist_Id := Get_States_Seen (Dependencies);
Clause : Node_Id;
begin
Clause := First (Dependencies); Clause := First (Dependencies);
while Present (Clause) loop while Present (Clause) loop
Check_Dependency_Clause (States_Seen, Clause); Check_Dependency_Clause
(Spec_Id => Spec_Id,
Dep_Clause => Clause,
Dep_States => States,
Refinements => Refinements,
Matched_Items => Matched_Items);
Next (Clause); Next (Clause);
end loop; end loop;
end;
-- Pragma Refined_Depends may contain multiple clarification clauses
-- which indicate that certain constituents do not influence the data
-- flow in any way. Such clauses must be removed as long as the state
-- has been matched, otherwise they will be incorrectly flagged as
-- unmatched.
-- Refined_State => (State => (Constit_1, Constit_2))
-- Depends => (Output => State)
-- Refined_Depends => ((Output => Constit_1), -- State matched
-- (null => Constit_2)) -- must be removed
Remove_Extra_Clauses (Refinements, Matched_Items);
if Serious_Errors_Detected = Errors then if Serious_Errors_Detected = Errors then
Report_Extra_Clauses; Report_Extra_Clauses (Spec_Id, Refinements);
end if; end if;
end if; end if;
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment