From: Ed Schonberg <schonberg@adacore.com>
Date: Mon, 8 Jul 2019 08:13:04 +0000 (+0000)
Subject: [Ada] Crash on named actual in postcondition for generic subprogram
X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=5291985c00302036cc6d5932fdffb9acab3043cf;p=gcc.git

[Ada] Crash on named actual in postcondition for generic subprogram

This patch fixes a crash on compiling the postcondtion for a generic
subprogram, when the postcondition is a call with both positional and
named parameter associations.

2019-07-08  Ed Schonberg  <schonberg@adacore.com>

gcc/ada/

	* sem_ch13.adb (Analyze_Aspect_Specifications): For a
	pre/postcondition of a generic subprogram declaration, do not
	use Relocate_Node on the aspect expression to construct the
	corresponding attribute specification, to prevent tree anomalies
	when the expression is a call with named actual parameters.

gcc/testsuite/

	* gnat.dg/predicate9.adb: New testcase.

From-SVN: r273201
---

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 9a86909fe68..d651ff09eaf 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,11 @@
+2019-07-08  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_ch13.adb (Analyze_Aspect_Specifications): For a
+	pre/postcondition of a generic subprogram declaration, do not
+	use Relocate_Node on the aspect expression to construct the
+	corresponding attribute specification, to prevent tree anomalies
+	when the expression is a call with named actual parameters.
+
 2019-07-08  Javier Miranda  <miranda@adacore.com>
 
 	* sem_attr.adb (Analyze_Attribute [Attribute_Size]): For pragmas
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index b62e2971def..8467f753576 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -3495,12 +3495,28 @@ package body Sem_Ch13 is
                   --  because subsequent visibility analysis of the aspect
                   --  depends on this sharing. This should be cleaned up???
 
-                  Make_Aitem_Pragma
-                    (Pragma_Argument_Associations => New_List (
-                       Make_Pragma_Argument_Association (Eloc,
-                         Chars      => Name_Check,
-                         Expression => Relocate_Node (Expr))),
-                       Pragma_Name                => Pname);
+                  --  If the context is generic or involves ASIS, we want
+                  --  to preserve the original tree, and simply share it
+                  --  between aspect and generated attribute. This parallels
+                  --  what is done in sem_prag.adb (see Get_Argument).
+
+                  declare
+                     New_Expr : Node_Id;
+
+                  begin
+                     if ASIS_Mode or else Inside_A_Generic then
+                        New_Expr := Expr;
+                     else
+                        New_Expr := Relocate_Node (Expr);
+                     end if;
+
+                     Make_Aitem_Pragma
+                       (Pragma_Argument_Associations => New_List (
+                          Make_Pragma_Argument_Association (Eloc,
+                            Chars      => Name_Check,
+                            Expression => New_Expr)),
+                          Pragma_Name                => Pname);
+                  end;
 
                   --  Add message unless exception messages are suppressed
 
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 744f7824355..94ad86f9895 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+2019-07-08  Ed Schonberg  <schonberg@adacore.com>
+
+	* gnat.dg/predicate9.adb: New testcase.
+
 2019-07-08  Justin Squirek  <squirek@adacore.com>
 
 	* gnat.dg/sso16.adb: New testcase.
diff --git a/gcc/testsuite/gnat.dg/predicate9.adb b/gcc/testsuite/gnat.dg/predicate9.adb
new file mode 100644
index 00000000000..ebcfca7f838
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/predicate9.adb
@@ -0,0 +1,21 @@
+--  { dg-do compile }
+procedure Predicate9 is
+  function Num (x : Integer) return Integer is (X + 1);
+  function name (X : String) return Integer is (X'Size);
+  function Post (One : Integer; Two : Integer) return Boolean;
+
+  generic
+     type T is private;
+  procedure Pro (Z : Integer) with Post =>
+    Post (Num (5), Two => Name ("yeah"));
+
+  function Post (One : Integer; Two : Integer) return Boolean
+  is (True);
+
+  procedure Pro (Z : Integer) is
+  begin
+     null;
+  end Pro;
+begin
+   null;
+end Predicate9;