===================================================================
@@ -3423,72 +3423,10 @@
--------------------
function Freeze_Profile (E : Entity_Id) return Boolean is
- function Has_Incomplete_Component (T : Entity_Id) return Boolean;
- -- If a type includes a private component from an enclosing scope it
- -- cannot be frozen yet. This can happen in a package nested within
- -- another, when freezing an expression function whose profile
- -- depends on a type in some outer scope. Those types will be frozen
- -- at a later time in the enclosing unit.
-
- ------------------------------
- -- Has_Incomplete_Component --
- ------------------------------
-
- function Has_Incomplete_Component (T : Entity_Id) return Boolean is
- Comp : Entity_Id;
- Comp_Typ : Entity_Id;
-
- begin
- if Nkind (N) /= N_Subprogram_Body
- or else not Was_Expression_Function (N)
- then
- return False;
-
- elsif In_Instance then
- return False;
-
- elsif Is_Record_Type (T) then
- Comp := First_Entity (T);
-
- while Present (Comp) loop
- Comp_Typ := Etype (Comp);
-
- if Ekind_In (Comp, E_Component, E_Discriminant)
- and then Is_Private_Type (Comp_Typ)
- and then No (Full_View (Comp_Typ))
- and then In_Open_Scopes (Scope (Comp_Typ))
- and then Scope (Comp_Typ) /= Current_Scope
- then
- return True;
- end if;
-
- Comp := Next_Entity (Comp);
- end loop;
-
- return False;
-
- elsif Is_Array_Type (T) then
- Comp_Typ := Component_Type (T);
-
- return
- Is_Private_Type (Comp_Typ)
- and then No (Full_View (Comp_Typ))
- and then In_Open_Scopes (Scope (Comp_Typ))
- and then Scope (Comp_Typ) /= Current_Scope;
-
- else
- return False;
- end if;
- end Has_Incomplete_Component;
-
- -- Local variables
-
F_Type : Entity_Id;
R_Type : Entity_Id;
Warn_Node : Node_Id;
- -- Start of processing for Freeze_Profile
-
begin
-- Loop through formals
@@ -3508,12 +3446,6 @@
Set_Etype (Formal, F_Type);
end if;
- if Has_Incomplete_Component (F_Type) then
- Set_Is_Frozen (E, False);
- Result := No_List;
- return False;
- end if;
-
if not From_Limited_With (F_Type) then
Freeze_And_Append (F_Type, N, Result);
end if;
@@ -8302,7 +8234,9 @@
-- that we know the convention.
if not Has_Foreign_Convention (E) then
- Create_Extra_Formals (E);
+ if No (Extra_Formals (E)) then
+ Create_Extra_Formals (E);
+ end if;
Set_Mechanisms (E);
-- If this is convention Ada and a Valued_Procedure, that's odd
===================================================================
@@ -728,11 +728,9 @@
Insert_After (Last (Decls), New_Body);
- -- Preanalyze the expression for name capture, except in an
- -- instance, where this has been done during generic analysis,
- -- and will be redone when analyzing the body.
+ -- Preanalyze the expression if not already done above
- if not In_Instance then
+ if not Inside_A_Generic then
Push_Scope (Def_Id);
Install_Formals (Def_Id);
Preanalyze_Spec_Expression (Expr, Typ);
@@ -2367,6 +2365,7 @@
Desig_View : Entity_Id := Empty;
Exch_Views : Elist_Id := No_Elist;
HSS : Node_Id;
+ Mask_Types : Elist_Id := No_Elist;
Prot_Typ : Entity_Id := Empty;
Spec_Decl : Node_Id := Empty;
Spec_Id : Entity_Id;
@@ -2442,6 +2441,12 @@
-- Determine whether subprogram Subp_Id is a primitive of a concurrent
-- type that implements an interface and has a private view.
+ function Mask_Unfrozen_Types (Spec_Id : Entity_Id) return Elist_Id;
+ -- N is the body generated for an expression function that is not a
+ -- completion and Spec_Id the defining entity of its spec. Mark all
+ -- the not-yet-frozen types referenced by the simple return statement
+ -- of the function as formally frozen.
+
procedure Restore_Limited_Views (Restore_List : Elist_Id);
-- Undo the transformation done by Exchange_Limited_Views.
@@ -2452,6 +2457,9 @@
-- of an entity, we mark the entity as set in source to suppress any
-- warning on the stylized use of function stubs with a dummy return.
+ procedure Unmask_Unfrozen_Types (Unmask_List : Elist_Id);
+ -- Undo the transformation done by Mask_Unfrozen_Types
+
procedure Verify_Overriding_Indicator;
-- If there was a previous spec, the entity has been entered in the
-- current scope previously. If the body itself carries an overriding
@@ -3195,6 +3203,73 @@
return False;
end Is_Private_Concurrent_Primitive;
+ -------------------------
+ -- Mask_Unfrozen_Types --
+ -------------------------
+
+ function Mask_Unfrozen_Types (Spec_Id : Entity_Id) return Elist_Id is
+ Result : Elist_Id := No_Elist;
+
+ function Mask_Type_Refs (Node : Node_Id) return Traverse_Result;
+ -- Mask all types referenced in the subtree rooted at Node
+
+ --------------------
+ -- Mask_Type_Refs --
+ --------------------
+
+ function Mask_Type_Refs (Node : Node_Id) return Traverse_Result is
+
+ procedure Mask_Type (Typ : Entity_Id);
+
+ ---------------
+ -- Mask_Type --
+ ---------------
+
+ procedure Mask_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;
+
+ if not Is_Frozen (Typ) then
+ Set_Is_Frozen (Typ);
+ Append_New_Elmt (Typ, Result);
+ end if;
+ end Mask_Type;
+
+ begin
+ if Is_Entity_Name (Node) and then Present (Entity (Node)) then
+ Mask_Type (Etype (Entity (Node)));
+
+ if Ekind_In (Entity (Node), E_Component, E_Discriminant) then
+ Mask_Type (Scope (Entity (Node)));
+ end if;
+
+ elsif Nkind_In (Node, N_Aggregate, N_Null, N_Type_Conversion)
+ and then Present (Etype (Node))
+ then
+ Mask_Type (Etype (Node));
+ end if;
+
+ return OK;
+ end Mask_Type_Refs;
+
+ procedure Mask_References is new Traverse_Proc (Mask_Type_Refs);
+
+ Return_Stmt : constant Node_Id :=
+ First (Statements (Handled_Statement_Sequence (N)));
+ begin
+ pragma Assert (Nkind (Return_Stmt) = N_Simple_Return_Statement);
+
+ Mask_References (Expression (Return_Stmt));
+
+ return Result;
+ end Mask_Unfrozen_Types;
+
---------------------------
-- Restore_Limited_Views --
---------------------------
@@ -3236,6 +3311,20 @@
end if;
end Set_Trivial_Subprogram;
+ ---------------------------
+ -- Unmask_Unfrozen_Types --
+ ---------------------------
+
+ procedure Unmask_Unfrozen_Types (Unmask_List : Elist_Id) is
+ Elmt : Elmt_Id := First_Elmt (Unmask_List);
+
+ begin
+ while Present (Elmt) loop
+ Set_Is_Frozen (Node (Elmt), False);
+ Next_Elmt (Elmt);
+ end loop;
+ end Unmask_Unfrozen_Types;
+
---------------------------------
-- Verify_Overriding_Indicator --
---------------------------------
@@ -3610,8 +3699,22 @@
or else (Operating_Mode = Check_Semantics
and then Serious_Errors_Detected = 0))
then
- Set_Has_Delayed_Freeze (Spec_Id);
- Freeze_Before (N, Spec_Id);
+ -- The body generated for an expression function that is not a
+ -- completion is a freeze point neither for the profile nor for
+ -- anything else. That's why, in order to prevent any freezing
+ -- during analysis, we need to mask types declared outside the
+ -- expression that are not yet frozen.
+
+ if Nkind (N) = N_Subprogram_Body
+ and then Was_Expression_Function (N)
+ and then not Has_Completion (Spec_Id)
+ then
+ Set_Is_Frozen (Spec_Id);
+ Mask_Types := Mask_Unfrozen_Types (Spec_Id);
+ else
+ Set_Has_Delayed_Freeze (Spec_Id);
+ Freeze_Before (N, Spec_Id);
+ end if;
end if;
end if;
@@ -4455,6 +4558,10 @@
Restore_Limited_Views (Exch_Views);
end if;
+ if Mask_Types /= No_Elist then
+ Unmask_Unfrozen_Types (Mask_Types);
+ end if;
+
if Present (Desig_View) then
Set_Directly_Designated_Type (Etype (Spec_Id), Desig_View);
end if;
===================================================================
@@ -11450,7 +11450,7 @@
begin
-- Do not perform this transformation within a pre/postcondition,
- -- because the expression will be re-analyzed, and the transformation
+ -- because the expression will be reanalyzed, and the transformation
-- might affect the visibility of the operator, e.g. in an instance.
-- Note that fully analyzed and expanded pre/postconditions appear as
-- pragma Check equivalents.
@@ -11459,6 +11459,22 @@
return;
end if;
+ -- Likewise when an expression function is being preanalyzed, since the
+ -- expression will be reanalyzed as part of the generated body.
+
+ if In_Spec_Expression then
+ declare
+ S : constant Entity_Id := Current_Scope_No_Loops;
+ begin
+ if Ekind (S) = E_Function
+ and then Nkind (Original_Node (Unit_Declaration_Node (S)))
+ = N_Expression_Function
+ then
+ return;
+ end if;
+ end;
+ end if;
+
-- Rewrite the operator node using the real operator, not its renaming.
-- Exclude user-defined intrinsic operations of the same name, which are
-- treated separately and rewritten as calls.
This patch totally disables the freezing of an expression function at the point its body is analyzed, as well the freezing of all the types that are not yet frozen, in order to support more cases where the profile contains a type which depends on a private type that is declared in an open scope and does not yet have a completion. The following package must compile quietly: package P is type Forward_Cursor is private; package Nested is type Cursor is access Forward_Cursor; type Rec is record C : Forward_Cursor; end record; function Element (R : Rec; Current : Cursor) return Cursor is (Current); end Nested; private type Forward_Cursor is null record; end P; Tested on x86_64-pc-linux-gnu, committed on trunk 2017-09-11 Eric Botcazou <ebotcazou@adacore.com> * freeze.adb (Has_Incomplete_Compoent): Delete. (Freeze_Profile): Do not inhibit the freezing of the profile of an expression function here. (Freeze_Subprogram): Do not re-create extra formals. * sem_ch6.adb (Analyze_Expression_Function): Always pre-analyze the expression if the function is not a completion. (Analyze_Subprogram_Body_Helper): For the body generated from an expression function that is not a completion, do not freeze the profile and temporary mask the types declared outside the expression that are not yet frozen. * sem_res.adb (Rewrite_Renamed_Operator): Also bail out if invoked during the pre-analysis of an expression function.