[Ada] Crash on return of raise expression

This patch fixes an issue whereby the compiler regarded assignments to limited
that consisted of raise expressions to be a compile-time error during
expansion.

2018-05-24  Justin Squirek  <squirek@adacore.com>

gcc/ada/

	* exp_ch3.adb (Expand_N_Object_Declaration): Ignore raising an error in
	expansion for limited tagged types when the node to be expanded is a
	raise expression due to it not representing a valid object.
	* exp_ch5.adb (Expand_N_Assignment_Statement): Add exception to error
	message regarding assignments to limited types to ignore genereated
	code.

gcc/testsuite/

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

From-SVN: r260654

5 files changed, 53 insertions, 4 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index bf69dbf..e0ea459 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,12 @@
+2018-05-24  Justin Squirek  <squirek@adacore.com>
+
+	* exp_ch3.adb (Expand_N_Object_Declaration): Ignore raising an error in
+	expansion for limited tagged types when the node to be expanded is a
+	raise expression due to it not representing a valid object.
+	* exp_ch5.adb (Expand_N_Assignment_Statement): Add exception to error
+	message regarding assignments to limited types to ignore genereated
+	code.
+
 2018-05-24  Hristian Kirtchev  <kirtchev@adacore.com>
 
 	* exp_util.adb (New_Class_Wide_Subtype): Capture and restore relevant
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 4c5d940..4c3a7b7 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -6952,9 +6952,11 @@ package body Exp_Ch3 is
 
                --  If we cannot convert the expression into a renaming we must
                --  consider it an internal error because the backend does not
-               --  have support to handle it.
+               --  have support to handle it. Also, when a raise expression is
+               --  encountered we ignore it since it doesn't return a value and
+               --  thus cannot trigger a copy.
 
-               else
+               elsif Nkind (Original_Node (Expr_Q)) /= N_Raise_Expression then
                   pragma Assert (False);
                   raise Program_Error;
                end if;
diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb
index 81fb162..0989370 100644
--- a/gcc/ada/exp_ch5.adb
+++ b/gcc/ada/exp_ch5.adb
@@ -2467,12 +2467,19 @@ package body Exp_Ch5 is
                   --  extension of a limited interface, and the actual is
                   --  limited. This is an error according to AI05-0087, but
                   --  is not caught at the point of instantiation in earlier
-                  --  versions.
+                  --  versions. We also must verify that the limited type does
+                  --  not come from source as corner cases may exist where
+                  --  an assignment was not intended like the pathological case
+                  --  of a raise expression within a return statement.
 
                   --  This is wrong, error messages cannot be issued during
                   --  expansion, since they would be missed in -gnatc mode ???
 
-                  Error_Msg_N ("assignment not available on limited type", N);
+                  if Comes_From_Source (N) then
+                     Error_Msg_N
+                       ("assignment not available on limited type", N);
+                  end if;
+
                   return;
                end if;
 
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 8381235..ad047a4 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+2018-05-24  Justin Squirek  <squirek@adacore.com>
+
+	* gnat.dg/raise_expr.adb: New testcase.
+
 2018-05-24  Hristian Kirtchev  <kirtchev@adacore.com>
 
 	* gnat.dg/formal_containers.adb: New testcase.
diff --git a/gcc/testsuite/gnat.dg/raise_expr.adb b/gcc/testsuite/gnat.dg/raise_expr.adb
new file mode 100644
index 0000000..cdca906
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/raise_expr.adb
@@ -0,0 +1,27 @@
+--  { dg-do compile }
+
+procedure Raise_Expr is
+
+   E : exception;
+
+   type T is tagged limited null record;
+   type TC is new T with null record;
+
+   function F0 return Boolean is
+   begin
+       return raise E;
+   end;
+
+   function F return T'Class is
+     TT : T;
+   begin
+      return raise E; -- Causes compile-time crash
+   end F;
+
+begin
+   declare
+      O : T'class  := F;
+   begin
+      null;
+   end;
+end Raise_Expr;