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.
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,
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;
--- /dev/null
+-- { 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;
--- /dev/null
+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;
--- /dev/null
+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;