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

* if the unit of a procedure call is explicitly specified, limit the search

Browse Source 
for (overloaded) procsyms to that unit (mantis #17220)

git-svn-id: trunk@15887 -
This commit is contained in:
Jonas Maebe 2010-08-23 20:51:40 +00:00
parent fae7605a36
commit 5ca1bd2a32
8 changed files with 117 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
.gitattributes vendored
View File

@ -10632,6 +10632,8 @@ tests/webtbs/tw17180.pp svneol=native#text/plain
tests/webtbs/tw17181.pp svneol=native#text/plain
tests/webtbs/tw1720.pp svneol=native#text/plain
tests/webtbs/tw17213.pp svneol=native#text/pascal
tests/webtbs/tw17220.pp svneol=native#text/plain
tests/webtbs/tw17220a.pp svneol=native#text/plain
tests/webtbs/tw1735.pp svneol=native#text/plain
tests/webtbs/tw1737.pp svneol=native#text/plain
tests/webtbs/tw1744.pp svneol=native#text/plain
@ -11489,6 +11491,8 @@ tests/webtbs/uw13583.pp svneol=native#text/plain
tests/webtbs/uw14124.pp svneol=native#text/plain
tests/webtbs/uw14958.pp svneol=native#text/plain
tests/webtbs/uw15909.pp svneol=native#text/plain
tests/webtbs/uw17220.pp svneol=native#text/plain
tests/webtbs/uw17220a.pp svneol=native#text/plain
tests/webtbs/uw2004.inc svneol=native#text/plain
tests/webtbs/uw2040.pp svneol=native#text/plain
tests/webtbs/uw2266a.inc svneol=native#text/plain

28
compiler/htypechk.pas
View File

@ -67,11 +67,11 @@ interface
FParaLength : smallint;
FAllowVariant : boolean;
procedure collect_overloads_in_class(ProcdefOverloadList:TFPObjectList);
procedure collect_overloads_in_units(ProcdefOverloadList:TFPObjectList; objcidcall: boolean);
procedure create_candidate_list(ignorevisibility,allowdefaultparas,objcidcall:boolean);
procedure collect_overloads_in_units(ProcdefOverloadList:TFPObjectList; objcidcall,explicitunit: boolean);
procedure create_candidate_list(ignorevisibility,allowdefaultparas,objcidcall,explicitunit:boolean);
function proc_add(ps:tprocsym;pd:tprocdef;objcidcall: boolean):pcandidate;
public
constructor create(sym:tprocsym;st:TSymtable;ppn:tnode;ignorevisibility,allowdefaultparas,objcidcall:boolean);
constructor create(sym:tprocsym;st:TSymtable;ppn:tnode;ignorevisibility,allowdefaultparas,objcidcall,explicitunit:boolean);
constructor create_operator(op:ttoken;ppn:tnode);
destructor destroy;override;
procedure list(all:boolean);
@ -1647,7 +1647,7 @@ implementation
TCallCandidates
****************************************************************************}
constructor tcallcandidates.create(sym:tprocsym;st:TSymtable;ppn:tnode;ignorevisibility,allowdefaultparas,objcidcall:boolean);
constructor tcallcandidates.create(sym:tprocsym;st:TSymtable;ppn:tnode;ignorevisibility,allowdefaultparas,objcidcall,explicitunit:boolean);
begin
if not assigned(sym) then
internalerror(200411015);
@ -1655,7 +1655,7 @@ implementation
FProcsym:=sym;
FProcsymtable:=st;
FParanode:=ppn;
create_candidate_list(ignorevisibility,allowdefaultparas,objcidcall);
create_candidate_list(ignorevisibility,allowdefaultparas,objcidcall,explicitunit);
end;
@ -1665,7 +1665,7 @@ implementation
FProcsym:=nil;
FProcsymtable:=nil;
FParanode:=ppn;
create_candidate_list(false,false,false);
create_candidate_list(false,false,false,false);
end;
@ -1722,7 +1722,7 @@ implementation
end;
procedure tcallcandidates.collect_overloads_in_units(ProcdefOverloadList:TFPObjectList; objcidcall: boolean);
procedure tcallcandidates.collect_overloads_in_units(ProcdefOverloadList:TFPObjectList; objcidcall,explicitunit: boolean);
var
j : integer;
pd : tprocdef;
@ -1755,6 +1755,14 @@ implementation
while assigned(checkstack) do
begin
srsymtable:=checkstack^.symtable;
{ if the unit in which the routine has to be searched has been
specified explicitly, stop searching after its symtable(s) have
been checked (can be both the static and the global symtable
in case it's the current unit itself) }
if explicitunit and
(FProcsymtable.symtabletype in [globalsymtable,staticsymtable]) and
(srsymtable.moduleid<>FProcsymtable.moduleid) then
break;
if srsymtable.symtabletype in [localsymtable,staticsymtable,globalsymtable] then
begin
srsym:=tprocsym(srsymtable.FindWithHash(hashedid));
@ -1780,12 +1788,12 @@ implementation
break;
end;
end;
checkstack:=checkstack^.next;
checkstack:=checkstack^.next
end;
end;
procedure tcallcandidates.create_candidate_list(ignorevisibility,allowdefaultparas,objcidcall:boolean);
procedure tcallcandidates.create_candidate_list(ignorevisibility,allowdefaultparas,objcidcall,explicitunit:boolean);
var
j : integer;
pd : tprocdef;
@ -1804,7 +1812,7 @@ implementation
(FProcsym.owner.symtabletype=objectsymtable) then
collect_overloads_in_class(ProcdefOverloadList)
else
collect_overloads_in_units(ProcdefOverloadList,objcidcall);
collect_overloads_in_units(ProcdefOverloadList,objcidcall,explicitunit);
{ determine length of parameter list.
for operators also enable the variant-operators if

5
compiler/ncal.pas
View File

@ -48,7 +48,8 @@ interface
cnf_uses_varargs, { varargs are used in the declaration }
cnf_create_failed, { exception thrown in constructor -> don't call beforedestruction }
cnf_objc_processed, { the procedure name has been set to the appropriate objc_msgSend* variant -> don't process again }
cnf_objc_id_call { the procedure is a member call via id -> any ObjC method of any ObjC type in scope is fair game }
cnf_objc_id_call, { the procedure is a member call via id -> any ObjC method of any ObjC type in scope is fair game }
cnf_unit_specified { the unit in which the procedure has to be searched has been specified }
);
tcallnodeflags = set of tcallnodeflag;
@ -2650,7 +2651,7 @@ implementation
{ 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);
candidates:=tcallcandidates.create(symtableprocentry,symtableproc,left,ignorevisibility,not(nf_isproperty in flags),cnf_objc_id_call in callnodeflags,cnf_unit_specified in callnodeflags);
{ no procedures found? then there is something wrong
with the parameter size or the procedures are

17
compiler/pexpr.pas
View File

@ -1351,12 +1351,13 @@ implementation
procedure factor_read_id(out p1:tnode;var again:boolean);
var
srsym : tsym;
unit_found : boolean;
srsymtable : TSymtable;
hdef : tdef;
orgstoredpattern,
storedpattern : string;
callflags: tcallnodeflags;
t : ttoken;
unit_found : boolean;
begin
{ allow post fix operators }
again:=true;
@ -1622,10 +1623,16 @@ implementation
internalerror(2007012006);
end
else
{ regular procedure/function call }
do_proc_call(srsym,srsymtable,nil,
(getaddr and not(token in [_CARET,_POINT,_LECKKLAMMER])),
again,p1,[]);
begin
{ regular procedure/function call }
if not unit_found then
callflags:=[]
else
callflags:=[cnf_unit_specified];
do_proc_call(srsym,srsymtable,nil,
(getaddr and not(token in [_CARET,_POINT,_LECKKLAMMER])),
again,p1,callflags);
end;
end;
propertysym :

14
tests/webtbs/tw17220.pp Normal file
View File

@ -0,0 +1,14 @@
program project1;
{$ifdef fpc}
{$mode objfpc}{$H+}
{$endif}
uses SysUtils, uw17220;
var
A, B: int64;
begin
writeln(uw17220.IntToHEX(16, 0)); {Here ERROR: called SysUtils.IntToHEX }
if uw17220.IntToHEX(16, 0)<>'passed' then
halt(1);
end.

10
tests/webtbs/tw17220a.pp Normal file
View File

@ -0,0 +1,10 @@
program project1;
{$ifdef fpc}
{$mode objfpc}{$H+}
{$endif}
uses uw17220a;
begin
test;
end.

17
tests/webtbs/uw17220.pp Normal file
View File

@ -0,0 +1,17 @@
unit uw17220;
{$ifdef fpc}
{$mode objfpc}{$H+}
{$endif}
interface
function IntToHEX(Value, Digits: int64): string; overload;
implementation
function IntToHEX(Value, Digits: int64): string;
begin
IntToHEX := 'passed';
end;
end.

39
tests/webtbs/uw17220a.pp Normal file
View File

@ -0,0 +1,39 @@
unit uw17220a;
{$ifdef fpc}
{$mode objfpc}{$H+}
{$endif}
interface
uses
SysUtils;
procedure test;
function IntToHEX(Value, Digits: int64): string; overload;
implementation
function IntToHEX(Value, Digits: int64): string;
begin
IntToHEX := 'passedq';
end;
function IntToHEX(Value, Digits: longint): string; overload;
begin
IntToHEX := 'passedl';
end;
procedure test;
var
l: longint;
i: int64;
begin
l:=0;
i:=0;
if uw17220a.inttohex(l,l)<>'passedl' then
halt(1);
if uw17220a.inttohex(i,i)<>'passedq' then
halt(2);
end;
end.