Skip to content

R
riscv-gcc-1
Commit 0db1c386 by Ed Schonberg Committed by Pierre-Marie de Rodat
Options

[Ada] Spurious crash on expression function as completion with contracts 

This patch fixes a compiler abort on an expression function that is a
completion of a subprogram with preconditions. The problem is caused by
the presence of types in the precondition that are not frozen when the
subprogram body constructed for the expression function receives the
code that enforces the precondition. These types must be frozen before
the contract is expanded, so the freeze nodes for these types appear in
the proper scope. This is analogous to what is done with type references
that appear in the original expression of the expression function.

2018-08-21  Ed Schonberg  <schonberg@adacore.com>

gcc/ada/

	* sem_ch6.adb: Remove Freeze_Expr_Types.
	* freeze.ads, freeze.adb (Freeze_Expr_Types): Moved from
	sem_ch6.adb, and extended to handle other expressions that may
	contain unfrozen types that must be frozen in their proper
	scopes.
	* contracts.adb (Analyze_Entry_Or_Subprogram_Contract): If the
	contract is for the generated body of an expression function
	that is a completion, traverse the expressions for pre- and
	postconditions to freeze all types before adding the contract
	code within the subprogram body.

gcc/testsuite/

	* gnat.dg/expr_func6.adb, gnat.dg/expr_func6.ads: New testcase.

From-SVN: r263734
parent 5b1c4547
Showing with 291 additions and 209 deletions
gcc/ada/ChangeLog
2018-08-21 Ed Schonberg <schonberg@adacore.com>
* sem_ch6.adb: Remove Freeze_Expr_Types.
* freeze.ads, freeze.adb (Freeze_Expr_Types): Moved from
sem_ch6.adb, and extended to handle other expressions that may
contain unfrozen types that must be frozen in their proper
scopes.
* contracts.adb (Analyze_Entry_Or_Subprogram_Contract): If the
contract is for the generated body of an expression function
that is a completion, traverse the expressions for pre- and
postconditions to freeze all types before adding the contract
code within the subprogram body.
2018-08-21 Hristian Kirtchev <kirtchev@adacore.com>
* sem_ch10.adb: Remove the with and use clause for unit Ghost.
......
gcc/ada/contracts.adb
......@@ -32,6 +32,7 @@ with Errout; use Errout;
with Exp_Prag; use Exp_Prag;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
......@@ -47,6 +48,7 @@ with Sem_Prag; use Sem_Prag;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
with SCIL_LL; use SCIL_LL;
with Tbuild; use Tbuild;
......@@ -589,14 +591,40 @@ package body Contracts is
if Skip_Assert_Exprs then
null;
-- Otherwise analyze the pre/postconditions
-- Otherwise analyze the pre/postconditions. Their expressions
-- might include references to types that are not frozen yet,
-- in the case where the body is a rewritten expression function
-- that is a completion, so freeze all types within before
-- constructing the contract code.
else
Prag := Pre_Post_Conditions (Items);
while Present (Prag) loop
Analyze_Pre_Post_Condition_In_Decl_Part (Prag, Freeze_Id);
Prag := Next_Pragma (Prag);
end loop;
declare
Bod : Node_Id;
Freeze_Types : Boolean := False;
begin
if Present (Freeze_Id) then
Bod := Unit_Declaration_Node (Freeze_Id);
if Nkind (Bod) = N_Subprogram_Body
and then Was_Expression_Function (Bod)
and then Ekind (Subp_Id) = E_Function
and then Chars (Subp_Id) = Chars (Freeze_Id)
and then Subp_Id /= Freeze_Id
then
Freeze_Types := True;
end if;
end if;
Prag := Pre_Post_Conditions (Items);
while Present (Prag) loop
if Freeze_Types then
Freeze_Expr_Types (Subp_Id, Standard_Boolean,
Expression (Corresponding_Aspect (Prag)), Bod);
end if;
Analyze_Pre_Post_Condition_In_Decl_Part (Prag, Freeze_Id);
Prag := Next_Pragma (Prag);
end loop;
end;
end if;
-- Analyze contract-cases and test-cases
......
gcc/ada/freeze.adb
......@@ -49,6 +49,7 @@ with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Cat; use Sem_Cat;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch7; use Sem_Ch7;
with Sem_Ch8; use Sem_Ch8;
......@@ -7643,6 +7644,209 @@ package body Freeze is
In_Spec_Expression := In_Spec_Exp;
end Freeze_Expression;
-----------------------
-- Freeze_Expr_Types --
-----------------------
procedure Freeze_Expr_Types
(Def_Id : Entity_Id;
Typ : Entity_Id;
Expr : Node_Id;
N : Node_Id)
is
function Cloned_Expression return Node_Id;
-- Build a duplicate of the expression of the return statement that
-- has no defining entities shared with the original expression.
function Freeze_Type_Refs (Node : Node_Id) return Traverse_Result;
-- Freeze all types referenced in the subtree rooted at Node
-----------------------
-- Cloned_Expression --
-----------------------
function Cloned_Expression return Node_Id is
function Clone_Id (Node : Node_Id) return Traverse_Result;
-- Tree traversal routine that clones the defining identifier of
-- iterator and loop parameter specification nodes.
--------------
-- Clone_Id --
--------------
function Clone_Id (Node : Node_Id) return Traverse_Result is
begin
if Nkind_In (Node, N_Iterator_Specification,
N_Loop_Parameter_Specification)
then
Set_Defining_Identifier (Node,
New_Copy (Defining_Identifier (Node)));
end if;
return OK;
end Clone_Id;
procedure Clone_Def_Ids is new Traverse_Proc (Clone_Id);
-- Local variable
Dup_Expr : constant Node_Id := New_Copy_Tree (Expr);
-- Start of processing for Cloned_Expression
begin
-- We must duplicate the expression with semantic information to
-- inherit the decoration of global entities in generic instances.
-- Set the parent of the new node to be the parent of the original
-- to get the proper context, which is needed for complete error
-- reporting and for semantic analysis.
Set_Parent (Dup_Expr, Parent (Expr));
-- Replace the defining identifier of iterators and loop param
-- specifications by a clone to ensure that the cloned expression
-- and the original expression don't have shared identifiers;
-- otherwise, as part of the preanalysis of the expression, these
-- shared identifiers may be left decorated with itypes which
-- will not be available in the tree passed to the backend.
Clone_Def_Ids (Dup_Expr);
return Dup_Expr;
end Cloned_Expression;
----------------------
-- Freeze_Type_Refs --
----------------------
function Freeze_Type_Refs (Node : Node_Id) return Traverse_Result is
procedure Check_And_Freeze_Type (Typ : Entity_Id);
-- Check that Typ is fully declared and freeze it if so
---------------------------
-- Check_And_Freeze_Type --
---------------------------
procedure Check_And_Freeze_Type (Typ : Entity_Id) is
begin
-- Skip Itypes created by the preanalysis, and itypes whose
-- scope is another type (i.e. component subtypes that depend
-- on a discriminant),
if Is_Itype (Typ)
and then (Scope_Within_Or_Same (Scope (Typ), Def_Id)
or else Is_Type (Scope (Typ)))
then
return;
end if;
-- This provides a better error message than generating
-- primitives whose compilation fails much later. Refine
-- the error message if possible.
Check_Fully_Declared (Typ, Node);
if Error_Posted (Node) then
if Has_Private_Component (Typ)
and then not Is_Private_Type (Typ)
then
Error_Msg_NE ("\type& has private component", Node, Typ);
end if;
else
Freeze_Before (N, Typ);
end if;
end Check_And_Freeze_Type;
-- Start of processing for Freeze_Type_Refs
begin
-- Check that a type referenced by an entity can be frozen
if Is_Entity_Name (Node) and then Present (Entity (Node)) then
Check_And_Freeze_Type (Etype (Entity (Node)));
-- Check that the enclosing record type can be frozen
if Ekind_In (Entity (Node), E_Component, E_Discriminant) then
Check_And_Freeze_Type (Scope (Entity (Node)));
end if;
-- Freezing an access type does not freeze the designated type,
-- but freezing conversions between access to interfaces requires
-- that the interface types themselves be frozen, so that dispatch
-- table entities are properly created.
-- Unclear whether a more general rule is needed ???
elsif Nkind (Node) = N_Type_Conversion
and then Is_Access_Type (Etype (Node))
and then Is_Interface (Designated_Type (Etype (Node)))
then
Check_And_Freeze_Type (Designated_Type (Etype (Node)));
end if;
-- An implicit dereference freezes the designated type. In the
-- case of a dispatching call whose controlling argument is an
-- access type, the dereference is not made explicit, so we must
-- check for such a call and freeze the designated type.
if Nkind (Node) in N_Has_Etype
and then Present (Etype (Node))
and then Is_Access_Type (Etype (Node))
and then Nkind (Parent (Node)) = N_Function_Call
and then Node = Controlling_Argument (Parent (Node))
then
Check_And_Freeze_Type (Designated_Type (Etype (Node)));
end if;
-- No point in posting several errors on the same expression
if Serious_Errors_Detected > 0 then
return Abandon;
else
return OK;
end if;
end Freeze_Type_Refs;
procedure Freeze_References is new Traverse_Proc (Freeze_Type_Refs);
-- Local variables
Saved_First_Entity : constant Entity_Id := First_Entity (Def_Id);
Saved_Last_Entity : constant Entity_Id := Last_Entity (Def_Id);
Dup_Expr : constant Node_Id := Cloned_Expression;
-- Start of processing for Freeze_Expr_Types
begin
-- Preanalyze a duplicate of the expression to have available the
-- minimum decoration needed to locate referenced unfrozen types
-- without adding any decoration to the function expression.
Push_Scope (Def_Id);
Install_Formals (Def_Id);
Preanalyze_Spec_Expression (Dup_Expr, Typ);
End_Scope;
-- Restore certain attributes of Def_Id since the preanalysis may
-- have introduced itypes to this scope, thus modifying attributes
-- First_Entity and Last_Entity.
Set_First_Entity (Def_Id, Saved_First_Entity);
Set_Last_Entity (Def_Id, Saved_Last_Entity);
if Present (Last_Entity (Def_Id)) then
Set_Next_Entity (Last_Entity (Def_Id), Empty);
end if;
-- Freeze all types referenced in the expression
Freeze_References (Dup_Expr);
end Freeze_Expr_Types;
-----------------------------
-- Freeze_Fixed_Point_Type --
-----------------------------
......
gcc/ada/freeze.ads
......@@ -230,6 +230,17 @@ package Freeze is
-- so need to be similarly treated. Freeze_Expression takes care of
-- determining the proper insertion point for generated freeze actions.
procedure Freeze_Expr_Types
(Def_Id : Entity_Id;
Typ : Entity_Id;
Expr : Node_Id;
N : Node_Id);
-- N is the body constructed for an expression function that is a
-- completion, and Def_Id is the function being completed.
-- This procedure freezes before N all the types referenced in Expr,
-- which is either the expression of the expression function, or
-- the expression in a pre/post aspect that applies to Def_Id;
procedure Freeze_Fixed_Point_Type (Typ : Entity_Id);
-- Freeze fixed point type. For fixed-point types, we have to defer
-- setting the size and bounds till the freeze point, since they are
......
gcc/ada/sem_ch6.adb
......@@ -285,208 +285,6 @@ package body Sem_Ch6 is
LocX : constant Source_Ptr := Sloc (Expr);
Spec : constant Node_Id := Specification (N);
procedure Freeze_Expr_Types (Def_Id : Entity_Id);
-- N is an expression function that is a completion and Def_Id its
-- defining entity. Freeze before N all the types referenced by the
-- expression of the function.
-----------------------
-- Freeze_Expr_Types --
-----------------------
procedure Freeze_Expr_Types (Def_Id : Entity_Id) is
function Cloned_Expression return Node_Id;
-- Build a duplicate of the expression of the return statement that
-- has no defining entities shared with the original expression.
function Freeze_Type_Refs (Node : Node_Id) return Traverse_Result;
-- Freeze all types referenced in the subtree rooted at Node
-----------------------
-- Cloned_Expression --
-----------------------
function Cloned_Expression return Node_Id is
function Clone_Id (Node : Node_Id) return Traverse_Result;
-- Tree traversal routine that clones the defining identifier of
-- iterator and loop parameter specification nodes.
--------------
-- Clone_Id --
--------------
function Clone_Id (Node : Node_Id) return Traverse_Result is
begin
if Nkind_In (Node, N_Iterator_Specification,
N_Loop_Parameter_Specification)
then
Set_Defining_Identifier (Node,
New_Copy (Defining_Identifier (Node)));
end if;
return OK;
end Clone_Id;
procedure Clone_Def_Ids is new Traverse_Proc (Clone_Id);
-- Local variable
Dup_Expr : constant Node_Id := New_Copy_Tree (Expr);
-- Start of processing for Cloned_Expression
begin
-- We must duplicate the expression with semantic information to
-- inherit the decoration of global entities in generic instances.
-- Set the parent of the new node to be the parent of the original
-- to get the proper context, which is needed for complete error
-- reporting and for semantic analysis.
Set_Parent (Dup_Expr, Parent (Expr));
-- Replace the defining identifier of iterators and loop param
-- specifications by a clone to ensure that the cloned expression
-- and the original expression don't have shared identifiers;
-- otherwise, as part of the preanalysis of the expression, these
-- shared identifiers may be left decorated with itypes which
-- will not be available in the tree passed to the backend.
Clone_Def_Ids (Dup_Expr);
return Dup_Expr;
end Cloned_Expression;
----------------------
-- Freeze_Type_Refs --
----------------------
function Freeze_Type_Refs (Node : Node_Id) return Traverse_Result is
procedure Check_And_Freeze_Type (Typ : Entity_Id);
-- Check that Typ is fully declared and freeze it if so
---------------------------
-- Check_And_Freeze_Type --
---------------------------
procedure Check_And_Freeze_Type (Typ : Entity_Id) is
begin
-- Skip Itypes created by the preanalysis, and itypes whose
-- scope is another type (i.e. component subtypes that depend
-- on a discriminant),
if Is_Itype (Typ)
and then (Scope_Within_Or_Same (Scope (Typ), Def_Id)
or else Is_Type (Scope (Typ)))
then
return;
end if;
-- This provides a better error message than generating
-- primitives whose compilation fails much later. Refine
-- the error message if possible.
Check_Fully_Declared (Typ, Node);
if Error_Posted (Node) then
if Has_Private_Component (Typ)
and then not Is_Private_Type (Typ)
then
Error_Msg_NE ("\type& has private component", Node, Typ);
end if;
else
Freeze_Before (N, Typ);
end if;
end Check_And_Freeze_Type;
-- Start of processing for Freeze_Type_Refs
begin
-- Check that a type referenced by an entity can be frozen
if Is_Entity_Name (Node) and then Present (Entity (Node)) then
Check_And_Freeze_Type (Etype (Entity (Node)));
-- Check that the enclosing record type can be frozen
if Ekind_In (Entity (Node), E_Component, E_Discriminant) then
Check_And_Freeze_Type (Scope (Entity (Node)));
end if;
-- Freezing an access type does not freeze the designated type,
-- but freezing conversions between access to interfaces requires
-- that the interface types themselves be frozen, so that dispatch
-- table entities are properly created.
-- Unclear whether a more general rule is needed ???
elsif Nkind (Node) = N_Type_Conversion
and then Is_Access_Type (Etype (Node))
and then Is_Interface (Designated_Type (Etype (Node)))
then
Check_And_Freeze_Type (Designated_Type (Etype (Node)));
end if;
-- An implicit dereference freezes the designated type. In the
-- case of a dispatching call whose controlling argument is an
-- access type, the dereference is not made explicit, so we must
-- check for such a call and freeze the designated type.
if Nkind (Node) in N_Has_Etype
and then Present (Etype (Node))
and then Is_Access_Type (Etype (Node))
and then Nkind (Parent (Node)) = N_Function_Call
and then Node = Controlling_Argument (Parent (Node))
then
Check_And_Freeze_Type (Designated_Type (Etype (Node)));
end if;
-- No point in posting several errors on the same expression
if Serious_Errors_Detected > 0 then
return Abandon;
else
return OK;
end if;
end Freeze_Type_Refs;
procedure Freeze_References is new Traverse_Proc (Freeze_Type_Refs);
-- Local variables
Saved_First_Entity : constant Entity_Id := First_Entity (Def_Id);
Saved_Last_Entity : constant Entity_Id := Last_Entity (Def_Id);
Dup_Expr : constant Node_Id := Cloned_Expression;
-- Start of processing for Freeze_Expr_Types
begin
-- Preanalyze a duplicate of the expression to have available the
-- minimum decoration needed to locate referenced unfrozen types
-- without adding any decoration to the function expression.
Push_Scope (Def_Id);
Install_Formals (Def_Id);
Preanalyze_Spec_Expression (Dup_Expr, Etype (Def_Id));
End_Scope;
-- Restore certain attributes of Def_Id since the preanalysis may
-- have introduced itypes to this scope, thus modifying attributes
-- First_Entity and Last_Entity.
Set_First_Entity (Def_Id, Saved_First_Entity);
Set_Last_Entity (Def_Id, Saved_Last_Entity);
if Present (Last_Entity (Def_Id)) then
Set_Next_Entity (Last_Entity (Def_Id), Empty);
end if;
-- Freeze all types referenced in the expression
Freeze_References (Dup_Expr);
end Freeze_Expr_Types;
-- Local variables
Asp : Node_Id;
......@@ -600,7 +398,7 @@ package body Sem_Ch6 is
-- As elsewhere, we do not emit freeze nodes within a generic unit.
if not Inside_A_Generic then
Freeze_Expr_Types (Def_Id);
Freeze_Expr_Types (Def_Id, Etype (Def_Id), Expr, N);
end if;
-- For navigation purposes, indicate that the function is a body
......
gcc/testsuite/ChangeLog
2018-08-21 Ed Schonberg <schonberg@adacore.com>
* gnat.dg/expr_func6.adb, gnat.dg/expr_func6.ads: New testcase.
2018-08-21 Javier Miranda <miranda@adacore.com>
* gnat.dg/spark2.adb, gnat.dg/spark2.ads: New testcase.
......
gcc/testsuite/gnat.dg/expr_func6.adb 0 → 100644
-- { dg-do compile }
package body Expr_Func6 is
procedure Dummy is null;
end Expr_Func6;
gcc/testsuite/gnat.dg/expr_func6.ads 0 → 100644
pragma Assertion_Policy (Check);
package Expr_Func6 is
type Monolean is (Nottrue);
function Basic_Function return Monolean;
function Fancy_Function_With_Contract return Boolean
with Pre => Basic_Function = Nottrue;
function Fancy_Function_With_Contract return Boolean is (False);
function Basic_Function return Monolean is (Nottrue);
procedure Dummy;
end Expr_Func6;
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