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

* fixed "inherited some_property" constructs for getters/setters

Browse Source 
(mantis #10927)
  * extended the tb0259 test a bit (tests similar constructs in
    case there is no getter/setter)

git-svn-id: trunk@10456 -
This commit is contained in:
Jonas Maebe 2008-03-07 19:29:40 +00:00
parent 931aef4daa
commit 005bdc1af4
4 changed files with 103 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -8008,6 +8008,7 @@ tests/webtbs/tw10897.pp svneol=native#text/plain
tests/webtbs/tw1090.pp svneol=native#text/plain
tests/webtbs/tw1092.pp svneol=native#text/plain
tests/webtbs/tw10920.pp svneol=native#text/plain
tests/webtbs/tw10927.pp svneol=native#text/plain
tests/webtbs/tw10931.pp svneol=native#text/plain
tests/webtbs/tw1096.pp svneol=native#text/plain
tests/webtbs/tw10966.pp svneol=native#text/plain

28
compiler/pexpr.pas
View File

@ -1062,6 +1062,21 @@ implementation
fieldvarsym :
begin
{ generate access code }
{ for fieldvars, having a typenode is wrong: }
{ fields cannot be overridden/hidden in child }
{ classes. However, we always have to pass the }
{ typenode to handle_propertysym because the }
{ parent doesn't know yet to what the property }
{ will resolve (and in case of procsyms, we do }
{ need the type node in case of }
{ "inherited property_with_getter/setter" }
if (assigned(p1)) and
(p1.nodetype = typen) then
begin
p1.free;
p1:=nil;
end;
propaccesslist_to_node(p1,st,propaccesslist);
include(p1.flags,nf_isproperty);
consume(_ASSIGNMENT);
@ -1090,6 +1105,15 @@ implementation
fieldvarsym :
begin
{ generate access code }
{ for fieldvars, having a typenode is wrong: }
{ see comments above for write access }
if (assigned(p1)) and
(p1.nodetype = typen) then
begin
p1.free;
p1:=nil;
end;
propaccesslist_to_node(p1,st,propaccesslist);
include(p1.flags,nf_isproperty);
end;
@ -2234,14 +2258,14 @@ implementation
not from self }
if srsym.typ in [procsym,propertysym] then
begin
hdef:=hclassdef;
if (srsym.typ = procsym) then
begin
hdef:=hclassdef;
if (po_classmethod in current_procinfo.procdef.procoptions) or
(po_staticmethod in current_procinfo.procdef.procoptions) then
hdef:=tclassrefdef.create(hdef);
p1:=ctypenode.create(hdef);
end;
p1:=ctypenode.create(hdef);
end
else
begin

21
tests/tbs/tb0259.pp
View File

@ -5,18 +5,35 @@
type
c1=class
Ffont : longint;
property Font:longint read Ffont;
property Font:longint read Ffont write Ffont;
end;
c2=class(c1)
function GetFont:longint;
procedure setfont(l: longint);
end;
function c2.GetFont:longint;
begin
result:=Font;
result:=inherited Font;
end;
procedure c2.SetFont(l: longint);
begin
inherited font := l;
end;
var
c: c2;
begin
c:=c2.create;
c.ffont:=5;
if c.getfont<>5 then
halt(1);
c.setfont(10);
if c.getfont<>10 then
halt(2);
if c.ffont<>10 then
halt(3);
end.

57
tests/webtbs/tw10927.pp Normal file
View File

@ -0,0 +1,57 @@
program project1;
{$mode objfpc}{$H+}
type
{ TOrgObject }
TOriginal=class
protected
procedure SetReadOnly(const AValue: boolean); virtual;
public
property readonly:boolean write SetReadOnly;
end;
{ TDerived }
TDerived=class(TOriginal)
protected
procedure SetReadOnly(const AValue: boolean); override;
end;
var
count1, count2: longint;
{ TDerived }
procedure TDerived.SetReadOnly(const AValue: boolean);
begin
if (count2>0) then
halt(1);
inc(count2);
WriteLn('TDerived.SetReadOnly');
inherited;
inherited ReadOnly := AValue;
end;
{ TOrgObject }
procedure TOriginal.SetReadOnly(const AValue: boolean);
begin
if (count1>1) then
halt(2);
inc(count1);
WriteLn('TOriginal.SetReadOnly');
end;
var
D: TDerived;
begin
D := TDerived.Create;
D.ReadOnly := True;
D.Free;
if (count1<>2) or
(count2<>1) then
halt(3);
end.