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

+ support for automatically generating setters/getters for properties on the

Browse Source 
JVM target, since Java bytecode itself has no support for properties and
    hence exposing properties to external Java code can only be done through
    getters/setters. Use the new parameters to do so:
      -CTautogetterprefix=XXX
      -CTautosetterprefix=YYY
    The getter/setter will get the same visibility as the property. If a
    getter/setter with the same naming convention was already specified for a
    property and this getter/setter is declared in the same class as the
    property, then the visibility of this existing getter/setter is
    modified and no new routine is generated.

    Newly generated getters/setters are virtual methods, because that is
    the only way in Java bytecode to allow redefining these getters/setters
    in child classes. However, that also means that using these switches can
    change the behvaviour of code, since normally the used property definition
    is only determined by the declared type of its associated class instance,
    and not by the actual instance type. The compiler will therefore warn when
    such an automatically generated getter/setter is overridden by another
    automatically generated getter/setter in a child class.

git-svn-id: trunk@22959 -
This commit is contained in:
Jonas Maebe 2012-11-08 20:18:08 +00:00
parent 1c32590294
commit 4aa05f5133
11 changed files with 892 additions and 575 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

60
compiler/globals.pas
View File

@ -319,6 +319,13 @@ interface
features : tfeatures;
{ prefix added to automatically generated setters/getters. If empty,
no getters/setters will be automatically generated except if required
for visibility reasons (but in that case the names will be mangled so
they are unique) }
prop_auto_getter_prefix,
prop_auto_setter_prefix : string;
const
DLLsource : boolean = false;
@ -1335,28 +1342,42 @@ implementation
function UpdateTargetSwitchStr(s: string; var a: ttargetswitches): boolean;
var
tok : string;
tok,
value : string;
setstr: string[2];
equalspos: longint;
doset,
gotvalue,
found : boolean;
opt : ttargetswitch;
begin
result:=true;
uppervar(s);
repeat
tok:=GetToken(s,',');
if tok='' then
break;
if Copy(tok,1,2)='NO' then
setstr:=upper(copy(tok,1,2));
if setstr='NO' then
begin
delete(tok,1,2);
doset:=false;
end
else
doset:=true;
{ value specified? }
gotvalue:=false;
equalspos:=pos('=',tok);
if equalspos<>0 then
begin
value:=copy(tok,equalspos+1,length(tok));
delete(tok,equalspos,length(tok));
gotvalue:=true;
end;
found:=false;
uppervar(tok);
for opt:=low(ttargetswitch) to high(ttargetswitch) do
begin
if TargetSwitchStr[opt]=tok then
if TargetSwitchStr[opt].name=tok then
begin
found:=true;
break;
@ -1364,10 +1385,35 @@ implementation
end;
if found then
begin
if doset then
include(a,opt)
if not TargetSwitchStr[opt].hasvalue then
begin
if gotvalue then
result:=false;
if doset then
include(a,opt)
else
exclude(a,opt)
end
else
exclude(a,opt);
begin
if not gotvalue or
not doset then
result:=false
else
begin
case opt of
ts_auto_getter_prefix:
prop_auto_getter_prefix:=value;
ts_auto_setter_predix:
prop_auto_setter_prefix:=value;
else
begin
writeln('Internalerror 2012053001');
halt(1);
end;
end;
end;
end;
end
else
result:=false;

24
compiler/globtype.pas
View File

@ -221,8 +221,11 @@ interface
of the current class, then this virtual method may already have
initialized that field with another value and the constructor
initialization will result in data loss }
ts_jvm_enum_field_init
ts_jvm_enum_field_init,
{ when automatically generating getters/setters for properties, use
these strings as prefixes for the generated getters/setter names }
ts_auto_getter_prefix,
ts_auto_setter_predix
);
ttargetswitches = set of ttargetswitch;
@ -271,6 +274,11 @@ interface
flashbase, flashsize, srambase, sramsize, eeprombase, eepromsize: dword;
end;
ttargetswitchinfo = record
name: string[22];
hasvalue: boolean;
end;
const
OptimizerSwitchStr : array[toptimizerswitch] of string[11] = ('',
'LEVEL1','LEVEL2','LEVEL3',
@ -286,10 +294,14 @@ interface
DebugSwitchStr : array[tdebugswitch] of string[22] = ('',
'DWARFSETS','STABSABSINCLUDES','DWARFMETHODCLASSPREFIX');
TargetSwitchStr : array[ttargetswitch] of string[19] = ('',
'SMALLTOC',
'COMPACTINTARRAYINIT',
'ENUMFIELDINIT');
TargetSwitchStr : array[ttargetswitch] of ttargetswitchinfo = (
(name: ''; hasvalue: false),
(name: 'SMALLTOC'; hasvalue: false),
(name: 'COMPACTINTARRAYINIT'; hasvalue: false),
(name: 'ENUMFIELDINIT'; hasvalue: false),
(name: 'AUTOGETTERPREFIX'; hasvalue: true ),
(name: 'AUTOSETTERPREFIX'; hasvalue: true )
);
{ switches being applied to all CPUs at the given level }
genericlevel1optimizerswitches = [cs_opt_level1];

320
compiler/jvm/pjvm.pas
View File

@ -52,15 +52,15 @@ interface
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 }
procedure jvm_create_getter_for_property(p: tpropertysym);
procedure jvm_create_setter_for_property(p: tpropertysym);
procedure jvm_create_getter_for_property(p: tpropertysym; orgaccesspd: tprocdef);
procedure jvm_create_setter_for_property(p: tpropertysym; orgaccesspd: tprocdef);
implementation
uses
cutils,cclasses,
verbose,systems,
verbose,globals,systems,
fmodule,
parabase,aasmdata,
pdecsub,ngenutil,pparautl,
@ -850,17 +850,22 @@ implementation
end;
procedure jvm_create_getter_or_setter_for_property(p: tpropertysym; getter: boolean);
procedure jvm_create_getter_or_setter_for_property(p: tpropertysym; orgaccesspd: tprocdef; getter: boolean);
var
obj: tabstractrecorddef;
ps: tprocsym;
pvs: tparavarsym;
pd: tprocdef;
sym: tsym;
pd, parentpd, accessorparapd: tprocdef;
tmpaccesslist: tpropaccesslist;
callthroughpropname,
name: string;
callthroughprop: tpropertysym;
accesstyp: tpropaccesslisttypes;
sktype: tsynthetickind;
procoptions: tprocoptions;
paranr: word;
explicitwrapper: boolean;
begin
obj:=current_structdef;
{ if someone gets the idea to add a property to an external class
@ -870,108 +875,241 @@ implementation
exit;
symtablestack.push(obj.symtable);
if getter then
accesstyp:=palt_read
else
accesstyp:=palt_write;
try
if getter then
accesstyp:=palt_read
else
accesstyp:=palt_write;
{ create a property for the old symaccesslist with a new name, so that
we can reuse it in the implementation (rather than having to
translate the symaccesslist back to Pascal code) }
callthroughpropname:='__fpc__'+p.realname;
if getter then
callthroughpropname:=callthroughpropname+'__getter_wrapper'
else
callthroughpropname:=callthroughpropname+'__setter_wrapper';
callthroughprop:=tpropertysym.create(callthroughpropname);
callthroughprop.visibility:=p.visibility;
callthroughprop.default:=longint($80000000);
if sp_static in p.symoptions then
include(callthroughprop.symoptions, sp_static);
{ copy original property target to callthrough property (and replace
original one with the new empty list; will be filled in later) }
tmpaccesslist:=callthroughprop.propaccesslist[accesstyp];
callthroughprop.propaccesslist[accesstyp]:=p.propaccesslist[accesstyp];
p.propaccesslist[accesstyp]:=tmpaccesslist;
p.owner.insert(callthroughprop);
{ we can't use str_parse_method_dec here because the type of the field
may not be visible at the Pascal level }
{ we can't use str_parse_method_dec here because the type of the field
may not be visible at the Pascal level }
explicitwrapper:=
{ private methods are not visibile outside the current class, so
no use in making life harder for us by introducing potential
(future or current) naming conflicts }
(p.visibility<>vis_private) and
(getter and
(prop_auto_getter_prefix<>'')) or
(not getter and
(prop_auto_getter_prefix<>''));
sym:=nil;
procoptions:=[];
if explicitwrapper then
begin
if getter then
name:=prop_auto_getter_prefix+p.realname
else
name:=prop_auto_setter_prefix+p.realname;
sym:=search_struct_member_no_helper(obj,upper(name));
if getter then
sktype:=tsk_field_getter
else
sktype:=tsk_field_setter;
if assigned(sym) then
begin
if ((sym.typ<>procsym) or
(tprocsym(sym).procdeflist.count<>1) or
(tprocdef(tprocsym(sym).procdeflist[0]).synthetickind<>sktype)) and
(not assigned(orgaccesspd) or
(sym<>orgaccesspd.procsym)) then
begin
MessagePos2(p.fileinfo,parser_e_cannot_generate_property_getter_setter,name,FullTypeName(tdef(sym.owner.defowner),nil)+'.'+name);
exit;
end
else
begin
if name<>sym.realname then
MessagePos2(p.fileinfo,parser_w_case_difference_auto_property_getter_setter_prefix,sym.realname,name);
{ is the specified getter/setter defined in the current
struct and was it originally specified as the getter/
setter for this property? If so, simply adjust its
visibility if necessary.
}
if assigned(orgaccesspd) then
parentpd:=orgaccesspd
else
parentpd:=tprocdef(tprocsym(sym).procdeflist[0]);
if parentpd.owner.defowner=p.owner.defowner then
begin
parentpd.visibility:=p.visibility;
include(parentpd.procoptions,po_auto_raised_visibility);
{ we are done, no need to create a wrapper }
exit
end
{ a parent already included this getter/setter -> try to
override it }
else if parentpd.visibility<>vis_private then
begin
if po_virtualmethod in parentpd.procoptions then
begin
procoptions:=procoptions+[po_virtualmethod,po_overridingmethod];
Message2(parser_w_overriding_property_getter_setter,name,FullTypeName(tdef(parentpd.owner.defowner),nil));
end;
{ otherwise we can't do anything, and
proc_add_definition will give an error }
end
end;
end;
{ make the artificial getter/setter virtual so we can override it in
children if necessary }
if not(sp_static in p.symoptions) and
(obj.typ=objectdef) then
include(procoptions,po_virtualmethod);
{ prevent problems in Delphi mode }
include(procoptions,po_overload);
end
else
begin
{ construct procsym name (unique for this access; reusing the same
helper for multiple accesses to the same field is hard because the
propacesslist can contain subscript nodes etc) }
name:=visibilityName[p.visibility];
replace(name,' ','_');
if getter then
name:=name+'$getter'
else
name:=name+'$setter';
end;
{ create procdef }
pd:=tprocdef.create(normal_function_level);
if df_generic in obj.defoptions then
include(pd.defoptions,df_generic);
{ create procdef }
if not assigned(orgaccesspd) then
begin
pd:=tprocdef.create(normal_function_level);
if df_generic in obj.defoptions then
include(pd.defoptions,df_generic);
{ method of this objectdef }
pd.struct:=obj;
{ can only construct the artificial name now, because it requires
pd.defid }
if not explicitwrapper then
name:='$'+obj.symtable.realname^+'$'+p.realname+'$'+name+'$'+tostr(pd.defid);
end
else
begin
{ getter/setter could have parameters in case of indexed access
-> copy original procdef }
pd:=tprocdef(orgaccesspd.getcopy);
{ can only construct the artificial name now, because it requires
pd.defid }
if not explicitwrapper then
name:='$'+obj.symtable.realname^+'$'+p.realname+'$'+name+'$'+tostr(pd.defid);
finish_copied_procdef(pd,name,obj.symtable,obj);
sym:=pd.procsym;
end;
{ add previously collected procoptions }
pd.procoptions:=pd.procoptions+procoptions;
{ visibility }
pd.visibility:=p.visibility;
{ construct procsym name (unique for this access; reusing the same
helper for multiple accesses to the same field is hard because the
propacesslist can contain subscript nodes etc) }
name:=visibilityName[p.visibility];
replace(name,' ','_');
if getter then
name:=name+'$getter'
else
name:=name+'$setter';
name:='$'+obj.symtable.realname^+'$'+p.realname+'$'+name+'$'+tostr(pd.defid);
{ new procsym? }
if not assigned(sym) or
(sym.owner<>p.owner) then
begin
ps:=tprocsym.create(name);
obj.symtable.insert(ps);
end
else
ps:=tprocsym(sym);
{ associate procsym with procdef}
pd.procsym:=ps;
{ new procsym }
ps:=tprocsym.create(name);
obj.symtable.insert(ps);
{ associate procsym with procdef}
pd.procsym:=ps;
{ method of this objectdef }
pd.struct:=obj;
{ visibility }
pd.visibility:=p.visibility;
{ function/procedure }
if getter then
begin
pd.proctypeoption:=potype_function;
pd.synthetickind:=tsk_field_getter;
{ result type }
pd.returndef:=p.propdef;
end
else
begin
pd.proctypeoption:=potype_procedure;
pd.synthetickind:=tsk_field_setter;
pd.returndef:=voidtype;
{ parameter with value to set }
pvs:=tparavarsym.create('__fpc_newval__',10,vs_const,p.propdef,[]);
pd.parast.insert(pvs);
end;
pd.skpara:=callthroughprop;
{ needs to be exported }
include(pd.procoptions,po_global);
{ class property -> static class method }
if sp_static in p.symoptions then
pd.procoptions:=pd.procoptions+[po_classmethod,po_staticmethod];
{ calling convention, self, ... }
if obj.typ=recorddef then
handle_calling_convention(pd,[hcc_check])
else
handle_calling_convention(pd,hcc_all);
{ register forward declaration with procsym }
proc_add_definition(pd);
{ make the property call this new function }
p.propaccesslist[accesstyp].addsym(sl_call,ps);
p.propaccesslist[accesstyp].procdef:=pd;
{ function/procedure }
accessorparapd:=nil;
if getter then
begin
pd.proctypeoption:=potype_function;
pd.synthetickind:=tsk_field_getter;
{ result type }
pd.returndef:=p.propdef;
if (ppo_hasparameters in p.propoptions) and
not assigned(orgaccesspd) then
accessorparapd:=pd;
end
else
begin
pd.proctypeoption:=potype_procedure;
pd.synthetickind:=tsk_field_setter;
pd.returndef:=voidtype;
if not assigned(orgaccesspd) then
begin
{ parameter with value to set }
pvs:=tparavarsym.create('__fpc_newval__',10,vs_const,p.propdef,[]);
pd.parast.insert(pvs);
end;
if (ppo_hasparameters in p.propoptions) and
not assigned(orgaccesspd) then
accessorparapd:=pd;
end;
symtablestack.pop(obj.symtable);
{ create a property for the old symaccesslist with a new name, so that
we can reuse it in the implementation (rather than having to
translate the symaccesslist back to Pascal code) }
callthroughpropname:='__fpc__'+p.realname;
if getter then
callthroughpropname:=callthroughpropname+'__getter_wrapper'
else
callthroughpropname:=callthroughpropname+'__setter_wrapper';
callthroughprop:=tpropertysym.create(callthroughpropname);
callthroughprop.visibility:=p.visibility;
if getter then
p.makeduplicate(callthroughprop,accessorparapd,nil,paranr)
else
p.makeduplicate(callthroughprop,nil,accessorparapd,paranr);
callthroughprop.default:=longint($80000000);
callthroughprop.default:=0;
callthroughprop.propoptions:=callthroughprop.propoptions-[ppo_stored,ppo_enumerator_current,ppo_overrides,ppo_defaultproperty];
if sp_static in p.symoptions then
include(callthroughprop.symoptions, sp_static);
{ copy original property target to callthrough property (and replace
original one with the new empty list; will be filled in later) }
tmpaccesslist:=callthroughprop.propaccesslist[accesstyp];
callthroughprop.propaccesslist[accesstyp]:=p.propaccesslist[accesstyp];
p.propaccesslist[accesstyp]:=tmpaccesslist;
p.owner.insert(callthroughprop);
pd.skpara:=callthroughprop;
{ needs to be exported }
include(pd.procoptions,po_global);
{ class property -> static class method }
if sp_static in p.symoptions then
pd.procoptions:=pd.procoptions+[po_classmethod,po_staticmethod];
{ in case we made a copy of the original accessor, this has all been
done already }
if not assigned(orgaccesspd) then
begin
{ calling convention, self, ... }
if obj.typ=recorddef then
handle_calling_convention(pd,[hcc_check])
else
handle_calling_convention(pd,hcc_all);
{ register forward declaration with procsym }
proc_add_definition(pd);
end;
{ make the property call this new function }
p.propaccesslist[accesstyp].addsym(sl_call,ps);
p.propaccesslist[accesstyp].procdef:=pd;
finally
symtablestack.pop(obj.symtable);
end;
end;
procedure jvm_create_getter_for_property(p: tpropertysym);
procedure jvm_create_getter_for_property(p: tpropertysym; orgaccesspd: tprocdef);
begin
jvm_create_getter_or_setter_for_property(p,true);
jvm_create_getter_or_setter_for_property(p,orgaccesspd,true);
end;
procedure jvm_create_setter_for_property(p: tpropertysym);
procedure jvm_create_setter_for_property(p: tpropertysym; orgaccesspd: tprocdef);
begin
jvm_create_getter_or_setter_for_property(p,false);
jvm_create_getter_or_setter_for_property(p,orgaccesspd,false);
end;
end.

27
compiler/msg/errore.msg
View File

@ -390,7 +390,7 @@ scan_w_unavailable_system_codepage=02091_W_Current system codepage "$1" is not a
#
# Parser
#
# 03324 is the last used one
# 03327 is the last used one
#
% \section{Parser messages}
% This section lists all parser messages. The parser takes care of the
@ -1446,12 +1446,31 @@ parser_e_jvm_invalid_virtual_constructor_call=03321_E_Calling a virtual construc
% for the current instance inside another constructor.
parser_e_method_lower_visibility=03322_E_Overriding method "$1" cannot have a lower visibility ($2) than in parent class $3 ($4)
% The JVM does not allow lowering the visibility of an overriding method.
% \end{description}
parser_w_nostackframe_without_assembler=03323_W_Procedure/Function declared with call option NOSTACKFRAME but without ASSEMBLER
% nostackframe call modifier is supposed to be used in conjunction with assembler.
parser_e_nostackframe_with_locals=03324_E_Procedure/Function declared with call option NOSTACKFRAME but local stack size is $1
% nostackframe call modifier used without assembler modifier
% might still generate local stack needs.
parser_e_cannot_generate_property_getter_setter=03325_E_Cannot generate property getter/setter $1 because its name clashes with existing identifier $2
% Automatically generated getters/setters cannot have the same name as existing
% identifiers, because this may change the behaviour of existing code.
parser_w_overriding_property_getter_setter=03326_W_Automatically generated property getter/setter $1 overrides the same-named getter/setter in class $2
% Automatically generated property getters/setters on the JVM platform are virtual methods, because
% the JVM does not support non-virtual methods that can be changed in child classes. This means
% that if a child class changes an inherited property definition, the behaviour of that property
% can change compared to native targets since even if a variable is declared as the parent type,
% by calling the virtual method the getter from the child will be used. This is different from
% the behaviour on native targets or when not activating automatically generated setters/getters,
% because in that case only the declared type of a variable influences the property behaviour.
parser_w_case_difference_auto_property_getter_setter_prefix=03327_W_Case mismatch between declared property getter/setter $1 and automatically constructed name $2, not changing declared name
% If a property's specified getter/setter already corresponded to the naming convention specified
% by the automatic getter/setter generation setting except in terms of upper/lowercase, the
% compiler will print a warning because it cannot necessarily change that other declaration itself
% not can it add one using the correct case (it could conflict with the original declaration).
% Manually correct the case of the getter/setter to conform to the desired coding rules.
% \var{TChild} overrides
%
% \end{description}
%
# Type Checking
#
@ -3359,8 +3378,10 @@ J*2CT<x>_Target-specific code generation options
p*3CTsmalltoc_ Generate smaller TOCs at the expense of execution speed (AIX)
P*3CTsmalltoc_ Generate smaller TOCs at the expense of execution speed (AIX)
J*3CTcompactintarrayinit_ Generate smaller (but potentially slower) code for initializing integer array constants
K*3CTenumfieldinit_ Initialize enumeration fields in constructors to enumtype(0), after calling inherited constructors
J*3CTenumfieldinit_ Initialize enumeration fields in constructors to enumtype(0), after calling inherited constructors
J*2Cv_Var/out parameter copy-out checking
J*3CTautogetterprefix=X_ Automatically create getters for properties with prefix X (empty string disables)
J*3CTautosetterprefix=X_ Automatically create setters for properties with prefix X (empty string disables)
**2CX_Create also smartlinked library
**1d<x>_Defines the symbol <x>
**1D_Generate a DEF file

7
compiler/msgidx.inc
View File

@ -419,6 +419,9 @@ const
parser_e_method_lower_visibility=03322;
parser_w_nostackframe_without_assembler=03323;
parser_e_nostackframe_with_locals=03324;
parser_e_cannot_generate_property_getter_setter=03325;
parser_w_overriding_property_getter_setter=03326;
parser_w_case_difference_auto_property_getter_setter_prefix=03327;
type_e_mismatch=04000;
type_e_incompatible_types=04001;
type_e_not_equal_types=04002;
@ -957,9 +960,9 @@ const
option_info=11024;
option_help_pages=11025;
MsgTxtSize = 67227;
MsgTxtSize = 67784;
MsgIdxMax : array[1..20] of longint=(
26,92,325,120,87,56,125,26,202,63,
26,92,328,120,87,56,125,26,202,63,
53,20,1,1,1,1,1,1,1,1
);

910
compiler/msgtxt.inc
View File

File diff suppressed because it is too large Load Diff

16
compiler/nobj.pas
View File

@ -423,13 +423,21 @@ implementation
{ Give a note if the new visibility is lower. For a higher
visibility update the vmt info }
if vmtentryvis>pd.visibility then
begin
if po_auto_raised_visibility in vmtpd.procoptions then
begin
if updatevalues then
pd.visibility:=vmtentryvis;
end
else
{$ifdef jvm}
MessagePos4(pd.fileinfo,parser_e_method_lower_visibility,
MessagePos4(pd.fileinfo,parser_e_method_lower_visibility,
{$else jvm}
MessagePos4(pd.fileinfo,parser_n_ignore_lower_visibility,
MessagePos4(pd.fileinfo,parser_n_ignore_lower_visibility,
{$endif jvm}
pd.fullprocname(false),
visibilityname[pd.visibility],tobjectdef(vmtpd.owner.defowner).objrealname^,visibilityname[vmtentryvis])
pd.fullprocname(false),
visibilityname[pd.visibility],tobjectdef(vmtpd.owner.defowner).objrealname^,visibilityname[vmtentryvis])
end
else if pd.visibility>vmtentryvis then
begin
if updatevalues then

23
compiler/pdecvar.pas
View File

@ -334,6 +334,9 @@ implementation
hdef : tdef;
arraytype : tdef;
def : tdef;
{$ifdef jvm}
orgaccesspd : tprocdef;
{$endif}
pt : tnode;
sc : TFPObjectList;
paranr : word;
@ -532,6 +535,7 @@ implementation
else
begin
{$ifdef jvm}
orgaccesspd:=tprocdef(p.propaccesslist[palt_read].procdef);
{ if the visibility of the getter is lower than
the visibility of the property, wrap it so that
we can call it from all contexts in which the
@ -541,6 +545,9 @@ implementation
p.propaccesslist[palt_read].procdef:=jvm_wrap_method_with_vis(tprocdef(p.propaccesslist[palt_read].procdef),p.visibility);
p.propaccesslist[palt_read].firstsym^.sym:=tprocdef(p.propaccesslist[palt_read].procdef).procsym;
end;
if (prop_auto_getter_prefix<>'') and
(p.propaccesslist[palt_read].firstsym^.sym.RealName<>prop_auto_getter_prefix+p.RealName) then
jvm_create_getter_for_property(p,orgaccesspd);
{$endif jvm}
end;
end;
@ -563,8 +570,9 @@ implementation
visibility of the property, wrap it in a getter
so that we can access it from all contexts in
which the property is visibile }
if (tfieldvarsym(sym).visibility<p.visibility) then
jvm_create_getter_for_property(p);
if (prop_auto_getter_prefix<>'') or
(tfieldvarsym(sym).visibility<p.visibility) then
jvm_create_getter_for_property(p,nil);
{$endif}
end
else
@ -608,7 +616,8 @@ implementation
else
begin
{$ifdef jvm}
{ if the visibility of the getter is lower than
orgaccesspd:=tprocdef(p.propaccesslist[palt_write].procdef);
{ if the visibility of the setter is lower than
the visibility of the property, wrap it so that
we can call it from all contexts in which the
property is visible }
@ -617,6 +626,9 @@ implementation
p.propaccesslist[palt_write].procdef:=jvm_wrap_method_with_vis(tprocdef(p.propaccesslist[palt_write].procdef),p.visibility);
p.propaccesslist[palt_write].firstsym^.sym:=tprocdef(p.propaccesslist[palt_write].procdef).procsym;
end;
if (prop_auto_setter_prefix<>'') and
(sym.RealName<>prop_auto_setter_prefix+p.RealName) then
jvm_create_setter_for_property(p,orgaccesspd);
{$endif jvm}
end;
end;
@ -639,8 +651,9 @@ implementation
visibility of the property, wrap it in a getter
so that we can access it from all contexts in
which the property is visibile }
if (tfieldvarsym(sym).visibility<p.visibility) then
jvm_create_setter_for_property(p);
if (prop_auto_setter_prefix<>'') or
(tfieldvarsym(sym).visibility<p.visibility) then
jvm_create_setter_for_property(p,nil);
{$endif}
end
else

6
compiler/symconst.pas
View File

@ -334,7 +334,11 @@ type
inherited, so we explicitly have to add the constructors of the parent
class to the child class; this influences the overload resolution logic
though, so ignore them there) }
po_ignore_for_overload_resolution
po_ignore_for_overload_resolution,
{ the visibility of of this procdef was raised automatically by the
compiler, e.g. because it was designated as a getter/setter for a property
with a higher visibility on the JVM target }
po_auto_raised_visibility
);
tprocoptions=set of tprocoption;

71
compiler/symcreat.pas
View File

@ -832,22 +832,87 @@ implementation
procedure implement_field_getter(pd: tprocdef);
var
i: longint;
pvs: tparavarsym;
str: ansistring;
callthroughprop: tpropertysym;
propaccesslist: tpropaccesslist;
lastparanr: longint;
firstpara: boolean;
begin
callthroughprop:=tpropertysym(pd.skpara);
str:='begin result:='+callthroughprop.realname+'; end;';
str:='begin result:='+callthroughprop.realname;
if ppo_hasparameters in callthroughprop.propoptions then
begin
if not callthroughprop.getpropaccesslist(palt_read,propaccesslist) then
internalerror(2012100701);
str:=str+'[';
firstpara:=true;
lastparanr:=tprocdef(propaccesslist.procdef).paras.count-1;
if ppo_indexed in callthroughprop.propoptions then
dec(lastparanr);
for i:=0 to lastparanr do
begin
{ skip self/vmt/parentfp, passed implicitly }
pvs:=tparavarsym(tprocdef(propaccesslist.procdef).paras[i]);
if ([vo_is_self,vo_is_vmt,vo_is_parentfp]*pvs.varoptions)<>[] then
continue;
if not firstpara then
str:=str+',';
firstpara:=false;
str:=str+pvs.realname;
end;
str:=str+']';
end;
str:=str+'; end;';
str_parse_method_impl(str,pd,po_classmethod in pd.procoptions)
end;
procedure implement_field_setter(pd: tprocdef);
var
str: ansistring;
i, lastparaindex: longint;
pvs: tparavarsym;
paraname, str: ansistring;
callthroughprop: tpropertysym;
propaccesslist: tpropaccesslist;
firstpara: boolean;
begin
callthroughprop:=tpropertysym(pd.skpara);
str:='begin '+callthroughprop.realname+':=__fpc_newval__; end;';
str:='begin '+callthroughprop.realname;
if not callthroughprop.getpropaccesslist(palt_write,propaccesslist) then
internalerror(2012100702);
if ppo_hasparameters in callthroughprop.propoptions then
begin
str:=str+'[';
firstpara:=true;
{ last parameter is the value to be set, skip (only add index
parameters here) }
lastparaindex:=tprocdef(propaccesslist.procdef).paras.count-2;
if ppo_indexed in callthroughprop.propoptions then
dec(lastparaindex);
for i:=0 to lastparaindex do
begin
{ skip self/vmt/parentfp/index, passed implicitly }
pvs:=tparavarsym(tprocdef(propaccesslist.procdef).paras[i]);
if ([vo_is_self,vo_is_vmt,vo_is_parentfp]*pvs.varoptions)<>[] then
continue;
if not firstpara then
str:=str+',';
firstpara:=false;
str:=str+pvs.realname;
end;
str:=str+']';
end;
{ the value-to-be-set }
if assigned(propaccesslist.procdef) then
begin
pvs:=tparavarsym(tprocdef(propaccesslist.procdef).paras[tprocdef(propaccesslist.procdef).paras.count-1]);
paraname:=pvs.realname;
end
else
paraname:='__fpc_newval__';
str:=str+':='+paraname+'; end;';
str_parse_method_impl(str,pd,po_classmethod in pd.procoptions)
end;

3
compiler/utils/ppudump.pp
View File

@ -1523,7 +1523,8 @@ const
(mask:po_delphi_nested_cc;str: 'Delphi-style nested frameptr'),
(mask:po_java_nonvirtual; str: 'Java non-virtual method'),
(mask:po_ignore_for_overload_resolution;str: 'Ignored for overload resolution'),
(mask:po_rtlproc; str: 'RTL procedure')
(mask:po_rtlproc; str: 'RTL procedure'),
(mask:po_auto_raised_visibility; str: 'Visibility raised by compiler')
);
var
proctypeoption : tproctypeoption;