Mantis #19182, Delphi compatible tweaks:

* Allow properties of type interface to implement not just the same interface, but also any of its ancestors.
* Allow a single property to implement multiple interfaces.

git-svn-id: trunk@18983 -

.gitattributes

@@ -11723,6 +11723,7 @@ tests/webtbs/tw1909.pp svneol=native#text/plain
 tests/webtbs/tw1910.pp svneol=native#text/plain
 tests/webtbs/tw1915.pp svneol=native#text/plain
 tests/webtbs/tw1917.pp svneol=native#text/plain
+tests/webtbs/tw19182.pp svneol=native#text/plain
 tests/webtbs/tw1920.pp svneol=native#text/plain
 tests/webtbs/tw19201.pp svneol=native#text/pascal
 tests/webtbs/tw1923.pp svneol=native#text/plain

compiler/pdecvar.pas

@@ -772,7 +772,7 @@ implementation
 *)
          { Parse possible "implements" keyword }
          if not is_record(astruct) and try_to_consume(_IMPLEMENTS) then
-           begin
+           repeat
              single_type(def,[]);
 
              if not(is_interface(def)) then
@@ -780,7 +780,8 @@ implementation
 
              if is_interface(p.propdef) then
                begin
-                 if compare_defs(def,p.propdef,nothingn)<te_equal then
+                 { an interface type may delegate itself or one of its ancestors }
+                 if not p.propdef.is_related(def) then
                    begin
                      message2(parser_e_implements_must_have_correct_type,def.typename,p.propdef.typename);
                      exit;
@@ -879,7 +880,7 @@ implementation
                end
              else
                message1(parser_e_implements_uses_non_implemented_interface,def.typename);
-         end;
+           until not try_to_consume(_COMMA);
 
          { remove unneeded procdefs }
          if readprocdef.proctypeoption<>potype_propgetter then

tests/webtbs/tw19182.pp

@@ -0,0 +1,173 @@
+program MultiIntfDelegation;
+{$mode objfpc}{$h+}
+
+type
+  IGMGetHandle = interface(IUnknown)
+    ['{5BB45961-15A9-11d5-A5E4-00E0987755DD}']
+    function GetHandle: THandle; stdcall;
+    property Handle: THandle read GetHandle;
+  end;
+
+  IGMGetFileName = interface(IUnknown)
+    ['{D3ECCB42-A563-4cc4-B375-79931031ECBA}']
+    function GetFileName: String; stdcall;
+    property FileName: String read GetFileName;
+  end;
+
+  IGMGetSetFileName = Interface(IGMGetFileName)
+    ['{ECFB879F-86F6-41a3-A685-0C899A2B5BCA}']
+    procedure SetFileName(const Value: String); stdcall;
+    property FileName: String read GetFileName write SetFileName;
+  end;
+
+
+  { TImplementor }
+
+  TImplementor = class(TObject, IGMGetHandle, IGMGetFileName, IGMGetSetFileName)
+   protected
+    FController: Tobject;
+
+   public
+    constructor Create(const AController: TObject);
+
+    function QueryInterface(constref IID: TGUID; out Intf): HResult; virtual; {$ifdef windows}stdcall{$else}cdecl{$endif};
+    function _AddRef: LongInt; virtual; {$ifdef windows}stdcall{$else}cdecl{$endif};
+    function _Release: LongInt; virtual; {$ifdef windows}stdcall{$else}cdecl{$endif};
+
+    function GetHandle: THandle; stdcall;
+    function GetFileName: String; stdcall;
+    procedure SetFileName(const Value: String); stdcall;
+  end;
+
+
+  { TIntfDelegator }
+
+  TIntfDelegator = class(TInterfacedObject, IGMGetFileName, IGMGetSetFileName)
+   protected
+    FImplementor: TImplementor;
+    FGetSetFileName: IGMGetSetFileName;
+
+   public
+    constructor Create;
+    destructor Destroy; override;
+
+    //
+    // This would be nice. NOTE: IGMGetFileName is derived from IGMGetSetFileName!
+    //
+    property Implementor: IGMGetSetFileName read FGetSetFileName implements IGMGetFileName, IGMGetSetFileName;
+  end;
+
+
+  { TObjDelegator }
+
+  TObjDelegator = class(TInterfacedObject, IGMGetHandle, IGMGetFileName, IGMGetSetFileName)
+   protected
+    FImplementor: TImplementor;
+
+   public
+    constructor Create;
+    destructor Destroy; override;
+
+    //
+    // This would be really smart!
+    //
+    property Implementor: TImplementor read FImplementor implements IGMGetHandle, IGMGetFileName, IGMGetSetFileName;
+  end;
+
+
+
+{ TImplementor }
+
+constructor TImplementor.Create(const AController: TObject);
+begin
+  FController := AController;
+end;
+
+function TImplementor.QueryInterface(constref IID: TGUID; out Intf): HResult; {$ifdef windows}stdcall{$else}cdecl{$endif};
+var PIUnkController: IUnknown;
+begin
+  if GetInterface(IID, Intf) then Result := S_OK else
+   if (FController <> nil) and FController.GetInterface(IUnknown, PIUnkController) then
+    Result := PIUnkController.QueryInterface(IID, Intf) else Result := E_NOINTERFACE;
+end;
+
+function TImplementor._AddRef: LongInt; {$ifdef windows}stdcall{$else}cdecl{$endif};
+var PIUnkController: IUnknown;
+begin
+  if (FController <> nil) and FController.GetInterface(IUnknown, PIUnkController) then
+   Result := PIUnkController._AddRef
+end;
+
+function TImplementor._Release: LongInt; {$ifdef windows}stdcall{$else}cdecl{$endif};
+var PIUnkController: IUnknown;
+begin
+  if (FController <> nil) and FController.GetInterface(IUnknown, PIUnkController) then
+   Result := PIUnkController._Release
+end;
+
+function TImplementor.GetHandle: THandle; stdcall;
+begin
+  writeln('TImplementor.GetHandle');
+  Result := 0;
+end;
+
+function TImplementor.GetFileName: String; stdcall;
+begin
+  writeln('TImplementor.GetFileName');
+  Result := '';
+end;
+
+procedure TImplementor.SetFileName(const Value: String); stdcall;
+begin
+  writeln('TImplementor.SetFileName');
+end;
+
+
+{ TIntfDelegator }
+
+constructor TIntfDelegator.Create;
+begin
+  FImplementor := TImplementor.Create(Self);
+  FGetSetFileName := FImplementor;
+end;
+
+destructor TIntfDelegator.Destroy;
+begin
+  FImplementor.Free;
+  inherited Destroy;
+end;
+
+
+{ TObjDelegator }
+
+constructor TObjDelegator.Create;
+begin
+  FImplementor := TImplementor.Create(Self);
+end;
+
+destructor TObjDelegator.Destroy;
+begin
+  FImplementor.Free;
+  inherited Destroy;
+end;
+
+
+var
+  PIUnk: IUnknown;
+  PIGetFileNAme: IGMGetFileName;
+  PIGetSetFileName: IGMGetSetFileName;
+  obj: TObjDelegator;
+begin
+  PIUnk := TIntfDelegator.Create;
+  PIUnk.QueryInterface(IGMGetFileName, PIGetFileName);
+  PIGetFileName.GetFileName;
+  PIUnk.QueryInterface(IGMGetSetFileName, PIGetSetFileName);
+  PIGetSetFileName.SetFileName('');
+  
+  obj := TObjDelegator.Create;
+  (obj as IGMGetFileName).GetFileName;
+  (obj as IGMGetSetFileName).SetFileName('');
+  (obj as IGMGetHandle).GetHandle;
+end.
+
+