From 5d57846b76a90d2a1f12b519afdb636851a15e90 Mon Sep 17 00:00:00 2001 From: Pierre-Marie de Rodat Date: Mon, 9 Oct 2017 18:23:07 +0000 Subject: [PATCH] exp_ch6.adb: (Make_Build_In_Place_Call_In_Object_Declaration): Take care of unchecked... gcc/ada/ 2017-10-09 Bob Duff * exp_ch6.adb: (Make_Build_In_Place_Call_In_Object_Declaration): Take care of unchecked conversions in addition to regular conversions. This takes care of a case where a type is derived from a private untagged type that is completed by a tagged controlled type. 2017-10-09 Ed Schonberg * exp_disp.adb (Build_Class_Wide_Check, Replace_Formals): When rewriting a class-wide condition, handle properly the case where the controlling argument of the operation to which the condition applies is an access to a tagged type, and the condition includes a dispatching call with an implicit dereference. gcc/testsuite/ 2017-10-09 Ed Schonberg * gnat.dg/class_wide4.adb, gnat.dg/class_wide4_pkg.ads, gnat.dg/class_wide4_pkg2.ads: New testcase. From-SVN: r253554 --- gcc/ada/ChangeLog | 15 +++++++++++++++ gcc/ada/exp_ch6.adb | 4 +++- gcc/ada/exp_disp.adb | 12 ++++++++++++ gcc/testsuite/gnat.dg/class_wide4.adb | 20 ++++++++++++++++++++ gcc/testsuite/gnat.dg/class_wide4_pkg.ads | 21 +++++++++++++++++++++ gcc/testsuite/gnat.dg/class_wide4_pkg2.ads | 30 ++++++++++++++++++++++++++++++ 6 files changed, 101 insertions(+), 1 deletion(-) create mode 100644 gcc/testsuite/gnat.dg/class_wide4.adb create mode 100644 gcc/testsuite/gnat.dg/class_wide4_pkg.ads create mode 100644 gcc/testsuite/gnat.dg/class_wide4_pkg2.ads diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index cba97a1..ff6392a 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,20 @@ 2017-10-09 Bob Duff + * exp_ch6.adb: (Make_Build_In_Place_Call_In_Object_Declaration): Take + care of unchecked conversions in addition to regular conversions. This + takes care of a case where a type is derived from a private untagged + type that is completed by a tagged controlled type. + +2017-10-09 Ed Schonberg + + * exp_disp.adb (Build_Class_Wide_Check, Replace_Formals): When + rewriting a class-wide condition, handle properly the case where the + controlling argument of the operation to which the condition applies is + an access to a tagged type, and the condition includes a dispatching + call with an implicit dereference. + +2017-10-09 Bob Duff + * exp_ch6.adb: (Make_Build_In_Place_Call_In_Object_Declaration): Remove the code at the end of this procedure that was setting the type of a class-wide object to the specific type returned by a function call. diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index f0afc1e..beb0291 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -8466,7 +8466,9 @@ package body Exp_Ch6 is Set_Etype (Def_Id, Ptr_Typ); Set_Is_Known_Non_Null (Def_Id); - if Nkind (Function_Call) = N_Type_Conversion then + if Nkind_In + (Function_Call, N_Type_Conversion, N_Unchecked_Type_Conversion) + then Res_Decl := Make_Object_Declaration (Loc, Defining_Identifier => Def_Id, diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 80276a9..63c996e 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -736,6 +736,18 @@ package body Exp_Disp is if Is_Class_Wide_Type (Etype (F)) then Set_Etype (N, Etype (F)); + + -- Conversely, if this is a controlling argument + -- (in a dispatching call in the condition) + -- that is a dereference, the source is an access to + -- classwide type, so preserve the dispatching nature + -- of the call in the rewritten condition. + + elsif Nkind (Parent (N)) = N_Explicit_Dereference + and then Is_Controlling_Actual (Parent (N)) + then + Set_Controlling_Argument (Parent (Parent (N)), + Parent (N)); end if; exit; diff --git a/gcc/testsuite/gnat.dg/class_wide4.adb b/gcc/testsuite/gnat.dg/class_wide4.adb new file mode 100644 index 0000000..d8e2ffa --- /dev/null +++ b/gcc/testsuite/gnat.dg/class_wide4.adb @@ -0,0 +1,20 @@ +-- { dg-do run } + +with Class_Wide4_Pkg; +with Class_Wide4_Pkg2; + +procedure Class_Wide4 is + D : aliased Class_Wide4_Pkg.Data_Object; + O : aliased Class_Wide4_Pkg.Object; + IA : not null access Class_Wide4_Pkg.Conditional_Interface'Class := + O'Access; + I : Class_Wide4_Pkg.Conditional_Interface'Class renames + Class_Wide4_Pkg.Conditional_Interface'Class (O); +begin + O.Do_Stuff; + O.Do_Stuff_Access; + IA.Do_Stuff; + IA.Do_Stuff_Access; + I.Do_Stuff; + I.Do_Stuff_Access; +end Class_Wide4; diff --git a/gcc/testsuite/gnat.dg/class_wide4_pkg.ads b/gcc/testsuite/gnat.dg/class_wide4_pkg.ads new file mode 100644 index 0000000..b8ba44c --- /dev/null +++ b/gcc/testsuite/gnat.dg/class_wide4_pkg.ads @@ -0,0 +1,21 @@ +package Class_Wide4_Pkg is + + type Conditional_Interface is limited interface; + + type Data_Object is tagged null record; + + function Is_Valid + (This : in Conditional_Interface) + return Boolean is abstract; + + procedure Do_Stuff + (This : in out Conditional_Interface) is abstract + with + Pre'Class => This.Is_Valid; + + procedure Do_Stuff_Access + (This : not null access Conditional_Interface) is abstract + with + Pre'Class => This.Is_Valid; + +end Class_Wide4_Pkg; diff --git a/gcc/testsuite/gnat.dg/class_wide4_pkg2.ads b/gcc/testsuite/gnat.dg/class_wide4_pkg2.ads new file mode 100644 index 0000000..1e5799d --- /dev/null +++ b/gcc/testsuite/gnat.dg/class_wide4_pkg2.ads @@ -0,0 +1,30 @@ +with Class_Wide4_Pkg; + +package Class_Wide4_Pkg2 is + + type Object is limited new + Class_Wide4_Pkg.Conditional_Interface with + record + Val : Integer := 1234; + end record; + + function Is_Valid + (This : in Object) + return Boolean + is + (This.Val = 1234); + + function Is_Supported_Data + (This : in Object; + Data : not null access Class_Wide4_Pkg.Data_Object'Class) + return Boolean + is + (This.Val = 1234); + + procedure Do_Stuff + (This : in out Object) is null; + + procedure Do_Stuff_Access + (This : not null access Object) is null; + +end Class_Wide4_Pkg2; -- 2.7.4