fpc/compiler/wasm32/symcpu.pas
2020-09-11 14:35:51 +00:00

698 lines
24 KiB
ObjectPascal
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

{
Copyright (c) 2014 by Florian Klaempfl
Symbol table overrides for WebAssembly
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
****************************************************************************
}
unit symcpu;
{$i fpcdefs.inc}
interface
uses
globtype,
aasmdata,
symtype,
symdef,symsym,
cgutils;
type
{ defs }
tcpufiledef = class(tfiledef)
end;
tcpufiledefclass = class of tcpufiledef;
tcpuvariantdef = class(tvariantdef)
end;
tcpuvariantdefclass = class of tcpuvariantdef;
tcpuformaldef = class(tformaldef)
end;
tcpuformaldefclass = class of tcpuformaldef;
tcpuforwarddef = class(tforwarddef)
end;
tcpuforwarddefclass = class of tcpuforwarddef;
tcpuundefineddef = class(tundefineddef)
end;
tcpuundefineddefclass = class of tcpuundefineddef;
tcpuerrordef = class(terrordef)
end;
tcpuerrordefclass = class of tcpuerrordef;
tcpupointerdef = class(tpointerdef)
end;
tcpupointerdefclass = class of tcpupointerdef;
tcpurecorddef = class(trecorddef)
end;
tcpurecorddefclass = class of tcpurecorddef;
tcpuimplementedinterface = class(timplementedinterface)
end;
tcpuimplementedinterfaceclass = class of tcpuimplementedinterface;
tcpuobjectdef = class(tobjectdef)
end;
tcpuobjectdefclass = class of tcpuobjectdef;
tcpuclassrefdef = class(tclassrefdef)
end;
tcpuclassrefdefclass = class of tcpuclassrefdef;
tcpuarraydef = class(tarraydef)
end;
tcpuarraydefclass = class of tcpuarraydef;
tcpuorddef = class(torddef)
end;
tcpuorddefclass = class of tcpuorddef;
tcpufloatdef = class(tfloatdef)
end;
tcpufloatdefclass = class of tcpufloatdef;
{ tcpuprocvardef }
tcpuprocvardef = class(tprocvardef)
end;
tcpuprocvardefclass = class of tcpuprocvardef;
{ tcpuprocdef }
tcpuprocdef = class(tprocdef)
frame_pointer_ref,
base_pointer_ref: treference;
{ generated assembler code; used by WebAssembly backend so it can afterwards
easily write out all methods grouped per class }
exprasmlist : TAsmList;
destructor destroy; override;
end;
tcpuprocdefclass = class of tcpuprocdef;
tcpustringdef = class(tstringdef)
end;
tcpustringdefclass = class of tcpustringdef;
tcpuenumdef = class(tenumdef)
protected
procedure ppuload_platform(ppufile: tcompilerppufile); override;
procedure ppuwrite_platform(ppufile: tcompilerppufile); override;
public
{ class representing this enum on the Java side }
classdef : tobjectdef;
classdefderef : tderef;
function getcopy: tstoreddef; override;
procedure buildderef; override;
procedure deref; override;
end;
tcpuenumdefclass = class of tcpuenumdef;
tcpusetdef = class(tsetdef)
end;
tcpusetdefclass = class of tcpusetdef;
{ syms }
tcpulabelsym = class(tlabelsym)
end;
tcpulabelsymclass = class of tcpulabelsym;
tcpuunitsym = class(tunitsym)
end;
tcpuunitsymclass = class of tcpuunitsym;
tcpuprogramparasym = class(tprogramparasym)
end;
tcpuprogramparasymclass = class(tprogramparasym);
tcpunamespacesym = class(tnamespacesym)
end;
tcpunamespacesymclass = class of tcpunamespacesym;
{ tcpuprocsym }
tcpuprocsym = class(tprocsym)
end;
tcpuprocsymclass = class of tcpuprocsym;
tcputypesym = class(ttypesym)
end;
tcpuypesymclass = class of tcputypesym;
tcpufieldvarsym = class(tfieldvarsym)
end;
tcpufieldvarsymclass = class of tcpufieldvarsym;
tcpulocalvarsym = class(tlocalvarsym)
end;
tcpulocalvarsymclass = class of tcpulocalvarsym;
tcpuparavarsym = class(tparavarsym)
end;
tcpuparavarsymclass = class of tcpuparavarsym;
tcpustaticvarsym = class(tstaticvarsym)
end;
tcpustaticvarsymclass = class of tcpustaticvarsym;
tcpuabsolutevarsym = class(tabsolutevarsym)
end;
tcpuabsolutevarsymclass = class of tcpuabsolutevarsym;
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;
procedure maybe_create_overridden_getter_or_setter(getset: tpropaccesslisttypes);
public
procedure inherit_accessor(getset: tpropaccesslisttypes); override;
end;
tcpupropertysymclass = class of tcpupropertysym;
tcpuconstsym = class(tconstsym)
end;
tcpuconstsymclass = class of tcpuconstsym;
tcpuenumsym = class(tenumsym)
end;
tcpuenumsymclass = class of tcpuenumsym;
tcpusyssym = class(tsyssym)
end;
tcpusyssymclass = class of tcpusyssym;
const
pbestrealtype : ^tdef = @s64floattype;
implementation
uses
verbose,cutils,cclasses,globals,
symconst,symbase,symtable,symcreat,wasmdef,
pdecsub,pparautl,paramgr,
// high-level code generator is needed to get access to type index for ncall
hlcgobj,hlcgcpu
;
{****************************************************************************
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;
accessortyp: tprocoption;
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;
if getter then
accessortyp:=po_is_auto_getter
else
accessortyp:=po_is_auto_setter;
procoptions:=[accessortyp];
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 assigned(sym) then
begin
if ((sym.typ<>procsym) or
(tprocsym(sym).procdeflist.count<>1) or
not(accessortyp in tprocdef(tprocsym(sym).procdeflist[0]).procoptions)) 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];
if not(parentpd.synthetickind in [tsk_field_getter,tsk_field_setter]) then
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.getcopyas(procdef,pc_normal_no_hidden,''));
{ 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;
{ set the accessor in the property }
propaccesslist[accesstyp].clear;
propaccesslist[accesstyp].addsym(sl_call,pd.procsym);
propaccesslist[accesstyp].procdef:=pd;
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,true);
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.unique_id_str }
if not explicitwrapper then
accessorname:='$'+obj.symtable.realname^+'$'+realname+'$'+accessorname+'$'+pd.unique_id_str;
end
else
begin
{ getter/setter could have parameters in case of indexed access
-> copy original procdef }
pd:=tprocdef(orgaccesspd.getcopyas(procdef,pc_normal_no_hidden,''));
exclude(pd.procoptions,po_abstractmethod);
exclude(pd.procoptions,po_overridingmethod);
{ can only construct the artificial accessorname now, because it requires
pd.unique_id_str }
if not explicitwrapper then
accessorname:='$'+obj.symtable.realname^+'$'+realname+'$'+accessorname+'$'+pd.unique_id_str;
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 }
handle_calling_convention(pd,hcc_default_actions_intf_struct);
{ 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: pshortstring;
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 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 }
if wrongvisibility or
((pprefix^<>'') and
(sym.RealName<>pprefix^+RealName)) then
create_getter_or_setter_for_property(orgaccesspd,getset=palt_read)
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;
procedure tcpupropertysym.maybe_create_overridden_getter_or_setter(getset: tpropaccesslisttypes);
var
sym: tsym;
accessordef: tprocdef;
psym: tpropertysym;
begin
{ find the last defined getter/setter/field accessed by an inherited
property }
psym:=overriddenpropsym;
while not assigned(psym.propaccesslist[getset].firstsym) do
begin
psym:=psym.overriddenpropsym;
{ if there is simply no getter/setter for this property, we're done }
if not assigned(psym) then
exit;
end;
sym:=psym.propaccesslist[getset].firstsym^.sym;
case sym.typ of
procsym:
begin
accessordef:=tprocdef(psym.propaccesslist[getset].procdef);
if accessordef.visibility>=visibility then
exit;
end;
fieldvarsym:
begin
if sym.visibility>=visibility then
exit;
accessordef:=nil;
end;
else
internalerror(2014061102);
end;
propaccesslist[getset]:=psym.propaccesslist[getset].getcopy;
finalize_getter_or_setter_for_sym(getset,sym,propdef,accessordef);
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
****************************************************************************}
procedure tcpuenumdef.ppuload_platform(ppufile: tcompilerppufile);
begin
inherited;
ppufile.getderef(classdefderef);
end;
procedure tcpuenumdef.ppuwrite_platform(ppufile: tcompilerppufile);
begin
inherited;
ppufile.putderef(classdefderef);
end;
function tcpuenumdef.getcopy: tstoreddef;
begin
result:=inherited;
tcpuenumdef(result).classdef:=classdef;
end;
procedure tcpuenumdef.buildderef;
begin
inherited;
classdefderef.build(classdef);
end;
procedure tcpuenumdef.deref;
begin
inherited;
classdef:=tobjectdef(classdefderef.resolve);
end;
{****************************************************************************
tcpuprocdef
****************************************************************************}
destructor tcpuprocdef.destroy;
begin
exprasmlist.free;
inherited destroy;
end;
{****************************************************************************
tcpuprocvardef
****************************************************************************}
{****************************************************************************
tcpuprocsym
****************************************************************************}
{****************************************************************************
tcpustaticvarsym
****************************************************************************}
{****************************************************************************
tcpufieldvarsym
****************************************************************************}
initialization
{ used tdef classes }
cfiledef:=tcpufiledef;
cvariantdef:=tcpuvariantdef;
cformaldef:=tcpuformaldef;
cforwarddef:=tcpuforwarddef;
cundefineddef:=tcpuundefineddef;
cerrordef:=tcpuerrordef;
cpointerdef:=tcpupointerdef;
crecorddef:=tcpurecorddef;
cimplementedinterface:=tcpuimplementedinterface;
cobjectdef:=tcpuobjectdef;
cclassrefdef:=tcpuclassrefdef;
carraydef:=tcpuarraydef;
corddef:=tcpuorddef;
cfloatdef:=tcpufloatdef;
cprocvardef:=tcpuprocvardef;
cprocdef:=tcpuprocdef;
cstringdef:=tcpustringdef;
cenumdef:=tcpuenumdef;
csetdef:=tcpusetdef;
{ used tsym classes }
clabelsym:=tcpulabelsym;
cunitsym:=tcpuunitsym;
cprogramparasym:=tcpuprogramparasym;
cnamespacesym:=tcpunamespacesym;
cprocsym:=tcpuprocsym;
ctypesym:=tcputypesym;
cfieldvarsym:=tcpufieldvarsym;
clocalvarsym:=tcpulocalvarsym;
cparavarsym:=tcpuparavarsym;
cstaticvarsym:=tcpustaticvarsym;
cabsolutevarsym:=tcpuabsolutevarsym;
cpropertysym:=tcpupropertysym;
cconstsym:=tcpuconstsym;
cenumsym:=tcpuenumsym;
csyssym:=tcpusyssym;
end.