[Ada] Generic_Dispatching_Constructor and multiple interfaces.

[Arnaud Charlet <charlet at adacore dot com>]

This patch fixes a regression in the handling of the generic_dispatching_
constructor in the presence of several levels of interfaces. Previous to
this patch, a dispatching call might call the wrong primitive of an object
whose type overrides a primitive inherited from an interface that has several
ancestors, if the object is built through a call to an instance of the
generic_dispatching constructor.

Executing:

   gnatmake -q main
   main

must yield

   Output
   Input
   Output
   Input

---
with Ada.Streams.Stream_IO; use Ada.Streams.Stream_IO;
with Ada.Streams;           use Ada.Streams;
with Ada.Tags;              use Ada.Tags;
with Messages;              use Messages;
procedure Main is

  procedure WriteAndRead (obj : access IOutput'Class) is
    file    : File_Type;
    pStream : Stream_Access;
  begin
    Create (file, Name => "buffer");
    pStream := Stream (file);

    String'Output (pStream, External_Tag (obj'Tag));
    obj.Output (pStream);

    Close (file);

    Open (file, Mode => In_File, Name => "buffer");
    pStream := Stream (file);
    declare
      obj : IInput'Class :=
         ClassInput (Internal_Tag (String'Input (pStream)), pStream);
    begin
      null;
    end;
    Close (file);
  end WriteAndRead;

begin
  WriteAndRead (new CTest_Success);
  WriteAndRead (new CTest_Fail);
end Main;
---
with Ada.Streams;
with Ada.Tags.Generic_Dispatching_Constructor;

package Messages is

  type CMessage is tagged null record;

  type IBase is interface;
  procedure Nothing (X : Ibase) is abstract;

  type IInput is interface and IBase;
  function Input (stream : not null access Ada.Streams.Root_Stream_Type'Class)
     return IInput is abstract;
  overriding procedure Nothing (X : IInput) is null;
  type IOutput is interface and IBase;
  procedure Output (self : in IOutput; stream :
       not null access Ada.Streams.Root_Stream_Type'Class) is abstract;

  overriding procedure Nothing (X : IOutput) is null;
  type IInputOutput is interface and IInput and IOutput;

  function ClassInput is new Ada.Tags.Generic_Dispatching_Constructor
      (IInput, Ada.Streams.Root_Stream_Type'Class, Input);

  ------------------------------
  -- correct procedure called --
  ------------------------------

  type CTest_Success is new CMessage and IInput and IOutput with record
    dummyInt : Integer := 123;
  end record;

  overriding function Input
     (stream : not null access Ada.Streams.Root_Stream_Type'Class)
  return CTest_Success;
  overriding procedure Output
     (self : in CTest_Success;
     stream : not null access Ada.Streams.Root_Stream_Type'Class);

  ----------------------------
  -- wrong procedure called --
  ----------------------------

  type CTest_Fail is new CMessage and IInputOutput with record
    dummyInt : Integer := 456;
  end record;

  overriding function Input
    (stream : not null access Ada.Streams.Root_Stream_Type'Class)
   return CTest_Fail;
  overriding procedure Output
    (self : in CTest_Fail;
     stream : not null access Ada.Streams.Root_Stream_Type'Class);
end Messages;
-- 
with Ada.Text_IO;

package body Messages is

  overriding function Input
   (stream : not null access Ada.Streams.Root_Stream_Type'Class)
    return CTest_Success
  is
  begin
    Ada.Text_IO.Put_Line ("Input");
    return CTest_Success'(dummyInt => Integer'Input (stream));
  end Input;

  overriding procedure Output
   (self   : in CTest_Success;
    stream : not null access Ada.Streams.Root_Stream_Type'Class)
  is
  begin
    Ada.Text_IO.Put_Line ("Output");
    Integer'Output (stream, self.dummyInt);
  end Output;

  overriding function Input
   (stream : not null access Ada.Streams.Root_Stream_Type'Class)
    return CTest_Fail
  is
  begin
    Ada.Text_IO.Put_Line ("Input");
    return CTest_Fail'(dummyInt => Integer'Input (Stream));
  end Input;

  overriding procedure Output
   (self   : in CTest_Fail;
    stream : not null access Ada.Streams.Root_Stream_Type'Class)
  is
  begin
    Ada.Text_IO.Put_Line ("Output");
    Integer'Output (stream, self.dummyInt);
  end Output;

end Messages;

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

2015-05-12  Ed Schonberg  <schonberg@adacore.com>

	* exp_intr.adb (Expand_Dispatching_Constructor_Call): The
	tag to be retrieved for the generated call is the first entry
	in the dispatch table for the return type of the instantiated
	constructor.

Attachment: difs
Description: Text document