This patch fixes a spurious error on a classwide precondition for a subprogram
S that is a primitive of some type T, when the precondition includes a
dispatching call on a classwide formal of S whose type is urelated to T.
The following must compile quietly:
gnatmake -q main
---
with Derived_Objects;
with Using_Interfaces;
with Using_Objects;
procedure Main is
D : aliased Derived_Objects.Derived_Object;
U : aliased Using_Objects.Using_Object;
UI : not null access Using_Interfaces.Using_Interface'Class :=
U'Access;
begin
U.Use_An_Object (D);
UI.Use_An_Object (D);
U.Use_A_Valid_Object (D);
UI.Use_A_Valid_Object (D);
end Main;
---
package Base_Objects is
type Base_Object is tagged null record;
function Is_Valid
(This : in Base_Object)
return Boolean
is (True);
end Base_Objects;
---
with Base_Objects;
package Derived_Objects is
type Derived_Object is new Base_Objects.Base_Object with null record;
end Derived_Objects;
---
with Base_Objects;
package Using_Interfaces is
type Using_Interface is limited interface;
procedure Use_An_Object
(This : aliased in out Using_Interface;
Obj : in Base_Objects.Base_Object'Class) is abstract;
procedure Use_A_Valid_Object
(This : aliased in out Using_Interface;
Obj : in Base_Objects.Base_Object'Class) is abstract
with
Pre'Class => Obj.Is_Valid;
end Using_Interfaces;
---
with Base_Objects;
with Using_Interfaces;
package Using_Objects is
type Using_Object is
limited new Using_Interfaces.Using_Interface with null record;
procedure Use_An_Object
(This : aliased in out Using_Object;
Base : in Base_Objects.Base_Object'Class)
is
null;
procedure Use_A_Valid_Object
(This : aliased in out Using_Object;
Base : in Base_Objects.Base_Object'Class)
is
null;
end Using_Objects;
Tested on x86_64-pc-linux-gnu, committed on trunk
2017-09-07 Ed Schonberg <schonb...@adacore.com>
* exp_disp.adb (Replace_Formals): If thr formal is classwide,
and thus not a controlling argument, preserve its type after
rewriting because it may appear in an nested call with a classwide
parameter.
Index: exp_disp.adb
===================================================================
--- exp_disp.adb (revision 251838)
+++ exp_disp.adb (working copy)
@@ -701,6 +701,16 @@
while Present (F) loop
if F = Entity (N) then
Rewrite (N, New_Copy_Tree (A));
+
+ -- If the formal is class-wide, and thus not a
+ -- controlling argument, preserve its type because
+ -- it may appear in a nested call with a class-wide
+ -- parameter.
+
+ if Is_Class_Wide_Type (Etype (F)) then
+ Set_Etype (N, Etype (F));
+ end if;
+
exit;
end if;
