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

Implement cross unit type overloading of generics. This fixes the regression introduced with revision 25498.

Browse Source 
symtable.pas:
  + add new tsymbol_search_flag type which can be passed to various searchsym* routines
  + add support to not call "addsymref"
  + add new searchsym_with_flags function that calls searchsym_maybe_with_symoption
  * adjust searchsym_maybe_with_symoption, searchsym_in_class & searchsym_in_helper to use new flag type instead of Boolean arguments
  * adjust searchsym & searchsym_with_symoption which call the modified functions
nutils.pas, handle_staticfield_access:
  * adjust searchsym_in_class call
pexpr.pas, handle_factor_typenode, postfixoperators, factor:
  * adjust searchsym_in_helper and searchsym_in_class calls
pinline.pas, new_function:
  * adjust searchsym_in_class call
scanner.pas, try_consume_nestedsym:
  * adjust searchsym_in_class call
fmodule.pas, tmodule:
  + add genericdummysyms field which is a TFPHashObjectList that contains TFPObjectList instances per generic dummy that in turn contains tgenericdummysyms instances
pgenutil.pas:
  + add function split_generic_name to split a generic name into non-generic name and count value of type parameters
  + add function resolve_generic_dummysym which tries to use the new genericdummysyms field to find the real symbol of a dummy sym
  * generate_specialization: adjust searchsym_in_class call
  * specialization_init/specialization_done: save/restore genericdummysyms of module
symdef.pas, tdefawaresymtablestack:
  + add new intermediate method pushcommon which is used by both push and pushafter
  + add new intermediate method remove_helpers_and_generics (which calls remove_generics and remove_helpers if necessary)
  * rename removehelpers to remove_helpers
  * rename addhelpers to add_helpers_and_generics and extend it to correctly fill current_module.genericdummysyms
  * call remove_helpers_and_generics from pop instead of remove_helpers
ptype.pas, single_type, read_named_type.expr_type, read_named_type:
  * try to resolve symbols with sp_generic_dummy with resolve_generic_dummysym

+ added test

git-svn-id: trunk@25519 -
This commit is contained in:
svenbarth 2013-09-18 14:28:46 +00:00
parent 2fa739f729
commit 9d48bc0baf
15 changed files with 360 additions and 60 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
.gitattributes vendored
View File

@ -11310,6 +11310,7 @@ tests/test/tgeneric92.pp svneol=native#text/pascal
tests/test/tgeneric93.pp svneol=native#text/pascal
tests/test/tgeneric94.pp svneol=native#text/pascal
tests/test/tgeneric95.pp svneol=native#text/pascal
tests/test/tgeneric96.pp svneol=native#text/pascal
tests/test/tgoto.pp svneol=native#text/plain
tests/test/theap.pp svneol=native#text/plain
tests/test/theapthread.pp svneol=native#text/plain
@ -11937,6 +11938,10 @@ tests/test/ugeneric91a.pp svneol=native#text/pascal
tests/test/ugeneric91b.pp svneol=native#text/pascal
tests/test/ugeneric93a.pp svneol=native#text/pascal
tests/test/ugeneric93b.pp svneol=native#text/pascal
tests/test/ugeneric96a.pp svneol=native#text/pascal
tests/test/ugeneric96b.pp svneol=native#text/pascal
tests/test/ugeneric96c.pp svneol=native#text/pascal
tests/test/ugeneric96d.pp svneol=native#text/pascal
tests/test/uhintdir.pp svneol=native#text/plain
tests/test/uhlp3.pp svneol=native#text/pascal
tests/test/uhlp31.pp svneol=native#text/pascal

7
compiler/fmodule.pas
View File

@ -184,6 +184,11 @@ interface
the full name of the type and the data is a TFPObjectList of
tobjectdef instances (the helper defs) }
extendeddefs: TFPHashObjectList;
{ contains a list of the current topmost non-generic symbol for a
typename of which at least one generic exists; the key is the
non-generic typename and the data is a TFPObjectList of tgenericdummyentry
instances whereby the last one is the current top most one }
genericdummysyms: TFPHashObjectList;
{ this contains a list of units that needs to be waited for until the
unit can be finished (code generated, etc.); this is needed to handle
@ -547,6 +552,7 @@ implementation
wpoinfo:=nil;
checkforwarddefs:=TFPObjectList.Create(false);
extendeddefs:=TFPHashObjectList.Create(true);
genericdummysyms:=tfphashobjectlist.create(true);
waitingforunit:=tfpobjectlist.create(false);
waitingunits:=tfpobjectlist.create(false);
globalsymtable:=nil;
@ -636,6 +642,7 @@ implementation
stringdispose(mainname);
FImportLibraryList.Free;
extendeddefs.Free;
genericdummysyms.free;
waitingforunit.free;
waitingunits.free;
stringdispose(asmprefix);

2
compiler/nutils.pas
View File

@ -1042,7 +1042,7 @@ implementation
else
static_name:=lower(generate_nested_name(sym.owner,'_'))+'_'+sym.name;
if sym.owner.defowner.typ=objectdef then
searchsym_in_class(tobjectdef(sym.owner.defowner),tobjectdef(sym.owner.defowner),static_name,sym,srsymtable,true)
searchsym_in_class(tobjectdef(sym.owner.defowner),tobjectdef(sym.owner.defowner),static_name,sym,srsymtable,[ssf_search_helper])
else
searchsym_in_record(trecorddef(sym.owner.defowner),static_name,sym,srsymtable);
if assigned(sym) then

16
compiler/pexpr.pas
View File

@ -1382,7 +1382,7 @@ implementation
result:=ctypenode.create(hdef);
ttypenode(result).typesym:=sym;
{ search also in inherited methods }
searchsym_in_class(tobjectdef(hdef),tobjectdef(current_structdef),pattern,srsym,srsymtable,true);
searchsym_in_class(tobjectdef(hdef),tobjectdef(current_structdef),pattern,srsym,srsymtable,[ssf_search_helper]);
if assigned(srsym) then
check_hints(srsym,srsym.symoptions,srsym.deprecatedmsg);
consume(_ID);
@ -2197,7 +2197,7 @@ implementation
if token=_ID then
begin
structh:=tobjectdef(tclassrefdef(p1.resultdef).pointeddef);
searchsym_in_class(tobjectdef(structh),tobjectdef(structh),pattern,srsym,srsymtable,true);
searchsym_in_class(tobjectdef(structh),tobjectdef(structh),pattern,srsym,srsymtable,[ssf_search_helper]);
if assigned(srsym) then
begin
check_hints(srsym,srsym.symoptions,srsym.deprecatedmsg);
@ -2221,7 +2221,7 @@ implementation
if token=_ID then
begin
structh:=tobjectdef(p1.resultdef);
searchsym_in_class(tobjectdef(structh),tobjectdef(structh),pattern,srsym,srsymtable,true);
searchsym_in_class(tobjectdef(structh),tobjectdef(structh),pattern,srsym,srsymtable,[ssf_search_helper]);
if assigned(srsym) then
begin
check_hints(srsym,srsym.symoptions,srsym.deprecatedmsg);
@ -2920,9 +2920,9 @@ implementation
else
{ helpers have their own ways of dealing with inherited }
if is_objectpascal_helper(current_structdef) then
searchsym_in_helper(tobjectdef(current_structdef),tobjectdef(current_structdef),hs,srsym,srsymtable,true)
searchsym_in_helper(tobjectdef(current_structdef),tobjectdef(current_structdef),hs,srsym,srsymtable,[ssf_has_inherited])
else
searchsym_in_class(hclassdef,current_structdef,hs,srsym,srsymtable,true);
searchsym_in_class(hclassdef,current_structdef,hs,srsym,srsymtable,[ssf_search_helper]);
end
else
begin
@ -2932,9 +2932,9 @@ implementation
anon_inherited:=false;
{ helpers have their own ways of dealing with inherited }
if is_objectpascal_helper(current_structdef) then
searchsym_in_helper(tobjectdef(current_structdef),tobjectdef(current_structdef),hs,srsym,srsymtable,true)
searchsym_in_helper(tobjectdef(current_structdef),tobjectdef(current_structdef),hs,srsym,srsymtable,[ssf_has_inherited])
else
searchsym_in_class(hclassdef,current_structdef,hs,srsym,srsymtable,true);
searchsym_in_class(hclassdef,current_structdef,hs,srsym,srsymtable,[ssf_search_helper]);
end;
if assigned(srsym) then
begin
@ -2992,7 +2992,7 @@ implementation
if (po_msgint in pd.procoptions) or
(po_msgstr in pd.procoptions) then
begin
searchsym_in_class(hclassdef,hclassdef,'DEFAULTHANDLER',srsym,srsymtable,true);
searchsym_in_class(hclassdef,hclassdef,'DEFAULTHANDLER',srsym,srsymtable,[ssf_search_helper]);
if not assigned(srsym) or
(srsym.typ<>procsym) then
internalerror(200303171);

41
compiler/pgenutil.pas
View File

@ -41,11 +41,14 @@ uses
procedure insert_generic_parameter_types(def:tstoreddef;genericdef:tstoreddef;genericlist:TFPObjectList);
procedure maybe_insert_generic_rename_symbol(const name:tidstring;genericlist:tfpobjectlist);
function generate_generic_name(const name:tidstring;specializename:ansistring):tidstring;
procedure split_generic_name(const name:tidstring;out nongeneric:string;out count:longint);
function resolve_generic_dummysym(const name:tidstring):tsym;
type
tspecializationstate = record
oldsymtablestack : tsymtablestack;
oldextendeddefs : TFPHashObjectList;
oldgenericdummysyms: tfphashobjectlist;
end;
procedure specialization_init(genericdef:tdef;var state:tspecializationstate);
@ -566,7 +569,7 @@ uses
if assigned(genericdef) and (genericdef.owner.symtabletype in [objectsymtable,recordsymtable]) then
begin
if genericdef.owner.symtabletype = objectsymtable then
found:=searchsym_in_class(tobjectdef(genericdef.owner.defowner),tobjectdef(genericdef.owner.defowner),ugenname,srsym,st,false)
found:=searchsym_in_class(tobjectdef(genericdef.owner.defowner),tobjectdef(genericdef.owner.defowner),ugenname,srsym,st,[])
else
found:=searchsym_in_record(tabstractrecorddef(genericdef.owner.defowner),ugenname,srsym,st);
end
@ -1102,6 +1105,38 @@ uses
result:=name+'$crc'+hexstr(crc,8);
end;
procedure split_generic_name(const name:tidstring;out nongeneric:string;out count:longint);
var
i,code : longint;
countstr : string;
begin
for i:=length(name) downto 1 do
if name[i]='$' then
begin
nongeneric:=copy(name,1,i-1);
countstr:=copy(name,i+1,length(name)-i);
val(countstr,count,code);
if code<>0 then
internalerror(2013091605);
exit;
end;
nongeneric:=name;
count:=0;
end;
function resolve_generic_dummysym(const name:tidstring):tsym;
var
list : tfpobjectlist;
begin
list:=tfpobjectlist(current_module.genericdummysyms.find(name));
if assigned(list) and (list.count>0) then
result:=tgenericdummyentry(list.last).resolvedsym
else
result:=nil;
end;
procedure specialization_init(genericdef:tdef;var state: tspecializationstate);
var
pu : tused_unit;
@ -1117,7 +1152,9 @@ uses
the resolved symbols }
state.oldsymtablestack:=symtablestack;
state.oldextendeddefs:=current_module.extendeddefs;
state.oldgenericdummysyms:=current_module.genericdummysyms;
current_module.extendeddefs:=TFPHashObjectList.create(true);
current_module.genericdummysyms:=tfphashobjectlist.create(true);
symtablestack:=tdefawaresymtablestack.create;
hmodule:=find_module_from_symtable(genericdef.owner);
if hmodule=nil then
@ -1169,6 +1206,8 @@ uses
{ Restore symtablestack }
current_module.extendeddefs.free;
current_module.extendeddefs:=state.oldextendeddefs;
current_module.genericdummysyms.free;
current_module.genericdummysyms:=state.oldgenericdummysyms;
symtablestack.free;
symtablestack:=state.oldsymtablestack;
{ clear the state record to be on the safe side }

2
compiler/pinline.pas
View File

@ -472,7 +472,7 @@ implementation
{ search the constructor also in the symbol tables of
the parents }
afterassignment:=false;
searchsym_in_class(classh,classh,pattern,srsym,srsymtable,true);
searchsym_in_class(classh,classh,pattern,srsym,srsymtable,[ssf_search_helper]);
consume(_ID);
do_member_read(classh,false,srsym,p1,again,[cnf_new_call]);
{ we need to know which procedure is called }

59
compiler/ptype.pas
View File

@ -493,8 +493,16 @@ implementation
)
then
begin
Message(parser_e_no_generics_as_types);
def:=generrordef;
srsym:=resolve_generic_dummysym(srsym.name);
if assigned(srsym) and
not (sp_generic_dummy in srsym.symoptions) and
(srsym.typ=typesym) then
def:=ttypesym(srsym).typedef
else
begin
Message(parser_e_no_generics_as_types);
def:=generrordef;
end;
end
else if (def.typ=undefineddef) and
(sp_generic_dummy in srsym.symoptions) and
@ -504,8 +512,16 @@ implementation
begin
if m_delphi in current_settings.modeswitches then
begin
Message(parser_e_no_generics_as_types);
def:=generrordef;
srsym:=resolve_generic_dummysym(srsym.name);
if assigned(srsym) and
not (sp_generic_dummy in srsym.symoptions) and
(srsym.typ=typesym) then
def:=ttypesym(srsym).typedef
else
begin
Message(parser_e_no_generics_as_types);
def:=generrordef;
end;
end
else
def:=current_genericdef;
@ -887,6 +903,9 @@ implementation
old_block_type : tblock_type;
dospecialize : boolean;
newdef : tdef;
sym : tsym;
genstr : string;
gencount : longint;
begin
old_block_type:=block_type;
dospecialize:=false;
@ -1031,8 +1050,26 @@ implementation
)
then
begin
Message(parser_e_no_generics_as_types);
def:=generrordef;
if assigned(def.typesym) then
begin
if ttypesym(def.typesym).typedef.typ<>undefineddef then
{ non-Delphi modes... }
split_generic_name(def.typesym.name,genstr,gencount)
else
genstr:=def.typesym.name;
sym:=resolve_generic_dummysym(genstr);
end
else
sym:=nil;
if assigned(sym) and
not (sp_generic_dummy in sym.symoptions) and
(sym.typ=typesym) then
def:=ttypesym(sym).typedef
else
begin
Message(parser_e_no_generics_as_types);
def:=generrordef;
end;
end
else if is_classhelper(def) then
begin
@ -1515,7 +1552,15 @@ implementation
(tt2.typ=undefineddef) and
assigned(tt2.typesym) and
(sp_generic_dummy in tt2.typesym.symoptions) then
Message(parser_e_no_generics_as_types);
begin
sym:=resolve_generic_dummysym(tt2.typesym.name);
if assigned(sym) and
not (sp_generic_dummy in sym.symoptions) and
(sym.typ=typesym) then
tt2:=ttypesym(sym).typedef
else
Message(parser_e_no_generics_as_types);
end;
{ don't use getpointerdef() here, since this is a type
declaration (-> must create new typedef) }
def:=tpointerdef.create(tt2);

2
compiler/scanner.pas
View File

@ -1390,7 +1390,7 @@ type
preproc_consume(_POINT);
current_scanner.skipspace;
if def.typ=objectdef then
found:=searchsym_in_class(tobjectdef(def),tobjectdef(def),current_scanner.preproc_pattern,srsym,srsymtable,true)
found:=searchsym_in_class(tobjectdef(def),tobjectdef(def),current_scanner.preproc_pattern,srsym,srsymtable,[ssf_search_helper])
else
found:=searchsym_in_record(trecorddef(def),current_scanner.preproc_pattern,srsym,srsymtable);
if not found then

136
compiler/symdef.pas
View File

@ -825,16 +825,27 @@ interface
function is_publishable : boolean;override;
end;
tgenericdummyentry = class
dummysym : tsym;
resolvedsym : tsym;
end;
tdefawaresymtablestack = class(TSymtablestack)
private
procedure addhelpers(st: TSymtable);
procedure removehelpers(st: TSymtable);
procedure add_helpers_and_generics(st:tsymtable;addgenerics:boolean);
procedure remove_helpers_and_generics(st:tsymtable);inline;
procedure remove_helpers(st:tsymtable);
procedure remove_generics(st:tsymtable);
procedure pushcommon(st:tsymtable);inline;
public
procedure push(st: TSymtable); override;
procedure pushafter(st,afterst:TSymtable); override;
procedure pop(st: TSymtable); override;
end;
var
current_structdef: tabstractrecorddef; { used for private functions check !! }
current_genericdef: tstoreddef; { used to reject declaration of generic class inside generic class }
@ -1080,6 +1091,8 @@ implementation
{$ifdef jvm}
jvmdef,
{$endif}
{ parser }
pgenutil,
{ module }
fmodule,
{ other }
@ -1316,12 +1329,15 @@ implementation
the pushed/popped symtables)
****************************************************************************}
procedure tdefawaresymtablestack.addhelpers(st: TSymtable);
procedure tdefawaresymtablestack.add_helpers_and_generics(st:tsymtable;addgenerics:boolean);
var
i: integer;
s: string;
list: TFPObjectList;
def: tdef;
sym,srsym : tsym;
srsymtable : tsymtable;
entry : tgenericdummyentry;
begin
{ search the symtable from first to last; the helper to use will be the
last one in the list }
@ -1330,6 +1346,7 @@ implementation
if not (st.symlist[i] is ttypesym) then
continue;
def:=ttypesym(st.SymList[i]).typedef;
sym:=tsym(st.symlist[i]);
if is_objectpascal_helper(def) then
begin
s:=generate_objectpascal_helper_key(tobjectdef(def).extendeddef);
@ -1343,13 +1360,62 @@ implementation
list.Add(def);
end
else
{ add nested helpers as well }
if def.typ in [recorddef,objectdef] then
addhelpers(tabstractrecorddef(def).symtable);
begin
if addgenerics and
(sp_generic_dummy in sym.symoptions)
then
begin
{ did we already search for a generic with that name? }
list:=tfpobjectlist(current_module.genericdummysyms.find(sym.name));
if not assigned(list) then
begin
list:=tfpobjectlist.create(true);
current_module.genericdummysyms.add(sym.name,list);
end;
{ is the dummy sym still "dummy"? }
if (sym.typ=typesym) and
(
{ dummy sym defined in mode Delphi }
(ttypesym(sym).typedef.typ=undefineddef) or
{ dummy sym defined in non-Delphi mode }
(tstoreddef(ttypesym(sym).typedef).is_generic)
) then
begin
{ do we have a non-generic type of the same name
available? }
if not searchsym_with_flags(sym.name,srsym,srsymtable,[ssf_no_addsymref]) then
srsym:=nil;
end
else
{ dummy symbol is already not so dummy anymore }
srsym:=nil;
if assigned(srsym) then
begin
entry:=tgenericdummyentry.create;
entry.resolvedsym:=srsym;
entry.dummysym:=sym;
list.add(entry);
end;
end;
{ add nested helpers as well }
if (def.typ in [recorddef,objectdef]) and
(sto_has_helper in tabstractrecorddef(def).symtable.tableoptions) then
add_helpers_and_generics(tabstractrecorddef(def).symtable,false);
end;
end;
end;
procedure tdefawaresymtablestack.removehelpers(st: TSymtable);
procedure tdefawaresymtablestack.remove_helpers_and_generics(st:tsymtable);
begin
if sto_has_helper in st.tableoptions then
remove_helpers(st);
if sto_has_generic in st.tableoptions then
remove_generics(st);
end;
procedure tdefawaresymtablestack.remove_helpers(st:TSymtable);
var
i, j: integer;
tmpst: TSymtable;
@ -1383,31 +1449,63 @@ implementation
end;
end;
procedure tdefawaresymtablestack.remove_generics(st:tsymtable);
var
i,j : longint;
entry : tgenericdummyentry;
list : tfpobjectlist;
begin
for i:=current_module.genericdummysyms.count-1 downto 0 do
begin
list:=tfpobjectlist(current_module.genericdummysyms[i]);
if not assigned(list) then
continue;
for j:=list.count-1 downto 0 do
begin
entry:=tgenericdummyentry(list[j]);
if entry.dummysym.owner=st then
list.delete(j);
end;
if list.count=0 then
current_module.genericdummysyms.delete(i);
end;
end;
procedure tdefawaresymtablestack.pushcommon(st:tsymtable);
begin
if (sto_has_generic in st.tableoptions) or
(
(st.symtabletype in [globalsymtable,staticsymtable]) and
(sto_has_helper in st.tableoptions)
) then
{ nested helpers will be added as well }
add_helpers_and_generics(st,true);
end;
procedure tdefawaresymtablestack.push(st: TSymtable);
begin
{ nested helpers will be added as well }
if (st.symtabletype in [globalsymtable,staticsymtable]) and
(sto_has_helper in st.tableoptions) then
addhelpers(st);
pushcommon(st);
inherited push(st);
end;
procedure tdefawaresymtablestack.pushafter(st,afterst:TSymtable);
begin
{ nested helpers will be added as well }
if (st.symtabletype in [globalsymtable,staticsymtable]) and
(sto_has_helper in st.tableoptions) then
addhelpers(st);
pushcommon(st);
inherited pushafter(st,afterst);
end;
procedure tdefawaresymtablestack.pop(st: TSymtable);
begin
inherited pop(st);
{ nested helpers will be removed as well }
if (st.symtabletype in [globalsymtable,staticsymtable]) and
(sto_has_helper in st.tableoptions) then
removehelpers(st);
if (sto_has_generic in st.tableoptions) or
(
(st.symtabletype in [globalsymtable,staticsymtable]) and
(sto_has_helper in st.tableoptions)
) then
{ nested helpers will be removed as well }
remove_helpers_and_generics(st);
end;

69
compiler/symtable.pas
View File

@ -206,6 +206,15 @@ interface
var
systemunit : tglobalsymtable; { pointer to the system unit }
type
tsymbol_search_flag = (
ssf_search_option,
ssf_search_helper,
ssf_has_inherited,
ssf_no_addsymref
);
tsymbol_search_flags = set of tsymbol_search_flag;
{****************************************************************************
Functions
@ -233,19 +242,20 @@ interface
function is_visible_for_object(pd:tprocdef;contextobjdef:tabstractrecorddef):boolean;
function is_visible_for_object(sym:tsym;contextobjdef:tabstractrecorddef):boolean;
function searchsym(const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean;
function searchsym_maybe_with_symoption(const s : TIDString;out srsym:tsym;out srsymtable:TSymtable;searchoption:boolean;option:tsymoption):boolean;
function searchsym_with_flags(const s : TIDString;out srsym:tsym;out srsymtable:TSymtable;flags:tsymbol_search_flags):boolean;
function searchsym_maybe_with_symoption(const s : TIDString;out srsym:tsym;out srsymtable:TSymtable;flags:tsymbol_search_flags;option:tsymoption):boolean;
{ searches for a symbol with the given name that has the given option in
symoptions set }
function searchsym_with_symoption(const s : TIDString;out srsym:tsym;out srsymtable:TSymtable;option:tsymoption):boolean;
function searchsym_type(const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean;
function searchsym_in_module(pm:pointer;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean;
function searchsym_in_named_module(const unitname, symname: TIDString; out srsym: tsym; out srsymtable: tsymtable): boolean;
function searchsym_in_class(classh: tobjectdef; contextclassh:tabstractrecorddef;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable;searchhelper:boolean):boolean;
function searchsym_in_class(classh: tobjectdef; contextclassh:tabstractrecorddef;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable;flags:tsymbol_search_flags):boolean;
function searchsym_in_record(recordh:tabstractrecorddef;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean;
function searchsym_in_class_by_msgint(classh:tobjectdef;msgid:longint;out srdef : tdef;out srsym:tsym;out srsymtable:TSymtable):boolean;
function searchsym_in_class_by_msgstr(classh:tobjectdef;const s:string;out srsym:tsym;out srsymtable:TSymtable):boolean;
{ searches symbols inside of a helper's implementation }
function searchsym_in_helper(classh,contextclassh:tobjectdef;const s: TIDString;out srsym:tsym;out srsymtable:TSymtable;aHasInherited:boolean):boolean;
function searchsym_in_helper(classh,contextclassh:tobjectdef;const s: TIDString;out srsym:tsym;out srsymtable:TSymtable;flags:tsymbol_search_flags):boolean;
function search_system_type(const s: TIDString): ttypesym;
function try_search_system_type(const s: TIDString): ttypesym;
function search_system_proc(const s: TIDString): tprocdef;
@ -2313,10 +2323,17 @@ implementation
function searchsym(const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean;
begin
result:=searchsym_maybe_with_symoption(s,srsym,srsymtable,false,sp_none);
result:=searchsym_maybe_with_symoption(s,srsym,srsymtable,[],sp_none);
end;
function searchsym_maybe_with_symoption(const s : TIDString;out srsym:tsym;out srsymtable:TSymtable;searchoption:boolean;option:tsymoption):boolean;
function searchsym_with_flags(const s : TIDString;out srsym:tsym;out srsymtable:TSymtable;flags:tsymbol_search_flags):boolean;
begin
result:=searchsym_maybe_with_symoption(s,srsym,srsymtable,flags,sp_none);
end;
function searchsym_maybe_with_symoption(const s : TIDString;out srsym:tsym;out srsymtable:TSymtable;flags:tsymbol_search_flags;option:tsymoption):boolean;
var
hashedid : THashedIDString;
contextstructdef : tabstractrecorddef;
@ -2331,12 +2348,12 @@ implementation
if (srsymtable.symtabletype=objectsymtable) then
begin
{ TODO : implement the search for an option in classes as well }
if searchoption then
if ssf_search_option in flags then
begin
result:=false;
exit;
end;
if searchsym_in_class(tobjectdef(srsymtable.defowner),tobjectdef(srsymtable.defowner),s,srsym,srsymtable,true) then
if searchsym_in_class(tobjectdef(srsymtable.defowner),tobjectdef(srsymtable.defowner),s,srsym,srsymtable,flags+[ssf_search_helper]) then
begin
result:=true;
exit;
@ -2360,7 +2377,7 @@ implementation
contextstructdef:=current_structdef;
if not (srsym.owner.symtabletype in [objectsymtable,recordsymtable]) or
is_visible_for_object(srsym,contextstructdef) and
(not searchoption or (option in srsym.symoptions)) then
(not (ssf_search_option in flags) or (option in srsym.symoptions)) then
begin
{ we need to know if a procedure references symbols
in the static symtable, because then it can't be
@ -2368,7 +2385,8 @@ implementation
if assigned(current_procinfo) and
(srsym.owner.symtabletype=staticsymtable) then
include(current_procinfo.flags,pi_uses_static_symtable);
addsymref(srsym);
if not (ssf_no_addsymref in flags) then
addsymref(srsym);
result:=true;
exit;
end;
@ -2383,7 +2401,7 @@ implementation
function searchsym_with_symoption(const s: TIDString;out srsym:tsym;out
srsymtable:TSymtable;option:tsymoption):boolean;
begin
result:=searchsym_maybe_with_symoption(s,srsym,srsymtable,true,option);
result:=searchsym_maybe_with_symoption(s,srsym,srsymtable,[ssf_search_option],option);
end;
function searchsym_type(const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean;
@ -2615,7 +2633,7 @@ implementation
end;
function searchsym_in_class(classh: tobjectdef;contextclassh:tabstractrecorddef;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable;searchhelper:boolean):boolean;
function searchsym_in_class(classh: tobjectdef;contextclassh:tabstractrecorddef;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable;flags:tsymbol_search_flags):boolean;
var
hashedid : THashedIDString;
orgclass : tobjectdef;
@ -2651,13 +2669,14 @@ implementation
if assigned(srsym) and
is_visible_for_object(srsym,contextclassh) then
begin
addsymref(srsym);
if not (ssf_no_addsymref in flags) then
addsymref(srsym);
result:=true;
exit;
end;
for i:=0 to classh.ImplementedInterfaces.count-1 do
begin
if searchsym_in_class(TImplementedInterface(classh.ImplementedInterfaces[i]).intfdef,contextclassh,s,srsym,srsymtable,false) then
if searchsym_in_class(TImplementedInterface(classh.ImplementedInterfaces[i]).intfdef,contextclassh,s,srsym,srsymtable,flags-[ssf_search_helper]) then
begin
result:=true;
exit;
@ -2668,7 +2687,7 @@ implementation
if is_objectpascal_helper(classh) then
begin
{ helpers have their own obscure search logic... }
result:=searchsym_in_helper(classh,tobjectdef(contextclassh),s,srsym,srsymtable,false);
result:=searchsym_in_helper(classh,tobjectdef(contextclassh),s,srsym,srsymtable,flags-[ssf_has_inherited]);
if result then
exit;
end
@ -2680,7 +2699,9 @@ implementation
begin
{ search for a class helper method first if this is an Object
Pascal class and we haven't yet found a helper symbol }
if is_class(classh) and searchhelper and not assigned(hlpsrsym) then
if is_class(classh) and
(ssf_search_helper in flags) and
not assigned(hlpsrsym) then
begin
result:=search_objectpascal_helper(classh,contextclassh,s,srsym,srsymtable);
if result then
@ -2703,7 +2724,8 @@ implementation
if assigned(srsym) and
is_visible_for_object(srsym,contextclassh) then
begin
addsymref(srsym);
if not (ssf_no_addsymref in flags) then
addsymref(srsym);
result:=true;
exit;
end;
@ -2840,7 +2862,7 @@ implementation
srsymtable:=nil;
end;
function searchsym_in_helper(classh,contextclassh:tobjectdef;const s: TIDString;out srsym:tsym;out srsymtable:TSymtable;aHasInherited:boolean):boolean;
function searchsym_in_helper(classh,contextclassh:tobjectdef;const s: TIDString;out srsym:tsym;out srsymtable:TSymtable;flags:tsymbol_search_flags):boolean;
var
hashedid : THashedIDString;
parentclassh : tobjectdef;
@ -2855,7 +2877,7 @@ implementation
3. search the symbol in the parent helpers
4. only classes: search the symbol in the parents of the extended type
}
if not aHasInherited then
if not (ssf_has_inherited in flags) then
begin
{ search in the helper itself }
srsymtable:=classh.symtable;
@ -2863,7 +2885,8 @@ implementation
if assigned(srsym) and
is_visible_for_object(srsym,contextclassh) then
begin
addsymref(srsym);
if not (ssf_no_addsymref in flags) then
addsymref(srsym);
result:=true;
exit;
end;
@ -2876,7 +2899,8 @@ implementation
if assigned(srsym) and
is_visible_for_object(srsym,contextclassh) then
begin
addsymref(srsym);
if not (ssf_no_addsymref in flags) then
addsymref(srsym);
result:=true;
exit;
end;
@ -2890,7 +2914,8 @@ implementation
if assigned(srsym) and
is_visible_for_object(srsym,contextclassh) then
begin
addsymref(srsym);
if not (ssf_no_addsymref in flags) then
addsymref(srsym);
result:=true;
exit;
end;
@ -2898,7 +2923,7 @@ implementation
end;
if is_class(classh.extendeddef) then
{ now search in the parents of the extended class (with helpers!) }
result:=searchsym_in_class(tobjectdef(classh.extendeddef).childof,contextclassh,s,srsym,srsymtable,true);
result:=searchsym_in_class(tobjectdef(classh.extendeddef).childof,contextclassh,s,srsym,srsymtable,flags+[ssf_search_helper]);
{ addsymref is already called by searchsym_in_class }
end;

11
tests/test/tgeneric96.pp Normal file
View File

@ -0,0 +1,11 @@
{ %NORUN }
program tgeneric96;
uses
ugeneric96a,
ugeneric96b;
begin
end.

21
tests/test/ugeneric96a.pp Normal file
View File

@ -0,0 +1,21 @@
unit ugeneric96a;
{$mode objfpc}
interface
uses
// difference to ugeneric96b: order of uses
ugeneric96c, // contains non-generic TTest
ugeneric96d; // contains generic TTest<>
type
TLongIntTest = specialize TTest<LongInt>;
var
lt: TLongIntTest;
t: TTest;
implementation
end.

21
tests/test/ugeneric96b.pp Normal file
View File

@ -0,0 +1,21 @@
unit ugeneric96b;
{$mode objfpc}
interface
uses
// difference to ugeneric96a: order of uses
ugeneric96d, // contains generic TTest<>
ugeneric96c; // contains non-generic TTest
type
TLongIntTest = specialize TTest<LongInt>;
var
lt: TLongIntTest;
t: TTest;
implementation
end.

14
tests/test/ugeneric96c.pp Normal file
View File

@ -0,0 +1,14 @@
unit ugeneric96c;
{$mode objfpc}
interface
type
TTest = class
end;
implementation
end.

14
tests/test/ugeneric96d.pp Normal file
View File

@ -0,0 +1,14 @@
unit ugeneric96d;
{$mode objfpc}
interface
type
generic TTest<T> = class
end;
implementation
end.