https://gcc.gnu.org/g:7bdac5a4a5cdf896d0358ea576439b3c3321ef22
commit r16-5018-g7bdac5a4a5cdf896d0358ea576439b3c3321ef22 Author: Eric Botcazou <[email protected]> Date: Tue Nov 4 00:40:39 2025 +0100 Ada: Fix segfault for instantiation on function call returning string 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. gcc/ada/ PR ada/78175 * sem_ch12.adb (Hide_Current_Scope): Deal with a transient scope as current scope. (Remove_Parent): Likewise. gcc/testsuite/ * gnat.dg/generic_inst15.adb: New test. * gnat.dg/generic_inst15_pkg-g.ads: New helper. * gnat.dg/generic_inst15_pkg.ads: Likewise. Diff: --- gcc/ada/sem_ch12.adb | 58 +++++++++++++++++++------- gcc/testsuite/gnat.dg/generic_inst15.adb | 27 ++++++++++++ gcc/testsuite/gnat.dg/generic_inst15_pkg-g.ads | 8 ++++ gcc/testsuite/gnat.dg/generic_inst15_pkg.ads | 37 ++++++++++++++++ 4 files changed, 115 insertions(+), 15 deletions(-) diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 702939a821b4..363abe38d0dd 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 @@ -11168,10 +11168,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); @@ -11194,7 +11204,6 @@ package body Sem_Ch12 is Set_Is_Immediately_Visible (C, False); Append_Elmt (C, Hidden_Entities); end if; - end Hide_Current_Scope; -------------- @@ -16948,20 +16957,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 @@ -17045,6 +17067,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 diff --git a/gcc/testsuite/gnat.dg/generic_inst15.adb b/gcc/testsuite/gnat.dg/generic_inst15.adb new file mode 100644 index 000000000000..e1abf04e07fb --- /dev/null +++ b/gcc/testsuite/gnat.dg/generic_inst15.adb @@ -0,0 +1,27 @@ +-- { 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; diff --git a/gcc/testsuite/gnat.dg/generic_inst15_pkg-g.ads b/gcc/testsuite/gnat.dg/generic_inst15_pkg-g.ads new file mode 100644 index 000000000000..371f2fec9c4c --- /dev/null +++ b/gcc/testsuite/gnat.dg/generic_inst15_pkg-g.ads @@ -0,0 +1,8 @@ +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; diff --git a/gcc/testsuite/gnat.dg/generic_inst15_pkg.ads b/gcc/testsuite/gnat.dg/generic_inst15_pkg.ads new file mode 100644 index 000000000000..d83af4545811 --- /dev/null +++ b/gcc/testsuite/gnat.dg/generic_inst15_pkg.ads @@ -0,0 +1,37 @@ +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;
