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

* pass context class to searchsym_in_class to fix the visibility

Browse Source 
of protected members called from a named class in a child class
    that also has the visibility for those protected members

git-svn-id: trunk@4384 -
This commit is contained in:
peter 2006-08-07 19:10:11 +00:00
parent 6fd4c50f0a
commit 22657a363b
6 changed files with 74 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitattributes vendored
View File

@ -6454,6 +6454,7 @@ tests/webtbf/tw4911.pp svneol=native#text/plain
tests/webtbf/tw4913.pp -text
tests/webtbf/tw6686.pp svneol=native#text/plain
tests/webtbf/tw6796.pp svneol=native#text/plain
tests/webtbf/tw6922.pp svneol=native#text/plain
tests/webtbf/tw6970.pp svneol=native#text/plain
tests/webtbf/uw0744.pp svneol=native#text/plain
tests/webtbf/uw0840a.pp svneol=native#text/plain
@ -6463,6 +6464,7 @@ tests/webtbf/uw2414.pp svneol=native#text/plain
tests/webtbf/uw3450.pp svneol=native#text/plain
tests/webtbf/uw3969.pp svneol=native#text/plain
tests/webtbf/uw4103.pp svneol=native#text/plain
tests/webtbf/uw6922.pp svneol=native#text/plain
tests/webtbs/tu2002.pp svneol=native#text/plain
tests/webtbs/tw0555.pp svneol=native#text/plain
tests/webtbs/tw0630.pp svneol=native#text/plain

12
compiler/pexpr.pas
View File

@ -1388,7 +1388,7 @@ implementation
begin
p1:=ctypenode.create(htype);
{ search also in inherited methods }
searchsym_in_class(tobjectdef(htype.def),pattern,srsym,srsymtable);
searchsym_in_class(tobjectdef(htype.def),current_procinfo.procdef._class,pattern,srsym,srsymtable);
if assigned(srsym) then
check_hints(srsym,srsym.symoptions);
consume(_ID);
@ -1919,7 +1919,7 @@ implementation
if token=_ID then
begin
classh:=tobjectdef(tclassrefdef(p1.resulttype.def).pointertype.def);
searchsym_in_class(classh,pattern,srsym,srsymtable);
searchsym_in_class(classh,classh,pattern,srsym,srsymtable);
if assigned(srsym) then
begin
check_hints(srsym,srsym.symoptions);
@ -1945,7 +1945,7 @@ implementation
store_static:=allow_only_static;
allow_only_static:=false;
classh:=tobjectdef(p1.resulttype.def);
searchsym_in_class(classh,pattern,srsym,srsymtable);
searchsym_in_class(classh,classh,pattern,srsym,srsymtable);
allow_only_static:=store_static;
if assigned(srsym) then
begin
@ -2107,7 +2107,7 @@ implementation
if (po_msgstr in pd.procoptions) then
searchsym_in_class_by_msgstr(classh,pd.messageinf.str,srsym,srsymtable)
else
searchsym_in_class(classh,hs,srsym,srsymtable);
searchsym_in_class(classh,current_procinfo.procdef._class,hs,srsym,srsymtable);
end
else
begin
@ -2115,7 +2115,7 @@ implementation
hsorg:=orgpattern;
consume(_ID);
anon_inherited:=false;
searchsym_in_class(classh,hs,srsym,srsymtable);
searchsym_in_class(classh,current_procinfo.procdef._class,hs,srsym,srsymtable);
end;
if assigned(srsym) then
begin
@ -2148,7 +2148,7 @@ implementation
if (po_msgint in pd.procoptions) or
(po_msgstr in pd.procoptions) then
begin
searchsym_in_class(classh,'DEFAULTHANDLER',srsym,srsymtable);
searchsym_in_class(classh,classh,'DEFAULTHANDLER',srsym,srsymtable);
if not assigned(srsym) or
(srsym.typ<>procsym) then
internalerror(200303171);

2
compiler/pinline.pas
View File

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

25
compiler/symtable.pas
View File

@ -211,7 +211,7 @@ interface
function searchsym(const s : stringid;out srsym:tsym;out srsymtable:tsymtable):boolean;
function searchsym_type(const s : stringid;out srsym:tsym;out srsymtable:tsymtable):boolean;
function searchsym_in_module(pm:pointer;const s : stringid;out srsym:tsym;out srsymtable:tsymtable):boolean;
function searchsym_in_class(classh:tobjectdef;const s : stringid;out srsym:tsym;out srsymtable:tsymtable):boolean;
function searchsym_in_class(classh,contextclassh:tobjectdef;const s : stringid;out srsym:tsym;out srsymtable:tsymtable):boolean;
function searchsym_in_class_by_msgint(classh:tobjectdef;i:longint;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;
function search_system_type(const s: stringid): ttypesym;
@ -1738,34 +1738,23 @@ implementation
end;
function searchsym_in_class(classh:tobjectdef;const s : stringid;out srsym:tsym;out srsymtable:tsymtable):boolean;
function searchsym_in_class(classh,contextclassh:tobjectdef;const s : stringid;out srsym:tsym;out srsymtable:tsymtable):boolean;
var
speedvalue : cardinal;
topclassh : tobjectdef;
currentclassh : tobjectdef;
begin
result:=false;
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 assigned(classh) and
(classh.owner.symtabletype in [globalsymtable,staticsymtable]) and
classh.owner.iscurrentunit then
topclassh:=classh
if assigned(current_procinfo.procdef) then
currentclassh:=current_procinfo.procdef._class
else
begin
if assigned(current_procinfo) then
topclassh:=current_procinfo.procdef._class
else
topclassh:=nil;
end;
currentclassh:=nil;
while assigned(classh) do
begin
srsymtable:=classh.symtable;
srsym:=tsym(srsymtable.speedsearch(s,speedvalue));
if assigned(srsym) and
tsym(srsym).is_visible_for_object(topclassh,current_procinfo.procdef._class) then
tsym(srsym).is_visible_for_object(contextclassh,currentclassh) then
begin
result:=true;
exit;

35
tests/webtbf/tw6922.pp Normal file
View File

@ -0,0 +1,35 @@
{ %fail }
{$ifdef fpc}{$mode objfpc}{$H+}{$endif}
uses uw6922;
type
{ TC }
TC=class(TA)
public
procedure Test;
end;
{ TC }
procedure TC.Test;
var
B: TB;
begin
T := 'Test1'; // allowed, because it is a descendant
B := TB.Create;
B.T := 'Test2'; // should not be allowed
writeln(B.T);
B.Free;
end;
var
c: TC;
begin
c := TC.Create;
c.T := 'Test3'; // allowed, because it is in the same 'unit'
c.Test;
c.Free;
end.

23
tests/webtbf/uw6922.pp Normal file
View File

@ -0,0 +1,23 @@
unit uw6922;
{$ifdef fpc}{$mode objfpc}{$H+}{$endif}
interface
type
{ TA }
TA = class
private
FT: string;
protected
property T: string read FT write FT;
end;
TB = class(TA)
end;
implementation
end.