diff mbox series

[Ada] Spurious error in precondition and classwide parameter

Message ID 20170907095834.GA15662@adacore.com
State New
Headers show
Series [Ada] Spurious error in precondition and classwide parameter | expand

Commit Message

Arnaud Charlet Sept. 7, 2017, 9:58 a.m. UTC
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  <schonberg@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.
diff mbox series

Patch

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;