paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-04 18:10:26 +02:00
Code Issues Packages Projects Releases Wiki Activity

* fix issue #32539 and #20551 by some ugly hack

Browse Source 
git-svn-id: trunk@38531 -
This commit is contained in:
florian 2018-03-15 20:37:50 +00:00
parent 054ef133f9
commit 3e7af376fe
3 changed files with 141 additions and 108 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -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

232
compiler/ncal.pas
View File

@ -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;

16
tests/webtbs/tw32539.pp Normal file
View File

@ -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.