freepascal.compiler/compiler/symtype.pas

{
    $Id$
    Copyright (c) 1998-2002 by Florian Klaempfl, Pierre Muller

    This unit handles the symbol tables

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

{$i fpcdefs.inc}

interface

    uses
      { common }
      cutils,
{$ifdef MEMDEBUG}
      cclasses,
{$endif MEMDEBUG}
      { global }
      globtype,globals,
      { symtable }
      symconst,symbase,
      { aasm }
      aasmbase
      ;

    type
{************************************************
                Required Forwards
************************************************}

      tsym = class;

{************************************************
                     TRef
************************************************}

      tref = class
        nextref     : tref;
        posinfo     : tfileposinfo;
        moduleindex : longint;
        is_written  : boolean;
        constructor create(ref:tref;pos:pfileposinfo);
        procedure   freechain;
        destructor  destroy;override;
      end;

{************************************************
                     TDef
************************************************}

      tgetsymtable = (gs_none,gs_record,gs_local,gs_para);

      tdef = class(tdefentry)
         typesym    : tsym;  { which type the definition was generated this def }
         defoptions : tdefoptions;
         constructor create;
         procedure deref;virtual;abstract;
         procedure derefimpl;virtual;abstract;
         function  typename:string;
         function  gettypename:string;virtual;
         function  mangledparaname:string;
         function  getmangledparaname:string;virtual;abstract;
         function  size:longint;virtual;abstract;
         function  alignment:longint;virtual;abstract;
         function  getsymtable(t:tgetsymtable):tsymtable;virtual;
         function  is_publishable:boolean;virtual;abstract;
         function  needs_inittable:boolean;virtual;abstract;
      end;

{************************************************
                     TSym
************************************************}

      { this object is the base for all symbol objects }
      tsym = class(tsymentry)
         _realname  : pstring;
         fileinfo   : tfileposinfo;
         symoptions : tsymoptions;
         constructor create(const n : string);
         destructor destroy;override;
         function  realname:string;
         procedure deref;virtual;abstract;
         function  gettypedef:tdef;virtual;
      end;

{************************************************
                   TDeref
************************************************}

      tderefdata = array[0..31] of byte;

      tderef = object
        len  : longint;
        data : tderefdata;
        procedure reset;
        procedure setdata(l:longint;var d);
        procedure build(s:tsymtableentry);
        function resolve:tsymtableentry;
      end;

{************************************************
                   TType
************************************************}

      ttype = object
        def : tdef;
        sym : tsym;
        deref : tderef;
        procedure reset;
        procedure setdef(p:tdef);
        procedure setsym(p:tsym);
        procedure resolve;
      end;

{************************************************
                   TSymList
************************************************}

      psymlistitem = ^tsymlistitem;
      tsymlistitem = record
        sltype : tsltype;
        sym    : tsym;
        symderef : tderef;
        value  : longint;
        next   : psymlistitem;
      end;

      tsymlist = class
        def      : tdef;
        defderef : tderef;
        firstsym,
        lastsym  : psymlistitem;
        constructor create;
        destructor  destroy;override;
        function  empty:boolean;
        procedure setdef(p:tdef);
        procedure addsym(slt:tsltype;p:tsym);
        procedure addsymderef(slt:tsltype;const d:tderef);
        procedure addconst(slt:tsltype;v:longint);
        procedure clear;
        function  getcopy:tsymlist;
        procedure resolve;
      end;


{$ifdef MEMDEBUG}
    var
      membrowser,
      memrealnames,
      memmanglednames,
      memprocparast,
      memproclocalst,
      memprocnodetree : tmemdebug;
{$endif MEMDEBUG}


implementation

    uses
       verbose,
       fmodule;

{****************************************************************************
                                Tdef
****************************************************************************}

    constructor tdef.create;
      begin
         inherited create;
         deftype:=abstractdef;
         owner := nil;
         typesym := nil;
         defoptions:=[];
      end;


    function tdef.typename:string;
      begin
        if assigned(typesym) and
           not(deftype in [procvardef,procdef]) and
           assigned(typesym._realname) and
           (typesym._realname^[1]<>'$') then
         typename:=typesym._realname^
        else
         typename:=gettypename;
      end;


    function tdef.gettypename : string;
      begin
         gettypename:='<unknown type>'
      end;


    function tdef.mangledparaname:string;
      begin
        if assigned(typesym) then
         mangledparaname:=typesym.name
        else
         mangledparaname:=getmangledparaname;
      end;


    function tdef.getsymtable(t:tgetsymtable):tsymtable;
      begin
        getsymtable:=nil;
      end;


{****************************************************************************
                          TSYM (base for all symtypes)
****************************************************************************}

    constructor tsym.create(const n : string);
      begin
         if n[1]='$' then
          inherited createname(copy(n,2,255))
         else
          inherited createname(upper(n));
         _realname:=stringdup(n);
         typ:=abstractsym;
         symoptions:=[];
      end;


    destructor tsym.destroy;
      begin
{$ifdef MEMDEBUG}
        memrealnames.start;
{$endif MEMDEBUG}
        stringdispose(_realname);
{$ifdef MEMDEBUG}
        memrealnames.stop;
{$endif MEMDEBUG}
        inherited destroy;
      end;


    function tsym.realname : string;
      begin
        if assigned(_realname) then
         realname:=_realname^
        else
         realname:=name;
      end;


    function tsym.gettypedef:tdef;
      begin
        gettypedef:=nil;
      end;


{****************************************************************************
                               TRef
****************************************************************************}

    constructor tref.create(ref :tref;pos : pfileposinfo);
      begin
        nextref:=nil;
        if pos<>nil then
          posinfo:=pos^;
        if assigned(current_module) then
          moduleindex:=current_module.unit_index;
        if assigned(ref) then
          ref.nextref:=self;
        is_written:=false;
      end;

    procedure tref.freechain;
      var
        p,q : tref;
      begin
        p:=nextref;
        nextref:=nil;
        while assigned(p) do
          begin
            q:=p.nextref;
            p.free;
            p:=q;
          end;
      end;

    destructor tref.destroy;
      begin
         nextref:=nil;
      end;


{****************************************************************************
                                   TType
****************************************************************************}

    procedure ttype.reset;
      begin
        def:=nil;
        sym:=nil;
      end;


    procedure ttype.setdef(p:tdef);
      begin
        def:=p;
        sym:=nil;
      end;


    procedure ttype.setsym(p:tsym);
      begin
        sym:=p;
        def:=p.gettypedef;
        if not assigned(def) then
         internalerror(1234005);
      end;


    procedure ttype.resolve;
      var
        p : tsymtableentry;
      begin
        p:=deref.resolve;
        if assigned(p) then
          begin
            if p is tsym then
              begin
                setsym(tsym(p));
                if not assigned(def) then
                 internalerror(200212272);
              end
            else
              begin
                setdef(tdef(p));
              end;
          end
        else
          reset;
      end;


{****************************************************************************
                                 TSymList
****************************************************************************}

    constructor tsymlist.create;
      begin
        def:=nil; { needed for procedures }
        firstsym:=nil;
        lastsym:=nil;
      end;


    destructor tsymlist.destroy;
      begin
        clear;
      end;


    function tsymlist.empty:boolean;
      begin
        empty:=(firstsym=nil);
      end;


    procedure tsymlist.clear;
      var
        hp : psymlistitem;
      begin
        while assigned(firstsym) do
         begin
           hp:=firstsym;
           firstsym:=firstsym^.next;
           dispose(hp);
         end;
        firstsym:=nil;
        lastsym:=nil;
        def:=nil;
      end;


    procedure tsymlist.setdef(p:tdef);
      begin
        def:=p;
      end;


    procedure tsymlist.addsym(slt:tsltype;p:tsym);
      var
        hp : psymlistitem;
      begin
        if not assigned(p) then
         internalerror(200110203);
        new(hp);
        hp^.sltype:=slt;
        hp^.sym:=p;
        hp^.symderef.reset;
        hp^.value:=0;
        hp^.next:=nil;
        if assigned(lastsym) then
         lastsym^.next:=hp
        else
         firstsym:=hp;
        lastsym:=hp;
      end;


    procedure tsymlist.addsymderef(slt:tsltype;const d:tderef);
      var
        hp : psymlistitem;
      begin
        new(hp);
        hp^.sltype:=slt;
        hp^.sym:=nil;
        hp^.symderef:=d;
        hp^.value:=0;
        hp^.next:=nil;
        if assigned(lastsym) then
         lastsym^.next:=hp
        else
         firstsym:=hp;
        lastsym:=hp;
      end;


    procedure tsymlist.addconst(slt:tsltype;v:longint);
      var
        hp : psymlistitem;
      begin
        new(hp);
        hp^.sltype:=slt;
        hp^.sym:=nil;
        hp^.symderef.reset;
        hp^.value:=v;
        hp^.next:=nil;
        if assigned(lastsym) then
         lastsym^.next:=hp
        else
         firstsym:=hp;
        lastsym:=hp;
      end;


    function tsymlist.getcopy:tsymlist;
      var
        hp  : tsymlist;
        hp2 : psymlistitem;
        hpn : psymlistitem;
      begin
        hp:=tsymlist.create;
        hp.def:=def;
        hp2:=firstsym;
        while assigned(hp2) do
         begin
           new(hpn);
           hpn^:=hp2^;
           hpn^.next:=nil;
           if assigned(hp.lastsym) then
            hp.lastsym^.next:=hpn
           else
            hp.firstsym:=hpn;
           hp.lastsym:=hpn;
           hp2:=hp2^.next;
         end;
        getcopy:=hp;
      end;


    procedure tsymlist.resolve;
      var
        hp : psymlistitem;
      begin
        def:=tdef(defderef.resolve);
        hp:=firstsym;
        while assigned(hp) do
         begin
           hp^.sym:=tsym(hp^.symderef.resolve);
           hp:=hp^.next;
         end;
      end;


{****************************************************************************
                                Tderef
****************************************************************************}


    procedure tderef.reset;
      begin
        len:=0;
      end;


    procedure tderef.setdata(l:longint;var d);
      begin
        len:=l;
        if l>sizeof(tderefdata) then
          internalerror(200306068);
        move(d,data,len);
      end;


    procedure tderef.build(s:tsymtableentry);

        procedure addowner(s:tsymtableentry);
        var
          typ : tdereftype;
          idx : word;
        begin
          if not assigned(s.owner) then
            internalerror(200306063);
          case s.owner.symtabletype of
            globalsymtable :
              begin
                { check if the unit is available in the uses
                  clause, else it's an error }
                if s.owner.unitid=$ffff then
                  internalerror(200306063);
                data[len]:=ord(derefunit);
                typ:=derefunit;
                idx:=s.owner.unitid;
              end;
            localsymtable :
              begin
                addowner(s.owner.defowner);
                typ:=dereflocal;
                idx:=s.owner.defowner.indexnr;
              end;
            parasymtable :
              begin
                addowner(s.owner.defowner);
                typ:=derefpara;
                idx:=s.owner.defowner.indexnr;
              end;
            objectsymtable,
            recordsymtable :
              begin
                addowner(s.owner.defowner);
                typ:=derefrecord;
                idx:=s.owner.defowner.indexnr;
              end;
            else
              internalerror(200306065);
          end;
          if len+3>sizeof(tderefdata) then
            internalerror(200306062);
          data[len]:=ord(typ);
          data[len+1]:=idx shr 8;
          data[len+2]:=idx and $ff;
          inc(len,3);
        end;

      begin
        len:=0;
        if assigned(s) then
         begin
           { symtableentry type }
           if s is tsym then
             data[len]:=1
           else
             data[len]:=2;
           inc(len);
           { Static symtable of current unit ? }
           if (s.owner.symtabletype=staticsymtable) and
              (s.owner.unitid=0) then
            begin
              data[len]:=ord(derefaktstaticindex);
              data[len+1]:=s.indexnr shr 8;
              data[len+2]:=s.indexnr and $ff;
              inc(len,3);
            end
           { Global symtable of current unit ? }
           else if (s.owner.symtabletype=globalsymtable) and
                   (s.owner.unitid=0) then
            begin
              data[len]:=ord(derefaktglobalindex);
              data[len+1]:=s.indexnr shr 8;
              data[len+2]:=s.indexnr and $ff;
              inc(len,3);
            end
           { Local record/object symtable ? }
           else if (s.owner=aktrecordsymtable) then
            begin
              data[len]:=ord(derefaktrecordindex);
              data[len+1]:=s.indexnr shr 8;
              data[len+2]:=s.indexnr and $ff;
              inc(len,3);
            end
           { Local local/para symtable ? }
           else if (s.owner=aktlocalsymtable) then
            begin
              data[len]:=ord(derefaktlocalindex);
              data[len+1]:=s.indexnr shr 8;
              data[len+2]:=s.indexnr and $ff;
              inc(len,3);
            end
           else
            begin
              addowner(s);
              data[len]:=ord(derefindex);
              data[len+1]:=s.indexnr shr 8;
              data[len+2]:=s.indexnr and $ff;
              inc(len,3);
            end;
         end
        else
         begin
           { nil pointer }
           data[len]:=0;
           inc(len);
         end;
      end;


    function tderef.resolve:tsymtableentry;
      var
        pd     : tdef;
        pm     : tmodule;
        typ    : tdereftype;
        st     : tsymtable;
        idx,
        symidx : word;
        issym  : boolean;
        i      : longint;
      begin
        result:=nil;
        { not initialized }
        if len=0 then
          internalerror(200306067);
        st:=nil;
        symidx:=0;
        issym:=false;
        i:=0;
        case data[i] of
          0 :
            begin
              { nil pointer }
              exit;
            end;
          1 :
            begin
              { tsym }
              issym:=true;
            end;
          2 :
            begin
              { tdef }
            end;
          else
            internalerror(200306066);
        end;
        inc(i);
        while (i<len) do
          begin
            typ:=tdereftype(data[i]);
            idx:=(data[i+1] shl 8) or data[i+2];
            inc(i,3);
            case typ of
              derefaktrecordindex :
                begin
                  st:=aktrecordsymtable;
                  symidx:=idx;
                end;
              derefaktstaticindex :
                begin
                  st:=aktstaticsymtable;
                  symidx:=idx;
                end;
              derefaktglobalindex :
                begin
                  st:=aktglobalsymtable;
                  symidx:=idx;
                end;
              derefaktlocalindex :
                begin
                  st:=aktlocalsymtable;
                  symidx:=idx;
                end;
              derefunit :
                begin
                  pm:=current_module.map^[idx];
                  if not assigned(pm) then
                    internalerror(200212273);
                  st:=pm.globalsymtable;
                end;
              derefrecord :
                begin
                  if not assigned(st) then
                    internalerror(200306068);
                  pd:=tdef(st.getdefnr(idx));
                  st:=pd.getsymtable(gs_record);
                  if not assigned(st) then
                    internalerror(200212274);
                end;
              dereflocal :
                begin
                  if not assigned(st) then
                    internalerror(200306069);
                  pd:=tdef(st.getdefnr(idx));
                  st:=pd.getsymtable(gs_local);
                  if not assigned(st) then
                    internalerror(200212275);
                end;
              derefpara :
                begin
                  if not assigned(st) then
                    internalerror(2003060610);
                  pd:=tdef(st.getdefnr(idx));
                  st:=pd.getsymtable(gs_para);
                  if not assigned(st) then
                    internalerror(200212276);
                end;
              derefindex :
                symidx:=idx;
              else
                internalerror(200212277);
            end;
          end;
        if assigned(st) then
          begin
            if issym then
              result:=st.getsymnr(symidx)
            else
              result:=st.getdefnr(symidx);
          end;
      end;


{$ifdef MEMDEBUG}
initialization
  membrowser:=TMemDebug.create('BrowserRefs');
  membrowser.stop;
  memrealnames:=TMemDebug.create('Realnames');
  memrealnames.stop;
  memmanglednames:=TMemDebug.create('Manglednames');
  memmanglednames.stop;
  memprocparast:=TMemDebug.create('ProcParaSt');
  memprocparast.stop;
  memproclocalst:=TMemDebug.create('ProcLocalSt');
  memproclocalst.stop;
  memprocnodetree:=TMemDebug.create('ProcNodeTree');
  memprocnodetree.stop;

finalization
  membrowser.free;
  memrealnames.free;
  memmanglednames.free;
  memprocparast.free;
  memproclocalst.free;
  memprocnodetree.free;
{$endif MEMDEBUG}

end.
{
  $Log$
  Revision 1.25  2003-06-07 20:26:32  peter
    * re-resolving added instead of reloading from ppu
    * tderef object added to store deref info for resolving

  Revision 1.24  2002/12/29 18:26:31  peter
    * also use gettypename for procdef always

  Revision 1.23  2002/12/29 14:57:50  peter
    * unit loading changed to first register units and load them
      afterwards. This is needed to support uses xxx in yyy correctly
    * unit dependency check fixed

  Revision 1.22  2002/09/05 19:29:46  peter
    * memdebug enhancements

  Revision 1.21  2002/08/18 20:06:28  peter
    * inlining is now also allowed in interface
    * renamed write/load to ppuwrite/ppuload
    * tnode storing in ppu
    * nld,ncon,nbas are already updated for storing in ppu

  Revision 1.20  2002/08/11 13:24:16  peter
    * saving of asmsymbols in ppu supported
    * asmsymbollist global is removed and moved into a new class
      tasmlibrarydata that will hold the info of a .a file which
      corresponds with a single module. Added librarydata to tmodule
      to keep the library info stored for the module. In the future the
      objectfiles will also be stored to the tasmlibrarydata class
    * all getlabel/newasmsymbol and friends are moved to the new class

  Revision 1.19  2002/07/01 18:46:29  peter
    * internal linker
    * reorganized aasm layer

  Revision 1.18  2002/05/18 13:34:21  peter
    * readded missing revisions

  Revision 1.17  2002/05/16 19:46:45  carl
  + defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
  + try to fix temp allocation (still in ifdef)
  + generic constructor calls
  + start of tassembler / tmodulebase class cleanup

  Revision 1.15  2002/05/12 16:53:15  peter
    * moved entry and exitcode to ncgutil and cgobj
    * foreach gets extra argument for passing local data to the
      iterator function
    * -CR checks also class typecasts at runtime by changing them
      into as
    * fixed compiler to cycle with the -CR option
    * fixed stabs with elf writer, finally the global variables can
      be watched
    * removed a lot of routines from cga unit and replaced them by
      calls to cgobj
    * u32bit-s32bit updates for and,or,xor nodes. When one element is
      u32bit then the other is typecasted also to u32bit without giving
      a rangecheck warning/error.
    * fixed pascal calling method with reversing also the high tree in
      the parast, detected by tcalcst3 test

  Revision 1.14  2002/04/19 15:46:04  peter
    * mangledname rewrite, tprocdef.mangledname is now created dynamicly
      in most cases and not written to the ppu
    * add mangeledname_prefix() routine to generate the prefix of
      manglednames depending on the current procedure, object and module
    * removed static procprefix since the mangledname is now build only
      on demand from tprocdef.mangledname

}