procedure Freeze_Expression (N : Node_Id) is
+ function Declared_In_Expanded_Body
+ (N : Node_Id;
+ Typ : Entity_Id;
+ Nam : Entity_Id) return Boolean;
+ -- Given the N_Handled_Sequence_Of_Statements node of an expander
+ -- generated subprogram body, determines if the frozen entity is
+ -- declared inside this body. This is recognized locating the
+ -- enclosing subprogram of the entity Name or its Type and
+ -- checking if it is this subprogram body.
+
function Find_Aggregate_Component_Desig_Type return Entity_Id;
-- If the expression is an array aggregate, the type of the component
-- expressions is also frozen. If the component type is an access type
-- Determines whether an entity E referenced in node N is declared in
-- the list L.
+ -------------------------------
+ -- Declared_In_Expanded_Body --
+ -------------------------------
+
+ function Declared_In_Expanded_Body
+ (N : Node_Id;
+ Typ : Entity_Id;
+ Nam : Entity_Id) return Boolean
+ is
+ pragma Assert (In_Expanded_Body (N));
+
+ Subp_Body : constant Node_Id := Parent (N);
+ Subp_Id : Entity_Id;
+ Scop : Entity_Id;
+
+ begin
+ if Acts_As_Spec (Subp_Body) then
+ Subp_Id := Unique_Defining_Entity (Specification (Subp_Body));
+ else
+ Subp_Id := Corresponding_Spec (Subp_Body);
+ end if;
+
+ if Present (Typ) then
+ Scop := Scope (Typ);
+ elsif Present (Nam) then
+ Scop := Scope (Nam);
+ else
+ Scop := Standard_Standard;
+ end if;
+
+ while Scop /= Standard_Standard
+ and then not Is_Subprogram (Scop)
+ loop
+ Scop := Scope (Scop);
+ end loop;
+
+ return Scop = Subp_Id;
+ end Declared_In_Expanded_Body;
+
-----------------------------------------
-- Find_Aggregate_Component_Desig_Type --
-----------------------------------------
if Nkind (P) /= N_Subprogram_Body then
return False;
- -- AI12-0157: An expression function that is a completion is a freeze
- -- point. If the body is the result of expansion, it is not.
+ -- Treat the generated body of an expression function like other
+ -- bodies generated during expansion (e.g. stream subprograms) so
+ -- that those bodies are not treated as freezing points.
elsif Was_Expression_Function (P) then
- return not Comes_From_Source (P);
+ pragma Assert (not Comes_From_Source (P));
+ return True;
-- This is the body of a generated predicate function
Allocator_Typ : Entity_Id := Empty;
- Freeze_Outside : Boolean := False;
- -- This flag is set true if the entity must be frozen outside the
- -- current subprogram. This happens in the case of expander generated
- -- subprograms (_Init_Proc, _Input, _Output, _Read, _Write) which do
- -- not freeze all entities like other bodies, but which nevertheless
- -- may reference entities that have to be frozen before the body and
- -- obviously cannot be frozen inside the body.
-
Freeze_Outside_Subp : Entity_Id := Empty;
-- This entity is set if we are inside a subprogram body and the frozen
-- entity is defined in the enclosing scope of this subprogram. In such
-- An exception occurs when the sequence of statements is
-- for an expander generated body that did not do the usual
-- freeze all operation. In this case we usually want to
- -- freeze outside this body, not inside it, and we skip
- -- past the subprogram body that we are inside.
-
- if In_Expanded_Body (Parent_P) then
- declare
- Subp_Body : constant Node_Id := Parent (Parent_P);
- Spec_Id : Entity_Id;
-
- begin
- -- Freeze the entity only when it is declared inside
- -- the body of the expander generated procedure. This
- -- case is recognized by the subprogram scope of the
- -- entity or its type, which is either the spec of an
- -- enclosing body, or (in the case of init_procs for
- -- which there is no separate spec) the current scope.
-
- if Nkind (Subp_Body) = N_Subprogram_Body then
- declare
- S : Entity_Id;
-
- begin
- Spec_Id := Corresponding_Spec (Subp_Body);
-
- if Present (Typ) then
- S := Scope (Typ);
- elsif Present (Nam) then
- S := Scope (Nam);
- else
- S := Standard_Standard;
- end if;
-
- while S /= Standard_Standard
- and then not Is_Subprogram (S)
- loop
- S := Scope (S);
- end loop;
-
- if S = Spec_Id then
- exit;
-
- elsif Present (Typ)
- and then Scope (Typ) = Current_Scope
- and then
- Defining_Entity (Subp_Body) = Current_Scope
- then
- exit;
- end if;
- end;
- end if;
-
- -- If the entity is not frozen by an expression
- -- function that is not a completion, continue
- -- climbing the tree.
+ -- freeze outside this body, not inside it, unless the
+ -- entity is declared inside this expander generated body.
- if Nkind (Subp_Body) = N_Subprogram_Body
- and then Was_Expression_Function (Subp_Body)
- then
- null;
-
- -- Freeze outside the body
-
- else
- Parent_P := Parent (Parent_P);
- Freeze_Outside := True;
- end if;
- end;
-
- -- Here if normal case where we are in handled statement
- -- sequence and want to do the insertion right there.
-
- else
- exit;
- end if;
+ exit when not In_Expanded_Body (Parent_P)
+ or else Declared_In_Expanded_Body (Parent_P, Typ, Nam);
-- If parent is a body or a spec or a block, then the current
-- node is a statement or declaration and we can insert the
| N_Selective_Accept
| N_Triggering_Alternative
=>
- exit when Is_List_Member (P);
+ if No (Current_Subprogram) then
+ exit when Is_List_Member (P);
+
+ -- Check exceptional case documented above for an enclosing
+ -- handled sequence of statements.
+
+ else
+ declare
+ Par : Node_Id := Parent (Parent_P);
+
+ begin
+ while Present (Par)
+ and then
+ Nkind (Par) /= N_Handled_Sequence_Of_Statements
+ and then Nkind (Parent (Par)) /= N_Subprogram_Body
+ loop
+ Par := Parent (Par);
+ end loop;
+
+ -- If we don't have a parent, then we are not in a
+ -- well-formed tree and we ignore the freeze request.
+ -- See previous comment in the enclosing loop.
+
+ if No (Par) then
+ return;
+ end if;
+
+ exit when not In_Expanded_Body (Par)
+ or else Declared_In_Expanded_Body (Par, Typ, Nam);
+ end;
+ end if;
-- The freeze nodes produced by an expression coming from the
-- Actions list of an N_Expression_With_Actions, short-circuit
-- placing them at the proper place, after the generic unit.
if (In_Spec_Exp and not Inside_A_Generic)
- or else Freeze_Outside
or else (Is_Type (Current_Scope)
and then (not Is_Concurrent_Type (Current_Scope)
or else not Has_Completion (Current_Scope)))