From 6459a31f98f0607e194720c3f9e0e26b21ad3e61 Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Fri, 25 May 2018 09:04:42 +0000 Subject: [PATCH] [Ada] Crash on classwide precondition on subprogram with stub This patch allows the compiler to handle properly a classwide precondition on a primitive operation whose body is a stub and a separate subunit. Executing: gnatmake -gnata -q check ./check must yield: precondition violated ---- with Text_IO; with Msg_Data_Block_Decoder; use Msg_Data_Block_Decoder; procedure Check is Thing : T_Msg_Data_Block_Decoder; Value : Integer; begin begin Value := Get_Long_Term_Corrections (Thing); exception when others => Text_IO.Put_Line ("precondition violated"); end; end Check; ---- package Msg_Data_Block_Decoder is pragma Preelaborate; type T_Msg_Data_Block_Decoder is Tagged Limited null record; type T_Msg_Data_Block_Decoder_Class_Access is access all T_Msg_Data_Block_Decoder'Class; function Get_Decoded_Data (This : in T_Msg_Data_Block_Decoder) return Integer; function Get_Long_Term_Corrections (This : in T_Msg_Data_Block_Decoder) return Integer with Pre' Class => Get_Decoded_Data (T_Msg_Data_Block_Decoder'Class (This)) = 2; end Msg_Data_Block_Decoder; ---- package body Msg_Data_Block_Decoder is function Get_Long_Term_Corrections (This : in T_Msg_Data_Block_Decoder) return Integer is separate; function Get_Decoded_Data (This : in T_Msg_Data_Block_Decoder) return Integer is begin return 0; end Get_Decoded_Data; end Msg_Data_Block_Decoder; ---- separate (Msg_Data_Block_Decoder) function Get_Long_Term_Corrections (This : in T_Msg_Data_Block_Decoder) return Integer is begin return 0; end Get_Long_Term_Corrections; 2018-05-25 Ed Schonberg gcc/ada/ * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Do not create Class_Wide_Clone_Body when analyzing a subprogram_body_stub: the clone is created when the proper body of the stub is analyzed. * sem_util.adb (ZBuild_Class_Wide_Clone_Body): If the subprogram body is the proper body of a subunit, the cloned body must be inserted in the declarative list that contains the stub. From-SVN: r260734 --- gcc/ada/ChangeLog | 9 +++++++++ gcc/ada/sem_ch6.adb | 3 +++ gcc/ada/sem_util.adb | 13 ++++++++++++- 3 files changed, 24 insertions(+), 1 deletion(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 2e5fd67e46b..904194e5ebb 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,12 @@ +2018-05-25 Ed Schonberg + + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Do not create + Class_Wide_Clone_Body when analyzing a subprogram_body_stub: the clone + is created when the proper body of the stub is analyzed. + * sem_util.adb (ZBuild_Class_Wide_Clone_Body): If the subprogram body + is the proper body of a subunit, the cloned body must be inserted in + the declarative list that contains the stub. + 2018-05-25 Justin Squirek * exp_ch6.adb (Expand_Simple_Function_Return): Add guard in check to diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 5eab1e0394d..3d8849a0491 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -3844,10 +3844,13 @@ package body Sem_Ch6 is -- If the subprogram has a class-wide clone, build its body as a copy -- of the original body, and rewrite body of original subprogram as a -- wrapper that calls the clone. + -- If N is a stub, this construction will take place when the proper + -- body is analyzed. if Present (Spec_Id) and then Present (Class_Wide_Clone (Spec_Id)) and then (Comes_From_Source (N) or else Was_Expression_Function (N)) + and then Nkind (N) /= N_Subprogram_Body_Stub then Build_Class_Wide_Clone_Body (Spec_Id, N); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 00b7cfba891..033903c09ea 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -1365,7 +1365,18 @@ package body Sem_Util is -- (the original primitive may have carried one). Set_Must_Override (Specification (Clone_Body), False); - Insert_Before (Bod, Clone_Body); + + -- If the subprogram body is the proper body of a stub, insert the + -- subprogram after the stub, i.e. the same declarative region as + -- the original sugprogram. + + if Nkind (Parent (Bod)) = N_Subunit then + Insert_After (Corresponding_Stub (Parent (Bod)), Clone_Body); + + else + Insert_Before (Bod, Clone_Body); + end if; + Analyze (Clone_Body); end Build_Class_Wide_Clone_Body; -- 2.30.2