+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.
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;
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;
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
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;
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 --
-----------------------------
-- 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
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;
-- 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
+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.
--- /dev/null
+-- { dg-do compile }
+
+package body Expr_Func6 is
+
+ procedure Dummy is null;
+
+end Expr_Func6;
--- /dev/null
+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;
projects / gcc.git / commitdiff