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 <schonb...@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.
Index: exp_intr.adb
===================================================================
--- exp_intr.adb (revision 223033)
+++ exp_intr.adb (working copy)
@@ -345,6 +345,9 @@
begin
pragma Assert (not Is_Interface (Etype (Tag_Arg)));
+ -- The tag is the first entry in the dispatch table of the
+ -- return type of the constructor.
+
Iface_Tag :=
Make_Object_Declaration (Loc,
Defining_Identifier => Make_Temporary (Loc, 'V'),
@@ -357,7 +360,7 @@
Relocate_Node (Tag_Arg),
New_Occurrence_Of
(Node (First_Elmt (Access_Disp_Table
- (Etype (Etype (Act_Constr))))),
+ (Etype (Act_Constr)))),
Loc))));
Insert_Action (N, Iface_Tag);
end;
