freepascal.compiler/compiler/nld.pas

{
    Copyright (c) 2000-2002 by Florian Klaempfl

    Type checking and register allocation for load/assignment 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 nld;

{$i fpcdefs.inc}

interface

    uses
       node,
       {$ifdef state_tracking}
       nstate,
       {$endif}
       symconst,symbase,symtype,symsym,symdef;

    type
       Trttidatatype = (rdt_normal,rdt_ord2str,rdt_str2ord);

       tloadnodeflags = (
         loadnf_is_self,
         { tell the load node the address of the symbol into the location, i.e. location^ must
           be used to access the symbol
           this is for example needed to load self for objects }
         loadnf_load_addr,
         loadnf_inherited,
         { the loadnode is generated internally and a varspez=vs_const should be ignore,
           this requires that the parameter is actually passed by value
           Be really carefull when using this flag! }
         loadnf_isinternal_ignoreconst,

         loadnf_only_uninitialized_hint
        );

       tloadnode = class(tunarynode)
       protected
          fprocdef : tprocdef;
          fprocdefderef : tderef;
          function handle_threadvar_access: tnode; virtual;
       public
          loadnodeflags : set of tloadnodeflags;
          symtableentry : tsym;
          symtableentryderef : tderef;
          symtable : TSymtable;
          constructor create(v : tsym;st : TSymtable);virtual;
          constructor create_procvar(v : tsym;d:tprocdef;st : TSymtable);virtual;
          constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
          procedure ppuwrite(ppufile:tcompilerppufile);override;
          procedure buildderefimpl;override;
          procedure derefimpl;override;
          procedure set_mp(p:tnode);
          function  is_addr_param_load:boolean;virtual;
          function  dogetcopy : tnode;override;
          function  pass_1 : tnode;override;
          function  pass_typecheck:tnode;override;
          procedure mark_write;override;
          function  docompare(p: tnode): boolean; override;
          procedure printnodedata(var t:text);override;
{$ifdef DEBUG_NODE_XML}
          procedure XMLPrintNodeData(var T: Text); override;
{$endif DEBUG_NODE_XML}
          procedure setprocdef(p : tprocdef);
          property procdef: tprocdef read fprocdef write setprocdef;
       end;
       tloadnodeclass = class of tloadnode;

       { different assignment types }
       tassigntype = (at_normal,at_plus,at_minus,at_star,at_slash);

       tassignmentnode = class(tbinarynode)
         protected
          function direct_shortstring_assignment: boolean; virtual;
         public
          assigntype : tassigntype;
          constructor create(l,r : tnode);virtual;
          { no checks for validity of assignment }
          constructor create_internal(l,r : tnode);virtual;
          constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
          procedure ppuwrite(ppufile:tcompilerppufile);override;
          function dogetcopy : tnode;override;
          function pass_1 : tnode;override;
          function pass_typecheck:tnode;override;
          function simplify(forinline : boolean) : tnode;override;
       {$ifdef state_tracking}
          function track_state_pass(exec_known:boolean):boolean;override;
       {$endif state_tracking}
          function docompare(p: tnode): boolean; override;
{$ifdef DEBUG_NODE_XML}
          procedure XMLPrintNodeData(var T: Text); override;
{$endif DEBUG_NODE_XML}
       end;
       tassignmentnodeclass = class of tassignmentnode;

       tarrayconstructorrangenode = class(tbinarynode)
          constructor create(l,r : tnode);virtual;
          function pass_1 : tnode;override;
          function pass_typecheck:tnode;override;
       end;
       tarrayconstructorrangenodeclass = class of tarrayconstructorrangenode;

       tarrayconstructornode = class(tbinarynode)
          allow_array_constructor : boolean;
         private
          function has_range_node:boolean;
         protected
          procedure wrapmanagedvarrec(var n: tnode);virtual;abstract;
         public
          constructor create(l,r : tnode);virtual;
          function dogetcopy : tnode;override;
          function pass_1 : tnode;override;
          function pass_typecheck:tnode;override;
          function docompare(p: tnode): boolean; override;
          procedure force_type(def:tdef);
          procedure insert_typeconvs;
          function isempty : boolean;
       end;
       tarrayconstructornodeclass = class of tarrayconstructornode;

       ttypenode = class(tnode)
          allowed : boolean;
          helperallowed : boolean;
          typedef : tdef;
          typedefderef : tderef;
          typesym : tsym;
          typesymderef : tderef;
          constructor create(def:tdef);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  dogetcopy : tnode;override;
          function docompare(p: tnode): boolean; override;
       end;
       ttypenodeclass = class of ttypenode;

       trttinode = class(tnode)
          l1,l2  : longint;
          rttitype : trttitype;
          rttidef : tstoreddef;
          rttidefderef : tderef;
          rttidatatype : Trttidatatype;
          constructor create(def:tstoreddef;rt:trttitype;dt:Trttidatatype);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 pass_typecheck:tnode;override;
          function docompare(p: tnode): boolean; override;
       end;
       trttinodeclass = class of trttinode;

    var
       cloadnode : tloadnodeclass = tloadnode;
       cassignmentnode : tassignmentnodeclass = tassignmentnode;
       carrayconstructorrangenode : tarrayconstructorrangenodeclass = tarrayconstructorrangenode;
       carrayconstructornode : tarrayconstructornodeclass = tarrayconstructornode;
       ctypenode : ttypenodeclass = ttypenode;
       crttinode : trttinodeclass = trttinode;

       { Current assignment node }
       aktassignmentnode : tassignmentnode;

       { Create a node tree to load a variable if symbol is assigned, otherwise an error node.
         Generates an internalerror if called for an absolutevarsym of the "tovar" kind (those
         are only supported for expansion in the parser) }
       function gen_load_var(sym: tabstractvarsym): tnode;

implementation

    uses
      verbose,globtype,globals,systems,constexp,compinnr,
      ppu,
      symtable,
      defutil,defcmp,
      cpuinfo,
      htypechk,pass_1,procinfo,paramgr,
      nbas,ncon,nflw,ninl,ncnv,nmem,ncal,nutils,
      cgbase,
      optloadmodifystore,wpobase
      ;


    function gen_load_var(sym: tabstractvarsym): tnode;
      begin
        result:=nil;
        if assigned(sym) then
          begin
            if (sym.typ<>absolutevarsym) or
               (tabsolutevarsym(sym).abstyp<>tovar) then
              begin
                result:=cloadnode.create(sym,sym.owner);
              end
            else
              internalerror(2020122601);
          end
        else
          begin
            result:=cerrornode.create;
            CGMessage(parser_e_illegal_expression);
          end;
      end;


{*****************************************************************************
                             TLOADNODE
*****************************************************************************}

    function tloadnode.handle_threadvar_access: tnode;
      begin
        { nothing special by default }
        result:=nil;
      end;


    constructor tloadnode.create(v : tsym;st : TSymtable);
      begin
         inherited create(loadn,nil);
         if not assigned(v) then
          internalerror(200108121);
         symtableentry:=v;
         symtable:=st;
         fprocdef:=nil;
      end;


    constructor tloadnode.create_procvar(v : tsym;d:tprocdef;st : TSymtable);
      begin
         inherited create(loadn,nil);
         if not assigned(v) then
          internalerror(200108122);
         symtableentry:=v;
         symtable:=st;
         fprocdef:=d;
      end;


    constructor tloadnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
      begin
        inherited ppuload(t,ppufile);
        ppufile.getderef(symtableentryderef);
        symtable:=nil;
        ppufile.getderef(fprocdefderef);
        ppufile.getset(tppuset1(loadnodeflags));
      end;


    procedure tloadnode.ppuwrite(ppufile:tcompilerppufile);
      begin
        inherited ppuwrite(ppufile);
        ppufile.putderef(symtableentryderef);
        ppufile.putderef(fprocdefderef);
        ppufile.putset(tppuset1(loadnodeflags));
      end;


    procedure tloadnode.buildderefimpl;
      begin
        inherited buildderefimpl;
        symtableentryderef.build(symtableentry);
        fprocdefderef.build(fprocdef);
      end;


    procedure tloadnode.derefimpl;
      begin
        inherited derefimpl;
        symtableentry:=tsym(symtableentryderef.resolve);
        symtable:=symtableentry.owner;
        fprocdef:=tprocdef(fprocdefderef.resolve);
      end;


    procedure tloadnode.set_mp(p:tnode);
      begin
        { typen nodes should not be set }
        if p.nodetype=typen then
          internalerror(200301042);
        left:=p;
      end;


    function tloadnode.dogetcopy : tnode;
      var
         n : tloadnode;
         orglabel,
         labelcopy : tlabelnode;
      begin
         n:=tloadnode(inherited dogetcopy);
         n.symtable:=symtable;
         n.symtableentry:=symtableentry;
         n.fprocdef:=fprocdef;
         n.loadnodeflags:=loadnodeflags;
         if symtableentry.typ=labelsym then
           begin
             { see the comments for the tgotonode.labelsym field }
             orglabel:=tlabelnode(tlabelsym(symtableentry).code);
             labelcopy:=tlabelnode(orglabel.dogetcopy);
             if not assigned(labelcopy.labsym) then
               begin
                 if not assigned(orglabel.labsym) then
                   internalerror(2019091301);
                 labelcopy.labsym:=clabelsym.create('$copiedlabelfrom$'+orglabel.labsym.RealName);
                 labelcopy.labsym.code:=labelcopy;
               end;
             n.symtableentry:=labelcopy.labsym;
           end;
         result:=n;
      end;


    function tloadnode.is_addr_param_load:boolean;
      begin
        result:=(symtable.symtabletype=parasymtable) and
                (symtableentry.typ=paravarsym) and
                not(vo_has_local_copy in tparavarsym(symtableentry).varoptions) and
                not(loadnf_load_addr in loadnodeflags) and
                paramanager.push_addr_param(tparavarsym(symtableentry).varspez,tparavarsym(symtableentry).vardef,tprocdef(symtable.defowner).proccalloption);
      end;


    function tloadnode.pass_typecheck:tnode;
      begin
         result:=nil;
         case symtableentry.typ of
           absolutevarsym :
             resultdef:=tabsolutevarsym(symtableentry).vardef;
           constsym:
             begin
               if tconstsym(symtableentry).consttyp=constresourcestring then
                 resultdef:=getansistringdef
               else
                 internalerror(22799);
             end;
           staticvarsym :
             begin
               tabstractvarsym(symtableentry).IncRefCountBy(1);
               { static variables referenced in procedures or from finalization,
                 variable needs to be in memory.
                 It is too hard and the benefit is too small to detect whether a
                 variable is only used in the finalization to add support for it (PFV) }
               if assigned(current_procinfo) and
                  (symtable.symtabletype=staticsymtable) and
                  (
                    (symtable.symtablelevel<>current_procinfo.procdef.localst.symtablelevel) or
                    (current_procinfo.procdef.proctypeoption=potype_unitfinalize)
                  ) then
                 make_not_regable(self,[ra_different_scope]);
               resultdef:=tabstractvarsym(symtableentry).vardef;
               if vo_is_thread_var in tstaticvarsym(symtableentry).varoptions then
                 result:=handle_threadvar_access;
             end;
           paravarsym,
           localvarsym :
             begin
               tabstractvarsym(symtableentry).IncRefCountBy(1);
               resultdef:=tabstractvarsym(symtableentry).vardef;
               { Nested variable? The we need to load the framepointer of
                 the parent procedure }
               if assigned(current_procinfo) and
                  (symtable.symtabletype in [localsymtable,parasymtable]) and
                  (symtable.symtablelevel<>current_procinfo.procdef.parast.symtablelevel) then
                 begin
                   if assigned(left) then
                     internalerror(200309289);
                   left:=cloadparentfpnode.create(tprocdef(symtable.defowner),lpf_forload);
                   current_procinfo.set_needs_parentfp(tprocdef(symtable.defowner).parast.symtablelevel);
                   { reference this as a captured symbol }
                   current_procinfo.add_captured_sym(symtableentry,resultdef,fileinfo);
                   { reference in nested procedures, variable needs to be in memory }
                   { and behaves as if its address escapes its parent block         }
                   make_not_regable(self,[ra_different_scope]);
                 end
               { if this is a nested function and it uses the Self parameter then
                 consider this as captured as well (needed for anonymous functions) }
               else if assigned(current_procinfo) and
                   (vo_is_self in tabstractvarsym(symtableentry).varoptions) and
                   (symtable.symtablelevel>normal_function_level) then
                 current_procinfo.add_captured_sym(symtableentry,resultdef,fileinfo);

               { e.g. self for objects is passed as var-parameter on the caller
                 side, but on the callee-side we use it as a pointer ->
                 adjust }
               if (loadnf_load_addr in loadnodeflags) then
                 resultdef:=cpointerdef.getreusable(resultdef);

               if (vo_is_self in tabstractvarsym(symtableentry).varoptions) and (resultdef=objc_idtype) and
                 (po_classmethod in tprocdef(symtableentry.owner.defowner).procoptions) then
                 resultdef:=cclassrefdef.create(tprocdef(symtableentry.owner.defowner).struct)
             end;
           procsym :
             begin
               { Return the first procdef. In case of overloaded
                 procdefs the matching procdef will be choosen
                 when the expected procvardef is known, see get_information
                 in htypechk.pas (PFV) }
               if not assigned(fprocdef) then
                 fprocdef:=tprocdef(tprocsym(symtableentry).ProcdefList[0])
               else if po_kylixlocal in fprocdef.procoptions then
                 CGMessage(type_e_cant_take_address_of_local_subroutine);

               { the result is a fprocdef, addrn and proc_to_procvar
                 typeconvn need this as resultdef so they know
                 that the address needs to be returned }
               resultdef:=fprocdef;

               if is_nested_pd(fprocdef) and is_nested_pd(current_procinfo.procdef) then
                 current_procinfo.set_needs_parentfp(tprocdef(fprocdef.owner.defowner).parast.symtablelevel);

               { process methodpointer/framepointer }
               if assigned(left) then
                 begin
                   typecheckpass(left);
                   if (po_classmethod in fprocdef.procoptions) and
                      is_class(left.resultdef) and
                      (left.nodetype<>niln) then
                     begin
                       left:=cloadvmtaddrnode.create(left);
                       typecheckpass(left);
                     end
                 end;

               { we can't know what will happen with this function pointer, so
                 we have to assume it will be used to create an instance of this
                 type }
               if fprocdef.wpo_may_create_instance(left) then
                 begin
                   if wpoinfomanager.symbol_live_in_currentproc(tdef(symtable.defowner)) then
                     begin
                       if assigned(left) then
                         tobjectdef(left.resultdef).register_created_object_type
                       else
                         tobjectdef(fprocdef.owner.defowner).register_created_object_type;
                     end;
                 end;
             end;
           labelsym:
             begin
               tlabelsym(symtableentry).used:=true;
               resultdef:=voidtype;
             end;
           else
             internalerror(200104141);
         end;
      end;

    procedure Tloadnode.mark_write;

    begin
      include(flags,nf_write);
    end;

    function tloadnode.pass_1 : tnode;
      begin
         result:=nil;
         expectloc:=LOC_REFERENCE;

         case symtableentry.typ of
            absolutevarsym :
              ;
            constsym:
              begin
                if tconstsym(symtableentry).consttyp=constresourcestring then
                  expectloc:=LOC_CREFERENCE;
              end;
            staticvarsym,
            localvarsym,
            paravarsym :
              begin
                if assigned(left) then
                  firstpass(left);
                if not is_addr_param_load and
                   tabstractvarsym(symtableentry).is_regvar(is_addr_param_load) then
                  expectloc:=tvarregable2tcgloc[tabstractvarsym(symtableentry).varregable]
                else
                  if (tabstractvarsym(symtableentry).varspez=vs_const) then
                    expectloc:=LOC_CREFERENCE;
                { call to get address of threadvar }
                if (vo_is_thread_var in tabstractvarsym(symtableentry).varoptions) then
                  begin
                    include(current_procinfo.flags,pi_do_call);
                    include(current_procinfo.flags,pi_uses_threadvar);
                  end;
              end;
            procsym :
              begin
                { initialise left for nested procs if necessary }
                if (m_nested_procvars in current_settings.modeswitches) then
                  setprocdef(fprocdef);
                { method pointer or nested proc ? }
                if assigned(left) then
                  begin
                     expectloc:=LOC_CREGISTER;
                     firstpass(left);
                  end;
              end;
            labelsym :
              begin
                if not assigned(tlabelsym(symtableentry).asmblocklabel) and
                   not assigned(tlabelsym(symtableentry).code) then
                  Message(parser_e_label_outside_proc);
              end
            else
              internalerror(200104143);
         end;
      end;


    function tloadnode.docompare(p: tnode): boolean;
      begin
        docompare :=
          inherited docompare(p) and
          (symtableentry = tloadnode(p).symtableentry) and
          (fprocdef = tloadnode(p).fprocdef) and
          (symtable = tloadnode(p).symtable);
      end;


    procedure tloadnode.printnodedata(var t:text);
      begin
        inherited printnodedata(t);
        write(t,printnodeindention,'symbol = ',symtableentry.name);
        if symtableentry.typ=procsym then
          write(t,printnodeindention,'procdef = ',fprocdef.mangledname);
        writeln(t,'');
      end;

{$ifdef DEBUG_NODE_XML}
    procedure TLoadNode.XMLPrintNodeData(var T: Text);
      begin
        inherited XMLPrintNodeData(T);
        WriteLn(T, printnodeindention, '<symbol>', symtableentry.name, '</symbol>');

        if symtableentry.typ = procsym then
          WriteLn(T, printnodeindention, '<procdef>', fprocdef.mangledname, '</procdef>');
      end;
{$endif DEBUG_NODE_XML}

    procedure tloadnode.setprocdef(p : tprocdef);
      begin
        fprocdef:=p;
        resultdef:=p;
        { nested procedure? }
        if assigned(p) and
           is_nested_pd(p) and
           (
             not (po_anonymous in p.procoptions) or
             (po_delphi_nested_cc in p.procoptions)
           ) then
          begin
            if not(m_nested_procvars in current_settings.modeswitches) then
              CGMessage(type_e_cant_take_address_of_local_subroutine)
            else
              begin
                { parent frame pointer pointer as "self" }
                left.free;
                left:=cloadparentfpnode.create(tprocdef(p.owner.defowner),lpf_forpara);
                typecheckpass(left);
              end;
          end
        { we should never go from nested to non-nested (except for an anonymous
          function which might have been changed to a global function or a
          method) }
        else if assigned(left) and
                (left.nodetype=loadparentfpn) then
          begin
            if po_anonymous in p.procoptions then
              begin
                left.free;
                left:=nil;
              end
            else
              internalerror(2010072201);
          end;
      end;

{*****************************************************************************
                             TASSIGNMENTNODE
*****************************************************************************}

    function tassignmentnode.direct_shortstring_assignment: boolean;
      begin
        result:=
          is_char(right.resultdef) or
          (right.resultdef.typ=stringdef);
      end;


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

      begin
         inherited create(assignn,l,r);
         assigntype:=at_normal;
         if r.nodetype = typeconvn then
           ttypeconvnode(r).warn_pointer_to_signed:=false;
      end;


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


    constructor tassignmentnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
      begin
        inherited ppuload(t,ppufile);
        assigntype:=tassigntype(ppufile.getbyte);
      end;


    procedure tassignmentnode.ppuwrite(ppufile:tcompilerppufile);
      begin
        inherited ppuwrite(ppufile);
        ppufile.putbyte(byte(assigntype));
      end;


    function tassignmentnode.dogetcopy : tnode;

      var
         n : tassignmentnode;

      begin
         n:=tassignmentnode(inherited dogetcopy);
         n.assigntype:=assigntype;
         result:=n;
      end;


    function tassignmentnode.simplify(forinline : boolean) : tnode;
      begin
        result:=nil;
        { assignment nodes can perform several floating point }
        { type conversions directly, so no typeconversions    }
        { are inserted in those cases. When inlining, a       }
        { variable may be replaced by a constant which can be }
        { converted at compile time, so check for this case   }
        if is_real(left.resultdef) and
           is_real(right.resultdef) and
           is_constrealnode(right) and
           not equal_defs(right.resultdef,left.resultdef) then
          inserttypeconv(right,left.resultdef);
{$if (cs_opt_use_load_modify_store in supported_optimizerswitches)}
        { Perform simple optimizations when -O2 and the dedicated
          cs_opt_use_load_modify_store optimization pass is not enabled. }
        if (cs_opt_level2 in current_settings.optimizerswitches) and
           not (cs_opt_use_load_modify_store in current_settings.optimizerswitches) then
          result:=try_opt_assignmentnode(self);
{$endif}
      end;


    function tassignmentnode.pass_typecheck:tnode;
      var
        hp : tnode;
        useshelper : boolean;
        oldassignmentnode : tassignmentnode;
      begin
        result:=nil;
        resultdef:=voidtype;

        { must be made unique }
        set_unique(left);

        typecheckpass(left);

        left.mark_write;

        { PI. This is needed to return correct resultdef of add nodes for ansistrings
          rawbytestring return needs to be replaced by left.resultdef }
        oldassignmentnode:=aktassignmentnode;
        aktassignmentnode:=self;
        typecheckpass(right);
        aktassignmentnode:=oldassignmentnode;

        set_varstate(right,vs_read,[vsf_must_be_valid]);
        set_varstate(left,vs_written,[]);
        if codegenerror then
          exit;

        { just in case the typecheckpass of right optimized something here }
        if nf_assign_done_in_right in flags then
          begin
            result:=right;
            right:=nil;
            exit;
          end;

        { tp procvar support, when we don't expect a procvar
          then we need to call the procvar }
        if (left.resultdef.typ<>procvardef) and
            not is_invokable(left.resultdef) then
          maybe_call_procvar(right,true);

        { assignments to formaldefs and open arrays aren't allowed }
        if is_open_array(left.resultdef) then
          CGMessage(type_e_assignment_not_allowed)
        else if (left.resultdef.typ=formaldef) then
          if not(target_info.system in systems_managed_vm) then
            CGMessage(type_e_assignment_not_allowed)
          else
            begin
              { on managed platforms, assigning to formaldefs is allowed (but
                typecasting them on the left hand side isn't), but primitive
                values need to be boxed first }
              if (right.resultdef.typ in [orddef,floatdef]) then
                begin
                  right:=cinlinenode.create(in_box_x,false,ccallparanode.create(right,nil));
                  typecheckpass(right);
                end;
            end;


        { test if node can be assigned, properties are allowed }
        if not(nf_internal in flags) then
          if not valid_for_assignment(left,true) then
            { errors can in situations that cause the compiler to run out of
              memory, such as assigning to an implicit pointer-to-array
              converted node (that array is 2^31 or 2^63 bytes large) }
            exit;

        { assigning nil or [] to a dynamic array clears the array }
        if is_dynamic_array(left.resultdef) and
            (
              (right.nodetype=niln) or
              (
                (right.nodetype=arrayconstructorn) and
                (right.resultdef.typ=arraydef) and
                (tarraydef(right.resultdef).elementdef=voidtype) and
                tarrayconstructornode(right).isempty
              )
            ) then
         begin
           { remove property flag to avoid errors, see comments for }
           { tf_winlikewidestring assignments below                 }
           exclude(left.flags,nf_isproperty);
           { generate a setlength node so it can be intercepted by
             target-specific code }
           result:=cinlinenode.create(in_setlength_x,false,
             ccallparanode.create(genintconstnode(0),
               ccallparanode.create(left,nil)));
           left:=nil;
           exit;
         end;

        { shortstring helpers can do the conversion directly,
          so treat them separatly }
        if (is_shortstring(left.resultdef)) then
         begin
           { insert typeconv, except for chars that are handled in
             secondpass and except for ansi/wide string that can
             be converted immediatly }
           if not direct_shortstring_assignment then
             inserttypeconv(right,left.resultdef);
           if right.resultdef.typ=stringdef then
            begin
              useshelper:=true;
              { convert constant strings to shortstrings. But
                skip empty constant strings, that will be handled
                in secondpass }
              if (right.nodetype=stringconstn) then
                begin
                  { verify if range fits within shortstring }
                  { just emit a warning, delphi gives an    }
                  { error, only if the type definition of   }
                  { of the string is less  < 255 characters }
                  if not is_open_string(left.resultdef) and
                     (tstringconstnode(right).len > tstringdef(left.resultdef).len) then
                     cgmessage(type_w_string_too_long);
                  inserttypeconv(right,left.resultdef);
                  if (right.nodetype=stringconstn) and
                     (tstringconstnode(right).len=0) then
                    useshelper:=false;
                end
              else if (tstringdef(right.resultdef).stringtype in [st_unicodestring,st_widestring]) then
                Message2(type_w_implicit_string_cast_loss,right.resultdef.typename,left.resultdef.typename);
             { rest is done in pass 1 (JM) }
             if useshelper then
               exit;
            end
         end
        { floating point assignments can also perform the conversion directly }
        else if is_real(left.resultdef) and is_real(right.resultdef) and
                not is_constrealnode(right)
{$ifdef cpufpemu}
                { the emulator can't do this obviously }
                and not(current_settings.fputype in [fpu_libgcc,fpu_soft])
{$endif cpufpemu}

{$ifdef x86}
                { the assignment node code can't convert a double in an }
                { sse register to an extended value in memory more      }
                { efficiently than a type conversion node, so don't     }
                { bother implementing support for that                  }
                and (use_vectorfpu(left.resultdef) or not(use_vectorfpu(right.resultdef)))
{$endif}

{$ifdef arm}
                { the assignment node code can't convert a single in
                  an interger register to a double in an mmregister or
                  vice versa }
                and (use_vectorfpu(left.resultdef) and
                     use_vectorfpu(right.resultdef) and
                     (tfloatdef(left.resultdef).floattype=tfloatdef(right.resultdef).floattype))
{$endif arm}
{$ifdef xtensa}
                and not((FPUXTENSA_SINGLE in fpu_capabilities[current_settings.fputype]) xor
                  (FPUXTENSA_DOUBLE in fpu_capabilities[current_settings.fputype]))
{$endif}
        then
          begin
            if not(nf_internal in flags) then
              check_ranges(fileinfo,right,left.resultdef);
          end
        else
          begin
            { check if the assignment may cause a range check error }
            if not(nf_internal in flags) then
              check_ranges(fileinfo,right,left.resultdef);

            { beginners might be confused about an error message like
              Incompatible types: got "untyped" expected "LongInt"
              when trying to assign the result of a procedure, so give
              a better error message, see also #19122 }
            if (left.resultdef.typ<>procvardef) and
                not is_invokable(left.resultdef) and
              (right.nodetype=calln) and is_void(right.resultdef) then
              CGMessage(type_e_procedures_return_no_value)
            else if nf_internal in flags then
              inserttypeconv_internal(right,left.resultdef)
            else
              inserttypeconv(right,left.resultdef);
          end;

        { call helpers for interface }
        if is_interfacecom_or_dispinterface(left.resultdef) then
         begin
	   { Normal interface assignments are handled by the generic refcount incr/decr }
           if not def_is_related(right.resultdef,left.resultdef) then
             begin
               { remove property flag to avoid errors, see comments for }
               { tf_winlikewidestring assignments below                 }
               exclude(left.flags,nf_isproperty);
               hp:=
                 ccallparanode.create(
                   cguidconstnode.create(tobjectdef(left.resultdef).iidguid^),
                 ccallparanode.create(
                   ctypeconvnode.create_internal(right,voidpointertype),
                 ccallparanode.create(
                   ctypeconvnode.create_internal(left,voidpointertype),
                   nil)));
               result:=ccallnode.createintern('fpc_intf_assign_by_iid',hp);
               left:=nil;
               right:=nil;
               exit;
             end;
         end;

        { check if local proc/func is assigned to procvar }
        if right.resultdef.typ=procvardef then
          test_local_to_procvar(tprocvardef(right.resultdef),left.resultdef);
      end;


    function tassignmentnode.pass_1 : tnode;
      var
        hp: tnode;
        oldassignmentnode : tassignmentnode;
        hdef: tdef;
        hs: string;
        needrtti: boolean;
      begin
         result:=nil;
         expectloc:=LOC_VOID;

         firstpass(left);

         { Optimize the reuse of the destination of the assingment in left.
           Allow the use of the left inside the tree generated on the right.
           This is especially useful for string routines where the destination
           is pushed as a parameter. Using the final destination of left directly
           save a temp allocation and copy of data (PFV) }
         oldassignmentnode:=aktassignmentnode;
         aktassignmentnode:=self;
         firstpass(right);
         aktassignmentnode:=oldassignmentnode;
         if nf_assign_done_in_right in flags then
           begin
             result:=right;
             right:=nil;
             exit;
           end;

         if codegenerror then
           exit;

         { assignment to refcounted variable -> inc/decref }
         if is_managed_type(left.resultdef) then
           include(current_procinfo.flags,pi_do_call);

         needrtti:=false;

        if (is_shortstring(left.resultdef)) then
          begin
           if right.resultdef.typ=stringdef then
            begin
              if (right.nodetype<>stringconstn) or
                 (tstringconstnode(right).len<>0) then
               begin
                 { remove property flag to avoid errors, see comments for }
                 { tf_winlikewidestring assignments below                 }
                 exclude(left.flags, nf_isproperty);
                 hp:=ccallparanode.create
                       (right,
                  ccallparanode.create(left,nil));
                 result:=ccallnode.createintern('fpc_'+tstringdef(right.resultdef).stringtypname+'_to_shortstr',hp);
                 firstpass(result);
                 left:=nil;
                 right:=nil;
               end;
            end;
            exit;
           end
        { call helpers for composite types containing automated types }
        else if is_managed_type(left.resultdef) and
            (left.resultdef.typ in [arraydef,objectdef,recorddef]) and
            not is_interfacecom_or_dispinterface(left.resultdef) and
            not is_dynamic_array(left.resultdef) and
            not is_const(left) and
            not(target_info.system in systems_garbage_collected_managed_types) then
         begin
           hp:=ccallparanode.create(caddrnode.create_internal(
                  crttinode.create(tstoreddef(left.resultdef),initrtti,rdt_normal)),
               ccallparanode.create(ctypeconvnode.create_internal(
                 caddrnode.create_internal(left),voidpointertype),
               ccallparanode.create(ctypeconvnode.create_internal(
                 caddrnode.create_internal(right),voidpointertype),
               nil)));
           result:=ccallnode.createintern('fpc_copy_proc',hp);
           firstpass(result);
           left:=nil;
           right:=nil;
           exit;
         end
        { call helpers for variant, they can contain non ref. counted types like
          vararrays which must be really copied }
        else if (left.resultdef.typ=variantdef) and
            not(is_const(left)) and
            not(target_info.system in systems_garbage_collected_managed_types)  then
         begin
           { remove property flag to avoid errors, see comments for }
           { tf_winlikewidestring assignments below                 }
           exclude(left.flags,nf_isproperty);
           hdef:=search_system_type('TVARDATA').typedef;
           hp:=ccallparanode.create(ctypeconvnode.create_internal(
                 right,hdef),
               ccallparanode.create(ctypeconvnode.create_internal(
                 left,hdef),
               nil));
           result:=ccallnode.createintern('fpc_variant_copy',hp);
           firstpass(result);
           left:=nil;
           right:=nil;
           exit;
         end
        else if not(target_info.system in systems_garbage_collected_managed_types) and
          not(is_const(left)) then
          begin
            { call helpers for pointer-sized managed types }
            if is_widestring(left.resultdef) then
              hs:='fpc_widestr_assign'
            else if is_ansistring(left.resultdef) then
              hs:='fpc_ansistr_assign'
            else if is_unicodestring(left.resultdef) then
              hs:='fpc_unicodestr_assign'
            else if is_interfacecom_or_dispinterface(left.resultdef) then
              hs:='fpc_intf_assign'
            else if is_dynamic_array(left.resultdef) then
              begin
                hs:='fpc_dynarray_assign';
                needrtti:=true;
              end
            else
              exit;
          end
        else
          exit;

        { The first argument of these procedures is a var parameter. Properties cannot     }
        { be passed to var or out parameters, because in that case setters/getters are not }
        { used. Further, if we would allow it in case there are no getters or setters, you }
        { would need source changes in case these are introduced later on, thus defeating  }
        { part of the transparency advantages of properties. In this particular case,      }
        { however:                                                                         }
        {   a) if there is a setter, this code will not be used since then the assignment  }
        {      will be converted to a procedure call                                       }
        {   b) the getter is irrelevant, because fpc_widestr_assign must always decrease   }
        {      the refcount of the field to which we are writing                           }
        {   c) source code changes are not required if a setter is added/removed, because  }
        {      this transformation is handled at compile time                              }
        {  -> we can remove the nf_isproperty flag (if any) from left, so that in case it  }
        {     is a property which refers to a field without a setter call, we will not get }
        {     an error about trying to pass a property as a var parameter                  }
        exclude(left.flags,nf_isproperty);
        hp:=ccallparanode.create(ctypeconvnode.create_internal(right,voidpointertype),
            ccallparanode.create(ctypeconvnode.create_internal(left,voidpointertype),
            nil));
        if needrtti then
          hp:=ccallparanode.create(
            caddrnode.create_internal(
              crttinode.create(tstoreddef(left.resultdef),initrtti,rdt_normal)),
            hp);
        result:=ccallnode.createintern(hs,hp);
        firstpass(result);
        left:=nil;
        right:=nil;
      end;


    function tassignmentnode.docompare(p: tnode): boolean;
      begin
        docompare :=
          inherited docompare(p) and
          (assigntype = tassignmentnode(p).assigntype);
      end;

{$ifdef state_tracking}
    function Tassignmentnode.track_state_pass(exec_known:boolean):boolean;

    var se:Tstate_entry;

    begin
        track_state_pass:=false;
        if exec_known then
            begin
                track_state_pass:=right.track_state_pass(exec_known);
                {Force a new resultdef pass.}
                right.resultdef:=nil;
                do_typecheckpass(right);
                typecheckpass(right);
                aktstate.store_fact(left.getcopy,right.getcopy);
            end
        else
            aktstate.delete_fact(left);
    end;
{$endif}


{$ifdef DEBUG_NODE_XML}
    procedure TAssignmentNode.XMLPrintNodeData(var T: Text);
      begin
        { For assignments, put the left and right branches on the same level for clarity }
        XMLPrintNode(T, Left);
        XMLPrintNode(T, Right);
        PrintNodeUnindent;
        WriteLn(T, PrintNodeIndention, '</', nodetype2str[nodetype], '>');
      end;
{$endif DEBUG_NODE_XML}


{*****************************************************************************
                           TARRAYCONSTRUCTORRANGENODE
*****************************************************************************}

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

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

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


    function tarrayconstructorrangenode.pass_1 : tnode;
      begin
        result:=nil;
        CGMessage(parser_e_illegal_expression);
      end;


{****************************************************************************
                            TARRAYCONSTRUCTORNODE
*****************************************************************************}

    constructor tarrayconstructornode.create(l,r : tnode);
      begin
         inherited create(arrayconstructorn,l,r);
         allow_array_constructor:=false;
      end;


    function tarrayconstructornode.dogetcopy : tnode;
      var
         n : tarrayconstructornode;
      begin
         n:=tarrayconstructornode(inherited dogetcopy);
         result:=n;
      end;


    function tarrayconstructornode.has_range_node:boolean;
      var
        n : tarrayconstructornode;
      begin
        result:=false;
        n:=self;
        while assigned(n) do
          begin
            if assigned(n.left) and (n.left.nodetype=arrayconstructorrangen) then
              begin
                result:=true;
                break;
              end;
            n:=tarrayconstructornode(n.right);
          end;
      end;


    function tarrayconstructornode.isempty:boolean;
      begin
        result:=not(assigned(left)) and not(assigned(right));
      end;


    function tarrayconstructornode.pass_typecheck:tnode;
      var
        hdef  : tdef;
        hp    : tarrayconstructornode;
        len   : longint;
        diff,
        varia : boolean;
        eq    : tequaltype;
        hnodetype : tnodetype;
      begin
        result:=nil;

      { are we allowing array constructor? Then convert it to a set.
        Do this only if we didn't convert the arrayconstructor yet. This
        is needed for the cases where the resultdef is forced for a second
        run }
        if not allow_array_constructor or has_range_node then
         begin
           hp:=tarrayconstructornode(getcopy);
           arrayconstructor_to_set(tnode(hp));
           result:=hp;
           exit;
         end;

      { only pass left tree, right tree contains next construct if any }
        hdef:=nil;
        hnodetype:=errorn;
        len:=0;
        varia:=false;
        diff:=false;
        if assigned(left) then
         begin
           hp:=self;
           while assigned(hp) do
            begin
              typecheckpass(hp.left);
              set_varstate(hp.left,vs_read,[vsf_must_be_valid]);
              if (hdef=nil) then
                begin
                  hdef:=hp.left.resultdef;
                  hnodetype:=hp.left.nodetype;
                end
              else
               begin
                 { If we got a niln we don't know the type yet and need to take the
                   type of the next array element.
                   This is to handle things like [nil,tclass,tclass], see also tw8371 (PFV) }
                 if hnodetype=niln then
                   begin
                     eq:=compare_defs(hp.left.resultdef,hdef,hnodetype);
                     if eq>te_incompatible then
                       begin
                         hdef:=hp.left.resultdef;
                         hnodetype:=hp.left.nodetype;
                       end;
                   end
                 else
                   eq:=compare_defs(hdef,hp.left.resultdef,hp.left.nodetype);
                 { the element is not compatible with the previous element
                   which means the constructor is array of const }
                 if eq=te_incompatible then
                   diff:=true;
                 if (not varia) and (eq<te_equal) then
                   begin
                     { If both are integers we need to take the type that can hold both
                       defs }
                     if is_integer(hdef) and is_integer(hp.left.resultdef) then
                       begin
                         if is_in_limit(hdef,hp.left.resultdef) then
                           hdef:=hp.left.resultdef;
                       end
                     else
                       if (nf_novariaallowed in flags) then
                         varia:=true;
                   end;
               end;
              inc(len);
              hp:=tarrayconstructornode(hp.right);
            end;
         end;
         { Set the type of empty or varia arrays to void. Also
           do this if the type is array of const/open array
           because those can't be used with setelementdef }
         if not assigned(hdef) or
            varia or
            is_array_of_const(hdef) or
            is_open_array(hdef) then
           hdef:=voidtype;
         resultdef:=carraydef.create(0,len-1,s32inttype);
         include(tarraydef(resultdef).arrayoptions,ado_IsConstructor);
         if varia then
           include(tarraydef(resultdef).arrayoptions,ado_IsVariant);
         if diff then
           include(tarraydef(resultdef).arrayoptions,ado_IsArrayOfConst);
         tarraydef(resultdef).elementdef:=hdef;
      end;


    procedure tarrayconstructornode.force_type(def:tdef);
      var
        hp : tarrayconstructornode;
      begin
        tarraydef(resultdef).elementdef:=def;
        include(tarraydef(resultdef).arrayoptions,ado_IsConstructor);
        exclude(tarraydef(resultdef).arrayoptions,ado_IsVariant);
        if assigned(left) then
         begin
           hp:=self;
           while assigned(hp) do
            begin
              inserttypeconv(hp.left,def);
              hp:=tarrayconstructornode(hp.right);
            end;
         end;
      end;


    procedure tarrayconstructornode.insert_typeconvs;
      var
        hp        : tarrayconstructornode;
        dovariant : boolean;
      begin
        dovariant:=(nf_forcevaria in flags) or (ado_isvariant in tarraydef(resultdef).arrayoptions);
        { only pass left tree, right tree contains next construct if any }
        if assigned(left) then
         begin
           hp:=self;
           while assigned(hp) do
            begin
              typecheckpass(hp.left);
              { Insert typeconvs for array of const }
              if dovariant then
                { at this time C varargs are no longer an arrayconstructornode }
                insert_varargstypeconv(hp.left,false);
              hp:=tarrayconstructornode(hp.right);
            end;
         end;
      end;


    function tarrayconstructornode.pass_1 : tnode;
      var
        hp : tarrayconstructornode;
        do_variant,
        do_managed_variant:boolean;
      begin
        do_variant:=(nf_forcevaria in flags) or (ado_isvariant in tarraydef(resultdef).arrayoptions);
        do_managed_variant:=
          do_variant and
          (target_info.system in systems_managed_vm);
        result:=nil;
        { Insert required type convs, this must be
          done in pass 1, because the call must be
          typecheckpassed already }
        if assigned(left) then
          begin
            insert_typeconvs;
            { call firstpass for all nodes }
            hp:=self;
            while assigned(hp) do
              begin
                if hp.left<>nil then
                  begin
                    {This check is pessimistic; a call will happen depending
                     on the location in which the elements will be found in
                     pass 2.}
                    if not do_variant then
                      include(current_procinfo.flags,pi_do_call);
                    firstpass(hp.left);
                    if do_managed_variant then
                      wrapmanagedvarrec(hp.left);
                  end;
                hp:=tarrayconstructornode(hp.right);
              end;
          end;
        { set the elementdef to the correct type in case of a variant array }
        if do_variant then
          tarraydef(resultdef).elementdef:=search_system_type('TVARREC').typedef;
        expectloc:=LOC_CREFERENCE;

        inc(current_procinfo.estimatedtempsize,(tarraydef(resultdef).highrange+1)*tarraydef(resultdef).elementdef.size);
      end;


    function tarrayconstructornode.docompare(p: tnode): boolean;
      begin
        docompare:=inherited docompare(p);
      end;


{*****************************************************************************
                              TTYPENODE
*****************************************************************************}

    constructor ttypenode.create(def:tdef);
      begin
         inherited create(typen);
         typedef:=def;
         typesym:=def.typesym;
         allowed:=false;
         helperallowed:=false;
      end;


    constructor ttypenode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
      begin
        inherited ppuload(t,ppufile);
        ppufile.getderef(typedefderef);
        ppufile.getderef(typesymderef);
        allowed:=ppufile.getboolean;
        helperallowed:=ppufile.getboolean;
      end;


    procedure ttypenode.ppuwrite(ppufile:tcompilerppufile);
      begin
        inherited ppuwrite(ppufile);
        ppufile.putderef(typedefderef);
        ppufile.putderef(typesymderef);
        ppufile.putboolean(allowed);
        ppufile.putboolean(helperallowed);
      end;


    procedure ttypenode.buildderefimpl;
      begin
        inherited buildderefimpl;
        typedefderef.build(typedef);
        typesymderef.build(typesym);
      end;


    procedure ttypenode.derefimpl;
      begin
        inherited derefimpl;
        typedef:=tdef(typedefderef.resolve);
        typesym:=tsym(typesymderef.resolve);
      end;


    function ttypenode.pass_typecheck:tnode;
      begin
        result:=nil;
        resultdef:=typedef;
        { check if it's valid }
        if typedef.typ = errordef then
          CGMessage(parser_e_illegal_expression);
      end;


    function ttypenode.pass_1 : tnode;
      begin
         result:=nil;
         expectloc:=LOC_VOID;
         { a typenode can't generate code, so we give here
           an error. Else it'll be an abstract error in pass_generate_code.
           Only when the allowed flag is set we don't generate
           an error }
         if not allowed then
           CGMessage(parser_e_no_type_not_allowed_here);
         if not helperallowed and is_objectpascal_helper(typedef) then
           CGMessage(parser_e_no_category_as_types);
      end;


    function ttypenode.dogetcopy : tnode;
      var
         n : ttypenode;
      begin
         n:=ttypenode(inherited dogetcopy);
         n.allowed:=allowed;
         n.typedef:=typedef;
         n.typesym:=typesym;
         n.helperallowed:=helperallowed;
         result:=n;
      end;


    function ttypenode.docompare(p: tnode): boolean;
      begin
        docompare :=
          inherited docompare(p) and
          (typedef=ttypenode(p).typedef) and
          (typesym=ttypenode(p).typesym) and
          (allowed=ttypenode(p).allowed) and
          (helperallowed=ttypenode(p).helperallowed);
      end;


{*****************************************************************************
                              TRTTINODE
*****************************************************************************}


    constructor trttinode.create(def:tstoreddef;rt:trttitype;dt:Trttidatatype);
      begin
         inherited create(rttin);
         rttidef:=def;
         rttitype:=rt;
         rttidatatype:=dt;
      end;


    constructor trttinode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
      begin
        inherited ppuload(t,ppufile);
        ppufile.getderef(rttidefderef);
        rttitype:=trttitype(ppufile.getbyte);
        rttidatatype:=trttidatatype(ppufile.getbyte);
      end;


    procedure trttinode.ppuwrite(ppufile:tcompilerppufile);
      begin
        inherited ppuwrite(ppufile);
        ppufile.putderef(rttidefderef);
        ppufile.putbyte(byte(rttitype));
        ppufile.putbyte(byte(rttidatatype));
      end;


    procedure trttinode.buildderefimpl;
      begin
        inherited buildderefimpl;
        rttidefderef.build(rttidef);
      end;


    procedure trttinode.derefimpl;
      begin
        inherited derefimpl;
        rttidef:=tstoreddef(rttidefderef.resolve);
      end;


    function trttinode.dogetcopy : tnode;
      var
         n : trttinode;
      begin
         n:=trttinode(inherited dogetcopy);
         n.rttidef:=rttidef;
         n.rttitype:=rttitype;
         n.rttidatatype:=rttidatatype;
         result:=n;
      end;


    function trttinode.pass_typecheck:tnode;
      begin
        { rtti information will be returned as a void pointer }
        result:=nil;
        resultdef:=voidpointertype;
      end;


    function trttinode.pass_1 : tnode;
      begin
        result:=nil;
        expectloc:=LOC_CREFERENCE;
      end;


    function trttinode.docompare(p: tnode): boolean;
      begin
        docompare :=
          inherited docompare(p) and
          (rttidef = trttinode(p).rttidef) and
          (rttitype = trttinode(p).rttitype) and
          (rttidatatype = trttinode(p).rttidatatype);
      end;

end.