A subtype of an interface type can appear as a progenitor in a type extension.
The routine that determines whether a given interface is a progenitor of a
type must take this subtype into account.
Compiling and executing main.adb must yield:
The integer: 42
---
with Ultimate_User;
procedure Main is
begin
Ultimate_User.Start;
end Main;
--
package Ultimate_User is
procedure Start;
end Ultimate_User;
---
with gp;
package user is
package Implementation is new gp (Message_Type => integer);
subtype T is Implementation.T;
subtype Dispatch_To_T is Implementation.Dispatch_To_T;
procedure Open (Dispatch_To : Dispatch_To_T) renames Implementation.Open;
end user;
---
generic
type Message_Type is private;
package Gp is
type T is limited interface;
procedure Dispatch
(Dispatch_To : in out T; Message : Message_Type) is abstract;
type Dispatch_To_T is access all T'Class;
procedure Open (Dispatch_To : Dispatch_To_T);
procedure Send (Message : Message_Type);
end Gp;
---
package body Gp is
Dispatch_To : Dispatch_To_T;
procedure Open (Dispatch_To : Dispatch_To_T) is
begin
Gp.Dispatch_To := Dispatch_To;
end Open;
procedure Send (Message : Message_Type) is
begin
Dispatch_To.Dispatch (Message);
end Send;
end Gp;
---
with Ada.Text_Io;
with User;
package body Ultimate_User is
task type Main_T is new User.T with
entry Start;
entry Dispatch (Deliver : Integer);
pragma Unreferenced (Dispatch);
-- It is a bit obscure but dispatch is actually called.
end Main_T;
Running : Boolean := True;
pragma Atomic (Running);
Main : aliased Main_T;
task body Main_T is
begin
accept Start;
while Running loop
select
accept Dispatch (Deliver : Integer) do
Ada.Text_Io.Put_Line ("The integer:" & Integer'Image (Deliver));
end Dispatch;
or
terminate;
end select;
end loop;
end Main_T;
procedure Start is
begin
Running := True;
Main.Start;
User.Open (Main'Access);
User.Implementation.Send (42);
end Start;
end Ultimate_User;
Tested on x86_64-pc-linux-gnu, committed on trunk
2013-10-10 Ed Schonberg <schonb...@adacore.com>
* sem_type.adb (Interface_Present_In_Ancestor): The progenitor
in a type declaration may be an interface subtype.
Index: sem_type.adb
===================================================================
--- sem_type.adb (revision 203342)
+++ sem_type.adb (working copy)
@@ -2611,8 +2611,13 @@
begin
AI := First (Interface_List (Parent (Target_Typ)));
+
+ -- The progenitor itself may be a subtype of an interface type.
+
while Present (AI) loop
- if Etype (AI) = Iface_Typ then
+ if Etype (AI) = Iface_Typ
+ or else Base_Type (Etype (AI)) = Iface_Typ
+ then
return True;
elsif Present (Interfaces (Etype (AI)))
