mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-09 21:31:30 +08:00
Code Issues Packages Projects Releases Wiki Activity

ada: Adjust classwide contract expression preanalysis

Browse Source 
Before this patch, a classwide contract expression was preanalyzed
only when its primitive operation's type was frozen. It caused name
resolution to be off in the cases where the freezing took place
after the end of the declaration list the primitive operation was
declared in.

This patch makes it so that if the compiler gets to the end of
the declaration list before the type is frozen, it preanalyzes the
classwide contract expression, so that the names are resolved in the
right context.

gcc/ada/

	* contracts.adb
	(Preanalyze_Class_Conditions): New procedure.
	(Preanalyze_Condition): Moved out from Merge_Class_Conditions in
	order to be spec-visible.
	* contracts.ads
	(Preanalyze_Class_Conditions): New procedure.
	* sem_prag.adb
	(Analyze_Pre_Post_Condition_In_Decl_Part): Call
	Preanalyze_Class_Conditions when necessary.
This commit is contained in:
Ronan Desplanques 2022-10-24 11:50:06 +02:00 committed by Marc Poulhiès
parent 48e2e5b4c2
commit 45656a992e
3 changed files with 267 additions and 232 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

481
gcc/ada/contracts.adb
View File

@ -107,6 +107,11 @@ package body Contracts is
-- well as Contract_Cases, Subprogram_Variant, invariants and predicates.
-- Body_Id denotes the entity of the subprogram body.
procedure Preanalyze_Condition
(Subp : Entity_Id;
Expr : Node_Id);
-- Preanalyze the class-wide condition Expr of Subp
procedure Set_Class_Condition
(Kind : Condition_Kind;
Subp : Entity_Id;
@ -4548,242 +4553,10 @@ package body Contracts is
procedure Merge_Class_Conditions (Spec_Id : Entity_Id) is
procedure Preanalyze_Condition
(Subp : Entity_Id;
Expr : Node_Id);
-- Preanalyze the class-wide condition Expr of Subp
procedure Process_Inherited_Conditions (Kind : Condition_Kind);
-- Collect all inherited class-wide conditions of Spec_Id and merge
-- them into one big condition.
--------------------------
-- Preanalyze_Condition --
--------------------------
procedure Preanalyze_Condition
(Subp : Entity_Id;
Expr : Node_Id)
is
procedure Clear_Unset_References;
-- Clear unset references on formals of Subp since preanalysis
-- occurs in a place unrelated to the actual code.
procedure Remove_Controlling_Arguments;
-- Traverse Expr and clear the Controlling_Argument of calls to
-- nonabstract functions.
procedure Remove_Formals (Id : Entity_Id);
-- Remove formals from homonym chains and make them not visible
procedure Restore_Original_Selected_Component;
-- Traverse Expr searching for dispatching calls to functions whose
-- original node was a selected component, and replace them with
-- their original node.
----------------------------
-- Clear_Unset_References --
----------------------------
procedure Clear_Unset_References is
F : Entity_Id := First_Formal (Subp);
begin
while Present (F) loop
Set_Unset_Reference (F, Empty);
Next_Formal (F);
end loop;
end Clear_Unset_References;
----------------------------------
-- Remove_Controlling_Arguments --
----------------------------------
procedure Remove_Controlling_Arguments is
function Remove_Ctrl_Arg (N : Node_Id) return Traverse_Result;
-- Reset the Controlling_Argument of calls to nonabstract
-- function calls.
---------------------
-- Remove_Ctrl_Arg --
---------------------
function Remove_Ctrl_Arg (N : Node_Id) return Traverse_Result is
begin
if Nkind (N) = N_Function_Call
and then Present (Controlling_Argument (N))
and then not Is_Abstract_Subprogram (Entity (Name (N)))
then
Set_Controlling_Argument (N, Empty);
end if;
return OK;
end Remove_Ctrl_Arg;
procedure Remove_Ctrl_Args is new Traverse_Proc (Remove_Ctrl_Arg);
begin
Remove_Ctrl_Args (Expr);
end Remove_Controlling_Arguments;
--------------------
-- Remove_Formals --
--------------------
procedure Remove_Formals (Id : Entity_Id) is
F : Entity_Id := First_Formal (Id);
begin
while Present (F) loop
Set_Is_Immediately_Visible (F, False);
Remove_Homonym (F);
Next_Formal (F);
end loop;
end Remove_Formals;
-----------------------------------------
-- Restore_Original_Selected_Component --
-----------------------------------------
procedure Restore_Original_Selected_Component is
Restored_Nodes_List : Elist_Id := No_Elist;
procedure Fix_Parents (N : Node_Id);
-- Traverse the subtree of N fixing the Parent field of all the
-- nodes.
function Restore_Node (N : Node_Id) return Traverse_Result;
-- Process dispatching calls to functions whose original node was
-- a selected component, and replace them with their original
-- node. Restored nodes are stored in the Restored_Nodes_List
-- to fix the parent fields of their subtrees in a separate
-- tree traversal.
-----------------
-- Fix_Parents --
-----------------
procedure Fix_Parents (N : Node_Id) is
function Fix_Parent
(Parent_Node : Node_Id;
Node : Node_Id) return Traverse_Result;
-- Process a single node
----------------
-- Fix_Parent --
----------------
function Fix_Parent
(Parent_Node : Node_Id;
Node : Node_Id) return Traverse_Result
is
Par : constant Node_Id := Parent (Node);
begin
if Par /= Parent_Node then
pragma Assert (not Is_List_Member (Node));
Set_Parent (Node, Parent_Node);
end if;
return OK;
end Fix_Parent;
procedure Fix_Parents is
new Traverse_Proc_With_Parent (Fix_Parent);
begin
Fix_Parents (N);
end Fix_Parents;
------------------
-- Restore_Node --
------------------
function Restore_Node (N : Node_Id) return Traverse_Result is
begin
if Nkind (N) = N_Function_Call
and then Nkind (Original_Node (N)) = N_Selected_Component
and then Is_Dispatching_Operation (Entity (Name (N)))
then
Rewrite (N, Original_Node (N));
Set_Original_Node (N, N);
-- Save the restored node in the Restored_Nodes_List to fix
-- the parent fields of their subtrees in a separate tree
-- traversal.
Append_New_Elmt (N, Restored_Nodes_List);
end if;
return OK;
end Restore_Node;
procedure Restore_Nodes is new Traverse_Proc (Restore_Node);
-- Start of processing for Restore_Original_Selected_Component
begin
Restore_Nodes (Expr);
-- After restoring the original node we must fix the decoration
-- of the Parent attribute to ensure tree consistency; required
-- because when the class-wide condition is inherited, calls to
-- New_Copy_Tree will perform copies of this subtree, and formal
-- occurrences with wrong Parent field cannot be mapped to the
-- new formals.
if Present (Restored_Nodes_List) then
declare
Elmt : Elmt_Id := First_Elmt (Restored_Nodes_List);
begin
while Present (Elmt) loop
Fix_Parents (Node (Elmt));
Next_Elmt (Elmt);
end loop;
end;
end if;
end Restore_Original_Selected_Component;
-- Start of processing for Preanalyze_Condition
begin
pragma Assert (Present (Expr));
pragma Assert (Inside_Class_Condition_Preanalysis = False);
Push_Scope (Subp);
Install_Formals (Subp);
Inside_Class_Condition_Preanalysis := True;
Preanalyze_Spec_Expression (Expr, Standard_Boolean);
Inside_Class_Condition_Preanalysis := False;
Remove_Formals (Subp);
Pop_Scope;
-- If this preanalyzed condition has occurrences of dispatching calls
-- using the Object.Operation notation, during preanalysis such calls
-- are rewritten as dispatching function calls; if at later stages
-- this condition is inherited we must have restored the original
-- selected-component node to ensure that the preanalysis of the
-- inherited condition rewrites these dispatching calls in the
-- correct context to avoid reporting spurious errors.
Restore_Original_Selected_Component;
-- Traverse Expr and clear the Controlling_Argument of calls to
-- nonabstract functions. Required since the preanalyzed condition
-- is not yet installed on its definite context and will be cloned
-- and extended in derivations with additional conditions.
Remove_Controlling_Arguments;
-- Clear also attribute Unset_Reference; again because preanalysis
-- occurs in a place unrelated to the actual code.
Clear_Unset_References;
end Preanalyze_Condition;
----------------------------------
-- Process_Inherited_Conditions --
----------------------------------
@ -5116,6 +4889,250 @@ package body Contracts is
end loop;
end Merge_Class_Conditions;
---------------------------------
-- Preanalyze_Class_Conditions --
---------------------------------
procedure Preanalyze_Class_Conditions (Spec_Id : Entity_Id) is
Cond : Node_Id;
begin
for Kind in Condition_Kind loop
Cond := Class_Condition (Kind, Spec_Id);
if Present (Cond) then
Preanalyze_Condition (Spec_Id, Cond);
end if;
end loop;
end Preanalyze_Class_Conditions;
--------------------------
-- Preanalyze_Condition --
--------------------------
procedure Preanalyze_Condition
(Subp : Entity_Id;
Expr : Node_Id)
is
procedure Clear_Unset_References;
-- Clear unset references on formals of Subp since preanalysis
-- occurs in a place unrelated to the actual code.
procedure Remove_Controlling_Arguments;
-- Traverse Expr and clear the Controlling_Argument of calls to
-- nonabstract functions.
procedure Remove_Formals (Id : Entity_Id);
-- Remove formals from homonym chains and make them not visible
procedure Restore_Original_Selected_Component;
-- Traverse Expr searching for dispatching calls to functions whose
-- original node was a selected component, and replace them with
-- their original node.
----------------------------
-- Clear_Unset_References --
----------------------------
procedure Clear_Unset_References is
F : Entity_Id := First_Formal (Subp);
begin
while Present (F) loop
Set_Unset_Reference (F, Empty);
Next_Formal (F);
end loop;
end Clear_Unset_References;
----------------------------------
-- Remove_Controlling_Arguments --
----------------------------------
procedure Remove_Controlling_Arguments is
function Remove_Ctrl_Arg (N : Node_Id) return Traverse_Result;
-- Reset the Controlling_Argument of calls to nonabstract
-- function calls.
---------------------
-- Remove_Ctrl_Arg --
---------------------
function Remove_Ctrl_Arg (N : Node_Id) return Traverse_Result is
begin
if Nkind (N) = N_Function_Call
and then Present (Controlling_Argument (N))
and then not Is_Abstract_Subprogram (Entity (Name (N)))
then
Set_Controlling_Argument (N, Empty);
end if;
return OK;
end Remove_Ctrl_Arg;
procedure Remove_Ctrl_Args is new Traverse_Proc (Remove_Ctrl_Arg);
begin
Remove_Ctrl_Args (Expr);
end Remove_Controlling_Arguments;
--------------------
-- Remove_Formals --
--------------------
procedure Remove_Formals (Id : Entity_Id) is
F : Entity_Id := First_Formal (Id);
begin
while Present (F) loop
Set_Is_Immediately_Visible (F, False);
Remove_Homonym (F);
Next_Formal (F);
end loop;
end Remove_Formals;
-----------------------------------------
-- Restore_Original_Selected_Component --
-----------------------------------------
procedure Restore_Original_Selected_Component is
Restored_Nodes_List : Elist_Id := No_Elist;
procedure Fix_Parents (N : Node_Id);
-- Traverse the subtree of N fixing the Parent field of all the
-- nodes.
function Restore_Node (N : Node_Id) return Traverse_Result;
-- Process dispatching calls to functions whose original node was
-- a selected component, and replace them with their original
-- node. Restored nodes are stored in the Restored_Nodes_List
-- to fix the parent fields of their subtrees in a separate
-- tree traversal.
-----------------
-- Fix_Parents --
-----------------
procedure Fix_Parents (N : Node_Id) is
function Fix_Parent
(Parent_Node : Node_Id;
Node : Node_Id) return Traverse_Result;
-- Process a single node
----------------
-- Fix_Parent --
----------------
function Fix_Parent
(Parent_Node : Node_Id;
Node : Node_Id) return Traverse_Result
is
Par : constant Node_Id := Parent (Node);
begin
if Par /= Parent_Node then
pragma Assert (not Is_List_Member (Node));
Set_Parent (Node, Parent_Node);
end if;
return OK;
end Fix_Parent;
procedure Fix_Parents is
new Traverse_Proc_With_Parent (Fix_Parent);
begin
Fix_Parents (N);
end Fix_Parents;
------------------
-- Restore_Node --
------------------
function Restore_Node (N : Node_Id) return Traverse_Result is
begin
if Nkind (N) = N_Function_Call
and then Nkind (Original_Node (N)) = N_Selected_Component
and then Is_Dispatching_Operation (Entity (Name (N)))
then
Rewrite (N, Original_Node (N));
Set_Original_Node (N, N);
-- Save the restored node in the Restored_Nodes_List to fix
-- the parent fields of their subtrees in a separate tree
-- traversal.
Append_New_Elmt (N, Restored_Nodes_List);
end if;
return OK;
end Restore_Node;
procedure Restore_Nodes is new Traverse_Proc (Restore_Node);
-- Start of processing for Restore_Original_Selected_Component
begin
Restore_Nodes (Expr);
-- After restoring the original node we must fix the decoration
-- of the Parent attribute to ensure tree consistency; required
-- because when the class-wide condition is inherited, calls to
-- New_Copy_Tree will perform copies of this subtree, and formal
-- occurrences with wrong Parent field cannot be mapped to the
-- new formals.
if Present (Restored_Nodes_List) then
declare
Elmt : Elmt_Id := First_Elmt (Restored_Nodes_List);
begin
while Present (Elmt) loop
Fix_Parents (Node (Elmt));
Next_Elmt (Elmt);
end loop;
end;
end if;
end Restore_Original_Selected_Component;
-- Start of processing for Preanalyze_Condition
begin
pragma Assert (Present (Expr));
pragma Assert (Inside_Class_Condition_Preanalysis = False);
Push_Scope (Subp);
Install_Formals (Subp);
Inside_Class_Condition_Preanalysis := True;
Preanalyze_Spec_Expression (Expr, Standard_Boolean);
Inside_Class_Condition_Preanalysis := False;
Remove_Formals (Subp);
Pop_Scope;
-- If this preanalyzed condition has occurrences of dispatching calls
-- using the Object.Operation notation, during preanalysis such calls
-- are rewritten as dispatching function calls; if at later stages
-- this condition is inherited we must have restored the original
-- selected-component node to ensure that the preanalysis of the
-- inherited condition rewrites these dispatching calls in the
-- correct context to avoid reporting spurious errors.
Restore_Original_Selected_Component;
-- Traverse Expr and clear the Controlling_Argument of calls to
-- nonabstract functions. Required since the preanalyzed condition
-- is not yet installed on its definite context and will be cloned
-- and extended in derivations with additional conditions.
Remove_Controlling_Arguments;
-- Clear also attribute Unset_Reference; again because preanalysis
-- occurs in a place unrelated to the actual code.
Clear_Unset_References;
end Preanalyze_Condition;
----------------------------------------
-- Save_Global_References_In_Contract --
----------------------------------------

4
gcc/ada/contracts.ads
View File

@ -276,6 +276,10 @@ package Contracts is
-- which are invoked from the caller side; they are also used to build
-- the dispatch-table wrapper (DTW), if required.
procedure Preanalyze_Class_Conditions (Spec_Id : Entity_Id);
-- Preanalyze class-wide pre-/postconditions of the given subprogram
-- specification.
procedure Process_Class_Conditions_At_Freeze_Point (Typ : Entity_Id);
-- Merge, preanalyze, and check class-wide pre/postconditions of Typ
-- primitives.

14
gcc/ada/sem_prag.adb
View File

@ -26201,6 +26201,20 @@ package body Sem_Prag is
Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
Set_Is_Analyzed_Pragma (N);
-- If the subprogram is frozen then its class-wide pre- and post-
-- conditions have been preanalyzed (see Merge_Class_Conditions);
-- otherwise they must be preanalyzed now to ensure the correct
-- visibility of their referenced entities. This scenario occurs
-- when the subprogram is defined in a nested package (since the
-- end of the package does not cause freezing).
if Class_Present (N)
and then Is_Dispatching_Operation (Spec_Id)
and then not Is_Frozen (Spec_Id)
then
Preanalyze_Class_Conditions (Spec_Id);
end if;
Restore_Ghost_Region (Saved_GM, Saved_IGR);
end Analyze_Pre_Post_Condition_In_Decl_Part;