diff mbox

[Ada] The progenitor of a type extension may be a subtype.

Message ID 20131010125244.GA767@adacore.com
State New
Headers show

Commit Message

Arnaud Charlet Oct. 10, 2013, 12:52 p.m. UTC 
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  <schonberg@adacore.com>

	* sem_type.adb (Interface_Present_In_Ancestor): The progenitor
	in a type declaration may be an interface subtype.
diff mbox

Patch

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)))