* gcc-interface/decl.c (gnat_to_gnu_entity) <E_Function>: Do not make

	a function returning an unconstrained type 'const' for the middle-end.

	* gcc-interface/trans.c (Pragma_to_gnu) <case Pragma_Warning>: Use
	exact condition to detect Reason => "..." pattern.


git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@221916 138bc75d-0d04-0410-961f-82ee72b054a4

9 files changed, 83 insertions, 9 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 8b9fbe5b65f..d93e5ac9c88 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,11 @@
+2015-04-08  Eric Botcazou  <ebotcazou@adacore.com>
+
+	* gcc-interface/decl.c (gnat_to_gnu_entity) <E_Function>: Do not make
+	a function returning an unconstrained type 'const' for the middle-end.
+
+	* gcc-interface/trans.c (Pragma_to_gnu) <case Pragma_Warning>: Use
+	exact condition to detect Reason => "..." pattern.
+
 2015-03-31  Tom de Vries  <tom@codesourcery.com>
 
 	PR ada/65490
diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c
index 0027d6f2f0c..d908a1b750d 100644
--- a/gcc/ada/gcc-interface/decl.c
+++ b/gcc/ada/gcc-interface/decl.c
@@ -4266,8 +4266,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
 		return_by_direct_ref_p = true;
 	      }
 
-	    /* If we are supposed to return an unconstrained array type, make
-	       the actual return type the fat pointer type.  */
+	    /* If the return type is an unconstrained array type, the return
+	       value will be allocated on the secondary stack so the actual
+	       return type is the fat pointer type.  */
 	    else if (TREE_CODE (gnu_return_type) == UNCONSTRAINED_ARRAY_TYPE)
 	      {
 		gnu_return_type = TREE_TYPE (gnu_return_type);
@@ -4275,8 +4276,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
 	      }
 
 	    /* Likewise, if the return type requires a transient scope, the
-	       return value will be allocated on the secondary stack so the
-	       actual return type is the pointer type.  */
+	       return value will also be allocated on the secondary stack so
+	       the actual return type is the pointer type.  */
 	    else if (Requires_Transient_Scope (gnat_return_type))
 	      {
 		gnu_return_type = build_pointer_type (gnu_return_type);
@@ -4591,11 +4592,14 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
 				 return_by_direct_ref_p,
 				 return_by_invisi_ref_p);
 
-	/* A subprogram (something that doesn't return anything) shouldn't
-	   be considered const since there would be no reason for such a
+	/* A procedure (something that doesn't return anything) shouldn't be
+	   considered const since there would be no reason for calling such a
 	   subprogram.  Note that procedures with Out (or In Out) parameters
-	   have already been converted into a function with a return type.  */
-	if (TREE_CODE (gnu_return_type) == VOID_TYPE)
+	   have already been converted into a function with a return type.
+	   Similarly, if the function returns an unconstrained type, then the
+	   function will allocate the return value on the secondary stack and
+	   thus calls to it cannot be CSE'ed, lest the stack be reclaimed.  */
+	if (TREE_CODE (gnu_return_type) == VOID_TYPE || return_unconstrained_p)
 	  const_flag = false;
 
 	if (const_flag || volatile_flag)
diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c
index 73794772158..6ffee062a04 100644
--- a/gcc/ada/gcc-interface/trans.c
+++ b/gcc/ada/gcc-interface/trans.c
@@ -1444,7 +1444,8 @@ Pragma_to_gnu (Node_Id gnat_node)
 	      }
 
 	    /* Deal with optional pattern (but ignore Reason => "...").  */
-	    if (Present (Next (gnat_temp)) && No (Chars (Next (gnat_temp))))
+	    if (Present (Next (gnat_temp))
+		&& Chars (Next (gnat_temp)) != Name_Reason)
 	      {
 		/* pragma Warnings (On | Off, Name) is handled differently.  */
 		if (Nkind (Expression (Next (gnat_temp))) != N_String_Literal)
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 74a39ec2a23..a6a7be318be 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2015-04-08  Eric Botcazou  <ebotcazou@adacore.com>
+
+	* gnat.dg/opt48.adb: New test.
+	* gnat.dg/opt48_pkg1.ad[sb]: New helper.
+	* gnat.dg/opt48_pkg2.ad[sb]: Likewise.
+
 2015-04-07  Jan Hubicka  <hubicka@ucw.cz>
 
 	PR ipa/65540
diff --git a/gcc/testsuite/gnat.dg/opt48.adb b/gcc/testsuite/gnat.dg/opt48.adb
new file mode 100644
index 00000000000..3f611cd1d6a
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/opt48.adb
@@ -0,0 +1,12 @@
+-- { dg-do run }
+-- { dg-options "-O" }
+
+with Opt48_Pkg1; use Opt48_Pkg1;
+with Opt48_Pkg2; use Opt48_Pkg2;
+
+procedure Opt48 is
+begin
+   if Get_Z /= (12, "Hello world!") then
+      raise Program_Error;
+   end if;
+end;
diff --git a/gcc/testsuite/gnat.dg/opt48_pkg1.adb b/gcc/testsuite/gnat.dg/opt48_pkg1.adb
new file mode 100644
index 00000000000..306551cea5f
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/opt48_pkg1.adb
@@ -0,0 +1,17 @@
+package body Opt48_Pkg1 is
+
+   function G return Rec is
+   begin
+      return (32, "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA");
+   end G;
+
+   X : Rec := F;
+   Y : Rec := G;
+   Z : Rec := F;
+
+   function Get_Z return Rec is
+   begin
+      return Z;
+   end;
+
+end Opt48_Pkg1;
diff --git a/gcc/testsuite/gnat.dg/opt48_pkg1.ads b/gcc/testsuite/gnat.dg/opt48_pkg1.ads
new file mode 100644
index 00000000000..50154c20c03
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/opt48_pkg1.ads
@@ -0,0 +1,7 @@
+with Opt48_Pkg2; use Opt48_Pkg2;
+
+package Opt48_Pkg1 is
+
+   function Get_Z return Rec;
+
+end Opt48_Pkg1;
diff --git a/gcc/testsuite/gnat.dg/opt48_pkg2.adb b/gcc/testsuite/gnat.dg/opt48_pkg2.adb
new file mode 100644
index 00000000000..41836e7be71
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/opt48_pkg2.adb
@@ -0,0 +1,8 @@
+package body Opt48_Pkg2 is
+
+   function F return Rec is
+   begin
+      return (12, "Hello world!");
+   end F;
+
+end Opt48_Pkg2;
diff --git a/gcc/testsuite/gnat.dg/opt48_pkg2.ads b/gcc/testsuite/gnat.dg/opt48_pkg2.ads
new file mode 100644
index 00000000000..d3edbeadb68
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/opt48_pkg2.ads
@@ -0,0 +1,11 @@
+package Opt48_Pkg2 is
+
+   pragma Pure;
+
+   type Rec (L : Natural) is record
+      S : String (1 .. L);
+   end record;
+
+   function F return Rec;
+
+end Opt48_Pkg2;