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

* symconst.pas:

Browse Source 
- remove thelpersearch again => adjustments to searchsym_in_class and calls to it
- rename sto_has_classhelper to sto_has_helper
* symbase.pas: make push and pop in tsymtablestack virtual
* symdef.pas:
- add a new class tdefawaresymtablestack which overrides push and pop of tsymtablestack and adjusts the new extendeddefs field of the current tmodule
- tobjectdef.create: sto_has_classhelper => sto_has_helper
* fmodule.pas:
- add new hash object list to tmodule (key: mangled type name) which holds object list instances that contain all helpers currently active for a given type (= key of the hash list)
- tmodule.create: the hash list owns the sublists (but those don't own the defs)
- tmodule.destroy: free the hash list
* pdecobjpas:
- rename parse_extended_class to parse_extended_type
- parsing of constructors:
# for all helper types: no class constructors allowed
# for record helpers: as long as constructors for records themselves are disabled they are for record helpers as well
- object_dec: manually add the helper to the extendeddefs if the overall owner of the current def is a static symtable (implementation section or program/library main file), because the symtable won't be popped and pushed then
* parser.pas: instantiate the new stack class
* psub.pas: backup the extendeddefs in specialize_objectdefs as well
* ptype.pas:
- generate_specialization: backup the extendeddefs as well
- record_dec: _RECORD is now consumed in read_named_type itself
- read_named_type: parse "record helper" if advanced record syntax is enabled
* symtable.pas:
- correct searchsym_in_class declaration => adjustments in this unit as well
- add the possibility to pass a context def to search_last_objectpascal_helper
- rename search_objectpascal_class_helper to search_objectpascal_helper
- rename search_class_helper to search_objc_helper
- searchsym_in_class: 
# search for helpers in every level of the tree of the class
# the contextclassh can also be a subclass of the extendeddef
- searchsym_in_record: search for helper methods as well
- searchsym_in_helper:
# search for symbols in class and record helpers is the same except for the search in the class' ancestors
# search the extendeddef directly and rely on searchsym_in_class only for the class' ancestors as we need to find the helpers there as well
- search_last_objectpascal_helper: use the extendeddefs list of current_module instead of scanning the symbol stack itself
* pexpr.pas: adjustments because of renaming of sto_has_classhelper
* pinline.pas: adjustment because of removing of thelpersearch
* nflw.pas: 
- renamed classhelper to helperdef
- adjusted search_last_objectpascal_helper call
* msg*:
- adjusted error message for constructors in records (this currently applies to record helpers as well)
- renamed parser_e_not_allowed_in_classhelper to parser_e_not_allowed_in_helper => adjustments in code
- added parser_e_no_class_constructors_in_helpers
* pdecsub.pas: adjusted renamed error message
* htypechk.pas: check for helpers in every step of the hierarchy
* nobj.pas: search_class_helper => search_objc_helper
* utils/ppudump.pas: adjust, because of renames

Note: the define "useoldsearch" will be only used for performance comparison on my (faster) Linux machine; that (and its associated code) will be removed afterwards

git-svn-id: branches/svenbarth/classhelpers@17151 -
This commit is contained in:
svenbarth 2011-03-20 11:27:27 +00:00
parent 96116a6c3a
commit f7f357f18e
19 changed files with 683 additions and 510 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
compiler/fmodule.pas
View File

@ -178,6 +178,11 @@ interface
moduleoptions: tmoduleoptions;
deprecatedmsg: pshortstring;
{ contains a list of types that are extended by helper types; the key is
the full name of the type and the data is a TFPObjectList of
tobjectdef instances (the helper defs) }
extendeddefs: TFPHashObjectList;
{create creates a new module which name is stored in 's'. LoadedFrom
points to the module calling it. It is nil for the first compiled
module. This allow inheritence of all path lists. MUST pay attention
@ -513,6 +518,7 @@ implementation
symlist:=TFPObjectList.Create(false);
wpoinfo:=nil;
checkforwarddefs:=TFPObjectList.Create(false);
extendeddefs := TFPHashObjectList.Create(true);
globalsymtable:=nil;
localsymtable:=nil;
globalmacrosymtable:=nil;
@ -602,6 +608,7 @@ implementation
linkotherframeworks.Free;
stringdispose(mainname);
FImportLibraryList.Free;
extendeddefs.Free;
stringdispose(objfilename);
stringdispose(asmfilename);
stringdispose(ppufilename);

51
compiler/htypechk.pas
View File

@ -1827,33 +1827,34 @@ implementation
else
hashedid.id:=overloaded_names[FOperator];
hasoverload:=false;
{ first search for potential symbols in the class helpers (this is
disabled in an inherited call if the method is available in the
extended class) }
if is_class(structdef) then
if search_last_objectpascal_helper(tobjectdef(structdef), helperdef) and searchhelpers then
begin
srsym:=nil;
while assigned(helperdef) do
begin
srsym:=tsym(helperdef.symtable.FindWithHash(hashedid));
if assigned(srsym) and
{ Delphi allows hiding a property by a procedure with the same name }
(srsym.typ=procsym) then
begin
hasoverload := processprocsym(tprocsym(srsym));
{ when there is no explicit overload we stop searching }
if not hasoverload then
break;
end;
helperdef:=helperdef.childof;
end;
if not hasoverload and assigned(srsym) then
exit;
end;
{ now search in the class and its parents or the record }
while assigned(structdef) do
begin
{ first search in helpers for this type }
if (is_class(structdef) or is_record(structdef))
and searchhelpers then
begin
if search_last_objectpascal_helper(structdef,nil,helperdef) then
begin
srsym:=nil;
while assigned(helperdef) do
begin
srsym:=tsym(helperdef.symtable.FindWithHash(hashedid));
if assigned(srsym) and
{ Delphi allows hiding a property by a procedure with the same name }
(srsym.typ=procsym) then
begin
hasoverload := processprocsym(tprocsym(srsym));
{ when there is no explicit overload we stop searching }
if not hasoverload then
break;
end;
helperdef:=helperdef.childof;
end;
if not hasoverload and assigned(srsym) then
exit;
end;
end;
{ now search in the type itself }
srsym:=tprocsym(structdef.symtable.FindWithHash(hashedid));
if assigned(srsym) and
{ Delphi allows hiding a property by a procedure with the same name }

19
compiler/msg/errore.msg
View File

@ -368,7 +368,7 @@ scanner_w_illegal_warn_identifier=02087_W_Illegal identifier "$1" for $WARN dire
#
# Parser
#
# 03305 is the last used one
# 03306 is the last used one
#
% \section{Parser messages}
% This section lists all parser messages. The parser takes care of the
@ -1355,22 +1355,25 @@ parser_e_forward_protocol_declaration_must_be_resolved=03298_E_Forward declarati
% where \var{MyProtocol} is declared but not defined.
parser_e_no_record_published=03299_E_Record types cannot have published sections
% Published sections can be used only inside classes.
parser_e_no_destructor_in_records=03300_E_Destructors aren't allowed in records or class helpers
% Destructor declarations aren't allowed in records or class helpers.
parser_e_no_destructor_in_records=03300_E_Destructors aren't allowed in records or helpers
% Destructor declarations aren't allowed in records or helpers.
parser_e_class_methods_only_static_in_records=03301_E_Class methods must be static in records
% Class methods declarations aren't allowed in records without static modifier.
% Records have no inheritance and therefore non static class methods have no sence for them.
parser_e_no_constructor_in_records=03302_E_Constructors aren't allowed in records
% Constructor declarations aren't allowed in records.
parser_e_no_constructor_in_records=03302_E_Constructors aren't allowed in records or record helpers
% Constructor declarations aren't allowed in records or record helpers.
parser_e_at_least_one_argument_must_be_of_type=03303_E_Either the result or at least one parameter must be of type "$1"
% It is required that either the result of the routine or at least one of its parameters be of the specified type.
% For example class operators either take an instance of the structured type in which they are defined, or they return one.
parser_e_cant_use_type_parameters_here=03304_E_Type parameters may require initialization/finalization - can't be used in variant records
% Type parameters may be specialized with types which (e.g. \var{ansistring}) need initialization/finalization
% code which is implicitly generated by the compiler.
parser_e_not_allowed_in_classhelper=03305_E_"$1" is not allowed in class helpers
% Some directives and specifiers like "virtual", "dynamic", "published" aren't
% allowed inside class helpers in mode ObjFPC (they are ignored in mode Delphi).
parser_e_not_allowed_in_helper=03305_E_"$1" is not allowed in helpers
% Some directives and specifiers like "virtual", "dynamic", "override" aren't
% allowed inside class helpers in mode ObjFPC (they are ignored in mode Delphi),
% because they have no meaning within helpers.
parser_e_no_class_constructor_in_helpers=03306_E_Class constructors aren't allowed in helpers
% Class constructor declarations aren't allowed in helpers.
% \end{description}
# Type Checking
#

7
compiler/msgidx.inc
View File

@ -393,7 +393,8 @@ const
parser_e_no_constructor_in_records=03302;
parser_e_at_least_one_argument_must_be_of_type=03303;
parser_e_cant_use_type_parameters_here=03304;
parser_e_not_allowed_in_classhelper=03305;
parser_e_not_allowed_in_helper=03305;
parser_e_no_class_constructor_in_helpers=03306;
type_e_mismatch=04000;
type_e_incompatible_types=04001;
type_e_not_equal_types=04002;
@ -887,9 +888,9 @@ const
option_info=11024;
option_help_pages=11025;
MsgTxtSize = 58973;
MsgTxtSize = 59014;
MsgIdxMax : array[1..20] of longint=(
24,88,306,103,84,54,111,22,202,63,
24,88,307,103,84,54,111,22,202,63,
49,20,1,1,1,1,1,1,1,1
);

635
compiler/msgtxt.inc
View File

File diff suppressed because it is too large Load Diff

12
compiler/nflw.pas
View File

@ -824,7 +824,7 @@ implementation
function create_for_in_loop(hloopvar, hloopbody, expr: tnode): tnode;
var
pd, movenext: tprocdef;
classhelper: tobjectdef;
helperdef: tobjectdef;
current: tpropertysym;
storefilepos: tfileposinfo;
begin
@ -866,12 +866,12 @@ implementation
{ first search using the class helper hierarchy if it's a
class }
if (expr.resultdef.typ=objectdef) and
search_last_objectpascal_helper(tobjectdef(expr.resultdef),classhelper) then
search_last_objectpascal_helper(tobjectdef(expr.resultdef),nil,helperdef) then
repeat
pd:=classhelper.search_enumerator_get;
classhelper:=classhelper.childof;
until (pd<>nil) or (classhelper=nil);
{ we didn't found a class helper, so search in the
pd:=helperdef.search_enumerator_get;
helperdef:=helperdef.childof;
until (pd<>nil) or (helperdef=nil);
{ we didn't find an enumerator in a helper, so search in the
class/record/object itself }
if pd=nil then
pd:=tabstractrecorddef(expr.resultdef).search_enumerator_get;

2
compiler/nobj.pas
View File

@ -460,7 +460,7 @@ implementation
"overriding" method }
if is_objcclass(_class) and
assigned(_class.childof) and
search_class_helper(_class.childof,pd.procsym.name,srsym,st) then
search_objc_helper(_class.childof,pd.procsym.name,srsym,st) then
begin
overridesclasshelper:=found_category_method(st);
end;

6
compiler/parser.pas
View File

@ -344,7 +344,11 @@ implementation
Message1(parser_i_compiling,filename);
{ reset symtable }
symtablestack:=TSymtablestack.create;
{$ifdef useoldsearch}
symtablestack:=tsymtablestack.create;
{$else}
symtablestack:=tdefawaresymtablestack.create;
{$endif}
macrosymtablestack:=TSymtablestack.create;
systemunit:=nil;
current_settings.defproccall:=init_settings.defproccall;

39
compiler/pdecobj.pas
View File

@ -582,7 +582,7 @@ implementation
end;
end;
procedure parse_extended_class(helpertype:thelpertype);
procedure parse_extended_type(helpertype:thelpertype);
var
hdef: tdef;
begin
@ -954,6 +954,16 @@ implementation
if is_objc_class_or_protocol(current_structdef) then
Message(parser_e_objc_no_constructor_destructor);
if is_objectpascal_helper(current_structdef) then
if is_classdef then
{ class constructors are not allowed in class helpers }
Message(parser_e_no_class_constructor_in_helpers)
else
if is_record(current_objectdef.extendeddef) then
{ as long as constructors aren't allowed in records they
aren't allowed in helpers either }
Message(parser_e_no_constructor_in_records);
{ only 1 class constructor is allowed }
if is_classdef and (oo_has_class_constructor in current_structdef.objectoptions) then
Message1(parser_e_only_one_class_constructor_allowed, current_structdef.objrealname^);
@ -1051,6 +1061,9 @@ implementation
old_current_genericdef,
old_current_specializedef: tstoreddef;
old_parse_generic: boolean;
list: TFPObjectList;
s: String;
st: TSymtable;
begin
old_current_structdef:=current_structdef;
old_current_genericdef:=current_genericdef;
@ -1170,7 +1183,7 @@ implementation
{ parse extended type for helpers }
if is_objectpascal_helper(current_structdef) then
parse_extended_class(helpertype);
parse_extended_type(helpertype);
{ parse optional GUID for interfaces }
parse_guid;
@ -1202,6 +1215,28 @@ implementation
else if is_objcclass(current_structdef) then
setobjcclassmethodoptions;
{ if this helper is defined in the implementation section of the unit
or inside the main project file, the extendeddefs list of the current
module must be updated (it will be removed when poping the symtable) }
if is_objectpascal_helper(current_structdef) then
begin
{ the topmost symtable must be a static symtable }
st:=current_structdef.owner;
while st.symtabletype in [objectsymtable,recordsymtable] do
st:=st.defowner.owner;
if st.symtabletype=staticsymtable then
begin
s:=make_mangledname('',current_objectdef.extendeddef.symtable,'');
list:=TFPObjectList(current_module.extendeddefs.Find(s));
if not assigned(list) then
begin
list:=TFPObjectList.Create(false);
current_module.extendeddefs.Add(s, list);
end;
list.add(current_structdef);
end;
end;
{ return defined objectdef }
result:=current_objectdef;

12
compiler/pdecsub.pas
View File

@ -1630,7 +1630,7 @@ begin
internalerror(200304269);
if is_objectpascal_helper(tprocdef(pd).struct) and
(m_objfpc in current_settings.modeswitches) then
Message1(parser_e_not_allowed_in_classhelper, arraytokeninfo[_ABSTRACT].str);
Message1(parser_e_not_allowed_in_helper, arraytokeninfo[_ABSTRACT].str);
if assigned(tprocdef(pd).struct) and
(oo_is_sealed in tprocdef(pd).struct.objectoptions) then
Message(parser_e_sealed_class_cannot_have_abstract_methods)
@ -1649,7 +1649,7 @@ begin
internalerror(200910170);
if is_objectpascal_helper(tprocdef(pd).struct) and
(m_objfpc in current_settings.modeswitches) then
Message1(parser_e_not_allowed_in_classhelper, arraytokeninfo[_FINAL].str);
Message1(parser_e_not_allowed_in_helper, arraytokeninfo[_FINAL].str);
if (po_virtualmethod in pd.procoptions) then
include(pd.procoptions,po_finalmethod)
else
@ -1697,7 +1697,7 @@ begin
Message(parser_e_constructor_cannot_be_not_virtual);
if is_objectpascal_helper(tprocdef(pd).struct) and
(m_objfpc in current_settings.modeswitches) then
Message1(parser_e_not_allowed_in_classhelper, arraytokeninfo[_VIRTUAL].str);
Message1(parser_e_not_allowed_in_helper, arraytokeninfo[_VIRTUAL].str);
{$ifdef WITHDMT}
if is_object(tprocdef(pd).struct) and
(token<>_SEMICOLON) then
@ -1750,7 +1750,7 @@ begin
if is_objectpascal_helper(tprocdef(pd).struct) then
begin
if m_objfpc in current_settings.modeswitches then
Message1(parser_e_not_allowed_in_classhelper, arraytokeninfo[_OVERRIDE].str)
Message1(parser_e_not_allowed_in_helper, arraytokeninfo[_OVERRIDE].str)
end
else if not(is_class_or_interface_or_objc(tprocdef(pd).struct)) then
Message(parser_e_no_object_override)
@ -1779,7 +1779,7 @@ begin
if is_objectpascal_helper(tprocdef(pd).struct) then
begin
if m_objfpc in current_settings.modeswitches then
Message1(parser_e_not_allowed_in_classhelper, arraytokeninfo[_MESSAGE].str);
Message1(parser_e_not_allowed_in_helper, arraytokeninfo[_MESSAGE].str);
end
else
if not is_class(tprocdef(pd).struct) and
@ -1841,7 +1841,7 @@ begin
if is_objectpascal_helper(tprocdef(pd).struct) then
begin
if m_objfpc in current_settings.modeswitches then
Message1(parser_e_not_allowed_in_classhelper, arraytokeninfo[_REINTRODUCE].str);
Message1(parser_e_not_allowed_in_helper, arraytokeninfo[_REINTRODUCE].str);
end
else
if not(is_class_or_interface_or_object(tprocdef(pd).struct)) and

14
compiler/pexpr.pas
View File

@ -1035,7 +1035,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,hs_searchfirst)
searchsym_in_class(tobjectdef(sym.owner.defowner),tobjectdef(sym.owner.defowner),static_name,sym,srsymtable,true)
else
searchsym_in_record(trecorddef(sym.owner.defowner),static_name,sym,srsymtable);
if assigned(sym) then
@ -1512,7 +1512,7 @@ implementation
begin
p1:=ctypenode.create(hdef);
{ search also in inherited methods }
searchsym_in_class(tobjectdef(hdef),tobjectdef(current_structdef),pattern,srsym,srsymtable,hs_searchfirst);
searchsym_in_class(tobjectdef(hdef),tobjectdef(current_structdef),pattern,srsym,srsymtable,true);
if assigned(srsym) then
check_hints(srsym,srsym.symoptions,srsym.deprecatedmsg);
consume(_ID);
@ -2147,7 +2147,7 @@ implementation
if token=_ID then
begin
structh:=tobjectdef(tclassrefdef(p1.resultdef).pointeddef);
searchsym_in_class(tobjectdef(structh),tobjectdef(structh),pattern,srsym,srsymtable,hs_searchfirst);
searchsym_in_class(tobjectdef(structh),tobjectdef(structh),pattern,srsym,srsymtable,true);
if assigned(srsym) then
begin
check_hints(srsym,srsym.symoptions,srsym.deprecatedmsg);
@ -2171,7 +2171,7 @@ implementation
if token=_ID then
begin
structh:=tobjectdef(p1.resultdef);
searchsym_in_class(tobjectdef(structh),tobjectdef(structh),pattern,srsym,srsymtable,hs_searchfirst);
searchsym_in_class(tobjectdef(structh),tobjectdef(structh),pattern,srsym,srsymtable,true);
if assigned(srsym) then
begin
check_hints(srsym,srsym.symoptions,srsym.deprecatedmsg);
@ -2398,7 +2398,7 @@ implementation
if is_objectpascal_helper(current_structdef) then
searchsym_in_helper(tobjectdef(current_structdef),tobjectdef(current_structdef),hs,srsym,srsymtable,true)
else
searchsym_in_class(hclassdef,tobjectdef(current_structdef),hs,srsym,srsymtable,hs_nosearch);
searchsym_in_class(hclassdef,tobjectdef(current_structdef),hs,srsym,srsymtable,true);
end
else
begin
@ -2410,7 +2410,7 @@ implementation
if is_objectpascal_helper(current_structdef) then
searchsym_in_helper(tobjectdef(current_structdef),tobjectdef(current_structdef),hs,srsym,srsymtable,true)
else
searchsym_in_class(hclassdef,tobjectdef(current_structdef),hs,srsym,srsymtable,hs_nosearch);
searchsym_in_class(hclassdef,tobjectdef(current_structdef),hs,srsym,srsymtable,true);
end;
if assigned(srsym) then
begin
@ -2444,7 +2444,7 @@ implementation
if (po_msgint in pd.procoptions) or
(po_msgstr in pd.procoptions) then
begin
searchsym_in_class(hclassdef,hclassdef,'DEFAULTHANDLER',srsym,srsymtable,hs_searchfirst);
searchsym_in_class(hclassdef,hclassdef,'DEFAULTHANDLER',srsym,srsymtable,true);
if not assigned(srsym) or
(srsym.typ<>procsym) then
internalerror(200303171);

2
compiler/pinline.pas
View File

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

13
compiler/psub.pas
View File

@ -1985,6 +1985,9 @@ implementation
hp : tdef;
oldcurrent_filepos : tfileposinfo;
oldsymtablestack : tsymtablestack;
{$ifndef useoldsearch}
oldextendeddefs : TFPHashObjectList;
{$endif}
pu : tused_unit;
hmodule : tmodule;
specobj : tabstractrecorddef;
@ -1999,7 +2002,13 @@ implementation
{ Setup symtablestack a definition time }
specobj:=tabstractrecorddef(ttypesym(p).typedef);
oldsymtablestack:=symtablestack;
{$ifdef useoldsearch}
symtablestack:=tsymtablestack.create;
{$else}
oldextendeddefs:=current_module.extendeddefs;
current_module.extendeddefs:=TFPHashObjectList.create(true);
symtablestack:=tdefawaresymtablestack.create;
{$endif}
if not assigned(specobj.genericdef) then
internalerror(200705151);
hmodule:=find_module_from_symtable(specobj.genericdef.owner);
@ -2046,6 +2055,10 @@ implementation
end;
{ Restore symtablestack }
{$ifndef useoldsearch}
current_module.extendeddefs.free;
current_module.extendeddefs:=oldextendeddefs;
{$endif}
symtablestack.free;
symtablestack:=oldsymtablestack;
end;

24
compiler/ptype.pas
View File

@ -159,6 +159,9 @@ implementation
generictype : ttypesym;
generictypelist : TFPObjectList;
oldsymtablestack : tsymtablestack;
{$ifndef useoldsearch}
oldextendeddefs : TFPHashObjectList;
{$endif}
hmodule : tmodule;
pu : tused_unit;
uspecializename,
@ -295,7 +298,13 @@ implementation
to get types right, however this is not perfect, we should probably record
the resolved symbols }
oldsymtablestack:=symtablestack;
{$ifdef useoldsearch}
symtablestack:=tsymtablestack.create;
{$else}
oldextendeddefs:=current_module.extendeddefs;
current_module.extendeddefs:=TFPHashObjectList.create(true);
symtablestack:=tdefawaresymtablestack.create;
{$endif}
if not assigned(genericdef) then
internalerror(200705151);
hmodule:=find_module_from_symtable(genericdef.owner);
@ -362,6 +371,10 @@ implementation
end;
{ Restore symtablestack }
{$ifndef useoldsearch}
current_module.extendeddefs.free;
current_module.extendeddefs:=oldextendeddefs;
{$endif}
symtablestack.free;
symtablestack:=oldsymtablestack;
end
@ -889,8 +902,6 @@ implementation
result:=current_structdef;
{ insert in symtablestack }
symtablestack.push(recst);
{ parse record }
consume(_RECORD);
{ usage of specialized type inside its generic template }
if assigned(genericdef) then
@ -1472,7 +1483,14 @@ implementation
end;
_RECORD:
begin
def:=record_dec(name,genericdef,genericlist);
consume(token);
if (idtoken=_HELPER) and (m_advanced_records in current_settings.modeswitches) then
begin
consume(_HELPER);
def:=object_dec(odt_helper,name,genericdef,genericlist,nil,ht_record);
end
else
def:=record_dec(name,genericdef,genericlist);
end;
_PACKED,
_BITPACKED:

4
compiler/symbase.pas
View File

@ -130,8 +130,8 @@ interface
constructor create;
destructor destroy;override;
procedure clear;
procedure push(st:TSymtable);
procedure pop(st:TSymtable);
procedure push(st:TSymtable); virtual;
procedure pop(st:TSymtable); virtual;
function top:TSymtable;
end;

9
compiler/symconst.pas
View File

@ -338,12 +338,6 @@ type
ht_record
);
{ defines when helper methods should be searched }
thelpersearch=(hs_nosearch, { helper methods are not searched at all }
hs_searchfirst, { search before the actual extended types symbols }
hs_searchlast { search only if no symbol is found in the extended type }
);
{ Variations in interfaces implementation }
{ Beware, this data is duplicated in the compiler and rtl. }
{ Do not change the order of the fields. }
@ -470,8 +464,7 @@ type
{ options for symtables }
tsymtableoption = (
sto_has_classhelper { contains at least one class
helper symbol }
sto_has_helper { contains at least one helper symbol }
);
tsymtableoptions = set of tsymtableoption;

101
compiler/symdef.pas
View File

@ -648,6 +648,15 @@ interface
function is_publishable : boolean;override;
end;
tdefawaresymtablestack = class(TSymtablestack)
private
procedure addhelpers(st: TSymtable);
procedure removehelpers(st: TSymtable);
public
procedure push(st: 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 }
@ -923,6 +932,96 @@ implementation
result := '_' + result;
end;
{****************************************************************************
TDEFAWARESYMTABLESTACK
(symtablestack descendant that does some special actions on
the pushed/popped symtables)
****************************************************************************}
procedure tdefawaresymtablestack.addhelpers(st: TSymtable);
var
i: integer;
s: string;
list: TFPObjectList;
def: tdef;
begin
{ search the symtable from first to last; the helper to use will be the
last one in the list }
for i:=0 to st.symlist.count-1 do
begin
if not (st.symlist[i] is ttypesym) then
continue;
def:=ttypesym(st.SymList[i]).typedef;
if is_objectpascal_helper(def) then
begin
s:=make_mangledname('',tobjectdef(def).extendeddef.symtable,'');
list:=TFPObjectList(current_module.extendeddefs.Find(s));
if not assigned(list) then
begin
list:=TFPObjectList.Create(false);
current_module.extendeddefs.Add(s,list);
end;
list.Add(def);
end
else
{ add nested helpers as well }
if def.typ in [recorddef,objectdef] then
addhelpers(tabstractrecorddef(def).symtable);
end;
end;
procedure tdefawaresymtablestack.removehelpers(st: TSymtable);
var
i, j: integer;
tmpst: TSymtable;
list: TFPObjectList;
begin
for i:=current_module.extendeddefs.count-1 downto 0 do
begin
list:=TFPObjectList(current_module.extendeddefs[i]);
for j:=list.count-1 downto 0 do
begin
if not (list[j] is tobjectdef) then
Internalerror(2011031501);
tmpst:=tobjectdef(list[j]).owner;
repeat
if tmpst=st then
begin
list.delete(j);
break;
end
else
begin
if assigned(tmpst.defowner) then
tmpst:=tmpst.defowner.owner
else
tmpst:=nil;
end;
until not assigned(tmpst) or (tmpst.symtabletype in [globalsymtable,staticsymtable]);
end;
if list.count=0 then
current_module.extendeddefs.delete(i);
end;
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);
inherited push(st);
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);
end;
{****************************************************************************
TDEF (base class for definitions)
@ -4160,7 +4259,7 @@ implementation
objecttype:=ot;
childof:=nil;
if objecttype=odt_helper then
owner.includeoption(sto_has_classhelper);
owner.includeoption(sto_has_helper);
symtable:=tObjectSymtable.create(self,n,current_settings.packrecords);
{ create space for vmt !! }
vmtentries:=TFPList.Create;

229
compiler/symtable.pas
View File

@ -220,19 +220,23 @@ interface
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,contextclassh:tobjectdef;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable;searchhelper:thelpersearch):boolean;
function searchsym_in_class(classh,contextclassh:tobjectdef;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable;searchhelper:boolean):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 search_system_type(const s: TIDString): ttypesym;
function search_named_unit_globaltype(const unitname, typename: TIDString; throwerror: boolean): ttypesym;
function search_struct_member(pd : tabstractrecorddef;const s : string):tsym;
function search_assignment_operator(from_def,to_def:Tdef;explicit:boolean):Tprocdef;
function search_enumerator_operator(from_def,to_def:Tdef):Tprocdef;
function search_last_objectpascal_helper(pd : tabstractrecorddef;out odef : tobjectdef):boolean;
function search_objectpascal_class_helper(pd,contextclassh : tobjectdef;const s : string; out srsym: tsym; out srsymtable: tsymtable):boolean;
function search_class_helper(pd : tobjectdef;const s : string; out srsym: tsym; out srsymtable: tsymtable):boolean;
{ searches for the helper definition that's currently active for pd }
function search_last_objectpascal_helper(pd,contextclassh : tabstractrecorddef;out odef : tobjectdef):boolean;
{ searches whether the symbol s is available in the currently active }
{ helper for pd }
function search_objectpascal_helper(pd,contextclassh : tabstractrecorddef;const s : string; out srsym: tsym; out srsymtable: tsymtable):boolean;
function search_objc_helper(pd : tobjectdef;const s : string; out srsym: tsym; out srsymtable: tsymtable):boolean;
function search_objc_method(const s : string; out srsym: tsym; out srsymtable: tsymtable):boolean;
{Looks for macro s (must be given in upper case) in the macrosymbolstack, }
{and returns it if found. Returns nil otherwise.}
@ -1919,7 +1923,7 @@ implementation
srsymtable:=stackitem^.symtable;
if (srsymtable.symtabletype=objectsymtable) then
begin
if searchsym_in_class(tobjectdef(srsymtable.defowner),tobjectdef(srsymtable.defowner),s,srsym,srsymtable,hs_searchfirst) then
if searchsym_in_class(tobjectdef(srsymtable.defowner),tobjectdef(srsymtable.defowner),s,srsym,srsymtable,true) then
begin
result:=true;
exit;
@ -2149,29 +2153,12 @@ implementation
end;
function searchsym_in_class(classh,contextclassh:tobjectdef;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable;searchhelper:thelpersearch):boolean;
function searchsym_in_class(classh,contextclassh:tobjectdef;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable;searchhelper:boolean):boolean;
var
hashedid : THashedIDString;
exdef : tabstractrecorddef;
orgclass : tobjectdef;
i : longint;
begin
{ search for a class helper method first if this is an Object Pascal
class }
if is_class(classh) and (searchhelper = hs_searchfirst) then
begin
result:=search_objectpascal_class_helper(classh,contextclassh,s,srsym,srsymtable);
if result then
begin
{ if the procsym is overloaded we need to use the "original"
symbol; the helper symbol will be find when searching for
overloads }
if (srsym.typ<>procsym) or
not (sp_has_overloaded in tprocsym(srsym).symoptions) then
Exit;
end;
end;
orgclass:=classh;
{ in case this is a formal objcclass, first find the real definition }
if assigned(classh) then
@ -2182,7 +2169,9 @@ implementation
or be a parent of contextclassh. E.g. for inherited searches the classh is the
parent or a class helper. }
if not (contextclassh.is_related(classh) or
(contextclassh.extendeddef=classh)) then
(assigned(contextclassh.extendeddef) and
(contextclassh.extendeddef.typ=objectdef) and
contextclassh.extendeddef.is_related(classh))) then
internalerror(200811161);
end;
result:=false;
@ -2202,7 +2191,7 @@ implementation
end;
for i:=0 to classh.ImplementedInterfaces.count-1 do
begin
if searchsym_in_class(TImplementedInterface(classh.ImplementedInterfaces[i]).intfdef,contextclassh,s,srsym,srsymtable,hs_nosearch) then
if searchsym_in_class(TImplementedInterface(classh.ImplementedInterfaces[i]).intfdef,contextclassh,s,srsym,srsymtable,false) then
begin
result:=true;
exit;
@ -2221,6 +2210,19 @@ implementation
begin
while assigned(classh) do
begin
{ search for a class helper method first if this is an Object
Pascal class }
if is_class(classh) and searchhelper then
begin
result:=search_objectpascal_helper(classh,contextclassh,s,srsym,srsymtable);
if result then
{ if the procsym is overloaded we need to use the
"original" symbol; the helper symbol will be found when
searching for overloads }
if (srsym.typ<>procsym) or
not (sp_has_overloaded in tprocsym(srsym).symoptions) then
exit;
end;
srsymtable:=classh.symtable;
srsym:=tsym(srsymtable.FindWithHash(hashedid));
if assigned(srsym) and
@ -2234,11 +2236,7 @@ implementation
end;
end;
if is_objcclass(orgclass) then
result:=search_class_helper(orgclass,s,srsym,srsymtable)
else
{ this is currently not used, so maybe this can be removed again... }
if is_class(orgclass) and (searchhelper = hs_searchlast) then
result:=search_objectpascal_class_helper(orgclass,contextclassh,s,srsym,srsymtable)
result:=search_objc_helper(orgclass,s,srsym,srsymtable)
else
begin
srsym:=nil;
@ -2251,6 +2249,15 @@ implementation
hashedid : THashedIDString;
begin
hashedid.id:=s;
{ search for a record helper method first }
result:=search_objectpascal_helper(recordh,recordh,s,srsym,srsymtable);
if result then
{ if the procsym is overloaded we need to use the
"original" symbol; the helper symbol will be found when
searching for overloads }
if (srsym.typ<>procsym) or
not (sp_has_overloaded in tprocsym(srsym).symoptions) then
exit;
srsymtable:=recordh.symtable;
srsym:=tsym(srsymtable.FindWithHash(hashedid));
if assigned(srsym) and is_visible_for_object(srsym,recordh) then
@ -2339,88 +2346,59 @@ implementation
function searchsym_in_helper(classh,contextclassh:tobjectdef;const s: TIDString;out srsym:tsym;out srsymtable:TSymtable;aHasInherited:boolean):boolean;
var
hashedid : THashedIDString;
tmpsrsym : tsym;
tmpsrsymtable : tsymtable;
found : boolean;
parentclassh : tobjectdef;
begin
if not is_objectpascal_helper(classh) then
Internalerror(2011030101);
hashedid.id:=s;
if is_class(classh.extendeddef) then
{ in a helper things are a bit more complex:
1. search the symbol in the helper (if not "inherited")
2. search the symbol in the extended type
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
begin
{ in a class helper things are a bit more complex:
1. search the symbol in the helper (if not "inherited")
2. search the symbol in the extended type
3. search the symbol in the parent helpers
4. search the symbol in the parents of the extended type
Thus we search in the hierarchy of the extended type first and
check whether the returned symtable (if any) belongs to the
extended type or one of its parents. If the latter we first
check whether one of the helper parents contains a suitable
symbol
}
if not aHasInherited then
{ search in the helper itself }
srsymtable:=classh.symtable;
srsym:=tsym(srsymtable.FindWithHash(hashedid));
if assigned(srsym) and
is_visible_for_object(srsym,contextclassh) then
begin
{ search in the helper itself }
srsymtable:=classh.symtable;
srsym:=tsym(srsymtable.FindWithHash(hashedid));
if assigned(srsym) and
is_visible_for_object(srsym,contextclassh) then
begin
addsymref(srsym);
result:=true;
exit;
end;
addsymref(srsym);
result:=true;
exit;
end;
{ search in the hierarchy of the extended class }
found:=searchsym_in_class(tobjectdef(classh.extendeddef),contextclassh,s,tmpsrsym,tmpsrsymtable,hs_nosearch);
if not found then
begin
if assigned(classh.childof) then
begin
{ the symbol isn't in the extended type's hierarchy,
so search in the parents of the helper }
result:=searchsym_in_class(classh.childof,contextclassh,s,srsym,srsymtable,hs_nosearch);
if result and is_visible_for_object(srsym,contextclassh) then
addsymref(srsym);
end;
end
else
begin
if (tmpsrsymtable.defowner=classh.extendeddef) and
is_visible_for_object(tmpsrsym,contextclassh) then
begin
{ the symbol was found in the extended type }
result:=true;
srsym:=tmpsrsym;
srsymtable:=tmpsrsymtable;
exit;
end
else
begin
result:=false;
{ search in the helper's parents first }
if assigned(classh.childof) then
result:=searchsym_in_helper(classh.childof,contextclassh,s,srsym,srsymtable,false);
if not result then
begin
{ we use the symbol found in one of the extended
type's ancestors }
result:=true;
srsym:=tmpsrsym;
srsymtable:=tmpsrsymtable;
end;
if assigned(srsym) and is_visible_for_object(srsym,contextclassh) then
addsymref(srsym);
end;
end;
end
else if is_record(classh.extendeddef) and
searchsym_in_record(classh.extendeddef, s, srsym, srsymtable) then
end;
{ now search in the extended type itself }
srsymtable:=classh.extendeddef.symtable;
srsym:=tsym(srsymtable.FindWithHash(hashedid));
if assigned(srsym) and
is_visible_for_object(srsym,contextclassh) then
begin
addsymref(srsym);
result:=true;
exit;
end;
{ now search in the parent helpers }
parentclassh:=classh.childof;
while assigned(parentclassh) do
begin
srsymtable:=parentclassh.symtable;
srsym:=tsym(srsymtable.FindWithHash(hashedid));
if assigned(srsym) and
is_visible_for_object(srsym,contextclassh) then
begin
addsymref(srsym);
result:=true;
exit;
end;
parentclassh:=parentclassh.childof;
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);
{ addsymref is already called by searchsym_in_class }
end;
function search_specific_assignment_operator(assignment_type:ttoken;from_def,to_def:Tdef):Tprocdef;
@ -2555,12 +2533,19 @@ implementation
end;
end;
function search_last_objectpascal_helper(pd : tabstractrecorddef;out odef : tobjectdef):boolean;
function search_last_objectpascal_helper(pd,contextclassh : tabstractrecorddef;out odef : tobjectdef):boolean;
var
{$ifdef useoldsearch}
stackitem : psymtablestackitem;
i : integer;
srsymtable : tsymtable;
{$else}
s: string;
list: TFPObjectList;
i: integer;
{$endif}
begin
{$ifdef useoldsearch}
result:=false;
stackitem:=symtablestack.stack;
while assigned(stackitem) do
@ -2568,7 +2553,7 @@ implementation
srsymtable:=stackitem^.symtable;
{ only check symtables that contain a class helper }
if (srsymtable.symtabletype in [staticsymtable,globalsymtable]) and
(sto_has_classhelper in srsymtable.tableoptions) then
(sto_has_helper in srsymtable.tableoptions) then
begin
{ we need to search from last to first }
for i:=srsymtable.symlist.count-1 downto 0 do
@ -2588,9 +2573,27 @@ implementation
end;
stackitem:=stackitem^.next;
end;
{$else}
result:=false;
s:=make_mangledname('',pd.symtable,'');
list:=TFPObjectList(current_module.extendeddefs.Find(s));
if assigned(list) and (list.count>0) then
begin
i:=list.count-1;
repeat
odef:=tobjectdef(list[list.count-1]);
result:=(odef.owner.symtabletype in [staticsymtable,globalsymtable]) or
is_visible_for_object(tobjectdef(list[i]).typesym,contextclassh);
dec(i);
until result or (i<0);
if not result then
{ just to be sure that noone uses odef }
odef:=nil;
end;
{$endif}
end;
function search_objectpascal_class_helper(pd,contextclassh : tobjectdef;const s: string; out srsym: tsym; out srsymtable: tsymtable):boolean;
function search_objectpascal_helper(pd,contextclassh : tabstractrecorddef;const s: string; out srsym: tsym; out srsymtable: tsymtable):boolean;
var
hashedid : THashedIDString;
@ -2602,7 +2605,7 @@ implementation
{ if there is no class helper for the class then there is no need to
search further }
if not search_last_objectpascal_helper(pd,classh) then
if not search_last_objectpascal_helper(pd,contextclassh,classh) then
exit;
hashedid.id:=s;
@ -2629,13 +2632,7 @@ implementation
if assigned(current_procinfo) and
(srsym.owner.symtabletype=staticsymtable) then
include(current_procinfo.flags,pi_uses_static_symtable);
{ no need to keep looking. There might be other
categories that extend this, a parent or child
class with a method with the same name (either
overriding this one, or overridden by this one),
but that doesn't matter as far as the basic
procsym is concerned.
}
{ the first found method wins }
srsym:=tprocdef(tprocsym(srsym).procdeflist[i]).procsym;
srsymtable:=srsym.owner;
addsymref(srsym);
@ -2644,7 +2641,7 @@ implementation
end;
end;
{ try the class helper parent if available }
{ try the helper parent if available }
classh:=classh.childof;
until classh=nil;
@ -2652,7 +2649,7 @@ implementation
srsymtable:=nil;
end;
function search_class_helper(pd : tobjectdef;const s : string; out srsym: tsym; out srsymtable: tsymtable):boolean;
function search_objc_helper(pd : tobjectdef;const s : string; out srsym: tsym; out srsymtable: tsymtable):boolean;
var
hashedid : THashedIDString;
stackitem : psymtablestackitem;
@ -2796,7 +2793,7 @@ implementation
{ not found, now look for class helpers }
if is_objcclass(pd) then
search_class_helper(tobjectdef(orgpd),s,result,srsymtable)
search_objc_helper(tobjectdef(orgpd),s,result,srsymtable)
else
result:=nil;
end;
@ -2864,7 +2861,7 @@ implementation
begin
_defaultprop:=nil;
{ first search in helper's hierarchy }
if search_last_objectpascal_helper(pd, helperpd) then
if search_last_objectpascal_helper(pd,nil,helperpd) then
while assigned(helperpd) do
begin
helperpd.symtable.SymList.ForEachCall(@tstoredsymtable(helperpd.symtable).testfordefaultproperty,@_defaultprop);

7
compiler/utils/ppudump.pp
View File

@ -429,8 +429,7 @@ end;
procedure readsymtableoptions(const s: string);
type
tsymtableoption = (
sto_has_classhelper { contains at least one class
helper symbol }
sto_has_helper { contains at least one helper symbol }
);
tsymtableoptions = set of tsymtableoption;
tsymtblopt=record
@ -440,7 +439,7 @@ type
const
symtblopts=1;
symtblopt : array[1..symtblopts] of tsymtblopt=(
(mask:sto_has_classhelper; str:'Has class helper')
(mask:sto_has_helper; str:'Has helper')
);
var
options : tsymtableoptions;
@ -1947,7 +1946,7 @@ type
odt_dispinterface,
odt_objcclass,
odt_objcprotocol,
odt_classhelper
odt_helper
);
tvarianttype = (
vt_normalvariant,vt_olevariant