fpc/compiler/nmem.pas

{
    Copyright (c) 2000-2002 by Florian Klaempfl

    Type checking and register allocation for memory related nodes

    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 nmem;

{$i fpcdefs.inc}

interface

    uses
       node,
       symdef,symsym,symtable,symtype;

    type
       tloadvmtaddrnode = class(tunarynode)
          { unless this is for a call, we have to send the "class" message to
            the objctype because the type information only gets initialized
            after the first message has been sent -> crash if you pass an
            uninitialized type to e.g. class_getInstanceSize() or so. No need
            to save to/restore from ppu. }
          forcall: boolean;
          constructor create(l : tnode);virtual;
          function pass_1 : tnode;override;
          function pass_typecheck:tnode;override;
          function docompare(p: tnode): boolean; override;
          function dogetcopy: tnode; override;
       end;
       tloadvmtaddrnodeclass = class of tloadvmtaddrnode;

       tloadparentfpkind = (
         { as parameter to a nested routine (current routine's frame) }
         lpf_forpara,
         { to load a local from a parent routine in the current nested routine
           (some parent routine's frame) }
         lpf_forload
       );
       tloadparentfpnode = class(tunarynode)
          parentpd : tprocdef;
          parentpdderef : tderef;
          kind: tloadparentfpkind;
          constructor create(pd: tprocdef; fpkind: tloadparentfpkind);virtual;
          constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
          procedure ppuwrite(ppufile:tcompilerppufile);override;
          procedure buildderefimpl;override;
          procedure derefimpl;override;
          function pass_1 : tnode;override;
          function pass_typecheck:tnode;override;
          function docompare(p: tnode): boolean; override;
          function dogetcopy : tnode;override;
       end;
       tloadparentfpnodeclass = class of tloadparentfpnode;

       taddrnodeflag = (
          { generated by the Ofs() internal function }
          anf_ofs,
          anf_typedaddr
       );
       taddrnodeflags = set of taddrnodeflag;

       taddrnode = class(tunarynode)
          getprocvardef : tprocvardef;
          getprocvardefderef : tderef;
          addrnodeflags : taddrnodeflags;
          constructor create(l : tnode);virtual;
          constructor create_internal(l : tnode); virtual;
          constructor create_internal_nomark(l : tnode); virtual;
          constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
          procedure ppuwrite(ppufile:tcompilerppufile);override;
          procedure mark_write;override;
          procedure buildderefimpl;override;
          procedure derefimpl;override;
          procedure printnodeinfo(var t: text); override;
{$ifdef DEBUG_NODE_XML}
          procedure XMLPrintNodeInfo(var T: Text); override;
{$endif DEBUG_NODE_XML}
          function docompare(p: tnode): boolean; override;
          function dogetcopy : tnode;override;
          function pass_1 : tnode;override;
          function pass_typecheck:tnode;override;
          function simplify(forinline : boolean) : tnode; override;
         protected
          mark_read_written: boolean;
          procedure set_labelsym_resultdef; virtual;
          function typecheck_non_proc(realsource: tnode; out res: tnode): boolean; virtual;
       end;
       taddrnodeclass = class of taddrnode;

       tderefnode = class(tunarynode)
          constructor create(l : tnode);virtual;
          function pass_1 : tnode;override;
          function pass_typecheck:tnode;override;
          procedure mark_write;override;
       end;
       tderefnodeclass = class of tderefnode;

       tsubscriptnode = class(tunarynode)
          vs : tfieldvarsym;
          vsderef : tderef;
          constructor create(varsym : tsym;l : tnode);virtual;
          constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
          procedure ppuwrite(ppufile:tcompilerppufile);override;
          procedure buildderefimpl;override;
          procedure derefimpl;override;
          function dogetcopy : tnode;override;
          function pass_1 : tnode;override;
          function docompare(p: tnode): boolean; override;
          function pass_typecheck:tnode;override;
          procedure mark_write;override;
{$ifdef DEBUG_NODE_XML}
          procedure XMLPrintNodeData(var T: Text); override;
{$endif DEBUG_NODE_XML}
       end;
       tsubscriptnodeclass = class of tsubscriptnode;

       tvecnode = class(tbinarynode)
       protected
          function first_arraydef: tnode; virtual;
          function gen_array_rangecheck: tnode; virtual;
       public
          constructor create(l,r : tnode);virtual;
          function pass_1 : tnode;override;
          function pass_typecheck:tnode;override;
          procedure mark_write;override;
{$ifdef DEBUG_NODE_XML}
          procedure XMLPrintNodeData(var T: Text); override;
{$endif DEBUG_NODE_XML}
       end;
       tvecnodeclass = class of tvecnode;

    var
       cloadvmtaddrnode : tloadvmtaddrnodeclass= tloadvmtaddrnode;
       caddrnode : taddrnodeclass= taddrnode;
       cderefnode : tderefnodeclass= tderefnode;
       csubscriptnode : tsubscriptnodeclass= tsubscriptnode;
       cvecnode : tvecnodeclass= tvecnode;
       cloadparentfpnode : tloadparentfpnodeclass = tloadparentfpnode;

    function is_big_untyped_addrnode(p: tnode): boolean;

implementation

    uses
      globtype,systems,constexp,
      cutils,verbose,globals,
      symconst,defutil,defcmp,
      nadd,nbas,nflw,nutils,objcutil,
      wpobase,
{$ifdef i8086}
      cpuinfo,
{$endif i8086}
      htypechk,pass_1,ncal,nld,ncon,ncnv,cgbase,procinfo
      ;

{*****************************************************************************
                            TLOADVMTADDRNODE
*****************************************************************************}

    constructor tloadvmtaddrnode.create(l : tnode);
      begin
         inherited create(loadvmtaddrn,l);
      end;


    function tloadvmtaddrnode.pass_typecheck:tnode;
      var
        defaultresultdef : boolean;
      begin
        result:=nil;
        typecheckpass(left);
        if codegenerror then
         exit;

        case left.resultdef.typ of
          classrefdef :
            resultdef:=left.resultdef;
          recorddef,
          objectdef:
            begin
              if (left.resultdef.typ=objectdef) or
                 ((target_info.system in systems_jvm) and
                  (left.resultdef.typ=recorddef)) then
                begin
                  { access to the classtype while specializing? }
                  if tstoreddef(left.resultdef).is_generic then
                    begin
                      defaultresultdef:=true;
                      if assigned(current_structdef) then
                        begin
                          if assigned(current_structdef.genericdef) then
                            if current_structdef.genericdef=left.resultdef then
                              begin
                                resultdef:=cclassrefdef.create(current_structdef);
                                defaultresultdef:=false;
                              end
                            else
                              CGMessage(parser_e_cant_create_generics_of_this_type);
                        end
                      else
                        message(parser_e_cant_create_generics_of_this_type);
                      if defaultresultdef then
                        resultdef:=cclassrefdef.create(left.resultdef);
                    end
                  else
                    resultdef:=cclassrefdef.create(left.resultdef);
                end
              else
                CGMessage(parser_e_pointer_to_class_expected);
            end
          else
            CGMessage(parser_e_pointer_to_class_expected);
        end;
      end;


    function tloadvmtaddrnode.docompare(p: tnode): boolean;
      begin
        result:=inherited docompare(p);
        if result then
          result:=forcall=tloadvmtaddrnode(p).forcall;
      end;


    function tloadvmtaddrnode.dogetcopy: tnode;
      begin
        result:=inherited dogetcopy;
        tloadvmtaddrnode(result).forcall:=forcall;
      end;


    function tloadvmtaddrnode.pass_1 : tnode;
      var
        vs: tsym;
      begin
         result:=nil;
         expectloc:=LOC_REGISTER;
         if left.nodetype<>typen then
           begin
             if (is_objc_class_or_protocol(left.resultdef) or
                 is_objcclassref(left.resultdef)) then
               begin
                 { on non-fragile ABI platforms, the ISA pointer may be opaque
                   and we must call Object_getClass to obtain the real ISA
                   pointer }
                 if target_info.system in systems_objc_nfabi then
                   begin
                     result:=ccallnode.createinternfromunit('OBJC','OBJECT_GETCLASS',ccallparanode.create(left,nil));
                     inserttypeconv_explicit(result,resultdef);
                   end
                 else
                   result:=objcloadbasefield(left,'ISA');
               end
             else
               result:=ctypeconvnode.create_internal(load_vmt_for_self_node(left),resultdef);
             { reused }
             left:=nil;
           end
         else if not is_objcclass(left.resultdef) and
                 not is_objcclassref(left.resultdef) then
           begin
             if not(nf_ignore_for_wpo in flags) and
                (not assigned(current_procinfo) or
                 (po_inline in current_procinfo.procdef.procoptions) or
                  wpoinfomanager.symbol_live(current_procinfo.procdef.mangledname)) then
             begin
               { keep track of which classes might be instantiated via a classrefdef }
               if (left.resultdef.typ=classrefdef) then
                 tobjectdef(tclassrefdef(left.resultdef).pointeddef).register_maybe_created_object_type
               else if (left.resultdef.typ=objectdef) then
                 tobjectdef(left.resultdef).register_maybe_created_object_type
             end
           end
         else if is_objcclass(left.resultdef) and
              not(forcall) then
           begin
             { call "class" method (= "classclass" in FPC), because otherwise
               we may use the class information before it has been
               initialized }
             vs:=search_struct_member(tobjectdef(left.resultdef),'CLASSCLASS');
             if not assigned(vs) or
                (vs.typ<>procsym) then
               internalerror(2011080601);
             { can't reuse "self", because it will be freed when we return }
             result:=ccallnode.create(nil,tprocsym(vs),vs.owner,self.getcopy,[],nil);
           end;
      end;


{*****************************************************************************
                        TLOADPARENTFPNODE
*****************************************************************************}

    constructor tloadparentfpnode.create(pd: tprocdef; fpkind: tloadparentfpkind);
      begin
        inherited create(loadparentfpn,nil);
        if not assigned(pd) then
          internalerror(200309288);
        if (pd.parast.symtablelevel>current_procinfo.procdef.parast.symtablelevel) then
          internalerror(200309284);
        parentpd:=pd;
        kind:=fpkind;
      end;


    constructor tloadparentfpnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
      begin
        inherited ppuload(t,ppufile);
        ppufile.getderef(parentpdderef);
        kind:=tloadparentfpkind(ppufile.getbyte);
      end;


    procedure tloadparentfpnode.ppuwrite(ppufile:tcompilerppufile);
      begin
        inherited ppuwrite(ppufile);
        ppufile.putderef(parentpdderef);
        ppufile.putbyte(byte(kind));
      end;


    procedure tloadparentfpnode.buildderefimpl;
      begin
        inherited buildderefimpl;
        parentpdderef.build(parentpd);
      end;


    procedure tloadparentfpnode.derefimpl;
      begin
        inherited derefimpl;
        parentpd:=tprocdef(parentpdderef.resolve);
      end;


    function tloadparentfpnode.docompare(p: tnode): boolean;
      begin
        result:=
          inherited docompare(p) and
          (tloadparentfpnode(p).parentpd=parentpd) and
          (tloadparentfpnode(p).kind=kind);
      end;


    function tloadparentfpnode.dogetcopy : tnode;
      var
         p : tloadparentfpnode;
      begin
         p:=tloadparentfpnode(inherited dogetcopy);
         p.parentpd:=parentpd;
         p.kind:=kind;
         dogetcopy:=p;
      end;


    function tloadparentfpnode.pass_typecheck:tnode;
{$ifdef dummy}
      var
        currpi : tprocinfo;
        hsym   : tparavarsym;
{$endif dummy}
      begin
        result:=nil;
        resultdef:=parentfpvoidpointertype;
{$ifdef dummy}
        { currently parentfps are never loaded in registers (FK) }
        if (current_procinfo.procdef.parast.symtablelevel<>parentpd.parast.symtablelevel) then
          begin
            currpi:=current_procinfo;
            { walk parents }
            while (currpi.procdef.owner.symtablelevel>parentpd.parast.symtablelevel) do
              begin
                currpi:=currpi.parent;
                if not assigned(currpi) then
                  internalerror(2005040602);
                hsym:=tparavarsym(currpi.procdef.parast.Find('parentfp'));
                if not assigned(hsym) then
                  internalerror(2005040601);
                hsym.varregable:=vr_none;
              end;
          end;
{$endif dummy}
      end;


    function tloadparentfpnode.pass_1 : tnode;
      begin
        result:=nil;
        expectloc:=LOC_REGISTER;
      end;


{*****************************************************************************
                             TADDRNODE
*****************************************************************************}

    constructor taddrnode.create(l : tnode);

      begin
         inherited create(addrn,l);
         getprocvardef:=nil;
         addrnodeflags:=[];
         mark_read_written := true;
      end;


    constructor taddrnode.create_internal(l : tnode);
      begin
        self.create(l);
        include(flags,nf_internal);
      end;


    constructor taddrnode.create_internal_nomark(l : tnode);
      begin
        self.create_internal(l);
        mark_read_written := false;
      end;


    constructor taddrnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
      begin
        inherited ppuload(t,ppufile);
        ppufile.getderef(getprocvardefderef);
        ppufile.getsmallset(addrnodeflags);
      end;


    procedure taddrnode.ppuwrite(ppufile:tcompilerppufile);
      begin
        inherited ppuwrite(ppufile);
        ppufile.putderef(getprocvardefderef);
        ppufile.putsmallset(addrnodeflags);
      end;

    procedure Taddrnode.mark_write;

    begin
      {@procvar:=nil is legal in Delphi mode.}
      left.mark_write;
    end;

    procedure taddrnode.buildderefimpl;
      begin
        inherited buildderefimpl;
        getprocvardefderef.build(getprocvardef);
      end;


    procedure taddrnode.derefimpl;
      begin
        inherited derefimpl;
        getprocvardef:=tprocvardef(getprocvardefderef.resolve);
      end;


    procedure taddrnode.printnodeinfo(var t: text);
      var
        first: Boolean;
        i: taddrnodeflag;
      begin
        inherited printnodeinfo(t);
        write(t,', addrnodeflags = [');
        first:=true;
        for i:=low(taddrnodeflag) to high(taddrnodeflag) do
          if i in addrnodeflags then
            begin
              if not first then
                write(t,',')
              else
                first:=false;
              write(t,i);
            end;
        write(t,']');
      end;

{$ifdef DEBUG_NODE_XML}
    procedure TAddrNode.XMLPrintNodeInfo(var T: Text);
      var
        First: Boolean;
        i: TAddrNodeFlag;
      begin
        inherited XMLPrintNodeInfo(t);
        First := True;
        for i := Low(TAddrNodeFlag) to High(TAddrNodeFlag) do
          if i in addrnodeflags then
            begin
              if First then
                begin
                  Write(T, ' addrnodeflags="', i);
                  First := False;
                end
              else
                Write(T, ',', i);
            end;
        if not First then
          Write(T, '"');
      end;
{$endif DEBUG_NODE_XML}

    function taddrnode.docompare(p: tnode): boolean;
      begin
        result:=
          inherited docompare(p) and
          (taddrnode(p).getprocvardef=getprocvardef) and
          (taddrnode(p).addrnodeflags=addrnodeflags);
      end;


    function taddrnode.dogetcopy : tnode;
      var
         p : taddrnode;
      begin
         p:=taddrnode(inherited dogetcopy);
         p.getprocvardef:=getprocvardef;
         p.addrnodeflags:=addrnodeflags;
         dogetcopy:=p;
      end;


    function taddrnode.pass_typecheck:tnode;
      var
         hp : tnode;
         hsym : tfieldvarsym;
         isprocvar,need_conv_to_voidptr: boolean;
         procpointertype: tdef;
      begin
        result:=nil;
        typecheckpass(left);
        if codegenerror then
         exit;

        make_not_regable(left,[ra_addr_regable,ra_addr_taken]);

        { don't allow constants, for internal use we also
          allow taking the address of strings and sets }
        if is_constnode(left) and
           not(
               (nf_internal in flags) and
               (left.nodetype in [stringconstn,setconstn])
              ) then
         begin
           CGMessagePos(left.fileinfo,type_e_no_addr_of_constant);
           exit;
         end;

        { Handle @proc special, also @procvar in tp-mode needs
          special handling }
        if (left.resultdef.typ=procdef) or
           (
            { in case of nf_internal, follow the normal FPC semantics so that
              we can easily get the actual address of a procvar }
            not(nf_internal in flags) and
            (left.resultdef.typ=procvardef) and
            ((m_tp_procvar in current_settings.modeswitches) or
             (m_mac_procvar in current_settings.modeswitches))
           ) then
          begin
            isprocvar:=(left.resultdef.typ=procvardef);
            need_conv_to_voidptr:=
              (m_tp_procvar in current_settings.modeswitches) or
              (m_mac_procvar in current_settings.modeswitches);

            if not isprocvar then
              begin
                left:=ctypeconvnode.create_proc_to_procvar(left);
                if need_conv_to_voidptr then
                  include(ttypeconvnode(left).convnodeflags,tcnf_proc_2_procvar_2_voidpointer);
                if anf_ofs in addrnodeflags then
                  include(ttypeconvnode(left).convnodeflags,tcnf_proc_2_procvar_get_offset_only);
                left.fileinfo:=fileinfo;
                typecheckpass(left);
              end;

            { In tp procvar mode the result is always a voidpointer. Insert
              a typeconversion to voidpointer. For methodpointers we need
              to load the proc field }
            if need_conv_to_voidptr then
              begin
                if tabstractprocdef(left.resultdef).is_addressonly then
                  begin
                    if anf_ofs in addrnodeflags then
                      result:=ctypeconvnode.create_internal(left,tabstractprocdef(left.resultdef).ofs_address_type)
                    else
                      result:=ctypeconvnode.create_internal(left,voidcodepointertype);
                    include(result.flags,nf_load_procvar);
                    left:=nil;
                  end
                else
                  begin
                    { For procvars and for nested routines we need to return
                      the proc field of the methodpointer }
                    if isprocvar or
                       is_nested_pd(tabstractprocdef(left.resultdef)) then
                      begin
                        if tabstractprocdef(left.resultdef).is_methodpointer then
                          procpointertype:=methodpointertype
                        else
                          procpointertype:=nestedprocpointertype;
                        { find proc field in methodpointer record }
                        hsym:=tfieldvarsym(trecorddef(procpointertype).symtable.Find('proc'));
                        if not assigned(hsym) then
                          internalerror(200412041);
                        { Load tmehodpointer(left).proc }
                        result:=csubscriptnode.create(
                                     hsym,
                                     ctypeconvnode.create_internal(left,procpointertype));
                        left:=nil;
                      end
                    else
                      CGMessage(type_e_variable_id_expected);
                  end;
              end
            else
              begin
                { Return the typeconvn only }
                result:=left;
                left:=nil;
              end;
          end
        else
          begin
            hp:=left;
            while assigned(hp) and (hp.nodetype in [typeconvn,derefn,subscriptn]) do
              hp:=tunarynode(hp).left;
            if not assigned(hp) then
              internalerror(200412042);
            if typecheck_non_proc(hp,result) then
              begin
                if assigned(result) then
                  exit;
              end
            else
              CGMessage(type_e_variable_id_expected);
          end;

        if mark_read_written then
          begin
            { This is actually only "read", but treat it nevertheless as  }
            { modified due to the possible use of pointers                }
            { To avoid false positives regarding "uninitialised"          }
            { warnings when using arrays, perform it in two steps         }
            set_varstate(left,vs_written,[]);
            { vsf_must_be_valid so it doesn't get changed into }
            { vsf_referred_not_inited                          }
            set_varstate(left,vs_read,[vsf_must_be_valid]);
          end;
        if not(assigned(result)) then
          result:=simplify(false);
      end;


    function taddrnode.simplify(forinline : boolean) : tnode;
      var
        hsym : tfieldvarsym;
      begin
        result:=nil;
        if ((left.nodetype=subscriptn) and
          (tsubscriptnode(left).left.nodetype=derefn) and
          (tsubscriptnode(left).left.resultdef.typ=recorddef) and
          (tderefnode(tsubscriptnode(left).left).left.nodetype=niln)) or
          ((left.nodetype=subscriptn) and
          (tsubscriptnode(left).left.nodetype=typeconvn) and
          (tsubscriptnode(left).left.resultdef.typ=recorddef) and
          (ttypeconvnode(tsubscriptnode(left).left).left.nodetype=derefn) and
          (tderefnode(ttypeconvnode(tsubscriptnode(left).left).left).left.nodetype=niln)) then
          begin
            hsym:=tsubscriptnode(left).vs;
            if tabstractrecordsymtable(hsym.owner).is_packed then
              result:=cpointerconstnode.create(hsym.fieldoffset div 8,resultdef)
            else
              result:=cpointerconstnode.create(hsym.fieldoffset,resultdef);
          end;
      end;


    procedure taddrnode.set_labelsym_resultdef;
      begin
        resultdef:=voidcodepointertype;
      end;


    function taddrnode.typecheck_non_proc(realsource: tnode; out res: tnode): boolean;
      var
         hp  : tnode;
         hsym : tfieldvarsym;
         offset: asizeint;
      begin
        result:=false;
        res:=nil;
        if (realsource.nodetype=loadn) and
           (tloadnode(realsource).symtableentry.typ=labelsym) then
          begin
            set_labelsym_resultdef;
            result:=true;
          end
        else if (realsource.nodetype=loadn) and
                (tloadnode(realsource).symtableentry.typ=absolutevarsym) and
                (tabsolutevarsym(tloadnode(realsource).symtableentry).abstyp=toaddr) then
          begin
            offset:=tabsolutevarsym(tloadnode(realsource).symtableentry).addroffset;
            hp:=left;
            while assigned(hp)and(hp.nodetype=subscriptn) do
              begin
                hsym:=tsubscriptnode(hp).vs;
                if tabstractrecordsymtable(hsym.owner).is_packed then
                  begin
                    { can't calculate the address of a non-byte aligned field }
                    if (hsym.fieldoffset mod 8)<>0 then
                      begin
                        CGMessagePos(hp.fileinfo,parser_e_packed_element_no_var_addr);
                        exit
                      end;
                    inc(offset,hsym.fieldoffset div 8)
                  end
                else
                  inc(offset,hsym.fieldoffset);
                hp:=tunarynode(hp).left;
              end;
            if anf_typedaddr in addrnodeflags then
              res:=cpointerconstnode.create(offset,cpointerdef.getreusable(left.resultdef))
            else
              res:=cpointerconstnode.create(offset,voidpointertype);
            result:=true;
          end
        else if (nf_internal in flags) or
           valid_for_addr(left,true) then
          begin
            if not(anf_typedaddr in addrnodeflags) then
              resultdef:=voidpointertype
            else
              resultdef:=cpointerdef.getreusable(left.resultdef);
            result:=true;
          end
      end;


    function taddrnode.pass_1 : tnode;
      begin
         result:=nil;
         firstpass(left);
         if codegenerror then
          exit;

         { is this right for object of methods ?? }
         expectloc:=LOC_REGISTER;
      end;


{*****************************************************************************
                             TDEREFNODE
*****************************************************************************}

    constructor tderefnode.create(l : tnode);
      begin
         inherited create(derefn,l);
      end;


    function tderefnode.pass_typecheck:tnode;
      begin
         result:=nil;
         typecheckpass(left);
         set_varstate(left,vs_read,[vsf_must_be_valid]);
         if codegenerror then
          exit;

         { tp procvar support }
         maybe_call_procvar(left,true);

         if left.resultdef.typ=pointerdef then
           resultdef:=tpointerdef(left.resultdef).pointeddef
         else if left.resultdef.typ=undefineddef then
           resultdef:=cundefineddef.create(true)
         else
           CGMessage(parser_e_invalid_qualifier);
      end;

    procedure Tderefnode.mark_write;

    begin
      include(flags,nf_write);
    end;

    function tderefnode.pass_1 : tnode;
      begin
         result:=nil;
         firstpass(left);
         if codegenerror then
          exit;

         expectloc:=LOC_REFERENCE;
      end;


{*****************************************************************************
                            TSUBSCRIPTNODE
*****************************************************************************}

    constructor tsubscriptnode.create(varsym : tsym;l : tnode);

      begin
         inherited create(subscriptn,l);
         { vs should be changed to tsym! }
         vs:=tfieldvarsym(varsym);
      end;

    constructor tsubscriptnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
      begin
        inherited ppuload(t,ppufile);
        ppufile.getderef(vsderef);
      end;


    procedure tsubscriptnode.ppuwrite(ppufile:tcompilerppufile);
      begin
        inherited ppuwrite(ppufile);
        ppufile.putderef(vsderef);
      end;


    procedure tsubscriptnode.buildderefimpl;
      begin
        inherited buildderefimpl;
        vsderef.build(vs);
      end;


    procedure tsubscriptnode.derefimpl;
      begin
        inherited derefimpl;
        vs:=tfieldvarsym(vsderef.resolve);
      end;


    function tsubscriptnode.dogetcopy : tnode;
      var
         p : tsubscriptnode;
      begin
         p:=tsubscriptnode(inherited dogetcopy);
         p.vs:=vs;
         dogetcopy:=p;
      end;


    function tsubscriptnode.pass_typecheck:tnode;
      begin
        result:=nil;
        typecheckpass(left);
        { tp procvar support }
        maybe_call_procvar(left,true);
        resultdef:=vs.vardef;

        // don't put records from which we load float fields
        // in integer registers
        if (left.resultdef.typ=recorddef) and
           (resultdef.typ=floatdef) then
          make_not_regable(left,[ra_addr_regable]);
      end;

    procedure Tsubscriptnode.mark_write;
      begin
        include(flags,nf_write);
        { if an element of a record is written, then the whole record is changed/it is written to it,
          for data types being implicit pointers this does not apply as the object itself does not change }
        if not(is_implicit_pointer_object_type(left.resultdef)) then
          left.mark_write;
      end;


    function tsubscriptnode.pass_1 : tnode;
      begin
         result:=nil;
         firstpass(left);
         if codegenerror then
          exit;

         { several object types must be dereferenced implicitly }
         if is_implicit_pointer_object_type(left.resultdef) then
           expectloc:=LOC_REFERENCE
         else
           begin
             case left.expectloc of
               { if a floating point value is casted into a record, it
                 can happen that we get here an fpu or mm register }
               LOC_CMMREGISTER,
               LOC_CFPUREGISTER,
               LOC_MMREGISTER,
               LOC_FPUREGISTER,
               LOC_CONSTANT,
               LOC_REGISTER,
               LOC_SUBSETREG:
                 // can happen for function results on win32 and darwin/x86
                 if (left.resultdef.size > sizeof(pint)) then
                   expectloc:=LOC_REFERENCE
                 else
                   expectloc:=LOC_SUBSETREG;
               LOC_CREGISTER,
               LOC_CSUBSETREG:
                 expectloc:=LOC_CSUBSETREG;
               LOC_REFERENCE,
               LOC_CREFERENCE:
                 expectloc:=left.expectloc;
               else internalerror(20060521);
              end;
           end;
      end;

    function tsubscriptnode.docompare(p: tnode): boolean;
      begin
        docompare :=
          inherited docompare(p) and
          (vs = tsubscriptnode(p).vs);
      end;

{$ifdef DEBUG_NODE_XML}
    procedure TSubscriptNode.XMLPrintNodeData(var T: Text);
      begin
        inherited XMLPrintNodeData(T);
        WriteLn(T, PrintNodeIndention, '<field>', vs.Name, '</field>');
      end;
{$endif DEBUG_NODE_XML}

{*****************************************************************************
                               TVECNODE
*****************************************************************************}

    constructor tvecnode.create(l,r : tnode);

      begin
         inherited create(vecn,l,r);
      end;


    function tvecnode.pass_typecheck:tnode;
      var
         htype,elementdef,elementptrdef : tdef;
         newordtyp: tordtype;
         valid : boolean;
      begin
         result:=nil;
         typecheckpass(left);
         typecheckpass(right);

         { implicitly convert stringconstant to stringdef,
           see tbs/tb0476.pp for a test }
         if (left.nodetype=stringconstn) and
            (tstringconstnode(left).cst_type=cst_conststring) then
           begin
             if tstringconstnode(left).len>255 then
               inserttypeconv(left,getansistringdef)
             else
               inserttypeconv(left,cshortstringtype);
           end;

         { In p[1] p is always valid, it is not possible to
           declared a shortstring or normal array that has
           undefined number of elements. Dynamic array and
           ansi/widestring needs to be valid }
         valid:=is_dynamic_array(left.resultdef) or
                is_ansistring(left.resultdef) or
                is_wide_or_unicode_string(left.resultdef) or
                { implicit pointer dereference -> pointer is read }
                (left.resultdef.typ = pointerdef);
         if valid then
           set_varstate(left,vs_read,[vsf_must_be_valid]);
{
         A vecn is, just like a loadn, always part of an expression with its
         own read/write and must_be_valid semantics. Therefore we don't have
         to do anything else here, just like for loadn's
}
         set_varstate(right,vs_read,[vsf_must_be_valid]);
         if codegenerror then
          exit;

         { maybe type conversion for the index value, but
           do not convert range nodes }
         if (right.nodetype<>rangen) then
           case left.resultdef.typ of
             arraydef:
               begin
                 htype:=Tarraydef(left.resultdef).rangedef;
                 if ado_isvariant in Tarraydef(left.resultdef).arrayoptions then
                   {Variant arrays are a special array, can have negative indexes and would therefore
                    need s32bit. However, they should not appear in a vecn, as they are handled in
                    handle_variantarray in pexpr.pas. Therefore, encountering a variant array is an
                    internal error... }
                   internalerror(200707031)
                 { open array and array constructor range checking is handled
                   below at the node level, where the validity of the index
                   will be checked -> use a regular type conversion to either
                   the signed or unsigned native int type to prevent another
                   range check from getting inserted here (unless the type is
                   larger than the int type). Exception: if it's an ordinal
                   constant, because then this check should be performed at
                   compile time }
                 else if is_open_array(left.resultdef) or
                    is_array_constructor(left.resultdef) then
                   begin
                     if is_signed(right.resultdef) and
                        not is_constnode(right) then
                       inserttypeconv(right,sizesinttype)
                     else
                       inserttypeconv(right,sizeuinttype)
                   end
                 else if is_special_array(left.resultdef) then
                   {Arrays without a high bound (dynamic arrays, open arrays) are zero based,
                    convert indexes into these arrays to aword.}
                   inserttypeconv(right,uinttype)
                 { note: <> rather than </>, because indexing e.g. an array 0..0
                     must not result in truncating the indexing value from 2/4/8
                     bytes to 1 byte (with range checking off, the full index
                     value must be used) }
                 else if (htype.typ=enumdef) and
                         (right.resultdef.typ=enumdef) and
                         (tenumdef(htype).basedef=tenumdef(right.resultdef).basedef) and
                    ((tarraydef(left.resultdef).lowrange<>tenumdef(htype).min) or
                     (tarraydef(left.resultdef).highrange<>tenumdef(htype).max)) then
                   {Convert array indexes to low_bound..high_bound.}
                   inserttypeconv(right,cenumdef.create_subrange(tenumdef(right.resultdef),
                                                      asizeint(Tarraydef(left.resultdef).lowrange),
                                                      asizeint(Tarraydef(left.resultdef).highrange)
                                                     ))
                 else if (htype.typ=orddef) and
                    { right can also be a variant or another type with
                      overloaded assignment }
                    (right.resultdef.typ=orddef) and
                    { don't try to create boolean types with custom ranges }
                    not is_boolean(right.resultdef) and
                    { ordtype determines the size of the loaded value -> make
                      sure we don't truncate }
                    ((Torddef(right.resultdef).ordtype<>torddef(htype).ordtype) or
                     (tarraydef(left.resultdef).lowrange<>torddef(htype).low) or
                     (tarraydef(left.resultdef).highrange<>torddef(htype).high)) then
                    {Convert array indexes to low_bound..high_bound.}
                   begin
                     if (right.resultdef.typ=orddef)
{$ifndef cpu64bitaddr}
                        { do truncate 64 bit values on 32 bit cpus, since
                           a) the arrays cannot be > 32 bit anyway
                           b) their code generators can't directly handle 64 bit
                              loads
                        }
                        and not is_64bit(right.resultdef)
{$endif not cpu64bitaddr}
                        then
                       newordtyp:=Torddef(right.resultdef).ordtype
                     else
                       newordtyp:=torddef(sizesinttype).ordtype;
                     inserttypeconv(right,corddef.create(newordtyp,
                                                         int64(Tarraydef(left.resultdef).lowrange),
                                                         int64(Tarraydef(left.resultdef).highrange),
                                                         true
                                                        ))
                   end
                 else
                   inserttypeconv(right,htype)
               end;
             stringdef:
               if is_open_string(left.resultdef) then
                 inserttypeconv(right,u8inttype)
               else if is_shortstring(left.resultdef) then
                 {Convert shortstring indexes to 0..length.}
                 inserttypeconv(right,corddef.create(u8bit,0,int64(Tstringdef(left.resultdef).len),true))
               else
                 {Convert indexes into dynamically allocated strings to aword.}
                 inserttypeconv(right,uinttype);
             pointerdef:
               inserttypeconv(right,tpointerdef(left.resultdef).pointer_arithmetic_int_type);
             else
               {Others, (are there any?) indexes to aint.}
               inserttypeconv(right,sinttype);
           end;

         { although we never put regular arrays or shortstrings in registers,
           it's possible that another type was typecasted to a small record
           that has a field of one of these types -> in that case the record
           can't be a regvar either }
         if ((left.resultdef.typ=arraydef) and
             not is_special_array(left.resultdef) and
             { arrays with elements equal to the alu size and with a constant index can be kept in register }
             not(is_constnode(right) and (tarraydef(left.resultdef).elementdef.size=alusinttype.size))) or
            ((left.resultdef.typ=stringdef) and
             (tstringdef(left.resultdef).stringtype in [st_shortstring,st_longstring])) then
           make_not_regable(left,[ra_addr_regable]);

         case left.resultdef.typ of
           arraydef :
             begin
               { check type of the index value }
               if (compare_defs(right.resultdef,tarraydef(left.resultdef).rangedef,right.nodetype)=te_incompatible) then
                 IncompatibleTypes(right.resultdef,tarraydef(left.resultdef).rangedef);
               if right.nodetype=rangen then
                 resultdef:=left.resultdef
               else
                 resultdef:=Tarraydef(left.resultdef).elementdef;

               result:=gen_array_rangecheck;
               if assigned(result) then
                 exit;

               { in case of a bitpacked array of enums that are size 2 (due to
                 packenum 2) but whose values all fit in one byte, the size of
                 bitpacked array elements will be 1 byte while the resultdef of
                 will currently say it's two bytes) -> create a temp enumdef
                 with packenum=1 for the resultdef as subtype of the main
                 enumdef }
               if is_enum(resultdef) and
                  is_packed_array(left.resultdef) and
                  ((tarraydef(left.resultdef).elepackedbitsize div 8) <> resultdef.size) then
                 begin
                   resultdef:=cenumdef.create_subrange(tenumdef(resultdef),tenumdef(resultdef).min,tenumdef(resultdef).max);
                   tenumdef(resultdef).calcsavesize(1);
                 end
             end;
           pointerdef :
             begin
               { are we accessing a pointer[], then convert the pointer to
                 an array first, in FPC this is allowed for all pointers
                 (except voidpointer) in delphi/tp7 it's only allowed for pchars. }
               if not is_voidpointer(left.resultdef) and
                  (
                   (cs_pointermath in current_settings.localswitches) or
                   tpointerdef(left.resultdef).has_pointer_math or
                   is_pchar(left.resultdef) or
                   is_pwidechar(left.resultdef)
                  ) then
                begin
                  { convert pointer to array }
                  htype:=carraydef.create_from_pointer(tpointerdef(left.resultdef));
                  inserttypeconv(left,htype);
                  if right.nodetype=rangen then
                    resultdef:=htype
                  else
                    resultdef:=tarraydef(htype).elementdef;
                end
               else
                CGMessage(type_e_array_required);
             end;
           stringdef :
             begin
                case tstringdef(left.resultdef).stringtype of
                  st_unicodestring,
                  st_widestring :
                    begin
                      elementdef:=cwidechartype;
                      elementptrdef:=widecharpointertype;
                    end;
                  st_ansistring,
                  st_longstring,
                  st_shortstring :
                    begin
                      elementdef:=cansichartype;
                      elementptrdef:=charpointertype;
                    end;
                end;
                if right.nodetype=rangen then
                  begin
                    htype:=carraydef.create_from_pointer(tpointerdef(elementptrdef));
                    resultdef:=htype;
                  end
                else
                 begin
                   { indexed access to 0 element is only allowed for shortstrings or if
                     zero based strings is turned on }
                   if (right.nodetype=ordconstn) and
                      (Tordconstnode(right).value.svalue=0) and
                      not is_shortstring(left.resultdef) and
                      not(cs_zerobasedstrings in current_settings.localswitches) then
                     CGMessage(cg_e_can_access_element_zero);
                   resultdef:=elementdef;
                 end;
             end;
           variantdef :
             resultdef:=cvarianttype;
           else
             CGMessage(type_e_array_required);
        end;
      end;


    procedure Tvecnode.mark_write;
      begin
        include(flags,nf_write);
        { see comment in tsubscriptnode.mark_write }
        if not(is_implicit_array_pointer(left.resultdef)) then
          left.mark_write;
      end;


    function tvecnode.pass_1 : tnode;
      begin
         result:=nil;
         firstpass(left);
         firstpass(right);
         if codegenerror then
           exit;

         if (nf_callunique in flags) and
            (is_ansistring(left.resultdef) or
             is_unicodestring(left.resultdef) or
            (is_widestring(left.resultdef) and not(tf_winlikewidestring in target_info.flags))) then
           begin
             left := ctypeconvnode.create_internal(ccallnode.createintern('fpc_'+tstringdef(left.resultdef).stringtypname+'_unique',
               ccallparanode.create(
                 ctypeconvnode.create_internal(left,voidpointertype),nil)),
               left.resultdef);
             firstpass(left);
             { double resultdef passes somwhere else may cause this to be }
             { reset though :/                                             }
             exclude(flags,nf_callunique);
           end
         else if is_widestring(left.resultdef) and (tf_winlikewidestring in target_info.flags) then
           exclude(flags,nf_callunique);

         { a range node as array index can only appear in function calls, and
           those convert the range node into something else in
           tcallnode.gen_high_tree }
         if (right.nodetype=rangen) then
           CGMessagePos(right.fileinfo,parser_e_illegal_expression)
         else if left.resultdef.typ=arraydef then
           result:=first_arraydef
         else
           begin
             if left.expectloc=LOC_CREFERENCE then
               expectloc:=LOC_CREFERENCE
             else
               expectloc:=LOC_REFERENCE
           end;
      end;


    function tvecnode.first_arraydef: tnode;
      begin
        result:=nil;
        if (not is_packed_array(left.resultdef)) or
           ((tarraydef(left.resultdef).elepackedbitsize mod 8) = 0) then
          if left.expectloc=LOC_CREFERENCE then
            expectloc:=LOC_CREFERENCE
          else
            expectloc:=LOC_REFERENCE
        else
          if left.expectloc=LOC_CREFERENCE then
            expectloc:=LOC_CSUBSETREF
          else
            expectloc:=LOC_SUBSETREF;
      end;

    function tvecnode.gen_array_rangecheck: tnode;
    var
      htype: tdef;
      temp: ttempcreatenode;
      stat: tstatementnode;
      indextree: tnode;
      hightree: tnode;
    begin
      result:=nil;

      { Range checking an array of const/open array/dynamic array is
        more complicated than regular arrays, because the bounds must
        be checked dynamically. Additionally, in case of array of const
        and open array we need the high parameter, which must not be
        made a regvar in case this is a nested rountine relative to the
        array parameter -> generate te check at the node tree level
        rather than in the code generator }
      if (cs_check_range in current_settings.localswitches) and
         (is_open_array(left.resultdef) or
          is_array_of_const(left.resultdef)) and
         (right.nodetype<>rangen) then
        begin
          { expect to find the load node }
          if get_open_const_array(left).nodetype<>loadn then
            internalerror(2014040601);
          { cdecl functions don't have high() so we can not check the range }
          { (can't use current_procdef, since it may be a nested procedure) }
          if not(tprocdef(tparasymtable(tparavarsym(tloadnode(get_open_const_array(left)).symtableentry).owner).defowner).proccalloption in cdecl_pocalls) then
            begin
              temp:=nil;
              result:=internalstatements(stat);
              { can't use node_complexity here, assumes that the code has
                already been firstpassed }
              if not is_const(right) then
                begin
                  temp:=ctempcreatenode.create(right.resultdef,right.resultdef.size,tt_persistent,true);
                  addstatement(stat,temp);
                  { needed so we can typecheck its temprefnodes }
                  typecheckpass(tnode(temp));
                  addstatement(stat,cassignmentnode.create(
                    ctemprefnode.create(temp),right)
                  );
                  right:=ctemprefnode.create(temp);
                  { right.resultdef is used below }
                  typecheckpass(right);
                end;
              { range check will be made explicit here }
              exclude(localswitches,cs_check_range);
              hightree:=load_high_value_node(tparavarsym(tloadnode(
                get_open_const_array(left)).symtableentry));
              { make index unsigned so we only need one comparison;
                lower bound is always zero for these arrays, but
                hightree can be -1 in case the array was empty ->
                add 1 before comparing (ignoring overflows) }
              htype:=get_unsigned_inttype(right.resultdef);
              inserttypeconv_explicit(hightree,htype);
              hightree:=caddnode.create(addn,hightree,genintconstnode(1));
              hightree.localswitches:=hightree.localswitches-[cs_check_range,
                cs_check_overflow];
              indextree:=ctypeconvnode.create_explicit(right.getcopy,htype);
              { range error if index >= hightree+1 }
              addstatement(stat,
                cifnode.create_internal(
                  caddnode.create_internal(gten,indextree,hightree),
                  ccallnode.createintern('fpc_rangeerror',nil),
                  nil
                )
              );
              if assigned(temp) then
                addstatement(stat,ctempdeletenode.create_normal_temp(temp));
              addstatement(stat,self.getcopy);
            end;
        end;
    end;


{$ifdef DEBUG_NODE_XML}
    procedure TVecNode.XMLPrintNodeData(var T: Text);
      begin
        XMLPrintNode(T, Left);

        { The right node is the index }
        WriteLn(T, PrintNodeIndention, '<index>');
        PrintNodeIndent;
        XMLPrintNode(T, Right);
        PrintNodeUnindent;
        WriteLn(T, PrintNodeIndention, '</index>');

        PrintNodeUnindent;
        WriteLn(T, PrintNodeIndention, '</', nodetype2str[nodetype], '>');
      end;
{$endif DEBUG_NODE_XML}


    function is_big_untyped_addrnode(p: tnode): boolean;
      begin
        is_big_untyped_addrnode:=(p.nodetype=addrn) and
          not (anf_typedaddr in taddrnode(p).addrnodeflags) and
          (taddrnode(p).left.resultdef.size > 1);
      end;

end.