===================================================================
@@ -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;
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;