From 9d48bc0baf6b8db5908be90ffbcfb2079ede4ac4 Mon Sep 17 00:00:00 2001
From: svenbarth <pascaldragon@googlemail.com>
Date: Wed, 18 Sep 2013 14:28:46 +0000
Subject: [PATCH] Implement cross unit type overloading of generics. This fixes
the regression introduced with revision 25498.
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 -
---
.gitattributes | 5 ++
compiler/fmodule.pas | 7 ++
compiler/nutils.pas | 2 +-
compiler/pexpr.pas | 16 ++---
compiler/pgenutil.pas | 41 +++++++++++-
compiler/pinline.pas | 2 +-
compiler/ptype.pas | 59 +++++++++++++++--
compiler/scanner.pas | 2 +-
compiler/symdef.pas | 136 ++++++++++++++++++++++++++++++++------
compiler/symtable.pas | 69 +++++++++++++------
tests/test/tgeneric96.pp | 11 +++
tests/test/ugeneric96a.pp | 21 ++++++
tests/test/ugeneric96b.pp | 21 ++++++
tests/test/ugeneric96c.pp | 14 ++++
tests/test/ugeneric96d.pp | 14 ++++
15 files changed, 360 insertions(+), 60 deletions(-)
create mode 100644 tests/test/tgeneric96.pp
create mode 100644 tests/test/ugeneric96a.pp
create mode 100644 tests/test/ugeneric96b.pp
create mode 100644 tests/test/ugeneric96c.pp
create mode 100644 tests/test/ugeneric96d.pp
diff --git a/.gitattributes b/.gitattributes
index f3cdc3ecef..f90bbca35e 100644
--- a/.gitattributes
+++ b/.gitattributes
@@ -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
diff --git a/compiler/fmodule.pas b/compiler/fmodule.pas
index d4b3aaf325..f146ddfab6 100644
--- a/compiler/fmodule.pas
+++ b/compiler/fmodule.pas
@@ -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);
diff --git a/compiler/nutils.pas b/compiler/nutils.pas
index 74c01b1600..f6d9667ac1 100644
--- a/compiler/nutils.pas
+++ b/compiler/nutils.pas
@@ -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
diff --git a/compiler/pexpr.pas b/compiler/pexpr.pas
index b0fbf80aea..b56fc6f05a 100644
--- a/compiler/pexpr.pas
+++ b/compiler/pexpr.pas
@@ -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);
diff --git a/compiler/pgenutil.pas b/compiler/pgenutil.pas
index af6f34ba94..97bbb20c89 100644
--- a/compiler/pgenutil.pas
+++ b/compiler/pgenutil.pas
@@ -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 }
diff --git a/compiler/pinline.pas b/compiler/pinline.pas
index 7cf7899df3..322fc53696 100644
--- a/compiler/pinline.pas
+++ b/compiler/pinline.pas
@@ -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 }
diff --git a/compiler/ptype.pas b/compiler/ptype.pas
index 5cc93d7d7f..210faf35ee 100644
--- a/compiler/ptype.pas
+++ b/compiler/ptype.pas
@@ -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);
diff --git a/compiler/scanner.pas b/compiler/scanner.pas
index c9eb11cd20..6bdaf98d3c 100644
--- a/compiler/scanner.pas
+++ b/compiler/scanner.pas
@@ -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
diff --git a/compiler/symdef.pas b/compiler/symdef.pas
index a4a6b61c35..6cc61ab040 100644
--- a/compiler/symdef.pas
+++ b/compiler/symdef.pas
@@ -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;
diff --git a/compiler/symtable.pas b/compiler/symtable.pas
index 3f08b1c8df..cd1ba82683 100644
--- a/compiler/symtable.pas
+++ b/compiler/symtable.pas
@@ -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;
diff --git a/tests/test/tgeneric96.pp b/tests/test/tgeneric96.pp
new file mode 100644
index 0000000000..8a030c8fd7
--- /dev/null
+++ b/tests/test/tgeneric96.pp
@@ -0,0 +1,11 @@
+{ %NORUN }
+
+program tgeneric96;
+
+uses
+ ugeneric96a,
+ ugeneric96b;
+
+begin
+
+end.
diff --git a/tests/test/ugeneric96a.pp b/tests/test/ugeneric96a.pp
new file mode 100644
index 0000000000..1eb19da880
--- /dev/null
+++ b/tests/test/ugeneric96a.pp
@@ -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.
diff --git a/tests/test/ugeneric96b.pp b/tests/test/ugeneric96b.pp
new file mode 100644
index 0000000000..53826c214a
--- /dev/null
+++ b/tests/test/ugeneric96b.pp
@@ -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.
diff --git a/tests/test/ugeneric96c.pp b/tests/test/ugeneric96c.pp
new file mode 100644
index 0000000000..8daa493105
--- /dev/null
+++ b/tests/test/ugeneric96c.pp
@@ -0,0 +1,14 @@
+unit ugeneric96c;
+
+{$mode objfpc}
+
+interface
+
+type
+ TTest = class
+
+ end;
+
+implementation
+
+end.
diff --git a/tests/test/ugeneric96d.pp b/tests/test/ugeneric96d.pp
new file mode 100644
index 0000000000..650f869541
--- /dev/null
+++ b/tests/test/ugeneric96d.pp
@@ -0,0 +1,14 @@
+unit ugeneric96d;
+
+{$mode objfpc}
+
+interface
+
+type
+ generic TTest<T> = class
+
+ end;
+
+implementation
+
+end.