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

* factored out associating properties with their getters/setters/fiels

Browse Source 
o moved JVM-specific code from pdecvar (and pjvm) to jvm/symcpu

git-svn-id: trunk@27938 -
This commit is contained in:
Jonas Maebe 2014-06-12 11:08:38 +00:00
parent 47c6b08ece
commit 2bd39f62cb
4 changed files with 413 additions and 434 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

290
compiler/jvm/pjvm.pas
View File

@ -48,13 +48,6 @@ interface
function jvm_wrap_method_with_vis(pd: tprocdef; vis: tvisibility): tprocdef; function jvm_wrap_method_with_vis(pd: tprocdef; vis: tvisibility): tprocdef;
{ when a private/protected field is exposed via a property with a higher
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; orgaccesspd: tprocdef);
procedure jvm_create_setter_for_property(p: tpropertysym; orgaccesspd: tprocdef);
implementation implementation
@ -853,287 +846,4 @@ implementation
end; end;
procedure jvm_create_getter_or_setter_for_property(p: tpropertysym; orgaccesspd: tprocdef; getter: boolean);
var
obj: tabstractrecorddef;
ps: tprocsym;
pvs: tparavarsym;
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
definition, don't try to wrap it since we cannot add methods to
external classes }
if oo_is_external in obj.objectoptions then
exit;
symtablestack.push(obj.symtable);
try
if getter then
accesstyp:=palt_read
else
accesstyp:=palt_write;
{ 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_setter_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
if parentpd.visibility<p.visibility then
begin
parentpd.visibility:=p.visibility;
include(parentpd.procoptions,po_auto_raised_visibility);
end;
{ 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;
{ add method with the correct visibility }
pd:=tprocdef(parentpd.getcopy);
{ get rid of the import name for inherited virtual class methods,
it has to be regenerated rather than amended }
if [po_classmethod,po_virtualmethod]<=pd.procoptions then
begin
stringdispose(pd.import_name);
exclude(pd.procoptions,po_has_importname);
end;
pd.visibility:=p.visibility;
pd.procoptions:=pd.procoptions+procoptions;
{ ignore this artificially added procdef when looking for overloads }
include(pd.procoptions,po_ignore_for_overload_resolution);
finish_copied_procdef(pd,parentpd.procsym.realname,obj.symtable,obj);
exclude(pd.procoptions,po_external);
pd.synthetickind:=tsk_anon_inherited;
exit;
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 }
if not assigned(orgaccesspd) then
begin
pd:=cprocdef.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);
exclude(pd.procoptions,po_abstractmethod);
{ 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;
{ new procsym? }
if not assigned(sym) or
(sym.owner<>p.owner) then
begin
ps:=cprocsym.create(name);
obj.symtable.insert(ps);
end
else
ps:=tprocsym(sym);
{ associate procsym with procdef}
pd.procsym:=ps;
{ 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:=cparavarsym.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;
{ 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:=cpropertysym.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; orgaccesspd: tprocdef);
begin
jvm_create_getter_or_setter_for_property(p,orgaccesspd,true);
end;
procedure jvm_create_setter_for_property(p: tpropertysym; orgaccesspd: tprocdef);
begin
jvm_create_getter_or_setter_for_property(p,orgaccesspd,false);
end;
end. end.

334
compiler/jvm/symcpu.pas
View File

@ -182,6 +182,13 @@ type
tcpuabsolutevarsymclass = class of tcpuabsolutevarsym; tcpuabsolutevarsymclass = class of tcpuabsolutevarsym;
tcpupropertysym = class(tpropertysym) tcpupropertysym = class(tpropertysym)
protected
{ when a private/protected field is exposed via a property with a higher
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 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;
end; end;
tcpupropertysymclass = class of tcpupropertysym; tcpupropertysymclass = class of tcpupropertysym;
@ -205,11 +212,334 @@ const
implementation implementation
uses uses
verbose,cutils,cclasses, verbose,cutils,cclasses,globals,
symconst,symbase,jvmdef, symconst,symbase,symtable,symcreat,jvmdef,
pdecsub,pjvm,
paramgr; paramgr;
{****************************************************************************
tcpuproptertysym
****************************************************************************}
procedure tcpupropertysym.create_getter_or_setter_for_property(orgaccesspd: tprocdef; getter: boolean);
var
obj: tabstractrecorddef;
ps: tprocsym;
pvs: tparavarsym;
sym: tsym;
pd, parentpd, accessorparapd: tprocdef;
tmpaccesslist: tpropaccesslist;
callthroughpropname,
accessorname: 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
definition, don't try to wrap it since we cannot add methods to
external classes }
if oo_is_external in obj.objectoptions then
exit;
symtablestack.push(obj.symtable);
try
if getter then
accesstyp:=palt_read
else
accesstyp:=palt_write;
{ 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 }
(visibility<>vis_private) and
(getter and
(prop_auto_getter_prefix<>'')) or
(not getter and
(prop_auto_setter_prefix<>''));
sym:=nil;
procoptions:=[];
if explicitwrapper then
begin
if getter then
accessorname:=prop_auto_getter_prefix+realname
else
accessorname:=prop_auto_setter_prefix+realname;
sym:=search_struct_member_no_helper(obj,upper(accessorname));
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(fileinfo,parser_e_cannot_generate_property_getter_setter,accessorname,FullTypeName(tdef(sym.owner.defowner),nil)+'.'+accessorname);
exit;
end
else
begin
if accessorname<>sym.realname then
MessagePos2(fileinfo,parser_w_case_difference_auto_property_getter_setter_prefix,sym.realname,accessorname);
{ 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=owner.defowner then
begin
if parentpd.visibility<visibility then
begin
parentpd.visibility:=visibility;
include(parentpd.procoptions,po_auto_raised_visibility);
end;
{ 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,accessorname,FullTypeName(tdef(parentpd.owner.defowner),nil));
end;
{ otherwise we can't do anything, and
proc_add_definition will give an error }
end;
{ add method with the correct visibility }
pd:=tprocdef(parentpd.getcopy);
{ get rid of the import accessorname for inherited virtual class methods,
it has to be regenerated rather than amended }
if [po_classmethod,po_virtualmethod]<=pd.procoptions then
begin
stringdispose(pd.import_name);
exclude(pd.procoptions,po_has_importname);
end;
pd.visibility:=visibility;
pd.procoptions:=pd.procoptions+procoptions;
{ ignore this artificially added procdef when looking for overloads }
include(pd.procoptions,po_ignore_for_overload_resolution);
finish_copied_procdef(pd,parentpd.procsym.realname,obj.symtable,obj);
exclude(pd.procoptions,po_external);
pd.synthetickind:=tsk_anon_inherited;
exit;
end;
end;
{ make the artificial getter/setter virtual so we can override it in
children if necessary }
if not(sp_static in symoptions) and
(obj.typ=objectdef) then
include(procoptions,po_virtualmethod);
{ prevent problems in Delphi mode }
include(procoptions,po_overload);
end
else
begin
{ construct procsym accessorname (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) }
accessorname:=visibilityName[visibility];
replace(accessorname,' ','_');
if getter then
accessorname:=accessorname+'$getter'
else
accessorname:=accessorname+'$setter';
end;
{ create procdef }
if not assigned(orgaccesspd) then
begin
pd:=cprocdef.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 accessorname now, because it requires
pd.defid }
if not explicitwrapper then
accessorname:='$'+obj.symtable.realname^+'$'+realname+'$'+accessorname+'$'+tostr(pd.defid);
end
else
begin
{ getter/setter could have parameters in case of indexed access
-> copy original procdef }
pd:=tprocdef(orgaccesspd.getcopy);
exclude(pd.procoptions,po_abstractmethod);
{ can only construct the artificial accessorname now, because it requires
pd.defid }
if not explicitwrapper then
accessorname:='$'+obj.symtable.realname^+'$'+realname+'$'+accessorname+'$'+tostr(pd.defid);
finish_copied_procdef(pd,accessorname,obj.symtable,obj);
sym:=pd.procsym;
end;
{ add previously collected procoptions }
pd.procoptions:=pd.procoptions+procoptions;
{ visibility }
pd.visibility:=visibility;
{ new procsym? }
if not assigned(sym) or
(sym.owner<>owner) then
begin
ps:=cprocsym.create(accessorname);
obj.symtable.insert(ps);
end
else
ps:=tprocsym(sym);
{ associate procsym with procdef}
pd.procsym:=ps;
{ function/procedure }
accessorparapd:=nil;
if getter then
begin
pd.proctypeoption:=potype_function;
pd.synthetickind:=tsk_field_getter;
{ result type }
pd.returndef:=propdef;
if (ppo_hasparameters in 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:=cparavarsym.create('__fpc_newval__',10,vs_const,propdef,[]);
pd.parast.insert(pvs);
end;
if (ppo_hasparameters in propoptions) and
not assigned(orgaccesspd) then
accessorparapd:=pd;
end;
{ create a property for the old symaccesslist with a new accessorname, so that
we can reuse it in the implementation (rather than having to
translate the symaccesslist back to Pascal code) }
callthroughpropname:='__fpc__'+realname;
if getter then
callthroughpropname:=callthroughpropname+'__getter_wrapper'
else
callthroughpropname:=callthroughpropname+'__setter_wrapper';
callthroughprop:=cpropertysym.create(callthroughpropname);
callthroughprop.visibility:=visibility;
if getter then
makeduplicate(callthroughprop,accessorparapd,nil,paranr)
else
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 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]:=propaccesslist[accesstyp];
propaccesslist[accesstyp]:=tmpaccesslist;
owner.insert(callthroughprop);
pd.skpara:=callthroughprop;
{ needs to be exported }
include(pd.procoptions,po_global);
{ class property -> static class method }
if sp_static in 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 }
propaccesslist[accesstyp].addsym(sl_call,ps);
propaccesslist[accesstyp].procdef:=pd;
finally
symtablestack.pop(obj.symtable);
end;
end;
procedure tcpupropertysym.finalize_getter_or_setter_for_sym(getset: tpropaccesslisttypes; sym: tsym; fielddef: tdef; accessordef: tprocdef);
var
orgaccesspd: tprocdef;
pprefix: pstring;
wrongvisibility: boolean;
begin
inherited;
if getset=palt_read then
pprefix:=@prop_auto_getter_prefix
else
pprefix:=@prop_auto_setter_prefix;
case sym.typ of
procsym:
begin
orgaccesspd:=tprocdef(propaccesslist[getset].procdef);
wrongvisibility:=tprocdef(propaccesslist[getset].procdef).visibility<visibility;
if (pprefix^<>'') and
(wrongvisibility or
(sym.RealName<>pprefix^+RealName)) then
create_getter_or_setter_for_property(orgaccesspd,getset=palt_read)
{ if the visibility of the accessor 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 }
else if wrongvisibility then
begin
propaccesslist[getset].procdef:=jvm_wrap_method_with_vis(tprocdef(propaccesslist[palt_read].procdef),visibility);
propaccesslist[getset].firstsym^.sym:=tprocdef(propaccesslist[getset].procdef).procsym;
end;
end;
fieldvarsym:
begin
{ if the visibility of the field is lower than the
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 (pprefix^<>'') or
(tfieldvarsym(sym).visibility<visibility) then
create_getter_or_setter_for_property(nil,getset=palt_read);
end;
else
internalerror(2014061101);
end;
end;
{**************************************************************************** {****************************************************************************
tcpuenumdef tcpuenumdef
****************************************************************************} ****************************************************************************}

163
compiler/pdecvar.pas
View File

@ -520,79 +520,21 @@ implementation
if not(is_dispinterface(astruct)) then if not(is_dispinterface(astruct)) then
begin begin
{ parse accessors }
if try_to_consume(_READ) then if try_to_consume(_READ) then
begin begin
p.propaccesslist[palt_read].clear; p.propaccesslist[palt_read].clear;
if parse_symlist(p.propaccesslist[palt_read],def) then if parse_symlist(p.propaccesslist[palt_read],def) then
begin begin
sym:=p.propaccesslist[palt_read].firstsym^.sym; sym:=p.propaccesslist[palt_read].firstsym^.sym;
case sym.typ of { getter is a function returning the type of the property }
procsym : if sym.typ=procsym then
begin begin
{ read is function returning the type of the property } readprocdef.returndef:=p.propdef;
readprocdef.returndef:=p.propdef; { Insert hidden parameters }
{ Insert hidden parameters } handle_calling_convention(readprocdef);
handle_calling_convention(readprocdef); end;
{ search procdefs matching readprocdef } p.add_getter_or_setter_for_sym(palt_read,sym,def,readprocdef);
{ we ignore hidden stuff here because the property access symbol might have
non default calling conventions which might change the hidden stuff;
see tw3216.pp (FK) }
p.propaccesslist[palt_read].procdef:=Tprocsym(sym).Find_procdef_bypara(readprocdef.paras,p.propdef,[cpo_allowdefaults,cpo_ignorehidden]);
if not assigned(p.propaccesslist[palt_read].procdef) or
{ because of cpo_ignorehidden we need to compare if it is a static class method and we have a class property }
((sp_static in p.symoptions) <> tprocdef(p.propaccesslist[palt_read].procdef).no_self_node) then
Message(parser_e_ill_property_access_sym)
else
begin
{$ifdef jvm}
orgaccesspd:=tprocdef(p.propaccesslist[palt_read].procdef);
wrongvisibility:=tprocdef(p.propaccesslist[palt_read].procdef).visibility<p.visibility;
if (prop_auto_getter_prefix<>'') and
(wrongvisibility or
(p.propaccesslist[palt_read].firstsym^.sym.RealName<>prop_auto_getter_prefix+p.RealName)) then
jvm_create_getter_for_property(p,orgaccesspd)
{ 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
property is visible }
else if wrongvisibility then
begin
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;
{$endif jvm}
end;
end;
fieldvarsym :
begin
if not assigned(def) then
internalerror(200310071);
if compare_defs(def,p.propdef,nothingn)>=te_equal then
begin
{ property parameters are allowed if this is
an indexed property, because the index is then
the parameter.
Note: In the help of Kylix it is written
that it isn't allowed, but the compiler accepts it (PFV) }
if (ppo_hasparameters in p.propoptions) or
((sp_static in p.symoptions) <> (sp_static in sym.symoptions)) then
Message(parser_e_ill_property_access_sym);
{$ifdef jvm}
{ if the visibility of the field is lower than the
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 (prop_auto_getter_prefix<>'') or
(tfieldvarsym(sym).visibility<p.visibility) then
jvm_create_getter_for_property(p,nil);
{$endif}
end
else
IncompatibleTypes(def,p.propdef);
end;
else
Message(parser_e_ill_property_access_sym);
end;
end; end;
end; end;
if try_to_consume(_WRITE) then if try_to_consume(_WRITE) then
@ -601,81 +543,18 @@ implementation
if parse_symlist(p.propaccesslist[palt_write],def) then if parse_symlist(p.propaccesslist[palt_write],def) then
begin begin
sym:=p.propaccesslist[palt_write].firstsym^.sym; sym:=p.propaccesslist[palt_write].firstsym^.sym;
case sym.typ of if sym.typ=procsym then
procsym : begin
begin { settter is a procedure with an extra value parameter
{ write is a procedure with an extra value parameter of the of the property }
of the of the property } writeprocdef.returndef:=voidtype;
writeprocdef.returndef:=voidtype; inc(paranr);
inc(paranr); hparavs:=cparavarsym.create('$value',10*paranr,vs_value,p.propdef,[]);
hparavs:=cparavarsym.create('$value',10*paranr,vs_value,p.propdef,[]); writeprocdef.parast.insert(hparavs);
writeprocdef.parast.insert(hparavs); { Insert hidden parameters }
{ Insert hidden parameters } handle_calling_convention(writeprocdef);
handle_calling_convention(writeprocdef); end;
{ search procdefs matching writeprocdef } p.add_getter_or_setter_for_sym(palt_write,sym,def,writeprocdef);
{ skip hidden part (same as for _READ part ) because of the }
{ possible different calling conventions and especialy for }
{ records - their methods hidden parameters are handled }
{ after the full record parse }
if cs_varpropsetter in current_settings.localswitches then
p.propaccesslist[palt_write].procdef:=Tprocsym(sym).Find_procdef_bypara(writeprocdef.paras,writeprocdef.returndef,[cpo_allowdefaults,cpo_ignorevarspez,cpo_ignorehidden])
else
p.propaccesslist[palt_write].procdef:=Tprocsym(sym).Find_procdef_bypara(writeprocdef.paras,writeprocdef.returndef,[cpo_allowdefaults,cpo_ignorehidden]);
if not assigned(p.propaccesslist[palt_write].procdef) or
{ because of cpo_ignorehidden we need to compare if it is a static class method and we have a class property }
((sp_static in p.symoptions) <> tprocdef(p.propaccesslist[palt_write].procdef).no_self_node) then
Message(parser_e_ill_property_access_sym)
else
begin
{$ifdef jvm}
orgaccesspd:=tprocdef(p.propaccesslist[palt_write].procdef);
wrongvisibility:=tprocdef(p.propaccesslist[palt_write].procdef).visibility<p.visibility;
if (prop_auto_setter_prefix<>'') and
((sym.RealName<>prop_auto_setter_prefix+p.RealName) or
wrongvisibility) then
jvm_create_setter_for_property(p,orgaccesspd)
{ 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 }
else if wrongvisibility then
begin
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;
{$endif jvm}
end;
end;
fieldvarsym :
begin
if not assigned(def) then
internalerror(200310072);
if compare_defs(def,p.propdef,nothingn)>=te_equal then
begin
{ property parameters are allowed if this is
an indexed property, because the index is then
the parameter.
Note: In the help of Kylix it is written
that it isn't allowed, but the compiler accepts it (PFV) }
if (ppo_hasparameters in p.propoptions) or
((sp_static in p.symoptions) <> (sp_static in sym.symoptions)) then
Message(parser_e_ill_property_access_sym);
{$ifdef jvm}
{ if the visibility of the field is lower than the
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 (prop_auto_setter_prefix<>'') or
(tfieldvarsym(sym).visibility<p.visibility) then
jvm_create_setter_for_property(p,nil);
{$endif}
end
else
IncompatibleTypes(def,p.propdef);
end;
else
Message(parser_e_ill_property_access_sym);
end;
end; end;
end; end;
end end

60
compiler/symsym.pas
View File

@ -317,6 +317,9 @@ interface
tpropaccesslisttypes=(palt_none,palt_read,palt_write,palt_stored); tpropaccesslisttypes=(palt_none,palt_read,palt_write,palt_stored);
tpropertysym = class(Tstoredsym) tpropertysym = class(Tstoredsym)
protected
procedure finalize_getter_or_setter_for_sym(getset: tpropaccesslisttypes; sym: tsym; fielddef: tdef; accessordef: tprocdef); virtual;
public
propoptions : tpropertyoptions; propoptions : tpropertyoptions;
overriddenpropsym : tpropertysym; overriddenpropsym : tpropertysym;
overriddenpropsymderef : tderef; overriddenpropsymderef : tderef;
@ -344,6 +347,8 @@ interface
procedure makeduplicate(p: tpropertysym; readprocdef, writeprocdef: tprocdef; out paranr: word); procedure makeduplicate(p: tpropertysym; readprocdef, writeprocdef: tprocdef; out paranr: word);
procedure add_accessor_parameters(readprocdef, writeprocdef: tprocdef); procedure add_accessor_parameters(readprocdef, writeprocdef: tprocdef);
procedure add_index_parameter(var paranr: word; readprocdef, writeprocdef: tprocdef); 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);
end; end;
tpropertysymclass = class of tpropertysym; tpropertysymclass = class of tpropertysym;
@ -1228,6 +1233,12 @@ implementation
TPROPERTYSYM TPROPERTYSYM
****************************************************************************} ****************************************************************************}
procedure tpropertysym.finalize_getter_or_setter_for_sym(getset: tpropaccesslisttypes; sym: tsym; fielddef: tdef; accessordef: tprocdef);
begin
{ do nothing by default }
end;
constructor tpropertysym.create(const n : string); constructor tpropertysym.create(const n : string);
var var
pap : tpropaccesslisttypes; pap : tpropaccesslisttypes;
@ -1376,6 +1387,55 @@ implementation
end; end;
procedure tpropertysym.add_getter_or_setter_for_sym(getset: tpropaccesslisttypes; sym: tsym; fielddef: tdef; accessordef: tprocdef);
var
cpo: tcompare_paras_options;
begin
case sym.typ of
procsym :
begin
{ search procdefs matching accessordef }
{ we ignore hidden stuff here because the property access symbol might have
non default calling conventions which might change the hidden stuff;
see tw3216.pp (FK) }
cpo:=[cpo_allowdefaults,cpo_ignorehidden];
{ allow var-parameters for setters in case of VARPROPSETTER+ }
if (getset=palt_write) and
(cs_varpropsetter in current_settings.localswitches) then
include(cpo,cpo_ignorevarspez);
propaccesslist[getset].procdef:=tprocsym(sym).find_procdef_bypara(accessordef.paras,accessordef.returndef,cpo);
if not assigned(propaccesslist[getset].procdef) or
{ because of cpo_ignorehidden we need to compare if it is a static class method and we have a class property }
((sp_static in symoptions)<>tprocdef(propaccesslist[getset].procdef).no_self_node) then
Message(parser_e_ill_property_access_sym)
else
finalize_getter_or_setter_for_sym(getset,sym,fielddef,accessordef);
end;
fieldvarsym :
begin
if not assigned(fielddef) then
internalerror(200310071);
if compare_defs(fielddef,propdef,nothingn)>=te_equal then
begin
{ property parameters are allowed if this is
an indexed property, because the index is then
the parameter.
Note: In the help of Kylix it is written
that it isn't allowed, but the compiler accepts it (PFV) }
if (ppo_hasparameters in propoptions) or
((sp_static in symoptions) <> (sp_static in sym.symoptions)) then
Message(parser_e_ill_property_access_sym)
else
finalize_getter_or_setter_for_sym(getset,sym,fielddef,accessordef);
end
else
IncompatibleTypes(fielddef,propdef);
end;
else
Message(parser_e_ill_property_access_sym);
end;
end;
procedure tpropertysym.makeduplicate(p: tpropertysym; readprocdef, writeprocdef: tprocdef; out paranr: word); procedure tpropertysym.makeduplicate(p: tpropertysym; readprocdef, writeprocdef: tprocdef; out paranr: word);
begin begin