From patchwork Tue Oct  5 09:57:50 2010
Content-Type: text/plain; charset="utf-8"
MIME-Version: 1.0
Content-Transfer-Encoding: 7bit
Subject: [Ada] Equality on classwide arguments of constrained private
 extensions
Date: Mon, 04 Oct 2010 23:57:50 -0000
From: Arnaud Charlet <charlet@adacore.com>
X-Patchwork-Id: 66784
Message-Id: <20101005095750.GA8044@adacore.com>
To: gcc-patches@gcc.gnu.org
Cc: Ed Schonberg <schonberg@adacore.com>

This patch simplifies type compatibility checks when one of the types is class-
wide, and the other is the specific type, which is a private extension that
constrains the discriminant of its parent.

The following must compile quietly:
   gcc -c main.adb

with P;
procedure Main is
   procedure Test
     (Left : access P.Child_1_3'Class;
      Right : access P.Child_1_3'Class) is
   begin
      if P."=" (Left.all, Right.all) then
         null;
      end if;
   end Test;
   null;
end Main;

package P is
   type Root_1 (V : Integer) is tagged record
      F : Integer := 15;
   end record;

   type Child_1_3 is new Root_1 (1) with private;

private
   type Child_1_3 is new Root_1 (1) with null record;
end P;

Tested on x86_64-pc-linux-gnu, committed on trunk

2010-10-05  Ed Schonberg  <schonberg@adacore.com>

	* sem_type.adb (Covers): In a dispatching context, T1 covers T2 if T2
	is class-wide and T1 is its specific type.


Index: sem_type.adb
===================================================================
--- sem_type.adb	(revision 164940)
+++ sem_type.adb	(working copy)
@@ -876,10 +876,13 @@ package body Sem_Type is
             return False;
          end;
 
-      --  In a dispatching call the actual may be class-wide
+         --  In a dispatching call the actual may be class-wide, the formal
+         --  may be its specific type, or that of a descendent of it.
 
       elsif Is_Class_Wide_Type (T2)
-        and then Base_Type (Root_Type (T2)) = Base_Type (T1)
+        and then
+          (Class_Wide_Type (T1) = T2
+             or else Base_Type (Root_Type (T2)) = Base_Type (T1))
       then
          return True;