diff --git a/.gitattributes b/.gitattributes index a0dcad54cb..cdd34ab9c4 100644 --- a/.gitattributes +++ b/.gitattributes @@ -16034,6 +16034,7 @@ tests/webtbs/tw3241a.pp svneol=native#text/plain tests/webtbs/tw32474.pp svneol=native#text/pascal tests/webtbs/tw32510.pp svneol=native#text/plain tests/webtbs/tw3252.pp svneol=native#text/plain +tests/webtbs/tw32539.pp svneol=native#text/pascal tests/webtbs/tw3255.pp svneol=native#text/plain tests/webtbs/tw3257.pp svneol=native#text/plain tests/webtbs/tw32576.pp svneol=native#text/pascal diff --git a/compiler/ncal.pas b/compiler/ncal.pas index af7d738503..8ea77e452f 100644 --- a/compiler/ncal.pas +++ b/compiler/ncal.pas @@ -3578,122 +3578,138 @@ implementation else { not a procedure variable } begin - { do we know the procedure to call ? } - if not(assigned(procdefinition)) then - begin - { ignore possible private for properties or in delphi mode for anon. inherited (FK) } - ignorevisibility:=(nf_isproperty in flags) or - ((m_delphi in current_settings.modeswitches) and (cnf_anon_inherited in callnodeflags)); - candidates:=tcallcandidates.create(symtableprocentry,symtableproc,left,ignorevisibility, - not(nf_isproperty in flags),cnf_objc_id_call in callnodeflags,cnf_unit_specified in callnodeflags, - callnodeflags*[cnf_anon_inherited,cnf_inherited]=[],cnf_anon_inherited in callnodeflags,spezcontext); - - { no procedures found? then there is something wrong - with the parameter size or the procedures are - not accessible } - if candidates.count=0 then - begin - { when it's an auto inherited call and there - is no procedure found, but the procedures - were defined with overload directive and at - least two procedures are defined then we ignore - this inherited by inserting a nothingn. Only - do this ugly hack in Delphi mode as it looks more - like a bug. It's also not documented } - if (m_delphi in current_settings.modeswitches) and - (cnf_anon_inherited in callnodeflags) and - (symtableprocentry.owner.symtabletype=ObjectSymtable) and - (po_overload in tprocdef(symtableprocentry.ProcdefList[0]).procoptions) and - (symtableprocentry.ProcdefList.Count>=2) then - result:=cnothingnode.create - else - begin - { in tp mode we can try to convert to procvar if - there are no parameters specified } - if not(assigned(left)) and - not(cnf_inherited in callnodeflags) and - ((m_tp_procvar in current_settings.modeswitches) or - (m_mac_procvar in current_settings.modeswitches)) and - (not assigned(methodpointer) or - (methodpointer.nodetype <> typen)) then - begin - hpt:=cloadnode.create(tprocsym(symtableprocentry),symtableproc); - if assigned(methodpointer) then - tloadnode(hpt).set_mp(methodpointer.getcopy); - typecheckpass(hpt); - result:=hpt; - end - else - begin - CGMessagePos1(fileinfo,parser_e_wrong_parameter_size,symtableprocentry.realname); - symtableprocentry.write_parameter_lists(nil); - end; - end; - candidates.free; - exit; - end; - - { Retrieve information about the candidates } - candidates.get_information; -{$ifdef EXTDEBUG} - { Display info when multiple candidates are found } - if candidates.count>1 then - candidates.dump_info(V_Debug); -{$endif EXTDEBUG} - - { Choose the best candidate and count the number of - candidates left } - cand_cnt:=candidates.choose_best(procdefinition, - assigned(left) and - not assigned(tcallparanode(left).right) and - (tcallparanode(left).left.resultdef.typ=variantdef)); - - { All parameters are checked, check if there are any - procedures left } - if cand_cnt>0 then - begin - { Multiple candidates left? } - if cand_cnt>1 then + { do we know the procedure to call ? } + if not(assigned(procdefinition)) then + begin + { according to bug reports 32539 and 20551, real variant of sqr/abs should be used when they are called for variants to be + delphi compatible, this is in contrast to normal overloading behaviour, so fix this by a terrible hack to be compatible } + if assigned(left) and assigned(tcallparanode(left).left) and + (tcallparanode(left).left.resultdef.typ=variantdef) and assigned(symtableproc.name) and (symtableproc.name^='SYSTEM') then + begin + if symtableprocentry.Name='SQR' then begin - CGMessage(type_e_cant_choose_overload_function); -{$ifdef EXTDEBUG} - candidates.dump_info(V_Hint); -{$else EXTDEBUG} - candidates.list(false); -{$endif EXTDEBUG} - { we'll just use the first candidate to make the - call } + result:=cinlinenode.createintern(in_sqr_real,false,tcallparanode(left).left.getcopy); + exit; end; + if symtableprocentry.Name='ABS' then + begin + result:=cinlinenode.createintern(in_abs_real,false,tcallparanode(left).left.getcopy); + exit; + end; + end; + { ignore possible private for properties or in delphi mode for anon. inherited (FK) } + ignorevisibility:=(nf_isproperty in flags) or + ((m_delphi in current_settings.modeswitches) and (cnf_anon_inherited in callnodeflags)); + candidates:=tcallcandidates.create(symtableprocentry,symtableproc,left,ignorevisibility, + not(nf_isproperty in flags),cnf_objc_id_call in callnodeflags,cnf_unit_specified in callnodeflags, + callnodeflags*[cnf_anon_inherited,cnf_inherited]=[],cnf_anon_inherited in callnodeflags,spezcontext); - { assign procdefinition } - if symtableproc=nil then - symtableproc:=procdefinition.owner; - end - else - begin - { No candidates left, this must be a type error, - because wrong size is already checked. procdefinition - is filled with the first (random) definition that is - found. We use this definition to display a nice error - message that the wrong type is passed } - candidates.find_wrong_para; - candidates.list(true); + { no procedures found? then there is something wrong + with the parameter size or the procedures are + not accessible } + if candidates.count=0 then + begin + { when it's an auto inherited call and there + is no procedure found, but the procedures + were defined with overload directive and at + least two procedures are defined then we ignore + this inherited by inserting a nothingn. Only + do this ugly hack in Delphi mode as it looks more + like a bug. It's also not documented } + if (m_delphi in current_settings.modeswitches) and + (cnf_anon_inherited in callnodeflags) and + (symtableprocentry.owner.symtabletype=ObjectSymtable) and + (po_overload in tprocdef(symtableprocentry.ProcdefList[0]).procoptions) and + (symtableprocentry.ProcdefList.Count>=2) then + result:=cnothingnode.create + else + begin + { in tp mode we can try to convert to procvar if + there are no parameters specified } + if not(assigned(left)) and + not(cnf_inherited in callnodeflags) and + ((m_tp_procvar in current_settings.modeswitches) or + (m_mac_procvar in current_settings.modeswitches)) and + (not assigned(methodpointer) or + (methodpointer.nodetype <> typen)) then + begin + hpt:=cloadnode.create(tprocsym(symtableprocentry),symtableproc); + if assigned(methodpointer) then + tloadnode(hpt).set_mp(methodpointer.getcopy); + typecheckpass(hpt); + result:=hpt; + end + else + begin + CGMessagePos1(fileinfo,parser_e_wrong_parameter_size,symtableprocentry.realname); + symtableprocentry.write_parameter_lists(nil); + end; + end; + candidates.free; + exit; + end; + + { Retrieve information about the candidates } + candidates.get_information; {$ifdef EXTDEBUG} - candidates.dump_info(V_Hint); + { Display info when multiple candidates are found } + if candidates.count>1 then + candidates.dump_info(V_Debug); {$endif EXTDEBUG} - { We can not proceed, release all procs and exit } - candidates.free; - exit; - end; + { Choose the best candidate and count the number of + candidates left } + cand_cnt:=candidates.choose_best(procdefinition, + assigned(left) and + not assigned(tcallparanode(left).right) and + (tcallparanode(left).left.resultdef.typ=variantdef)); - { if the final procedure definition is not yet owned, - ensure that it is } - procdefinition.register_def; - if procdefinition.is_specialization and (procdefinition.typ=procdef) then - maybe_add_pending_specialization(procdefinition); + { All parameters are checked, check if there are any + procedures left } + if cand_cnt>0 then + begin + { Multiple candidates left? } + if cand_cnt>1 then + begin + CGMessage(type_e_cant_choose_overload_function); +{$ifdef EXTDEBUG} + candidates.dump_info(V_Hint); +{$else EXTDEBUG} + candidates.list(false); +{$endif EXTDEBUG} + { we'll just use the first candidate to make the + call } + end; - candidates.free; + { assign procdefinition } + if symtableproc=nil then + symtableproc:=procdefinition.owner; + end + else + begin + { No candidates left, this must be a type error, + because wrong size is already checked. procdefinition + is filled with the first (random) definition that is + found. We use this definition to display a nice error + message that the wrong type is passed } + candidates.find_wrong_para; + candidates.list(true); +{$ifdef EXTDEBUG} + candidates.dump_info(V_Hint); +{$endif EXTDEBUG} + + { We can not proceed, release all procs and exit } + candidates.free; + exit; + end; + + { if the final procedure definition is not yet owned, + ensure that it is } + procdefinition.register_def; + if procdefinition.is_specialization and (procdefinition.typ=procdef) then + maybe_add_pending_specialization(procdefinition); + + candidates.free; end; { end of procedure to call determination } end; diff --git a/tests/webtbs/tw32539.pp b/tests/webtbs/tw32539.pp new file mode 100644 index 0000000000..7b2ec21782 --- /dev/null +++ b/tests/webtbs/tw32539.pp @@ -0,0 +1,16 @@ +uses + variants; +var + v : variant; + +begin + v:=1.5; + v:=sqr(v); + if v<>1.5*1.5 then + halt(1); + v:=-v; + v:=abs(v); + if v<>1.5*1.5 then + halt(1); + writeln('ok'); +end.