The problem is that a transient scope is created during the analysis of the
actual parameters of the instantiation and this discombobulates the complex
handling of scopes in Sem_Ch12.
Tested on x86-64/Linux, applied on the mainline.
2025-11-03 Eric Botcazou <[email protected]>
PR ada/78175
* sem_ch12.adb (Hide_Current_Scope): Deal with a transient scope
as current scope.
(Remove_Parent): Likewise.
2025-11-03 Eric Botcazou <[email protected]>
* gnat.dg/generic_inst15.adb: New test.
* gnat.dg/generic_inst15_pkg-g.ads: New helper.
* gnat.dg/generic_inst15_pkg.ads: Likewise.
--
Eric Botcazoudiff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
index deb19ee118e..d759baf782a 100644
--- a/gcc/ada/sem_ch12.adb
+++ b/gcc/ada/sem_ch12.adb
@@ -810,11 +810,11 @@ package body Sem_Ch12 is
-- the suffix is removed is added to Prims_List to restore them later.
procedure Install_Parent (P : Entity_Id; In_Body : Boolean := False);
- -- When compiling an instance of a child unit the parent (which is
- -- itself an instance) is an enclosing scope that must be made
- -- immediately visible. This procedure is also used to install the non-
- -- generic parent of a generic child unit when compiling its body, so
- -- that full views of types in the parent are made visible.
+ -- When compiling an instance of a child unit, the parent P is an enclosing
+ -- scope that must be made immediately visible. In_Body is True if this is
+ -- done for an instance body and False for an instance spec. Note that the
+ -- procedure does not insert P on the scope stack above the current scope,
+ -- but instead pushes P and then pushes an extra copy of the current scope.
-- The functions Instantiate_... perform various legality checks and build
-- the declarations for instantiated generic parameters. In all of these
@@ -930,7 +930,7 @@ package body Sem_Ch12 is
-- subprogram declaration N.
procedure Remove_Parent (In_Body : Boolean := False);
- -- Reverse effect after instantiation of child is complete
+ -- Reverse Install_Parent's effect after instantiation of child is complete
function Renames_Standard_Subprogram (Subp : Entity_Id) return Boolean;
-- Determine whether Subp renames one of the subprograms defined in the
@@ -11182,10 +11182,20 @@ package body Sem_Ch12 is
------------------------
procedure Hide_Current_Scope is
- C : constant Entity_Id := Current_Scope;
+ C : Entity_Id;
E : Entity_Id;
begin
+ C := Current_Scope;
+
+ -- The analysis of the actual parameters may have created a transient
+ -- scope after the extra copy of the current scope was pushed onto the
+ -- stack, so we need to skip it.
+
+ if Scope_Is_Transient then
+ C := Scope (C);
+ end if;
+
Set_Is_Hidden_Open_Scope (C);
E := First_Entity (C);
@@ -11208,7 +11218,6 @@ package body Sem_Ch12 is
Set_Is_Immediately_Visible (C, False);
Append_Elmt (C, Hidden_Entities);
end if;
-
end Hide_Current_Scope;
--------------
@@ -16960,20 +16969,33 @@ package body Sem_Ch12 is
procedure Remove_Parent (In_Body : Boolean := False) is
S : Entity_Id := Current_Scope;
- -- S is the scope containing the instantiation just completed. The scope
- -- stack contains the parent instances of the instantiation, followed by
- -- the original S.
+ -- S is the extra copy of the current scope that has been pushed by
+ -- Install_Parent. The scope stack next contains the parents of the
+ -- instance followed by the original S.
Cur_P : Entity_Id;
E : Entity_Id;
- P : Entity_Id;
Hidden : Elmt_Id;
+ P : Entity_Id;
+ SE : Scope_Stack_Entry;
begin
- -- After child instantiation is complete, remove from scope stack the
- -- extra copy of the current scope, and then remove parent instances.
-
if not In_Body then
+ -- If the analysis of the actual parameters has created a transient
+ -- scope after the extra copy of the current scope was pushed onto
+ -- the stack, we first need to save this transient scope and pop it.
+
+ if Scope_Is_Transient then
+ SE := Scope_Stack.Table (Scope_Stack.Last);
+ Scope_Stack.Decrement_Last;
+ S := Current_Scope;
+ else
+ SE := (Is_Transient => False, others => <>);
+ end if;
+
+ -- After child instantiation is complete, remove from scope stack the
+ -- extra copy of the current scope, and then remove the parents.
+
Pop_Scope;
while Current_Scope /= S loop
@@ -17057,6 +17079,12 @@ package body Sem_Ch12 is
Next_Elmt (Hidden);
end loop;
+ -- Restore the transient scope that was popped on entry, if any
+
+ if SE.Is_Transient then
+ Scope_Stack.Append (SE);
+ end if;
+
else
-- Each body is analyzed separately, and there is no context that
-- needs preserving from one body instance to the next, so remove all
-- { dg-do compile }
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Directories; use Ada.Directories;
with Ada.Text_IO; use Ada.Text_IO;
with Generic_Inst15_Pkg;
with Generic_Inst15_Pkg.G;
procedure Generic_Inst15 is
procedure Print_Word
(Word : in out Generic_Inst15_Pkg.Word_Type;
Continue : out Boolean)
is
begin
Ada.Text_IO.Put_Line(Generic_Inst15_Pkg.Get_Word(Word));
Continue := True;
end;
package Word_Lister is new Generic_Inst15_Pkg.G
(Order => Generic_Inst15_Pkg.Word_Order'Val (Positive'Value (Argument(1))),
Process => Print_Word);
begin
null;
end;
generic
Order : Word_Order;
with procedure Process
(Word : in out Word_Type;
Continue : out Boolean);
package Generic_Inst15_Pkg.G is
procedure Translate (Code : in Book_Code_Type) is null;
end Generic_Inst15_Pkg.G;
private with Ada.Containers.Indefinite_Vectors;
private with Ada.Strings.Unbounded;
package Generic_Inst15_Pkg is
type Word_Order is
(wo_Alpha,
wo_Position,
wo_Frequency_Alpha,
wo_Frequency_Position);
subtype Book_Code_Type is String (1 .. 24);
type Word_Type is private;
type Word_Status is (ws_Single, ws_Multi, ws_Not_All, ws_Unknown);
type Translation_Index is new Natural range 1 .. 10;
function Get_Word (Self : in Word_Type) return String;
type Book_Type is private;
private
package Translation_List is new Ada.Containers.Indefinite_Vectors (
Index_Type => Translation_Index,
Element_Type => String,
"=" => "=");
type Word_Type is record
Is_All : Boolean := False;
Translations : Translation_List.Vector;
end record;
type Book_Type is record
Line : Positive := 1;
Index : Positive := 1;
end record;
end Generic_Inst15_Pkg;
