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

* fixes for the support for overriding properties on the JVM target:

Browse Source 
o only create an accessor wrapping the inherited accessor at a
     potentially lower visibility level if the overriding property
     itself does not specify a different accessor to use
   o simplified code
   o tests

git-svn-id: trunk@27954 -
This commit is contained in:
Jonas Maebe 2014-06-14 10:35:35 +00:00
parent a8ed74d4d2
commit 8634aa8ad2
8 changed files with 103 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitattributes vendored
View File

@ -10908,6 +10908,8 @@ tests/test/jvm/tprop3.pp svneol=native#text/plain
tests/test/jvm/tprop4.pp svneol=native#text/plain
tests/test/jvm/tprop5.pp svneol=native#text/plain
tests/test/jvm/tprop5a.pp svneol=native#text/plain
tests/test/jvm/tprop6.pp svneol=native#text/plain
tests/test/jvm/tprop6a.pp svneol=native#text/plain
tests/test/jvm/tptrdynarr.pp svneol=native#text/plain
tests/test/jvm/tpvar.pp svneol=native#text/plain
tests/test/jvm/tpvardelphi.pp svneol=native#text/plain

60
compiler/jvm/symcpu.pas
View File

@ -187,10 +187,11 @@ type
visibility, then we have to create a getter and/or setter with that same
higher visibility to make sure that using the property does not result
in JVM verification errors }
function create_getter_or_setter_for_property(orgaccesspd: tprocdef; getter: boolean): tprocdef;
procedure create_getter_or_setter_for_property(orgaccesspd: tprocdef; getter: boolean);
procedure finalize_getter_or_setter_for_sym(getset: tpropaccesslisttypes; sym: tsym; fielddef: tdef; accessordef: tprocdef); override;
procedure register_override(overriddenprop: tpropertysym); override;
procedure maybe_create_overridden_getter_or_setter(getset: tpropaccesslisttypes);
public
procedure inherit_accessor(getset: tpropaccesslisttypes); override;
end;
tcpupropertysymclass = class of tcpupropertysym;
@ -224,7 +225,7 @@ implementation
tcpuproptertysym
****************************************************************************}
function tcpupropertysym.create_getter_or_setter_for_property(orgaccesspd: tprocdef; getter: boolean): tprocdef;
procedure tcpupropertysym.create_getter_or_setter_for_property(orgaccesspd: tprocdef; getter: boolean);
var
obj: tabstractrecorddef;
ps: tprocsym;
@ -311,7 +312,6 @@ implementation
parentpd.visibility:=visibility;
include(parentpd.procoptions,po_auto_raised_visibility);
end;
result:=parentpd;
{ we are done, no need to create a wrapper }
exit
end
@ -344,7 +344,10 @@ implementation
finish_copied_procdef(pd,parentpd.procsym.realname,obj.symtable,obj);
exclude(pd.procoptions,po_external);
pd.synthetickind:=tsk_anon_inherited;
result:=pd;
{ set the accessor in the property }
propaccesslist[accesstyp].clear;
propaccesslist[accesstyp].addsym(sl_call,pd.procsym);
propaccesslist[accesstyp].procdef:=pd;
exit;
end;
end;
@ -400,7 +403,6 @@ implementation
pd.procoptions:=pd.procoptions+procoptions;
{ visibility }
pd.visibility:=visibility;
result:=pd;
{ new procsym? }
if not assigned(sym) or
@ -501,7 +503,7 @@ implementation
procedure tcpupropertysym.finalize_getter_or_setter_for_sym(getset: tpropaccesslisttypes; sym: tsym; fielddef: tdef; accessordef: tprocdef);
var
orgaccesspd, newaccesspd: tprocdef;
orgaccesspd: tprocdef;
pprefix: pshortstring;
wrongvisibility: boolean;
begin
@ -510,7 +512,6 @@ implementation
pprefix:=@prop_auto_getter_prefix
else
pprefix:=@prop_auto_setter_prefix;
newaccesspd:=nil;
case sym.typ of
procsym:
begin
@ -523,7 +524,7 @@ implementation
if wrongvisibility or
((pprefix^<>'') and
(sym.RealName<>pprefix^+RealName)) then
newaccesspd:=create_getter_or_setter_for_property(orgaccesspd,getset=palt_read)
create_getter_or_setter_for_property(orgaccesspd,getset=palt_read)
end;
fieldvarsym:
begin
@ -533,43 +534,17 @@ implementation
which the property is visibile }
if (pprefix^<>'') or
(tfieldvarsym(sym).visibility<visibility) then
newaccesspd:=create_getter_or_setter_for_property(nil,getset=palt_read);
create_getter_or_setter_for_property(nil,getset=palt_read);
end;
else
internalerror(2014061101);
end;
{ update the getter/setter used for this property (already done in case
a new method was created from scratch, but not if we overrode a
getter/setter generated for the inherited property) }
if assigned(newaccesspd) then
begin
if propaccesslist[getset].firstsym^.sym.typ<>procsym then
internalerror(2014061201);
propaccesslist[getset].procdef:=newaccesspd;
propaccesslist[getset].firstsym^.sym:=newaccesspd.procsym;
end;
end;
procedure tcpupropertysym.register_override(overriddenprop: tpropertysym);
var
sym: tsym;
begin
inherited;
{ new property has higher visibility than previous one -> maybe override
the getters/setters }
if (overriddenprop.visibility<visibility) then
begin
maybe_create_overridden_getter_or_setter(palt_read);
maybe_create_overridden_getter_or_setter(palt_write);
end;
end;
procedure tcpupropertysym.maybe_create_overridden_getter_or_setter(getset: tpropaccesslisttypes);
var
sym: tsym;
fielddef: tdef;
accessordef: tprocdef;
psym: tpropertysym;
begin
@ -590,14 +565,12 @@ implementation
accessordef:=tprocdef(psym.propaccesslist[getset].procdef);
if accessordef.visibility>=visibility then
exit;
fielddef:=nil;
end;
fieldvarsym:
begin
if sym.visibility>=visibility then
exit;
accessordef:=nil;
fielddef:=tfieldvarsym(sym).vardef;
end;
else
internalerror(2014061102);
@ -607,6 +580,17 @@ implementation
end;
procedure tcpupropertysym.inherit_accessor(getset: tpropaccesslisttypes);
begin
inherited;
{ new property has higher visibility than previous one -> maybe override
the getters/setters }
if assigned(overriddenpropsym) and
(overriddenpropsym.visibility<visibility) then
maybe_create_overridden_getter_or_setter(getset);
end;
{****************************************************************************
tcpuenumdef
****************************************************************************}

8
compiler/pdecvar.pas
View File

@ -535,7 +535,9 @@ implementation
end;
p.add_getter_or_setter_for_sym(palt_read,sym,def,readprocdef);
end;
end;
end
else
p.inherit_accessor(palt_read);
if try_to_consume(_WRITE) then
begin
p.propaccesslist[palt_write].clear;
@ -555,7 +557,9 @@ implementation
end;
p.add_getter_or_setter_for_sym(palt_write,sym,def,writeprocdef);
end;
end;
end
else
p.inherit_accessor(palt_write);
end
else
parse_dispinterface(p,readprocdef,writeprocdef,paranr);

10
compiler/symsym.pas
View File

@ -349,7 +349,9 @@ interface
procedure add_index_parameter(var paranr: word; readprocdef, writeprocdef: tprocdef);
{ set up the accessors for this property }
procedure add_getter_or_setter_for_sym(getset: tpropaccesslisttypes; sym: tsym; fielddef: tdef; accessordef: tprocdef);
procedure register_override(overriddenprop: tpropertysym); virtual;
procedure register_override(overriddenprop: tpropertysym);
{ inherit the read/write property }
procedure inherit_accessor(getset: tpropaccesslisttypes); virtual;
end;
tpropertysymclass = class of tpropertysym;
@ -1445,6 +1447,12 @@ implementation
end;
procedure tpropertysym.inherit_accessor(getset: tpropaccesslisttypes);
begin
{ nothing to do by default }
end;
procedure tpropertysym.makeduplicate(p: tpropertysym; readprocdef, writeprocdef: tprocdef; out paranr: word);
begin
{ inherit all type related entries }

4
tests/test/jvm/testall.bat
View File

@ -298,3 +298,7 @@ ppcjvm -O2 -g -B -Sa tprop5a
java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. tprop5a
ppcjvm -O2 -g -B -Sa tprop5a -CTautosetterprefix=Set -CTautogetterprefix=Get
java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. tprop5a
ppcjvm -O2 -g -B -Sa tprop6a
java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. tprop6a
ppcjvm -O2 -g -B -Sa tprop6a -CTautosetterprefix=Set -CTautogetterprefix=Get
java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. tprop6a

4
tests/test/jvm/testall.sh
View File

@ -178,3 +178,7 @@ $PPC -O2 -g -B -Sa tprop5a
java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/$RTLDIR:. tprop5a
$PPC -O2 -g -B -Sa tprop5a -CTautosetterprefix=Set -CTautogetterprefix=Get
java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/$RTLDIR:. tprop5a
$PPC -O2 -g -B -Sa tprop6a
java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/$RTLDIR:. tprop6a
$PPC -O2 -g -B -Sa tprop6a -CTautosetterprefix=Set -CTautogetterprefix=Get
java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/$RTLDIR:. tprop6a

40
tests/test/jvm/tprop6.pp Normal file
View File

@ -0,0 +1,40 @@
{$mode delphi}
{$modeswitch unicodestrings}
{$namespace org.freepascal.test}
Unit tprop6;
interface
uses
jdk15;
type
TBaseClassProp6 = class
private
FLevel : integer;
procedure SetLevel(value: integer); virtual;
public
property Level: Integer read FLevel write SetLevel;
end;
TDerivedClassProp6 = class(TBaseClassProp6)
protected
procedure SetLevel(value: integer); override;
public
property Level: Integer read FLevel write SetLevel;
end;
implementation
procedure TBaseClassProp6.SetLevel(Value: integer);
begin
FLevel := Value;
end;
procedure TDerivedClassProp6.SetLevel(Value: integer);
begin
FLevel := Value+1;
end;
end.

16
tests/test/jvm/tprop6a.pp Normal file
View File

@ -0,0 +1,16 @@
program tprop6a;
uses
tprop6;
var
c: tbaseclassprop6;
d: tderivedclassprop6;
begin
c:=tbaseclassprop6.create;
c.level:=4;
if c.level<>4 then
halt(1);
d:=tderivedclassprop6.create;
d.level:=5;
halt(d.level-6);
end.