[Ada] Incorrect expansion on renamings of formal parameters

This patch fixes an issue whereby a renaming of an unconstrained formal
parameter leads to spurious runtime errors; manifesting either as a
storage or constraint error due to incorrect bounds being assumed.

This issue also occurs when the renamings are implicit such as through
generic instantiations.

2019-07-03  Justin Squirek  <squirek@adacore.com>

gcc/ada/

	* sem_ch8.adb (Analyze_Object_Renaming): Add call to search for
	the appropriate actual subtype of the object renaming being
	analyzed.
	(Check_Constrained_Object): Minor cleanup.

gcc/testsuite/

	* gnat.dg/renaming13.adb, gnat.dg/renaming14.adb: New testcases.

From-SVN: r272982

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 608d870..152820f 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,10 @@
+2019-07-03  Justin Squirek  <squirek@adacore.com>
+
+       * sem_ch8.adb (Analyze_Object_Renaming): Add call to search for
+       the appropriate actual subtype of the object renaming being
+       analyzed.
+       (Check_Constrained_Object): Minor cleanup.
+
 2019-07-03  Yannick Moy  <moy@adacore.com>
 
        * sem_spark.adb (Get_Observed_Or_Borrowed_Expr): New function to

diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb
index 5f515bc..b58ad64 100644 (file)
--- a/gcc/ada/sem_ch8.adb
+++ b/gcc/ada/sem_ch8.adb
@@ -784,9 +784,9 @@ package body Sem_Ch8 is
 
       begin
          if Nkind_In (Nam, N_Function_Call, N_Explicit_Dereference)
-           and then Is_Composite_Type (Etype (Nam))
-           and then not Is_Constrained (Etype (Nam))
-           and then not Has_Unknown_Discriminants (Etype (Nam))
+           and then Is_Composite_Type (Typ)
+           and then not Is_Constrained (Typ)
+           and then not Has_Unknown_Discriminants (Typ)
            and then Expander_Active
          then
             --  If Actual_Subtype is already set, nothing to do
@@ -1122,7 +1122,11 @@ package body Sem_Ch8 is
          Wrong_Type (Nam, T);
       end if;
 
-      T2 := Etype (Nam);
+      --  We must search for an actual subtype here so that the bounds of
+      --  objects of unconstrained types don't get dropped on the floor - such
+      --  as with renamings of formal parameters.
+
+      T2 := Get_Actual_Subtype_If_Available (Nam);
 
       --  Ada 2005 (AI-326): Handle wrong use of incomplete type
 

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 9116893..709e0c5 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+2019-07-03  Justin Squirek  <squirek@adacore.com>
+
+       * gnat.dg/renaming13.adb, gnat.dg/renaming14.adb: New testcases.
+
 2019-07-03  Hristian Kirtchev  <kirtchev@adacore.com>
 
        * gnat.dg/inline15.adb, gnat.dg/inline15_gen.adb,

diff --git a/gcc/testsuite/gnat.dg/renaming13.adb b/gcc/testsuite/gnat.dg/renaming13.adb
new file mode 100644 (file)
index 0000000..434a71e
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/renaming13.adb
@@ -0,0 +1,21 @@
+--  { dg-do run }
+
+procedure Renaming13 is
+   type Stack_Type_Base is array (Natural range <>) of Integer;
+
+   procedure Foo (Buf : in out Stack_Type_Base) is
+      S : Stack_Type_Base renames Buf;
+
+      procedure Init is
+      begin
+         S := (others => 0);
+      end;
+
+   begin
+      Init;
+   end;
+
+   Temp : Stack_Type_Base (1 .. 100);
+begin
+   Foo (Temp);
+end;

diff --git a/gcc/testsuite/gnat.dg/renaming14.adb b/gcc/testsuite/gnat.dg/renaming14.adb
new file mode 100644 (file)
index 0000000..d61a82d
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/renaming14.adb
@@ -0,0 +1,32 @@
+--  { dg-do run }
+
+procedure Renaming14 is
+   type Rec_Typ is record
+      XX : Integer;
+   end record;
+
+   type Stack_Type_Base is array (Natural range <>) of Rec_Typ;
+
+   generic
+      S : in out Stack_Type_Base;
+   package Stack is
+      procedure Init;
+   end;
+
+   package body Stack is
+      procedure Init is
+      begin
+         S := (others => (XX => 0));
+      end;
+   end;
+
+   procedure Foo (Buf : in out Stack_Type_Base) is
+      package Stack_Inst is new Stack (Buf);
+   begin
+      Stack_Inst.Init;
+   end;
+
+   Temp : Stack_Type_Base (1 .. 100);
+begin
+   Foo (Temp);
+end;