OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[Ada] Crash in class-wide pre/postconditions

Browse Source 
gcc/ada/

	* contracts.adb (Restore_Original_Selected_Component): New
	subprogram that traverses a preanalyzed expression searching for
	dispatching calls to functions whose original node was a
	selected component, and replacing them with their original node.
	This functionality is required because the preanalyis of
	dispatching calls using the Object.Operation notation transforms
	such calls, and we need the original condition to properly
	inherit and extend the condition expression on tagged type
	derivations.  This functionality was previously provided by the
	routine Install_Original_Selected_Component (as part of
	inheriting conditions); now it is performed as part of the
	preanalysis of the condition, thus avoiding repeatedly
	installing and restoring such nodes.
	(Install_Original_Selected_Component): Removed.
	(Restore_Dispatching_Calls): Removed.
This commit is contained in:
Javier Miranda 2021-11-29 18:12:47 +00:00 committed by Pierre-Marie de Rodat
parent 2a3652640b
commit bfbb8de660
1 changed files with 58 additions and 106 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

164
gcc/ada/contracts.adb
View File

@ -4254,6 +4254,11 @@ package body Contracts is
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 --
----------------------------
@ -4313,6 +4318,46 @@ package body Contracts is
end loop;
end Remove_Formals;
-----------------------------------------
-- Restore_Original_Selected_Component --
-----------------------------------------
procedure Restore_Original_Selected_Component is
function Restore_Node (N : Node_Id) return Traverse_Result;
-- Process a single node
------------------
-- 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);
-- Restore decoration of its child nodes; required to ensure
-- proper copies of this subtree (if required) by subsequent
-- calls to New_Copy_Tree (since otherwise these child nodes
-- are not duplicated).
Set_Parent (Prefix (N), N);
Set_Parent (Selector_Name (N), N);
end if;
return OK;
end Restore_Node;
procedure Restore_Nodes is new Traverse_Proc (Restore_Node);
begin
Restore_Nodes (Expr);
end Restore_Original_Selected_Component;
-- Start of processing for Preanalyze_Condition
begin
@ -4329,6 +4374,16 @@ package body Contracts is
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
@ -4373,103 +4428,9 @@ package body Contracts is
(Par_Subp : Entity_Id;
Subp : Entity_Id) return Node_Id
is
Installed_Calls : constant Elist_Id := New_Elmt_List;
procedure Install_Original_Selected_Component (Expr : Node_Id);
-- Traverse the given expression searching for dispatching calls
-- to functions whose original nodes was a selected component,
-- and replacing them temporarily by a copy of their original
-- node. Modified calls are stored in the list Installed_Calls
-- (to undo this work later).
procedure Restore_Dispatching_Calls (Expr : Node_Id);
-- Undo the work done by Install_Original_Selected_Component.
-----------------------------------------
-- Install_Original_Selected_Component --
-----------------------------------------
procedure Install_Original_Selected_Component (Expr : Node_Id) is
function Install_Node (N : Node_Id) return Traverse_Result;
-- Process a single node
------------------
-- Install_Node --
------------------
function Install_Node (N : Node_Id) return Traverse_Result is
New_N : Node_Id;
Orig_Nod : Node_Id;
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
Orig_Nod := Original_Node (N);
-- Temporarily use the original node field to keep the
-- reference to this node (to undo this work later!).
New_N := New_Copy (N);
Set_Original_Node (New_N, Orig_Nod);
Append_Elmt (New_N, Installed_Calls);
Rewrite (N, Orig_Nod);
Set_Original_Node (N, New_N);
end if;
return OK;
end Install_Node;
procedure Install_Nodes is new Traverse_Proc (Install_Node);
begin
Install_Nodes (Expr);
end Install_Original_Selected_Component;
-------------------------------
-- Restore_Dispatching_Calls --
-------------------------------
procedure Restore_Dispatching_Calls (Expr : Node_Id) is
function Restore_Node (N : Node_Id) return Traverse_Result;
-- Process a single node
------------------
-- Restore_Node --
------------------
function Restore_Node (N : Node_Id) return Traverse_Result is
Orig_Sel_N : Node_Id;
begin
if Nkind (N) = N_Selected_Component
and then Nkind (Original_Node (N)) = N_Function_Call
and then Contains (Installed_Calls, Original_Node (N))
then
Orig_Sel_N := Original_Node (Original_Node (N));
pragma Assert (Nkind (Orig_Sel_N) = N_Selected_Component);
Rewrite (N, Original_Node (N));
Set_Original_Node (N, Orig_Sel_N);
end if;
return OK;
end Restore_Node;
procedure Restore_Nodes is new Traverse_Proc (Restore_Node);
begin
Restore_Nodes (Expr);
end Restore_Dispatching_Calls;
-- Local variables
Assoc_List : constant Elist_Id := New_Elmt_List;
Par_Formal_Id : Entity_Id := First_Formal (Par_Subp);
Subp_Formal_Id : Entity_Id := First_Formal (Subp);
New_Expr : Node_Id;
Class_Cond : Node_Id;
-- Start of processing for Inherit_Condition
@ -4482,18 +4443,9 @@ package body Contracts is
Next_Formal (Subp_Formal_Id);
end loop;
-- In order to properly preanalyze an inherited preanalyzed
-- condition that has occurrences of the Object.Operation
-- notation we must restore the original node; otherwise we
-- would report spurious errors.
Class_Cond := Class_Condition (Kind, Par_Subp);
Install_Original_Selected_Component (Class_Cond);
New_Expr := New_Copy_Tree (Class_Cond);
Restore_Dispatching_Calls (Class_Cond);
return New_Copy_Tree (New_Expr, Map => Assoc_List);
return New_Copy_Tree
(Source => Class_Condition (Kind, Par_Subp),
Map => Assoc_List);
end Inherit_Condition;
----------------------