home *** CD-ROM | disk | FTP | other *** search
/ AmigActive 2 / AACD 2.iso / AACD / Programming / fpc / compiler / tree.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1998-09-24  |  37.4 KB  |  1,276 lines
  1. {
  2.     $Id: tree.pas,v 1.1.1.1 1998/03/25 11:18:13 root Exp $
  3.     Copyright (c) 1993-98 by Florian Klaempfl
  4.  
  5.     This units exports some routines to manage the parse tree
  6.  
  7.     This program is free software; you can redistribute it and/or modify
  8.     it under the terms of the GNU General Public License as published by
  9.     the Free Software Foundation; either version 2 of the License, or
  10.     (at your option) any later version.
  11.  
  12.     This program is distributed in the hope that it will be useful,
  13.     but WITHOUT ANY WARRANTY; without even the implied warranty of
  14.     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15.     GNU General Public License for more details.
  16.  
  17.     You should have received a copy of the GNU General Public License
  18.     along with this program; if not, write to the Free Software
  19.     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21.  ****************************************************************************
  22. }
  23.  
  24. {$ifdef tp}
  25.   {E+,N+}
  26. {$endif}
  27. unit tree;
  28.  
  29.   interface
  30.  
  31.     uses
  32.        objects,globals,symtable,cobjects,verbose,aasm,files
  33. {$ifdef i386}
  34.        ,i386
  35. {$endif}
  36. {$ifdef m68k}
  37.        ,m68k
  38. {$endif}
  39. {$ifdef alpha}
  40.        ,alpha
  41. {$endif}
  42.        ;
  43.  
  44.     type
  45.        tconstset = array[0..31] of byte;
  46.  
  47.        pconstset = ^tconstset;
  48.  
  49.        ttreetyp = (addn,            {Represents the + operator.}
  50.                    muln,            {Represents the * operator.}
  51.                    subn,            {Represents the - operator.}
  52.                    divn,            {Represents the div operator.}
  53.                    symdifn,         {Represents the >< operator.}
  54.                    modn,            {Represents the mod operator.}
  55.                    assignn,         {Represents an assignment.}
  56.                    loadn,           {Represents the use of a variabele.}
  57.                    rangen,          {Represents a range (i.e. 0..9).}
  58.                    ltn,             {Represents the < operator.}
  59.                    lten,            {Represents the <= operator.}
  60.                    gtn,             {Represents the > operator.}
  61.                    gten,            {Represents the >= operator.}
  62.                    equaln,          {Represents the = operator.}
  63.                    unequaln,        {Represents the <> operator.}
  64.                    inn,             {Represents the in operator.}
  65.                    orn,             {Represents the or operator.}
  66.                    xorn,            {Represents the xor operator.}
  67.                    shrn,            {Represents the shr operator.}
  68.                    shln,            {Represents the shl operator.}
  69.                    slashn,          {Represents the / operator.}
  70.                    andn,            {Represents the and operator.}
  71.                    subscriptn,      {??? Field in a record/object?}
  72.                    derefn,          {Dereferences a pointer.}
  73.                    addrn,           {Represents the @ operator.}
  74.                    doubleaddrn,     {Represents the @@ operator.}
  75.                    ordconstn,       {Represents an ordinal value.}
  76.                    typeconvn,       {Represents type-conversion/typecast.}
  77.                    calln,           {Represents a call node.}
  78.                    callparan,       {Represents a parameter.}
  79.                    realconstn,      {Represents a real value.}
  80.                    fixconstn,       {Represents a fixed value.}
  81.                    umminusn,        {Represents a sign change (i.e. -2).}
  82.                    asmn,            {Represents an assembler node }
  83.                    vecn,            {Represents array indexing.}
  84.                    stringconstn,    {Represents a string constant.}
  85.                    funcretn,        {Represents the function result var.}
  86.                    selfn,           {Represents the self parameter.}
  87.                    notn,            {Represents the not operator.}
  88.                    inlinen,         {Internal procedures (i.e. writeln).}
  89.                    niln,            {Represents the nil pointer.}
  90.                    errorn,          {This part of the tree could not be
  91.                                      parsed because of a compiler error.}
  92.                    typen,           {A type name. Used for i.e. typeof(obj).}
  93.                    hnewn,           {The new operation, constructor call.}
  94.                    hdisposen,       {The dispose operation with destructor call.}
  95.                    newn,            {The new operation, constructor call.}
  96.                    simpledisposen,  {The dispose operation.}
  97.                    setelen,         {A set element (i.e. [a,b]).}
  98.                    setconstrn,      {A set constant (i.e. [1,2]).}
  99.                    blockn,          {A block of statements.}
  100.                    anwein,          {A linear list of nodes.}
  101.                    loopn,           { used in genloopnode, must be converted }
  102.                    ifn,             {An if statement.}
  103.                    breakn,          {A break statement.}
  104.                    continuen,       {A continue statement.}
  105.                    repeatn,         {A repeat until block.}
  106.                    whilen,          {A while do statement.}
  107.                    forn,            {A for loop.}
  108.                    exitn,           {An exit statement.}
  109.                    withn,           {A with statement.}
  110.                    casen,           {A case statement.}
  111.                    labeln,          {A label.}
  112.                    goton,           {A goto statement.}
  113.                    simplenewn,      {The new operation.}
  114.                    tryexceptn,      {A try except block.}
  115.                    raisen,          {A raise statement.}
  116.                    switchesn,       {??? Currently unused...}
  117.                    tryfinallyn,     {A try finally statement.}
  118.                    isn,             {Represents the is operator.}
  119.                    asn,             {Represents the as typecast.}
  120.                    caretn,          {Represents the ^ operator.}
  121.                    failn,           {Represents the fail statement.}
  122.                    { added for optimizations where we cannot suppress }
  123.                    nothingn,
  124.                    loadvmtn);       {???.}
  125.  
  126.        tconverttype = (tc_equal,tc_not_possible,tc_u8bit_2_s32bit,
  127.                       tc_only_rangechecks32bit,tc_s8bit_2_s32bit,
  128.                       tc_u16bit_2_s32bit,tc_s16bit_2_s32bit,
  129.                       tc_s32bit_2_s16bit,tc_s32bit_2_u8bit,
  130.                       tc_s32bit_2_u16bit,tc_string_to_string,
  131.                       tc_cstring_charpointer,tc_string_chararray,
  132.                       tc_array_to_pointer,tc_pointer_to_array,
  133.                       tc_char_to_string,tc_u8bit_2_s16bit,
  134.                       tc_u8bit_2_u16bit,tc_s8bit_2_s16bit,
  135.                       tc_s16bit_2_s8bit,tc_s16bit_2_u8bit,
  136.                       tc_u16bit_2_s8bit,tc_u16bit_2_u8bit,
  137.                       tc_s8bit_2_u16bit,tc_s32bit_2_s8bit,
  138.                       tc_s32bit_2_u32bit,tc_s16bit_2_u32bit,
  139.                       tc_s8bit_2_u32bit,tc_u16bit_2_u32bit,
  140.                       tc_u8bit_2_u32bit,tc_u32bit_2_s32bit,
  141.                       tc_int_2_real,tc_real_2_fix,
  142.                       tc_fix_2_real,tc_int_2_fix,tc_real_2_real,
  143.                       tc_chararray_2_string,tc_bool_2_u8bit,
  144.                       tc_proc2procvar,
  145.                       tc_cchar_charpointer);
  146.  
  147.        { allows to determine which elementes are to be replaced }
  148.        tdisposetyp = (dt_nothing,dt_leftright,dt_left,
  149.                       dt_mbleft,dt_string,dt_typeconv,dt_inlinen,
  150.                       dt_mbleft_and_method,dt_constset,dt_loop,dt_case,
  151.                       dt_with);
  152.  
  153.       { different assignment types }
  154.  
  155.       tassigntyp = (at_normal,at_plus,at_minus,at_star,at_slash);
  156.  
  157.       pcaserecord = ^tcaserecord;
  158.  
  159.       tcaserecord = record
  160.  
  161.           { range }
  162.           _low,_high : longint;
  163.  
  164.           { only used by gentreejmp }
  165.           _at : plabel;
  166.  
  167.           { label of instruction }
  168.           statement : plabel;
  169.  
  170.           { left and right tree node }
  171.           less,greater : pcaserecord;
  172.        end;
  173.  
  174.        ptree = ^ttree;
  175.  
  176.        ttree = record
  177.           error : boolean;
  178.           disposetyp : tdisposetyp;
  179.           { is true, if the right and left operand are swaped }
  180.           swaped : boolean;
  181.  
  182.           { the location of the result of this node }
  183.           location : tlocation;
  184.  
  185.           { the number of registers needed to evalute the node }
  186.           registers32,registersfpu : longint;  { must be longint !!!! }
  187. {$ifdef SUPPORT_MMX}
  188.                   registersmmx : longint;
  189. {$endif SUPPORT_MMX}
  190.           left,right : ptree;
  191.           resulttype : pdef;
  192.           inputfile : pinputfile;
  193.           {$ifdef TP}
  194.           line:word;
  195.           {$else}
  196.           line : longint;
  197.           {$endif}
  198.           pragmas : Tcswitches;
  199. {$ifdef extdebug}
  200.         firstpasscount : longint;
  201. {$endif extdebug}
  202.           case treetype : ttreetyp of
  203.              callparan : (is_colon_para : boolean;exact_match_found : boolean);
  204.              assignn : (assigntyp : tassigntyp);
  205.              loadn : (symtableentry : psym;symtable : psymtable;
  206.                       is_absolute,is_first : boolean);
  207.              calln : (symtableprocentry : pprocsym;
  208.                       symtableproc : psymtable;procdefinition : pprocdef;
  209.                       methodpointer : ptree;
  210.                       unit_specific : boolean);
  211.              ordconstn : (value : longint);
  212.              realconstn : (valued : bestreal;labnumber : longint;realtyp : tait);
  213.              fixconstn : (valuef: longint);
  214. {$ifdef TEST_FUNCRET}
  215.              funcretn : (funcretprocinfo : pointer;retdef : pdef);
  216. {$endif TEST_FUNCRET}
  217.              subscriptn : (vs : pvarsym);
  218.              vecn : (memindex,memseg:boolean);
  219.              stringconstn : (values : pstring;labstrnumber : longint);
  220.              typeconvn : (convtyp : tconverttype;explizit : boolean);
  221.              inlinen : (inlinenumber : longint);
  222.              { procinlinen : (proc : pprocsym); }
  223.              setconstrn : (constset : pconstset);
  224.              loopn : (t1,t2 : ptree;backward : boolean);
  225.              asmn : (p_asm : paasmoutput);
  226.              casen : (nodes : pcaserecord;elseblock : ptree);
  227.              labeln,goton : (labelnr : plabel);
  228.              withn : (withsymtable : psymtable;tablecount : longint);
  229.            end;
  230.  
  231.     procedure init_tree;
  232.     function gennode(t : ttreetyp;l,r : ptree) : ptree;
  233.     function genlabelnode(t : ttreetyp;nr : plabel) : ptree;
  234.     function genloadnode(v : pvarsym;st : psymtable) : ptree;
  235.     function genloadcallnode(v: pprocsym;st: psymtable): ptree;
  236.     function gensinglenode(t : ttreetyp;l : ptree) : ptree;
  237.     function gensubscriptnode(varsym : pvarsym;l : ptree) : ptree;
  238.     function genordinalconstnode(v : longint;def : pdef) : ptree;
  239.     function genfixconstnode(v : longint;def : pdef) : ptree;
  240.     function gentypeconvnode(node : ptree;t : pdef) : ptree;
  241.     function gencallparanode(expr,next : ptree) : ptree;
  242.     function genrealconstnode(v : bestreal) : ptree;
  243.     function gencallnode(v : pprocsym;st : psymtable) : ptree;
  244.     function genmethodcallnode(v : pprocsym;st : psymtable;mp : ptree) : ptree;
  245.     function genstringconstnode(const s : string) : ptree;
  246.     function genzeronode(t : ttreetyp) : ptree;
  247.     function geninlinenode(number : longint;l : ptree) : ptree;
  248.    {
  249.    function genprocinlinenode(code : ptree;procsym : pprocsym) : ptree;
  250.    }
  251.     function gentypedconstloadnode(sym : ptypedconstsym;st : psymtable) : ptree;
  252.     function genenumnode(v : penumsym) : ptree;
  253.     function genselfnode(_class : pdef) : ptree;
  254.     function gensetconstruktnode(s : pconstset;settype : psetdef) : ptree;
  255.     function genloopnode(t : ttreetyp;l,r,n1: ptree;back : boolean) : ptree;
  256.     function genasmnode(p_asm : paasmoutput) : ptree;
  257.     function gencasenode(l,r : ptree;nodes : pcaserecord) : ptree;
  258.     function genwithnode(symtable : psymtable;l,r : ptree;count : longint) : ptree;
  259.  
  260.     function getcopy(p : ptree) : ptree;
  261.  
  262.     function equal_trees(t1,t2 : ptree) : boolean;
  263.  
  264.     procedure disposetree(p : ptree);
  265.     procedure putnode(p : ptree);
  266.     function getnode : ptree;
  267.     procedure clearnodes;
  268.     procedure set_location(var destloc,sourceloc : tlocation);
  269.     procedure swap_location(var destloc,sourceloc : tlocation);
  270.     procedure set_file_line(from,_to : ptree);
  271.  
  272. {$ifdef extdebug}
  273.     const
  274.        maxfirstpasscount : longint = 0;
  275. {$endif extdebug}
  276.  
  277. {$I innr.inc}
  278.  
  279.   implementation
  280.  
  281.     const
  282.        oldswitches : tcswitches = [];
  283.  
  284. {****************************************************************************
  285.         this is a pool for the tree nodes to get more performance
  286.  ****************************************************************************}
  287.  
  288.     var
  289.        root : ptree;
  290.  
  291.     procedure init_tree;
  292.  
  293.       begin
  294.          root:=nil;
  295.       end;
  296.  
  297.     procedure clearnodes;
  298.  
  299.       var
  300.          hp : ptree;
  301.  
  302.       begin
  303.          hp:=root;
  304.          while assigned(hp) do
  305.            begin
  306.               root:=hp^.left;
  307.               dispose(hp);
  308.               hp:=root;
  309.            end;
  310.       end;
  311.  
  312.     function getnode : ptree;
  313.  
  314.       var
  315.          hp : ptree;
  316.  
  317.       begin
  318.          if root=nil then
  319.            new(hp)
  320.          else
  321.            begin
  322.               hp:=root;
  323.               root:=root^.left;
  324.            end;
  325.  
  326.          { makes error tracking easier }
  327.          fillchar(hp^,sizeof(ttree),#0);
  328.          hp^.location.loc:=LOC_INVALID;
  329.  
  330.          { new node is error free }
  331.          hp^.error:=false;
  332.  
  333.          { we know also the position }
  334.          hp^.line:=current_module^.current_inputfile^.line_no;
  335.          hp^.inputfile:=current_module^.current_inputfile;
  336.          hp^.pragmas:=aktswitches;
  337.          getnode:=hp;
  338.       end;
  339.  
  340.     procedure putnode(p : ptree);
  341.  
  342.       begin
  343.          { clean up the contents of a node }
  344.          if p^.treetype=asmn then
  345.            if assigned(p^.p_asm) then
  346.              dispose(p^.p_asm,done);
  347.  
  348.          if p^.treetype=setconstrn then
  349.           if assigned(p^.constset) then
  350.             dispose(p^.constset);
  351.  
  352.          if (p^.location.loc=LOC_MEM) or (p^.location.loc=LOC_REFERENCE) and
  353.            assigned(p^.location.reference.symbol) then
  354.            stringdispose(p^.location.reference.symbol);
  355.  
  356.          if p^.disposetyp=dt_string then
  357.            stringdispose(p^.values);
  358. {$ifdef extdebug}
  359.          if p^.firstpasscount>maxfirstpasscount then
  360.             maxfirstpasscount:=p^.firstpasscount;
  361.          dispose(p);
  362. {$else extdebug}
  363.          p^.left:=root;
  364.          root:=p;
  365. {$endif extdebug}
  366.       end;
  367.  
  368.     function getcopy(p : ptree) : ptree;
  369.  
  370.       var
  371.          hp : ptree;
  372.  
  373.       begin
  374.          hp:=getnode;
  375.          hp^:=p^;
  376.          if assigned(p^.location.reference.symbol) then
  377.            hp^.location.reference.symbol:=stringdup(p^.location.reference.symbol^);
  378.          case p^.disposetyp of
  379.             dt_leftright :
  380.               begin
  381.                  if assigned(p^.left) then
  382.                    hp^.left:=getcopy(p^.left);
  383.                  if assigned(p^.right) then
  384.                    hp^.right:=getcopy(p^.right);
  385.               end;
  386.             dt_nothing : ;
  387.             dt_left    :
  388.               if assigned(p^.left) then
  389.                 hp^.left:=getcopy(p^.left);
  390.             dt_mbleft :
  391.               if assigned(p^.left) then
  392.                 hp^.left:=getcopy(p^.left);
  393.             dt_mbleft_and_method :
  394.               begin
  395.                  if assigned(p^.left) then
  396.                    hp^.left:=getcopy(p^.left);
  397.                  hp^.methodpointer:=getcopy(p^.methodpointer);
  398.               end;
  399.             dt_loop :
  400.               begin
  401.                  if assigned(p^.left) then
  402.                    hp^.left:=getcopy(p^.left);
  403.                  if assigned(p^.right) then
  404.                    hp^.right:=getcopy(p^.right);
  405.                  if assigned(p^.t1) then
  406.                    hp^.t1:=getcopy(p^.t1);
  407.                  if assigned(p^.t2) then
  408.                    hp^.t2:=getcopy(p^.t2);
  409.               end;
  410.             dt_string : hp^.values:=stringdup(p^.values^);
  411.             dt_typeconv : hp^.left:=getcopy(p^.left);
  412.             dt_inlinen :
  413.               if assigned(p^.left) then
  414.                 hp^.left:=getcopy(p^.left);
  415.             else internalerror(11);
  416.          end;
  417.          getcopy:=hp;
  418.       end;
  419.  
  420.     procedure deletecaselabels(p : pcaserecord);
  421.  
  422.       begin
  423.          if assigned(p^.greater) then
  424.            deletecaselabels(p^.greater);
  425.          if assigned(p^.less) then
  426.            deletecaselabels(p^.less);
  427.          dispose(p);
  428.       end;
  429.  
  430.     procedure disposetree(p : ptree);
  431.  
  432.       begin
  433.          if not(assigned(p)) then
  434.            exit;
  435.          case p^.disposetyp of
  436.             dt_leftright :
  437.               begin
  438.                  if assigned(p^.left) then
  439.                    disposetree(p^.left);
  440.                  if assigned(p^.right) then
  441.                    disposetree(p^.right);
  442.               end;
  443.             dt_case :
  444.               begin
  445.                  if assigned(p^.left) then
  446.                    disposetree(p^.left);
  447.                  if assigned(p^.right) then
  448.                    disposetree(p^.right);
  449.                  if assigned(p^.nodes) then
  450.                    deletecaselabels(p^.nodes);
  451.                  if assigned(p^.elseblock) then
  452.                    disposetree(p^.elseblock);
  453.               end;
  454.             dt_nothing : ;
  455.             dt_left    :
  456.               if assigned(p^.left) then
  457.                 disposetree(p^.left);
  458.             dt_mbleft :
  459.               if assigned(p^.left) then
  460.                 disposetree(p^.left);
  461.             dt_mbleft_and_method :
  462.               begin
  463.                  if assigned(p^.left) then disposetree(p^.left);
  464.                  disposetree(p^.methodpointer);
  465.               end;
  466.             dt_string : stringdispose(p^.values);
  467.             dt_constset :
  468.               begin
  469.                  if assigned(p^.constset) then
  470.                    begin
  471.                       dispose(p^.constset);
  472.                       p^.constset:=nil;
  473.                    end;
  474.                  if assigned(p^.left) then
  475.                    disposetree(p^.left);
  476.               end;
  477.             dt_typeconv : disposetree(p^.left);
  478.             dt_inlinen :
  479.               if assigned(p^.left) then
  480.                 disposetree(p^.left);
  481.             dt_loop :
  482.               begin
  483.                  if assigned(p^.left) then
  484.                    disposetree(p^.left);
  485.                  if assigned(p^.right) then
  486.                    disposetree(p^.right);
  487.                  if assigned(p^.t1) then
  488.                    disposetree(p^.t1);
  489.                  if assigned(p^.t2) then
  490.                    disposetree(p^.t2);
  491.               end;
  492.             dt_with :
  493.               begin
  494.                  if assigned(p^.left) then
  495.                    disposetree(p^.left);
  496.                  if assigned(p^.right) then
  497.                    disposetree(p^.right);
  498.                  if assigned(p^.withsymtable) then
  499.                    dispose(p^.withsymtable,done);
  500.               end;
  501.             else internalerror(12);
  502.          end;
  503.          putnode(p);
  504.       end;
  505.  
  506.     procedure set_file_line(from,_to : ptree);
  507.  
  508.       begin
  509.          if from<>nil then
  510.            begin
  511.               _to^.line:=from^.line;
  512.               _to^.inputfile:=from^.inputfile;
  513.            end;
  514.       end;
  515.  
  516.    function genwithnode(symtable : psymtable;l,r : ptree;count : longint) : ptree;
  517.  
  518.       var
  519.          p : ptree;
  520.  
  521.       begin
  522.          p:=getnode;
  523.          p^.disposetyp:=dt_with;
  524.          p^.treetype:=withn;
  525.          p^.left:=l;
  526.          p^.right:=r;
  527.          p^.registers32:=0;
  528.          { p^.registers16:=0;
  529.          p^.registers8:=0; }
  530.          p^.registersfpu:=0;
  531. {$ifdef SUPPORT_MMX}
  532.          p^.registersmmx:=0;
  533. {$endif SUPPORT_MMX}
  534.          p^.resulttype:=nil;
  535.          p^.withsymtable:=symtable;
  536.          p^.tablecount:=count;
  537.          set_file_line(l,p);
  538.          genwithnode:=p;
  539.       end;
  540.  
  541.     function genfixconstnode(v : longint;def : pdef) : ptree;
  542.  
  543.       var
  544.          p : ptree;
  545.  
  546.       begin
  547.          p:=getnode;
  548.          p^.disposetyp:=dt_nothing;
  549.          p^.treetype:=fixconstn;
  550.          p^.registers32:=0;
  551.          { p^.registers16:=0;
  552.          p^.registers8:=0; }
  553.          p^.registersfpu:=0;
  554. {$ifdef SUPPORT_MMX}
  555.          p^.registersmmx:=0;
  556. {$endif SUPPORT_MMX}
  557.          p^.resulttype:=def;
  558.          p^.value:=v;
  559.          genfixconstnode:=p;
  560.       end;
  561.  
  562.     function gencallparanode(expr,next : ptree) : ptree;
  563.  
  564.       var
  565.          p : ptree;
  566.  
  567.       begin
  568.          p:=getnode;
  569.          p^.disposetyp:=dt_leftright;
  570.          p^.treetype:=callparan;
  571.          p^.left:=expr;
  572.          p^.right:=next;
  573.          p^.registers32:=0;
  574.          { p^.registers16:=0;
  575.          p^.registers8:=0; }
  576. {$ifdef SUPPORT_MMX}
  577.          p^.registersmmx:=0;
  578. {$endif SUPPORT_MMX}
  579.          p^.registersfpu:=0;
  580.          p^.resulttype:=nil;
  581.          p^.exact_match_found:=false;
  582.          p^.is_colon_para:=false;
  583.          set_file_line(expr,p);
  584.          gencallparanode:=p;
  585.       end;
  586.  
  587.     function gennode(t : ttreetyp;l,r : ptree) : ptree;
  588.  
  589.       var
  590.          p : ptree;
  591.  
  592.       begin
  593.          p:=getnode;
  594.          p^.disposetyp:=dt_leftright;
  595.          p^.treetype:=t;
  596.          p^.left:=l;
  597.          p^.right:=r;
  598.          p^.registers32:=0;
  599.          { p^.registers16:=0;
  600.          p^.registers8:=0; }
  601.          p^.registersfpu:=0;
  602. {$ifdef SUPPORT_MMX}
  603.          p^.registersmmx:=0;
  604. {$endif SUPPORT_MMX}
  605.          p^.resulttype:=nil;
  606.          gennode:=p;
  607.       end;
  608.  
  609.     function gencasenode(l,r : ptree;nodes : pcaserecord) : ptree;
  610.  
  611.       var
  612.          p : ptree;
  613.  
  614.       begin
  615.          p:=getnode;
  616.          p^.disposetyp:=dt_case;
  617.          p^.treetype:=casen;
  618.          p^.left:=l;
  619.          p^.right:=r;
  620.          p^.nodes:=nodes;
  621.          p^.registers32:=0;
  622.          p^.registersfpu:=0;
  623. {$ifdef SUPPORT_MMX}
  624.          p^.registersmmx:=0;
  625. {$endif SUPPORT_MMX}
  626.          p^.resulttype:=nil;
  627.          set_file_line(l,p);
  628.          gencasenode:=p;
  629.       end;
  630.  
  631.     function genloopnode(t : ttreetyp;l,r,n1 : ptree;back : boolean) : ptree;
  632.  
  633.       var
  634.          p : ptree;
  635.  
  636.       begin
  637.          p:=getnode;
  638.          p^.disposetyp:=dt_loop;
  639.          p^.treetype:=t;
  640.          p^.left:=l;
  641.          p^.right:=r;
  642.          p^.t1:=n1;
  643.          p^.t2:=nil;
  644.          p^.registers32:=0;
  645.          p^.backward:=back;
  646.          { p^.registers16:=0;
  647.          p^.registers8:=0; }
  648.          p^.registersfpu:=0;
  649. {$ifdef SUPPORT_MMX}
  650.          p^.registersmmx:=0;
  651. {$endif SUPPORT_MMX}
  652.          p^.resulttype:=nil;
  653.          set_file_line(l,p);
  654.          genloopnode:=p;
  655.       end;
  656.  
  657.     function genordinalconstnode(v : longint;def : pdef) : ptree;
  658.  
  659.       var
  660.          p : ptree;
  661.  
  662.       begin
  663.          p:=getnode;
  664.          p^.disposetyp:=dt_nothing;
  665.          p^.treetype:=ordconstn;
  666.          p^.registers32:=0;
  667.          { p^.registers16:=0;
  668.          p^.registers8:=0; }
  669.          p^.registersfpu:=0;
  670. {$ifdef SUPPORT_MMX}
  671.          p^.registersmmx:=0;
  672. {$endif SUPPORT_MMX}
  673.          p^.resulttype:=def;
  674.          p^.value:=v;
  675.          genordinalconstnode:=p;
  676.       end;
  677.  
  678.     function genenumnode(v : penumsym) : ptree;
  679.  
  680.       var
  681.          p : ptree;
  682.  
  683.       begin
  684.          p:=getnode;
  685.          p^.disposetyp:=dt_nothing;
  686.          p^.treetype:=ordconstn;
  687.          p^.registers32:=0;
  688. {         p^.registers16:=0;
  689.          p^.registers8:=0; }
  690.          p^.registersfpu:=0;
  691. {$ifdef SUPPORT_MMX}
  692.          p^.registersmmx:=0;
  693. {$endif SUPPORT_MMX}
  694.          p^.resulttype:=v^.definition;
  695.          p^.value:=v^.value;
  696.          genenumnode:=p;
  697.       end;
  698.  
  699.     function genrealconstnode(v : bestreal) : ptree;
  700.  
  701.       var
  702.          p : ptree;
  703.  
  704.       begin
  705.          p:=getnode;
  706.          p^.disposetyp:=dt_nothing;
  707.          p^.treetype:=realconstn;
  708.          p^.registers32:=0;
  709. {         p^.registers16:=0;
  710.          p^.registers8:=0; }
  711.          p^.registersfpu:=0;
  712. {$ifdef SUPPORT_MMX}
  713.          p^.registersmmx:=0;
  714. {$endif SUPPORT_MMX}
  715. {$ifdef i386}
  716.          p^.resulttype:=c64floatdef;
  717.          p^.valued:=v;
  718.          { default value is double }
  719.          p^.realtyp:=ait_real_64bit;
  720. {$endif}
  721. {$ifdef m68k}
  722.          p^.resulttype:=new(pfloatdef,init(s32real));
  723.          p^.valued:=v;
  724.          { default value is double }
  725.          p^.realtyp:=ait_real_32bit;
  726. {$endif}
  727.          p^.labnumber:=-1;
  728.          genrealconstnode:=p;
  729.       end;
  730.  
  731.     function genstringconstnode(const s : string) : ptree;
  732.  
  733.       var
  734.          p : ptree;
  735.  
  736.       begin
  737.          p:=getnode;
  738.          p^.disposetyp:=dt_string;
  739.          p^.treetype:=stringconstn;
  740.          p^.registers32:=0;
  741. {         p^.registers16:=0;
  742.          p^.registers8:=0; }
  743.          p^.registersfpu:=0;
  744. {$ifdef SUPPORT_MMX}
  745.          p^.registersmmx:=0;
  746. {$endif SUPPORT_MMX}
  747.          p^.resulttype:=cstringdef;
  748.          p^.values:=stringdup(s);
  749.          p^.labstrnumber:=-1;
  750.          genstringconstnode:=p;
  751.       end;
  752.  
  753.     function gensinglenode(t : ttreetyp;l : ptree) : ptree;
  754.  
  755.       var
  756.          p : ptree;
  757.  
  758.       begin
  759.          p:=getnode;
  760.          p^.disposetyp:=dt_left;
  761.          p^.treetype:=t;
  762.          p^.left:=l;
  763.          p^.registers32:=0;
  764. {         p^.registers16:=0;
  765.          p^.registers8:=0; }
  766.          p^.registersfpu:=0;
  767. {$ifdef SUPPORT_MMX}
  768.          p^.registersmmx:=0;
  769. {$endif SUPPORT_MMX}
  770.          p^.resulttype:=nil;
  771.          gensinglenode:=p;
  772.       end;
  773.  
  774.     function genasmnode(p_asm : paasmoutput) : ptree;
  775.  
  776.       var
  777.          p : ptree;
  778.  
  779.       begin
  780.          p:=getnode;
  781.          p^.disposetyp:=dt_nothing;
  782.          p^.treetype:=asmn;
  783.          p^.registers32:=4;
  784.          p^.p_asm:=p_asm;
  785. {         p^.registers16:=0;
  786.          p^.registers8:=0; }
  787.          p^.registersfpu:=8;
  788. {$ifdef SUPPORT_MMX}
  789.          p^.registersmmx:=8;
  790. {$endif SUPPORT_MMX}
  791.          p^.resulttype:=nil;
  792.          genasmnode:=p;
  793.       end;
  794.  
  795.     function genloadnode(v : pvarsym;st : psymtable) : ptree;
  796.  
  797.       var
  798.          p : ptree;
  799.  
  800.       begin
  801.          p:=getnode;
  802.          p^.registers32:=0;
  803. {         p^.registers16:=0;
  804.          p^.registers8:=0; }
  805.          p^.registersfpu:=0;
  806. {$ifdef SUPPORT_MMX}
  807.          p^.registersmmx:=0;
  808. {$endif SUPPORT_MMX}
  809.          p^.treetype:=loadn;
  810.          p^.resulttype:=v^.definition;
  811.          p^.symtableentry:=v;
  812.          p^.symtable:=st;
  813.          p^.is_first := False;
  814.          p^.disposetyp:=dt_nothing;
  815.          genloadnode:=p;
  816.       end;
  817.  
  818.     function genloadcallnode(v: pprocsym;st: psymtable): ptree;
  819.       var
  820.          p : ptree;
  821.  
  822.       begin
  823.          p:=getnode;
  824.          p^.registers32:=0;
  825. {         p^.registers16:=0;
  826.          p^.registers8:=0; }
  827.          p^.registersfpu:=0;
  828. {$ifdef SUPPORT_MMX}
  829.          p^.registersmmx:=0;
  830. {$endif SUPPORT_MMX}
  831.          p^.treetype:=loadn;
  832.          p^.resulttype:=v^.definition;
  833.          p^.symtableentry:=v;
  834.          p^.symtable:=st;
  835.          p^.is_first := False;
  836.          p^.disposetyp:=dt_nothing;
  837.          genloadcallnode:=p;
  838.       end;
  839.  
  840.  
  841.     function gentypedconstloadnode(sym : ptypedconstsym;st : psymtable) : ptree;
  842.  
  843.       var
  844.          p : ptree;
  845.  
  846.       begin
  847.          p:=getnode;
  848.          p^.registers32:=0;
  849. {         p^.registers16:=0;
  850.          p^.registers8:=0; }
  851.          p^.registersfpu:=0;
  852. {$ifdef SUPPORT_MMX}
  853.          p^.registersmmx:=0;
  854. {$endif SUPPORT_MMX}
  855.          p^.treetype:=loadn;
  856.          p^.resulttype:=sym^.definition;
  857.          p^.symtableentry:=pvarsym(sym);
  858.          p^.symtable:=st;
  859.          p^.disposetyp:=dt_nothing;
  860.          gentypedconstloadnode:=p;
  861.       end;
  862.  
  863.     function gentypeconvnode(node : ptree;t : pdef) : ptree;
  864.  
  865.       var
  866.          p : ptree;
  867.  
  868.       begin
  869.          p:=getnode;
  870.          p^.disposetyp:=dt_typeconv;
  871.          p^.treetype:=typeconvn;
  872.          p^.left:=node;
  873.          p^.registers32:=0;
  874. {         p^.registers16:=0;
  875.          p^.registers8:=0; }
  876.          p^.convtyp:=tc_equal;
  877.          p^.registersfpu:=0;
  878. {$ifdef SUPPORT_MMX}
  879.          p^.registersmmx:=0;
  880. {$endif SUPPORT_MMX}
  881.          p^.resulttype:=t;
  882.          p^.convtyp:=tc_equal;
  883.          p^.explizit:=false;
  884.          set_file_line(node,p);
  885.          gentypeconvnode:=p;
  886.       end;
  887.  
  888.     function gencallnode(v : pprocsym;st : psymtable) : ptree;
  889.  
  890.       var
  891.          p : ptree;
  892.  
  893.       begin
  894.          p:=getnode;
  895.          p^.registers32:=0;
  896. {         p^.registers16:=0;
  897.          p^.registers8:=0; }
  898.          p^.registersfpu:=0;
  899. {$ifdef SUPPORT_MMX}
  900.          p^.registersmmx:=0;
  901. {$endif SUPPORT_MMX}
  902.          p^.treetype:=calln;
  903.          p^.symtableprocentry:=v;
  904.          p^.symtableproc:=st;
  905.          p^.unit_specific:=false;
  906.          p^.disposetyp := dt_leftright;
  907.          p^.methodpointer:=nil;
  908.          p^.left:=nil;
  909.          p^.right:=nil;
  910.          p^.procdefinition:=nil;
  911.          gencallnode:=p;
  912.       end;
  913.  
  914.     function genmethodcallnode(v : pprocsym;st : psymtable;mp : ptree) : ptree;
  915.  
  916.       var
  917.          p : ptree;
  918.  
  919.       begin
  920.          p:=getnode;
  921.          p^.registers32:=0;
  922. {         p^.registers16:=0;
  923.          p^.registers8:=0; }
  924.          p^.registersfpu:=0;
  925. {$ifdef SUPPORT_MMX}
  926.          p^.registersmmx:=0;
  927. {$endif SUPPORT_MMX}
  928.          p^.treetype:=calln;
  929.  
  930.          p^.symtableprocentry:=v;
  931.          p^.symtableproc:=st;
  932.          p^.disposetyp:=dt_mbleft_and_method;
  933.          p^.left:=nil;
  934.          p^.right:=nil;
  935.          p^.methodpointer:=mp;
  936.          p^.procdefinition:=nil;
  937.          genmethodcallnode:=p;
  938.       end;
  939.  
  940.     function gensubscriptnode(varsym : pvarsym;l : ptree) : ptree;
  941.  
  942.       var
  943.          p : ptree;
  944.  
  945.       begin
  946.          p:=getnode;
  947.          p^.disposetyp:=dt_left;
  948.          p^.treetype:=subscriptn;
  949.          p^.left:=l;
  950.          p^.registers32:=0;
  951.          p^.vs:=varsym;
  952. {         p^.registers16:=0;
  953.          p^.registers8:=0; }
  954.          p^.registersfpu:=0;
  955. {$ifdef SUPPORT_MMX}
  956.          p^.registersmmx:=0;
  957. {$endif SUPPORT_MMX}
  958.          p^.resulttype:=nil;
  959.          gensubscriptnode:=p;
  960.       end;
  961.  
  962.    function genzeronode(t : ttreetyp) : ptree;
  963.  
  964.       var
  965.          p : ptree;
  966.  
  967.       begin
  968.          p:=getnode;
  969.          p^.disposetyp:=dt_nothing;
  970.          p^.treetype:=t;
  971.          p^.registers32:=0;
  972. {         p^.registers16:=0;
  973.          p^.registers8:=0; }
  974.          p^.registersfpu:=0;
  975. {$ifdef SUPPORT_MMX}
  976.          p^.registersmmx:=0;
  977. {$endif SUPPORT_MMX}
  978.          p^.resulttype:=nil;
  979.          genzeronode:=p;
  980.       end;
  981.  
  982.    function genlabelnode(t : ttreetyp;nr : plabel) : ptree;
  983.  
  984.       var
  985.          p : ptree;
  986.  
  987.       begin
  988.          p:=getnode;
  989.          p^.disposetyp:=dt_nothing;
  990.          p^.treetype:=t;
  991.          p^.registers32:=0;
  992. {         p^.registers16:=0;
  993.          p^.registers8:=0; }
  994.          p^.registersfpu:=0;
  995. {$ifdef SUPPORT_MMX}
  996.          p^.registersmmx:=0;
  997. {$endif SUPPORT_MMX}
  998.          p^.resulttype:=nil;
  999.          { for security }
  1000.          { nr^.is_used:=true;}
  1001.          p^.labelnr:=nr;
  1002.          genlabelnode:=p;
  1003.       end;
  1004.  
  1005.     function genselfnode(_class : pdef) : ptree;
  1006.  
  1007.       var
  1008.          p : ptree;
  1009.  
  1010.       begin
  1011.          p:=getnode;
  1012.          p^.disposetyp:=dt_nothing;
  1013.          p^.treetype:=selfn;
  1014.          p^.registers32:=0;
  1015. {         p^.registers16:=0;
  1016.          p^.registers8:=0; }
  1017.          p^.registersfpu:=0;
  1018. {$ifdef SUPPORT_MMX}
  1019.          p^.registersmmx:=0;
  1020. {$endif SUPPORT_MMX}
  1021.          p^.resulttype:=_class;
  1022.          genselfnode:=p;
  1023.       end;
  1024.  
  1025.    function geninlinenode(number : longint;l : ptree) : ptree;
  1026.  
  1027.       var
  1028.          p : ptree;
  1029.  
  1030.       begin
  1031.          p:=getnode;
  1032.          p^.disposetyp:=dt_inlinen;
  1033.          p^.treetype:=inlinen;
  1034.          p^.left:=l;
  1035.          p^.inlinenumber:=number;
  1036.          p^.registers32:=0;
  1037. {         p^.registers16:=0;
  1038.          p^.registers8:=0; }
  1039.          p^.registersfpu:=0;
  1040. {$ifdef SUPPORT_MMX}
  1041.          p^.registersmmx:=0;
  1042. {$endif SUPPORT_MMX}
  1043.          p^.resulttype:=nil;
  1044.          geninlinenode:=p;
  1045.       end;
  1046.  
  1047.  
  1048. {    function genprocinlinenode(code : ptree;proc : pprocsym) : ptree;
  1049.  
  1050.       var
  1051.          p : ptree;
  1052.  
  1053.       begin
  1054.          p:=getnode;
  1055.          p^.disposetyp:=dt_inlinen;
  1056.          p^.treetype:=inlinen;
  1057.          p^.inlineproc:=proc;
  1058.          p^.left:=code;
  1059.          p^.registers32:=code^.registers32;
  1060.          p^.registersfpu:=code^.registersfpu;
  1061. $ifdef SUPPORT_MMX
  1062.          p^.registersmmx:=0;
  1063. $endif SUPPORT_MMX
  1064.          p^.resulttype:=proc^.definition^.returntype;
  1065.          genprocinlinenode:=p;
  1066.       end; }
  1067.  
  1068.    function gensetconstruktnode(s : pconstset;settype : psetdef) : ptree;
  1069.  
  1070.      var
  1071.         p : ptree;
  1072.  
  1073.      begin
  1074.         p:=getnode;
  1075.         p^.disposetyp:=dt_constset;
  1076.         p^.treetype:=setconstrn;
  1077.         p^.registers32:=0;
  1078.         p^.registersfpu:=0;
  1079. {$ifdef SUPPORT_MMX}
  1080.          p^.registersmmx:=0;
  1081. {$endif SUPPORT_MMX}
  1082.          p^.resulttype:=settype;
  1083.          p^.left:=nil;
  1084.          new(p^.constset);
  1085.          p^.constset^:=s^;
  1086.          gensetconstruktnode:=p;
  1087.       end;
  1088.  
  1089.     function equal_trees(t1,t2 : ptree) : boolean;
  1090.  
  1091.       begin
  1092.          if t1^.treetype=t2^.treetype then
  1093.            begin
  1094.               case t1^.treetype of
  1095.                  addn,
  1096.                  muln,
  1097.                  equaln,
  1098.                  orn,
  1099.                  xorn,
  1100.                  andn,
  1101.                  unequaln:
  1102.                    begin
  1103.                       equal_trees:=(equal_trees(t1^.left,t2^.left) and
  1104.                                     equal_trees(t1^.right,t2^.right)) or
  1105.                                    (equal_trees(t1^.right,t2^.left) and
  1106.                                     equal_trees(t1^.left,t2^.right));
  1107.                    end;
  1108.                  subn,
  1109.                  divn,
  1110.                  modn,
  1111.                  assignn,
  1112.                  ltn,
  1113.                  lten,
  1114.                  gtn,
  1115.                  gten,
  1116.                  inn,
  1117.                  shrn,
  1118.                  shln,
  1119.                  slashn,
  1120.                  rangen:
  1121.                    begin
  1122.                       equal_trees:=(equal_trees(t1^.left,t2^.left) and
  1123.                                     equal_trees(t1^.right,t2^.right));
  1124.                    end;
  1125.                  umminusn,
  1126.                  notn,
  1127.                  derefn,
  1128.                  addrn:
  1129.                    begin
  1130.                       equal_trees:=(equal_trees(t1^.left,t2^.left));
  1131.                    end;
  1132.                 loadn:
  1133.                    begin
  1134.                       equal_trees:=(t1^.symtableentry=t2^.symtableentry)
  1135.                         { not necessary
  1136.                                      and (t1^.symtable=t2^.symtable)};
  1137.                    end;
  1138.                 {
  1139.  
  1140.                    subscriptn,
  1141.                    ordconstn,typeconvn,calln,callparan,
  1142.                    realconstn,asmn,vecn,
  1143.                    stringconstn,funcretn,selfn,
  1144.                    inlinen,niln,errorn,
  1145.                    typen,hnewn,hdisposen,newn,
  1146.                    disposen,setelen,setconstrn
  1147.                 }
  1148.                 else equal_trees:=false;
  1149.              end;
  1150.           end
  1151.         else
  1152.           equal_trees:=false;
  1153.      end;
  1154.  
  1155.     {This is needed if you want to be able to delete the string with the nodes !!}
  1156.     procedure set_location(var destloc,sourceloc : tlocation);
  1157.  
  1158.       begin
  1159.         if assigned(destloc.reference.symbol) then
  1160.           stringdispose(destloc.reference.symbol);
  1161.         destloc:= sourceloc;
  1162.         if sourceloc.loc in [LOC_MEM,LOC_REFERENCE] then
  1163.           begin
  1164.              if assigned(sourceloc.reference.symbol) then
  1165.                destloc.reference.symbol:=
  1166.                  stringdup(sourceloc.reference.symbol^);
  1167.           end
  1168.         else
  1169.           destloc.reference.symbol:=nil;
  1170.       end;
  1171.  
  1172.     procedure swap_location(var destloc,sourceloc : tlocation);
  1173.  
  1174.       var
  1175.          swapl : tlocation;
  1176.  
  1177.       begin
  1178.          swapl := destloc;
  1179.          destloc := sourceloc;
  1180.          sourceloc := swapl;
  1181.       end;
  1182. end.
  1183. {
  1184.   $Log: tree.pas,v $
  1185.   Revision 1.1.1.1  1998/03/25 11:18:13  root
  1186.   * Restored version
  1187.  
  1188.   Revision 1.15  1998/03/24 21:48:36  florian
  1189.     * just a couple of fixes applied:
  1190.          - problem with fixed16 solved
  1191.          - internalerror 10005 problem fixed
  1192.          - patch for assembler reading
  1193.          - small optimizer fix
  1194.          - mem is now supported
  1195.  
  1196.   Revision 1.14  1998/03/10 16:27:46  pierre
  1197.     * better line info in stabs debug
  1198.     * symtabletype and lexlevel separated into two fields of tsymtable
  1199.     + ifdef MAKELIB for direct library output, not complete
  1200.     + ifdef CHAINPROCSYMS for overloaded seach across units, not fully
  1201.       working
  1202.     + ifdef TESTFUNCRET for setting func result in underfunction, not
  1203.       working
  1204.  
  1205.   Revision 1.13  1998/03/10 01:17:30  peter
  1206.     * all files have the same header
  1207.     * messages are fully implemented, EXTDEBUG uses Comment()
  1208.     + AG... files for the Assembler generation
  1209.  
  1210.   Revision 1.12  1998/03/02 01:49:37  peter
  1211.     * renamed target_DOS to target_GO32V1
  1212.     + new verbose system, merged old errors and verbose units into one new
  1213.       verbose.pas, so errors.pas is obsolete
  1214.  
  1215.   Revision 1.11  1998/02/27 09:26:18  daniel
  1216.   * Changed symtable handling so no junk symtable is put on the symtablestack.
  1217.  
  1218.   Revision 1.10  1998/02/13 10:35:54  daniel
  1219.   * Made Motorola version compilable.
  1220.   * Fixed optimizer
  1221.  
  1222.   Revision 1.9  1998/02/12 11:50:51  daniel
  1223.   Yes! Finally! After three retries, my patch!
  1224.  
  1225.   Changes:
  1226.  
  1227.   Complete rewrite of psub.pas.
  1228.   Added support for DLL's.
  1229.   Compiler requires less memory.
  1230.   Platform units for each platform.
  1231.  
  1232.   Revision 1.8  1998/02/04 14:39:31  florian
  1233.     * small clean up
  1234.  
  1235.   Revision 1.7  1998/01/13 23:11:16  florian
  1236.     + class methods
  1237.  
  1238.   Revision 1.6  1998/01/11 04:16:36  carl
  1239.   + correct floating point support for m68k
  1240.  
  1241.   Revision 1.5  1998/01/07 00:17:11  michael
  1242.   Restored released version (plus fixes) as current
  1243.  
  1244.   Revision 1.3  1997/12/04 12:02:15  pierre
  1245.      + added a counter of max firstpass's for a ptree
  1246.        for debugging only in ifdef extdebug
  1247.  
  1248.   Revision 1.2  1997/11/29 15:43:08  florian
  1249.   * some minor changes
  1250.  
  1251.   Revision 1.1.1.1  1997/11/27 08:33:03  michael
  1252.   FPC Compiler CVS start
  1253.  
  1254.   Pre-CVS log:
  1255.  
  1256.     CEC    Carl-Eric Codere
  1257.     FK     Florian Klaempfl
  1258.     PM     Pierre Muller
  1259.     +      feature added
  1260.     -      removed
  1261.     *      bug fixed or changed
  1262.  
  1263.     History:
  1264.         19th october 1996:
  1265.             + adapted to version 0.9.0
  1266.          6th september 1997:
  1267.             + added support for MC68000 (CEC)
  1268.          3rd october 1997:
  1269.             + added tc_bool_2_u8bit for in_ord_x (PM)
  1270.          3rd november1997:
  1271.             + added symdifn for sets (PM)
  1272.          13th november 1997:
  1273.             + added partial code for u32bit support (PM)
  1274. }
  1275.  
  1276.