fpc/compiler/node.inc

{
    $Id$
    Copyright (c) 1999-2000 by Florian Klaempfl

    The implementation of the abstract 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.

 ****************************************************************************
}

{****************************************************************************
                                 TNODE
 ****************************************************************************}

    constructor tnode.create(tt : tnodetype);

      begin
         inherited create;
         nodetype:=tt;
         { this allows easier error tracing }
         location.loc:=LOC_INVALID;
         { save local info }
         fileinfo:=aktfilepos;
         localswitches:=aktlocalswitches;
         resulttype:=nil;
         registersint:=0;
         registersfpu:=0;
{$ifdef SUPPORT_MMX}
         registersmmx:=0;
{$endif SUPPORT_MMX}
         flags:=[];
      end;

    constructor tnode.createforcopy;

      begin
      end;

    destructor tnode.destroy;

      begin
         { reference info }
         if (location.loc in [LOC_MEM,LOC_REFERENCE]) and
            assigned(location.reference.symbol) then
           dispose(location.reference.symbol,done);
{$ifdef EXTDEBUG}
         if firstpasscount>maxfirstpasscount then
            maxfirstpasscount:=firstpasscount;
{$endif EXTDEBUG}
      end;

    function tnode.pass_1 : tnode;

      begin
         if not(assigned(resulttype)) then
           det_resulttype;

         det_temp;
      end;

    procedure tnode.concattolist(l : plinkedlist);

      begin
{$ifdef newcg}
         l^.concat(self);
{$endif newcg}
      end;

    function tnode.ischild(p : tnode) : boolean;

      begin
         ischild:=false;
      end;
{$ifdef EXTDEBUG}
    procedure tnode.dowrite;

      const treetype2str : array[tnodetype] of string[20] = (
          'addn',
          'muln',
          'subn',
          'divn',
          'symdifn',
          'modn',
          'assignn',
          'loadn',
          'rangen',
          'ltn',
          'lten',
          'gtn',
          'gten',
          'equaln',
          'unequaln',
          'inn',
          'orn',
          'xorn',
          'shrn',
          'shln',
          'slashn',
          'andn',
          'subscriptn',
          'derefn',
          'addrn',
          'doubleaddrn',
          'ordconstn',
          'typeconvn',
          'calln',
          'callparan',
          'realconstn',
          'fixconstn',
          'umminusn',
          'asmn',
          'vecn',
          'stringconstn',
          'funcretn',
          'selfn',
          'notn',
          'inlinen',
          'niln',
          'errorn',
          'typen',
          'hnewn',
          'hdisposen',
          'newn',
          'simpledisposen',
          'setelementn',
          'setconstn',
          'blockn',
          'statementn',
          'loopn',
          'ifn',
          'breakn',
          'continuen',
          'repeatn',
          'whilen',
          'forn',
          'exitn',
          'withn',
          'casen',
          'labeln',
          'goton',
          'simplenewn',
          'tryexceptn',
          'raisen',
          'switchesn',
          'tryfinallyn',
          'onn',
          'isn',
          'asn',
          'caretn',
          'failn',
          'starstarn',
          'procinlinen',
          'arrayconstructn',
          'arrayconstructrangen',
          'nothingn',
          'loadvmtn',
          'pointerconstn');

      begin
         write(indention,'(',treetype2str[nodetype]);
      end;
{$endif EXTDEBUG}

    function tnode.isequal(p : tnode) : boolean;

      begin
         isequal:=assigned(p) and (p.nodetype=nodetype) and
           (flags*flagsequal=p.flags*flagsequal) and
           docompare(p);
      end;

    function tnode.docompare(p : tnode) : boolean;

      begin
         docompare:=true;
      end;

    function tnode.getcopy : tnode;

      var
         p : tnode;

      begin
         { this is quite tricky because we need a node of the current }
         { node type and not one of tnode!                            }
         p:=classtype.createforcopy;
         p.nodetype:=nodetype;
         p.location:=location;
         p.varstateset:=varstateset;
         p.parent:=parent;
         p.flags:=flags;
         p.registers32:=registers32
         p.registersfpu:=registersfpu;
{$ifdef SUPPORT_MMX}
         p.registersmmx:=registersmmx;
         p.registerskni:=registerskni
{$endif SUPPORT_MMX}
         p.resulttype:=resulttype;
         p.fileinfo:=fileinfo;
         p.localswitches:=localswitches;
{$ifdef extdebug}
         p.firstpasscount:=firstpasscount;
{$endif extdebug}
         p.list:=list;
         getcopy:=p;
      end;

    procedure tnode.set_file_line(from : tnode);

      begin
         if assigned(from) then
           fileinfo:=from.fileinfo;
      end;

    procedure tnode.set_tree_filepos(const filepos : tfileposinfo);

      begin
         fileinfo:=filepos;
      end;

    procedure tnode.unset_varstate;

      begin
         internalerror(220920002);
      end;

    procedure tnode.set_varstate(must_be_valid : boolean);

      begin
         internalerror(220920001);
      end;

{$warning FIX ME !!!!!}
{$ifdef dummy}
    procedure unset_varstate(p : ptree);
      begin
        while assigned(p) do
         begin
           p^.varstateset:=false;
           case p^.treetype of
             typeconvn,
             subscriptn,
             vecn :
               p:=p^.left;
             else
               break;
           end;
         end;
      end;


    procedure set_varstate(p : ptree;must_be_valid : boolean);

      begin
         if not assigned(p) then
           exit
         else
           begin
             if p^.varstateset then
               exit;
              case p^.treetype of
           typeconvn :
             if p^.convtyp in
               [
                tc_cchar_2_pchar,
                tc_cstring_2_pchar,
                tc_array_2_pointer
               ] then
               set_varstate(p^.left,false)
             else if p^.convtyp in
               [
                tc_pchar_2_string,
                tc_pointer_2_array
               ] then
               set_varstate(p^.left,true)
             else
               set_varstate(p^.left,must_be_valid);
           subscriptn :
             set_varstate(p^.left,must_be_valid);
           vecn:
             begin
               if (p^.left^.resulttype^.deftype in [stringdef,arraydef]) then
                 set_varstate(p^.left,must_be_valid)
               else
                 set_varstate(p^.left,true);
               set_varstate(p^.right,true);
             end;
           { do not parse calln }
           calln : ;
           callparan:
             begin
               set_varstate(p^.left,must_be_valid);
               set_varstate(p^.right,must_be_valid);
             end;
           loadn :
         if (p^.symtableentry^.typ=varsym) then
          begin
            if must_be_valid and p^.is_first then
              begin
                if (pvarsym(p^.symtableentry)^.varstate=vs_declared_and_first_found) or
                   (pvarsym(p^.symtableentry)^.varstate=vs_set_but_first_not_passed) then
                 if (assigned(pvarsym(p^.symtableentry)^.owner) and
                    assigned(aktprocsym) and
                    (pvarsym(p^.symtableentry)^.owner = aktprocsym^.definition^.localst)) then
                  begin
                    if p^.symtable^.symtabletype=localsymtable then
                     CGMessage1(sym_n_uninitialized_local_variable,pvarsym(p^.symtableentry)^.name)
                    else
                     CGMessage1(sym_n_uninitialized_variable,pvarsym(p^.symtableentry)^.name);
                  end;
              end;
          if (p^.is_first) then
           begin
             if pvarsym(p^.symtableentry)^.varstate=vs_declared_and_first_found then
             { this can only happen at left of an assignment, no ? PM }
              if (parsing_para_level=0) and not must_be_valid then
               pvarsym(p^.symtableentry)^.varstate:=vs_assigned
              else
               pvarsym(p^.symtableentry)^.varstate:=vs_used;
             if pvarsym(p^.symtableentry)^.varstate=vs_set_but_first_not_passed then
               pvarsym(p^.symtableentry)^.varstate:=vs_used;
             p^.is_first:=false;
           end
         else
           begin
             if (pvarsym(p^.symtableentry)^.varstate=vs_assigned) and
                (must_be_valid or (parsing_para_level>0) or
                 (p^.resulttype^.deftype=procvardef)) then
               pvarsym(p^.symtableentry)^.varstate:=vs_used;
             if (pvarsym(p^.symtableentry)^.varstate=vs_declared_and_first_found) and
                (must_be_valid or (parsing_para_level>0) or
                (p^.resulttype^.deftype=procvardef)) then
               pvarsym(p^.symtableentry)^.varstate:=vs_set_but_first_not_passed;
           end;
         end;
         funcretn:
         begin
         { no claim if setting higher return value_str }
         if must_be_valid and
            (procinfo=pprocinfo(p^.funcretprocinfo)) and
            ((procinfo^.funcret_state=vs_declared) or
            ((p^.is_first_funcret) and
             (procinfo^.funcret_state=vs_declared_and_first_found))) then
           begin
             CGMessage(sym_w_function_result_not_set);
             { avoid multiple warnings }
             procinfo^.funcret_state:=vs_assigned;
           end;
         if p^.is_first_funcret and not must_be_valid then
           pprocinfo(p^.funcretprocinfo)^.funcret_state:=vs_assigned;
         end;
         else
           begin
             {internalerror(565656);}
           end;
         end;{case }
         p^.varstateset:=true;
      end;
    end;

{$endif}

{****************************************************************************
                                 TUNARYNODE
 ****************************************************************************}

    constructor tunarynode.create(tt : tnodetype;l : tnode);

      begin
         inherited create(tt);
         left:=l;
      end;

    function tunarynode.docompare(p : tnode) : boolean;

      begin
         docompare:=(inherited docompare(p)) and
           left.isequal(tunarynode(p).left);
      end;

    function.tunarynode.getcopy : tnode;

      var
         p : tunarynode;

      begin
         p:=tunarynode(inherited getcopy);
         p.left:=left.getcopy;
      end;

{$ifdef extdebug}
    procedure tunarynode.dowrite;

      begin
         inherited dowrite;
         writeln(',');
         writenode(left);
         writeln(')');
         dec(byte(indention[0]),2);
      end;
{$endif}

    procedure tunarynode.concattolist(l : plinkedlist);

      begin
         left.parent:=self;
         left.concattolist(l);
         inherited concattolist(l);
      end;

    function tunarynode.ischild(p : tnode) : boolean;

      begin
         ischild:=p=left;
      end;

    procedure tunarynode.det_resulttype;

      begin
         left.det_resulttype;
      end;

    procedure tunarynode.det_temp;

      begin
         left.det_temp;
      end;

{****************************************************************************
                            TBINARYNODE
 ****************************************************************************}

    constructor tbinarynode.create(tt : tnodetype;l,r : tnode);

      begin
         inherited create(tt,l);
         right:=r
      end;

    procedure tbinarynode.concattolist(l : plinkedlist);

      begin
         { we could change that depending on the number of }
         { required registers                              }
         left.parent:=self;
         left.concattolist(l);
         left.parent:=self;
         left.concattolist(l);
         inherited concattolist(l);
      end;

    function tbinarynode.ischild(p : tnode) : boolean;

      begin
         ischild:=(p=right) or (p=right);
      end;

    procedure tbinarynode.det_resulttype;

      begin
         left.det_resulttype;
         right.det_resulttype;
      end;

    procedure tbinarynode.det_temp;

      begin
         left.det_temp;
         right.det_temp;
      end;

    function tbinarynode.docompare(p : tnode) : boolean;

      begin
         docompare:=left.isequal(tbinarynode(p).left) and
           right.isequal(tbinarynode(p).right);
      end;

    function.tbinarynode.getcopy : tnode;

      var
         p : tbinarynode;

      begin
         p:=tbinarynode(inherited getcopy);
         p.right:=right.getcopy;
      end;

    function tbinarynode.isbinaryoverloaded(var t : tnode) : boolean;

     var
         rd,ld   : pdef;
         optoken : ttoken;

      begin
        t:=nil;
        isbinaryoverloaded:=false;
        { overloaded operator ? }
        { load easier access variables }
        rd:=right.resulttype;
        ld:=left.resulttype;
        if isbinaryoperatoroverloadable(ld,rd,voiddef,nodetype) then
          begin
             isbinaryoverloaded:=true;
             {!!!!!!!!! handle paras }
             case nodetype of
                { the nil as symtable signs firstcalln that this is
                  an overloaded operator }
                addn:
                  optoken:=_PLUS;
                subn:
                  optoken:=_MINUS;
                muln:
                  optoken:=_STAR;
                starstarn:
                  optoken:=_STARSTAR;
                slashn:
                  optoken:=_SLASH;
                ltn:
                  optoken:=tokens._lt;
                gtn:
                  optoken:=tokens._gt;
                lten:
                  optoken:=_lte;
                gten:
                  optoken:=_gte;
                equaln,unequaln :
                  optoken:=_EQUAL;
                symdifn :
                  optoken:=_SYMDIF;
                modn :
                  optoken:=_OP_MOD;
                orn :
                  optoken:=_OP_OR;
                xorn :
                  optoken:=_OP_XOR;
                andn :
                  optoken:=_OP_AND;
                divn :
                  optoken:=_OP_DIV;
                shln :
                  optoken:=_OP_SHL;
                shrn :
                  optoken:=_OP_SHR;
                else
                  exit;
             end;
             t:=gencallnode(overloaded_operators[optoken],nil);
             { we have to convert p^.left and p^.right into
              callparanodes }
             if tcallnode(t).symtableprocentry=nil then
               begin
                  CGMessage(parser_e_operator_not_overloaded);
                  t.free;
               end
             else
               begin
                  inc(tcallnode(t).symtableprocentry^.refs);
                  tcallnode(t).left:=gencallparanode(left,nil);
                  tcallnode(t).left:=gencallparanode(right,tcallnode(t).left);
                  if nodetype=unequaln then
                    t:=cnotnode.create(t);

                  firstpass(t);

                  putnode(p);
                  p:=t;
               end;
          end;
      end;

    procedure tbinarynode.swapleftright;

      var
         swapp : tnode;

      begin
         swapp:=right;
         right:=left;
         left:=swapp;
         if nf_swaped in flags then
           exclude(flags,nf_swaped)
         else
           include(flags,nf_swaped);
      end;

    procedure tbinarynode.left_right_max;
      begin
        if assigned(left) then
         begin
           if assigned(right) then
            begin
              registers32:=max(left.registers32,right.registers32);
              registersfpu:=max(left.registersfpu,right.registersfpu);
{$ifdef SUPPORT_MMX}
              registersmmx:=max(left.registersmmx,right.registersmmx);
{$endif SUPPORT_MMX}
            end
           else
            begin
              registers32:=left.registers32;
              registersfpu:=left.registersfpu;
{$ifdef SUPPORT_MMX}
              registersmmx:=left.registersmmx;
{$endif SUPPORT_MMX}
            end;
         end;
      end;

{****************************************************************************
                            TBINOPYNODE
 ****************************************************************************}

    constructor tbinopnode.create(tt : tnodetype;l,r : tnode);

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

    function tbinopnode.docompare(p : tnode) : boolean;

      begin
         docompare:=(inherited docompare(p)) or
           ((nf_swapable in flags) and
            left.isequal(tbinopnode(p).right) and
            right.isequal(tbinopnode(p).left));
      end;
{
  $Log$
  Revision 1.4  2000-09-26 20:06:13  florian
    * hmm, still a lot of work to get things compilable

  Revision 1.3  2000/09/22 21:45:36  florian
    * some updates e.g. getcopy added

  Revision 1.2  2000/09/20 21:52:38  florian
    * removed a lot of errors

  Revision 1.1  2000/08/26 12:27:17  florian
    * createial release

}