[Ada] Crash on subprogram instantiation in nested package

[Pierre-Marie de Rodat]

This patch fixes a crash on a subpogram instance that appears within a package
that declares the actual type for the instance, when the corresponding type is
a private or incomplete formal type.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada

2017-12-15  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch6.adb (Possible_Freeze): Do not set Delayed_Freeze on an
	subprogram instantiation, now that the enclosing wrapper package
	carries an explicit freeze node. THis prevents freeze nodes for the
	subprogram for appearing in the wrong scope. This is relevant when the
	generic subprogram has a private or incomplete formal type and the
	instance appears within a package that declares the actual type for the
	instantiation, and that type has itself a delayed freeze.

gcc/testsuite/

2017-12-15  Ed Schonberg  <schonberg@adacore.com>

	* gnat.dg/subp_inst.adb, gnat.dg/subp_inst_pkg.adb,
	gnat.dg/subp_inst_pkg.ads: New testcase.
-------------- next part --------------
Index: sem_ch6.adb
===================================================================
--- sem_ch6.adb	(revision 255678)
+++ sem_ch6.adb	(working copy)
@@ -5834,8 +5834,21 @@
       ---------------------
 
       procedure Possible_Freeze (T : Entity_Id) is
+         Scop : constant Entity_Id := Scope (Designator);
       begin
-         if Has_Delayed_Freeze (T) and then not Is_Frozen (T) then
+         --  If the subprogram appears within a package instance (which
+         --  may be the wrapper package of a subprogram instance) the
+         --  freeze node for that package will freeze the subprogram at
+         --  the proper place, so do not emit a freeze node for the
+         --  subprogram, given that it may appear in the wrong scope.
+
+         if Ekind (Scop) = E_Package
+           and then not Comes_From_Source (Scop)
+           and then Is_Generic_Instance (Scop)
+         then
+            null;
+
+         elsif Has_Delayed_Freeze (T) and then not Is_Frozen (T) then
             Set_Has_Delayed_Freeze (Designator);
 
          elsif Is_Access_Type (T)
Index: ../testsuite/gnat.dg/subp_inst.adb
===================================================================
--- ../testsuite/gnat.dg/subp_inst.adb	(revision 0)
+++ ../testsuite/gnat.dg/subp_inst.adb	(revision 0)
@@ -0,0 +1,26 @@
+--  { dg-do compile }
+with Subp_Inst_Pkg;
+procedure Subp_Inst is
+   procedure Test_Access_Image is
+      package Nested is
+         type T is private;
+
+         type T_General_Access is access all T;
+         type T_Access is access T;
+         function Image1 is new Subp_Inst_Pkg.Image (T, T_Access);
+         function Image2 is new Subp_Inst_Pkg.Image (T, T_General_Access);
+         function Image3 is new Subp_Inst_Pkg.T_Image (T);
+      private
+         type T is null record;
+      end Nested;
+
+      A : aliased Nested.T;
+      AG : aliased constant Nested.T_General_Access := A'Access;
+      AA : aliased constant Nested.T_Access := new Nested.T;
+   begin
+      null;
+   end Test_Access_Image;
+
+begin
+   Test_Access_Image;
+end Subp_Inst;
Index: ../testsuite/gnat.dg/subp_inst_pkg.adb
===================================================================
--- ../testsuite/gnat.dg/subp_inst_pkg.adb	(revision 0)
+++ ../testsuite/gnat.dg/subp_inst_pkg.adb	(revision 0)
@@ -0,0 +1,20 @@
+with Ada.Unchecked_Conversion;
+with System.Address_Image;
+package body Subp_Inst_Pkg is
+
+   function Image (Val : T_Access) return String is
+      function Convert is new Ada.Unchecked_Conversion
+         (T_Access, System.Address);
+   begin
+      return System.Address_Image (Convert (Val));
+   end Image;
+
+   function T_Image (Val : access T) return String is
+      type T_Access is access all T;
+      function Convert is new Ada.Unchecked_Conversion
+         (T_Access, System.Address);
+   begin
+      return System.Address_Image (Convert (Val));
+   end T_Image;
+
+end Subp_Inst_Pkg;
Index: ../testsuite/gnat.dg/subp_inst_pkg.ads
===================================================================
--- ../testsuite/gnat.dg/subp_inst_pkg.ads	(revision 0)
+++ ../testsuite/gnat.dg/subp_inst_pkg.ads	(revision 0)
@@ -0,0 +1,13 @@
+package Subp_Inst_Pkg is
+   pragma Pure;
+
+   generic
+      type T;
+      type T_Access is access T;
+   function Image (Val : T_Access) return String;
+
+   generic
+      type T;
+   function T_Image (Val : access T) return String;
+
+end Subp_Inst_Pkg;