From eee51f3dd6d8e444270efb6fe191524b79a01445 Mon Sep 17 00:00:00 2001 From: Justin Squirek Date: Wed, 3 Jul 2019 08:16:06 +0000 Subject: [PATCH] [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 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 --- gcc/ada/ChangeLog | 7 ++++++ gcc/ada/sem_ch8.adb | 12 +++++++---- gcc/testsuite/ChangeLog | 4 ++++ gcc/testsuite/gnat.dg/renaming13.adb | 21 ++++++++++++++++++ gcc/testsuite/gnat.dg/renaming14.adb | 32 ++++++++++++++++++++++++++++ 5 files changed, 72 insertions(+), 4 deletions(-) create mode 100644 gcc/testsuite/gnat.dg/renaming13.adb create mode 100644 gcc/testsuite/gnat.dg/renaming14.adb diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 608d87006d1..152820f99de 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,10 @@ +2019-07-03 Justin Squirek + + * 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 * 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 5f515bcf422..b58ad64535d 100644 --- 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 91168935178..709e0c574b5 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2019-07-03 Justin Squirek + + * gnat.dg/renaming13.adb, gnat.dg/renaming14.adb: New testcases. + 2019-07-03 Hristian Kirtchev * 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 index 00000000000..434a71e1eec --- /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 index 00000000000..d61a82dca89 --- /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; -- 2.30.2