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

* more fixes for protected handling

Browse Source
This commit is contained in:
peter 2002-02-03 09:30:03 +00:00
parent e56fafb7d7
commit 190ead04c0
4 changed files with 149 additions and 80 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

82
compiler/ncnv.pas
View File

@ -733,7 +733,7 @@ implementation
function ttypeconvnode.resulttype_dynarray_to_openarray : tnode;
begin
{ a dynamic array is a pointer to an array, so to convert it to }
{ an open array, we have to dereference it (JM) }
@ -1533,6 +1533,27 @@ implementation
else
CGMessage(type_e_mismatch);
end
else if is_interface(right.resulttype.def) then
begin
{ left is a class }
if is_class(left.resulttype.def) then
begin
{ the operands must be related }
if not(assigned(tobjectdef(left.resulttype.def).implementedinterfaces) and
(tobjectdef(left.resulttype.def).implementedinterfaces.searchintf(right.resulttype.def)<>-1)) then
CGMessage(type_e_mismatch);
end
{ left is an interface }
else if is_interface(left.resulttype.def) then
begin
{ the operands must be related }
if (not(tobjectdef(left.resulttype.def).is_related(tobjectdef(right.resulttype.def)))) and
(not(tobjectdef(right.resulttype.def).is_related(tobjectdef(left.resulttype.def)))) then
CGMessage(type_e_mismatch);
end
else
CGMessage(type_e_mismatch);
end
else
CGMessage(type_e_mismatch);
@ -1546,11 +1567,16 @@ implementation
paras: tcallparanode;
begin
paras := ccallparanode.create(left,ccallparanode.create(right,nil));
left := nil;
right := nil;
result := ccallnode.createintern('fpc_do_is',paras);
firstpass(result);
if (right.resulttype.def.deftype=classrefdef) then
begin
paras := ccallparanode.create(left,ccallparanode.create(right,nil));
left := nil;
right := nil;
result := ccallnode.createintern('fpc_do_is',paras);
firstpass(result);
end
else
result:=nil;
end;
{ dummy pass_2, it will never be called, but we need one since }
@ -1600,6 +1626,28 @@ implementation
CGMessage(type_e_mismatch);
resulttype:=tclassrefdef(right.resulttype.def).pointertype;
end
else if is_interface(right.resulttype.def) then
begin
{ left is a class }
if is_class(left.resulttype.def) then
begin
{ the operands must be related }
if not(assigned(tobjectdef(left.resulttype.def).implementedinterfaces) and
(tobjectdef(left.resulttype.def).implementedinterfaces.searchintf(right.resulttype.def)<>-1)) then
CGMessage(type_e_mismatch);
end
{ left is an interface }
else if is_interface(left.resulttype.def) then
begin
{ the operands must be related }
if (not(tobjectdef(left.resulttype.def).is_related(tobjectdef(right.resulttype.def)))) and
(not(tobjectdef(right.resulttype.def).is_related(tobjectdef(left.resulttype.def)))) then
CGMessage(type_e_mismatch);
end
else
CGMessage(type_e_mismatch);
resulttype:=right.resulttype;
end
else
CGMessage(type_e_mismatch);
end;
@ -1611,12 +1659,17 @@ implementation
paras: tcallparanode;
begin
paras := ccallparanode.create(left,ccallparanode.create(right,nil));
left := nil;
right := nil;
result := ccallnode.createinternres('fpc_do_as',paras,
resulttype);
firstpass(result);
if (right.resulttype.def.deftype=classrefdef) then
begin
paras := ccallparanode.create(left,ccallparanode.create(right,nil));
left := nil;
right := nil;
result := ccallnode.createinternres('fpc_do_as',paras,
resulttype);
firstpass(result);
end
else
result:=nil;
end;
@ -1635,7 +1688,10 @@ begin
end.
{
$Log$
Revision 1.47 2001-12-10 14:34:04 jonas
Revision 1.48 2002-02-03 09:30:03 peter
* more fixes for protected handling
Revision 1.47 2001/12/10 14:34:04 jonas
* fixed type conversions from dynamic arrays to open arrays
Revision 1.46 2001/12/06 17:57:34 florian

89
compiler/pexpr.pas
View File

@ -424,15 +424,7 @@ implementation
Message(sym_e_no_instance_of_abstract_object);
{ search the constructor also in the symbol tables of
the parents }
sym:=nil;
while assigned(classh) do
begin
sym:=tsym(classh.symtable.search(pattern));
if assigned(sym) and
tstoredsym(sym).is_visible_for_proc(aktprocdef) then
break;
classh:=classh.childof;
end;
sym:=searchsym_in_class(classh,pattern);
consume(_ID);
do_member_read(false,sym,p2,again);
{ we need to know which procedure is called }
@ -1317,13 +1309,7 @@ implementation
begin
p1:=ctypenode.create(htype);
{ search also in inherited methods }
repeat
srsym:=tvarsym(tobjectdef(htype.def).symtable.search(pattern));
if assigned(srsym) and
tstoredsym(srsym).is_visible_for_proc(aktprocdef) then
break;
htype.def:=tobjectdef(htype.def).childof;
until not assigned(htype.def);
srsym:=searchsym_in_class(tobjectdef(htype.def),pattern);
consume(_ID);
do_member_read(false,srsym,p1,again);
end
@ -1757,44 +1743,28 @@ implementation
classrefdef:
begin
classh:=tobjectdef(tclassrefdef(p1.resulttype.def).pointertype.def);
hsym:=nil;
while assigned(classh) do
hsym:=searchsym_in_class(classh,pattern);
if hsym=nil then
begin
hsym:=tsym(classh.symtable.search(pattern));
if assigned(hsym) and
tstoredsym(hsym).is_visible_for_proc(aktprocdef) then
break;
classh:=classh.childof;
Message1(sym_e_id_no_member,pattern);
p1.destroy;
p1:=cerrornode.create;
{ try to clean up }
consume(_ID);
end
else
begin
consume(_ID);
do_member_read(getaddr,hsym,p1,again);
end;
if hsym=nil then
begin
Message1(sym_e_id_no_member,pattern);
p1.destroy;
p1:=cerrornode.create;
{ try to clean up }
consume(_ID);
end
else
begin
consume(_ID);
do_member_read(getaddr,hsym,p1,again);
end;
end;
objectdef:
begin
classh:=tobjectdef(p1.resulttype.def);
hsym:=nil;
store_static:=allow_only_static;
allow_only_static:=false;
while assigned(classh) do
begin
hsym:=tsym(classh.symtable.search(pattern));
if assigned(hsym) and
tstoredsym(hsym).is_visible_for_proc(aktprocdef) then
break;
classh:=classh.childof;
end;
classh:=tobjectdef(p1.resulttype.def);
hsym:=searchsym_in_class(classh,pattern);
allow_only_static:=store_static;
if hsym=nil then
begin
@ -1974,23 +1944,17 @@ implementation
auto_inherited:=false;
end;
classh:=procinfo^._class.childof;
while assigned(classh) do
sym:=searchsym_in_class(classh,hs);
if assigned(sym) then
begin
sym:=tsym(tobjectdef(classh).symtable.search(hs));
if assigned(sym) and
tstoredsym(sym).is_visible_for_proc(aktprocdef) then
if sym.typ=procsym then
begin
if sym.typ=procsym then
begin
htype.setdef(classh);
p1:=ctypenode.create(htype);
end;
do_member_read(false,sym,p1,again);
break;
htype.setdef(classh);
p1:=ctypenode.create(htype);
end;
classh:=classh.childof;
end;
if classh=nil then
do_member_read(false,sym,p1,again);
end
else
begin
Message1(sym_e_id_no_member,hs);
again:=false;
@ -2488,7 +2452,10 @@ implementation
end.
{
$Log$
Revision 1.56 2002-01-29 21:25:22 peter
Revision 1.57 2002-02-03 09:30:04 peter
* more fixes for protected handling
Revision 1.56 2002/01/29 21:25:22 peter
* more checks for private and protected
Revision 1.55 2002/01/24 18:25:49 peter

13
compiler/symsym.pas
View File

@ -547,7 +547,7 @@ implementation
{ 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=globalsymtable) and
(owner.defowner.owner.symtabletype in [globalsymtable,staticsymtable]) and
(owner.defowner.owner.unitid<>0) then
exit;
@ -556,7 +556,7 @@ implementation
if (sp_protected in symoptions) and
(
(
(owner.defowner.owner.symtabletype=globalsymtable) and
(owner.defowner.owner.symtabletype in [globalsymtable,staticsymtable]) and
(owner.defowner.owner.unitid<>0)
) and
not(
@ -578,7 +578,7 @@ implementation
{ 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=globalsymtable) and
(owner.defowner.owner.symtabletype in [globalsymtable,staticsymtable]) and
(owner.defowner.owner.unitid<>0) then
exit;
@ -587,7 +587,7 @@ implementation
if (sp_protected in symoptions) and
(
(
(owner.defowner.owner.symtabletype=globalsymtable) and
(owner.defowner.owner.symtabletype in [globalsymtable,staticsymtable]) and
(owner.defowner.owner.unitid<>0)
) and
not(
@ -2513,7 +2513,10 @@ implementation
end.
{
$Log$
Revision 1.30 2001-12-31 16:59:43 peter
Revision 1.31 2002-02-03 09:30:04 peter
* more fixes for protected handling
Revision 1.30 2001/12/31 16:59:43 peter
* protected/private symbols parsing fixed
Revision 1.29 2001/12/03 21:48:42 peter

45
compiler/symtable.pas
View File

@ -212,6 +212,7 @@ interface
{*** Search ***}
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 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;
@ -1754,6 +1755,45 @@ implementation
end;
function searchsym_in_class(classh:tobjectdef;const s : stringid):tsym;
var
speedvalue : cardinal;
topclassh : tobjectdef;
sym : tsym;
begin
speedvalue:=getspeedvalue(s);
{ 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 (classh.owner.symtabletype in [globalsymtable,staticsymtable]) and
(classh.owner.unitid=0) then
topclassh:=classh
else
topclassh:=nil;
sym:=nil;
while assigned(classh) do
begin
sym:=tsym(classh.symtable.speedsearch(s,speedvalue));
if assigned(sym) then
begin
if assigned(topclassh) then
begin
if tstoredsym(sym).is_visible_for_object(topclassh) then
break;
end
else
begin
if tstoredsym(sym).is_visible_for_proc(aktprocdef) then
break;
end;
end;
classh:=classh.childof;
end;
searchsym_in_class:=sym;
end;
function searchsystype(const s: stringid; var srsym: ttypesym): boolean;
var
symowner: tsymtable;
@ -2028,7 +2068,10 @@ implementation
end.
{
$Log$
Revision 1.54 2002-01-29 21:30:25 peter
Revision 1.55 2002-02-03 09:30:07 peter
* more fixes for protected handling
Revision 1.54 2002/01/29 21:30:25 peter
* allow also dup id in delphi mode in interfaces
Revision 1.53 2002/01/29 19:46:00 peter