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