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 --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
index 702939a821b45a1259127ac705aaa1e364227d4c..363abe38d0dd881ac34ccbf4a3a92e32a39b61a6 100644 (file)
--- 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 (file)
index 0000000..e1abf04
--- /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 (file)
index 0000000..371f2fe
--- /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 (file)
index 0000000..d83af45
--- /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;