[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

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

+--  { dg-do compile }
+
+package body Expr_Func6 is
+
+   procedure Dummy is null;
+
+end Expr_Func6;

gcc/testsuite/gnat.dg/expr_func6.ads

+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;