freepascal.compiler/compiler/wasm32/symcpu.pas

{
    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.