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,ppu,cpuinfo
      ;

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

      tsym = class;
      Tcompilerppufile=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 buildderef;virtual;abstract;
         procedure buildderefimpl;virtual;abstract;
         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  getparentdef:tdef;virtual;
         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)
      protected
      public
         _realname  : pstring;
         fileinfo   : tfileposinfo;
         symoptions : tsymoptions;
         refs          : longint;
         lastref,
         defref,
         lastwritten : tref;
         refcount    : longint;
{$ifdef GDB}
         isstabwritten : boolean;
         function  get_var_value(const s:string):string;
         function  stabstr_evaluate(const s:string;vars:array of string):Pchar;
         function  stabstring : pchar;virtual;
{$endif GDB}
         constructor create(const n : string);
         constructor loadsym(ppufile:tcompilerppufile);
         destructor destroy;override;
         procedure ppuwrite(ppufile:tcompilerppufile);virtual;abstract;
         procedure writesym(ppufile:tcompilerppufile);
         function  realname:string;
         procedure buildderef;virtual;
{         procedure buildderefimpl;virtual;abstract;}
         procedure deref;virtual;
{         procedure derefimpl;virtual;abstract;}
         function  gettypedef:tdef;virtual;
         procedure load_references(ppufile:tcompilerppufile;locals:boolean);virtual;
         function  write_references(ppufile:tcompilerppufile;locals:boolean):boolean;virtual;
         function is_visible_for_object(currobjdef:Tdef):boolean;
      end;

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

      tderef = object
        dataidx : longint;
        procedure reset;
        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;
        procedure buildderef;
      end;

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

      psymlistitem = ^tsymlistitem;
      tsymlistitem = record
        sltype : tsltype;
        next   : psymlistitem;
        case byte of
          0 : (sym : tsym; symderef : tderef);
          1 : (value  : longint);
          2 : (tt : ttype);
      end;

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

{************************************************
                Tcompilerppufile
************************************************}
       tcompilerppufile=class(tppufile)
       public
         procedure checkerror;
         procedure getguid(var g: tguid);
         function  getexprint:tconstexprint;
         function  getptruint:TConstPtrUInt;
         procedure getposinfo(var p:tfileposinfo);
         procedure getderef(var d:tderef);
         function  getsymlist:tsymlist;
         procedure gettype(var t:ttype);
         function  getasmsymbol:tasmsymbol;
         procedure putguid(const g: tguid);
         procedure putexprint(v:tconstexprint);
         procedure PutPtrUInt(v:TConstPtrUInt);
         procedure putposinfo(const p:tfileposinfo);
         procedure putderef(const d:tderef);
         procedure putsymlist(p:tsymlist);
         procedure puttype(const t:ttype);
         procedure putasmsymbol(s:tasmsymbol);
       end;

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

    const
       current_object_option : tsymoptions = [sp_public];


implementation

    uses
       verbose,
       fmodule,
       symdef
{$ifdef GDB}
       ,gdb
{$endif GDB}
       ;


{****************************************************************************
                                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.getparentdef:tdef;
      begin
        result:=nil;
      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:=[];
         defref:=nil;
         refs:=0;
         lastwritten:=nil;
         refcount:=0;
         fileinfo:=akttokenpos;
         if (cs_browser in aktmoduleswitches) and make_ref then
          begin
            defref:=tref.create(defref,@akttokenpos);
            inc(refcount);
          end;
         lastref:=defref;
{$ifdef GDB}
         isstabwritten := false;
{$endif GDB}
         symoptions:=current_object_option;
      end;

    constructor tsym.loadsym(ppufile:tcompilerppufile);
      var
        s  : string;
        nr : word;
      begin
         nr:=ppufile.getword;
         s:=ppufile.getstring;
         if s[1]='$' then
          inherited createname(copy(s,2,255))
         else
          inherited createname(upper(s));
         _realname:=stringdup(s);
         typ:=abstractsym;
         { force the correct indexnr. must be after create! }
         indexnr:=nr;
         ppufile.getposinfo(fileinfo);
         ppufile.getsmallset(symoptions);
         lastref:=nil;
         defref:=nil;
         refs:=0;
         lastwritten:=nil;
         refcount:=0;
{$ifdef GDB}
         isstabwritten := false;
{$endif GDB}
      end;

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

    procedure Tsym.writesym(ppufile:tcompilerppufile);
      begin
         ppufile.putword(indexnr);
         ppufile.putstring(_realname^);
         ppufile.putposinfo(fileinfo);
         ppufile.putsmallset(symoptions);
      end;

    procedure Tsym.buildderef;

    begin
    end;

    procedure Tsym.deref;

    begin
    end;

{$ifdef GDB}
    function Tsym.get_var_value(const s:string):string;

    begin
      if s='name' then
        get_var_value:=name
      else if s='ownername' then
        get_var_value:=owner.name^
      else if s='line' then
        get_var_value:=tostr(fileinfo.line)
      else if s='N_LSYM' then
        get_var_value:=tostr(N_LSYM)
      else if s='N_LCSYM' then
        get_var_value:=tostr(N_LCSYM)
      else if s='N_RSYM' then
        get_var_value:=tostr(N_RSYM)
      else if s='N_TSYM' then
        get_var_value:=tostr(N_TSYM)
      else if s='N_STSYM' then
        get_var_value:=tostr(N_STSYM)
      else if s='N_FUNCTION' then
        get_var_value:=tostr(N_FUNCTION)
      else
        internalerror(200401152);
    end;

    function Tsym.stabstr_evaluate(const s:string;vars:array of string):Pchar;

    begin
      stabstr_evaluate:=string_evaluate(s,@get_var_value,vars);
    end;

    function Tsym.stabstring : pchar;

    begin
(*      stabstring:=stabstr_evaluate('"${name}",${N_LSYM},0,${line},0',[]); *)
       stabstring:=nil;
    end;
{
    procedure Tsym.concatstabto(asmlist : taasmoutput);
      var
        stab_str : pchar;
      begin
         if not isstabwritten then
           begin
              stab_str := stabstring;
              if assigned(stab_str) then
                asmList.concat(Tai_stabs.Create(stab_str));
              isstabwritten:=true;
          end;
    end;}
{$endif GDB}


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


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


    procedure Tsym.load_references(ppufile:tcompilerppufile;locals:boolean);
      var
        pos : tfileposinfo;
        move_last : boolean;
      begin
        move_last:=lastwritten=lastref;
        while (not ppufile.endofentry) do
         begin
           ppufile.getposinfo(pos);
           inc(refcount);
           lastref:=tref.create(lastref,@pos);
           lastref.is_written:=true;
           if refcount=1 then
            defref:=lastref;
         end;
        if move_last then
          lastwritten:=lastref;
      end;

    { big problem here :
      wrong refs were written because of
      interface parsing of other units PM
      moduleindex must be checked !! }

    function Tsym.write_references(ppufile:tcompilerppufile;locals:boolean):boolean;
      var
        d : tderef;
        ref   : tref;
        symref_written,move_last : boolean;
      begin
        write_references:=false;
        if lastwritten=lastref then
          exit;
      { should we update lastref }
        move_last:=true;
        symref_written:=false;
      { write symbol refs }
        d.reset;
        if assigned(lastwritten) then
          ref:=lastwritten
        else
          ref:=defref;
        while assigned(ref) do
         begin
           if ref.moduleindex=current_module.unit_index then
             begin
              { write address to this symbol }
                if not symref_written then
                  begin
                     d.build(self);
                     ppufile.putderef(d);
                     symref_written:=true;
                  end;
                ppufile.putposinfo(ref.posinfo);
                ref.is_written:=true;
                if move_last then
                  lastwritten:=ref;
             end
           else if not ref.is_written then
             move_last:=false
           else if move_last then
             lastwritten:=ref;
           ref:=ref.nextref;
         end;
        if symref_written then
          ppufile.writeentry(ibsymref);
        write_references:=symref_written;
      end;


    function Tsym.is_visible_for_object(currobjdef:Tdef):boolean;
      begin
        is_visible_for_object:=false;

        { private symbols are allowed when we are in the same
          module as they are defined }
        if (sp_private in symoptions) and
           assigned(owner.defowner) and
           (owner.defowner.owner.symtabletype in [globalsymtable,staticsymtable]) and
           (owner.defowner.owner.unitid<>0) then
          exit;

        { protected symbols are vissible in the module that defines them and
          also visible to related objects }
        if (sp_protected in symoptions) and
           (
            (
             assigned(owner.defowner) and
             (owner.defowner.owner.symtabletype in [globalsymtable,staticsymtable]) and
             (owner.defowner.owner.unitid<>0)
            ) and
            not(
                assigned(currobjdef) and
                Tobjectdef(currobjdef).is_related(tobjectdef(owner.defowner))
               )
           ) then
          exit;

        is_visible_for_object:=true;
      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;


    procedure ttype.buildderef;
      begin
        { Write symbol references when the symbol is a redefine,
          but don't write symbol references for the current unit
          and for the system unit }
        if assigned(sym) and
           (
            (sym<>def.typesym) or
            ((sym.owner.unitid<>0) and
             (sym.owner.unitid<>1))
           ) then
          deref.build(sym)
        else
          deref.build(def);
      end;


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

    constructor tsymlist.create;
      begin
        procdef:=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;
        procdef:=nil;
      end;


    procedure tsymlist.addsym(slt:tsltype;p:tsym);
      var
        hp : psymlistitem;
      begin
        if not assigned(p) then
         internalerror(200110203);
        new(hp);
        fillchar(hp^,sizeof(tsymlistitem),0);
        hp^.sltype:=slt;
        hp^.sym:=p;
        hp^.symderef.reset;
        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);
        fillchar(hp^,sizeof(tsymlistitem),0);
        hp^.sltype:=slt;
        hp^.symderef:=d;
        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);
        fillchar(hp^,sizeof(tsymlistitem),0);
        hp^.sltype:=slt;
        hp^.value:=v;
        if assigned(lastsym) then
         lastsym^.next:=hp
        else
         firstsym:=hp;
        lastsym:=hp;
      end;


    procedure tsymlist.addtype(slt:tsltype;const tt:ttype);
      var
        hp : psymlistitem;
      begin
        new(hp);
        fillchar(hp^,sizeof(tsymlistitem),0);
        hp^.sltype:=slt;
        hp^.tt:=tt;
        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.procdef:=procdef;
        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
        procdef:=tdef(procdefderef.resolve);
        hp:=firstsym;
        while assigned(hp) do
         begin
           case hp^.sltype of
             sl_call,
             sl_load,
             sl_subscript :
               hp^.sym:=tsym(hp^.symderef.resolve);
             sl_typeconv :
               hp^.tt.resolve;
             sl_vec :
               ;
             else
              internalerror(200110205);
           end;
           hp:=hp^.next;
         end;
      end;


    procedure tsymlist.buildderef;
      var
        hp : psymlistitem;
      begin
        procdefderef.build(procdef);
        hp:=firstsym;
        while assigned(hp) do
         begin
           case hp^.sltype of
             sl_call,
             sl_load,
             sl_subscript :
               hp^.symderef.build(hp^.sym);
             sl_typeconv :
               hp^.tt.buildderef;
             sl_vec :
               ;
             else
              internalerror(200110205);
           end;
           hp:=hp^.next;
         end;
      end;


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


    procedure tderef.reset;
      begin
        dataidx:=-1;
      end;


    procedure tderef.build(s:tsymtableentry);
      var
        len  : byte;
        data : array[0..255] of byte;

        function is_child(currdef,ownerdef:tdef):boolean;
        begin
          while assigned(currdef) and
                (currdef<>ownerdef) do
            currdef:=currdef.getparentdef;
          result:=assigned(currdef);
        end;

        procedure addowner(s:tsymtableentry);
        begin
          if not assigned(s.owner) then
            internalerror(200306063);
          case s.owner.symtabletype of
            globalsymtable :
              begin
                if s.owner.unitid=0 then
                  begin
                    data[len]:=ord(deref_aktglobal);
                    inc(len);
                  end
                else
                  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(deref_unit);
                    data[len+1]:=s.owner.unitid shr 8;
                    data[len+2]:=s.owner.unitid and $ff;
                    inc(len,3);
                  end;
              end;
            staticsymtable :
              begin
                { only references to the current static symtable are allowed }
                if s.owner<>aktstaticsymtable then
                  internalerror(200306233);
                data[len]:=ord(deref_aktstatic);
                inc(len);
              end;
            localsymtable :
              begin
                addowner(s.owner.defowner);
                data[len]:=ord(deref_def);
                data[len+1]:=s.owner.defowner.indexnr shr 8;
                data[len+2]:=s.owner.defowner.indexnr and $ff;
                data[len+3]:=ord(deref_local);
                inc(len,4);
              end;
            parasymtable :
              begin
                addowner(s.owner.defowner);
                data[len]:=ord(deref_def);
                data[len+1]:=s.owner.defowner.indexnr shr 8;
                data[len+2]:=s.owner.defowner.indexnr and $ff;
                data[len+3]:=ord(deref_para);
                inc(len,4);
              end;
            objectsymtable,
            recordsymtable :
              begin
                addowner(s.owner.defowner);
                data[len]:=ord(deref_def);
                data[len+1]:=s.owner.defowner.indexnr shr 8;
                data[len+2]:=s.owner.defowner.indexnr and $ff;
                data[len+3]:=ord(deref_record);
                inc(len,4);
              end;
            else
              internalerror(200306065);
          end;
          if len>252 then
            internalerror(200306062);
        end;

        procedure addparentobject(currdef,ownerdef:tdef);
        var
          nextdef : tdef;
        begin
          if not assigned(currdef) then
            internalerror(200306185);
          { Already handled by derefaktrecordindex }
          if currdef=ownerdef then
            internalerror(200306188);
          { Generate a direct reference to the top parent
            class available in the current unit, this is required because
            the parent class is maybe not resolved yet and therefor
            has the childof value not available yet }
          while (currdef<>ownerdef) do
            begin
              nextdef:=currdef.getparentdef;
              { objects are only allowed in globalsymtable,staticsymtable this check is
                needed because we need the unitid }
              if not(nextdef.owner.symtabletype in [globalsymtable,staticsymtable]) then
                internalerror(200306187);
              { Next parent is in a different unit, then stop }
              if nextdef.owner.unitid<>0 then
                break;
              currdef:=nextdef;
            end;
          { Add reference where to start the parent lookup }
          if currdef=aktrecordsymtable.defowner then
            begin
              data[len]:=ord(deref_aktrecord);
              inc(len);
            end
          else
            begin
              if currdef.owner.symtabletype=globalsymtable then
                data[len]:=ord(deref_aktglobal)
              else
                data[len]:=ord(deref_aktstatic);
              data[len+1]:=ord(deref_def);
              data[len+2]:=currdef.indexnr shr 8;
              data[len+3]:=currdef.indexnr and $ff;
              data[len+4]:=ord(deref_record);
              inc(len,5);
            end;
          { When the current found parent in this module is not the owner we
            add derefs for the parent classes not available in this unit }
          while (currdef<>ownerdef) do
            begin
              data[len]:=ord(deref_parent_object);
              inc(len);
              currdef:=currdef.getparentdef;
              { It should be valid as it is checked by is_child }
              if not assigned(currdef) then
                internalerror(200306186);
            end;
        end;

      begin
        { skip length byte }
        len:=1;
        if assigned(s) then
         begin
           { Static symtable of current unit ? }
           if (s.owner.symtabletype=staticsymtable) and
              (s.owner.unitid=0) then
            begin
              data[len]:=ord(deref_aktstatic);
              inc(len);
            end
           { Global symtable of current unit ? }
           else if (s.owner.symtabletype=globalsymtable) and
                   (s.owner.unitid=0) then
            begin
              data[len]:=ord(deref_aktglobal);
              inc(len);
            end
           { Current record/object symtable ? }
           else if (s.owner=aktrecordsymtable) then
            begin
              data[len]:=ord(deref_aktrecord);
              inc(len);
            end
           { Current local symtable ? }
           else if (s.owner=aktlocalsymtable) then
            begin
              data[len]:=ord(deref_aktlocal);
              inc(len);
            end
           { Current para symtable ? }
           else if (s.owner=aktparasymtable) then
            begin
              data[len]:=ord(deref_aktpara);
              inc(len);
            end
           { Parent class? }
           else if assigned(aktrecordsymtable) and
                   (aktrecordsymtable.symtabletype=objectsymtable) and
                   (s.owner.symtabletype=objectsymtable) and
                   is_child(tdef(aktrecordsymtable.defowner),tdef(s.owner.defowner)) then
            begin
              addparentobject(tdef(aktrecordsymtable.defowner),tdef(s.owner.defowner));
            end
           else
           { Default, start by building from unit symtable }
            begin
              addowner(s);
            end;
           { Add index of the symbol/def }
           if s is tsym then
             data[len]:=ord(deref_sym)
           else
             data[len]:=ord(deref_def);
           data[len+1]:=s.indexnr shr 8;
           data[len+2]:=s.indexnr and $ff;
           inc(len,3);
         end
        else
         begin
           { nil pointer }
           data[len]:=0;
           inc(len);
         end;
        { store data length in first byte }
        data[0]:=len-1;
        { store index and write to derefdata }
        dataidx:=current_module.derefdata.size;
        current_module.derefdata.write(data,len);
      end;


    function tderef.resolve:tsymtableentry;
      var
        pd     : tdef;
        pm     : tmodule;
        typ    : tdereftype;
        st     : tsymtable;
        idx    : word;
        i      : longint;
        len    : byte;
        data   : array[0..255] of byte;
      begin
        result:=nil;
        { not initialized }
        if dataidx=-1 then
          internalerror(200306067);
        { read data }
        current_module.derefdata.seek(dataidx);
        if current_module.derefdata.read(len,1)<>1 then
          internalerror(200310221);
        if len>0 then
          begin
            if current_module.derefdata.read(data,len)<>len then
              internalerror(200310222);
          end;
        { process data }
        st:=nil;
        i:=0;
        while (i<len) do
          begin
            typ:=tdereftype(data[i]);
            inc(i);
            case typ of
              deref_nil :
                begin
                  result:=nil;
                  { Only allowed when no other deref is available }
                  if len<>1 then
                    internalerror(200306232);
                end;
              deref_sym :
                begin
                  if not assigned(st) then
                    internalerror(200309141);
                  idx:=(data[i] shl 8) or data[i+1];
                  inc(i,2);
                  result:=st.getsymnr(idx);
                end;
              deref_def :
                begin
                  if not assigned(st) then
                    internalerror(200309142);
                  idx:=(data[i] shl 8) or data[i+1];
                  inc(i,2);
                  result:=st.getdefnr(idx);
                end;
              deref_aktrecord :
                st:=aktrecordsymtable;
              deref_aktstatic :
                st:=aktstaticsymtable;
              deref_aktglobal :
                st:=aktglobalsymtable;
              deref_aktlocal :
                st:=aktlocalsymtable;
              deref_aktpara :
                st:=aktparasymtable;
              deref_unit :
                begin
                  idx:=(data[i] shl 8) or data[i+1];
                  inc(i,2);
                  if idx>current_module.mapsize then
                    internalerror(200306231);
                  pm:=current_module.map[idx].u;
                  if not assigned(pm) then
                    internalerror(200212273);
                  st:=pm.globalsymtable;
                end;
              deref_local :
                begin
                  if not assigned(result) then
                    internalerror(200306069);
                  st:=tdef(result).getsymtable(gs_local);
                  result:=nil;
                  if not assigned(st) then
                    internalerror(200212275);
                end;
              deref_para :
                begin
                  if not assigned(result) then
                    internalerror(2003060610);
                  st:=tdef(result).getsymtable(gs_para);
                  result:=nil;
                  if not assigned(st) then
                    internalerror(200212276);
                end;
              deref_record :
                begin
                  if not assigned(result) then
                    internalerror(200306068);
                  st:=tdef(result).getsymtable(gs_record);
                  result:=nil;
                  if not assigned(st) then
                    internalerror(200212274);
                end;
              deref_parent_object :
                begin
                  { load current object symtable if no
                    symtable is available yet }
                  if st=nil then
                    begin
                      st:=aktrecordsymtable;
                      if not assigned(st) then
                        internalerror(200306068);
                    end;
                  if st.symtabletype<>objectsymtable then
                    internalerror(200306189);
                  pd:=tdef(st.defowner).getparentdef;
                  if not assigned(pd) then
                    internalerror(200306184);
                  st:=pd.getsymtable(gs_record);
                  if not assigned(st) then
                    internalerror(200212274);
                end;
              else
                internalerror(200212277);
            end;
          end;
      end;

{*****************************************************************************
                            TCompilerPPUFile
*****************************************************************************}

    procedure tcompilerppufile.checkerror;
      begin
        if error then
         Message(unit_f_ppu_read_error);
      end;


    procedure tcompilerppufile.getguid(var g: tguid);
      begin
        getdata(g,sizeof(g));
      end;


    function tcompilerppufile.getexprint:tconstexprint;
      var
        l1,l2 : longint;
      begin
        if sizeof(tconstexprint)=8 then
          begin
            l1:=getlongint;
            l2:=getlongint;
{$ifopt R+}
  {$define Range_check_on}
{$endif opt R+}
{$R- needed here }
{$ifdef Delphi}
            result:=int64(l1)+(int64(l2) shl 32);
{$else}
            result:=qword(l1)+(int64(l2) shl 32);
{$endif}
{$ifdef Range_check_on}
  {$R+}
  {$undef Range_check_on}
{$endif Range_check_on}
          end
        else
          result:=tconstexprint(getlongint);
      end;


    function tcompilerppufile.getPtrUInt:TConstPtrUInt;
      var
        l1,l2 : longint;
      begin
        if sizeof(TConstPtrUInt)=8 then
          begin
            l1:=getlongint;
            l2:=getlongint;
{$ifopt R+}
  {$define Range_check_on}
{$endif opt R+}
{$R- needed here }
{$ifdef Delphi}
            result:=int64(l1)+(int64(l2) shl 32);
{$else}
            result:=qword(l1)+(int64(l2) shl 32);
{$endif}
{$ifdef Range_check_on}
  {$R+}
  {$undef Range_check_on}
{$endif Range_check_on}
          end
        else
          result:=TConstPtrUInt(getlongint);
      end;


    procedure tcompilerppufile.getposinfo(var p:tfileposinfo);
      var
        info : byte;
      begin
        {
          info byte layout in bits:
          0-1 - amount of bytes for fileindex
          2-3 - amount of bytes for line
          4-5 - amount of bytes for column
        }
        info:=getbyte;
        case (info and $03) of
         0 : p.fileindex:=getbyte;
         1 : p.fileindex:=getword;
         2 : p.fileindex:=(getbyte shl 16) or getword;
         3 : p.fileindex:=getlongint;
        end;
        case ((info shr 2) and $03) of
         0 : p.line:=getbyte;
         1 : p.line:=getword;
         2 : p.line:=(getbyte shl 16) or getword;
         3 : p.line:=getlongint;
        end;
        case ((info shr 4) and $03) of
         0 : p.column:=getbyte;
         1 : p.column:=getword;
         2 : p.column:=(getbyte shl 16) or getword;
         3 : p.column:=getlongint;
        end;
      end;


    procedure tcompilerppufile.getderef(var d:tderef);
      begin
        d.dataidx:=getlongint;
      end;


    function tcompilerppufile.getsymlist:tsymlist;
      var
        symderef : tderef;
        tt  : ttype;
        slt : tsltype;
        idx : longint;
        p   : tsymlist;
      begin
        p:=tsymlist.create;
        getderef(p.procdefderef);
        repeat
          slt:=tsltype(getbyte);
          case slt of
            sl_none :
              break;
            sl_call,
            sl_load,
            sl_subscript :
              begin
                getderef(symderef);
                p.addsymderef(slt,symderef);
              end;
            sl_typeconv :
              begin
                gettype(tt);
                p.addtype(slt,tt);
              end;
            sl_vec :
              begin
                idx:=getlongint;
                p.addconst(slt,idx);
              end;
            else
              internalerror(200110204);
          end;
        until false;
        getsymlist:=tsymlist(p);
      end;


    procedure tcompilerppufile.gettype(var t:ttype);
      begin
        getderef(t.deref);
        t.def:=nil;
        t.sym:=nil;
      end;


    function  tcompilerppufile.getasmsymbol:tasmsymbol;
      begin
        getasmsymbol:=tasmsymbol(pointer(getlongint));
      end;


    procedure tcompilerppufile.putposinfo(const p:tfileposinfo);
      var
        oldcrc : boolean;
        info   : byte;
      begin
        { posinfo is not relevant for changes in PPU }
        oldcrc:=do_crc;
        do_crc:=false;
        {
          info byte layout in bits:
          0-1 - amount of bytes for fileindex
          2-3 - amount of bytes for line
          4-5 - amount of bytes for column
        }
        info:=0;
        { calculate info byte }
        if (p.fileindex>$ff) then
         begin
           if (p.fileindex<=$ffff) then
            info:=info or $1
           else
            if (p.fileindex<=$ffffff) then
             info:=info or $2
           else
            info:=info or $3;
          end;
        if (p.line>$ff) then
         begin
           if (p.line<=$ffff) then
            info:=info or $4
           else
            if (p.line<=$ffffff) then
             info:=info or $8
           else
            info:=info or $c;
          end;
        if (p.column>$ff) then
         begin
           if (p.column<=$ffff) then
            info:=info or $10
           else
            if (p.column<=$ffffff) then
             info:=info or $20
           else
            info:=info or $30;
          end;
        { write data }
        putbyte(info);
        case (info and $03) of
         0 : putbyte(p.fileindex);
         1 : putword(p.fileindex);
         2 : begin
               putbyte(p.fileindex shr 16);
               putword(p.fileindex and $ffff);
             end;
         3 : putlongint(p.fileindex);
        end;
        case ((info shr 2) and $03) of
         0 : putbyte(p.line);
         1 : putword(p.line);
         2 : begin
               putbyte(p.line shr 16);
               putword(p.line and $ffff);
             end;
         3 : putlongint(p.line);
        end;
        case ((info shr 4) and $03) of
         0 : putbyte(p.column);
         1 : putword(p.column);
         2 : begin
               putbyte(p.column shr 16);
               putword(p.column and $ffff);
             end;
         3 : putlongint(p.column);
        end;
        do_crc:=oldcrc;
      end;


    procedure tcompilerppufile.putguid(const g: tguid);
      begin
        putdata(g,sizeof(g));
      end;


    procedure tcompilerppufile.putexprint(v:tconstexprint);
      begin
        if sizeof(TConstExprInt)=8 then
          begin
             putlongint(longint(lo(v)));
             putlongint(longint(hi(v)));
          end
        else if sizeof(TConstExprInt)=4 then
          putlongint(longint(v))
        else
          internalerror(2002082601);
      end;


    procedure tcompilerppufile.PutPtrUInt(v:TConstPtrUInt);
      begin
        if sizeof(TConstPtrUInt)=8 then
          begin
             putlongint(longint(lo(v)));
             putlongint(longint(hi(v)));
          end
        else if sizeof(TConstPtrUInt)=4 then
          putlongint(longint(v))
        else
          internalerror(2002082601);
      end;


    procedure tcompilerppufile.putderef(const d:tderef);
      var
        oldcrc : boolean;
      begin
        oldcrc:=do_crc;
        do_crc:=false;
        putlongint(d.dataidx);
        do_crc:=oldcrc;
      end;


    procedure tcompilerppufile.putsymlist(p:tsymlist);
      var
        hp : psymlistitem;
      begin
        putderef(p.procdefderef);
        hp:=p.firstsym;
        while assigned(hp) do
         begin
           putbyte(byte(hp^.sltype));
           case hp^.sltype of
             sl_call,
             sl_load,
             sl_subscript :
               putderef(hp^.symderef);
             sl_typeconv :
               puttype(hp^.tt);
             sl_vec :
               putlongint(hp^.value);
             else
              internalerror(200110205);
           end;
           hp:=hp^.next;
         end;
        putbyte(byte(sl_none));
      end;


    procedure tcompilerppufile.puttype(const t:ttype);
      begin
        putderef(t.deref);
      end;


    procedure tcompilerppufile.putasmsymbol(s:tasmsymbol);
      begin
        if assigned(s) then
         begin
           if s.ppuidx=-1 then
            begin
              inc(objectlibrary.asmsymbolppuidx);
              s.ppuidx:=objectlibrary.asmsymbolppuidx;
            end;
           putlongint(s.ppuidx);
         end
        else
         putlongint(0);
      end;

{$ifdef MEMDEBUG}
initialization
  membrowser:=TMemDebug.create('BrowserRefs');
  membrowser.stop;
  memrealnames:=TMemDebug.create('Realnames');
  memrealnames.stop;
  memmanglednames:=TMemDebug.create('Manglednames');
  memmanglednames.stop;
  memprocpara:=TMemDebug.create('ProcPara');
  memprocpara.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;
  memprocpara.free;
  memprocparast.free;
  memproclocalst.free;
  memprocnodetree.free;
{$endif MEMDEBUG}

end.
{
  $Log$
  Revision 1.39  2004-02-11 19:59:06  peter
    * fix compilation without GDB

  Revision 1.38  2004/01/31 22:48:31  daniel
    * Fix stabs generation problem reported by Jonas

  Revision 1.37  2004/01/31 21:09:58  daniel
    * Stabs lineinfo problem fixed

  Revision 1.36  2004/01/31 18:40:15  daniel
    * Last steps before removal of aasmtai dependency in symsym can be
      accomplished.

  Revision 1.35  2004/01/26 16:12:28  daniel
    * reginfo now also only allocated during register allocation
    * third round of gdb cleanups: kick out most of concatstabto

  Revision 1.34  2003/11/10 22:02:52  peter
    * cross unit inlining fixed

  Revision 1.33  2003/10/28 15:36:01  peter
    * absolute to object field supported, fixes tb0458

  Revision 1.32  2003/10/23 14:44:07  peter
    * splitted buildderef and buildderefimpl to fix interface crc
      calculation

  Revision 1.31  2003/10/22 20:40:00  peter
    * write derefdata in a separate ppu entry

  Revision 1.30  2003/10/22 15:22:33  peter
    * fixed unitsym-globalsymtable relation so the uses of a unit
      is counted correctly

  Revision 1.29  2003/10/17 14:38:32  peter
    * 64k registers supported
    * fixed some memory leaks

  Revision 1.28  2003/10/07 16:06:30  peter
    * tsymlist.def renamed to tsymlist.procdef
    * tsymlist.procdef is now only used to store the procdef

  Revision 1.27  2003/09/14 12:58:29  peter
    * give IE when st is not assigned in deref

  Revision 1.26  2003/06/25 18:31:23  peter
    * sym,def resolving partly rewritten to support also parent objects
      not directly available through the uses clause

  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

}



end.