diff mbox series

[Ada] Fix crash on expression function that is a completion

Message ID 20170908100306.GA106924@adacore.com
State New
Headers show
Series [Ada] Fix crash on expression function that is a completion | expand

Commit Message

Arnaud Charlet Sept. 8, 2017, 10:03 a.m. UTC
This change fixes a crash on an expression function which is the completion of
a previous declaration, when the type of the expression is a record type which
contains private components.

Such a code is illegal as per AI12-0103, which says that expression functions
that are a completion freeze their expression (but don't freeze anything else),
and must therefore be properly rejected.

Compiling the following package:

package P is

   type Cursor is private;

   package Nested is

      type Rec is record
         C : Cursor;
      end record;

      function F (R : Rec) return Rec;

   private

      function F (R : Rec) return Rec is (R);

   end Nested;

private

   type Cursor is null record;

end P;

must yield:

p.ads:15:43: premature usage of incomplete type "Rec" defined at line 7
p.ads:15:43: type "Rec" has private component

Tested on x86_64-pc-linux-gnu, committed on trunk

2017-09-08  Eric Botcazou  <ebotcazou@adacore.com>

	* sem_ch6.adb (Freeze_Expr_Types): Really freeze
	all the types that are referenced by the expression.
	(Analyze_Expression_Function): Call Freeze_Expr_Types for
	a completion instead of manually freezing the type of the
	expression.
	(Analyze_Subprogram_Body_Helper): Do not call Freeze_Expr_Types here.
diff mbox series

Patch

Index: sem_ch6.adb
===================================================================
--- sem_ch6.adb	(revision 251875)
+++ sem_ch6.adb	(working copy)
@@ -267,18 +267,214 @@ 
       LocX : constant Source_Ptr := Sloc (Expr);
       Spec : constant Node_Id    := Specification (N);
 
+      procedure Freeze_Expr_Types (Spec_Id : Entity_Id);
+      --  N is an expression function that is a completion and Spec_Id its
+      --  defining entity. Freeze before N all the types referenced by the
+      --  expression of the function.
+
+      -----------------------
+      -- Freeze_Expr_Types --
+      -----------------------
+
+      procedure Freeze_Expr_Types (Spec_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.
+
+            ----------------
+            -- Check_Node --
+            ----------------
+
+            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
+
+               if Is_Itype (Typ)
+                 and then Scope_Within_Or_Same (Scope (Typ), Spec_Id)
+               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;
+
+            --  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 (Spec_Id);
+         Saved_Last_Entity  : constant Entity_Id := Last_Entity  (Spec_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. This
+         --  preanalysis is performed with errors disabled to avoid reporting
+         --  spurious errors on Ghost entities (since the expression is not
+         --  fully analyzed).
+
+         Push_Scope (Spec_Id);
+         Install_Formals (Spec_Id);
+         Ignore_Errors_Enable := Ignore_Errors_Enable + 1;
+
+         Preanalyze_Spec_Expression (Dup_Expr, Etype (Spec_Id));
+
+         Ignore_Errors_Enable := Ignore_Errors_Enable - 1;
+         End_Scope;
+
+         --  Restore certain attributes of Spec_Id since the preanalysis may
+         --  have introduced itypes to this scope, thus modifying attributes
+         --  First_Entity and Last_Entity.
+
+         Set_First_Entity (Spec_Id, Saved_First_Entity);
+         Set_Last_Entity  (Spec_Id, Saved_Last_Entity);
+
+         if Present (Last_Entity (Spec_Id)) then
+            Set_Next_Entity (Last_Entity (Spec_Id), Empty);
+         end if;
+
+         --  Freeze all types referenced in the expression
+
+         Freeze_References (Dup_Expr);
+      end Freeze_Expr_Types;
+
+      --  Local variables
+
       Asp      : Node_Id;
-      Def_Id   : Entity_Id;
       New_Body : Node_Id;
       New_Spec : Node_Id;
       Orig_N   : Node_Id;
       Ret      : Node_Id;
-      Ret_Type : Entity_Id;
 
-      Prev : Entity_Id;
+      Def_Id   : Entity_Id;
+      Prev     : Entity_Id;
       --  If the expression is a completion, Prev is the entity whose
       --  declaration is completed. Def_Id is needed to analyze the spec.
 
+   --  Start of processing for Analyze_Expression_Function
+
    begin
       --  This is one of the occasions on which we transform the tree during
       --  semantic analysis. If this is a completion, transform the expression
@@ -319,7 +515,7 @@ 
          end if;
       end if;
 
-      Ret := Make_Simple_Return_Statement (LocX, Expression (N));
+      Ret := Make_Simple_Return_Statement (LocX, Expr);
 
       New_Body :=
         Make_Subprogram_Body (Loc,
@@ -361,48 +557,22 @@ 
       --  to be inlined.
 
       elsif Present (Prev)
-        and then Comes_From_Source (Parent (Prev))
+        and then Is_Overloadable (Prev)
         and then not Is_Formal_Subprogram (Prev)
+        and then Comes_From_Source (Parent (Prev))
       then
          Set_Has_Completion (Prev, False);
          Set_Is_Inlined (Prev);
-         Ret_Type := Etype (Prev);
 
-         --  An expression function which acts as a completion freezes the
-         --  expression. This means freezing the return type, and if it is
-         --  an access type, freezing its designated type as well.
+         --  AI12-0103: Expression functions that are a completion freeze their
+         --  expression but don't freeze anything else (unlike regular bodies).
 
          --  Note that we cannot defer this freezing to the analysis of the
          --  expression itself, because a freeze node might appear in a nested
          --  scope, leading to an elaboration order issue in gigi.
 
-         Freeze_Before (N, Ret_Type);
+         Freeze_Expr_Types (Def_Id);
 
-         --  An entity can only be frozen if it is complete, so if the type
-         --  is still unfrozen it must still be incomplete in some way, e.g.
-         --  a private type without a full view, or a type derived from such
-         --  in an enclosing scope. Except in a generic context (where the
-         --  type may be a generic formal or derived from such), such use of
-         --  an incomplete type is an error. On the other hand, if this is a
-         --  limited view of a type, the type is declared in another unit and
-         --  frozen there. We must be in a context seeing the nonlimited view
-         --  of the type, which will be installed when the body is compiled.
-
-         if not Is_Frozen (Ret_Type)
-           and then not Is_Generic_Type (Root_Type (Ret_Type))
-           and then not Inside_A_Generic
-         then
-            if From_Limited_With (Ret_Type)
-              and then Present (Non_Limited_View (Ret_Type))
-            then
-               null;
-            else
-               Error_Msg_NE
-                 ("premature use of private type&",
-                  Result_Definition (Specification (N)), Ret_Type);
-            end if;
-         end if;
-
          --  For navigation purposes, indicate that the function is a body
 
          Generate_Reference (Prev, Defining_Entity (N), 'b', Force => True);
@@ -2273,11 +2443,6 @@ 
       --  limited views with the non-limited ones. Return the list of changes
       --  to be used to undo the transformation.
 
-      procedure Freeze_Expr_Types (Spec_Id : Entity_Id);
-      --  AI12-0103: N is the body associated with an expression function that
-      --  is a completion, and Spec_Id is its defining entity. Freeze before N
-      --  all the types referenced by the expression of the function.
-
       function Is_Private_Concurrent_Primitive
         (Subp_Id : Entity_Id) return Boolean;
       --  Determine whether subprogram Subp_Id is a primitive of a concurrent
@@ -3003,180 +3168,6 @@ 
          return Result;
       end Exchange_Limited_Views;
 
-      -----------------------
-      -- Freeze_Expr_Types --
-      -----------------------
-
-      procedure Freeze_Expr_Types (Spec_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.
-
-            ----------------
-            -- Check_Node --
-            ----------------
-
-            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;
-
-            -------------------
-            -- Clone_Def_Ids --
-            -------------------
-
-            procedure Clone_Def_Ids is new Traverse_Proc (Clone_Id);
-
-            --  Local variables
-
-            Return_Stmt : constant Node_Id :=
-                            First
-                              (Statements (Handled_Statement_Sequence (N)));
-            Dup_Expr    : Node_Id;
-
-         --  Start of processing for Cloned_Expression
-
-         begin
-            pragma Assert (Nkind (Return_Stmt) = N_Simple_Return_Statement);
-
-            --  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.
-
-            Dup_Expr := New_Copy_Tree (Expression (Return_Stmt));
-            Set_Parent (Dup_Expr, Return_Stmt);
-
-            --  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
-         begin
-            if Nkind (Node) = N_Identifier
-              and then Present (Entity (Node))
-            then
-               if Is_Type (Entity (Node)) then
-                  Freeze_Before (N, Entity (Node));
-
-               elsif Ekind_In (Entity (Node), E_Component,
-                                              E_Discriminant)
-               then
-                  declare
-                     Rec : constant Entity_Id := Scope (Entity (Node));
-                  begin
-
-                     --  Check that the enclosing record type can be frozen.
-                     --  This provides a better error message than generating
-                     --  primitives whose compilation fails much later. Refine
-                     --  the error message if possible.
-
-                     Check_Fully_Declared (Rec, Node);
-
-                     if Error_Posted (Node) then
-                        if Has_Private_Component (Rec) then
-                           Error_Msg_NE
-                             ("\type& has private component", Node, Rec);
-                        end if;
-
-                     else
-                        Freeze_Before (N, Rec);
-                     end if;
-                  end;
-               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
-               Freeze_Before (N, Designated_Type (Etype (Node)));
-            end if;
-
-            return OK;
-         end Freeze_Type_Refs;
-
-         procedure Freeze_References is new Traverse_Proc (Freeze_Type_Refs);
-
-         --  Local variables
-
-         Saved_First_Entity : constant Entity_Id := First_Entity (Spec_Id);
-         Saved_Last_Entity  : constant Entity_Id := Last_Entity  (Spec_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. This
-         --  preanalysis is performed with errors disabled to avoid reporting
-         --  spurious errors on Ghost entities (since the expression is not
-         --  fully analyzed).
-
-         Push_Scope (Spec_Id);
-         Install_Formals (Spec_Id);
-         Ignore_Errors_Enable := Ignore_Errors_Enable + 1;
-
-         Preanalyze_Spec_Expression (Dup_Expr, Etype (Spec_Id));
-
-         Ignore_Errors_Enable := Ignore_Errors_Enable - 1;
-         End_Scope;
-
-         --  Restore certain attributes of Spec_Id since the preanalysis may
-         --  have introduced itypes to this scope, thus modifying attributes
-         --  First_Entity and Last_Entity.
-
-         Set_First_Entity (Spec_Id, Saved_First_Entity);
-         Set_Last_Entity  (Spec_Id, Saved_Last_Entity);
-
-         if Present (Last_Entity (Spec_Id)) then
-            Set_Next_Entity (Last_Entity (Spec_Id), Empty);
-         end if;
-
-         --  Freeze all types referenced in the expression
-
-         Freeze_References (Dup_Expr);
-      end Freeze_Expr_Types;
-
       -------------------------------------
       -- Is_Private_Concurrent_Primitive --
       -------------------------------------
@@ -3627,17 +3618,6 @@ 
          then
             Set_Has_Delayed_Freeze (Spec_Id);
             Freeze_Before (N, Spec_Id);
-
-            --  AI12-0103: At the occurrence of an expression function
-            --  declaration that is a completion, its expression causes
-            --  freezing.
-
-            if Has_Completion (Spec_Id)
-              and then Nkind (N) = N_Subprogram_Body
-              and then Was_Expression_Function (N)
-            then
-               Freeze_Expr_Types (Spec_Id);
-            end if;
          end if;
       end if;