===================================================================
@@ -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;
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.