From 50659b7e7fff5b7dd83276bb0866e64adaba42ad Mon Sep 17 00:00:00 2001 From: Jonas Maebe Date: Thu, 7 Jun 2012 22:36:39 +0000 Subject: [PATCH] * give an error if a routine definition defines default values for parameters that do not appear in forward/interface definitions (mantis #19434) * added test for #17136 already works git-svn-id: trunk@21524 - --- .gitattributes | 4 ++++ compiler/defcmp.pas | 24 +++++++++++++++++------- compiler/nobj.pas | 2 +- compiler/pdecsub.pas | 15 +++++++++++---- tests/webtbf/tw19434.pp | 18 ++++++++++++++++++ tests/webtbs/tw17136.pp | 27 +++++++++++++++++++++++++++ tests/webtbs/tw19434a.pp | 23 +++++++++++++++++++++++ tests/webtbs/tw19434b.pp | 28 ++++++++++++++++++++++++++++ 8 files changed, 129 insertions(+), 12 deletions(-) create mode 100644 tests/webtbf/tw19434.pp create mode 100644 tests/webtbs/tw17136.pp create mode 100644 tests/webtbs/tw19434a.pp create mode 100644 tests/webtbs/tw19434b.pp diff --git a/.gitattributes b/.gitattributes index 2fa441fe88..c52f8871c0 100644 --- a/.gitattributes +++ b/.gitattributes @@ -11616,6 +11616,7 @@ tests/webtbf/tw19213.pp svneol=native#text/plain tests/webtbf/tw1927.pp svneol=native#text/plain tests/webtbf/tw1928.pp svneol=native#text/plain tests/webtbf/tw1939.pp svneol=native#text/plain +tests/webtbf/tw19434.pp svneol=native#text/plain tests/webtbf/tw19463.pp svneol=native#text/pascal tests/webtbf/tw1949.pp svneol=native#text/plain tests/webtbf/tw19591.pp svneol=native#text/plain @@ -12363,6 +12364,7 @@ tests/webtbs/tw16980.pp svneol=native#text/plain tests/webtbs/tw1699.pp svneol=native#text/plain tests/webtbs/tw1709.pp svneol=native#text/plain tests/webtbs/tw17118.pp svneol=native#text/plain +tests/webtbs/tw17136.pp svneol=native#text/plain tests/webtbs/tw17164.pp svneol=native#text/plain tests/webtbs/tw17180.pp svneol=native#text/plain tests/webtbs/tw17181.pp svneol=native#text/plain @@ -12495,6 +12497,8 @@ tests/webtbs/tw1935.pp svneol=native#text/plain tests/webtbs/tw1936.pp svneol=native#text/plain tests/webtbs/tw19368.pp svneol=native#text/pascal tests/webtbs/tw1938.pp svneol=native#text/plain +tests/webtbs/tw19434a.pp svneol=native#text/plain +tests/webtbs/tw19434b.pp svneol=native#text/plain tests/webtbs/tw1948.pp svneol=native#text/plain tests/webtbs/tw19498.pp svneol=native#text/pascal tests/webtbs/tw19499.pp svneol=native#text/pascal diff --git a/compiler/defcmp.pas b/compiler/defcmp.pas index 79bd4eae3d..bc50dd2e29 100644 --- a/compiler/defcmp.pas +++ b/compiler/defcmp.pas @@ -133,6 +133,10 @@ interface are allowed (in this case, the search order will first search for a routine with default parameters, before searching for the same definition with no parameters) + + para1 is expected to be parameter list of the first encountered + declaration (interface, forward), and para2 that of the second one + (important in case of cpo_comparedefaultvalue) } function compare_paras(para1,para2 : TFPObjectList; acp : tcompare_paras_type; cpoptions: tcompare_paras_options):tequaltype; @@ -1964,13 +1968,19 @@ implementation if eq=te_equal) and + (compare_paras(proc.paras,implprocdef.paras,cp_all,[cpo_ignorehidden,cpo_ignoreuniv])>=te_equal) and (compare_defs(proc.returndef,implprocdef.returndef,nothingn)>=te_equal) and (proc.proccalloption=implprocdef.proccalloption) and (proc.proctypeoption=implprocdef.proctypeoption) and diff --git a/compiler/pdecsub.pas b/compiler/pdecsub.pas index 01ab2a932b..cc541b16b6 100644 --- a/compiler/pdecsub.pas +++ b/compiler/pdecsub.pas @@ -2939,9 +2939,13 @@ const not(po_overload in fwpd.procoptions) ) or { check arguments, we need to check only the user visible parameters. The hidden parameters - can be in a different location because of the calling convention, eg. L-R vs. R-L order (PFV) } + can be in a different location because of the calling convention, eg. L-R vs. R-L order (PFV) + + don't check default values here, because routines that are the same except for their default + values should be reported as mismatches (since you can't overload based on different default + parameter values) } ( - (compare_paras(currpd.paras,fwpd.paras,cp_none,[cpo_comparedefaultvalue,cpo_ignorehidden,cpo_openequalisexact,cpo_ignoreuniv])=te_exact) and + (compare_paras(fwpd.paras,currpd.paras,cp_none,[cpo_ignorehidden,cpo_openequalisexact,cpo_ignoreuniv])=te_exact) and (compare_defs(fwpd.returndef,currpd.returndef,nothingn)=te_exact) ) then begin @@ -3009,10 +3013,13 @@ const end; { Check if the procedure type and return type are correct, - also the parameters must match also with the type } + also the parameters must match also with the type and that + if the implementation has default parameters, the interface + also has them and that if they both have them, that they + have the same value } if ((m_repeat_forward in current_settings.modeswitches) or not is_bareprocdef(currpd)) and - ((compare_paras(currpd.paras,fwpd.paras,cp_all,paracompopt)<>te_exact) or + ((compare_paras(fwpd.paras,currpd.paras,cp_all,paracompopt)<>te_exact) or (compare_defs(fwpd.returndef,currpd.returndef,nothingn)<>te_exact)) then begin MessagePos1(currpd.fileinfo,parser_e_header_dont_match_forward, diff --git a/tests/webtbf/tw19434.pp b/tests/webtbf/tw19434.pp new file mode 100644 index 0000000000..bc3510150b --- /dev/null +++ b/tests/webtbf/tw19434.pp @@ -0,0 +1,18 @@ +{ %fail } + +unit tw19434; +{$mode delphi} + +interface + +function PostMessage2MainWnd(Msg: cardinal; wParam: longint; + lParam: longint): boolean; + +implementation + +function PostMessage2MainWnd(Msg: cardinal; wParam: longint = 0; + lParam: longint = 0): boolean; +begin +end; + +end. diff --git a/tests/webtbs/tw17136.pp b/tests/webtbs/tw17136.pp new file mode 100644 index 0000000000..b4a030da29 --- /dev/null +++ b/tests/webtbs/tw17136.pp @@ -0,0 +1,27 @@ +{ %opt=-vw -Sew } + +{$mode objfpc} + +type + TA = class + public + procedure A(X: boolean = false); virtual; abstract; + end; + + TB = class(TA) + public + procedure A(X: boolean = true); override; + end; + +procedure TB.A(X: boolean = true); +begin + writeln('hi'); +end; + +var + B: TB; +begin + B := TB.Create; + B.A; + B.Free; +end. diff --git a/tests/webtbs/tw19434a.pp b/tests/webtbs/tw19434a.pp new file mode 100644 index 0000000000..53d9bf16e6 --- /dev/null +++ b/tests/webtbs/tw19434a.pp @@ -0,0 +1,23 @@ +{ %norun } + +unit tw19434a; +{$mode delphi} + +interface + + function Connect(const aHost: string; const aPort: Word = 21): Boolean; overload; + function Connect: Boolean; overload; + +implementation + + function Connect(const aHost: string; const aPort: Word): Boolean; + begin + end; + + + function Connect: Boolean; + begin + end; + +end. + diff --git a/tests/webtbs/tw19434b.pp b/tests/webtbs/tw19434b.pp new file mode 100644 index 0000000000..625fd2108e --- /dev/null +++ b/tests/webtbs/tw19434b.pp @@ -0,0 +1,28 @@ +{ %norun } + +unit tw19434b; +{$ifdef fpc} +{$mode delphi} +{$endif} + +interface + +type + tintf = interface + procedure connect(s: string; port: longint = 23); + end; + + tc = class(tinterfacedobject,tintf) + procedure connect(s: string; port: longint); + end; + + +implementation + + + procedure tc.connect(s: string; port: longint); + begin + end; + +end. +