The previous change implemented the rule in Freeze_Expression that
expression functions that are not completions are not freeze points.
However, for code generation purposes, the artificial entities that
are created during the expansion of the expressions must still be
frozen inside the body created for the functions. Now the existing
mechanism aimed at ensuring this had a loophole for entities created
in nested blocks, which is plugged by the change.
The change also removes some unreachable code in In_Expanded_Body.
Tested on x86_64-pc-linux-gnu, committed on trunk
2020-06-16 Eric Botcazou <ebotca...@adacore.com>
gcc/ada/
* freeze.adb (In_Expanded_Body): Remove unreachable code.
(Freeze_Expression): Rename a couple of local variables.
In the case of an expanded body, also freeze locally the
entities declared in a nested block.--- gcc/ada/freeze.adb
+++ gcc/ada/freeze.adb
@@ -7114,22 +7114,15 @@ package body Freeze is
----------------------
function In_Expanded_Body (N : Node_Id) return Boolean is
- P : Node_Id;
+ P : constant Node_Id := Parent (N);
Id : Entity_Id;
begin
- if Nkind (N) = N_Subprogram_Body then
- P := N;
- else
- P := Parent (N);
- end if;
-
if Nkind (P) /= N_Subprogram_Body then
return False;
- -- AI12-0152 : an expression function that is a completion
- -- is a freeze point. If the body is the result of expansion
- -- it is not.
+ -- AI12-0157: An expression function that is a completion is a freeze
+ -- point. If the body is the result of expansion, it is not.
elsif Was_Expression_Function (P) then
return not Comes_From_Source (P);
@@ -7146,9 +7139,8 @@ package body Freeze is
or else Is_TSS (Id, TSS_Stream_Output)
or else Is_TSS (Id, TSS_Stream_Read)
or else Is_TSS (Id, TSS_Stream_Write)
- or else Nkind_In (Original_Node (P),
- N_Subprogram_Renaming_Declaration,
- N_Expression_Function))
+ or else Nkind (Original_Node (P)) =
+ N_Subprogram_Renaming_Declaration)
then
return True;
else
@@ -7518,45 +7510,61 @@ package body Freeze is
if In_Expanded_Body (Parent_P) then
declare
- Subp : constant Node_Id := Parent (Parent_P);
- Spec : Entity_Id;
+ 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 scope of the entity
- -- or its type, which is either the spec for some
- -- enclosing body, or (in the case of init_procs,
- -- for which there are no separate specs) the current
- -- scope.
-
- if Nkind (Subp) = N_Subprogram_Body then
- Spec := Corresponding_Spec (Subp);
-
- if (Present (Typ) and then Scope (Typ) = Spec)
- or else
- (Present (Nam) and then Scope (Nam) = Spec)
- then
- exit;
+ -- 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;
- elsif Present (Typ)
- and then Scope (Typ) = Current_Scope
- and then Defining_Entity (Subp) = Current_Scope
- then
- exit;
- 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 a completion, continue climing
- -- the tree.
+ -- function that is not a completion, continue
+ -- climbing the tree.
- if Nkind (Subp) = N_Subprogram_Body
- and then Was_Expression_Function (Subp)
+ if Nkind (Subp_Body) = N_Subprogram_Body
+ and then Was_Expression_Function (Subp_Body)
then
null;
- -- Freeze outside the body
+ -- Freeze outside the body
else
Parent_P := Parent (Parent_P);
