* fixed mantis 6631, 7322 and 7989: check parameters and return

types of interface methods implemented in a class

git-svn-id: trunk@5686 -

.gitattributes

@@ -6979,12 +6979,15 @@ tests/webtbf/tw4893d.pp svneol=native#text/plain
 tests/webtbf/tw4893e.pp svneol=native#text/plain
 tests/webtbf/tw4911.pp svneol=native#text/plain
 tests/webtbf/tw4913.pp -text
+tests/webtbf/tw6631.pp svneol=native#text/plain
 tests/webtbf/tw6686.pp svneol=native#text/plain
 tests/webtbf/tw6796.pp svneol=native#text/plain
 tests/webtbf/tw6922.pp svneol=native#text/plain
 tests/webtbf/tw6970.pp svneol=native#text/plain
+tests/webtbf/tw7322.pp svneol=native#text/plain
 tests/webtbf/tw7438.pp svneol=native#text/plain
 tests/webtbf/tw7438a.pp svneol=native#text/plain
+tests/webtbf/tw7989.pp svneol=native#text/plain
 tests/webtbf/uw0744.pp svneol=native#text/plain
 tests/webtbf/uw0840a.pp svneol=native#text/plain
 tests/webtbf/uw0840b.pp svneol=native#text/plain

compiler/defcmp.pas

@@ -116,6 +116,13 @@ interface
     { used to test compatibility between two pprocvardefs (JM)               }
     function proc_to_procvar_equal(def1:tabstractprocdef;def2:tprocvardef):tequaltype;
 
+    { Parentdef is the definition of a method defined in a parent class or interface }
+    { Childdef is the definition of a method defined in a child class, interface or  }
+    { a class implementing an interface with parentdef.                              }
+    { Returns true if the resultdef of childdef can be used to implement/override    }
+    { parentdef's resultdef                                                          }
+    function compatible_childmethod_resultdef(parentretdef, childretdef: tdef): boolean;
+
 
 implementation
 
@@ -1542,4 +1549,17 @@ implementation
           end;
       end;
 
+
+    function compatible_childmethod_resultdef(parentretdef, childretdef: tdef): boolean;
+      begin
+        compatible_childmethod_resultdef :=
+          (equal_defs(parentretdef,childretdef)) or
+          ((parentretdef.typ=objectdef) and
+           (childretdef.typ=objectdef) and
+           is_class_or_interface(parentretdef) and
+           is_class_or_interface(childretdef) and
+           (tobjectdef(childretdef).is_related(tobjectdef(parentretdef))))
+      end;
+
+
 end.

compiler/nobj.pas

@@ -330,12 +330,7 @@ implementation
                            end;
 
                         { error, if the return types aren't equal }
-                        if not(equal_defs(procdefcoll^.data.returndef,pd.returndef)) and
-                           not((procdefcoll^.data.returndef.typ=objectdef) and
-                            (pd.returndef.typ=objectdef) and
-                            is_class_or_interface(procdefcoll^.data.returndef) and
-                            is_class_or_interface(pd.returndef) and
-                            (tobjectdef(pd.returndef).is_related(tobjectdef(procdefcoll^.data.returndef)))) then
+                        if not compatible_childmethod_resultdef(procdefcoll^.data.returndef,pd.returndef) then
                           begin
                             if not((m_delphi in current_settings.modeswitches) and
                                    is_interface(_class)) then
@@ -514,7 +509,13 @@ implementation
                   implprocdef:=intf_search_procdef_by_name(tprocdef(def),tprocdef(def).procsym.name);
                 { Add procdef to the implemented interface }
                 if assigned(implprocdef) then
-                  ImplIntf.AddImplProc(implprocdef)
+                  begin
+                    if (compare_paras(tprocdef(def).paras,implprocdef.paras,cp_all,[cpo_ignorehidden,cpo_comparedefaultvalue])<te_equal) or
+                       not compatible_childmethod_resultdef(tprocdef(def).returndef,implprocdef.returndef) then
+                      MessagePos1(tprocdef(implprocdef).fileinfo,parser_e_header_dont_match_forward,
+                                  tprocdef(def).fullprocname(false));
+                    ImplIntf.AddImplProc(implprocdef)
+                  end
                 else
                   if ImplIntf.IntfDef.iitype = etStandard then
                     Message1(sym_e_no_matching_implementation_found,tprocdef(def).fullprocname(false));

tests/webtbf/tw6631.pp

@@ -0,0 +1,26 @@
+{ %fail }
+program test;
+
+{$MODE DELPHI}
+
+type
+  XBool = LongBool;
+  XInt = Int64;
+  XResult = type XInt;
+
+  ITest = interface(IInterface)
+    function Foobar: XResult;
+  end;
+
+  TTest = class(TInterfacedObject, ITest)
+    function Foobar: XBool;
+  end;
+
+
+function TTest.Foobar: LongBool;
+begin
+  Result := True;
+end;
+
+begin
+end.

tests/webtbf/tw7322.pp

@@ -0,0 +1,24 @@
+{ %fail }
+
+program project1;
+
+{$mode objfpc}{$H+}
+
+type
+
+IExample = interface
+  function add(a, b: single): integer; 
+end;
+
+{ TExample }
+
+TExample = class (TInterfacedObject, IExample)
+  function add(a, b: single): single;
+end;
+
+function texample.add(a, b: single): single;
+begin
+end;
+
+begin
+end.

tests/webtbf/tw7989.pp

@@ -0,0 +1,38 @@
+{ %fail }
+program test;
+
+{$mode objfpc}
+
+uses
+  Classes, SysUtils;
+
+type
+  IMyInterface = interface
+    function test1: integer;
+    function test2: single;
+    function test3: double;
+  end;
+
+  TMyObject = class(TInterfacedObject, IMyInterface)
+    function test1: byte;
+    function test2: double;
+    function test3: integer;
+  end;
+
+function TMyObject.test1: byte;
+begin
+  Result := 0;
+end;
+
+function TMyObject.test2: double;
+begin
+  Result := 0;
+end;
+
+function TMyObject.test3: integer;
+begin
+  Result := 0;
+end;
+
+begin
+end.