diff --git a/.gitattributes b/.gitattributes index c86e3dd3ea..bd5533f9ad 100644 --- a/.gitattributes +++ b/.gitattributes @@ -6305,6 +6305,7 @@ tests/webtbs/tw4188.pp svneol=native#text/plain tests/webtbs/tw4199.pp svneol=native#text/plain tests/webtbs/tw4201.pp svneol=native#text/plain tests/webtbs/tw4202.pp svneol=native#text/plain +tests/webtbs/tw4209.pp svneol=native#text/plain tests/webtbs/tw4215.pp svneol=native#text/plain tests/webtbs/tw4219.pp svneol=native#text/plain tests/webtbs/tw4223.pp svneol=native#text/plain diff --git a/compiler/defcmp.pas b/compiler/defcmp.pas index a97385052a..8117ef0ea4 100644 --- a/compiler/defcmp.pas +++ b/compiler/defcmp.pas @@ -114,7 +114,7 @@ interface { True if a function can be assigned to a procvar } { changed first argument type to pabstractprocdef so that it can also be } { used to test compatibility between two pprocvardefs (JM) } - function proc_to_procvar_equal(def1:tabstractprocdef;def2:tprocvardef;methoderr:boolean):tequaltype; + function proc_to_procvar_equal(def1:tabstractprocdef;def2:tprocvardef):tequaltype; implementation @@ -1020,7 +1020,7 @@ implementation if (m_tp_procvar in aktmodeswitches) or (m_mac_procvar in aktmodeswitches) then begin - subeq:=proc_to_procvar_equal(tprocdef(def_from),tprocvardef(def_to),true); + subeq:=proc_to_procvar_equal(tprocdef(def_from),tprocvardef(def_to)); if subeq>te_incompatible then begin doconv:=tc_proc_2_procvar; @@ -1031,7 +1031,7 @@ implementation procvardef : begin { procvar -> procvar } - eq:=proc_to_procvar_equal(tprocvardef(def_from),tprocvardef(def_to),false); + eq:=proc_to_procvar_equal(tprocvardef(def_from),tprocvardef(def_to)); end; pointerdef : begin @@ -1455,7 +1455,7 @@ implementation end; - function proc_to_procvar_equal(def1:tabstractprocdef;def2:tprocvardef;methoderr:boolean):tequaltype; + function proc_to_procvar_equal(def1:tabstractprocdef;def2:tprocvardef):tequaltype; var eq : tequaltype; po_comp : tprocoptions; @@ -1466,11 +1466,7 @@ implementation { check for method pointer } if (def1.is_methodpointer xor def2.is_methodpointer) or (def1.is_addressonly xor def2.is_addressonly) then - begin - if methoderr then - Message(type_e_no_method_and_procedure_not_compatible); - exit; - end; + exit; { check return value and options, methodpointer is already checked } po_comp:=[po_staticmethod,po_interrupt, po_iocheck,po_varargs]; diff --git a/compiler/htypechk.pas b/compiler/htypechk.pas index f21ffd69da..7db14c51e9 100644 --- a/compiler/htypechk.pas +++ b/compiler/htypechk.pas @@ -1367,7 +1367,7 @@ implementation if ((m_tp_procvar in aktmodeswitches) or (m_mac_procvar in aktmodeswitches)) and (p.left.nodetype=calln) and - (proc_to_procvar_equal(tprocdef(tcallnode(p.left).procdefinition),tprocvardef(def_to),true)>=te_equal) then + (proc_to_procvar_equal(tprocdef(tcallnode(p.left).procdefinition),tprocvardef(def_to))>=te_equal) then eq:=te_equal else if (m_mac_procvar in aktmodeswitches) and @@ -1835,7 +1835,7 @@ implementation end else { for value and const parameters check precision of real, give - penalty for loosing of precision } + penalty for loosing of precision. var and out parameters must match exactly } if not(currpara.varspez in [vs_var,vs_out]) and is_real(def_from) and is_real(def_to) then @@ -1864,8 +1864,9 @@ implementation end else { related object parameters also need to determine the distance between the current - object and the object we are comparing with } - if (def_from.deftype=objectdef) and + object and the object we are comparing with. var and out parameters must match exactly } + if not(currpara.varspez in [vs_var,vs_out]) and + (def_from.deftype=objectdef) and (def_to.deftype=objectdef) and (tobjectdef(def_from).objecttype=tobjectdef(def_to).objecttype) and tobjectdef(def_from).is_related(tobjectdef(def_to)) then diff --git a/compiler/ncnv.pas b/compiler/ncnv.pas index 164764624e..3fcb23a15a 100644 --- a/compiler/ncnv.pas +++ b/compiler/ncnv.pas @@ -1511,8 +1511,7 @@ implementation { Now check if the procedure we are going to assign to the procvar, is compatible with the procvar's type } if not(nf_explicit in flags) and - (proc_to_procvar_equal(currprocdef, - tprocvardef(resulttype.def),true)=te_incompatible) then + (proc_to_procvar_equal(currprocdef,tprocvardef(resulttype.def))=te_incompatible) then IncompatibleTypes(left.resulttype.def,resulttype.def); exit; end; diff --git a/compiler/symsym.pas b/compiler/symsym.pas index f4a9517fd1..71d8c093c8 100644 --- a/compiler/symsym.pas +++ b/compiler/symsym.pas @@ -882,7 +882,7 @@ implementation pd:=pdlistfirst; while assigned(pd) do begin - eq:=proc_to_procvar_equal(pd^.def,d,false); + eq:=proc_to_procvar_equal(pd^.def,d); if eq>=te_equal then begin { multiple procvars with the same equal level } diff --git a/tests/webtbs/tw4209.pp b/tests/webtbs/tw4209.pp new file mode 100755 index 0000000000..830d4a357b --- /dev/null +++ b/tests/webtbs/tw4209.pp @@ -0,0 +1,34 @@ +{ Source provided for Free Pascal Bug Report 4209 } +{ Submitted by "Ivo Steinmann" on 2005-07-22 } +{ e-mail: isteinmann@bluewin.ch } +Program testprog; + +{$mode delphi} + +var + err : boolean; + +type + XMethod = procedure of object; + XProcedure = procedure; + +procedure Test(const Callback: XMethod); overload; +begin +end; + +procedure Test(const Callback: XProcedure); overload; +begin + writeln('ok'); + err:=false; +end; + +procedure Foobar; +begin +end; + +begin + err:=true; + Test(Foobar); + if err then + halt(1); +end.