From c06a59be1990743d1520b89016a532572a9256ab Mon Sep 17 00:00:00 2001 From: Justin Squirek Date: Thu, 24 May 2018 13:05:32 +0000 Subject: [PATCH] [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 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 --- gcc/ada/ChangeLog | 9 +++++++++ gcc/ada/exp_ch3.adb | 6 ++++-- gcc/ada/exp_ch5.adb | 11 +++++++++-- gcc/testsuite/ChangeLog | 4 ++++ gcc/testsuite/gnat.dg/raise_expr.adb | 27 +++++++++++++++++++++++++++ 5 files changed, 53 insertions(+), 4 deletions(-) create mode 100644 gcc/testsuite/gnat.dg/raise_expr.adb diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index bf69dbf2d79..e0ea4595fa3 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,12 @@ +2018-05-24 Justin Squirek + + * 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 * 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 4c5d940ee6b..4c3a7b768bc 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 81fb162f39d..0989370d5e8 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 8381235981c..ad047a47412 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2018-05-24 Justin Squirek + + * gnat.dg/raise_expr.adb: New testcase. + 2018-05-24 Hristian Kirtchev * 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 00000000000..cdca9064425 --- /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; -- 2.30.2