exp_ch6.adb: (Make_Build_In_Place_Call_In_Object_Declaration): Take care of unchecked...

gcc/ada/

2017-10-09  Bob Duff  <duff@adacore.com>

	* 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  <schonberg@adacore.com>

	* 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  <schonberg@adacore.com>

	* gnat.dg/class_wide4.adb, gnat.dg/class_wide4_pkg.ads,
	gnat.dg/class_wide4_pkg2.ads: New testcase.

From-SVN: r253554

6 files changed, 101 insertions, 1 deletions

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  <duff@adacore.com>
 
+	* 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  <schonberg@adacore.com>
+
+	* 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  <duff@adacore.com>
+
 	* 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;