{$ifdef tp}
{E+,N+}
{$endif}
{****************************************************************************

                     Copyright (c) 1993,96 by Florian Klämpfl

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

unit tree;

  interface

    uses
       objects,globals,symtable,cobjects,asmgen;

    type
       tconstset = array[0..31] of byte;
       
       pconstset = ^tconstset;

       ttreetyp = (addn,muln,subn,divn,
                   modn,assignn,loadn,rangen,
                   ltn,lten,gtn,gten,
                   equaln,unequaln,inn,orn,
                   xorn,shrn,shln,slashn,
                   andn,subscriptn,derefn,addrn,
                   ordconstn,typeconvn,calln,callparan,
                   realconstn,umminusn,asmn,vecn,
                   stringconstn,funcretn,selfn,
                   notn,inlinen,niln,errorn,
                   typen,hnewn,hdisposen,newn,
                   simpledisposen,setelen,setconstrn,blockn,
                   anwein,loopn,ifn,breakn,
                   continuen,repeatn,whilen,forn,
                   exitn,withn,casen,labeln,
                   goton,simplenewn);

       tconverttype = (tc_equal,tc_not_possible,tc_u8bit_2_s32bit,
                       tc_only_rangechecks32bit,tc_s8bit_2_s32bit,
                       tc_u16bit_2_s32bit,tc_s16bit_2_s32bit,
                       tc_s32bit_2_s16bit,tc_s32bit_2_u8bit,
                       tc_s32bit_2_u16bit,tc_string_to_string,
                       tc_cstring_charpointer,tc_cstring_chararray,
                       tc_array_to_pointer,tc_pointer_to_array,
                       tc_char_to_string,tc_u8bit_2_s16bit,
                       tc_u8bit_2_u16bit,tc_s8bit_2_s16bit,
                       tc_s16bit_2_s8bit,tc_s16bit_2_u8bit,
                       tc_u16bit_2_s8bit,tc_u16bit_2_u8bit,
                       tc_s8bit_2_u16bit,tc_s32bit_2_s8bit,
                       tc_int_2_real,tc_cchar_chararray);

       { gibt an, welche Nachfolger eines Knotens }
       { gelöscht werden müssen }
       tdisposetyp = (dt_nothing,dt_leftright,dt_left,
                      dt_mbleft,dt_string,dt_typeconv,dt_inlinen,
                      dt_mbleft_and_method,dt_constset,dt_loop,dt_case);

       plocation = ^tlocation;

       { Angabe über den Ort eines Operanden im Speicher }
       { LOC_FPU_STACK   auf dem FPU-Stack }
       { LOC_REGISTER    in Prozessorregister }
       { LOC_MEM         im Speicher }
       { LOC_REFERENZ    wie LOC_MEM, nur gleichzeitig lvalue }
       { LOC_JUMP        nur bool'sche Resultate, Sprung zu false- oder }
       {                 truelabel }
       { LOC_FLAGS       nur bool'sche Rsultate, Flags sind gesetzt }
       { LOC_CREGISTER   Register, das nicht verändert werden darf }

       tloc = (LOC_FPUSTACK,LOC_REGISTER,LOC_MEM,LOC_REFERENZ,LOC_JUMP,
               LOC_FLAGS,LOC_CREGISTER);

       tresflags = (F_E,F_NE,F_G,F_L,F_GE,F_LE,F_C,F_NC,
                    F_A,F_AE,F_B,F_BE);

       tlocation = record
          case loc : tloc of
             LOC_REGISTER : (register : tregister);
             LOC_MEM,LOC_REFERENZ : (referenz : treferenz);
             LOC_FPUSTACK : ();
             LOC_JUMP : ();
             LOC_FLAGS : (resflags : tresflags);
       end;

       pcaserecord = ^tcaserecord;

       tcaserecord = record

          { range }
          low,high : longint;

          { only used by gentreejmp }
          at : longint;

          { lable of instruction }
          anweisung : longint;

          { left and right tree node }
          less,greater : pcaserecord;
       end;

       ptree = ^ttree;

       ttree = record
          error : boolean;
          disposetyp : tdisposetyp;
          swaped : boolean; { wird auf true gesetzt, wenn linker und }
                            { rechter Operand vertauscht sind        }
          location : tlocation;
          registers32,registersfpu : integer;
          left,right : ptree;
          resulttype : pdef;
          inputfile : pinputstack;
          line : longint;
          case treetype : ttreetyp of
             callparan : (is_colon_para : boolean);
             loadn : (symtableentry : psym;symtable : psymtable);
             calln : (symtableprocentry : pprocsym;
                      symtableproc : psymtable;procdefinition : pprocdef;
                      methodpointer : ptree);
             ordconstn : (value : longint);
             realconstn : (valued : double;labnumber : longint);
             subscriptn : (vs : pvarsym);
             stringconstn : (values : pstring);
             typeconvn : (convtyp : tconverttype;explizit : boolean);
             inlinen : (inlinenumber : longint);
             setconstrn : (constset : pconstset);
             loopn : (t1,t2 : ptree;backward : boolean);
             asmn : (p_asm : pasmlist);
             casen : (nodes : pcaserecord;elseblock : ptree;ranges : boolean);
             labeln,goton : (labelnr : longint);
       end;

    procedure init_tree;
    function gennode(t : ttreetyp;l,r : ptree) : ptree;
    function genlabelnode(t : ttreetyp;nr : longint) : ptree;
    function genloadnode(v : pvarsym;st : psymtable) : ptree;
    function gensinglenode(t : ttreetyp;l : ptree) : ptree;
    function gensubscriptnode(varsym : pvarsym;l : ptree) : ptree;
    function genordinalconstnode(v : longint;def : pdef) : ptree;
    function gentypeconvnode(node : ptree;t : pdef) : ptree;
    function gencallparanode(expr,next : ptree) : ptree;
    function genrealconstnode(v : double) : ptree;
    function gencallnode(v : pprocsym;st : psymtable) : ptree;
    function genmethodcallnode(v : pprocsym;st : psymtable;mp : ptree) : ptree;
    function genstringconstnode(const s : string) : ptree;
    function genzeronode(t : ttreetyp) : ptree;
    function geninlinenode(number : longint;l : ptree) : ptree;
    function gentypedconstloadnode(sym : ptypedconstsym;st : psymtable) : ptree;
    function genaufzaehlnode(v : paufzaehlsym) : ptree;
    function genselfnode(_class : pdef) : ptree;
    function gensetconstruktnode(settype : pdef;p : pconstset) : ptree;
    function genloopnode(t : ttreetyp;l,r,n1: ptree;back : boolean) : ptree;
    function genasmnode(p_asm : pasmlist) : ptree;
    function gencasenode(l,r : ptree;nodes : pcaserecord) : ptree;

    function getcopy(p : ptree) : ptree;

    procedure disposetree(p : ptree);
    procedure putnode(p : ptree);
    function getnode : ptree;

    const
       flag_2_jmp : array[F_E..F_BE] of tasmop =
          (JE,JNE,JG,JL,JGE,JLE,JC,JNC,
           JA,JAE,JB,JBE);

       flag_2_set : array[F_E..F_BE] of tasmop =
          (SETE,SETNE,SETG,SETL,SETGE,SETLE,SETC,SETNC,
           SETA,SETAE,SETB,SETBE);

    {$I INNR.INC}

  implementation

    { eine Poolverwaltung für die Nodes, was die Geschwindigkeit sehr }
    { steigert }

    var
       wurzel : ptree;

    procedure init_tree;

      begin
         wurzel:=nil;
      end;

    function getnode : ptree;

      var
         hp : ptree;

      begin
         if wurzel=nil then new(hp)
         else
           begin
              hp:=wurzel;
              wurzel:=wurzel^.left;
           end;

         { neue Node hat sicher keinen Fehler }
         hp^.error:=false;

         { auch ist die Position bekannt }
         hp^.line:=inputstack^.line_no;
         hp^.inputfile:=inputstack;

         getnode:=hp;
      end;

    procedure putnode(p : ptree);

      begin
         p^.left:=wurzel;
         wurzel:=p;
      end;

    function getcopy(p : ptree) : ptree;

      var
         hp : ptree;

      begin
         hp:=getnode;
         hp^:=p^;
         case p^.disposetyp of
            dt_leftright : begin
                              if assigned(p^.left) then
                                hp^.left:=getcopy(p^.left);
                              if assigned(p^.right) then
                                hp^.right:=getcopy(p^.right);
                           end;
            dt_nothing : ;
            dt_left    : if assigned(p^.left) then
                           hp^.left:=getcopy(p^.left);
            dt_mbleft : if assigned(p^.left) then
                          hp^.left:=getcopy(p^.left);
            dt_mbleft_and_method : begin
                                      if assigned(p^.left) then
                                        hp^.left:=getcopy(p^.left);
                                      hp^.methodpointer:=getcopy(p^.methodpointer);
                                   end;
            dt_loop : begin
                         if assigned(p^.left) then
                           hp^.left:=getcopy(p^.left);
                         if assigned(p^.right) then
                           hp^.right:=getcopy(p^.right);
                         if assigned(p^.t1) then
                           hp^.t1:=getcopy(p^.t1);
                         if assigned(p^.t2) then
                           hp^.t2:=getcopy(p^.t2);
                      end;
            dt_string : hp^.values:=stringdup(p^.values^);
            dt_typeconv : hp^.left:=getcopy(p^.left);
            dt_inlinen : if assigned(p^.left) then
                           hp^.left:=getcopy(p^.left);
            else internalerror(11);
         end;
         getcopy:=hp;
      end;

    procedure deletecaselabels(p : pcaserecord);

      begin
         if assigned(p^.greater) then
           deletecaselabels(p^.greater);
         if assigned(p^.less) then
           deletecaselabels(p^.less);
         dispose(p);
      end;

    procedure disposetree(p : ptree);

      begin
         if not(assigned(p)) then
           exit;
         case p^.disposetyp of
            dt_leftright : begin
                              if assigned(p^.left) then
                                disposetree(p^.left);
                              if assigned(p^.right) then
                                disposetree(p^.right);
                           end;
            dt_case      : begin
                              if assigned(p^.left) then
                                disposetree(p^.left);
                              if assigned(p^.right) then
                                disposetree(p^.right);
                              if assigned(p^.nodes) then
                                deletecaselabels(p^.nodes);
                              if assigned(p^.elseblock) then
                                disposetree(p^.elseblock);
                           end;
            dt_nothing : ;
            dt_left    : if assigned(p^.left) then
                           disposetree(p^.left);
            dt_mbleft : if assigned(p^.left) then
                          disposetree(p^.left);
            dt_mbleft_and_method : begin
                                      if assigned(p^.left) then disposetree(p^.left);
                                        disposetree(p^.methodpointer);
                                   end;
            dt_string : stringdispose(p^.values);
            dt_typeconv : disposetree(p^.left);
            dt_inlinen : if assigned(p^.left) then
                           disposetree(p^.left);
            dt_loop : begin
                         if assigned(p^.left) then
                           disposetree(p^.left);
                         if assigned(p^.right) then
                           disposetree(p^.right);
                         if assigned(p^.t1) then
                           disposetree(p^.t1);
                         if assigned(p^.t2) then
                           disposetree(p^.t2);
                      end;
            else internalerror(12);
         end;
         putnode(p);
      end;

    function gencallparanode(expr,next : ptree) : ptree;

      var
         p : ptree;

      begin
         p:=getnode;
         p^.disposetyp:=dt_leftright;
         p^.treetype:=callparan;
         p^.left:=expr;
         p^.right:=next;
         p^.registers32:=0;
{         p^.registers16:=0;
         p^.registers8:=0; }
         p^.registersfpu:=0;
         p^.resulttype:=nil;
         p^.is_colon_para:=false;
         gencallparanode:=p;
      end;

    function gennode(t : ttreetyp;l,r : ptree) : ptree;

      var
         p : ptree;

      begin
         p:=getnode;
         p^.disposetyp:=dt_leftright;
         p^.treetype:=t;
         p^.left:=l;
         p^.right:=r;
         p^.registers32:=0;
{         p^.registers16:=0;
         p^.registers8:=0; }
         p^.registersfpu:=0;
         p^.resulttype:=nil;
         gennode:=p;
      end;

    function gencasenode(l,r : ptree;nodes : pcaserecord) : ptree;

      var
         p : ptree;

      begin
         p:=getnode;
         p^.disposetyp:=dt_case;
         p^.treetype:=casen;
         p^.left:=l;
         p^.right:=r;
         p^.nodes:=nodes;
         p^.registers32:=0;
         p^.registersfpu:=0;
         p^.resulttype:=nil;
         gencasenode:=p;
      end;

    function genloopnode(t : ttreetyp;l,r,n1 : ptree;back : boolean) : ptree;

      var
         p : ptree;

      begin
         p:=getnode;
         p^.disposetyp:=dt_loop;
         p^.treetype:=t;
         p^.left:=l;
         p^.right:=r;
         p^.t1:=n1;
         p^.t2:=nil;
         p^.registers32:=0;
         p^.backward:=back;
{         p^.registers16:=0;
         p^.registers8:=0; }
         p^.registersfpu:=0;
         p^.resulttype:=nil;
         genloopnode:=p;
      end;

    function genordinalconstnode(v : longint;def : pdef) : ptree;

      var
         p : ptree;

      begin
         p:=getnode;
         p^.disposetyp:=dt_nothing;
         p^.treetype:=ordconstn;
         p^.registers32:=0;
{         p^.registers16:=0;
         p^.registers8:=0; }
         p^.registersfpu:=0;
         p^.resulttype:=def;
         p^.value:=v;
         genordinalconstnode:=p;
      end;

    function genaufzaehlnode(v : paufzaehlsym) : ptree;

      var
         p : ptree;

      begin
         p:=getnode;
         p^.disposetyp:=dt_nothing;
         p^.treetype:=ordconstn;
         p^.registers32:=0;
{         p^.registers16:=0;
         p^.registers8:=0; }
         p^.registersfpu:=0;
         p^.resulttype:=v^.definition;
         p^.value:=v^.value;
         genaufzaehlnode:=p;
      end;

    function genrealconstnode(v : double) : ptree;

      var
         p : ptree;

      begin
         p:=getnode;
         p^.disposetyp:=dt_nothing;
         p^.treetype:=realconstn;
         p^.registers32:=0;
{         p^.registers16:=0;
         p^.registers8:=0; }
         p^.registersfpu:=0;
         p^.resulttype:=cs64realdef;
         p^.valued:=v;
         p^.labnumber:=-1;
         genrealconstnode:=p;
      end;

    function genstringconstnode(const s : string) : ptree;

      var
         p : ptree;

      begin
         p:=getnode;
         p^.disposetyp:=dt_string;
         p^.treetype:=stringconstn;
         p^.registers32:=0;
{         p^.registers16:=0;
         p^.registers8:=0; }
         p^.registersfpu:=0;
         p^.resulttype:=cstringdef;
         p^.values:=stringdup(s);
         genstringconstnode:=p;
      end;

    function gensinglenode(t : ttreetyp;l : ptree) : ptree;

      var
         p : ptree;

      begin
         p:=getnode;
         p^.disposetyp:=dt_left;
         p^.treetype:=t;
         p^.left:=l;
         p^.registers32:=0;
{         p^.registers16:=0;
         p^.registers8:=0; }
         p^.registersfpu:=0;
         p^.resulttype:=nil;
         gensinglenode:=p;
      end;

    function genasmnode(p_asm : pasmlist) : ptree;

      var
         p : ptree;

      begin
         p:=getnode;
         p^.disposetyp:=dt_nothing;
         p^.treetype:=asmn;
         p^.registers32:=4;
         p^.p_asm:=p_asm;
{         p^.registers16:=0;
         p^.registers8:=0; }
         p^.registersfpu:=8;
         p^.resulttype:=nil;
         genasmnode:=p;
      end;

    function genloadnode(v : pvarsym;st : psymtable) : ptree;

      var
         p : ptree;

      begin
         p:=getnode;
         p^.registers32:=0;
{         p^.registers16:=0;
         p^.registers8:=0; }
         p^.registersfpu:=0;
         p^.treetype:=loadn;
         p^.resulttype:=v^.definition;
         p^.symtableentry:=v;
         p^.symtable:=st;
         p^.disposetyp:=dt_nothing;
         genloadnode:=p;
      end;

    function gentypedconstloadnode(sym : ptypedconstsym;st : psymtable) : ptree;

      var
         p : ptree;

      begin
         p:=getnode;
         p^.registers32:=0;
{         p^.registers16:=0;
         p^.registers8:=0; }
         p^.registersfpu:=0;
         p^.treetype:=loadn;
         p^.resulttype:=sym^.definition;
         p^.symtableentry:=pvarsym(sym);
         p^.symtable:=st;
         p^.disposetyp:=dt_nothing;
         gentypedconstloadnode:=p;
      end;

    function gentypeconvnode(node : ptree;t : pdef) : ptree;

      var
         p : ptree;

      begin
         p:=getnode;
         p^.disposetyp:=dt_typeconv;
         p^.treetype:=typeconvn;
         p^.left:=node;
         p^.registers32:=0;
{         p^.registers16:=0;
         p^.registers8:=0; }
         p^.registersfpu:=0;
         p^.resulttype:=t;
         p^.explizit:=false;
         gentypeconvnode:=p;
      end;

    function gencallnode(v : pprocsym;st : psymtable) : ptree;

      var
         p : ptree;

      begin
         p:=getnode;
         p^.registers32:=0;
{         p^.registers16:=0;
         p^.registers8:=0; }
         p^.registersfpu:=0;
         p^.treetype:=calln;

         p^.symtableprocentry:=v;
         p^.symtableproc:=st;
         p^.disposetyp:=dt_mbleft;
         p^.methodpointer:=nil;
         p^.left:=nil;
         p^.right:=nil;
         p^.procdefinition:=nil;
         gencallnode:=p;
      end;

    function genmethodcallnode(v : pprocsym;st : psymtable;mp : ptree) : ptree;

      var
         p : ptree;

      begin
         p:=getnode;
         p^.registers32:=0;
{         p^.registers16:=0;
         p^.registers8:=0; }
         p^.registersfpu:=0;
         p^.treetype:=calln;

         p^.symtableprocentry:=v;
         p^.symtableproc:=st;
         p^.disposetyp:=dt_mbleft_and_method;
         p^.left:=nil;
         p^.right:=nil;
         p^.methodpointer:=mp;
         p^.procdefinition:=nil;
         genmethodcallnode:=p;
      end;

    function gensubscriptnode(varsym : pvarsym;l : ptree) : ptree;

      var
         p : ptree;

      begin
         p:=getnode;
         p^.disposetyp:=dt_left;
         p^.treetype:=subscriptn;
         p^.left:=l;
         p^.registers32:=0;
         p^.vs:=varsym;
{         p^.registers16:=0;
         p^.registers8:=0; }
         p^.registersfpu:=0;
         p^.resulttype:=nil;
         gensubscriptnode:=p;
      end;

   function genzeronode(t : ttreetyp) : ptree;

      var
         p : ptree;

      begin
         p:=getnode;
         p^.disposetyp:=dt_nothing;
         p^.treetype:=t;
         p^.registers32:=0;
{         p^.registers16:=0;
         p^.registers8:=0; }
         p^.registersfpu:=0;
         p^.resulttype:=nil;
         genzeronode:=p;
      end;

   function genlabelnode(t : ttreetyp;nr : longint) : ptree;

      var
         p : ptree;

      begin
         p:=getnode;
         p^.disposetyp:=dt_nothing;
         p^.treetype:=t;
         p^.registers32:=0;
{         p^.registers16:=0;
         p^.registers8:=0; }
         p^.registersfpu:=0;
         p^.resulttype:=nil;
         p^.labelnr:=nr;
         genlabelnode:=p;
      end;

    function genselfnode(_class : pdef) : ptree;

      var
         p : ptree;

      begin
         p:=getnode;
         p^.disposetyp:=dt_nothing;
         p^.treetype:=selfn;
         p^.registers32:=0;
{         p^.registers16:=0;
         p^.registers8:=0; }
         p^.registersfpu:=0;
         p^.resulttype:=_class;
         genselfnode:=p;
      end;

    function geninlinenode(number : longint;l : ptree) : ptree;

      var
         p : ptree;

      begin
         p:=getnode;
         p^.disposetyp:=dt_inlinen;
         p^.treetype:=inlinen;
         p^.left:=l;
         p^.inlinenumber:=number;
         p^.registers32:=0;
{         p^.registers16:=0;
         p^.registers8:=0; }
         p^.registersfpu:=0;
         p^.resulttype:=nil;
         geninlinenode:=p;
      end;

   function gensetconstruktnode(settype : pdef;p : pconstset) : ptree;

{     var
        p : ptree; }

     begin
{         p:=getnode;
         p^.disposetyp:=dt_constset;
         p^.treetype:=constsetn;
         p^.registers32:=0;
         p^.registersfpu:=0;
         p^.resulttype:=settype;
         p^.setdata:=p;         }
     end;

   function equal_trees(t1,t2 : ptree) : boolean;

     begin
        if t1^.treetype=t2^.treetype then
          begin
             case t1^.treetype of
                addn,
                muln,
                equaln,
                orn,
                xorn,
                andn,
                unequaln:
                   begin
                      equal_trees:=(equal_trees(t1^.left,t2^.left) and
                                    equal_trees(t1^.right,t2^.right)) or
                                   (equal_trees(t1^.right,t2^.left) and
                                    equal_trees(t1^.left,t2^.right));
                   end;
                subn,
                divn,
                modn,
                assignn,
                ltn,
                lten,
                gtn,
                gten,
                inn,
                shrn,
                shln,
                slashn,
                rangen:
                   begin
                      equal_trees:=(equal_trees(t1^.left,t2^.left) and
                                    equal_trees(t1^.right,t2^.right));
                   end;
                umminusn,
                notn,
                derefn,
                addrn:
                   begin
                      equal_trees:=(equal_trees(t1^.left,t2^.left));
                   end;
                loadn:
                   begin
                      equal_trees:=(t1^.symtableentry=t2^.symtableentry)
                                   { unnötig }
                                     and (t1^.symtable=t2^.symtable);
                   end;
                {

                   subscriptn,
                   ordconstn,typeconvn,calln,callparan,
                   realconstn,asmn,vecn,
                   stringconstn,funcretn,selfn,
                   inlinen,niln,errorn,
                   typen,hnewn,hdisposen,newn,
                   disposen,setelen,setconstrn
                }
                else equal_trees:=false;
             end;
          end
        else
          equal_trees:=false;
     end;

end.