freepascal.compiler/compiler/symsym.inc

{
    $Id$
    Copyright (c) 1993-98 by Florian Klaempfl, Pierre Muller

    Implementation for the symbols types of the symtable

    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.
 ****************************************************************************
}

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

    constructor tsym.init(const n : string);
      begin
         left:=nil;
         right:=nil;
         setname(n);
         typ:=abstractsym;
         properties:=current_object_option;
{$ifdef GDB}
         isstabwritten := false;
{$endif GDB}
         if assigned(current_module) and assigned(current_module^.current_inputfile) then
           line_no:=current_module^.current_inputfile^.line_no
         else
           line_no:=0;
{$ifdef UseBrowser}
         defref:=nil;
         lastwritten:=nil;
         if make_ref then
           add_new_ref(defref,@tokenpos);
         lastref:=defref;
         refcount:=1;
{$endif UseBrowser}
      end;

    constructor tsym.load;

      begin
         left:=nil;
         right:=nil;
         setname(readstring);
         typ:=abstractsym;
         if object_options then
           properties:=symprop(readbyte)
         else
           properties:=sp_public;
{$ifdef UseBrowser}
         lastref:=nil;
         defref:=nil;
         lastwritten:=nil;
         refcount:=0;
         if (current_module^.flags and uf_uses_browser)<>0 then
           { references do not change the ppu caracteristics      }
           { this only save the references to variables/functions }
           { defined in the unit what about the others            }
           load_references;
{$endif UseBrowser}
{$ifdef GDB}
         isstabwritten := false;
{$endif GDB}
         line_no:=0;
      end;

{$ifdef UseBrowser}

{$ifdef NEWPPU}

    procedure tsym.load_references;
      var
        fileindex : word;
        b         : byte;
        l,c       : longint;
      begin
         b:=readentry;
         if b=ibref then
          begin
            while (not ppufile^.endofentry) do
             begin
               fileindex:=readword;
               l:=readlong;
               c:=readword;
               inc(refcount);
               lastref:=new(pref,load(lastref,fileindex,l,c));
               if refcount=1 then
                defref:=lastref;
             end;
          end
         else
          Message(unit_f_ppu_read_error);
         lastwritten:=lastref;
      end;

    procedure tsym.write_references;
      var
        ref : pref;
      begin
      { references do not change the ppu caracteristics      }
      { this only save the references to variables/functions }
      { defined in the unit what about the others            }
         ppufile^.do_crc:=false;
         if assigned(lastwritten) then
           ref:=lastwritten
         else
           ref:=defref;
         while assigned(ref) do
           begin
              writeposinfo(ref^.posinfo);
              ref:=ref^.nextref;
           end;
         lastwritten:=lastref;
         ppufile^.writeentry(ibref);
         ppufile^.do_crc:=true;
      end;


    procedure load_external_references;
      var b     : byte;
          sym   : psym;
          prdef : pdef;
      begin
        b:=readentry;
        if b=ibextsymref then
         begin
           sym:=readsymref;
           resolvesym(sym);
           sym^.load_references;
         end;
         ibextdefref : begin
                         prdef:=readdefref;
                         resolvedef(prdef);
                         if prdef^.deftype<>procdef then
                          Message(unit_f_ppu_read_error);
                         pprocdef(prdef)^.load_references;
                       end;
        else
          Message(unit_f_ppu_read_error);
        end;
      end;

    procedure tsym.write_external_references;
      var ref : pref;
          prdef : pdef;
      begin
         ppufile^.do_crc:=false;
         if lastwritten=lastref then
           exit;
         writesymref(@self);
         writeentry(ibextsymref);

         write_references;

         if typ=procsym then
           begin
              prdef:=pprocsym(@self)^.definition;
              while assigned(prdef) do
                begin
                   pprocdef(prdef)^.write_external_references;
                   prdef:=pprocdef(prdef)^.nextoverloaded;
                end;
           end;
         ppufile^.do_crc:=true;
      end;

{$else NEWPPU}

    procedure tsym.load_references;

      var fileindex : word;
          b : byte;
          l,c : longint;

      begin
         b:=readbyte;
         while b=ibref do
           begin
              fileindex:=readword;
              l:=readlong;
              c:=readword;
              inc(refcount);
              lastref:=new(pref,load(lastref,fileindex,l,c));
              if refcount=1 then defref:=lastref;
              b:=readbyte;
           end;
         lastwritten:=lastref;
         if b <> ibend then
          Message(unit_f_ppu_read_error);
      end;

    procedure tsym.write_references;

      var ref : pref;

      begin
      { references do not change the ppu caracteristics      }
      { this only save the references to variables/functions }
      { defined in the unit what about the others            }
         ppufile^.do_crc:=false;
         if assigned(lastwritten) then
           ref:=lastwritten
         else
           ref:=defref;
         while assigned(ref) do
           begin
              writebyte(ibref);
              writeword(ref^.posinfo.fileindex);
              writelong(ref^.posinfo.line);
              writeword(ref^.posinfo.column);
              ref:=ref^.nextref;
           end;
         lastwritten:=lastref;
         writebyte(ibend);
         ppufile^.do_crc:=true;
      end;


    procedure load_external_references;

      var b : byte;
          sym : psym;
          prdef : pdef;
      begin
         b:=readbyte;
         while (b=ibextsymref) or (b=ibextdefref) do
           begin
              if b=ibextsymref then
                begin
                   sym:=readsymref;
                   resolvesym(sym);
                   sym^.load_references;
                   b:=readbyte;
                end
              else
              if b=ibextdefref then
                begin
                   prdef:=readdefref;
                   resolvedef(prdef);
                   if prdef^.deftype<>procdef then
                    Message(unit_f_ppu_read_error);
                   pprocdef(prdef)^.load_references;
                   b:=readbyte;
                end;
           end;
         if b <> ibend then
           Message(unit_f_ppu_read_error);
      end;

    procedure tsym.write_external_references;
      var ref : pref;
          prdef : pdef;
      begin
         ppufile^.do_crc:=false;
         if lastwritten=lastref then
           exit;
         writebyte(ibextsymref);
         writesymref(@self);
         if assigned(lastwritten) then
           ref:=lastwritten
         else
           ref:=defref;
         while assigned(ref) do
           begin
              writebyte(ibref);
              writeword(ref^.posinfo.fileindex);
              writelong(ref^.posinfo.line);
              writeword(ref^.posinfo.column);
              ref:=ref^.nextref;
           end;
         lastwritten:=lastref;
         writebyte(ibend);
         if typ=procsym then
           begin
              prdef:=pprocsym(@self)^.definition;
              while assigned(prdef) do
                begin
                   pprocdef(prdef)^.write_external_references;
                   prdef:=pprocdef(prdef)^.nextoverloaded;
                end;
           end;
         ppufile^.do_crc:=true;
      end;

{$endif NEWPPU}

    procedure tsym.write_ref_to_file(var f : text);

      var ref : pref;
         i : longint;

      begin
         ref:=defref;
         if assigned(ref) then
           begin
              for i:=1 to reffile_indent do
                system.write(f,' ');
              writeln(f,'***',name,'***');
           end;
         inc(reffile_indent,2);
         while assigned(ref) do
           begin
              for i:=1 to reffile_indent do
                system.write(f,' ');
              writeln(f,ref^.get_file_line);
              ref:=ref^.nextref;
           end;
         dec(reffile_indent,2);
      end;
{$endif UseBrowser}

    destructor tsym.done;

      begin
{$ifdef tp}
         if not(use_big) then
{$endif tp}
           strdispose(_name);
         if assigned(left) then dispose(left,done);
         if assigned(right) then dispose(right,done);
      end;

    destructor tsym.single_done;

      begin
{$ifdef tp}
         if not(use_big) then
{$endif tp}
           strdispose(_name);
      end;

    procedure tsym.write;

      begin
         writestring(name);
         if object_options then
           writebyte(byte(properties));
{$ifdef UseBrowser}
         if (current_module^.flags and uf_uses_browser)<>0 then
           write_references;
{$endif UseBrowser}
      end;

    procedure tsym.deref;

      begin
      end;

    function tsym.name : string;
{$ifdef tp}
      var
         s : string;
         b : byte;
{$endif}
      begin
{$ifdef tp}
         if use_big then
           begin
              symbolstream.seek(longint(_name));
              symbolstream.read(b,1);
              symbolstream.read(s[1],b);
              s[0]:=chr(b);
              name:=s;
           end
         else
{$endif}
        if assigned(_name) then
         name:=strpas(_name)
        else
         name:='';
      end;

    function tsym.mangledname : string;
      begin
         mangledname:=name;
      end;

    procedure tsym.setname(const s : string);
      begin
         setstring(_name,s);
      end;

    { for most symbol types ther is nothing to do at all }
    procedure tsym.insert_in_data;
      begin
      end;


{$ifdef GDB}
    function tsym.stabstring : pchar;

      begin
         stabstring:=strpnew('"'+name+'",'+tostr(N_LSYM)+',0,'+tostr(line_no)+',0');
      end;

    procedure tsym.concatstabto(asmlist : paasmoutput);

    var stab_str : pchar;
      begin
         if not isstabwritten then
           begin
              stab_str := stabstring;
              if asmlist = debuglist then do_count_dbx := true;
              { count_dbx(stab_str); moved to GDB.PAS }
              asmlist^.concat(new(pai_stabs,init(stab_str)));
              isstabwritten:=true;
          end;
    end;
{$endif GDB}

{****************************************************************************
                                 TLABELSYM
****************************************************************************}

    constructor tlabelsym.init(const n : string; l : plabel);

      begin
         inherited init(n);
         typ:=labelsym;
         number:=l;
         number^.is_used:=false;
         number^.is_set:=true;
         number^.refcount:=0;
         defined:=false;
      end;

    destructor tlabelsym.done;

      begin
         if not(defined) then
          Message1(sym_e_label_not_defined,name);
         inherited done;
      end;

    function tlabelsym.mangledname : string;

      begin
         { this also sets the is_used field }
         mangledname:=lab2str(number);
      end;

    procedure tlabelsym.write;

      begin
         Message(sym_e_ill_label_decl);
      end;

{****************************************************************************
                                  TUNITSYM
****************************************************************************}

    constructor tunitsym.init(const n : string;ref : punitsymtable);

      begin
         tsym.init(n);
         typ:=unitsym;
         unitsymtable:=ref;
         prevsym:=ref^.unitsym;
         ref^.unitsym:=@self;
         refs:=0;
      end;

    destructor tunitsym.done;
      begin
         if assigned(unitsymtable) and (unitsymtable^.unitsym=@self) then
           unitsymtable^.unitsym:=prevsym;
         inherited done;
      end;

    procedure tunitsym.write;
      begin
      end;

{$ifdef GDB}
    procedure tunitsym.concatstabto(asmlist : paasmoutput);
      begin
      {Nothing to write to stabs !}
      end;
{$endif GDB}

{****************************************************************************
                                  TPROCSYM
****************************************************************************}

    constructor tprocsym.init(const n : string);

      begin
         tsym.init(n);
         typ:=procsym;
         definition:=nil;
         owner:=nil;
{$ifdef GDB}
         is_global := false;
{$endif GDB}
      end;

    constructor tprocsym.load;

      begin
         tsym.load;
         typ:=procsym;
         definition:=pprocdef(readdefref);
{$ifdef GDB}
         is_global := false;
{$endif GDB}
      end;

    destructor tprocsym.done;

      begin
         check_forward;
         tsym.done;
      end;

    function tprocsym.mangledname : string;

      begin
         mangledname:=definition^.mangledname;
      end;


    function tprocsym.demangledname:string;
      begin
        demangledname:=name+definition^.demangled_paras;
      end;


    procedure tprocsym.check_forward;

      var
         pd : pprocdef;

      begin
         pd:=definition;
         while assigned(pd) do
           begin
              if pd^.forwarddef then
                begin
{$ifdef GDB}
                   if assigned(pd^._class) then
                     Message1(sym_e_forward_not_resolved,pd^._class^.name^+'.'+name+demangledparas(pd^.demangled_paras))
                   else
{$endif GDB}
                     Message1(sym_e_forward_not_resolved,name+pd^.demangled_paras)
                end;
              pd:=pd^.nextoverloaded;
           end;
      end;

    procedure tprocsym.deref;
      var t : ttoken;

      begin
         resolvedef(pdef(definition));
         for t:=PLUS to last_overloaded do
           if (overloaded_operators[t]=nil) and
              (name=overloaded_names[t]) then
              overloaded_operators[t]:=@self;
      end;

    procedure tprocsym.write;
      begin
{$ifndef NEWPPU}
         writebyte(ibprocsym);
{$endif}
         tsym.write;
         writedefref(pdef(definition));
{$ifdef NEWPPU}
         ppufile^.writeentry(ibprocsym);
{$endif}
      end;

{$ifdef GDB}
    function tprocsym.stabstring : pchar;
     Var RetType : Char;
         Obj,Info : String;
    begin
      obj := name;
      info := '';
      if is_global then
       RetType := 'F'
      else
       RetType := 'f';
     if assigned(owner) then
      begin
        if (owner^.symtabletype = objectsymtable) then
         obj := owner^.name^+'__'+name;
        if (owner^.symtabletype=localsymtable) and assigned(owner^.name) then
         info := ','+name+','+owner^.name^;
      end;
     stabstring :=strpnew('"'+obj+':'+RetType
           +definition^.retdef^.numberstring+info+'",'+tostr(n_function)
           +',0,'+tostr(current_module^.current_inputfile^.line_no)
           +','+definition^.mangledname);
    end;

    procedure tprocsym.concatstabto(asmlist : paasmoutput);
    begin
      if (definition^.options and pointernproc) <> 0 then exit;
      if not isstabwritten then
        asmlist^.concat(new(pai_stabs,init(stabstring)));
      isstabwritten := true;
      if assigned(definition^.parast) then
        definition^.parast^.concatstabto(asmlist);
      if assigned(definition^.localst) then
        definition^.localst^.concatstabto(asmlist);
      definition^.is_def_stab_written := true;
    end;
{$endif GDB}


{****************************************************************************
                                  TPROGRAMSYM
****************************************************************************}

    constructor tprogramsym.init(const n : string);
      begin
         tsym.init(n);
         typ:=programsym;
      end;

{****************************************************************************
                                  TERRORSYM
****************************************************************************}

    constructor terrorsym.init;
      begin
         tsym.init('');
         typ:=errorsym;
      end;

{****************************************************************************
                                TPROPERTYSYM
****************************************************************************}

    constructor tpropertysym.init(const n : string);
      begin
         inherited init(n);
         typ:=propertysym;
         options:=0;
         proptype:=nil;
         readaccessdef:=nil;
         writeaccessdef:=nil;
         readaccesssym:=nil;
         writeaccesssym:=nil;
         index:=$0;
      end;

    destructor tpropertysym.done;

      begin
         inherited done;
      end;

    constructor tpropertysym.load;

      begin
         inherited load;
         typ:=propertysym;
         proptype:=readdefref;
         options:=readlong;
         index:=readlong;
         { it's hack ... }
         readaccesssym:=psym(stringdup(readstring));
         writeaccesssym:=psym(stringdup(readstring));
         { now the defs: }
         readaccessdef:=readdefref;
         writeaccessdef:=readdefref;
      end;

    procedure tpropertysym.deref;

      begin
         resolvedef(proptype);
         resolvedef(readaccessdef);
         resolvedef(writeaccessdef);
         { solve the hack we did in load: }
         if pstring(readaccesssym)^<>'' then
           begin
              srsym:=search_class_member(pobjectdef(owner^.defowner),pstring(readaccesssym)^);
              if not(assigned(srsym)) then
                srsym:=generrorsym;
           end
         else
           srsym:=nil;
         stringdispose(pstring(readaccesssym));
         readaccesssym:=srsym;
         if pstring(writeaccesssym)^<>'' then
           begin
              srsym:=search_class_member(pobjectdef(owner^.defowner),pstring(writeaccesssym)^);
              if not(assigned(srsym)) then
                srsym:=generrorsym;
           end
         else
           srsym:=nil;
         stringdispose(pstring(writeaccesssym));
         writeaccesssym:=srsym;
      end;

    function tpropertysym.getsize : longint;

      begin
         getsize:=0;
      end;

    procedure tpropertysym.write;

      begin
{$ifndef NEWPPU}
         writebyte(ibpropertysym);
{$endif}
         tsym.write;
         writedefref(proptype);
         writelong(options);
         writelong(index);
         if assigned(readaccesssym) then
           writestring(readaccesssym^.name)
         else
           writestring('');
         if assigned(writeaccesssym) then
           writestring(writeaccesssym^.name)
         else
           writestring('');
         writedefref(readaccessdef);
         writedefref(writeaccessdef);
{$ifdef NEWPPU}
         ppufile^.writeentry(ibpropertysym);
{$endif}
      end;

{$ifdef GDB}
    function tpropertysym.stabstring : pchar;
      begin
         { !!!! don't know how to handle }
         stabstring:=strpnew('');
      end;

    procedure tpropertysym.concatstabto(asmlist : paasmoutput);
      begin
         { !!!! don't know how to handle }
      end;
{$endif GDB}

{****************************************************************************
                                  TFUNCRETSYM
****************************************************************************}

{$ifdef TEST_FUNCRET}
    constructor tfuncretsym.init(const n : string;approcinfo : pointer{pprocinfo});

      begin
         tsym.init(n);
         funcretprocinfo:=approcinfo;
         funcretdef:=pprocinfo(approcinfo)^.retdef;
         { address valid for ret in param only }
         { otherwise set by insert             }
         address:=pprocinfo(approcinfo)^.retoffset;
      end;
{$endif TEST_FUNCRET}

{****************************************************************************
                                  TABSOLUTESYM
****************************************************************************}

{   constructor tabsolutesym.init(const s : string;p : pdef;newref : psym);
     begin
        inherited init(s,p);
        ref:=newref;
        typ:=absolutesym;
     end; }

    constructor tabsolutesym.load;

      begin
         tvarsym.load;
         typ:=absolutesym;
         ref:=nil;
         address:=0;
         asmname:=nil;
         abstyp:=absolutetyp(readbyte);
         absseg:=false;
         case abstyp of
       tovar : begin
                 asmname:=stringdup(readstring);
                 ref:=srsym;
               end;
       toasm : asmname:=stringdup(readstring);
      toaddr : address:=readlong;
         end;
      end;

    procedure tabsolutesym.write;

      begin
{$ifndef NEWPPU}
         writebyte(ibabsolutesym);
{$endif}
         tsym.write;
         writebyte(byte(varspez));
         if read_member then
           writelong(address);
         writedefref(definition);
         writebyte(byte(abstyp));
         case abstyp of
           tovar : writestring(ref^.name);
           toasm : writestring(asmname^);
          toaddr : writelong(address);
         end;
{$ifdef NEWPPU}
        ppufile^.writeentry(ibabsolutesym);
{$endif}
      end;

    procedure tabsolutesym.deref;
      begin
         resolvedef(definition);
         if (abstyp=tovar) and (asmname<>nil) then
           begin
              { search previous loaded symtables }
              getsym(asmname^,false);
              if not(assigned(srsym)) then
                getsymonlyin(owner,asmname^);
              if not(assigned(srsym)) then
                srsym:=generrorsym;
              ref:=srsym;
              stringdispose(asmname);
           end;
      end;

    function tabsolutesym.mangledname : string;
      begin
         case abstyp of
           tovar : mangledname:=ref^.mangledname;
           toasm : mangledname:=asmname^;
          toaddr : mangledname:='$'+tostr(address);
         else
           internalerror(10002);
         end;
      end;

      procedure tabsolutesym.insert_in_data;

        begin
        end;


{$ifdef GDB}
    procedure tabsolutesym.concatstabto(asmlist : paasmoutput);
      begin
      { I don't know how to handle this !! }
      end;
{$endif GDB}

{****************************************************************************
                                  TVARSYM
****************************************************************************}

    constructor tvarsym.init(const n : string;p : pdef);
      begin
         tsym.init(n);
         typ:=varsym;
         definition:=p;
         varspez:=vs_value;
         address:=0;
         refs:=0;
         is_valid := 1;
         { can we load the value into a register ? }
         case p^.deftype of
        pointerdef,
           enumdef,
        procvardef : regable:=true;
            orddef : case porddef(p)^.typ of
                      u8bit,s32bit,
                    bool8bit,uchar,
                      s8bit,s16bit,
                     u16bit,u32bit : regable:=true;
                     else
                       regable:=false;
                     end;
         else
           regable:=false;
         end;
         reg:=R_NO;
      end;

    constructor tvarsym.load;

      begin
         tsym.load;
         typ:=varsym;
         varspez:=tvarspez(readbyte);
         if read_member then
           address:=readlong
         else address:=0;
         definition:=readdefref;
         refs := 0;
         is_valid := 1;
         { symbols which are load are never candidates for a register }
         regable:=false;
         reg:=R_NO;
      end;

    procedure tvarsym.deref;

      begin
         resolvedef(definition);
      end;

    procedure tvarsym.write;

      begin
{$ifndef NEWPPU}
         writebyte(ibvarsym);
{$endif}
         tsym.write;
         writebyte(byte(varspez));

         if read_member then
           writelong(address);

         writedefref(definition);
{$ifdef NEWPPU}
         ppufile^.writeentry(ibvarsym);
{$endif}
      end;

    function tvarsym.mangledname : string;
      var
        prefix : string;
      begin
         case owner^.symtabletype of
           staticsymtable : if (cs_smartlink in aktswitches) then
                              prefix:='_'+owner^.name^+'$$$_'
                            else
                              prefix:='_';
             unitsymtable,
           globalsymtable : prefix:='U_'+owner^.name^+'_';
           else
             Message(sym_e_invalid_call_tvarsymmangledname);
           end;
         mangledname:=prefix+name;
      end;

    function tvarsym.getsize : longint;
      begin
         { only if the definition is set, we could determine the   }
         { size, this is if an error occurs while reading the type }
         { also used for operator, this allows not to allocate the }
         { return size twice                                       }
         if assigned(definition) then
           begin
              case varspez of
                 vs_value : getsize:=definition^.size;
                 vs_var : getsize:=sizeof(pointer);
                 vs_const : begin
                               if (definition^.deftype in [stringdef,arraydef,
                                     recorddef,objectdef,setdef]) then
                                 getsize:=sizeof(pointer)
                               else
                                 getsize:=definition^.size;
                            end;
              end;
           end
         else
           getsize:=0;
      end;

    procedure tvarsym.insert_in_data;
      var
         l,modulo : longint;
      begin
       { handle static variables of objects especially }
       if read_member and (owner^.symtabletype=objectsymtable) and
          ((properties and sp_static)<>0) then
         begin
            { the data filed is generated in parser.pas
              with a tobject_FIELDNAME variable }
            { this symbol can't be loaded to a register }
            regable:=false;
         end
       else if not(read_member) then
         begin
            { made problems with parameters etc. ! (FK) }

            {  check for instance of an abstract object or class }
            {
            if (pvarsym(sym)^.definition^.deftype=objectdef) and
              ((pobjectdef(pvarsym(sym)^.definition)^.options and oois_abstract)<>0) then
              Message(sym_e_no_instance_of_abstract_object);
            }
            { bei einer lokalen Symboltabelle erst! erh”hen, da der }
            { Wert in codegen.secondload dann mit minus verwendet   }
            { wird                                                  }
            l:=getsize;
            if owner^.symtabletype=localsymtable then
              begin
                 is_valid := 0;
                 modulo:=owner^.datasize and 3;
{$ifdef m68k}
                 { word alignment required for motorola }
                 if (l=1) then
                  l:=2
                 else
{$endif}

                 if (l>=4) and (modulo<>0) then
                   inc(l,4-modulo)
                 else if (l>=2) and ((modulo and 1)<>0) then
                   inc(l,2-(modulo and 1));
                 inc(owner^.datasize,l);

                 address:=owner^.datasize;
              end
            else if owner^.symtabletype=staticsymtable then
              begin
                if (cs_smartlink in aktswitches) then
                  bsssegment^.concat(new(pai_cut,init));
{$ifdef GDB}
                if cs_debuginfo in aktswitches then
                   concatstabto(bsssegment);
{$endif GDB}
                if (cs_smartlink in aktswitches) then
                  bsssegment^.concat(new(pai_datablock,init_global(mangledname,l)))
                else
                  bsssegment^.concat(new(pai_datablock,init(mangledname,l)));

                inc(owner^.datasize,l);

                { this symbol can't be loaded to a register }
                regable:=false;
              end
            else if owner^.symtabletype=globalsymtable then
              begin
                 if (cs_smartlink in aktswitches) then
                   bsssegment^.concat(new(pai_cut,init));
{$ifdef GDB}
                 if cs_debuginfo in aktswitches then
                   begin
                      concatstabto(bsssegment);
                      { this has to be added so that the debugger knows where to find
                        the global variable
                        Doesn't work !!
                      bsssegment^.concat(new(pai_symbol,init('_'+name))); }
                   end;
{$endif GDB}
                 bsssegment^.concat(new(pai_datablock,init_global(mangledname,l)));
                 inc(owner^.datasize,l);

                 { this symbol can't be loaded to a register }
                 regable:=false;
              end
            else if owner^.symtabletype in [recordsymtable,objectsymtable] then
              begin
                 { align record and object fields }
                 if aktpackrecords=2 then
                   begin
                     { align to word }
                     modulo:=owner^.datasize and 3;
                     if (l>=2) and ((modulo and 1)<>0) then
                       inc(owner^.datasize);
                   end
                 else if aktpackrecords=4 then
                   begin
                      { align to dword }
                      if (l>=3) and (modulo<>0) then
                        inc(owner^.datasize,4-modulo)
                        { or word }
                      else if (l=2) and ((modulo and 1)<>0) then
                        inc(owner^.datasize)
                   end;
                 address:=owner^.datasize;
                 inc(owner^.datasize,l);

                 { this symbol can't be loaded to a register }
                 regable:=false;
              end
             else if owner^.symtabletype=parasymtable then
              begin
                 address:=owner^.datasize;

                 { intel processors don't know a byte push, }
                 { so is always a word pushed               }
                 { so it must allways be even               }
                 if (l and 1)<>0 then
                   inc(l);
                 inc(owner^.datasize,l);
              end
            else
              begin
                 modulo:=owner^.datasize and 3 ;
                 if (l>=4) and (modulo<>0) then
                   inc(owner^.datasize,4-modulo)
                 else if (l>=2) and ((modulo and 1)<>0) then
                   { nice piece of code !!
                   inc(owner^.datasize,2-(datasize and 1));
                   2 - (datasize and 1) is allways 1 in this case
                   Florian when will your global stream analyser
                   find this out ?? }
                   inc(owner^.datasize);
                 address:=owner^.datasize;
                 inc(owner^.datasize,l);
              end;
            end
        end;

{$ifdef GDB}
    function tvarsym.stabstring : pchar;
    var
      st : char;
    begin
       if (owner^.symtabletype = objectsymtable) and
          ((properties and sp_static)<>0) then
         begin
            if use_gsym then st := 'G' else st := 'S';
            stabstring := strpnew('"'+owner^.name^+'__'+name+':'+
                     +definition^.numberstring+'",'+
                     tostr(N_LCSYM)+',0,'+tostr(line_no)+','+mangledname);
         end
       else if (owner^.symtabletype = globalsymtable) or
          (owner^.symtabletype = unitsymtable) then
         begin
            { Here we used S instead of
              because with G GDB doesn't look at the address field
              but searches the same name or with a leading underscore
              but these names don't exist in pascal !}
            if use_gsym then st := 'G' else st := 'S';
            stabstring := strpnew('"'+name+':'+st
                     +definition^.numberstring+'",'+
                     tostr(N_LCSYM)+',0,'+tostr(line_no)+','+mangledname);
         end
       else if owner^.symtabletype = staticsymtable then
         begin
            stabstring := strpnew('"'+name+':S'
                  +definition^.numberstring+'",'+
                  tostr(N_LCSYM)+',0,'+tostr(line_no)+','+mangledname);
         end
       else if (owner^.symtabletype=parasymtable) then
         begin
            case varspez of
               vs_value : st := 'p';
               vs_var   : st := 'v';
               vs_const : if dont_copy_const_param(definition) then
                            st := 'v'{ should be 'i' but 'i' doesn't work }
                          else
                            st := 'p';
              end;
            stabstring := strpnew('"'+name+':'+st
                  +definition^.numberstring+'",'+
                  tostr(N_PSYM)+',0,'+tostr(line_no)+','+tostr(address+owner^.call_offset))
                  {offset to ebp => will not work if the framepointer is esp
                  so some optimizing will make things harder to debug }
         end
       else if (owner^.symtabletype=localsymtable) then
   {$ifdef i386}
         if reg<>R_NO then
           begin
              { "eax", "ecx", "edx", "ebx", "esp", "ebp", "esi", "edi", "eip", "ps", "cs", "ss", "ds", "es", "fs", "gs", }
              { this is the register order for GDB}
              stabstring:=strpnew('"'+name+':r'
                        +definition^.numberstring+'",'+
                        tostr(N_RSYM)+',0,'+tostr(line_no)+','+tostr(GDB_i386index[reg]));
           end
         else
   {$endif i386}
           stabstring := strpnew('"'+name+':'
                  +definition^.numberstring+'",'+
                  tostr(N_LSYM)+',0,'+tostr(line_no)+',-'+tostr(address))
       else
         stabstring := inherited stabstring;
  end;

    procedure tvarsym.concatstabto(asmlist : paasmoutput);
{$ifdef i386}
      var stab_str : pchar;
{$endif i386}
      begin
         inherited concatstabto(asmlist);
{$ifdef i386}
      if (owner^.symtabletype=parasymtable) and
         (reg<>R_NO) then
           begin
           { "eax", "ecx", "edx", "ebx", "esp", "ebp", "esi", "edi", "eip", "ps", "cs", "ss", "ds", "es", "fs", "gs", }
           { this is the register order for GDB}
              stab_str:=strpnew('"'+name+':r'
                     +definition^.numberstring+'",'+
                     tostr(N_RSYM)+',0,'+tostr(line_no)+','+tostr(GDB_i386index[reg]));
              asmlist^.concat(new(pai_stabs,init(stab_str)));
           end;
{$endif i386}
      end;
{$endif GDB}

{****************************************************************************
                             TTYPEDCONSTSYM
*****************************************************************************}

    constructor ttypedconstsym.init(const n : string;p : pdef);

      begin
         tsym.init(n);
         typ:=typedconstsym;
         definition:=p;
         prefix:=stringdup(procprefix);
      end;

    constructor ttypedconstsym.load;

      begin
         tsym.load;
         typ:=typedconstsym;
         definition:=readdefref;
         prefix:=stringdup(readstring);
      end;

    destructor ttypedconstsym.done;

      begin
         stringdispose(prefix);
         tsym.done;
      end;

    function ttypedconstsym.mangledname : string;

      begin
         mangledname:='TC_'+prefix^+'_'+name;
      end;

    procedure ttypedconstsym.deref;

      begin
         resolvedef(definition);
      end;

    procedure ttypedconstsym.write;

      begin
{$ifndef NEWPPU}
         writebyte(ibtypedconstsym);
{$endif}
         tsym.write;
         writedefref(definition);
         writestring(prefix^);
{$ifdef NEWPPU}
         ppufile^.writeentry(ibtypedconstsym);
{$endif}
      end;

      { for most symbol types ther is nothing to do at all }
      procedure ttypedconstsym.insert_in_data;

        begin
           { here there is a problem for ansistrings !!                 }
           { we must write the label only after the 12 header bytes (PM) }
           if not is_ansistring(definition) then
             really_insert_in_data;
        end;

      procedure ttypedconstsym.really_insert_in_data;
        begin
           if (cs_smartlink in aktswitches) then
             datasegment^.concat(new(pai_cut,init));
           if owner^.symtabletype=globalsymtable then
             begin
{$ifdef GDB}
                if cs_debuginfo in aktswitches then
                  concatstabto(datasegment);
{$endif GDB}
                datasegment^.concat(new(pai_symbol,init_global(mangledname)));
             end
           else
             if owner^.symtabletype<>unitsymtable then
               begin
{$ifdef GDB}
                 if cs_debuginfo in aktswitches then
                   concatstabto(datasegment);
{$endif GDB}
                 if (cs_smartlink in aktswitches) then
                   datasegment^.concat(new(pai_symbol,init_global(mangledname)))
                 else
                   datasegment^.concat(new(pai_symbol,init(mangledname)));
               end;
           end;

{$ifdef GDB}
    function ttypedconstsym.stabstring : pchar;
    var
      st : char;
    begin
    if use_gsym and (owner^.symtabletype in [unitsymtable,globalsymtable]) then
      st := 'G'
    else
      st := 'S';
    stabstring := strpnew('"'+name+':'+st
            +definition^.numberstring+'",'+tostr(n_STSYM)+',0,'+tostr(line_no)+','+mangledname);
    end;
{$endif GDB}

{****************************************************************************
                                  TCONSTSYM
****************************************************************************}

    constructor tconstsym.init(const n : string;t : tconsttype;v : longint;def : pdef);

      begin
         tsym.init(n);
         typ:=constsym;
         definition:=def;
         consttype:=t;
         value:=v;
      end;

    constructor tconstsym.load;

      var
         pd : pdouble;
         ps : pointer;  {***SETCONST}

      begin
         tsym.load;
         typ:=constsym;
         consttype:=tconsttype(readbyte);
         case consttype of
            constint,
            constbool,
            constchar : value:=readlong;
            constord : begin
                          definition:=readdefref;
                          value:=readlong;
                       end;
            conststring : value:=longint(stringdup(readstring));
            constreal : begin
                           new(pd);
                           pd^:=readdouble;
                           value:=longint(pd);
                        end;
{***SETCONST}
            constseta : begin
                           getmem(ps,32);
                           readset(ps^);
                           value:=longint(ps);
                       end;
{***}
         else Message1(unit_f_ppu_invalid_entry,tostr(ord(consttype)));
         end;
      end;

    destructor tconstsym.done;
      begin
      if consttype = conststring then stringdispose(pstring(value));
      inherited done;
      end;

    function tconstsym.mangledname : string;

      begin
         mangledname:=name;
      end;

    procedure tconstsym.deref;

      begin
         if consttype=constord then
           resolvedef(pdef(definition));
      end;

    procedure tconstsym.write;

      begin
{$ifndef NEWPPU}
         writebyte(ibconstsym);
{$endif}
         tsym.write;
         writebyte(byte(consttype));
         case consttype of
            constint,
            constbool,
            constchar : writelong(value);
            constord : begin
                          writedefref(definition);
                          writelong(value);
                       end;
            conststring : writestring(pstring(value)^);
            constreal : writedouble(pdouble(value)^);
{***SETCONST}
            constseta: writeset(pointer(value)^);
{***}
            else internalerror(13);
         end;
{$ifdef NEWPPU}
        ppufile^.writeentry(ibconstsym);
{$endif}
      end;

{$ifdef GDB}
    function tconstsym.stabstring : pchar;
    var st : string;
    begin
         {even GDB v4.16 only now 'i' 'r' and 'e' !!!}
         case consttype of
            conststring : begin
                          { I had to remove ibm2ascii !! }
                          st := pstring(value)^;
                          {st := ibm2ascii(pstring(value)^);}
                          st := 's'''+st+'''';
                          end;
            constbool, constint, constord, constchar : st := 'i'+tostr(value);
            constreal : begin
                        system.str(pdouble(value)^,st);
                        st := 'r'+st;
                        end;
         { if we don't know just put zero !! }
         else st:='i0';
            {***SETCONST}
            {constset:;}    {*** I don't know what to do with a set.}
         { sets are not recognized by GDB}
            {***}
        end;
    stabstring := strpnew('"'+name+':c='+st+'",'+tostr(N_function)+',0,'+tostr(line_no)+',0');
    end;

    procedure tconstsym.concatstabto(asmlist : paasmoutput);
      begin
        if consttype <> conststring then
          inherited concatstabto(asmlist);
      end;
{$endif GDB}

{****************************************************************************
                                  TENUMSYM
****************************************************************************}

    constructor tenumsym.init(const n : string;def : penumdef;v : longint);
      begin
         tsym.init(n);
         typ:=enumsym;
         definition:=def;
         value:=v;
{$ifdef GDB}
         order;
{$endif GDB}
      end;

    constructor tenumsym.load;

      begin
         tsym.load;
         typ:=enumsym;
         definition:=penumdef(readdefref);
         value:=readlong;
{$ifdef GDB}
         next := Nil;
{$endif GDB}
      end;

    procedure tenumsym.deref;

      begin
         resolvedef(pdef(definition));
{$ifdef GDB}
         order;
{$endif}
      end;

{$ifdef GDB}
         procedure tenumsym.order;
         var sym : penumsym;
         begin
         sym := definition^.first;
         if sym = nil then
           begin
           definition^.first := @self;
           next := nil;
           exit;
           end;
         {reorder the symbols in increasing value }
         if value < sym^.value then
           begin
           next := sym;
           definition^.first := @self;
           end else
           begin
           while (sym^.value <= value) and assigned(sym^.next) do
             sym := sym^.next;
           next := sym^.next;
           sym^.next := @self;
           end;
         end;
{$endif GDB}

    procedure tenumsym.write;

      begin
{$ifndef NEWPPU}
         writebyte(ibenumsym);
{$endif}
         tsym.write;
         writedefref(definition);
         writelong(value);
{$ifdef NEWPPU}
         ppufile^.writeentry(ibenumsym);
{$endif}
      end;

{$ifdef GDB}
    procedure tenumsym.concatstabto(asmlist : paasmoutput);
    begin
    {enum elements have no stab !}
    end;
{$EndIf GDB}

{****************************************************************************
                                  TTYPESYM
****************************************************************************}

    constructor ttypesym.init(const n : string;d : pdef);

      begin
         tsym.init(n);
         typ:=typesym;
         definition:=d;
{$ifdef GDB}
         isusedinstab := false;
{$endif GDB}
         forwardpointer:=nil;
         { this allows to link definitions with the type with declares }
         { them                                                        }
         if assigned(definition) then
           if definition^.sym=nil then
             definition^.sym:=@self;
      end;

    constructor ttypesym.load;

      begin
         tsym.load;
         typ:=typesym;
         forwardpointer:=nil;
{$ifdef GDB}
         isusedinstab := false;
{$endif GDB}
         definition:=readdefref;
      end;

    destructor ttypesym.done;

      begin
         if assigned(definition) then
           if definition^.sym=@self then
             definition^.sym:=nil;
         inherited done;
      end;

    procedure ttypesym.deref;

      begin
         resolvedef(definition);
         if assigned(definition) then
           if definition^.sym=nil then
             definition^.sym:=@self;
         if definition^.deftype=recorddef then
           precdef(definition)^.symtable^.name:=stringdup('record '+name);
         {if definition^.deftype=objectdef then
           pobjectdef(definition)^.publicsyms^.name:=stringdup('object '+name);
           done in tobjectdef.load }
      end;

    procedure ttypesym.write;

      begin
{$ifndef NEWPPU}
         writebyte(ibtypesym);
{$endif}
         tsym.write;
         writedefref(definition);
{$ifdef NEWPPU}
         ppufile^.writeentry(ibtypesym);
{$endif}
      end;

{$ifdef GDB}
    function ttypesym.stabstring : pchar;
    var stabchar : string[2];
        short : string;
    begin
      if definition^.deftype in tagtypes then
        stabchar := 'Tt'
      else
        stabchar := 't';
      short := '"'+name+':'+stabchar+definition^.numberstring
               +'",'+tostr(N_LSYM)+',0,'+tostr(line_no)+',0';
      stabstring := strpnew(short);
    end;

    procedure ttypesym.concatstabto(asmlist : paasmoutput);
      begin
      {not stabs for forward defs }
      if assigned(definition) then
        if (definition^.sym = @self) then
          definition^.concatstabto(asmlist)
        else
          inherited concatstabto(asmlist);
      end;
{$endif GDB}

{****************************************************************************
                                  TSYSSYM
****************************************************************************}

    constructor tsyssym.init(const n : string;l : longint);
      begin
         inherited init(n);
         typ:=syssym;
         number:=l;
      end;

    procedure tsyssym.write;
      begin
      end;

{$ifdef GDB}
    procedure tsyssym.concatstabto(asmlist : paasmoutput);
      begin
      end;
{$endif GDB}

{****************************************************************************
                                  TMACROSYM
****************************************************************************}

    constructor tmacrosym.init(const n : string);
      begin
         inherited init(n);
         defined:=true;
         buftext:=nil;
         buflen:=0;
      end;

    destructor tmacrosym.done;
      begin
         if assigned(buftext) then
           freemem(buftext,buflen);
         inherited done;
      end;

{$ifdef GDB}
    function typeglobalnumber(const s : string) : string;

      var st : string;
          symt : psymtable;
          old_make_ref : boolean;
      begin
         old_make_ref:=make_ref;
         make_ref:=false;
         typeglobalnumber := '0';
         srsym := nil;
         if pos('.',s) > 0 then
           begin
           st := copy(s,1,pos('.',s)-1);
           getsym(st,false);
           st := copy(s,pos('.',s)+1,255);
           if assigned(srsym) then
             begin
             if srsym^.typ = unitsym then
               begin
               symt := punitsym(srsym)^.unitsymtable;
               srsym := symt^.search(st);
               end else srsym := nil;
             end;
           end else st := s;
         if srsym = nil then getsym(st,true);
         if srsym^.typ<>typesym then
           begin
             Message(sym_e_type_id_expected);
             exit;
           end;
         typeglobalnumber := ptypesym(srsym)^.definition^.numberstring;
         make_ref:=old_make_ref;
      end;
{$endif GDB}

{
  $Log$
  Revision 1.5  1998-06-04 23:52:02  peter
    * m68k compiles
    + .def file creation moved to gendef.pas so it could also be used
      for win32

  Revision 1.4  1998/06/04 09:55:46  pierre
    * demangled name of procsym reworked to become independant of the mangling scheme

  Come test_funcret improvements (not yet working)S: ----------------------------------------------------------------------

  Revision 1.3  1998/06/03 22:14:20  florian
    * problem with sizes of classes fixed (if the anchestor was declared
      forward, the compiler doesn't update the child classes size)

  Revision 1.2  1998/05/28 14:40:29  peter
    * fixes for newppu, remake3 works now with it

  Revision 1.1  1998/05/27 19:45:09  peter
    * symtable.pas splitted into includefiles
    * symtable adapted for $ifdef NEWPPU

}