[Ada] Crash with Inline_Always on a function with an extended return

This patch fixes a crash on a unit with a function with the GNAT-specific
Inline_Always pragma whose body is an extended return statement, when compiling
with no optimization level specified.

2018-06-11  Ed Schonberg  <schonberg@adacore.com>

gcc/ada/

	* inline.adb (Expand_Inlined_Call): If no optimization level is
	specified, the expansion of a call to an Inline_Always function is
	fully performed in the front-end even on a target that support back-end
	inlining.

gcc/testsuite/

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

From-SVN: r261402

4 files changed, 93 insertions, 8 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index a2624b8..25e133e 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,10 @@
+2018-06-11  Ed Schonberg  <schonberg@adacore.com>
+
+	* inline.adb (Expand_Inlined_Call): If no optimization level is
+	specified, the expansion of a call to an Inline_Always function is
+	fully performed in the front-end even on a target that support back-end
+	inlining.
+
 2018-06-11  Arnaud Charlet  <charlet@adacore.com>
 
 	* bindgen.adb (Gen_Adainit): Protect reference to System.Parameters
diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb
index 336b336..f7e6b28 100644
--- a/gcc/ada/inline.adb
+++ b/gcc/ada/inline.adb
@@ -2269,11 +2269,16 @@ package body Inline is
      Subp      : Entity_Id;
      Orig_Subp : Entity_Id)
    is
-      Loc       : constant Source_Ptr := Sloc (N);
-      Is_Predef : constant Boolean :=
-                    Is_Predefined_Unit (Get_Source_Unit (Subp));
-      Orig_Bod  : constant Node_Id :=
+      Loc           : constant Source_Ptr := Sloc (N);
+      Is_Predef     : constant Boolean :=
+                        Is_Predefined_Unit (Get_Source_Unit (Subp));
+      Orig_Bod      : constant Node_Id :=
                     Body_To_Inline (Unit_Declaration_Node (Subp));
+      Uses_Back_End : constant Boolean :=
+                         Back_End_Inlining and then Optimization_Level > 0;
+      --  The back-end expansion is used if the target supports back-end
+      --  inlining and some level of optimixation is required; otherwise
+      --  the inlining takes place fully as a tree expansion.
 
       Blk      : Node_Id;
       Decl     : Node_Id;
@@ -2840,7 +2845,7 @@ package body Inline is
    begin
       --  Initializations for old/new semantics
 
-      if not Back_End_Inlining then
+      if not Uses_Back_End then
          Is_Unc      := Is_Array_Type (Etype (Subp))
                           and then not Is_Constrained (Etype (Subp));
          Is_Unc_Decl := False;
@@ -2914,7 +2919,7 @@ package body Inline is
 
       --  Old semantics
 
-      if not Back_End_Inlining then
+      if not Uses_Back_End then
          declare
             Bod : Node_Id;
 
@@ -2958,8 +2963,20 @@ package body Inline is
                begin
                   First_Decl := First (Declarations (Blk));
 
+                  --  If the body is a single extended return statement,
+                  --  the resulting block is a nested block.
+
+                  if No (First_Decl) then
+                        First_Decl := First
+                          (Statements (Handled_Statement_Sequence (Blk)));
+
+                     if Nkind (First_Decl) = N_Block_Statement then
+                        First_Decl := First (Declarations (First_Decl));
+                     end if;
+                  end if;
+
                   if Nkind (First_Decl) /= N_Object_Declaration then
-                     return;
+                     return;  --  No front-end inlining possible,
                   end if;
 
                   if Nkind (Parent (N)) /= N_Assignment_Statement then
@@ -3288,7 +3305,7 @@ package body Inline is
          --  of the result of a call to an inlined function that returns
          --  an unconstrained type
 
-         elsif Back_End_Inlining
+         elsif Uses_Back_End
            and then Nkind (Parent (N)) = N_Object_Declaration
            and then Is_Unc
          then
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 579cc61..6d5e964 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,5 +1,9 @@
 2018-06-11  Ed Schonberg  <schonberg@adacore.com>
 
+	* gnat.dg/inline_always1.adb: New testcase.
+
+2018-06-11  Ed Schonberg  <schonberg@adacore.com>
+
 	* gnat.dg/nested_generic2.adb, gnat.dg/nested_generic2.ads,
 	gnat.dg/nested_generic2_g1.adb, gnat.dg/nested_generic2_g1.ads,
 	gnat.dg/nested_generic2_g2.ads: New testcase.
diff --git a/gcc/testsuite/gnat.dg/inline_always1.adb b/gcc/testsuite/gnat.dg/inline_always1.adb
new file mode 100644
index 0000000..59f161c
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/inline_always1.adb
@@ -0,0 +1,57 @@
+--  { dg-do compile }
+
+with Ada.Text_IO;
+
+procedure Inline_Always1 is
+
+   function S(N : Integer ) return String is
+   begin
+      return "hello world";
+   end S;
+
+   type String_Access is access all String;
+   type R  is record
+      SA : String_Access;
+   end record;
+
+   Data : aliased String := "hello world";
+   My_SA : constant String_Access :=  Data'Access;
+   function Make_R( S : String ) return R is
+      My_R : R;
+   begin
+      My_R.SA := My_SA;
+      return My_R;
+   end Make_R;
+
+   function Get_String( My_R : R ) return String
+   is
+   begin
+      return S : String(My_R.SA.all'Range) do
+         S := My_R.SA.all;
+      end return;
+   end Get_String;
+   pragma Inline_Always( Get_String);
+
+   My_R : constant R := Make_R( "hello world");
+begin
+   for I in 1..10000 loop
+      declare
+         Res : constant String := S( 4 );
+      begin
+         Ada.Text_IO.Put_Line(Res);
+      end;
+      declare
+         Res : constant String := S( 4 );
+      begin
+         Ada.Text_IO.Put_Line(Res);
+      end;
+
+      declare
+         S : constant String := Get_String( My_R );
+      begin
+         Ada.Text_IO.Put_Line(S);
+         Ada.Text_IO.Put_Line(My_R.SA.all);
+      end;
+   end loop;
+
+end Inline_Always1;