* Check that a single interface is only delegated to a single property within a class.

* Disallow simultaneous use of method resolution and delegation for the same interface. An interface with method resolution must be implemented directly. This is Delphi compatible and resolves #18058.

git-svn-id: trunk@18179 -

.gitattributes

@@ -10850,6 +10850,9 @@ tests/webtbf/tw1754.pp svneol=native#text/plain
 tests/webtbf/tw1754b.pp svneol=native#text/plain
 tests/webtbf/tw17646a.pp svneol=native#text/plain
 tests/webtbf/tw1782.pp svneol=native#text/plain
+tests/webtbf/tw18058a.pp svneol=native#text/plain
+tests/webtbf/tw18058b.pp svneol=native#text/plain
+tests/webtbf/tw18058c.pp svneol=native#text/plain
 tests/webtbf/tw18096.pp svneol=native#text/pascal
 tests/webtbf/tw18096c.pp svneol=native#text/pascal
 tests/webtbf/tw18267.pp svneol=native#text/plain

compiler/msg/errore.msg

@@ -1392,6 +1392,14 @@ parser_e_inherited_not_in_record=03309_E_The use of "inherited" is not allowed i
 parser_e_no_types_in_local_anonymous_records=03310_E_Type declarations are not allowed in local or anonymous records
 % Records with types must be defined globally. Types cannot be defined inside records which are defined in a
 % procedure or function or in anonymous records.
+parser_e_duplicate_implements_clause=03311_E_Duplicate implements clause for interface "$1"
+% A class may delegate an interface using the "implements" clause only to a single property. Delegating it multiple times
+% is a error.
+parser_e_mapping_no_implements=03312_E_Interface "$1" can't be delegated by "$2", it already has method resolutions
+% Method resolution clause maps a method of an interface to a method of the current class. Therefore the current class
+% has to implement the interface directly. Delegation is not possible.
+parser_e_implements_no_mapping=03313_E_Interface "$1" can't have method resolutions, "$2" already delegates it
+% Method resoulution is only possible for interfaces that are implemented directly, not by delegation.
 % \end{description}
 # Type Checking
 #

compiler/msgidx.inc

@@ -402,6 +402,9 @@ const
   parser_e_no_class_constructor_in_helpers=03308;
   parser_e_inherited_not_in_record=03309;
   parser_e_no_types_in_local_anonymous_records=03310;
+  parser_e_duplicate_implements_clause=03311;
+  parser_e_mapping_no_implements=03312;
+  parser_e_implements_no_mapping=03313;
   type_e_mismatch=04000;
   type_e_incompatible_types=04001;
   type_e_not_equal_types=04002;
@@ -897,9 +900,9 @@ const
   option_info=11024;
   option_help_pages=11025;
 
-  MsgTxtSize = 60771;
+  MsgTxtSize = 60991;
 
   MsgIdxMax : array[1..20] of longint=(
-    26,89,311,103,85,54,111,23,202,63,
+    26,89,314,103,85,54,111,23,202,63,
     49,20,1,1,1,1,1,1,1,1
   );

compiler/pdecsub.pas

@@ -1008,6 +1008,9 @@ implementation
              ImplIntf:=tobjectdef(astruct).find_implemented_interface(tobjectdef(ttypesym(srsym).typedef));
            if ImplIntf=nil then
              Message(parser_e_interface_id_expected);
+           { must be a directly implemented interface }
+           if Assigned(ImplIntf.ImplementsGetter) then
+             Message2(parser_e_implements_no_mapping,ImplIntf.IntfDef.typename,astruct.objrealname^);
            consume(_ID);
            { Create unique name <interface>.<method> }
            hs:=sp+'.'+pattern;

compiler/pdecvar.pas

@@ -841,6 +841,13 @@ implementation
                end;
              if found then
                begin
+                 { An interface may not be delegated by more than one property,
+                   it also may not have method mappings. }
+                 if Assigned(ImplIntf.ImplementsGetter) then
+                   message1(parser_e_duplicate_implements_clause,ImplIntf.IntfDef.typename);
+                 if Assigned(ImplIntf.NameMappings) then
+                   message2(parser_e_mapping_no_implements,ImplIntf.IntfDef.typename,astruct.objrealname^);
+
                  ImplIntf.ImplementsGetter:=p;
                  ImplIntf.VtblImplIntf:=ImplIntf;
                  case p.propaccesslist[palt_read].firstsym^.sym.typ of

tests/webtbf/tw18058a.pp

@@ -0,0 +1,74 @@
+{ %fail }
+
+{$ifdef fpc}{$mode objfpc}{$H+}{$endif}
+
+uses
+  Classes;
+
+type
+  IIntf1 = interface
+    ['{87776F0F-8CE0-4881-B969-C76F5A9CA517}']
+    procedure M1;
+  end;
+
+  IIntf2 = interface
+    ['{923C47DF-0A7E-4698-98B8-45175306CDF2}']
+    procedure M2;
+  end;
+
+  { TObjIntf2 }
+
+  TObjIntf2 = class(TInterfacedObject, IIntf2)
+    procedure M2;
+  end;
+
+  { TObj }
+
+  TObj = class(TInterfacedObject, IIntf1, IIntf2)
+  private
+    FObjIntf2:IIntf2;
+  public
+    constructor Create;
+    procedure M1;
+
+    // multiple delegations are forbidden
+    property I2:IIntf2 read FObjIntf2 implements IIntf2;
+    property I21: IIntf2 read FObjIntf2 implements IIntf2;
+  end;
+
+{ TObjIntf2 }
+
+procedure TObjIntf2.M2;
+begin
+  Writeln('TObjIntf2.M2 called');
+end;
+
+{ TObj }
+
+constructor TObj.Create;
+begin
+  FObjIntf2:=TObjIntf2.Create;
+end;
+
+procedure TObj.M1;
+begin
+  Writeln('TObj.M1 called');
+end;
+
+
+var O:TObj;
+    i1:IIntf1;
+    i2:IIntf2;
+begin
+  O:=TObj.Create;
+  i1:=O;
+
+  //all tries are unsuccessful
+  i2:=O as IIntf2;
+  //(O as IIntf1).QueryInterface(IIntf2, i2);
+//  i1.QueryInterface(IIntf2, i2);
+
+  //still calls TObj1.M1
+  i2.M2;
+end.
+

tests/webtbf/tw18058b.pp

@@ -0,0 +1,81 @@
+{ %fail }
+
+{$ifdef fpc}{$mode objfpc}{$H+}{$endif}
+
+uses
+  Classes;
+
+type
+  IIntf1 = interface
+    ['{87776F0F-8CE0-4881-B969-C76F5A9CA517}']
+    procedure M1;
+  end;
+
+  IIntf2 = interface
+    ['{923C47DF-0A7E-4698-98B8-45175306CDF2}']
+    procedure M2;
+  end;
+
+  { TObjIntf2 }
+
+  TObjIntf2 = class(TInterfacedObject, IIntf2)
+    procedure M2;
+  end;
+
+  { TObj }
+
+  TObj = class(TInterfacedObject, IIntf1, IIntf2)
+  private
+    FObjIntf2:IIntf2;
+  public
+    constructor Create;
+    procedure M1;
+
+     
+    property I2:IIntf2 read FObjIntf2 implements IIntf2;
+
+    // method resolution after delegation, forbidden
+    procedure IIntf2.M2 = _M2;
+    procedure _M2;
+  end;
+
+{ TObjIntf2 }
+
+procedure TObjIntf2.M2;
+begin
+  Writeln('TObjIntf2.M2 called');
+end;
+
+{ TObj }
+
+constructor TObj.Create;
+begin
+  FObjIntf2:=TObjIntf2.Create;
+end;
+
+procedure TObj.M1;
+begin
+  Writeln('TObj.M1 called');
+end;
+
+procedure TObj._M2;
+begin
+  Writeln('TObj.M2 called');
+end;
+
+var O:TObj;
+    i1:IIntf1;
+    i2:IIntf2;
+begin
+  O:=TObj.Create;
+  i1:=O;
+
+  //all tries are unsuccessful
+  i2:=O as IIntf2;
+  //(O as IIntf1).QueryInterface(IIntf2, i2);
+//  i1.QueryInterface(IIntf2, i2);
+
+  //still calls TObj1.M1
+  i2.M2;
+end.
+

tests/webtbf/tw18058c.pp

@@ -0,0 +1,81 @@
+{ %fail }
+
+{$ifdef fpc}{$mode objfpc}{$H+}{$endif}
+
+uses
+  Classes;
+
+type
+  IIntf1 = interface
+    ['{87776F0F-8CE0-4881-B969-C76F5A9CA517}']
+    procedure M1;
+  end;
+
+  IIntf2 = interface
+    ['{923C47DF-0A7E-4698-98B8-45175306CDF2}']
+    procedure M2;
+  end;
+
+  { TObjIntf2 }
+
+  TObjIntf2 = class(TInterfacedObject, IIntf2)
+    procedure M2;
+  end;
+
+  { TObj }
+
+  TObj = class(TInterfacedObject, IIntf1, IIntf2)
+  private
+    FObjIntf2:IIntf2;
+  public
+    constructor Create;
+
+    procedure M1;
+
+    procedure IIntf2.M2 = _M2;
+    procedure _M2;
+
+    // delegation after method resolution, forbidden
+    property I2:IIntf2 read FObjIntf2 implements IIntf2;
+  end;
+
+{ TObjIntf2 }
+
+procedure TObjIntf2.M2;
+begin
+  Writeln('TObjIntf2.M2 called');
+end;
+
+{ TObj }
+
+constructor TObj.Create;
+begin
+  FObjIntf2:=TObjIntf2.Create;
+end;
+
+procedure TObj.M1;
+begin
+  Writeln('TObj.M1 called');
+end;
+
+procedure TObj._M2;
+begin
+  Writeln('TObj.M2 called');
+end;
+
+var O:TObj;
+    i1:IIntf1;
+    i2:IIntf2;
+begin
+  O:=TObj.Create;
+  i1:=O;
+
+  //all tries are unsuccessful
+  i2:=O as IIntf2;
+  //(O as IIntf1).QueryInterface(IIntf2, i2);
+//  i1.QueryInterface(IIntf2, i2);
+
+  //still calls TObj1.M1
+  i2.M2;
+end.
+