paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-12-04 13:27:15 +01:00
Code Issues Packages Projects Releases Wiki Activity

* support DefaultHandler and anonymous inheritance fixed

Browse Source 
for message methods
This commit is contained in:
peter 2003-03-17 16:54:41 +00:00
parent 94ee30def5
commit 830ea4e876
5 changed files with 185 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
compiler/ncal.pas
View File

@ -1742,7 +1742,7 @@ type
do this ugly hack in Delphi mode as it looks more
like a bug. It's also not documented }
if (m_delphi in aktmodeswitches) and
(nf_auto_inherited in flags) and
(nf_anon_inherited in flags) and
(symtableprocentry.owner.symtabletype=objectsymtable) and
(po_overload in symtableprocentry.first_procdef.procoptions) and
(symtableprocentry.procdef_count>=2) then
@ -2395,7 +2395,11 @@ begin
end.
{
$Log$
Revision 1.129 2003-03-17 15:54:22 peter
Revision 1.130 2003-03-17 16:54:41 peter
* support DefaultHandler and anonymous inheritance fixed
for message methods
Revision 1.129 2003/03/17 15:54:22 peter
* store symoptions also for procdef
* check symoptions (private,public) when calculating possible
overload candidates

8
compiler/node.pas
View File

@ -222,7 +222,7 @@ interface
{ flags used by tcallnode }
nf_return_value_used,
nf_static_call,
nf_auto_inherited,
nf_anon_inherited,
{ flags used by tcallparanode }
nf_varargs_para, { belongs this para to varargs }
@ -976,7 +976,11 @@ implementation
end.
{
$Log$
Revision 1.49 2003-01-04 15:54:03 daniel
Revision 1.50 2003-03-17 16:54:41 peter
* support DefaultHandler and anonymous inheritance fixed
for message methods
Revision 1.49 2003/01/04 15:54:03 daniel
* Fixed mark_write for @ operator
(can happen when compiling @procvar:=nil (Delphi mode construction))

46
compiler/pexpr.pas
View File

@ -91,7 +91,7 @@ implementation
const
got_addrn : boolean = false;
auto_inherited : boolean = false;
anon_inherited : boolean = false;
@ -671,7 +671,7 @@ implementation
if not(getaddr) then
begin
para:=nil;
if auto_inherited then
if anon_inherited then
begin
hst:=symtablestack;
while assigned(hst) and (hst.symtabletype<>parasymtable) do
@ -1780,24 +1780,33 @@ implementation
consume(_INHERITED);
if assigned(procinfo._class) then
begin
classh:=procinfo._class.childof;
{ if inherited; only then we need the method with
the same name }
if token=_SEMICOLON then
begin
hs:=aktprocsym.name;
auto_inherited:=true
anon_inherited:=true;
{ For message methods we need to search using the message
number or string }
if (po_msgint in aktprocsym.first_procdef.procoptions) then
sym:=searchsym_in_class_by_msgint(classh,aktprocsym.first_procdef.messageinf.i)
else
if (po_msgstr in aktprocsym.first_procdef.procoptions) then
sym:=searchsym_in_class_by_msgstr(classh,aktprocsym.first_procdef.messageinf.str)
else
sym:=searchsym_in_class(classh,hs);
end
else
begin
hs:=pattern;
consume(_ID);
auto_inherited:=false;
anon_inherited:=false;
sym:=searchsym_in_class(classh,hs);
end;
classh:=procinfo._class.childof;
sym:=searchsym_in_class(classh,hs);
check_hints(sym);
if assigned(sym) then
begin
check_hints(sym);
if sym.typ=procsym then
begin
htype.setdef(classh);
@ -1806,15 +1815,20 @@ implementation
do_member_read(false,sym,p1,again);
{ Add flag to indicate that inherited is used }
if p1.nodetype=calln then
include(p1.flags,nf_auto_inherited);
include(p1.flags,nf_anon_inherited);
end
else
begin
if auto_inherited then
if anon_inherited then
begin
{ we didn't find a member in the parents so
we do nothing. This is compatible with delphi (PFV) }
p1:=cnothingnode.create;
{ we didn't find a member in the parents call the
DefaultHandler }
sym:=searchsym_in_class(classh,'DEFAULTHANDLER');
if not assigned(sym) or
(sym.typ<>procsym) then
internalerror(200303171);
p1:=nil;
do_proc_call(sym,sym.owner,false,again,p1);
end
else
begin
@ -1824,7 +1838,7 @@ implementation
again:=false;
end;
{ turn auto inheriting off }
auto_inherited:=false;
anon_inherited:=false;
end
else
begin
@ -2326,7 +2340,11 @@ implementation
end.
{
$Log$
Revision 1.102 2003-01-30 21:46:57 peter
Revision 1.103 2003-03-17 16:54:41 peter
* support DefaultHandler and anonymous inheritance fixed
for message methods
Revision 1.102 2003/01/30 21:46:57 peter
* self fixes for static methods (merged)
Revision 1.101 2003/01/16 22:12:22 peter

37
compiler/symdef.pas
View File

@ -546,6 +546,7 @@ interface
function is_methodpointer:boolean;override;
function is_addressonly:boolean;override;
function is_visible_for_proc(currprocdef:tprocdef):boolean;
function is_visible_for_object(currobjdef:tobjectdef):boolean;
{ debug }
{$ifdef GDB}
function stabstring : pchar;override;
@ -3672,6 +3673,36 @@ implementation
end;
function tprocdef.is_visible_for_object(currobjdef:tobjectdef):boolean;
begin
is_visible_for_object:=false;
{ private symbols are allowed when we are in the same
module as they are defined }
if (sp_private in symoptions) and
(owner.defowner.owner.symtabletype in [globalsymtable,staticsymtable]) and
(owner.defowner.owner.unitid<>0) then
exit;
{ protected symbols are vissible in the module that defines them and
also visible to related objects }
if (sp_protected in symoptions) and
(
(
(owner.defowner.owner.symtabletype in [globalsymtable,staticsymtable]) and
(owner.defowner.owner.unitid<>0)
) and
not(
assigned(currobjdef) and
currobjdef.is_related(tobjectdef(owner.defowner))
)
) then
exit;
is_visible_for_object:=true;
end;
function tprocdef.getsymtable(t:tgetsymtable):tsymtable;
begin
case t of
@ -5693,7 +5724,11 @@ implementation
end.
{
$Log$
Revision 1.130 2003-03-17 15:54:22 peter
Revision 1.131 2003-03-17 16:54:41 peter
* support DefaultHandler and anonymous inheritance fixed
for message methods
Revision 1.130 2003/03/17 15:54:22 peter
* store symoptions also for procdef
* check symoptions (private,public) when calculating possible
overload candidates

106
compiler/symtable.pas
View File

@ -221,6 +221,8 @@ interface
function searchsym(const s : stringid;var srsym:tsym;var srsymtable:tsymtable):boolean;
function searchsymonlyin(p : tsymtable;const s : stringid):tsym;
function searchsym_in_class(classh:tobjectdef;const s : stringid):tsym;
function searchsym_in_class_by_msgint(classh:tobjectdef;i:longint):tsym;
function searchsym_in_class_by_msgstr(classh:tobjectdef;const s:string):tsym;
function searchsystype(const s: stringid; var srsym: ttypesym): boolean;
function searchsysvar(const s: stringid; var srsym: tvarsym; var symowner: tsymtable): boolean;
function search_class_member(pd : tobjectdef;const s : string):tsym;
@ -2076,6 +2078,104 @@ implementation
end;
function searchsym_in_class_by_msgint(classh:tobjectdef;i:longint):tsym;
var
topclassh : tobjectdef;
def : tdef;
sym : tsym;
begin
{ when the class passed is defined in this unit we
need to use the scope of that class. This is a trick
that can be used to access protected members in other
units. At least kylix supports it this way (PFV) }
if assigned(classh) and
(classh.owner.symtabletype in [globalsymtable,staticsymtable]) and
(classh.owner.unitid=0) then
topclassh:=classh
else
topclassh:=nil;
sym:=nil;
def:=nil;
while assigned(classh) do
begin
def:=tdef(classh.symtable.defindex.first);
while assigned(def) do
begin
if (def.deftype=procdef) and
(po_msgint in tprocdef(def).procoptions) and
(tprocdef(def).messageinf.i=i) then
begin
sym:=tprocdef(def).procsym;
if assigned(topclassh) then
begin
if tprocdef(def).is_visible_for_object(topclassh) then
break;
end
else
begin
if tprocdef(def).is_visible_for_proc(aktprocdef) then
break;
end;
end;
def:=tdef(def.indexnext);
end;
if assigned(sym) then
break;
classh:=classh.childof;
end;
searchsym_in_class_by_msgint:=sym;
end;
function searchsym_in_class_by_msgstr(classh:tobjectdef;const s:string):tsym;
var
topclassh : tobjectdef;
def : tdef;
sym : tsym;
begin
{ when the class passed is defined in this unit we
need to use the scope of that class. This is a trick
that can be used to access protected members in other
units. At least kylix supports it this way (PFV) }
if assigned(classh) and
(classh.owner.symtabletype in [globalsymtable,staticsymtable]) and
(classh.owner.unitid=0) then
topclassh:=classh
else
topclassh:=nil;
sym:=nil;
def:=nil;
while assigned(classh) do
begin
def:=tdef(classh.symtable.defindex.first);
while assigned(def) do
begin
if (def.deftype=procdef) and
(po_msgstr in tprocdef(def).procoptions) and
(tprocdef(def).messageinf.str=s) then
begin
sym:=tprocdef(def).procsym;
if assigned(topclassh) then
begin
if tprocdef(def).is_visible_for_object(topclassh) then
break;
end
else
begin
if tprocdef(def).is_visible_for_proc(aktprocdef) then
break;
end;
end;
def:=tdef(def.indexnext);
end;
if assigned(sym) then
break;
classh:=classh.childof;
end;
searchsym_in_class_by_msgstr:=sym;
end;
function searchsystype(const s: stringid; var srsym: ttypesym): boolean;
var
symowner: tsymtable;
@ -2350,7 +2450,11 @@ implementation
end.
{
$Log$
Revision 1.89 2002-12-29 14:57:50 peter
Revision 1.90 2003-03-17 16:54:41 peter
* support DefaultHandler and anonymous inheritance fixed
for message methods
Revision 1.89 2002/12/29 14:57:50 peter
* unit loading changed to first register units and load them
afterwards. This is needed to support uses xxx in yyy correctly
* unit dependency check fixed