freepascal.compiler/compiler/ncon.pas

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

    Type checking and register allocation for constants

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

{$i defines.inc}

interface

    uses
      globtype,widestr,
      node,
      aasm,cpuinfo,
      symconst,symtype,symdef,symsym;

    type
       trealconstnode = class(tnode)
          value_real : bestreal;
          lab_real : pasmlabel;
          constructor create(v : bestreal;def : pdef);virtual;
          function getcopy : tnode;override;
          function pass_1 : tnode;override;
          function docompare(p: tnode) : boolean; override;
       end;

       tfixconstnode = class(tnode)
          value_fix: longint;
          constructor create(v : longint;def : pdef);virtual;
          function getcopy : tnode;override;
          function pass_1 : tnode;override;
          function docompare(p: tnode) : boolean; override;
       end;

       tordconstnode = class(tnode)
          value : TConstExprInt;
          constructor create(v : tconstexprint;def : pdef);virtual;
          function getcopy : tnode;override;
          function pass_1 : tnode;override;
          function docompare(p: tnode) : boolean; override;
       end;

       tpointerconstnode = class(tnode)
          value : TPointerOrd;
          constructor create(v : tpointerord;def : pdef);virtual;
          function getcopy : tnode;override;
          function pass_1 : tnode;override;
          function docompare(p: tnode) : boolean; override;
       end;

       tstringconstnode = class(tnode)
          value_str : pchar;
          len : longint;
          lab_str : pasmlabel;
          stringtype : tstringtype;
          constructor createstr(const s : string;st:tstringtype);virtual;
          constructor createpchar(s : pchar;l : longint);virtual;
          constructor createwstr(const w : tcompilerwidestring);virtual;
          destructor destroy;override;
          function getcopy : tnode;override;
          function pass_1 : tnode;override;
          function getpcharcopy : pchar;
          function docompare(p: tnode) : boolean; override;
       end;

       tsetconstnode = class(tunarynode)
          value_set : pconstset;
          lab_set : pasmlabel;
          constructor create(s : pconstset;settype : psetdef);virtual;
          destructor destroy;override;
          function getcopy : tnode;override;
          function pass_1 : tnode;override;
          function docompare(p: tnode) : boolean; override;
       end;

       tnilnode = class(tnode)
          constructor create;virtual;
          function pass_1 : tnode;override;
       end;

    var
       crealconstnode : class of trealconstnode;
       cfixconstnode : class of tfixconstnode;
       cordconstnode : class of tordconstnode;
       cpointerconstnode : class of tpointerconstnode;
       cstringconstnode : class of tstringconstnode;
       csetconstnode : class of tsetconstnode;
       cnilnode : class of tnilnode;

    function genordinalconstnode(v : TConstExprInt;def : pdef) : tordconstnode;
    { same as genordinalconstnode, but the resulttype }
    { is determines automatically                     }
    function genintconstnode(v : TConstExprInt) : tordconstnode;
    function genpointerconstnode(v : tpointerord;def : pdef) : tpointerconstnode;
    function genenumnode(v : penumsym) : tordconstnode;
    function genfixconstnode(v : longint;def : pdef) : tfixconstnode;
    function genrealconstnode(v : bestreal;def : pdef) : trealconstnode;
    { allow pchar or string for defining a pchar node }
    function genstringconstnode(const s : string;st:tstringtype) : tstringconstnode;
    { length is required for ansistrings }
    function genpcharconstnode(s : pchar;length : longint) : tstringconstnode;
    function genwstringconstnode(const w : tcompilerwidestring) : tnode;
    function gensetconstnode(s : pconstset;settype : psetdef) : tsetconstnode;

    { some helper routines }

{$ifdef INT64FUNCRESOK}
    function get_ordinal_value(p : tnode) : TConstExprInt;
{$else INT64FUNCRESOK}
    function get_ordinal_value(p : tnode) : longint;
{$endif INT64FUNCRESOK}
    function is_constnode(p : tnode) : boolean;
    function is_constintnode(p : tnode) : boolean;
    function is_constcharnode(p : tnode) : boolean;
    function is_constrealnode(p : tnode) : boolean;
    function is_constboolnode(p : tnode) : boolean;
    function is_constresourcestringnode(p : tnode) : boolean;
    function str_length(p : tnode) : longint;
    function is_emptyset(p : tnode):boolean;
    function genconstsymtree(p : pconstsym) : tnode;

implementation

    uses
      cutils,verbose,globals,systems,
      types,cpubase,nld;

    function genordinalconstnode(v : tconstexprint;def : pdef) : tordconstnode;
      begin
         genordinalconstnode:=cordconstnode.create(v,def);
      end;


    function genintconstnode(v : TConstExprInt) : tordconstnode;

      var
         i,i2 : TConstExprInt;

      begin
         { we need to bootstrap this code, so it's a little bit messy }
         i:=2147483647;
         { maxcardinal }
         i2 := i+i+1;
         if (v<=i) and (v>=-i-1) then
           genintconstnode:=genordinalconstnode(v,s32bitdef)
         else if (v > i) and (v <= i2) then
           genintconstnode:=genordinalconstnode(v,u32bitdef)
         else
           genintconstnode:=genordinalconstnode(v,cs64bitdef);
      end;


    function genpointerconstnode(v : tpointerord;def : pdef) : tpointerconstnode;
      begin
         genpointerconstnode:=cpointerconstnode.create(v,def);
      end;


    function genenumnode(v : penumsym) : tordconstnode;
      begin
         genenumnode:=cordconstnode.create(v^.value,v^.definition);
      end;


    function gensetconstnode(s : pconstset;settype : psetdef) : tsetconstnode;
      begin
         gensetconstnode:=csetconstnode.create(s,settype);
      end;


    function genrealconstnode(v : bestreal;def : pdef) : trealconstnode;
      begin
         genrealconstnode:=crealconstnode.create(v,def);
      end;


    function genfixconstnode(v : longint;def : pdef) : tfixconstnode;
      begin
         genfixconstnode:=cfixconstnode.create(v,def);
      end;


    function genstringconstnode(const s : string;st:tstringtype) : tstringconstnode;
      begin
         genstringconstnode:=cstringconstnode.createstr(s,st);
      end;

    function genwstringconstnode(const w : tcompilerwidestring) : tnode;

      begin
         genwstringconstnode:=cstringconstnode.createwstr(w);
      end;


    function genpcharconstnode(s : pchar;length : longint) : tstringconstnode;
      begin
         genpcharconstnode:=cstringconstnode.createpchar(s,length);
      end;

{$ifdef INT64FUNCRESOK}
    function get_ordinal_value(p : tnode) : TConstExprInt;
{$else INT64FUNCRESOK}
    function get_ordinal_value(p : tnode) : longint;
{$endif INT64FUNCRESOK}
      begin
         if p.nodetype=ordconstn then
           get_ordinal_value:=tordconstnode(p).value
         else
           begin
             Message(type_e_ordinal_expr_expected);
             get_ordinal_value:=0;
           end;
      end;


    function is_constnode(p : tnode) : boolean;
      begin
        is_constnode:=(p.nodetype in [ordconstn,realconstn,stringconstn,fixconstn,setconstn]);
      end;


    function is_constintnode(p : tnode) : boolean;
      begin
         is_constintnode:=(p.nodetype=ordconstn) and is_integer(p.resulttype);
      end;


    function is_constcharnode(p : tnode) : boolean;

      begin
         is_constcharnode:=(p.nodetype=ordconstn) and is_char(p.resulttype);
      end;


    function is_constrealnode(p : tnode) : boolean;

      begin
         is_constrealnode:=(p.nodetype=realconstn);
      end;


    function is_constboolnode(p : tnode) : boolean;

      begin
         is_constboolnode:=(p.nodetype=ordconstn) and is_boolean(p.resulttype);
      end;


    function is_constresourcestringnode(p : tnode) : boolean;
      begin
        is_constresourcestringnode:=(p.nodetype=loadn) and
          (tloadnode(p).symtableentry^.typ=constsym) and
          (pconstsym(tloadnode(p).symtableentry)^.consttyp=constresourcestring);
      end;


    function str_length(p : tnode) : longint;

      begin
         str_length:=tstringconstnode(p).len;
      end;


    function is_emptyset(p : tnode):boolean;

      var
        i : longint;
      begin
        i:=0;
        if p.nodetype=setconstn then
         begin
           while (i<32) and (tsetconstnode(p).value_set^[i]=0) do
            inc(i);
         end;
        is_emptyset:=(i=32);
      end;


    function genconstsymtree(p : pconstsym) : tnode;
      var
        p1  : tnode;
        len : longint;
        pc  : pchar;
      begin
        p1:=nil;
        case p^.consttyp of
          constint :
            if (p^.value >= -maxlongint-1) and (p^.value <= maxlongint) then
              p1:=genordinalconstnode(p^.value,s32bitdef)
            else if (p^.value > maxlongint) and (p^.value <= int64(maxlongint)+int64(maxlongint)+int64(1)) then
              p1:=genordinalconstnode(p^.value,u32bitdef)
            else
              p1:=genordinalconstnode(p^.value,cs64bitdef);
          conststring :
            begin
              len:=p^.len;
              if not(cs_ansistrings in aktlocalswitches) and (len>255) then
               len:=255;
              getmem(pc,len+1);
              move(pchar(tpointerord(p^.value))^,pc^,len);
              pc[len]:=#0;
              p1:=genpcharconstnode(pc,len);
            end;
          constchar :
            p1:=genordinalconstnode(p^.value,cchardef);
          constreal :
            p1:=genrealconstnode(pbestreal(tpointerord(p^.value))^,bestrealdef^);
          constbool :
            p1:=genordinalconstnode(p^.value,booldef);
          constset :
            p1:=gensetconstnode(pconstset(tpointerord(p^.value)),psetdef(p^.consttype.def));
          constord :
            p1:=genordinalconstnode(p^.value,p^.consttype.def);
          constpointer :
            p1:=genpointerconstnode(p^.value,p^.consttype.def);
          constnil :
            p1:=cnilnode.create;
          constresourcestring:
            begin
              p1:=genloadnode(pvarsym(p),pvarsym(p)^.owner);
              p1.resulttype:=cansistringdef;
            end;
        end;
        genconstsymtree:=p1;
      end;

{*****************************************************************************
                             TREALCONSTNODE
*****************************************************************************}

    constructor trealconstnode.create(v : bestreal;def : pdef);

      begin
         inherited create(realconstn);
         resulttype:=def;
         value_real:=v;
         lab_real:=nil;
      end;

    function trealconstnode.getcopy : tnode;

      var
         n : trealconstnode;

      begin
         n:=trealconstnode(inherited getcopy);
         n.value_real:=value_real;
         n.lab_real:=lab_real;
         getcopy:=n;
      end;

    function trealconstnode.pass_1 : tnode;
      begin
         pass_1:=nil;
         if (value_real=1.0) or (value_real=0.0) then
           begin
              location.loc:=LOC_FPU;
              registersfpu:=1;
           end
         else
           location.loc:=LOC_MEM;
      end;

    function trealconstnode.docompare(p: tnode): boolean;
      begin
        docompare :=
          inherited docompare(p) and
          (value_real = trealconstnode(p).value_real);
      end;

{*****************************************************************************
                             TFIXCONSTNODE
*****************************************************************************}

    constructor tfixconstnode.create(v : longint;def : pdef);

      begin
         inherited create(fixconstn);
         resulttype:=def;
         value_fix:=v;
      end;

    function tfixconstnode.getcopy : tnode;

      var
         n : tfixconstnode;

      begin
         n:=tfixconstnode(inherited getcopy);
         n.value_fix:=value_fix;
         getcopy:=n;
      end;

    function tfixconstnode.pass_1 : tnode;

      begin
         pass_1:=nil;
         location.loc:=LOC_MEM;
      end;

    function tfixconstnode.docompare(p: tnode): boolean;
      begin
        docompare :=
          inherited docompare(p) and
          (value_fix = tfixconstnode(p).value_fix);
      end;

{*****************************************************************************
                              TORDCONSTNODE
*****************************************************************************}

    constructor tordconstnode.create(v : tconstexprint;def : pdef);

      begin
         inherited create(ordconstn);
         value:=v;
         resulttype:=def;
         if resulttype^.deftype=orddef then
          testrange(resulttype,value);
      end;

    function tordconstnode.getcopy : tnode;

      var
         n : tordconstnode;

      begin
         n:=tordconstnode(inherited getcopy);
         n.value:=value;
         getcopy:=n;
      end;

    function tordconstnode.pass_1 : tnode;
      begin
         pass_1:=nil;
         location.loc:=LOC_MEM;
      end;

    function tordconstnode.docompare(p: tnode): boolean;
      begin
        docompare :=
          inherited docompare(p) and
          (value = tordconstnode(p).value);
      end;

{*****************************************************************************
                            TPOINTERCONSTNODE
*****************************************************************************}

    constructor tpointerconstnode.create(v : tpointerord;def : pdef);

      begin
         inherited create(pointerconstn);
         value:=v;
         resulttype:=def;
      end;

    function tpointerconstnode.getcopy : tnode;

      var
         n : tpointerconstnode;

      begin
         n:=tpointerconstnode(inherited getcopy);
         n.value:=value;
         getcopy:=n;
      end;

    function tpointerconstnode.pass_1 : tnode;
      begin
         pass_1:=nil;
         location.loc:=LOC_MEM;
      end;

    function tpointerconstnode.docompare(p: tnode): boolean;
      begin
        docompare :=
          inherited docompare(p) and
          (value = tpointerconstnode(p).value);
      end;

{*****************************************************************************
                             TSTRINGCONSTNODE
*****************************************************************************}

    constructor tstringconstnode.createstr(const s : string;st:tstringtype);

      var
         l : longint;

      begin
         inherited create(stringconstn);
         l:=length(s);
         len:=l;
         { stringdup write even past a #0 }
         getmem(value_str,l+1);
         move(s[1],value_str^,l);
         value_str[l]:=#0;
         lab_str:=nil;
         if st=st_default then
          begin
            if cs_ansistrings in aktlocalswitches then
              stringtype:=st_ansistring
            else
              stringtype:=st_shortstring;
          end
         else
          stringtype:=st;
         case stringtype of
           st_shortstring :
             resulttype:=cshortstringdef;
           st_ansistring :
             resulttype:=cansistringdef;
           else
             internalerror(44990099);
         end;
      end;

    constructor tstringconstnode.createwstr(const w : tcompilerwidestring);

      begin
         inherited create(stringconstn);
         len:=getlengthwidestring(w);
         new(pcompilerwidestring(value_str));
         initwidestring(pcompilerwidestring(value_str)^);
         copywidestring(w,pcompilerwidestring(value_str)^);
         lab_str:=nil;
         stringtype:=st_widestring;
         resulttype:=cwidestringdef;
      end;

    constructor tstringconstnode.createpchar(s : pchar;l : longint);

      begin
         inherited create(stringconstn);
         len:=l;
         if (cs_ansistrings in aktlocalswitches) or
            (len>255) then
          begin
             stringtype:=st_ansistring;
             resulttype:=cansistringdef;
          end
         else
          begin
             stringtype:=st_shortstring;
             resulttype:=cshortstringdef;
          end;
         value_str:=s;
         lab_str:=nil;
      end;

    destructor tstringconstnode.destroy;
      begin
        ansistringdispose(value_str,len);
        inherited destroy;
      end;

    function tstringconstnode.getcopy : tnode;

      var
         n : tstringconstnode;

      begin
         n:=tstringconstnode(inherited getcopy);
         n.stringtype:=stringtype;
         n.len:=len;
         n.lab_str:=lab_str;
         if stringtype=st_widestring then
           copywidestring(pcompilerwidestring(value_str)^,
             pcompilerwidestring(n.value_str)^)
         else
           n.value_str:=getpcharcopy;
         getcopy:=n;
      end;

    function tstringconstnode.pass_1 : tnode;
      begin
         pass_1:=nil;
        case stringtype of
          st_shortstring :
            resulttype:=cshortstringdef;
          st_ansistring :
            resulttype:=cansistringdef;
          st_widestring :
            resulttype:=cwidestringdef;
          st_longstring :
            resulttype:=clongstringdef;
        end;
        location.loc:=LOC_MEM;
      end;

    function tstringconstnode.getpcharcopy : pchar;
      var
         pc : pchar;
      begin
         pc:=nil;
         getmem(pc,len+1);
         if pc=nil then
           Message(general_f_no_memory_left);
         move(value_str^,pc^,len+1);
         getpcharcopy:=pc;
      end;

    function tstringconstnode.docompare(p: tnode): boolean;
      begin
        docompare :=
          inherited docompare(p) and
          (len = tstringconstnode(p).len) and
          { Don't compare the pchars, since they may contain null chars }
          { Since all equal constant strings are replaced by the same   }
          { label, the following compare should be enough (JM)          }
          (lab_str = tstringconstnode(p).lab_str);
      end;

{*****************************************************************************
                             TSETCONSTNODE
*****************************************************************************}

    constructor tsetconstnode.create(s : pconstset;settype : psetdef);

      begin
         inherited create(setconstn,nil);
         resulttype:=settype;
         if assigned(s) then
           begin
              new(value_set);
              value_set^:=s^;
           end
         else
           value_set:=nil;
      end;

    destructor tsetconstnode.destroy;
      begin
        if assigned(value_set) then
         dispose(value_set);
        inherited destroy;
      end;

    function tsetconstnode.getcopy : tnode;

      var
         n : tsetconstnode;

      begin
         n:=tsetconstnode(inherited getcopy);
         if assigned(value_set) then
           begin
              new(n.value_set);
              n.value_set^:=value_set^
           end
         else
           n.value_set:=nil;
         n.lab_set:=lab_set;
         getcopy:=n;
      end;

    function tsetconstnode.pass_1 : tnode;
      begin
         pass_1:=nil;
         location.loc:=LOC_MEM;
      end;

    function tsetconstnode.docompare(p: tnode): boolean;
      var
        i: 0..31;
      begin
        if inherited docompare(p) then
          begin
            for i := 0 to 31 do
              if (value_set^[i] <> tsetconstnode(p).value_set^[i]) then
                begin
                  docompare := false;
                  exit
                end;
            docompare := true;
          end
        else
          docompare := false;
      end;

{*****************************************************************************
                               TNILNODE
*****************************************************************************}

    constructor tnilnode.create;

      begin
         inherited create(niln);
      end;

    function tnilnode.pass_1 : tnode;
      begin
        pass_1:=nil;
        resulttype:=voidpointerdef;
        location.loc:=LOC_MEM;
      end;

begin
   crealconstnode:=trealconstnode;
   cfixconstnode:=tfixconstnode;
   cordconstnode:=tordconstnode;
   cpointerconstnode:=tpointerconstnode;
   cstringconstnode:=tstringconstnode;
   csetconstnode:=tsetconstnode;
   cnilnode:=tnilnode;
end.
{
  $Log$
  Revision 1.15  2000-12-31 11:14:10  jonas
    + implemented/fixed docompare() mathods for all nodes (not tested)
    + nopt.pas, nadd.pas, i386/n386opt.pas: optimized nodes for adding strings
      and constant strings/chars together
    * n386add.pas: don't copy temp strings (of size 256) to another temp string
      when adding

  Revision 1.14  2000/12/16 15:58:48  jonas
    * genintconstnode now returns cardinals instead of int64 constants if possible

  Revision 1.13  2000/12/15 13:26:01  jonas
    * only return int64's from functions if it int64funcresok is defined
    + added int64funcresok define to options.pas

  Revision 1.12  2000/12/07 17:19:42  jonas
    * new constant handling: from now on, hex constants >$7fffffff are
      parsed as unsigned constants (otherwise, $80000000 got sign extended
      and became $ffffffff80000000), all constants in the longint range
      become longints, all constants >$7fffffff and <=cardinal($ffffffff)
      are cardinals and the rest are int64's.
    * added lots of longint typecast to prevent range check errors in the
      compiler and rtl
    * type casts of symbolic ordinal constants are now preserved
    * fixed bug where the original resulttype wasn't restored correctly
      after doing a 64bit rangecheck

  Revision 1.11  2000/11/29 00:30:32  florian
    * unused units removed from uses clause
    * some changes for widestrings

  Revision 1.10  2000/10/31 22:02:48  peter
    * symtable splitted, no real code changes

  Revision 1.9  2000/10/14 21:52:55  peter
    * fixed memory leaks

  Revision 1.8  2000/10/14 10:14:50  peter
    * moehrendorf oct 2000 rewrite

  Revision 1.7  2000/09/28 19:49:52  florian
  *** empty log message ***

  Revision 1.6  2000/09/27 20:25:44  florian
    * more stuff fixed

  Revision 1.5  2000/09/27 18:14:31  florian
    * fixed a lot of syntax errors in the n*.pas stuff

  Revision 1.4  2000/09/26 14:59:34  florian
    * more conversion work done

  Revision 1.3  2000/09/24 21:15:34  florian
    * some errors fix to get more stuff compilable

  Revision 1.2  2000/09/24 15:06:19  peter
    * use defines.inc

  Revision 1.1  2000/09/22 21:44:48  florian
    + initial revision

}