fpc/compiler/symdef.pas

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

    Symbol table implementation for the definitions

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

{$i fpcdefs.inc}

interface

    uses
       { common }
       cutils,cclasses,
       { global }
       globtype,globals,tokens,
       { symtable }
       symconst,symbase,symtype,
       { ppu }
       ppu,
       { node }
       node,
       { aasm }
       aasmbase,aasmtai,
       cpubase,cpuinfo,
       cgbase,cgutils,
       parabase
       ;


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

       tstoreddef = class(tdef)
       protected
          typesymderef  : tderef;
       public
          { persistent (available across units) rtti and init tables }
          rttitablesym,
          inittablesym  : tsym; {trttisym}
          rttitablesymderef,
          inittablesymderef : tderef;
          { local (per module) rtti and init tables }
          localrttilab  : array[trttitype] of tasmlabel;
          { linked list of global definitions }
{$ifdef EXTDEBUG}
          fileinfo   : tfileposinfo;
{$endif}
{$ifdef GDB}
          globalnb   : word;
          stab_state : tdefstabstatus;
{$endif GDB}
          constructor create;
          constructor ppuloaddef(ppufile:tcompilerppufile);
          procedure reset;
          function getcopy : tstoreddef;virtual;
          procedure ppuwritedef(ppufile:tcompilerppufile);
          procedure ppuwrite(ppufile:tcompilerppufile);virtual;abstract;
          procedure buildderef;override;
          procedure buildderefimpl;override;
          procedure deref;override;
          procedure derefimpl;override;
          function  size:aint;override;
          function  alignment:longint;override;
          function  is_publishable : boolean;override;
          function  needs_inittable : boolean;override;
          { debug }
{$ifdef GDB}
          function get_var_value(const s:string):string;
          function stabstr_evaluate(const s:string;const vars:array of string):Pchar;
          function  stabstring : pchar;virtual;
          procedure concatstabto(asmlist : taasmoutput);virtual;
          function  numberstring:string;virtual;
          procedure set_globalnb;virtual;
          function  allstabstring : pchar;virtual;
{$endif GDB}
          { rtti generation }
          procedure write_rtti_name;
          procedure write_rtti_data(rt:trttitype);virtual;
          procedure write_child_rtti_data(rt:trttitype);virtual;
          function  get_rtti_label(rt:trttitype):tasmsymbol;
          { regvars }
          function is_intregable : boolean;
          function is_fpuregable : boolean;
       private
          savesize  : aint;
       end;

       tfiletyp = (ft_text,ft_typed,ft_untyped);

       tfiledef = class(tstoreddef)
          filetyp : tfiletyp;
          typedfiletype : ttype;
          constructor createtext;
          constructor createuntyped;
          constructor createtyped(const tt : ttype);
          constructor ppuload(ppufile:tcompilerppufile);
          function getcopy : tstoreddef;override;
          procedure ppuwrite(ppufile:tcompilerppufile);override;
          procedure buildderef;override;
          procedure deref;override;
          function  gettypename:string;override;
          function  getmangledparaname:string;override;
          procedure setsize;
          { debug }
{$ifdef GDB}
          function  stabstring : pchar;override;
          procedure concatstabto(asmlist : taasmoutput);override;
{$endif GDB}
       end;

       tvariantdef = class(tstoreddef)
          varianttype : tvarianttype;
          constructor create(v : tvarianttype);
          constructor ppuload(ppufile:tcompilerppufile);
          function getcopy : tstoreddef;override;
          function gettypename:string;override;
          procedure ppuwrite(ppufile:tcompilerppufile);override;
          procedure setsize;
          function needs_inittable : boolean;override;
          procedure write_rtti_data(rt:trttitype);override;
{$ifdef GDB}
          function  numberstring:string;override;
          function  stabstring : pchar;override;
          procedure concatstabto(asmlist : taasmoutput);override;
{$endif GDB}
       end;

       tformaldef = class(tstoreddef)
          constructor create;
          constructor ppuload(ppufile:tcompilerppufile);
          procedure ppuwrite(ppufile:tcompilerppufile);override;
          function  gettypename:string;override;
{$ifdef GDB}
          function  numberstring:string;override;
          function  stabstring : pchar;override;
          procedure concatstabto(asmlist : taasmoutput);override;
{$endif GDB}
       end;

       tforwarddef = class(tstoreddef)
          tosymname : pstring;
          forwardpos : tfileposinfo;
          constructor create(const s:string;const pos : tfileposinfo);
          destructor destroy;override;
          function  gettypename:string;override;
       end;

       terrordef = class(tstoreddef)
          constructor create;
          procedure ppuwrite(ppufile:tcompilerppufile);override;
          function  gettypename:string;override;
          function  getmangledparaname : string;override;
          { debug }
{$ifdef GDB}
          function  stabstring : pchar;override;
          procedure concatstabto(asmlist : taasmoutput);override;
{$endif GDB}
       end;

       { tpointerdef and tclassrefdef should get a common
         base class, but I derived tclassrefdef from tpointerdef
         to avoid problems with bugs (FK)
       }

       tpointerdef = class(tstoreddef)
          pointertype : ttype;
          is_far : boolean;
          constructor create(const tt : ttype);
          constructor createfar(const tt : ttype);
          function getcopy : tstoreddef;override;
          constructor ppuload(ppufile:tcompilerppufile);
          procedure ppuwrite(ppufile:tcompilerppufile);override;
          procedure buildderef;override;
          procedure deref;override;
          function  gettypename:string;override;
          { debug }
{$ifdef GDB}
          function  stabstring : pchar;override;
          procedure concatstabto(asmlist : taasmoutput);override;
{$endif GDB}
       end;

       Trecord_stabgen_state=record
          stabstring:Pchar;
          stabsize,staballoc,recoffset:integer;
       end;

       tabstractrecorddef= class(tstoreddef)
       private
          Count         : integer;
          FRTTIType     : trttitype;
{$ifdef GDB}
          procedure field_addname(p:Tnamedindexitem;arg:pointer);
          procedure field_concatstabto(p:Tnamedindexitem;arg:pointer);
{$endif}
          procedure count_field_rtti(sym : tnamedindexitem;arg:pointer);
          procedure write_field_rtti(sym : tnamedindexitem;arg:pointer);
          procedure generate_field_rtti(sym : tnamedindexitem;arg:pointer);
       public
          symtable : tsymtable;
          function  getsymtable(t:tgetsymtable):tsymtable;override;
       end;

       trecorddef = class(tabstractrecorddef)
       public
          isunion       : boolean;
          constructor create(p : tsymtable);
          constructor ppuload(ppufile:tcompilerppufile);
          destructor destroy;override;
          function getcopy : tstoreddef;override;
          procedure ppuwrite(ppufile:tcompilerppufile);override;
          procedure buildderef;override;
          procedure deref;override;
          function  size:aint;override;
          function  alignment : longint;override;
          function  padalignment: longint;
          function  gettypename:string;override;
          { debug }
{$ifdef GDB}
          function  stabstring : pchar;override;
          procedure concatstabto(asmlist:taasmoutput);override;
{$endif GDB}
          function  needs_inittable : boolean;override;
          { rtti }
          procedure write_child_rtti_data(rt:trttitype);override;
          procedure write_rtti_data(rt:trttitype);override;
       end;

       tprocdef = class;
       tobjectdef = class;
       timplementedinterfaces = class;

       timplintfentry = class(TNamedIndexItem)
         intf         : tobjectdef;
         intfderef    : tderef;
         ioffset      : longint;
         implintf     : longint;
         namemappings : tdictionary;
         procdefs     : TIndexArray;
         constructor create(aintf: tobjectdef);
         constructor create_deref(const d:tderef);
         destructor  destroy; override;
       end;

       tobjectdef = class(tabstractrecorddef)
       private
{$ifdef GDB}
          procedure proc_addname(p :tnamedindexitem;arg:pointer);
          procedure proc_concatstabto(p :tnamedindexitem;arg:pointer);
{$endif GDB}
          procedure count_published_properties(sym:tnamedindexitem;arg:pointer);
          procedure write_property_info(sym : tnamedindexitem;arg:pointer);
          procedure generate_published_child_rtti(sym : tnamedindexitem;arg:pointer);
          procedure count_published_fields(sym:tnamedindexitem;arg:pointer);
          procedure writefields(sym:tnamedindexitem;arg:pointer);
       public
          childof  : tobjectdef;
          childofderef  : tderef;
          objname,
          objrealname   : pstring;
          objectoptions : tobjectoptions;
          { to be able to have a variable vmt position }
          { and no vmt field for objects without virtuals }
          vmt_offset : longint;
{$ifdef GDB}
          writing_class_record_stab : boolean;
{$endif GDB}
          objecttype : tobjectdeftype;
          iidguid: pguid;
          iidstr: pstring;
          lastvtableindex: longint;
          { store implemented interfaces defs and name mappings }
          implementedinterfaces: timplementedinterfaces;
          constructor create(ot : tobjectdeftype;const n : string;c : tobjectdef);
          constructor ppuload(ppufile:tcompilerppufile);
          destructor  destroy;override;
          function getcopy : tstoreddef;override;
          procedure ppuwrite(ppufile:tcompilerppufile);override;
          function gettypename:string;override;
          procedure buildderef;override;
          procedure deref;override;
          function  getparentdef:tdef;override;
          function  size : aint;override;
          function  alignment:longint;override;
          function  vmtmethodoffset(index:longint):longint;
          function  members_need_inittable : boolean;
          { this should be called when this class implements an interface }
          procedure prepareguid;
          function  is_publishable : boolean;override;
          function  needs_inittable : boolean;override;
          function  vmt_mangledname : string;
          function  rtti_name : string;
          procedure check_forwards;
          function  is_related(d : tobjectdef) : boolean;
          function  next_free_name_index : longint;
          procedure insertvmt;
          procedure set_parent(c : tobjectdef);
          function searchdestructor : tprocdef;
          { debug }
{$ifdef GDB}
          function  stabstring : pchar;override;
          procedure set_globalnb;override;
          function  classnumberstring : string;
          procedure concatstabto(asmlist : taasmoutput);override;
          function  allstabstring : pchar;override;
{$endif GDB}
          { rtti }
          procedure write_child_rtti_data(rt:trttitype);override;
          procedure write_rtti_data(rt:trttitype);override;
          function generate_field_table : tasmlabel;
       end;

       timplementedinterfaces = class
          constructor create;
          destructor  destroy; override;

          function  count: longint;
          function  interfaces(intfindex: longint): tobjectdef;
          function  interfacesderef(intfindex: longint): tderef;
          function  ioffsets(intfindex: longint): longint;
          procedure setioffsets(intfindex,iofs:longint);
          function  searchintf(def: tdef): longint;
          procedure addintf(def: tdef);

          procedure buildderef;
          procedure deref;
          { add interface reference loaded from ppu }
          procedure addintf_deref(const d:tderef;iofs:longint);

          procedure clearmappings;
          procedure addmappings(intfindex: longint; const name, newname: string);
          function  getmappings(intfindex: longint; const name: string; var nextexist: pointer): string;

          procedure clearimplprocs;
          procedure addimplproc(intfindex: longint; procdef: tprocdef);
          function  implproccount(intfindex: longint): longint;
          function  implprocs(intfindex: longint; procindex: longint): tprocdef;
          function  isimplmergepossible(intfindex, remainindex: longint; var weight: longint): boolean;

       private
          finterfaces: tindexarray;
          procedure checkindex(intfindex: longint);
       end;


       tclassrefdef = class(tpointerdef)
          constructor create(const t:ttype);
          constructor ppuload(ppufile:tcompilerppufile);
          procedure ppuwrite(ppufile:tcompilerppufile);override;
          function gettypename:string;override;
          { debug }
{$ifdef GDB}
          function stabstring : pchar;override;
{$endif GDB}
       end;

       tarraydef = class(tstoreddef)
          lowrange,
          highrange  : aint;
          rangetype  : ttype;
          IsConvertedPointer,
          IsDynamicArray,
          IsVariant,
          IsConstructor,
          IsArrayOfConst : boolean;
       protected
          _elementtype : ttype;
       public
          function elesize : aint;
          function elecount : aint;
          constructor create_from_pointer(const elemt : ttype);
          constructor create(l,h : aint;const t : ttype);
          constructor ppuload(ppufile:tcompilerppufile);
          function getcopy : tstoreddef;override;
          procedure ppuwrite(ppufile:tcompilerppufile);override;
          function  gettypename:string;override;
          function  getmangledparaname : string;override;
          procedure setelementtype(t: ttype);
{$ifdef GDB}
          function  stabstring : pchar;override;
          procedure concatstabto(asmlist : taasmoutput);override;
{$endif GDB}
          procedure buildderef;override;
          procedure deref;override;
          function size : aint;override;
          function alignment : longint;override;
          { returns the label of the range check string }
          function needs_inittable : boolean;override;
          procedure write_child_rtti_data(rt:trttitype);override;
          procedure write_rtti_data(rt:trttitype);override;
          property elementtype : ttype Read _ElementType;
       end;

       torddef = class(tstoreddef)
          low,high : TConstExprInt;
          typ      : tbasetype;
          constructor create(t : tbasetype;v,b : TConstExprInt);
          constructor ppuload(ppufile:tcompilerppufile);
          function getcopy : tstoreddef;override;
          procedure ppuwrite(ppufile:tcompilerppufile);override;
          function  is_publishable : boolean;override;
          function  gettypename:string;override;
          procedure setsize;
          { debug }
{$ifdef GDB}
          function  stabstring : pchar;override;
{$endif GDB}
          { rtti }
          procedure write_rtti_data(rt:trttitype);override;
       end;

       tfloatdef = class(tstoreddef)
          typ : tfloattype;
          constructor create(t : tfloattype);
          constructor ppuload(ppufile:tcompilerppufile);
          function getcopy : tstoreddef;override;
          procedure ppuwrite(ppufile:tcompilerppufile);override;
          function  gettypename:string;override;
          function  is_publishable : boolean;override;
          procedure setsize;
          { debug }
{$ifdef GDB}
          function stabstring : pchar;override;
          procedure concatstabto(asmlist:taasmoutput);override;
{$endif GDB}
          { rtti }
          procedure write_rtti_data(rt:trttitype);override;
       end;

       tabstractprocdef = class(tstoreddef)
          { saves a definition to the return type }
          rettype         : ttype;
          parast          : tsymtable;
          paras           : tparalist;
          proctypeoption  : tproctypeoption;
          proccalloption  : tproccalloption;
          procoptions     : tprocoptions;
          requiredargarea : aint;
          { number of user visibile parameters }
          maxparacount,
          minparacount    : byte;
{$ifdef i386}
          fpu_used        : longint;    { how many stack fpu must be empty }
{$endif i386}
          funcretloc : array[tcallercallee] of TLocation;
          has_paraloc_info : boolean; { paraloc info is available }
          constructor create(level:byte);
          constructor ppuload(ppufile:tcompilerppufile);
          destructor destroy;override;
          procedure  ppuwrite(ppufile:tcompilerppufile);override;
          procedure buildderef;override;
          procedure deref;override;
          procedure releasemem;
          procedure calcparas;
          function  typename_paras(showhidden:boolean): string;
          procedure test_if_fpu_result;
          function  is_methodpointer:boolean;virtual;
          function  is_addressonly:boolean;virtual;
          { debug }
{$ifdef GDB}
          function  stabstring : pchar;override;
{$endif GDB}
       private
          procedure count_para(p:tnamedindexitem;arg:pointer);
          procedure insert_para(p:tnamedindexitem;arg:pointer);
       end;

       tprocvardef = class(tabstractprocdef)
          constructor create(level:byte);
          constructor ppuload(ppufile:tcompilerppufile);
          function getcopy : tstoreddef;override;
          procedure ppuwrite(ppufile:tcompilerppufile);override;
          procedure buildderef;override;
          procedure deref;override;
          function  getsymtable(t:tgetsymtable):tsymtable;override;
          function  size : aint;override;
          function  gettypename:string;override;
          function  is_publishable : boolean;override;
          function  is_methodpointer:boolean;override;
          function  is_addressonly:boolean;override;
          { debug }
{$ifdef GDB}
          function stabstring : pchar;override;
          procedure concatstabto(asmlist:taasmoutput);override;
{$endif GDB}
          { rtti }
          procedure write_rtti_data(rt:trttitype);override;
       end;

       tmessageinf = record
         case integer of
           0 : (str : pchar);
           1 : (i : longint);
       end;

       tinlininginfo = record
          { node tree }
          code  : tnode;
          flags : tprocinfoflags;
       end;
       pinlininginfo = ^tinlininginfo;


{$ifdef oldregvars}
       { register variables }
       pregvarinfo = ^tregvarinfo;
       tregvarinfo = record
          regvars : array[1..maxvarregs] of tsym;
          regvars_para : array[1..maxvarregs] of boolean;
          regvars_refs : array[1..maxvarregs] of longint;

          fpuregvars : array[1..maxfpuvarregs] of tsym;
          fpuregvars_para : array[1..maxfpuvarregs] of boolean;
          fpuregvars_refs : array[1..maxfpuvarregs] of longint;
       end;
{$endif oldregvars}

       tprocdef = class(tabstractprocdef)
       private
          _mangledname : pstring;
{$ifdef GDB}
          isstabwritten : boolean;
{$endif GDB}
       public
          extnumber      : word;
          messageinf : tmessageinf;
{$ifndef EXTDEBUG}
          { where is this function defined and what were the symbol
            flags, needed here because there
            is only one symbol for all overloaded functions
            EXTDEBUG has fileinfo in tdef (PFV) }
          fileinfo : tfileposinfo;
{$endif}
          symoptions : tsymoptions;
          { symbol owning this definition }
          procsym : tsym;
          procsymderef : tderef;
          { alias names }
          aliasnames : tstringlist;
          { symtables }
          localst : tsymtable;
          funcretsym : tsym;
          funcretsymderef : tderef;
          { browser info }
          lastref,
          defref,
          lastwritten : tref;
          refcount : longint;
          _class : tobjectdef;
          _classderef : tderef;
{$ifdef powerpc}
          { library symbol for AmigaOS/MorphOS }
          libsym : tsym;
          libsymderef : tderef;
{$endif powerpc}
          { name of the result variable to insert in the localsymtable }
          resultname : stringid;
          { true, if the procedure is only declared
            (forward procedure) }
          forwarddef,
          { true if the procedure is declared in the interface }
          interfacedef : boolean;
          { true if the procedure has a forward declaration }
          hasforward : boolean;
          { import info }
          import_dll,
          import_name : pstring;
          import_nr   : word;
          { info for inlining the subroutine, if this pointer is nil,
            the procedure can't be inlined }
          inlininginfo : pinlininginfo;
{$ifdef oldregvars}
          regvarinfo: pregvarinfo;
{$endif oldregvars}
          constructor create(level:byte);
          constructor ppuload(ppufile:tcompilerppufile);
          destructor  destroy;override;
          procedure ppuwrite(ppufile:tcompilerppufile);override;
          procedure buildderef;override;
          procedure buildderefimpl;override;
          procedure deref;override;
          procedure derefimpl;override;
          function  getsymtable(t:tgetsymtable):tsymtable;override;
          function gettypename : string;override;
          function  mangledname : string;
          procedure setmangledname(const s : string);
          procedure load_references(ppufile:tcompilerppufile;locals:boolean);
          function  write_references(ppufile:tcompilerppufile;locals:boolean):boolean;
          { inserts the local symbol table, if this is not
            no local symbol table is built. Should be called only
            when we are sure that a local symbol table will be required.
          }
          procedure insert_localst;
          function  fullprocname(showhidden:boolean):string;
          function  cplusplusmangledname : string;
          function  is_methodpointer:boolean;override;
          function  is_addressonly:boolean;override;
          function  is_visible_for_object(currobjdef:tobjectdef):boolean;
          { debug }
{$ifdef GDB}
          function  numberstring:string;override;
          function  stabstring : pchar;override;
          procedure concatstabto(asmlist : taasmoutput);override;
{$endif GDB}
       end;

       { single linked list of overloaded procs }
       pprocdeflist = ^tprocdeflist;
       tprocdeflist = record
         def  : tprocdef;
         defderef : tderef;
         own  : boolean;
         next : pprocdeflist;
       end;

       tstringdef = class(tstoreddef)
          string_typ : tstringtype;
          len        : aint;
          constructor createshort(l : byte);
          constructor loadshort(ppufile:tcompilerppufile);
          constructor createlong(l : aint);
          constructor loadlong(ppufile:tcompilerppufile);
       {$ifdef ansistring_bits}
          constructor createansi(l:aint;bits:Tstringbits);
          constructor loadansi(ppufile:tcompilerppufile;bits:Tstringbits);
       {$else}
          constructor createansi(l : aint);
          constructor loadansi(ppufile:tcompilerppufile);
       {$endif}
          constructor createwide(l : aint);
          constructor loadwide(ppufile:tcompilerppufile);
          function getcopy : tstoreddef;override;
          function  stringtypname:string;
          procedure ppuwrite(ppufile:tcompilerppufile);override;
          function  gettypename:string;override;
          function  getmangledparaname:string;override;
          function  is_publishable : boolean;override;
          { debug }
{$ifdef GDB}
          function  stabstring : pchar;override;
          procedure concatstabto(asmlist : taasmoutput);override;
{$endif GDB}
          function alignment : longint;override;
          { init/final }
          function  needs_inittable : boolean;override;
          { rtti }
          procedure write_rtti_data(rt:trttitype);override;
       end;

       tenumdef = class(tstoreddef)
          minval,
          maxval    : aint;
          has_jumps : boolean;
          firstenum : tsym;  {tenumsym}
          basedef   : tenumdef;
          basedefderef : tderef;
          constructor create;
          constructor create_subrange(_basedef:tenumdef;_min,_max:aint);
          constructor ppuload(ppufile:tcompilerppufile);
          destructor destroy;override;
          function getcopy : tstoreddef;override;
          procedure ppuwrite(ppufile:tcompilerppufile);override;
          procedure buildderef;override;
          procedure deref;override;
          function  gettypename:string;override;
          function  is_publishable : boolean;override;
          procedure calcsavesize;
          procedure setmax(_max:aint);
          procedure setmin(_min:aint);
          function  min:aint;
          function  max:aint;
          { debug }
{$ifdef GDB}
          function stabstring : pchar;override;
{$endif GDB}
          { rtti }
          procedure write_rtti_data(rt:trttitype);override;
          procedure write_child_rtti_data(rt:trttitype);override;
       private
          procedure correct_owner_symtable;
       end;

       tsetdef = class(tstoreddef)
          elementtype : ttype;
          settype : tsettype;
          constructor create(const t:ttype;high : longint);
          constructor ppuload(ppufile:tcompilerppufile);
          destructor  destroy;override;
          function getcopy : tstoreddef;override;
          procedure ppuwrite(ppufile:tcompilerppufile);override;
          procedure buildderef;override;
          procedure deref;override;
          function  gettypename:string;override;
          function  is_publishable : boolean;override;
          { debug }
{$ifdef GDB}
          function  stabstring : pchar;override;
          procedure concatstabto(asmlist : taasmoutput);override;
{$endif GDB}
          { rtti }
          procedure write_rtti_data(rt:trttitype);override;
          procedure write_child_rtti_data(rt:trttitype);override;
       end;

       Tdefmatch=(dm_exact,dm_equal,dm_convertl1);

    var
       aktobjectdef : tobjectdef;  { used for private functions check !! }
{$ifdef GDB}
       writing_def_stabs : boolean;
       { for STAB debugging }
       globaltypecount  : word;
       pglobaltypecount : pword;
{$endif GDB}

    { default types }
       generrortype,              { error in definition }
       voidpointertype,           { pointer for Void-Pointerdef }
       charpointertype,           { pointer for Char-Pointerdef }
       widecharpointertype,       { pointer for WideChar-Pointerdef }
       voidfarpointertype,
       cformaltype,               { unique formal definition }
       voidtype,                  { Void (procedure) }
       cchartype,                 { Char }
       cwidechartype,             { WideChar }
       booltype,                  { boolean type }
       u8inttype,                 { 8-Bit unsigned integer }
       s8inttype,                 { 8-Bit signed integer }
       u16inttype,                { 16-Bit unsigned integer }
       s16inttype,                { 16-Bit signed integer }
       u32inttype,                { 32-Bit unsigned integer }
       s32inttype,                { 32-Bit signed integer }
       u64inttype,                { 64-bit unsigned integer }
       s64inttype,                { 64-bit signed integer }
       s32floattype,              { pointer for realconstn }
       s64floattype,              { pointer for realconstn }
       s80floattype,              { pointer to type of temp. floats }
       s64currencytype,           { pointer to a currency type }
       cshortstringtype,          { pointer to type of short string const   }
       clongstringtype,           { pointer to type of long string const   }
{$ifdef ansistring_bits}
       cansistringtype16,         { pointer to type of ansi string const  }
       cansistringtype32,         { pointer to type of ansi string const  }
       cansistringtype64,         { pointer to type of ansi string const  }
{$else}
       cansistringtype,           { pointer to type of ansi string const  }
{$endif}
       cwidestringtype,           { pointer to type of wide string const  }
       openshortstringtype,       { pointer to type of an open shortstring,
                                    needed for readln() }
       openchararraytype,         { pointer to type of an open array of char,
                                    needed for readln() }
       cfiletype,                 { get the same definition for all file }
                                  { used for stabs }
       methodpointertype,         { typecasting of methodpointers to extract self }
       { we use only one variant def for every variant class }
       cvarianttype,
       colevarianttype,
       { default integer type s32inttype on 32 bit systems, s64bittype on 64 bit systems }
       sinttype,
       uinttype,
       { unsigned ord type with the same size as a pointer }
       ptrinttype,
       { several types to simulate more or less C++ objects for GDB }
       vmttype,
       vmtarraytype,
       pvmttype      : ttype;     { type of classrefs, used for stabs }

       { pointer to the anchestor of all classes }
       class_tobject : tobjectdef;
       { pointer to the ancestor of all COM interfaces }
       interface_iunknown : tobjectdef;
       { pointer to the TGUID type
         of all interfaces         }
       rec_tguid : trecorddef;

    const
{$ifdef i386}
       pbestrealtype : ^ttype = @s80floattype;
{$endif}
{$ifdef x86_64}
       pbestrealtype : ^ttype = @s80floattype;
{$endif}
{$ifdef m68k}
       pbestrealtype : ^ttype = @s64floattype;
{$endif}
{$ifdef alpha}
       pbestrealtype : ^ttype = @s64floattype;
{$endif}
{$ifdef powerpc}
       pbestrealtype : ^ttype = @s64floattype;
{$endif}
{$ifdef ia64}
       pbestrealtype : ^ttype = @s64floattype;
{$endif}
{$ifdef SPARC}
       pbestrealtype : ^ttype = @s64floattype;
{$endif SPARC}
{$ifdef vis}
       pbestrealtype : ^ttype = @s64floattype;
{$endif vis}
{$ifdef ARM}
       pbestrealtype : ^ttype = @s64floattype;
{$endif ARM}

    function make_mangledname(const typeprefix:string;st:tsymtable;const suffix:string):string;

    { should be in the types unit, but the types unit uses the node stuff :( }
    function is_interfacecom(def: tdef): boolean;
    function is_interfacecorba(def: tdef): boolean;
    function is_interface(def: tdef): boolean;
    function is_object(def: tdef): boolean;
    function is_class(def: tdef): boolean;
    function is_cppclass(def: tdef): boolean;
    function is_class_or_interface(def: tdef): boolean;


implementation

    uses
       strings,
       { global }
       verbose,
       { target }
       systems,aasmcpu,paramgr,
       { symtable }
       symsym,symtable,symutil,defutil,
       { module }
{$ifdef GDB}
       gdb,
{$endif GDB}
       fmodule,
       { other }
       gendef,
       crc
       ;


{****************************************************************************
                                  Helpers
****************************************************************************}

    function make_mangledname(const typeprefix:string;st:tsymtable;const suffix:string):string;
      var
        s,hs,
        prefix : string;
        oldlen,
        newlen,
        i   : longint;
        crc : dword;
        hp  : tparavarsym;
      begin
        prefix:='';
        if not assigned(st) then
         internalerror(200204212);
        { sub procedures }
        while (st.symtabletype=localsymtable) do
         begin
           if st.defowner.deftype<>procdef then
            internalerror(200204173);
           { Add the full mangledname of procedure to prevent
             conflicts with 2 overloads having both a nested procedure
             with the same name, see tb0314 (PFV) }
           s:=tprocdef(st.defowner).procsym.name;
           oldlen:=length(s);
           for i:=0 to tprocdef(st.defowner).paras.count-1 do
            begin
              hp:=tparavarsym(tprocdef(st.defowner).paras[i]);
              if not(vo_is_hidden_para in hp.varoptions) then
                s:=s+'$'+hp.vartype.def.mangledparaname;
            end;
           if not is_void(tprocdef(st.defowner).rettype.def) then
             s:=s+'$$'+tprocdef(st.defowner).rettype.def.mangledparaname;
           newlen:=length(s);
           { Replace with CRC if the parameter line is very long }
           if (newlen-oldlen>12) and
              ((newlen>128) or (newlen-oldlen>64)) then
             begin
               crc:=$ffffffff;
               for i:=0 to tprocdef(st.defowner).paras.count-1 do
                 begin
                   hp:=tparavarsym(tprocdef(st.defowner).paras[i]);
                   if not(vo_is_hidden_para in hp.varoptions) then
                     begin
                       hs:=hp.vartype.def.mangledparaname;
                       crc:=UpdateCrc32(crc,hs[1],length(hs));
                     end;
                 end;
               hs:=hp.vartype.def.mangledparaname;
               crc:=UpdateCrc32(crc,hs[1],length(hs));
               s:=Copy(s,1,oldlen)+'$crc'+hexstr(crc,8);
             end;
           if prefix<>'' then
             prefix:=s+'_'+prefix
           else
             prefix:=s;
           st:=st.defowner.owner;
         end;
        { object/classes symtable }
        if (st.symtabletype=objectsymtable) then
         begin
           if st.defowner.deftype<>objectdef then
            internalerror(200204174);
           prefix:=tobjectdef(st.defowner).objname^+'_$_'+prefix;
           st:=st.defowner.owner;
         end;
        { symtable must now be static or global }
        if not(st.symtabletype in [staticsymtable,globalsymtable]) then
         internalerror(200204175);
        result:='';
        if typeprefix<>'' then
          result:=result+typeprefix+'_';
        { Add P$ for program, which can have the same name as
          a unit }
        if (tsymtable(main_module.localsymtable)=st) and
           (not main_module.is_unit) then
          result:=result+'P$'+st.name^
        else
          result:=result+st.name^;
        if prefix<>'' then
          result:=result+'_'+prefix;
        if suffix<>'' then
          result:=result+'_'+suffix;
        { the Darwin assembler assumes that all symbols starting with 'L' are local }
        if (target_info.system = system_powerpc_darwin) and
           (result[1] = 'L') then
          result := '_' + result;
      end;


{****************************************************************************
                     TDEF (base class for definitions)
****************************************************************************}

    constructor tstoreddef.create;
      begin
         inherited create;
         savesize := 0;
{$ifdef EXTDEBUG}
         fileinfo := aktfilepos;
{$endif}
         if registerdef then
           symtablestack.registerdef(self);
{$ifdef GDB}
         stab_state:=stab_state_unused;
         globalnb := 0;
{$endif GDB}
         fillchar(localrttilab,sizeof(localrttilab),0);
      end;


    constructor tstoreddef.ppuloaddef(ppufile:tcompilerppufile);
      begin
         inherited create;
{$ifdef EXTDEBUG}
         fillchar(fileinfo,sizeof(fileinfo),0);
{$endif}
{$ifdef GDB}
         stab_state:=stab_state_unused;
         globalnb := 0;
{$endif GDB}
         fillchar(localrttilab,sizeof(localrttilab),0);
      { load }
         indexnr:=ppufile.getword;
         ppufile.getderef(typesymderef);
         ppufile.getsmallset(defoptions);
         if df_has_rttitable in defoptions then
          ppufile.getderef(rttitablesymderef);
         if df_has_inittable in defoptions then
          ppufile.getderef(inittablesymderef);
      end;


    procedure Tstoreddef.reset;
      begin
{$ifdef GDB}
        stab_state:=stab_state_unused;
{$endif GDB}
        if assigned(rttitablesym) then
          trttisym(rttitablesym).lab := nil;
        if assigned(inittablesym) then
          trttisym(inittablesym).lab := nil;
        localrttilab[initrtti]:=nil;
        localrttilab[fullrtti]:=nil;
      end;


    function tstoreddef.getcopy : tstoreddef;
      begin
        Message(sym_e_cant_create_unique_type);
        getcopy:=terrordef.create;
      end;


    procedure tstoreddef.ppuwritedef(ppufile:tcompilerppufile);
      begin
        ppufile.putword(indexnr);
        ppufile.putderef(typesymderef);
        ppufile.putsmallset(defoptions);
        if df_has_rttitable in defoptions then
         ppufile.putderef(rttitablesymderef);
        if df_has_inittable in defoptions then
         ppufile.putderef(inittablesymderef);
{$ifdef GDB}
        if globalnb=0 then
          begin
            if (cs_gdb_dbx in aktglobalswitches) and
               assigned(owner) then
              globalnb := owner.getnewtypecount
            else
              set_globalnb;
          end;
{$endif GDB}
      end;


    procedure tstoreddef.buildderef;
      begin
        typesymderef.build(typesym);
        rttitablesymderef.build(rttitablesym);
        inittablesymderef.build(inittablesym);
      end;


    procedure tstoreddef.buildderefimpl;
      begin
      end;


    procedure tstoreddef.deref;
      begin
        typesym:=ttypesym(typesymderef.resolve);
        if df_has_rttitable in defoptions then
          rttitablesym:=trttisym(rttitablesymderef.resolve);
        if df_has_inittable in defoptions then
          inittablesym:=trttisym(inittablesymderef.resolve);
      end;


    procedure tstoreddef.derefimpl;
      begin
      end;


    function tstoreddef.size : aint;
      begin
         size:=savesize;
      end;


    function tstoreddef.alignment : longint;
      begin
         { natural alignment by default }
         alignment:=size_2_align(savesize);
      end;


{$ifdef GDB}
    procedure tstoreddef.set_globalnb;
      begin
        globalnb:=PGlobalTypeCount^;
        inc(PglobalTypeCount^);
      end;


    function Tstoreddef.get_var_value(const s:string):string;
      begin
        if s='numberstring' then
          get_var_value:=numberstring
        else if s='sym_name' then
          if assigned(typesym) then
             get_var_value:=Ttypesym(typesym).name
          else
             get_var_value:=' '
        else if s='N_LSYM' then
          get_var_value:=tostr(N_LSYM)
        else if s='savesize' then
          get_var_value:=tostr(savesize);
      end;


    function Tstoreddef.stabstr_evaluate(const s:string;const vars:array of string):Pchar;
      begin
        stabstr_evaluate:=string_evaluate(s,@get_var_value,vars);
      end;


    function tstoreddef.stabstring : pchar;
      begin
        stabstring:=stabstr_evaluate('t${numberstring};',[]);
      end;


    function tstoreddef.numberstring : string;
      begin
        { Stab must already be written, or we must be busy writing it }
        if writing_def_stabs and
           not(stab_state in [stab_state_writing,stab_state_written]) then
          internalerror(200403091);
        { Keep track of used stabs, this info is only usefull for stabs
          referenced by the symbols. Definitions will always include all
          required stabs }
        if stab_state=stab_state_unused then
          stab_state:=stab_state_used;
        { Need a new number? }
        if globalnb=0 then
          begin
            if (cs_gdb_dbx in aktglobalswitches) and
               assigned(owner) then
              globalnb := owner.getnewtypecount
            else
              set_globalnb;
          end;
        if (cs_gdb_dbx in aktglobalswitches) and
           assigned(typesym) and
           (ttypesym(typesym).owner.unitid<>0) then
          result:='('+tostr(ttypesym(typesym).owner.unitid)+','+tostr(tstoreddef(ttypesym(typesym).restype.def).globalnb)+')'
        else
          result:=tostr(globalnb);
      end;


    function tstoreddef.allstabstring : pchar;
      var
        stabchar : string[2];
        ss,st,su : pchar;
      begin
        ss := stabstring;
        stabchar := 't';
        if deftype in tagtypes then
          stabchar := 'Tt';
        { Here we maybe generate a type, so we have to use numberstring }
        st:=stabstr_evaluate('"${sym_name}:$1$2=',[stabchar,numberstring]);
        reallocmem(st,strlen(ss)+512);
        { line info is set to 0 for all defs, because the def can be in an other
          unit and then the linenumber is invalid in the current sourcefile }
        su:=stabstr_evaluate('",${N_LSYM},0,0,0',[]);
        strcopy(strecopy(strend(st),ss),su);
        reallocmem(st,strlen(st)+1);
        allstabstring:=st;
        strdispose(ss);
        strdispose(su);
      end;


    procedure tstoreddef.concatstabto(asmlist : taasmoutput);
      var
        stab_str : pchar;
      begin
        if (stab_state in [stab_state_writing,stab_state_written]) then
          exit;
        If cs_gdb_dbx in aktglobalswitches then
          begin
            { otherwise you get two of each def }
            If assigned(typesym) then
              begin
                if (ttypesym(typesym).owner = nil) or
                   ((ttypesym(typesym).owner.symtabletype = globalsymtable) and
                    tglobalsymtable(ttypesym(typesym).owner).dbx_count_ok)  then
                  begin
                    {with DBX we get the definition from the other objects }
                    stab_state := stab_state_written;
                    exit;
                  end;
              end;
          end;
        { to avoid infinite loops }
        stab_state := stab_state_writing;
        stab_str := allstabstring;
        asmList.concat(Tai_stabs.Create(stab_str));
        stab_state := stab_state_written;
      end;
{$endif GDB}


    procedure tstoreddef.write_rtti_name;
      var
         str : string;
      begin
         { name }
         if assigned(typesym) then
           begin
              str:=ttypesym(typesym).realname;
              rttiList.concat(Tai_string.Create(chr(length(str))+str));
           end
         else
           rttiList.concat(Tai_string.Create(#0))
      end;


    procedure tstoreddef.write_rtti_data(rt:trttitype);
      begin
        rttilist.concat(tai_const.create_8bit(tkUnknown));
        write_rtti_name;
      end;


    procedure tstoreddef.write_child_rtti_data(rt:trttitype);
      begin
      end;


    function tstoreddef.get_rtti_label(rt:trttitype) : tasmsymbol;
      begin
         { try to reuse persistent rtti data }
         if (rt=fullrtti) and (df_has_rttitable in defoptions) then
          get_rtti_label:=trttisym(rttitablesym).get_label
         else
          if (rt=initrtti) and (df_has_inittable in defoptions) then
           get_rtti_label:=trttisym(inittablesym).get_label
         else
          begin
            if not assigned(localrttilab[rt]) then
             begin
               objectlibrary.getdatalabel(localrttilab[rt]);
               write_child_rtti_data(rt);
               maybe_new_object_file(rttiList);
               new_section(rttiList,sec_rodata,localrttilab[rt].name,const_align(sizeof(aint)));
               rttiList.concat(Tai_symbol.Create_global(localrttilab[rt],0));
               write_rtti_data(rt);
               rttiList.concat(Tai_symbol_end.Create(localrttilab[rt]));
             end;
            get_rtti_label:=localrttilab[rt];
          end;
      end;


    { returns true, if the definition can be published }
    function tstoreddef.is_publishable : boolean;
      begin
         is_publishable:=false;
      end;


    { needs an init table }
    function tstoreddef.needs_inittable : boolean;
      begin
         needs_inittable:=false;
      end;


   function tstoreddef.is_intregable : boolean;
     begin
        is_intregable:=false;
        case deftype of
          orddef,
          pointerdef,
          enumdef:
            is_intregable:=true;
          procvardef :
            is_intregable:=not(po_methodpointer in tprocvardef(self).procoptions);
          objectdef:
            is_intregable:=is_class(self) or is_interface(self);
          setdef:
            is_intregable:=(tsetdef(self).settype=smallset);
        end;
     end;


   function tstoreddef.is_fpuregable : boolean;
     begin
{$ifdef x86}
       result:=false;
{$else x86}
       result:=(deftype=floatdef);
{$endif x86}
     end;



{****************************************************************************
                               Tstringdef
****************************************************************************}

    constructor tstringdef.createshort(l : byte);
      begin
         inherited create;
         string_typ:=st_shortstring;
         deftype:=stringdef;
         len:=l;
         savesize:=len+1;
      end;


    constructor tstringdef.loadshort(ppufile:tcompilerppufile);
      begin
         inherited ppuloaddef(ppufile);
         string_typ:=st_shortstring;
         deftype:=stringdef;
         len:=ppufile.getbyte;
         savesize:=len+1;
      end;


    constructor tstringdef.createlong(l : aint);
      begin
         inherited create;
         string_typ:=st_longstring;
         deftype:=stringdef;
         len:=l;
         savesize:=sizeof(aint);
      end;


    constructor tstringdef.loadlong(ppufile:tcompilerppufile);
      begin
         inherited ppuloaddef(ppufile);
         deftype:=stringdef;
         string_typ:=st_longstring;
         len:=ppufile.getaint;
         savesize:=sizeof(aint);
      end;

{$ifdef ansistring_bits}
    constructor tstringdef.createansi(l:aint;bits:Tstringbits);
      begin
         inherited create;
         case bits of
           sb_16:
             string_typ:=st_ansistring16;
           sb_32:
             string_typ:=st_ansistring32;
           sb_64:
             string_typ:=st_ansistring64;
         end;
         deftype:=stringdef;
         len:=l;
         savesize:=POINTER_SIZE;
      end;


    constructor tstringdef.loadansi(ppufile:tcompilerppufile;bits:Tstringbits);
      begin
         inherited ppuloaddef(ppufile);
         deftype:=stringdef;
         case bits of
           sb_16:
             string_typ:=st_ansistring16;
           sb_32:
             string_typ:=st_ansistring32;
           sb_64:
             string_typ:=st_ansistring64;
         end;
         len:=ppufile.getaint;
         savesize:=POINTER_SIZE;
      end;
{$else}
    constructor tstringdef.createansi(l:aint);
      begin
         inherited create;
         string_typ:=st_ansistring;
         deftype:=stringdef;
         len:=l;
         savesize:=sizeof(aint);
      end;


    constructor tstringdef.loadansi(ppufile:tcompilerppufile);

      begin
         inherited ppuloaddef(ppufile);
         deftype:=stringdef;
         string_typ:=st_ansistring;
         len:=ppufile.getaint;
         savesize:=sizeof(aint);
      end;
{$endif}

    constructor tstringdef.createwide(l : aint);
      begin
         inherited create;
         string_typ:=st_widestring;
         deftype:=stringdef;
         len:=l;
         savesize:=sizeof(aint);
      end;


    constructor tstringdef.loadwide(ppufile:tcompilerppufile);
      begin
         inherited ppuloaddef(ppufile);
         deftype:=stringdef;
         string_typ:=st_widestring;
         len:=ppufile.getaint;
         savesize:=sizeof(aint);
      end;


    function tstringdef.getcopy : tstoreddef;
      begin
        result:=tstringdef.create;
        result.deftype:=stringdef;
        tstringdef(result).string_typ:=string_typ;
        tstringdef(result).len:=len;
        tstringdef(result).savesize:=savesize;
      end;


    function tstringdef.stringtypname:string;
{$ifdef ansistring_bits}
      const
        typname:array[tstringtype] of string[9]=('',
          'shortstr','longstr','ansistr16','ansistr32','ansistr64','widestr'
        );
{$else}
      const
        typname:array[tstringtype] of string[8]=('',
          'shortstr','longstr','ansistr','widestr'
        );
{$endif}
      begin
        stringtypname:=typname[string_typ];
      end;


    procedure tstringdef.ppuwrite(ppufile:tcompilerppufile);
      begin
         inherited ppuwritedef(ppufile);
         if string_typ=st_shortstring then
           begin
{$ifdef extdebug}
            if len > 255 then internalerror(12122002);
{$endif}
            ppufile.putbyte(byte(len))
           end
         else
           ppufile.putaint(len);
         case string_typ of
            st_shortstring : ppufile.writeentry(ibshortstringdef);
            st_longstring : ppufile.writeentry(iblongstringdef);
         {$ifdef ansistring_bits}
            st_ansistring16 : ppufile.writeentry(ibansistring16def);
            st_ansistring32 : ppufile.writeentry(ibansistring32def);
            st_ansistring64 : ppufile.writeentry(ibansistring64def);
         {$else}
            st_ansistring : ppufile.writeentry(ibansistringdef);
         {$endif}
            st_widestring : ppufile.writeentry(ibwidestringdef);
         end;
      end;


{$ifdef GDB}
    function tstringdef.stabstring : pchar;
      var
        bytest,charst,longst : string;
        slen : aint;
      begin
        case string_typ of
           st_shortstring:
             begin
               charst:=tstoreddef(cchartype.def).numberstring;
               { this is what I found in stabs.texinfo but
                 gdb 4.12 for go32 doesn't understand that !! }
             {$IfDef GDBknowsstrings}
                stabstring:=stabstr_evaluate('n$1;$2',[charst,tostr(len)]);
             {$else}
               { fix length of openshortstring }
               slen:=len;
               if slen=0 then
                 slen:=255;
               bytest:=tstoreddef(u8inttype.def).numberstring;
               stabstring:=stabstr_evaluate('s$1length:$2,0,8;st:ar$2;1;$3;$4,8,$5;;',
                           [tostr(slen+1),bytest,tostr(slen),charst,tostr(slen*8)]);
             {$EndIf}
             end;
           st_longstring:
             begin
               charst:=tstoreddef(cchartype.def).numberstring;
               { this is what I found in stabs.texinfo but
                 gdb 4.12 for go32 doesn't understand that !! }
             {$IfDef GDBknowsstrings}
               stabstring:=stabstr_evaluate('n$1;$2',[charst,tostr(len)]);
             {$else}
               bytest:=tstoreddef(u8inttype.def).numberstring;
               longst:=tstoreddef(u32inttype.def).numberstring;
               stabstring:=stabstr_evaluate('s$1length:$2,0,32;dummy:$6,32,8;st:ar$2;1;$3;$4,40,$5;;',
                            [tostr(len+5),longst,tostr(len),charst,tostr(len*8),bytest]);
              {$EndIf}
             end;
         {$ifdef ansistring_bits}
           st_ansistring16,st_ansistring32,st_ansistring64:
         {$else}
           st_ansistring:
         {$endif}
             begin
               { an ansi string looks like a pchar easy !! }
               charst:=tstoreddef(cchartype.def).numberstring;
               stabstring:=strpnew('*'+charst);
             end;
           st_widestring:
             begin
               { an ansi string looks like a pwidechar easy !! }
               charst:=tstoreddef(cwidechartype.def).numberstring;
               stabstring:=strpnew('*'+charst);
             end;
        end;
      end;


    procedure tstringdef.concatstabto(asmlist:taasmoutput);
      begin
        if (stab_state in [stab_state_writing,stab_state_written]) then
          exit;
        case string_typ of
           st_shortstring:
             begin
               tstoreddef(cchartype.def).concatstabto(asmlist);
             {$IfNDef GDBknowsstrings}
               tstoreddef(u8inttype.def).concatstabto(asmlist);
             {$EndIf}
             end;
           st_longstring:
             begin
               tstoreddef(cchartype.def).concatstabto(asmlist);
             {$IfNDef GDBknowsstrings}
               tstoreddef(u8inttype.def).concatstabto(asmlist);
               tstoreddef(u32inttype.def).concatstabto(asmlist);
             {$EndIf}
             end;
         {$ifdef ansistring_bits}
           st_ansistring16,st_ansistring32,st_ansistring64:
         {$else}
           st_ansistring:
         {$endif}
             tstoreddef(cchartype.def).concatstabto(asmlist);
           st_widestring:
             tstoreddef(cwidechartype.def).concatstabto(asmlist);
        end;
        inherited concatstabto(asmlist);
      end;
{$endif GDB}


    function tstringdef.needs_inittable : boolean;
      begin
      {$ifdef ansistring_bits}
         needs_inittable:=string_typ in [st_ansistring16,st_ansistring32,st_ansistring64,st_widestring];
      {$else}
         needs_inittable:=string_typ in [st_ansistring,st_widestring];
      {$endif}
      end;


    function tstringdef.gettypename : string;
{$ifdef ansistring_bits}
      const
         names : array[tstringtype] of string[20] = ('',
           'shortstring','longstring','ansistring16','ansistring32','ansistring64','widestring');
{$else}
      const
         names : array[tstringtype] of string[20] = ('',
           'ShortString','LongString','AnsiString','WideString');
{$endif}
      begin
         gettypename:=names[string_typ];
      end;


    function tstringdef.alignment : longint;
      begin
        case string_typ of
          st_widestring,
          st_ansistring:
            alignment:=size_2_align(savesize);
          st_longstring,
          st_shortstring:
            alignment:=size_2_align(1);
          else
            internalerror(200412301);
        end;
      end;


    procedure tstringdef.write_rtti_data(rt:trttitype);
      begin
         case string_typ of
          {$ifdef ansistring_bits}
            st_ansistring16:
              begin
                 rttiList.concat(Tai_const.Create_8bit(tkA16String));
                 write_rtti_name;
              end;
            st_ansistring32:
              begin
                 rttiList.concat(Tai_const.Create_8bit(tkA32String));
                 write_rtti_name;
              end;
            st_ansistring64:
              begin
                 rttiList.concat(Tai_const.Create_8bit(tkA64String));
                 write_rtti_name;
              end;
          {$else}
            st_ansistring:
              begin
                 rttiList.concat(Tai_const.Create_8bit(tkAString));
                 write_rtti_name;
              end;
          {$endif}
            st_widestring:
              begin
                 rttiList.concat(Tai_const.Create_8bit(tkWString));
                 write_rtti_name;
              end;
            st_longstring:
              begin
                 rttiList.concat(Tai_const.Create_8bit(tkLString));
                 write_rtti_name;
              end;
            st_shortstring:
              begin
                 rttiList.concat(Tai_const.Create_8bit(tkSString));
                 write_rtti_name;
                 rttiList.concat(Tai_const.Create_8bit(len));
{$ifdef cpurequiresproperalignment}
                 rttilist.concat(Tai_align.Create(sizeof(TConstPtrUInt)));
{$endif cpurequiresproperalignment}
              end;
         end;
      end;


    function tstringdef.getmangledparaname : string;
      begin
        getmangledparaname:='STRING';
      end;


    function tstringdef.is_publishable : boolean;
      begin
         is_publishable:=true;
      end;


{****************************************************************************
                                 TENUMDEF
****************************************************************************}

    constructor tenumdef.create;
      begin
         inherited create;
         deftype:=enumdef;
         minval:=0;
         maxval:=0;
         calcsavesize;
         has_jumps:=false;
         basedef:=nil;
         firstenum:=nil;
         correct_owner_symtable;
      end;


    constructor tenumdef.create_subrange(_basedef:tenumdef;_min,_max:aint);
      begin
         inherited create;
         deftype:=enumdef;
         minval:=_min;
         maxval:=_max;
         basedef:=_basedef;
         calcsavesize;
         has_jumps:=false;
         firstenum:=basedef.firstenum;
         while assigned(firstenum) and (tenumsym(firstenum).value<>minval) do
           firstenum:=tenumsym(firstenum).nextenum;
         correct_owner_symtable;
      end;


    constructor tenumdef.ppuload(ppufile:tcompilerppufile);
      begin
         inherited ppuloaddef(ppufile);
         deftype:=enumdef;
         ppufile.getderef(basedefderef);
         minval:=ppufile.getaint;
         maxval:=ppufile.getaint;
         savesize:=ppufile.getaint;
         has_jumps:=false;
         firstenum:=Nil;
      end;


    function tenumdef.getcopy : tstoreddef;
      begin
        if assigned(basedef) then
          result:=tenumdef.create_subrange(basedef,minval,maxval)
        else
          begin
            result:=tenumdef.create;
            tenumdef(result).minval:=minval;
            tenumdef(result).maxval:=maxval;
          end;
        tenumdef(result).has_jumps:=has_jumps;
        tenumdef(result).firstenum:=firstenum;
        tenumdef(result).basedefderef:=basedefderef;
      end;


    procedure tenumdef.calcsavesize;
      begin
        if (aktpackenum=8) or (min<low(longint)) or (int64(max)>high(cardinal)) then
         savesize:=8
        else
         if (aktpackenum=4) or (min<low(smallint)) or (max>high(word)) then
          savesize:=4
        else
         if (aktpackenum=2) or (min<low(shortint)) or (max>high(byte)) then
          savesize:=2
        else
         savesize:=1;
      end;


    procedure tenumdef.setmax(_max:aint);
      begin
        maxval:=_max;
        calcsavesize;
      end;


    procedure tenumdef.setmin(_min:aint);
      begin
        minval:=_min;
        calcsavesize;
      end;


    function tenumdef.min:aint;
      begin
        min:=minval;
      end;


    function tenumdef.max:aint;
      begin
        max:=maxval;
      end;


    procedure tenumdef.buildderef;
      begin
        inherited buildderef;
        basedefderef.build(basedef);
      end;


    procedure tenumdef.deref;
      begin
        inherited deref;
        basedef:=tenumdef(basedefderef.resolve);
        { restart ordering }
        firstenum:=nil;
      end;


    destructor tenumdef.destroy;
      begin
        inherited destroy;
      end;


    procedure tenumdef.ppuwrite(ppufile:tcompilerppufile);
      begin
         inherited ppuwritedef(ppufile);
         ppufile.putderef(basedefderef);
         ppufile.putaint(min);
         ppufile.putaint(max);
         ppufile.putaint(savesize);
         ppufile.writeentry(ibenumdef);
      end;


    { used for enumdef because the symbols are
      inserted in the owner symtable }
    procedure tenumdef.correct_owner_symtable;
      var
         st : tsymtable;
      begin
         if assigned(owner) and
            (owner.symtabletype in [recordsymtable,objectsymtable]) then
           begin
              owner.defindex.deleteindex(self);
              st:=owner;
              while (st.symtabletype in [recordsymtable,objectsymtable]) do
                st:=st.next;
              st.registerdef(self);
           end;
      end;



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

    var st:Pchar;
        p:Tenumsym;
        s:string;
        memsize,stl:cardinal;

    begin
      memsize:=memsizeinc;
      getmem(st,memsize);
      { we can specify the size with @s<size>; prefix PM }
      if savesize <> std_param_align then
        strpcopy(st,'@s'+tostr(savesize*8)+';e')
      else
        strpcopy(st,'e');
      p := tenumsym(firstenum);
      stl:=strlen(st);
      while assigned(p) do
        begin
          s :=p.name+':'+tostr(p.value)+',';
          { place for the ending ';' also }
          if (stl+length(s)+1>=memsize) then
            begin
              inc(memsize,memsizeinc);
              reallocmem(st,memsize);
            end;
          strpcopy(st+stl,s);
          inc(stl,length(s));
          p:=p.nextenum;
        end;
      st[stl]:=';';
      st[stl+1]:=#0;
      reallocmem(st,stl+2);
      stabstring:=st;
    end;
{$endif GDB}


    procedure tenumdef.write_child_rtti_data(rt:trttitype);
      begin
         if assigned(basedef) then
           basedef.get_rtti_label(rt);
      end;


    procedure tenumdef.write_rtti_data(rt:trttitype);
      var
         hp : tenumsym;
      begin
         rttiList.concat(Tai_const.Create_8bit(tkEnumeration));
         write_rtti_name;
{$ifdef cpurequiresproperalignment}
         rttilist.concat(Tai_align.Create(sizeof(TConstPtrUInt)));
{$endif cpurequiresproperalignment}
         case longint(savesize) of
            1:
              rttiList.concat(Tai_const.Create_8bit(otUByte));
            2:
              rttiList.concat(Tai_const.Create_8bit(otUWord));
            4:
              rttiList.concat(Tai_const.Create_8bit(otULong));
         end;
{$ifdef cpurequiresproperalignment}
         rttilist.concat(Tai_align.Create(4));
{$endif cpurequiresproperalignment}
         rttiList.concat(Tai_const.Create_32bit(min));
         rttiList.concat(Tai_const.Create_32bit(max));
         if assigned(basedef) then
           rttiList.concat(Tai_const.Create_sym(basedef.get_rtti_label(rt)))
         else
           rttiList.concat(Tai_const.create_sym(nil));
         hp:=tenumsym(firstenum);
         while assigned(hp) do
           begin
              rttiList.concat(Tai_const.Create_8bit(length(hp.realname)));
              rttiList.concat(Tai_string.Create(hp.realname));
              hp:=hp.nextenum;
           end;
         rttiList.concat(Tai_const.Create_8bit(0));
      end;


    function tenumdef.is_publishable : boolean;
      begin
         is_publishable:=true;
      end;

    function tenumdef.gettypename : string;

      begin
         gettypename:='<enumeration type>';
      end;

{****************************************************************************
                                 TORDDEF
****************************************************************************}

    constructor torddef.create(t : tbasetype;v,b : TConstExprInt);
      begin
         inherited create;
         deftype:=orddef;
         low:=v;
         high:=b;
         typ:=t;
         setsize;
      end;


    constructor torddef.ppuload(ppufile:tcompilerppufile);
      begin
         inherited ppuloaddef(ppufile);
         deftype:=orddef;
         typ:=tbasetype(ppufile.getbyte);
         if sizeof(TConstExprInt)=8 then
           begin
             low:=ppufile.getint64;
             high:=ppufile.getint64;
           end
         else
           begin
             low:=ppufile.getlongint;
             high:=ppufile.getlongint;
           end;
         setsize;
      end;


    function torddef.getcopy : tstoreddef;
      begin
         result:=torddef.create(typ,low,high);
         result.deftype:=orddef;
         torddef(result).low:=low;
         torddef(result).high:=high;
         torddef(result).typ:=typ;
         torddef(result).savesize:=savesize;
      end;


    procedure torddef.setsize;
      const
        sizetbl : array[tbasetype] of longint = (
          0,
          1,2,4,8,
          1,2,4,8,
          1,2,4,
          1,2,8
        );
      begin
        savesize:=sizetbl[typ];
      end;


    procedure torddef.ppuwrite(ppufile:tcompilerppufile);
      begin
         inherited ppuwritedef(ppufile);
         ppufile.putbyte(byte(typ));
         if sizeof(TConstExprInt)=8 then
          begin
            ppufile.putint64(low);
            ppufile.putint64(high);
          end
         else
          begin
            ppufile.putlongint(low);
            ppufile.putlongint(high);
          end;
         ppufile.writeentry(iborddef);
      end;


{$ifdef GDB}
    function torddef.stabstring : pchar;
      begin
        if cs_gdb_valgrind in aktglobalswitches then
          begin
            case typ of
              uvoid :
                stabstring := strpnew(numberstring);
              bool8bit,
              bool16bit,
              bool32bit :
                stabstring := stabstr_evaluate('r${numberstring};0;255;',[]);
              u32bit,
              s64bit,
              u64bit :
                stabstring:=stabstr_evaluate('r${numberstring};0;-1;',[]);
              else
                stabstring:=stabstr_evaluate('r${numberstring};$1;$2;',[tostr(longint(low)),tostr(longint(high))]);
            end;
          end
        else
          begin
            case typ of
              uvoid :
                stabstring := strpnew(numberstring);
              uchar :
                stabstring := strpnew('-20;');
              uwidechar :
                stabstring := strpnew('-30;');
              bool8bit :
                stabstring := strpnew('-21;');
              bool16bit :
                stabstring := strpnew('-22;');
              bool32bit :
                stabstring := strpnew('-23;');
              u64bit :
                stabstring := strpnew('-32;');
              s64bit :
                stabstring := strpnew('-31;');
              {u32bit : stabstring := tstoreddef(s32inttype.def).numberstring+';0;-1;'); }
              else
                stabstring:=stabstr_evaluate('r${numberstring};$1;$2;',[tostr(longint(low)),tostr(longint(high))]);
            end;
         end;
      end;
{$endif GDB}


    procedure torddef.write_rtti_data(rt:trttitype);

        procedure dointeger;
        const
          trans : array[tbasetype] of byte =
            (otUByte{otNone},
             otUByte,otUWord,otULong,otUByte{otNone},
             otSByte,otSWord,otSLong,otUByte{otNone},
             otUByte,otUWord,otULong,
             otUByte,otUWord,otUByte);
        begin
          write_rtti_name;
{$ifdef cpurequiresproperalignment}
          rttilist.concat(Tai_align.Create(sizeof(TConstPtrUInt)));
{$endif cpurequiresproperalignment}
          rttiList.concat(Tai_const.Create_8bit(byte(trans[typ])));
{$ifdef cpurequiresproperalignment}
         rttilist.concat(Tai_align.Create(4));
{$endif cpurequiresproperalignment}
          rttiList.concat(Tai_const.Create_32bit(longint(low)));
          rttiList.concat(Tai_const.Create_32bit(longint(high)));
        end;

      begin
        case typ of
          s64bit :
            begin
              rttiList.concat(Tai_const.Create_8bit(tkInt64));
              write_rtti_name;
{$ifdef cpurequiresproperalignment}
              rttilist.concat(Tai_align.Create(sizeof(TConstPtrUInt)));
{$endif cpurequiresproperalignment}
              { low }
              rttiList.concat(Tai_const.Create_64bit(int64($80000000) shl 32));
              { high }
              rttiList.concat(Tai_const.Create_64bit((int64($7fffffff) shl 32) or int64($ffffffff)));
            end;
          u64bit :
            begin
              rttiList.concat(Tai_const.Create_8bit(tkQWord));
              write_rtti_name;
{$ifdef cpurequiresproperalignment}
              rttilist.concat(Tai_align.Create(sizeof(TConstPtrUInt)));
{$endif cpurequiresproperalignment}
              { low }
              rttiList.concat(Tai_const.Create_64bit(0));
              { high }
              rttiList.concat(Tai_const.Create_64bit(int64((int64($ffffffff) shl 32) or int64($ffffffff))));
            end;
          bool8bit:
            begin
              rttiList.concat(Tai_const.Create_8bit(tkBool));
              dointeger;
            end;
          uchar:
            begin
              rttiList.concat(Tai_const.Create_8bit(tkChar));
              dointeger;
            end;
          uwidechar:
            begin
              rttiList.concat(Tai_const.Create_8bit(tkWChar));
              dointeger;
            end;
          else
            begin
              rttiList.concat(Tai_const.Create_8bit(tkInteger));
              dointeger;
            end;
        end;
      end;


    function torddef.is_publishable : boolean;
      begin
         is_publishable:=(typ<>uvoid);
      end;


    function torddef.gettypename : string;

      const
        names : array[tbasetype] of string[20] = (
          'untyped',
          'Byte','Word','DWord','QWord',
          'ShortInt','SmallInt','LongInt','Int64',
          'Boolean','WordBool','LongBool',
          'Char','WideChar','Currency');

      begin
         gettypename:=names[typ];
      end;

{****************************************************************************
                                TFLOATDEF
****************************************************************************}

    constructor tfloatdef.create(t : tfloattype);
      begin
         inherited create;
         deftype:=floatdef;
         typ:=t;
         setsize;
      end;


    constructor tfloatdef.ppuload(ppufile:tcompilerppufile);
      begin
         inherited ppuloaddef(ppufile);
         deftype:=floatdef;
         typ:=tfloattype(ppufile.getbyte);
         setsize;
      end;


    function tfloatdef.getcopy : tstoreddef;
      begin
         result:=tfloatdef.create(typ);
         result.deftype:=floatdef;
         tfloatdef(result).savesize:=savesize;
      end;


    procedure tfloatdef.setsize;
      begin
         case typ of
           s32real : savesize:=4;
           s80real : savesize:=10;
           s64real,
           s64currency,
           s64comp : savesize:=8;
         else
           savesize:=0;
         end;
      end;


    procedure tfloatdef.ppuwrite(ppufile:tcompilerppufile);
      begin
         inherited ppuwritedef(ppufile);
         ppufile.putbyte(byte(typ));
         ppufile.writeentry(ibfloatdef);
      end;


{$ifdef GDB}
    function Tfloatdef.stabstring:Pchar;
      begin
        case typ of
          s32real,s64real:
            { found this solution in stabsread.c from GDB v4.16 }
            stabstring:=stabstr_evaluate('r$1;${savesize};0;',[tstoreddef(s32inttype.def).numberstring]);
          s64currency,s64comp:
            stabstring:=stabstr_evaluate('r$1;-${savesize};0;',[tstoreddef(s32inttype.def).numberstring]);
          s80real:
           { under dos at least you must give a size of twelve instead of 10 !! }
           { this is probably do to the fact that in gcc all is pushed in 4 bytes size }
            stabstring:=stabstr_evaluate('r$1;12;0;',[tstoreddef(s32inttype.def).numberstring]);
          else
            internalerror(10005);
        end;
      end;


    procedure tfloatdef.concatstabto(asmlist:taasmoutput);
      begin
        if (stab_state in [stab_state_writing,stab_state_written]) then
          exit;
        tstoreddef(s32inttype.def).concatstabto(asmlist);
        inherited concatstabto(asmlist);
      end;
{$endif GDB}


    procedure tfloatdef.write_rtti_data(rt:trttitype);
      const
         {tfloattype = (s32real,s64real,s80real,s64bit,s128bit);}
         translate : array[tfloattype] of byte =
           (ftSingle,ftDouble,ftExtended,ftComp,ftCurr,ftFloat128);
      begin
         rttiList.concat(Tai_const.Create_8bit(tkFloat));
         write_rtti_name;
{$ifdef cpurequiresproperalignment}
         rttilist.concat(Tai_align.Create(sizeof(TConstPtrUInt)));
{$endif cpurequiresproperalignment}
         rttiList.concat(Tai_const.Create_8bit(translate[typ]));
      end;


    function tfloatdef.is_publishable : boolean;
      begin
         is_publishable:=true;
      end;

    function tfloatdef.gettypename : string;

      const
        names : array[tfloattype] of string[20] = (
          'Single','Double','Extended','Comp','Currency','Float128');

      begin
         gettypename:=names[typ];
      end;

{****************************************************************************
                                TFILEDEF
****************************************************************************}

    constructor tfiledef.createtext;
      begin
         inherited create;
         deftype:=filedef;
         filetyp:=ft_text;
         typedfiletype.reset;
         setsize;
      end;


    constructor tfiledef.createuntyped;
      begin
         inherited create;
         deftype:=filedef;
         filetyp:=ft_untyped;
         typedfiletype.reset;
         setsize;
      end;


    constructor tfiledef.createtyped(const tt : ttype);
      begin
         inherited create;
         deftype:=filedef;
         filetyp:=ft_typed;
         typedfiletype:=tt;
         setsize;
      end;


    constructor tfiledef.ppuload(ppufile:tcompilerppufile);
      begin
         inherited ppuloaddef(ppufile);
         deftype:=filedef;
         filetyp:=tfiletyp(ppufile.getbyte);
         if filetyp=ft_typed then
           ppufile.gettype(typedfiletype)
         else
           typedfiletype.reset;
         setsize;
      end;


    function tfiledef.getcopy : tstoreddef;
      begin
        case filetyp of
          ft_typed:
            result:=tfiledef.createtyped(typedfiletype);
          ft_untyped:
            result:=tfiledef.createuntyped;
          ft_text:
            result:=tfiledef.createtext;
          else
            internalerror(2004121201);
        end;
      end;


    procedure tfiledef.buildderef;
      begin
        inherited buildderef;
        if filetyp=ft_typed then
          typedfiletype.buildderef;
      end;


    procedure tfiledef.deref;
      begin
        inherited deref;
        if filetyp=ft_typed then
          typedfiletype.resolve;
      end;


    procedure tfiledef.setsize;
      begin
{$ifdef cpu64bit}
        case filetyp of
          ft_text :
            savesize:=612;
          ft_typed,
          ft_untyped :
            savesize:=352;
        end;
{$else cpu64bit}
        case filetyp of
          ft_text :
            savesize:=576;
          ft_typed,
          ft_untyped :
            savesize:=316;
        end;
{$endif cpu64bit}
      end;


    procedure tfiledef.ppuwrite(ppufile:tcompilerppufile);
      begin
         inherited ppuwritedef(ppufile);
         ppufile.putbyte(byte(filetyp));
         if filetyp=ft_typed then
           ppufile.puttype(typedfiletype);
         ppufile.writeentry(ibfiledef);
      end;


{$ifdef GDB}
    function tfiledef.stabstring : pchar;
      begin
   {$IfDef GDBknowsfiles}
      case filetyp of
        ft_typed :
          stabstring := strpnew('d'+typedfiletype.def.numberstring{+';'});
        ft_untyped :
          stabstring := strpnew('d'+voiddef.numberstring{+';'});
        ft_text :
          stabstring := strpnew('d'+cchartype^.numberstring{+';'});
      end;
   {$Else}
{$ifdef cpu64bit}
      stabstring:=stabstr_evaluate('s${savesize}HANDLE:$1,0,32;MODE:$1,32,32;RECSIZE:$2,64,64;'+
                                   '_PRIVATE:ar$1;1;64;$3,128,256;USERDATA:ar$1;1;16;$3,384,128;'+
                                   'NAME:ar$1;0;255;$4,512,2048;;',[tstoreddef(s32inttype.def).numberstring,
                                   tstoreddef(s64inttype.def).numberstring,
                                   tstoreddef(u8inttype.def).numberstring,
                                   tstoreddef(cchartype.def).numberstring]);
{$else cpu64bit}
      stabstring:=stabstr_evaluate('s${savesize}HANDLE:$1,0,32;MODE:$1,32,32;RECSIZE:$1,64,32;'+
                                   '_PRIVATE:ar$1;1;32;$3,96,256;USERDATA:ar$1;1;16;$2,352,128;'+
                                   'NAME:ar$1;0;255;$3,480,2048;;',[tstoreddef(s32inttype.def).numberstring,
                                   tstoreddef(u8inttype.def).numberstring,
                                   tstoreddef(cchartype.def).numberstring]);
{$endif cpu64bit}
   {$EndIf}
      end;


    procedure tfiledef.concatstabto(asmlist:taasmoutput);
      begin
        if (stab_state in [stab_state_writing,stab_state_written]) then
          exit;
  {$IfDef GDBknowsfiles}
        case filetyp of
          ft_typed :
            tstoreddef(typedfiletype.def).concatstabto(asmlist);
          ft_untyped :
            tstoreddef(voidtype.def).concatstabto(asmlist);
          ft_text :
            tstoreddef(cchartype.def).concatstabto(asmlist);
        end;
  {$Else}
        tstoreddef(s32inttype.def).concatstabto(asmlist);
{$ifdef cpu64bit}
        tstoreddef(s64inttype.def).concatstabto(asmlist);
{$endif cpu64bit}
        tstoreddef(u8inttype.def).concatstabto(asmlist);
        tstoreddef(cchartype.def).concatstabto(asmlist);
  {$EndIf}
        inherited concatstabto(asmlist);
      end;
{$endif GDB}


    function tfiledef.gettypename : string;
      begin
         case filetyp of
           ft_untyped:
             gettypename:='File';
           ft_typed:
             gettypename:='File Of '+typedfiletype.def.typename;
           ft_text:
             gettypename:='Text'
         end;
      end;


    function tfiledef.getmangledparaname : string;
      begin
         case filetyp of
           ft_untyped:
             getmangledparaname:='FILE';
           ft_typed:
             getmangledparaname:='FILE$OF$'+typedfiletype.def.mangledparaname;
           ft_text:
             getmangledparaname:='TEXT'
         end;
      end;


{****************************************************************************
                               TVARIANTDEF
****************************************************************************}

    constructor tvariantdef.create(v : tvarianttype);
      begin
         inherited create;
         varianttype:=v;
         deftype:=variantdef;
         setsize;
      end;


    constructor tvariantdef.ppuload(ppufile:tcompilerppufile);
      begin
         inherited ppuloaddef(ppufile);
         varianttype:=tvarianttype(ppufile.getbyte);
         deftype:=variantdef;
         setsize;
      end;


    function tvariantdef.getcopy : tstoreddef;
      begin
        result:=tvariantdef.create(varianttype);
      end;


    procedure tvariantdef.ppuwrite(ppufile:tcompilerppufile);
      begin
         inherited ppuwritedef(ppufile);
         ppufile.putbyte(byte(varianttype));
         ppufile.writeentry(ibvariantdef);
      end;


    procedure tvariantdef.setsize;
      begin
         savesize:=16;
      end;


    function tvariantdef.gettypename : string;
      begin
         case varianttype of
           vt_normalvariant:
             gettypename:='Variant';
           vt_olevariant:
             gettypename:='OleVariant';
         end;
      end;


    procedure tvariantdef.write_rtti_data(rt:trttitype);
      begin
         rttiList.concat(Tai_const.Create_8bit(tkVariant));
      end;


    function tvariantdef.needs_inittable : boolean;
      begin
         needs_inittable:=true;
      end;

{$ifdef GDB}
    function tvariantdef.stabstring : pchar;
      begin
        stabstring:=stabstr_evaluate('formal${numberstring};',[]);
      end;


    function tvariantdef.numberstring:string;
      begin
        result:=tstoreddef(voidtype.def).numberstring;
      end;


    procedure tvariantdef.concatstabto(asmlist : taasmoutput);
      begin
        { don't know how to handle this }
      end;
{$endif GDB}

{****************************************************************************
                               TPOINTERDEF
****************************************************************************}

    constructor tpointerdef.create(const tt : ttype);
      begin
        inherited create;
        deftype:=pointerdef;
        pointertype:=tt;
        is_far:=false;
        savesize:=sizeof(aint);
      end;


    constructor tpointerdef.createfar(const tt : ttype);
      begin
        inherited create;
        deftype:=pointerdef;
        pointertype:=tt;
        is_far:=true;
        savesize:=sizeof(aint);
      end;


    constructor tpointerdef.ppuload(ppufile:tcompilerppufile);
      begin
         inherited ppuloaddef(ppufile);
         deftype:=pointerdef;
         ppufile.gettype(pointertype);
         is_far:=(ppufile.getbyte<>0);
         savesize:=sizeof(aint);
      end;


    function tpointerdef.getcopy : tstoreddef;
      begin
        result:=tpointerdef.create(pointertype);
        tpointerdef(result).is_far:=is_far;
        tpointerdef(result).savesize:=savesize;
      end;


    procedure tpointerdef.buildderef;
      begin
        inherited buildderef;
        pointertype.buildderef;
      end;


    procedure tpointerdef.deref;
      begin
        inherited deref;
        pointertype.resolve;
      end;


    procedure tpointerdef.ppuwrite(ppufile:tcompilerppufile);
      begin
         inherited ppuwritedef(ppufile);
         ppufile.puttype(pointertype);
         ppufile.putbyte(byte(is_far));
         ppufile.writeentry(ibpointerdef);
      end;


{$ifdef GDB}
    function tpointerdef.stabstring : pchar;
      begin
        stabstring := strpnew('*'+tstoreddef(pointertype.def).numberstring);
      end;


    procedure tpointerdef.concatstabto(asmlist : taasmoutput);
      var st,nb : string;

      begin
        if (stab_state in [stab_state_writing,stab_state_written]) then
          exit;
        stab_state:=stab_state_writing;

        tstoreddef(pointertype.def).concatstabto(asmlist);

        if (pointertype.def.deftype in [recorddef,objectdef]) then
          begin
            if pointertype.def.deftype=objectdef then
              nb:=tobjectdef(pointertype.def).classnumberstring
            else
              nb:=tstoreddef(pointertype.def).numberstring;
            {to avoid infinite recursion in record with next-like fields }
            if tstoreddef(pointertype.def).stab_state=stab_state_writing then
              begin
                if assigned(pointertype.def.typesym) then
                  begin
                    if assigned(typesym) then
                      st := ttypesym(typesym).name
                    else
                      st := ' ';
                    asmlist.concat(Tai_stabs.create(stabstr_evaluate(
                            '"$1:t${numberstring}=*$2=xs$3:",${N_LSYM},0,0,0',
                            [st,nb,pointertype.def.typesym.name])));
                  end;
                stab_state:=stab_state_written;
              end
            else
              begin
                stab_state:=stab_state_used;
                inherited concatstabto(asmlist);
              end;
          end
        else
          begin
            stab_state:=stab_state_used;
            inherited concatstabto(asmlist);
          end;
      end;
{$endif GDB}


    function tpointerdef.gettypename : string;
      begin
         if is_far then
          gettypename:='^'+pointertype.def.typename+';far'
         else
          gettypename:='^'+pointertype.def.typename;
      end;


{****************************************************************************
                              TCLASSREFDEF
****************************************************************************}

    constructor tclassrefdef.create(const t:ttype);
      begin
         inherited create(t);
         deftype:=classrefdef;
      end;


    constructor tclassrefdef.ppuload(ppufile:tcompilerppufile);
      begin
         { be careful, tclassdefref inherits from tpointerdef }
         inherited ppuloaddef(ppufile);
         deftype:=classrefdef;
         ppufile.gettype(pointertype);
         is_far:=false;
         savesize:=sizeof(aint);
      end;


    procedure tclassrefdef.ppuwrite(ppufile:tcompilerppufile);
      begin
         { be careful, tclassdefref inherits from tpointerdef }
         inherited ppuwritedef(ppufile);
         ppufile.puttype(pointertype);
         ppufile.writeentry(ibclassrefdef);
      end;


{$ifdef GDB}
    function tclassrefdef.stabstring : pchar;
      begin
         stabstring:=strpnew(tstoreddef(pvmttype.def).numberstring);
      end;
{$endif GDB}


    function tclassrefdef.gettypename : string;
      begin
         gettypename:='Class Of '+pointertype.def.typename;
      end;


{***************************************************************************
                                   TSETDEF
***************************************************************************}

    constructor tsetdef.create(const t:ttype;high : longint);
      begin
         inherited create;
         deftype:=setdef;
         elementtype:=t;
         if high<32 then
           begin
            settype:=smallset;
           {$ifdef testvarsets}
            if aktsetalloc=0 THEN      { $PACKSET Fixed?}
           {$endif}
            savesize:=Sizeof(longint)
           {$ifdef testvarsets}
           else                       {No, use $PACKSET VALUE for rounding}
            savesize:=aktsetalloc*((high+aktsetalloc*8-1) DIV (aktsetalloc*8))
           {$endif}
              ;
          end
         else
          if high<256 then
           begin
              settype:=normset;
              savesize:=32;
           end
         else
{$ifdef testvarsets}
         if high<$10000 then
           begin
              settype:=varset;
              savesize:=4*((high+31) div 32);
           end
         else
{$endif testvarsets}
          Message(sym_e_ill_type_decl_set);
      end;


    constructor tsetdef.ppuload(ppufile:tcompilerppufile);
      begin
         inherited ppuloaddef(ppufile);
         deftype:=setdef;
         ppufile.gettype(elementtype);
         settype:=tsettype(ppufile.getbyte);
         case settype of
            normset : savesize:=32;
            varset : savesize:=ppufile.getlongint;
            smallset : savesize:=Sizeof(longint);
         end;
      end;


    destructor tsetdef.destroy;
      begin
        inherited destroy;
      end;


    function tsetdef.getcopy : tstoreddef;
      begin
        case settype of
          smallset:
            result:=tsetdef.create(elementtype,31);
          normset:
            result:=tsetdef.create(elementtype,255);
          else
            internalerror(2004121202);
        end;
      end;


    procedure tsetdef.ppuwrite(ppufile:tcompilerppufile);
      begin
         inherited ppuwritedef(ppufile);
         ppufile.puttype(elementtype);
         ppufile.putbyte(byte(settype));
         if settype=varset then
           ppufile.putlongint(savesize);
         ppufile.writeentry(ibsetdef);
      end;


{$ifdef GDB}
    function tsetdef.stabstring : pchar;
      begin
        stabstring:=stabstr_evaluate('@s$1;S$2',[tostr(savesize*8),tstoreddef(elementtype.def).numberstring]);
      end;


    procedure tsetdef.concatstabto(asmlist:taasmoutput);
      begin
        if (stab_state in [stab_state_writing,stab_state_written]) then
          exit;
        tstoreddef(elementtype.def).concatstabto(asmlist);
        inherited concatstabto(asmlist);
      end;
{$endif GDB}


    procedure tsetdef.buildderef;
      begin
        inherited buildderef;
        elementtype.buildderef;
      end;


    procedure tsetdef.deref;
      begin
        inherited deref;
        elementtype.resolve;
      end;


    procedure tsetdef.write_child_rtti_data(rt:trttitype);
      begin
        tstoreddef(elementtype.def).get_rtti_label(rt);
      end;


    procedure tsetdef.write_rtti_data(rt:trttitype);
      begin
         rttiList.concat(Tai_const.Create_8bit(tkSet));
         write_rtti_name;
{$ifdef cpurequiresproperalignment}
         rttilist.concat(Tai_align.Create(sizeof(TConstPtrUInt)));
{$endif cpurequiresproperalignment}
         rttiList.concat(Tai_const.Create_8bit(otULong));
{$ifdef cpurequiresproperalignment}
         rttilist.concat(Tai_align.Create(sizeof(TConstPtrUInt)));
{$endif cpurequiresproperalignment}
         rttiList.concat(Tai_const.Create_sym(tstoreddef(elementtype.def).get_rtti_label(rt)));
      end;


    function tsetdef.is_publishable : boolean;
      begin
         is_publishable:=(settype=smallset);
      end;


    function tsetdef.gettypename : string;
      begin
         if assigned(elementtype.def) then
          gettypename:='Set Of '+elementtype.def.typename
         else
          gettypename:='Empty Set';
      end;


{***************************************************************************
                                 TFORMALDEF
***************************************************************************}

    constructor tformaldef.create;
      var
         stregdef : boolean;
      begin
         stregdef:=registerdef;
         registerdef:=false;
         inherited create;
         deftype:=formaldef;
         registerdef:=stregdef;
         { formaldef must be registered at unit level !! }
         if registerdef and assigned(current_module) then
            if assigned(current_module.localsymtable) then
              tsymtable(current_module.localsymtable).registerdef(self)
            else if assigned(current_module.globalsymtable) then
              tsymtable(current_module.globalsymtable).registerdef(self);
         savesize:=0;
      end;


    constructor tformaldef.ppuload(ppufile:tcompilerppufile);
      begin
         inherited ppuloaddef(ppufile);
         deftype:=formaldef;
         savesize:=0;
      end;


    procedure tformaldef.ppuwrite(ppufile:tcompilerppufile);
      begin
         inherited ppuwritedef(ppufile);
         ppufile.writeentry(ibformaldef);
      end;


{$ifdef GDB}
    function tformaldef.stabstring : pchar;
      begin
        stabstring:=stabstr_evaluate('formal${numberstring};',[]);
      end;


    function tformaldef.numberstring:string;
      begin
        result:=tstoreddef(voidtype.def).numberstring;
      end;


    procedure tformaldef.concatstabto(asmlist : taasmoutput);
      begin
        { formaldef can't be stab'ed !}
      end;
{$endif GDB}


    function tformaldef.gettypename : string;
      begin
         gettypename:='<Formal type>';
      end;


{***************************************************************************
                           TARRAYDEF
***************************************************************************}

    constructor tarraydef.create(l,h : aint;const t : ttype);
      begin
         inherited create;
         deftype:=arraydef;
         lowrange:=l;
         highrange:=h;
         rangetype:=t;
         elementtype.reset;
         IsVariant:=false;
         IsConstructor:=false;
         IsArrayOfConst:=false;
         IsDynamicArray:=false;
         IsConvertedPointer:=false;
      end;


    constructor tarraydef.create_from_pointer(const elemt : ttype);
      begin
         self.create(0,$7fffffff,s32inttype);
         IsConvertedPointer:=true;
         setelementtype(elemt);
      end;


    constructor tarraydef.ppuload(ppufile:tcompilerppufile);
      begin
         inherited ppuloaddef(ppufile);
         deftype:=arraydef;
         { the addresses are calculated later }
         ppufile.gettype(_elementtype);
         ppufile.gettype(rangetype);
         lowrange:=ppufile.getaint;
         highrange:=ppufile.getaint;
         IsArrayOfConst:=boolean(ppufile.getbyte);
         IsDynamicArray:=boolean(ppufile.getbyte);
         IsVariant:=false;
         IsConstructor:=false;
      end;


    function tarraydef.getcopy : tstoreddef;
      begin
        result:=tarraydef.create(lowrange,highrange,rangetype);
        tarraydef(result).IsConvertedPointer:=IsConvertedPointer;
        tarraydef(result).IsDynamicArray:=IsDynamicArray;
        tarraydef(result).IsVariant:=IsVariant;
        tarraydef(result).IsConstructor:=IsConstructor;
        tarraydef(result).IsArrayOfConst:=IsArrayOfConst;
        tarraydef(result)._elementtype:=_elementtype;
      end;


    procedure tarraydef.buildderef;
      begin
        inherited buildderef;
        _elementtype.buildderef;
        rangetype.buildderef;
      end;


    procedure tarraydef.deref;
      begin
        inherited deref;
        _elementtype.resolve;
        rangetype.resolve;
      end;


    procedure tarraydef.ppuwrite(ppufile:tcompilerppufile);
      begin
         inherited ppuwritedef(ppufile);
         ppufile.puttype(_elementtype);
         ppufile.puttype(rangetype);
         ppufile.putaint(lowrange);
         ppufile.putaint(highrange);
         ppufile.putbyte(byte(IsArrayOfConst));
         ppufile.putbyte(byte(IsDynamicArray));
         ppufile.writeentry(ibarraydef);
      end;


{$ifdef GDB}
    function tarraydef.stabstring : pchar;
      begin
        stabstring:=stabstr_evaluate('ar$1;$2;$3;$4',[Tstoreddef(rangetype.def).numberstring,
                    tostr(lowrange),tostr(highrange),Tstoreddef(_elementtype.def).numberstring]);
      end;


    procedure tarraydef.concatstabto(asmlist:taasmoutput);
      begin
        if (stab_state in [stab_state_writing,stab_state_written]) then
          exit;
        tstoreddef(rangetype.def).concatstabto(asmlist);
        tstoreddef(_elementtype.def).concatstabto(asmlist);
        inherited concatstabto(asmlist);
      end;
{$endif GDB}


    function tarraydef.elesize : aint;
      begin
        elesize:=_elementtype.def.size;
      end;


    function tarraydef.elecount : aint;
      var
        qhigh,qlow : qword;
      begin
        if IsDynamicArray then
          begin
            result:=0;
            exit;
          end;
        if (highrange>0) and (lowrange<0) then
          begin
            qhigh:=highrange;
            qlow:=qword(-lowrange);
            { prevent overflow, return -1 to indicate overflow }
            if qhigh+qlow>qword(high(aint)-1) then
              result:=-1
            else
              result:=qhigh+qlow+1;
          end
        else
          result:=int64(highrange)-lowrange+1;
      end;


    function tarraydef.size : aint;
      var
        cachedelecount,
        cachedelesize : aint;
      begin
        if IsDynamicArray then
          begin
            size:=sizeof(aint);
            exit;
          end;
        { Tarraydef.size may never be called for an open array! }
        if highrange<lowrange then
          internalerror(99080501);
        cachedelesize:=elesize;
        cachedelecount:=elecount;
        { prevent overflow, return -1 to indicate overflow }
        if (cachedelesize <> 0) and
           (
            (cachedelecount < 0) or
            ((high(aint) div cachedelesize) < cachedelecount) or
            { also lowrange*elesize must be < high(aint) to prevent overflow when
              accessing the array, see ncgmem (PFV) }
            ((high(aint) div cachedelesize) < abs(lowrange))
           ) then
          result:=-1
        else
          result:=cachedelesize*cachedelecount;
      end;


    procedure tarraydef.setelementtype(t: ttype);
      begin
        _elementtype:=t;
       if not(IsDynamicArray or
              IsConvertedPointer or
              (highrange<lowrange)) then
         begin
           if (size=-1) then
             Message(sym_e_segment_too_large);
         end;
      end;


    function tarraydef.alignment : longint;
      begin
         { alignment is the size of the elements }
         if elementtype.def.deftype=recorddef then
          alignment:=elementtype.def.alignment
         else
          alignment:=elesize;
      end;


    function tarraydef.needs_inittable : boolean;
      begin
         needs_inittable:=IsDynamicArray or elementtype.def.needs_inittable;
      end;


    procedure tarraydef.write_child_rtti_data(rt:trttitype);
      begin
        tstoreddef(elementtype.def).get_rtti_label(rt);
      end;


    procedure tarraydef.write_rtti_data(rt:trttitype);
      begin
         if IsDynamicArray then
           rttiList.concat(Tai_const.Create_8bit(tkdynarray))
         else
           rttiList.concat(Tai_const.Create_8bit(tkarray));
         write_rtti_name;
{$ifdef cpurequiresproperalignment}
         rttilist.concat(Tai_align.Create(sizeof(TConstPtrUInt)));
{$endif cpurequiresproperalignment}
         { size of elements }
         rttiList.concat(Tai_const.Create_aint(elesize));
         if not(IsDynamicArray) then
           rttiList.concat(Tai_const.Create_aint(elecount));
         { element type }
         rttiList.concat(Tai_const.Create_sym(tstoreddef(elementtype.def).get_rtti_label(rt)));
         { variant type }
         // !!!!!!!!!!!!!!!!
      end;


    function tarraydef.gettypename : string;
      begin
         if isarrayofconst or isConstructor then
           begin
             if isvariant or ((highrange=-1) and (lowrange=0)) then
               gettypename:='Array Of Const'
             else
               gettypename:='Array Of '+elementtype.def.typename;
           end
         else if ((highrange=-1) and (lowrange=0)) or IsDynamicArray then
           gettypename:='Array Of '+elementtype.def.typename
         else
           begin
              if rangetype.def.deftype=enumdef then
                gettypename:='Array['+rangetype.def.typename+'] Of '+elementtype.def.typename
              else
                gettypename:='Array['+tostr(lowrange)+'..'+
                  tostr(highrange)+'] Of '+elementtype.def.typename
           end;
      end;


    function tarraydef.getmangledparaname : string;
      begin
         if isarrayofconst then
          getmangledparaname:='array_of_const'
         else
          if ((highrange=-1) and (lowrange=0)) then
           getmangledparaname:='array_of_'+elementtype.def.mangledparaname
         else
          internalerror(200204176);
      end;


{***************************************************************************
                              tabstractrecorddef
***************************************************************************}

    function tabstractrecorddef.getsymtable(t:tgetsymtable):tsymtable;
      begin
         if t=gs_record then
         getsymtable:=symtable
        else
         getsymtable:=nil;
      end;


{$ifdef GDB}
    procedure tabstractrecorddef.field_addname(p:Tnamedindexitem;arg:pointer);
      var
        newrec:Pchar;
        spec:string[3];
        varsize : aint;
        state   : ^Trecord_stabgen_state;
      begin
        state:=arg;
        { static variables from objects are like global objects }
        if (Tsym(p).typ=fieldvarsym) and not (sp_static in Tsym(p).symoptions) then
          begin
            if (sp_protected in tsym(p).symoptions) then
              spec:='/1'
            else if (sp_private in tsym(p).symoptions) then
              spec:='/0'
            else
              spec:='';
            varsize:=tfieldvarsym(p).vartype.def.size;
            { open arrays made overflows !! }
            if varsize>$fffffff then
              varsize:=$fffffff;
            newrec:=stabstr_evaluate('$1:$2,$3,$4;',[p.name,
                                     spec+tstoreddef(tfieldvarsym(p).vartype.def).numberstring,
                                     tostr(tfieldvarsym(p).fieldoffset*8),tostr(varsize*8)]);
            if state^.stabsize+strlen(newrec)>=state^.staballoc-256 then
              begin
                inc(state^.staballoc,memsizeinc);
                reallocmem(state^.stabstring,state^.staballoc);
              end;
            strcopy(state^.stabstring+state^.stabsize,newrec);
            inc(state^.stabsize,strlen(newrec));
            strdispose(newrec);
            {This should be used for case !!}
            inc(state^.recoffset,Tfieldvarsym(p).vartype.def.size);
          end;
      end;


    procedure tabstractrecorddef.field_concatstabto(p:Tnamedindexitem;arg:pointer);
      begin
        if (Tsym(p).typ=fieldvarsym) and not (sp_static in Tsym(p).symoptions) then
          tstoreddef(tfieldvarsym(p).vartype.def).concatstabto(taasmoutput(arg));
      end;


{$endif GDB}


    procedure tabstractrecorddef.count_field_rtti(sym : tnamedindexitem;arg:pointer);
      begin
         if (FRTTIType=fullrtti) or
            ((tsym(sym).typ=fieldvarsym) and
             tfieldvarsym(sym).vartype.def.needs_inittable) then
           inc(Count);
      end;


    procedure tabstractrecorddef.generate_field_rtti(sym:tnamedindexitem;arg:pointer);
      begin
         if (FRTTIType=fullrtti) or
            ((tsym(sym).typ=fieldvarsym) and
             tfieldvarsym(sym).vartype.def.needs_inittable) then
           tstoreddef(tfieldvarsym(sym).vartype.def).get_rtti_label(FRTTIType);
      end;


    procedure tabstractrecorddef.write_field_rtti(sym : tnamedindexitem;arg:pointer);
      begin
         if (FRTTIType=fullrtti) or
            ((tsym(sym).typ=fieldvarsym) and
             tfieldvarsym(sym).vartype.def.needs_inittable) then
          begin
            rttiList.concat(Tai_const.Create_sym(tstoreddef(tfieldvarsym(sym).vartype.def).get_rtti_label(FRTTIType)));
            rttiList.concat(Tai_const.Create_32bit(tfieldvarsym(sym).fieldoffset));
          end;
      end;



{***************************************************************************
                                  trecorddef
***************************************************************************}

    constructor trecorddef.create(p : tsymtable);
      begin
         inherited create;
         deftype:=recorddef;
         symtable:=p;
         symtable.defowner:=self;
         isunion:=false;
      end;


    constructor trecorddef.ppuload(ppufile:tcompilerppufile);
      begin
         inherited ppuloaddef(ppufile);
         deftype:=recorddef;
         symtable:=trecordsymtable.create(0);
         trecordsymtable(symtable).datasize:=ppufile.getaint;
         trecordsymtable(symtable).fieldalignment:=shortint(ppufile.getbyte);
         trecordsymtable(symtable).recordalignment:=shortint(ppufile.getbyte);
         trecordsymtable(symtable).padalignment:=shortint(ppufile.getbyte);
         trecordsymtable(symtable).ppuload(ppufile);
         symtable.defowner:=self;
         isunion:=false;
      end;


    destructor trecorddef.destroy;
      begin
         if assigned(symtable) then
           symtable.free;
         inherited destroy;
      end;


    function trecorddef.getcopy : tstoreddef;
      begin
        result:=trecorddef.create(symtable.getcopy);
        trecorddef(result).isunion:=isunion;
      end;


    function trecorddef.needs_inittable : boolean;
      begin
        needs_inittable:=trecordsymtable(symtable).needs_init_final
      end;


    procedure trecorddef.buildderef;
      var
         oldrecsyms : tsymtable;
      begin
         inherited buildderef;
         oldrecsyms:=aktrecordsymtable;
         aktrecordsymtable:=symtable;
         { now build the definitions }
         tstoredsymtable(symtable).buildderef;
         aktrecordsymtable:=oldrecsyms;
      end;


    procedure trecorddef.deref;
      var
         oldrecsyms : tsymtable;
      begin
         inherited deref;
         oldrecsyms:=aktrecordsymtable;
         aktrecordsymtable:=symtable;
         { now dereference the definitions }
         tstoredsymtable(symtable).deref;
         aktrecordsymtable:=oldrecsyms;
         { assign TGUID? load only from system unit (unitid=1) }
         if not(assigned(rec_tguid)) and
            (upper(typename)='TGUID') and
            assigned(owner) and
            assigned(owner.name) and
            (owner.name^='SYSTEM') then
           rec_tguid:=self;
      end;


    procedure trecorddef.ppuwrite(ppufile:tcompilerppufile);
      begin
         inherited ppuwritedef(ppufile);
         ppufile.putaint(trecordsymtable(symtable).datasize);
         ppufile.putbyte(byte(trecordsymtable(symtable).fieldalignment));
         ppufile.putbyte(byte(trecordsymtable(symtable).recordalignment));
         ppufile.putbyte(byte(trecordsymtable(symtable).padalignment));
         ppufile.writeentry(ibrecorddef);
         trecordsymtable(symtable).ppuwrite(ppufile);
      end;


    function trecorddef.size:aint;
      begin
        result:=trecordsymtable(symtable).datasize;
      end;


    function trecorddef.alignment:longint;
      begin
        alignment:=trecordsymtable(symtable).recordalignment;
      end;


    function trecorddef.padalignment:longint;
      begin
        padalignment := trecordsymtable(symtable).padalignment;
      end;

{$ifdef GDB}
    function trecorddef.stabstring : pchar;
      var
        state:Trecord_stabgen_state;
      begin
        getmem(state.stabstring,memsizeinc);
        state.staballoc:=memsizeinc;
        strpcopy(state.stabstring,'s'+tostr(size));
        state.recoffset:=0;
        state.stabsize:=strlen(state.stabstring);
        symtable.foreach(@field_addname,@state);
        state.stabstring[state.stabsize]:=';';
        state.stabstring[state.stabsize+1]:=#0;
        reallocmem(state.stabstring,state.stabsize+2);
        stabstring:=state.stabstring;
      end;


    procedure trecorddef.concatstabto(asmlist:taasmoutput);
      begin
        if (stab_state in [stab_state_writing,stab_state_written]) then
          exit;
        symtable.foreach(@field_concatstabto,asmlist);
        inherited concatstabto(asmlist);
      end;
{$endif GDB}


    procedure trecorddef.write_child_rtti_data(rt:trttitype);
      begin
         FRTTIType:=rt;
         symtable.foreach(@generate_field_rtti,nil);
      end;


    procedure trecorddef.write_rtti_data(rt:trttitype);
      begin
         rttiList.concat(Tai_const.Create_8bit(tkrecord));
         write_rtti_name;
{$ifdef cpurequiresproperalignment}
         rttilist.concat(Tai_align.Create(sizeof(TConstPtrUInt)));
{$endif cpurequiresproperalignment}
         rttiList.concat(Tai_const.Create_32bit(size));
         Count:=0;
         FRTTIType:=rt;
         symtable.foreach(@count_field_rtti,nil);
         rttiList.concat(Tai_const.Create_32bit(Count));
         symtable.foreach(@write_field_rtti,nil);
      end;


    function trecorddef.gettypename : string;
      begin
         gettypename:='<record type>'
      end;


{***************************************************************************
                       TABSTRACTPROCDEF
***************************************************************************}

    constructor tabstractprocdef.create(level:byte);
      begin
         inherited create;
         parast:=tparasymtable.create(level);
         parast.defowner:=self;
         parast.next:=owner;
         paras:=nil;
         minparacount:=0;
         maxparacount:=0;
         proctypeoption:=potype_none;
         proccalloption:=pocall_none;
         procoptions:=[];
         rettype:=voidtype;
{$ifdef i386}
         fpu_used:=0;
{$endif i386}
         savesize:=sizeof(aint);
         requiredargarea:=0;
         has_paraloc_info:=false;

         location_reset(funcretloc[callerside],LOC_INVALID,OS_NO);
         location_reset(funcretloc[calleeside],LOC_INVALID,OS_NO);
      end;


    destructor tabstractprocdef.destroy;
      begin
         if assigned(paras) then
           begin
{$ifdef MEMDEBUG}
             memprocpara.start;
{$endif MEMDEBUG}
             paras.free;
{$ifdef MEMDEBUG}
             memprocpara.stop;
{$endif MEMDEBUG}
          end;
         if assigned(parast) then
          begin
{$ifdef MEMDEBUG}
            memprocparast.start;
{$endif MEMDEBUG}
            parast.free;
{$ifdef MEMDEBUG}
            memprocparast.stop;
{$endif MEMDEBUG}
          end;
         inherited destroy;
      end;


    procedure tabstractprocdef.releasemem;
      begin
        if assigned(paras) then
          begin
            paras.free;
            paras:=nil;
          end;
        parast.free;
        parast:=nil;
      end;


    procedure tabstractprocdef.count_para(p:tnamedindexitem;arg:pointer);
      begin
        if (tsym(p).typ<>paravarsym) then
          exit;
        inc(plongint(arg)^);
        if not(vo_is_hidden_para in tparavarsym(p).varoptions) then
         begin
           if not assigned(tparavarsym(p).defaultconstsym) then
             inc(minparacount);
           inc(maxparacount);
         end;
      end;


    procedure tabstractprocdef.insert_para(p:tnamedindexitem;arg:pointer);
      begin
        if (tsym(p).typ<>paravarsym) then
          exit;
        paras.add(p);
      end;


    procedure tabstractprocdef.calcparas;
      var
        paracount : longint;
      begin
        { This can already be assigned when
          we need to reresolve this unit (PFV) }
        if assigned(paras) then
          paras.free;
        paras:=tparalist.create;
        paracount:=0;
        minparacount:=0;
        maxparacount:=0;
        parast.foreach(@count_para,@paracount);
        paras.capacity:=paracount;
        { Insert parameters in table }
        parast.foreach(@insert_para,nil);
        { Order parameters }
        paras.sortparas;
      end;


    { all functions returning in FPU are
      assume to use 2 FPU registers
      until the function implementation
      is processed   PM }
    procedure tabstractprocdef.test_if_fpu_result;
      begin
{$ifdef i386}
         if assigned(rettype.def) and
            (rettype.def.deftype=floatdef) then
           fpu_used:=maxfpuregs;
{$endif i386}
      end;


    procedure tabstractprocdef.buildderef;
      begin
         { released procdef? }
         if not assigned(parast) then
           exit;
         inherited buildderef;
         rettype.buildderef;
         { parast }
         tparasymtable(parast).buildderef;
      end;


    procedure tabstractprocdef.deref;
      begin
         inherited deref;
         rettype.resolve;
         { parast }
         tparasymtable(parast).deref;
         { recalculated parameters }
         calcparas;
      end;


    constructor tabstractprocdef.ppuload(ppufile:tcompilerppufile);
      var
        b : byte;
      begin
         inherited ppuloaddef(ppufile);
         parast:=nil;
         Paras:=nil;
         minparacount:=0;
         maxparacount:=0;
         ppufile.gettype(rettype);
{$ifdef i386}
         fpu_used:=ppufile.getbyte;
{$else}
         ppufile.getbyte;
{$endif i386}
         proctypeoption:=tproctypeoption(ppufile.getbyte);
         proccalloption:=tproccalloption(ppufile.getbyte);
         ppufile.getsmallset(procoptions);

         location_reset(funcretloc[callerside],LOC_INVALID,OS_NO);
         location_reset(funcretloc[calleeside],LOC_INVALID,OS_NO);
         if po_explicitparaloc in procoptions then
           begin
             b:=ppufile.getbyte;
             if b<>sizeof(funcretloc[callerside]) then
               internalerror(200411154);
             ppufile.getdata(funcretloc[callerside],sizeof(funcretloc[callerside]));
           end;

         savesize:=sizeof(aint);
         has_paraloc_info:=(po_explicitparaloc in procoptions);
      end;


    procedure tabstractprocdef.ppuwrite(ppufile:tcompilerppufile);
      var
        oldintfcrc : boolean;
      begin
         { released procdef? }
         if not assigned(parast) then
           exit;
         inherited ppuwritedef(ppufile);
         ppufile.puttype(rettype);
         oldintfcrc:=ppufile.do_interface_crc;
         ppufile.do_interface_crc:=false;
{$ifdef i386}
         if simplify_ppu then
          fpu_used:=0;
         ppufile.putbyte(fpu_used);
{$else}
         ppufile.putbyte(0);
{$endif}
         ppufile.putbyte(ord(proctypeoption));
         ppufile.putbyte(ord(proccalloption));
         ppufile.putsmallset(procoptions);
         ppufile.do_interface_crc:=oldintfcrc;

         if (po_explicitparaloc in procoptions) then
           begin
             { Make a 'valid' funcretloc for procedures }
             ppufile.putbyte(sizeof(funcretloc[callerside]));
             ppufile.putdata(funcretloc[callerside],sizeof(funcretloc[callerside]));
           end;
      end;


    function tabstractprocdef.typename_paras(showhidden:boolean) : string;
      var
        hs,s  : string;
        hp    : TParavarsym;
        hpc   : tconstsym;
        first : boolean;
        i     : integer;
      begin
        s:='';
        first:=true;
        for i:=0 to paras.count-1 do
         begin
           hp:=tparavarsym(paras[i]);
           if not(vo_is_hidden_para in hp.varoptions) or
              (showhidden) then
            begin
               if first then
                begin
                  s:=s+'(';
                  first:=false;
                end
               else
                s:=s+',';
               case hp.varspez of
                 vs_var :
                   s:=s+'var';
                 vs_const :
                   s:=s+'const';
                 vs_out :
                   s:=s+'out';
               end;
               if assigned(hp.vartype.def.typesym) then
                 begin
                   if s<>'(' then
                    s:=s+' ';
                   hs:=hp.vartype.def.typesym.realname;
                   if hs[1]<>'$' then
                     s:=s+hp.vartype.def.typesym.realname
                   else
                     s:=s+hp.vartype.def.gettypename;
                 end
               else
                 s:=s+hp.vartype.def.gettypename;
               { default value }
               if assigned(hp.defaultconstsym) then
                begin
                  hpc:=tconstsym(hp.defaultconstsym);
                  hs:='';
                  case hpc.consttyp of
                    conststring,
                    constresourcestring :
                      hs:=strpas(pchar(hpc.value.valueptr));
                    constreal :
                      str(pbestreal(hpc.value.valueptr)^,hs);
                    constpointer :
                      hs:=tostr(hpc.value.valueordptr);
                    constord :
                      begin
                        if is_boolean(hpc.consttype.def) then
                          begin
                            if hpc.value.valueord<>0 then
                             hs:='TRUE'
                            else
                             hs:='FALSE';
                          end
                        else
                          hs:=tostr(hpc.value.valueord);
                      end;
                    constnil :
                      hs:='nil';
                    constset :
                      hs:='<set>';
                  end;
                  if hs<>'' then
                   s:=s+'="'+hs+'"';
                end;
             end;
         end;
        if not first then
         s:=s+')';
        if (po_varargs in procoptions) then
         s:=s+';VarArgs';
        typename_paras:=s;
      end;


    function tabstractprocdef.is_methodpointer:boolean;
      begin
        result:=false;
      end;


    function tabstractprocdef.is_addressonly:boolean;
      begin
        result:=true;
      end;


{$ifdef GDB}
    function tabstractprocdef.stabstring : pchar;
      begin
        stabstring := strpnew('abstractproc'+numberstring+';');
      end;
{$endif GDB}


{***************************************************************************
                                  TPROCDEF
***************************************************************************}

    constructor tprocdef.create(level:byte);
      begin
         inherited create(level);
         deftype:=procdef;
         _mangledname:=nil;
         fileinfo:=aktfilepos;
         extnumber:=$ffff;
         aliasnames:=tstringlist.create;
         funcretsym:=nil;
         localst := nil;
         defref:=nil;
         lastwritten:=nil;
         refcount:=0;
         if (cs_browser in aktmoduleswitches) and make_ref then
          begin
            defref:=tref.create(defref,@akttokenpos);
            inc(refcount);
          end;
         lastref:=defref;
         forwarddef:=true;
         interfacedef:=false;
         hasforward:=false;
         _class := nil;
         import_dll:=nil;
         import_name:=nil;
         import_nr:=0;
         inlininginfo:=nil;
{$ifdef GDB}
         isstabwritten := false;
{$endif GDB}
      end;


    constructor tprocdef.ppuload(ppufile:tcompilerppufile);
      var
        level : byte;
      begin
         inherited ppuload(ppufile);
         deftype:=procdef;

         if po_has_mangledname in procoptions then
          _mangledname:=stringdup(ppufile.getstring)
         else
          _mangledname:=nil;
         extnumber:=ppufile.getword;
         level:=ppufile.getbyte;
         ppufile.getderef(_classderef);
         ppufile.getderef(procsymderef);
         ppufile.getposinfo(fileinfo);
         ppufile.getsmallset(symoptions);
{$ifdef powerpc}
         { library symbol for AmigaOS/MorphOS }
         ppufile.getderef(libsymderef);
{$endif powerpc}
         { import stuff }
         import_dll:=nil;
         import_name:=nil;
         import_nr:=0;
         { inline stuff }
         if (po_has_inlininginfo in procoptions) then
           begin
             ppufile.getderef(funcretsymderef);
             new(inlininginfo);
             ppufile.getsmallset(inlininginfo^.flags);
           end
         else
           begin
             inlininginfo:=nil;
             funcretsym:=nil;
           end;
         { load para symtable }
         parast:=tparasymtable.create(level);
         tparasymtable(parast).ppuload(ppufile);
         parast.defowner:=self;
         { load local symtable }
         if (po_has_inlininginfo in procoptions) or
            ((current_module.flags and uf_local_browser)<>0) then
          begin
            localst:=tlocalsymtable.create(level);
            tlocalsymtable(localst).ppuload(ppufile);
            localst.defowner:=self;
          end
         else
          localst:=nil;
         { inline stuff }
         if (po_has_inlininginfo in procoptions) then
           inlininginfo^.code:=ppuloadnodetree(ppufile);
         { default values for no persistent data }
         if (cs_link_deffile in aktglobalswitches) and
            (tf_need_export in target_info.flags) and
            (po_exports in procoptions) then
           deffile.AddExport(mangledname);
         aliasnames:=tstringlist.create;
         forwarddef:=false;
         interfacedef:=false;
         hasforward:=false;
         lastref:=nil;
         lastwritten:=nil;
         defref:=nil;
         refcount:=0;
{$ifdef GDB}
         isstabwritten := false;
{$endif GDB}
      end;


    destructor tprocdef.destroy;
      begin
         if assigned(defref) then
           begin
             defref.freechain;
             defref.free;
           end;
         aliasnames.free;
         if assigned(localst) and (localst.symtabletype<>staticsymtable) then
          begin
{$ifdef MEMDEBUG}
            memproclocalst.start;
{$endif MEMDEBUG}
            localst.free;
{$ifdef MEMDEBUG}
            memproclocalst.start;
{$endif MEMDEBUG}
          end;
         if assigned(inlininginfo) then
          begin
{$ifdef MEMDEBUG}
            memprocnodetree.start;
{$endif MEMDEBUG}
            tnode(inlininginfo^.code).free;
{$ifdef MEMDEBUG}
            memprocnodetree.start;
{$endif MEMDEBUG}
            dispose(inlininginfo);
          end;
         stringdispose(import_dll);
         stringdispose(import_name);
         if (po_msgstr in procoptions) then
           strdispose(messageinf.str);
         if assigned(_mangledname) then
          begin
{$ifdef MEMDEBUG}
            memmanglednames.start;
{$endif MEMDEBUG}
            stringdispose(_mangledname);
{$ifdef MEMDEBUG}
            memmanglednames.stop;
{$endif MEMDEBUG}
          end;
         inherited destroy;
      end;


    procedure tprocdef.ppuwrite(ppufile:tcompilerppufile);
      var
        oldintfcrc : boolean;
        oldparasymtable,
        oldlocalsymtable : tsymtable;
      begin
         { released procdef? }
         if not assigned(parast) then
           exit;

         oldparasymtable:=aktparasymtable;
         oldlocalsymtable:=aktlocalsymtable;
         aktparasymtable:=parast;
         aktlocalsymtable:=localst;

         inherited ppuwrite(ppufile);
         oldintfcrc:=ppufile.do_interface_crc;
         ppufile.do_interface_crc:=false;
         ppufile.do_interface_crc:=oldintfcrc;
         if po_has_mangledname in procoptions then
          ppufile.putstring(_mangledname^);
         ppufile.putword(extnumber);
         ppufile.putbyte(parast.symtablelevel);
         ppufile.putderef(_classderef);
         ppufile.putderef(procsymderef);
         ppufile.putposinfo(fileinfo);
         ppufile.putsmallset(symoptions);
{$ifdef powerpc}
         { library symbol for AmigaOS/MorphOS }
         ppufile.putderef(libsymderef);
{$endif powerpc}
         { inline stuff }
         oldintfcrc:=ppufile.do_crc;
         ppufile.do_crc:=false;
         if (po_has_inlininginfo in procoptions) then
           begin
             ppufile.putderef(funcretsymderef);
             ppufile.putsmallset(inlininginfo^.flags);
           end;
         ppufile.do_crc:=oldintfcrc;

         { write this entry }
         ppufile.writeentry(ibprocdef);

         { Save the para symtable, this is taken from the interface }
         tparasymtable(parast).ppuwrite(ppufile);

         { save localsymtable for inline procedures or when local
           browser info is requested, this has no influence on the crc }
         if (po_has_inlininginfo in procoptions) or
            ((current_module.flags and uf_local_browser)<>0) then
          begin
            { we must write a localsymtable }
            if not assigned(localst) then
              insert_localst;
            oldintfcrc:=ppufile.do_crc;
            ppufile.do_crc:=false;
            tlocalsymtable(localst).ppuwrite(ppufile);
            ppufile.do_crc:=oldintfcrc;
          end;

         { node tree for inlining }
         oldintfcrc:=ppufile.do_crc;
         ppufile.do_crc:=false;
         if (po_has_inlininginfo in procoptions) then
           ppuwritenodetree(ppufile,inlininginfo^.code);
         ppufile.do_crc:=oldintfcrc;

         aktparasymtable:=oldparasymtable;
         aktlocalsymtable:=oldlocalsymtable;
      end;


    procedure tprocdef.insert_localst;
      begin
         localst:=tlocalsymtable.create(parast.symtablelevel);
         localst.defowner:=self;
         { this is used by insert
           to check same names in parast and localst }
         localst.next:=parast;
      end;


    function tprocdef.fullprocname(showhidden:boolean):string;
      var
        s : string;
        t : ttoken;
      begin
{$ifdef EXTDEBUG}
        showhidden:=true;
{$endif EXTDEBUG}
        s:='';
        if assigned(_class) then
         begin
           if po_classmethod in procoptions then
            s:=s+'class ';
           s:=s+_class.objrealname^+'.';
         end;
        if proctypeoption=potype_operator then
          begin
            for t:=NOTOKEN to last_overloaded do
              if procsym.realname='$'+overloaded_names[t] then
                begin
                  s:='operator '+arraytokeninfo[t].str+typename_paras(showhidden);
                  break;
                end;
          end
        else
          s:=s+procsym.realname+typename_paras(showhidden);
        case proctypeoption of
          potype_constructor:
            s:='constructor '+s;
          potype_destructor:
            s:='destructor '+s;
          else
            if assigned(rettype.def) and
              not(is_void(rettype.def)) then
              s:=s+':'+rettype.def.gettypename;
        end;
        { forced calling convention? }
        if (po_hascallingconvention in procoptions) then
          s:=s+';'+ProcCallOptionStr[proccalloption];
        fullprocname:=s;
      end;


    function tprocdef.is_methodpointer:boolean;
      begin
        result:=assigned(_class);
      end;


    function tprocdef.is_addressonly:boolean;
      begin
        result:=assigned(owner) and
                (owner.symtabletype<>objectsymtable);
      end;


    function tprocdef.is_visible_for_object(currobjdef:tobjectdef):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
           (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. The related object must be defined
          in the current module }
        if (sp_protected in symoptions) and
           (
            (
             (owner.defowner.owner.symtabletype in [globalsymtable,staticsymtable]) and
             (owner.defowner.owner.unitid<>0)
            ) and
            not(
                assigned(currobjdef) and
                (currobjdef.owner.unitid=0) and
                currobjdef.is_related(tobjectdef(owner.defowner))
               )
           ) then
          exit;

        is_visible_for_object:=true;
      end;


    function tprocdef.getsymtable(t:tgetsymtable):tsymtable;
      begin
        case t of
          gs_local :
            getsymtable:=localst;
          gs_para :
            getsymtable:=parast;
          else
            getsymtable:=nil;
        end;
      end;


    procedure tprocdef.load_references(ppufile:tcompilerppufile;locals:boolean);
      var
        pos : tfileposinfo;
        move_last : boolean;
        oldparasymtable,
        oldlocalsymtable : tsymtable;
      begin
        oldparasymtable:=aktparasymtable;
        oldlocalsymtable:=aktlocalsymtable;
        aktparasymtable:=parast;
        aktlocalsymtable:=localst;

        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;
        if ((current_module.flags and uf_local_browser)<>0) and
           assigned(localst) and
           locals then
          begin
             tparasymtable(parast).load_references(ppufile,locals);
             tlocalsymtable(localst).load_references(ppufile,locals);
          end;

        aktparasymtable:=oldparasymtable;
        aktlocalsymtable:=oldlocalsymtable;
      end;


    Const
      local_symtable_index : word = $8001;

    function tprocdef.write_references(ppufile:tcompilerppufile;locals:boolean):boolean;
      var
        ref : tref;
        pdo : tobjectdef;
        move_last : boolean;
        d : tderef;
        oldparasymtable,
        oldlocalsymtable : tsymtable;
      begin
        d.reset;
        move_last:=lastwritten=lastref;
        if move_last and
           (((current_module.flags and uf_local_browser)=0) or
            not locals) then
          exit;
        oldparasymtable:=aktparasymtable;
        oldlocalsymtable:=aktlocalsymtable;
        aktparasymtable:=parast;
        aktlocalsymtable:=localst;
        { write address of this symbol }
        d.build(self);
        ppufile.putderef(d);
        { write refs }
        if assigned(lastwritten) then
          ref:=lastwritten
        else
          ref:=defref;
        while assigned(ref) do
         begin
           if ref.moduleindex=current_module.unit_index then
             begin
                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;
        ppufile.writeentry(ibdefref);
        write_references:=true;
        if ((current_module.flags and uf_local_browser)<>0) and
           assigned(localst) and
           locals then
          begin
             pdo:=_class;
             if (owner.symtabletype<>localsymtable) then
               while assigned(pdo) do
                 begin
                    if pdo.symtable<>aktrecordsymtable then
                      begin
                         pdo.symtable.unitid:=local_symtable_index;
                         inc(local_symtable_index);
                      end;
                    pdo:=pdo.childof;
                 end;
             parast.unitid:=local_symtable_index;
             inc(local_symtable_index);
             localst.unitid:=local_symtable_index;
             inc(local_symtable_index);
             tstoredsymtable(parast).write_references(ppufile,locals);
             tstoredsymtable(localst).write_references(ppufile,locals);
             { decrement for }
             local_symtable_index:=local_symtable_index-2;
             pdo:=_class;
             if (owner.symtabletype<>localsymtable) then
               while assigned(pdo) do
                 begin
                    if pdo.symtable<>aktrecordsymtable then
                      dec(local_symtable_index);
                    pdo:=pdo.childof;
                 end;
          end;
        aktparasymtable:=oldparasymtable;
        aktlocalsymtable:=oldlocalsymtable;
      end;

{$ifdef GDB}
    function tprocdef.numberstring : string;
      begin
        { procdefs are always available }
        stab_state:=stab_state_written;
        result:=inherited numberstring;
      end;


    function tprocdef.stabstring: pchar;
      Var
        RType : Char;
        Obj,Info : String;
        stabsstr : string;
        p : pchar;
      begin
        obj := procsym.name;
        info := '';
        if tprocsym(procsym).is_global then
          RType := 'F'
        else
          RType := 'f';
        if assigned(owner) then
         begin
           if (owner.symtabletype = objectsymtable) then
             obj := owner.name^+'__'+procsym.name;
           if not(cs_gdb_valgrind in aktglobalswitches) and
              (owner.symtabletype=localsymtable) and
              assigned(owner.defowner) and
              assigned(tprocdef(owner.defowner).procsym) then
             info := ','+procsym.name+','+tprocdef(owner.defowner).procsym.name;
         end;
        stabsstr:=mangledname;
        getmem(p,length(stabsstr)+255);
        strpcopy(p,'"'+obj+':'+RType
              +tstoreddef(rettype.def).numberstring+info+'",'+tostr(n_function)
              +',0,'+
              tostr(fileinfo.line)
              +',');
        strpcopy(strend(p),stabsstr);
        stabstring:=strnew(p);
        freemem(p,length(stabsstr)+255);
      end;


    procedure tprocdef.concatstabto(asmlist : taasmoutput);
      begin
        { released procdef? }
        if not assigned(parast) then
          exit;
        if (proccalloption=pocall_internproc) then
          exit;
        { be sure to have a number assigned for this def }
        numberstring;
        { write stabs }
        stab_state:=stab_state_writing;
        asmList.concat(Tai_stabs.Create(stabstring));
        if not(po_external in procoptions) then
          begin
            tparasymtable(parast).concatstabto(asmlist);
            { local type defs and vars should not be written
              inside the main proc stab }
            if assigned(localst) and
               (localst.symtabletype=localsymtable) then
              tlocalsymtable(localst).concatstabto(asmlist);
          end;
        stab_state:=stab_state_written;
      end;
{$endif GDB}


    procedure tprocdef.buildderef;
      var
        oldparasymtable,
        oldlocalsymtable : tsymtable;
      begin
         oldparasymtable:=aktparasymtable;
         oldlocalsymtable:=aktlocalsymtable;
         aktparasymtable:=parast;
         aktlocalsymtable:=localst;

         inherited buildderef;
         _classderef.build(_class);
         { procsym that originaly defined this definition, should be in the
           same symtable }
         procsymderef.build(procsym);
{$ifdef powerpc}
         { library symbol for AmigaOS/MorphOS }
         libsymderef.build(libsym);
{$endif powerpc}

         aktparasymtable:=oldparasymtable;
         aktlocalsymtable:=oldlocalsymtable;
      end;


    procedure tprocdef.buildderefimpl;
      var
        oldparasymtable,
        oldlocalsymtable : tsymtable;
      begin
         { released procdef? }
         if not assigned(parast) then
           exit;

         oldparasymtable:=aktparasymtable;
         oldlocalsymtable:=aktlocalsymtable;
         aktparasymtable:=parast;
         aktlocalsymtable:=localst;

         inherited buildderefimpl;

         { Locals }
         if assigned(localst) and
            ((po_has_inlininginfo in procoptions) or
             ((current_module.flags and uf_local_browser)<>0)) then
           begin
             tlocalsymtable(localst).buildderef;
             tlocalsymtable(localst).buildderefimpl;
           end;

         { inline tree }
         if (po_has_inlininginfo in procoptions) then
           begin
             funcretsymderef.build(funcretsym);
             inlininginfo^.code.buildderefimpl;
           end;

         aktparasymtable:=oldparasymtable;
         aktlocalsymtable:=oldlocalsymtable;
      end;


    procedure tprocdef.deref;
      var
        oldparasymtable,
        oldlocalsymtable : tsymtable;
      begin
         { released procdef? }
         if not assigned(parast) then
           exit;

         oldparasymtable:=aktparasymtable;
         oldlocalsymtable:=aktlocalsymtable;
         aktparasymtable:=parast;
         aktlocalsymtable:=localst;

         inherited deref;
         _class:=tobjectdef(_classderef.resolve);
         { procsym that originaly defined this definition, should be in the
           same symtable }
         procsym:=tprocsym(procsymderef.resolve);
{$ifdef powerpc}
         { library symbol for AmigaOS/MorphOS }
         libsym:=tsym(libsymderef.resolve);
{$endif powerpc}

         aktparasymtable:=oldparasymtable;
         aktlocalsymtable:=oldlocalsymtable;
      end;


    procedure tprocdef.derefimpl;
      var
        oldparasymtable,
        oldlocalsymtable : tsymtable;
      begin
         oldparasymtable:=aktparasymtable;
         oldlocalsymtable:=aktlocalsymtable;
         aktparasymtable:=parast;
         aktlocalsymtable:=localst;

         { Locals }
         if assigned(localst) then
          begin
            tlocalsymtable(localst).deref;
            tlocalsymtable(localst).derefimpl;
          end;

        { Inline }
        if (po_has_inlininginfo in procoptions) then
          begin
            inlininginfo^.code.derefimpl;
            { funcretsym, this is always located in the localst }
            funcretsym:=tsym(funcretsymderef.resolve);
          end
        else
          begin
            { safety }
            funcretsym:=nil;
          end;

        aktparasymtable:=oldparasymtable;
        aktlocalsymtable:=oldlocalsymtable;
      end;


    function tprocdef.gettypename : string;
      begin
         gettypename := FullProcName(false);
      end;


    function tprocdef.mangledname : string;
      var
        hp   : TParavarsym;
        hs   : string;
        crc  : dword;
        newlen,
        oldlen,
        i    : integer;
      begin
        if assigned(_mangledname) then
         begin
         {$ifdef compress}
           mangledname:=minilzw_decode(_mangledname^);
         {$else}
           mangledname:=_mangledname^;
         {$endif}
           exit;
         end;
        { we need to use the symtable where the procsym is inserted,
          because that is visible to the world }
        mangledname:=make_mangledname('',procsym.owner,procsym.name);
        oldlen:=length(mangledname);
        { add parameter types }
        for i:=0 to paras.count-1 do
         begin
           hp:=tparavarsym(paras[i]);
           if not(vo_is_hidden_para in hp.varoptions) then
             mangledname:=mangledname+'$'+hp.vartype.def.mangledparaname;
         end;
        { add resulttype, add $$ as separator to make it unique from a
          parameter separator }
        if not is_void(rettype.def) then
          mangledname:=mangledname+'$$'+rettype.def.mangledparaname;
        newlen:=length(mangledname);
        { Replace with CRC if the parameter line is very long }
        if (newlen-oldlen>12) and
           ((newlen>128) or (newlen-oldlen>64)) then
          begin
            crc:=$ffffffff;
            for i:=0 to paras.count-1 do
              begin
                hp:=tparavarsym(paras[i]);
                if not(vo_is_hidden_para in hp.varoptions) then
                  begin
                    hs:=hp.vartype.def.mangledparaname;
                    crc:=UpdateCrc32(crc,hs[1],length(hs));
                  end;
              end;
            hs:=hp.vartype.def.mangledparaname;
            crc:=UpdateCrc32(crc,hs[1],length(hs));
            mangledname:=Copy(mangledname,1,oldlen)+'$crc'+hexstr(crc,8);
          end;
       {$ifdef compress}
        _mangledname:=stringdup(minilzw_encode(mangledname));
       {$else}
        _mangledname:=stringdup(mangledname);
       {$endif}
      end;


    function tprocdef.cplusplusmangledname : string;

      function getcppparaname(p : tdef) : string;

        const
           ordtype2str : array[tbasetype] of string[2] = (
             '',
             'Uc','Us','Ui','Us',
             'Sc','s','i','x',
             'b','b','b',
             'c','w','x');

        var
           s : string;

        begin
           case p.deftype of
              orddef:
                s:=ordtype2str[torddef(p).typ];
              pointerdef:
                s:='P'+getcppparaname(tpointerdef(p).pointertype.def);
              else
                internalerror(2103001);
           end;
           getcppparaname:=s;
        end;

      var
         s,s2 : string;
         hp   : TParavarsym;
         i    : integer;

      begin
         s := procsym.realname;
         if procsym.owner.symtabletype=objectsymtable then
           begin
              s2:=upper(tobjectdef(procsym.owner.defowner).typesym.realname);
              case proctypeoption of
                 potype_destructor:
                   s:='_$_'+tostr(length(s2))+s2;
                 potype_constructor:
                   s:='___'+tostr(length(s2))+s2;
                 else
                   s:='_'+s+'__'+tostr(length(s2))+s2;
              end;

           end
         else s:=s+'__';

         s:=s+'F';

         { concat modifiers }
         { !!!!! }

         { now we handle the parameters }
         if maxparacount>0 then
           begin
             for i:=0 to paras.count-1 do
               begin
                 hp:=tparavarsym(paras[i]);
                 s2:=getcppparaname(hp.vartype.def);
                 if hp.varspez in [vs_var,vs_out] then
                   s2:='R'+s2;
                 s:=s+s2;
               end;
           end
         else
           s:=s+'v';
         cplusplusmangledname:=s;
      end;


    procedure tprocdef.setmangledname(const s : string);
      begin
        { This is not allowed anymore, the forward declaration
          already needs to create the correct mangledname, no changes
          afterwards are allowed (PFV) }
        if assigned(_mangledname) then
          internalerror(200411171);
      {$ifdef compress}
        _mangledname:=stringdup(minilzw_encode(s));
      {$else}
        _mangledname:=stringdup(s);
      {$endif}
        include(procoptions,po_has_mangledname);
      end;


{***************************************************************************
                                 TPROCVARDEF
***************************************************************************}

    constructor tprocvardef.create(level:byte);
      begin
         inherited create(level);
         deftype:=procvardef;
      end;


    constructor tprocvardef.ppuload(ppufile:tcompilerppufile);
      begin
         inherited ppuload(ppufile);
         deftype:=procvardef;
         { load para symtable }
         parast:=tparasymtable.create(unknown_level);
         tparasymtable(parast).ppuload(ppufile);
         parast.defowner:=self;
      end;


    function tprocvardef.getcopy : tstoreddef;
      begin
      {
          { saves a definition to the return type }
          rettype         : ttype;
          parast          : tsymtable;
          paras           : tparalist;
          proctypeoption  : tproctypeoption;
          proccalloption  : tproccalloption;
          procoptions     : tprocoptions;
          requiredargarea : aint;
          { number of user visibile parameters }
          maxparacount,
          minparacount    : byte;
{$ifdef i386}
          fpu_used        : longint;    { how many stack fpu must be empty }
{$endif i386}
          funcretloc : array[tcallercallee] of TLocation;
          has_paraloc_info : boolean; { paraloc info is available }

       tprocvardef = class(tabstractprocdef)
          constructor create(level:byte);
          constructor ppuload(ppufile:tcompilerppufile);
          function getcopy : tstoreddef;override;
       }
      end;


    procedure tprocvardef.ppuwrite(ppufile:tcompilerppufile);
      var
        oldparasymtable,
        oldlocalsymtable : tsymtable;
      begin
        oldparasymtable:=aktparasymtable;
        oldlocalsymtable:=aktlocalsymtable;
        aktparasymtable:=parast;
        aktlocalsymtable:=nil;

        { here we cannot get a real good value so just give something }
        { plausible (PM) }
        { a more secure way would be
          to allways store in a temp }
{$ifdef i386}
        if is_fpu(rettype.def) then
          fpu_used:={2}maxfpuregs
        else
          fpu_used:=0;
{$endif i386}
        inherited ppuwrite(ppufile);

        { Write this entry }
        ppufile.writeentry(ibprocvardef);

        { Save the para symtable, this is taken from the interface }
        tparasymtable(parast).ppuwrite(ppufile);

        aktparasymtable:=oldparasymtable;
        aktlocalsymtable:=oldlocalsymtable;
      end;


    procedure tprocvardef.buildderef;
      var
        oldparasymtable,
        oldlocalsymtable : tsymtable;
      begin
        oldparasymtable:=aktparasymtable;
        oldlocalsymtable:=aktlocalsymtable;
        aktparasymtable:=parast;
        aktlocalsymtable:=nil;

        inherited buildderef;

        aktparasymtable:=oldparasymtable;
        aktlocalsymtable:=oldlocalsymtable;
      end;


    procedure tprocvardef.deref;
      var
        oldparasymtable,
        oldlocalsymtable : tsymtable;
      begin
        oldparasymtable:=aktparasymtable;
        oldlocalsymtable:=aktlocalsymtable;
        aktparasymtable:=parast;
        aktlocalsymtable:=nil;

        inherited deref;

        aktparasymtable:=oldparasymtable;
        aktlocalsymtable:=oldlocalsymtable;
      end;


    function tprocvardef.getsymtable(t:tgetsymtable):tsymtable;
      begin
        case t of
          gs_para :
            getsymtable:=parast;
          else
            getsymtable:=nil;
        end;
      end;


    function tprocvardef.size : aint;
      begin
         if (po_methodpointer in procoptions) and
            not(po_addressonly in procoptions) then
           size:=2*sizeof(aint)
         else
           size:=sizeof(aint);
      end;


    function tprocvardef.is_methodpointer:boolean;
      begin
        result:=(po_methodpointer in procoptions);
      end;


    function tprocvardef.is_addressonly:boolean;
      begin
        result:=not(po_methodpointer in procoptions) or
                (po_addressonly in procoptions);
      end;


{$ifdef GDB}
    function tprocvardef.stabstring : pchar;
      var
         nss : pchar;
        { i   : longint; }
      begin
        { i := maxparacount; }
        getmem(nss,1024);
        { it is not a function but a function pointer !! (PM) }

        strpcopy(nss,'*f'+tstoreddef(rettype.def).numberstring{+','+tostr(i)});
        { this confuses gdb !!
          we should use 'F' instead of 'f' but
          as we use c++ language mode
          it does not like that either
          Please do not remove this part
          might be used once
          gdb for pascal is ready PM }
      {$ifdef disabled}
        param := para1;
        i := 0;
        while assigned(param) do
          begin
            inc(i);
            if param^.paratyp = vs_value then vartyp := '1' else vartyp := '0';
            {Here we have lost the parameter names !!}
            pst := strpnew('p'+tostr(i)+':'+param^.vartype.def.numberstring+','+vartyp+';');
            strcat(nss,pst);
            strdispose(pst);
            param := param^.next;
          end;
      {$endif}
        {strpcopy(strend(nss),';');}
        stabstring := strnew(nss);
        freemem(nss,1024);
      end;


    procedure tprocvardef.concatstabto(asmlist : taasmoutput);
      begin
        if (stab_state in [stab_state_writing,stab_state_written]) then
          exit;
        tstoreddef(rettype.def).concatstabto(asmlist);
        inherited concatstabto(asmlist);
      end;
{$endif GDB}


    procedure tprocvardef.write_rtti_data(rt:trttitype);

         procedure write_para(parasym:tparavarsym);
         var
           paraspec : byte;
         begin
           { only store user visible parameters }
           if not(vo_is_hidden_para in parasym.varoptions) then
             begin
               case parasym.varspez of
                 vs_value: paraspec := 0;
                 vs_const: paraspec := pfConst;
                 vs_var  : paraspec := pfVar;
                 vs_out  : paraspec := pfOut;
               end;
               { write flags for current parameter }
               rttiList.concat(Tai_const.Create_8bit(paraspec));
               { write name of current parameter }
               rttiList.concat(Tai_const.Create_8bit(length(parasym.realname)));
               rttiList.concat(Tai_string.Create(parasym.realname));

               { write name of type of current parameter }
               tstoreddef(parasym.vartype.def).write_rtti_name;
             end;
         end;

       var
         methodkind : byte;
         i : integer;
      begin
        if po_methodpointer in procoptions then
          begin
             { write method id and name }
             rttiList.concat(Tai_const.Create_8bit(tkmethod));
             write_rtti_name;

{$ifdef cpurequiresproperalignment}
             rttilist.concat(Tai_align.Create(sizeof(TConstPtrUInt)));
{$endif cpurequiresproperalignment}
             { write kind of method (can only be function or procedure)}
             if rettype.def = voidtype.def then
               methodkind := mkProcedure
             else
               methodkind := mkFunction;
             rttiList.concat(Tai_const.Create_8bit(methodkind));

             { get # of parameters }
             rttiList.concat(Tai_const.Create_8bit(maxparacount));

             { write parameter info. The parameters must be written in reverse order
               if this method uses right to left parameter pushing! }
             if proccalloption in pushleftright_pocalls then
               begin
                 for i:=0 to paras.count-1 do
                   write_para(tparavarsym(paras[i]));
               end
             else
               begin
                 for i:=paras.count-1 downto 0 do
                   write_para(tparavarsym(paras[i]));
               end;

             { write name of result type }
             tstoreddef(rettype.def).write_rtti_name;
          end;
      end;


    function tprocvardef.is_publishable : boolean;
      begin
         is_publishable:=(po_methodpointer in procoptions);
      end;


    function tprocvardef.gettypename : string;
      var
        s: string;
        showhidden : boolean;
      begin
{$ifdef EXTDEBUG}
         showhidden:=true;
{$else EXTDEBUG}
         showhidden:=false;
{$endif EXTDEBUG}
         s:='<';
         if po_classmethod in procoptions then
           s := s+'class method type of'
         else
           if po_addressonly in procoptions then
             s := s+'address of'
           else
             s := s+'procedure variable type of';
         if assigned(rettype.def) and
            (rettype.def<>voidtype.def) then
           s:=s+' function'+typename_paras(showhidden)+':'+rettype.def.gettypename
         else
           s:=s+' procedure'+typename_paras(showhidden);
         if po_methodpointer in procoptions then
           s := s+' of object';
         gettypename := s+';'+ProcCallOptionStr[proccalloption]+'>';
      end;


{***************************************************************************
                              TOBJECTDEF
***************************************************************************}


   constructor tobjectdef.create(ot : tobjectdeftype;const n : string;c : tobjectdef);
     begin
        inherited create;
        objecttype:=ot;
        deftype:=objectdef;
        objectoptions:=[];
        childof:=nil;
        symtable:=tobjectsymtable.create(n,aktpackrecords);
        { create space for vmt !! }
        vmt_offset:=0;
        symtable.defowner:=self;
        lastvtableindex:=0;
        set_parent(c);
        objname:=stringdup(upper(n));
        objrealname:=stringdup(n);
        if objecttype in [odt_interfacecorba,odt_interfacecom] then
          prepareguid;
        { setup implemented interfaces }
        if objecttype in [odt_class,odt_interfacecorba] then
          implementedinterfaces:=timplementedinterfaces.create
        else
          implementedinterfaces:=nil;

{$ifdef GDB}
        writing_class_record_stab:=false;
{$endif GDB}
     end;


    constructor tobjectdef.ppuload(ppufile:tcompilerppufile);
      var
         i,implintfcount: longint;
         d : tderef;
      begin
         inherited ppuloaddef(ppufile);
         deftype:=objectdef;
         objecttype:=tobjectdeftype(ppufile.getbyte);
         objrealname:=stringdup(ppufile.getstring);
         objname:=stringdup(upper(objrealname^));
         symtable:=tobjectsymtable.create(objrealname^,0);
         tobjectsymtable(symtable).datasize:=ppufile.getaint;
         tobjectsymtable(symtable).fieldalignment:=ppufile.getbyte;
         tobjectsymtable(symtable).recordalignment:=ppufile.getbyte;
         vmt_offset:=ppufile.getlongint;
         ppufile.getderef(childofderef);
         ppufile.getsmallset(objectoptions);

         { load guid }
         iidstr:=nil;
         if objecttype in [odt_interfacecom,odt_interfacecorba] then
           begin
              new(iidguid);
              ppufile.getguid(iidguid^);
              iidstr:=stringdup(ppufile.getstring);
              lastvtableindex:=ppufile.getlongint;
           end;

         { load implemented interfaces }
         if objecttype in [odt_class,odt_interfacecorba] then
           begin
             implementedinterfaces:=timplementedinterfaces.create;
             implintfcount:=ppufile.getlongint;
             for i:=1 to implintfcount do
               begin
                  ppufile.getderef(d);
                  implementedinterfaces.addintf_deref(d,ppufile.getlongint);
               end;
           end
         else
           implementedinterfaces:=nil;

         tobjectsymtable(symtable).ppuload(ppufile);

         symtable.defowner:=self;

         { handles the predefined class tobject  }
         { the last TOBJECT which is loaded gets }
         { it !                                  }
         if (childof=nil) and
            (objecttype=odt_class) and
            (objname^='TOBJECT') then
           class_tobject:=self;
         if (childof=nil) and
            (objecttype=odt_interfacecom) and
            (objname^='IUNKNOWN') then
           interface_iunknown:=self;
{$ifdef GDB}
         writing_class_record_stab:=false;
{$endif GDB}
       end;

    destructor tobjectdef.destroy;
      begin
         if assigned(symtable) then
           symtable.free;
         stringdispose(objname);
         stringdispose(objrealname);
         if assigned(iidstr) then
           stringdispose(iidstr);
         if assigned(implementedinterfaces) then
           implementedinterfaces.free;
         if assigned(iidguid) then
           dispose(iidguid);
         inherited destroy;
      end;


    function tobjectdef.getcopy : tstoreddef;
      begin
        result:=inherited getcopy;
      {
        result:=tobjectdef.create(objecttype,objname^,childof);
          childofderef  : tderef;
          objname,
          objrealname   : pstring;
          objectoptions : tobjectoptions;
          { to be able to have a variable vmt position }
          { and no vmt field for objects without virtuals }
          vmt_offset : longint;
{$ifdef GDB}
          writing_class_record_stab : boolean;
{$endif GDB}
          objecttype : tobjectdeftype;
          iidguid: pguid;
          iidstr: pstring;
          lastvtableindex: longint;
          { store implemented interfaces defs and name mappings }
          implementedinterfaces: timplementedinterfaces;
      }
      end;


    procedure tobjectdef.ppuwrite(ppufile:tcompilerppufile);
      var
         implintfcount : longint;
         i : longint;
      begin
         inherited ppuwritedef(ppufile);
         ppufile.putbyte(byte(objecttype));
         ppufile.putstring(objrealname^);
         ppufile.putaint(tobjectsymtable(symtable).datasize);
         ppufile.putbyte(tobjectsymtable(symtable).fieldalignment);
         ppufile.putbyte(tobjectsymtable(symtable).recordalignment);
         ppufile.putlongint(vmt_offset);
         ppufile.putderef(childofderef);
         ppufile.putsmallset(objectoptions);
         if objecttype in [odt_interfacecom,odt_interfacecorba] then
           begin
              ppufile.putguid(iidguid^);
              ppufile.putstring(iidstr^);
              ppufile.putlongint(lastvtableindex);
           end;

         if objecttype in [odt_class,odt_interfacecorba] then
           begin
              implintfcount:=implementedinterfaces.count;
              ppufile.putlongint(implintfcount);
              for i:=1 to implintfcount do
                begin
                   ppufile.putderef(implementedinterfaces.interfacesderef(i));
                   ppufile.putlongint(implementedinterfaces.ioffsets(i));
                end;
           end;

         ppufile.writeentry(ibobjectdef);

         tobjectsymtable(symtable).ppuwrite(ppufile);
      end;


    function tobjectdef.gettypename:string;
      begin
        gettypename:=typename;
      end;


    procedure tobjectdef.buildderef;
      var
         oldrecsyms : tsymtable;
      begin
         inherited buildderef;
         childofderef.build(childof);
         oldrecsyms:=aktrecordsymtable;
         aktrecordsymtable:=symtable;
         tstoredsymtable(symtable).buildderef;
         aktrecordsymtable:=oldrecsyms;
         if objecttype in [odt_class,odt_interfacecorba] then
           implementedinterfaces.buildderef;
      end;


    procedure tobjectdef.deref;
      var
         oldrecsyms : tsymtable;
      begin
         inherited deref;
         childof:=tobjectdef(childofderef.resolve);
         oldrecsyms:=aktrecordsymtable;
         aktrecordsymtable:=symtable;
         tstoredsymtable(symtable).deref;
         aktrecordsymtable:=oldrecsyms;
         if objecttype in [odt_class,odt_interfacecorba] then
           implementedinterfaces.deref;
      end;


    function tobjectdef.getparentdef:tdef;
      begin
        result:=childof;
      end;


    procedure tobjectdef.prepareguid;
      begin
        { set up guid }
        if not assigned(iidguid) then
         begin
            new(iidguid);
            fillchar(iidguid^,sizeof(iidguid^),0); { default null guid }
         end;
        { setup iidstring }
        if not assigned(iidstr) then
          iidstr:=stringdup(''); { default is empty string }
      end;


    procedure tobjectdef.set_parent( c : tobjectdef);
      begin
        { nothing to do if the parent was not forward !}
        if assigned(childof) then
          exit;
        childof:=c;
        { some options are inherited !! }
        if assigned(c) then
          begin
             { only important for classes }
             lastvtableindex:=c.lastvtableindex;
             objectoptions:=objectoptions+(c.objectoptions*
               [oo_has_virtual,oo_has_private,oo_has_protected,
                oo_has_constructor,oo_has_destructor]);
             if not (objecttype in [odt_interfacecom,odt_interfacecorba]) then
               begin
                  { add the data of the anchestor class }
                  inc(tobjectsymtable(symtable).datasize,tobjectsymtable(c.symtable).datasize);
                  if (oo_has_vmt in objectoptions) and
                     (oo_has_vmt in c.objectoptions) then
                    dec(tobjectsymtable(symtable).datasize,sizeof(aint));
                  { if parent has a vmt field then
                    the offset is the same for the child PM }
                  if (oo_has_vmt in c.objectoptions) or is_class(self) then
                    begin
                       vmt_offset:=c.vmt_offset;
                       include(objectoptions,oo_has_vmt);
                    end;
               end;
          end;
      end;


   procedure tobjectdef.insertvmt;
     begin
        if objecttype in [odt_interfacecom,odt_interfacecorba] then
          exit;
        if (oo_has_vmt in objectoptions) then
          internalerror(12345)
        else
          begin
             tobjectsymtable(symtable).datasize:=align(tobjectsymtable(symtable).datasize,
                 tobjectsymtable(symtable).fieldalignment);

{$ifdef cpurequiresproperalignment}
             tobjectsymtable(symtable).datasize:=align(tobjectsymtable(symtable).datasize,sizeof(aint));
{$endif cpurequiresproperalignment}

             vmt_offset:=tobjectsymtable(symtable).datasize;
             inc(tobjectsymtable(symtable).datasize,sizeof(aint));
             include(objectoptions,oo_has_vmt);
          end;
     end;



   procedure tobjectdef.check_forwards;
     begin
        if not(objecttype in [odt_interfacecom,odt_interfacecorba]) then
          tstoredsymtable(symtable).check_forwards;
        if (oo_is_forward in objectoptions) then
          begin
             { ok, in future, the forward can be resolved }
             Message1(sym_e_class_forward_not_resolved,objrealname^);
             exclude(objectoptions,oo_is_forward);
          end;
     end;


   { true, if self inherits from d (or if they are equal) }
   function tobjectdef.is_related(d : tobjectdef) : boolean;
     var
        hp : tobjectdef;
     begin
        hp:=self;
        while assigned(hp) do
          begin
             if hp=d then
               begin
                  is_related:=true;
                  exit;
               end;
             hp:=hp.childof;
          end;
        is_related:=false;
     end;


(*   procedure tobjectdef._searchdestructor(sym : tnamedindexitem;arg:pointer);

     var
        p : pprocdeflist;

     begin
        { if we found already a destructor, then we exit }
        if assigned(sd) then
          exit;
        if tsym(sym).typ=procsym then
          begin
             p:=tprocsym(sym).defs;
             while assigned(p) do
               begin
                  if p^.def.proctypeoption=potype_destructor then
                    begin
                       sd:=p^.def;
                       exit;
                    end;
                  p:=p^.next;
               end;
          end;
     end;*)

    procedure _searchdestructor(sym:Tnamedindexitem;sd:pointer);

    begin
        { if we found already a destructor, then we exit }
        if (ppointer(sd)^=nil) and
           (Tsym(sym).typ=procsym) then
          ppointer(sd)^:=Tprocsym(sym).search_procdef_bytype(potype_destructor);
    end;

   function tobjectdef.searchdestructor : tprocdef;

     var
        o : tobjectdef;
        sd : tprocdef;
     begin
        searchdestructor:=nil;
        o:=self;
        sd:=nil;
        while assigned(o) do
          begin
             o.symtable.foreach_static(@_searchdestructor,@sd);
             if assigned(sd) then
               begin
                  searchdestructor:=sd;
                  exit;
               end;
             o:=o.childof;
          end;
     end;


    function tobjectdef.size : aint;
      begin
        if objecttype in [odt_class,odt_interfacecom,odt_interfacecorba] then
          result:=sizeof(aint)
        else
          result:=tobjectsymtable(symtable).datasize;
      end;


    function tobjectdef.alignment:longint;
      begin
        if objecttype in [odt_class,odt_interfacecom,odt_interfacecorba] then
          alignment:=sizeof(aint)
        else
          alignment:=tobjectsymtable(symtable).recordalignment;
      end;


    function tobjectdef.vmtmethodoffset(index:longint):longint;
      begin
        { for offset of methods for classes, see rtl/inc/objpash.inc }
        case objecttype of
        odt_class:
          { the +2*sizeof(Aint) is size and -size }
          vmtmethodoffset:=(index+10)*sizeof(aint)+2*sizeof(AInt);
        odt_interfacecom,odt_interfacecorba:
          vmtmethodoffset:=index*sizeof(aint);
        else
{$ifdef WITHDMT}
          vmtmethodoffset:=(index+4)*sizeof(aint);
{$else WITHDMT}
          vmtmethodoffset:=(index+3)*sizeof(aint);
{$endif WITHDMT}
        end;
      end;


    function tobjectdef.vmt_mangledname : string;
      begin
        if not(oo_has_vmt in objectoptions) then
          Message1(parser_n_object_has_no_vmt,objrealname^);
        vmt_mangledname:=make_mangledname('VMT',owner,objname^);
      end;


    function tobjectdef.rtti_name : string;
      begin
        rtti_name:=make_mangledname('RTTI',owner,objname^);
      end;


{$ifdef GDB}
    procedure tobjectdef.proc_addname(p :tnamedindexitem;arg:pointer);
      var virtualind,argnames : string;
          newrec : pchar;
          pd     : tprocdef;
          lindex : longint;
          arglength : byte;
          sp : char;
          state:^Trecord_stabgen_state;
          olds:integer;
          i : integer;
          parasym : tparavarsym;
      begin
        state:=arg;
        if tsym(p).typ = procsym then
         begin
           pd := tprocsym(p).first_procdef;
           if (po_virtualmethod in pd.procoptions) then
             begin
               lindex := pd.extnumber;
               {doesnt seem to be necessary
               lindex := lindex or $80000000;}
               virtualind := '*'+tostr(lindex)+';'+pd._class.classnumberstring+';'
             end
            else
             virtualind := '.';

            { used by gdbpas to recognize constructor and destructors }
            if (pd.proctypeoption=potype_constructor) then
              argnames:='__ct__'
            else if (pd.proctypeoption=potype_destructor) then
              argnames:='__dt__'
            else
              argnames := '';

           { arguments are not listed here }
           {we don't need another definition}
            for i:=0 to pd.paras.count-1 do
              begin
                parasym:=tparavarsym(pd.paras[i]);
                if Parasym.vartype.def.deftype = formaldef then
                  begin
                    case Parasym.varspez of
                      vs_var :
                        argnames := argnames+'3var';
                      vs_const :
                        argnames:=argnames+'5const';
                      vs_out :
                        argnames:=argnames+'3out';
                    end;
                  end
                else
                  begin
                    { if the arg definition is like (v: ^byte;..
                    there is no sym attached to data !!! }
                    if assigned(Parasym.vartype.def.typesym) then
                      begin
                        arglength := length(Parasym.vartype.def.typesym.name);
                        argnames := argnames + tostr(arglength)+Parasym.vartype.def.typesym.name;
                      end
                    else
                      argnames:=argnames+'11unnamedtype';
                  end;
              end;
           { here 2A must be changed for private and protected }
           { 0 is private 1 protected and 2 public }
           if (sp_private in tsym(p).symoptions) then
             sp:='0'
           else if (sp_protected in tsym(p).symoptions) then
             sp:='1'
           else
             sp:='2';
           newrec:=stabstr_evaluate('$1::$2=##$3;:$4;$5A$6;',[p.name,pd.numberstring,
                                    Tstoreddef(pd.rettype.def).numberstring,argnames,sp,
                                    virtualind]);
           { get spare place for a string at the end }
           olds:=state^.stabsize;
           inc(state^.stabsize,strlen(newrec));
           if state^.stabsize>=state^.staballoc-256 then
             begin
                inc(state^.staballoc,memsizeinc);
                reallocmem(state^.stabstring,state^.staballoc);
             end;
           strcopy(state^.stabstring+olds,newrec);
           strdispose(newrec);
           {This should be used for case !!
           RecOffset := RecOffset + pd.size;}
         end;
      end;


    procedure tobjectdef.proc_concatstabto(p :tnamedindexitem;arg:pointer);
      var
        pd : tprocdef;
      begin
        if tsym(p).typ = procsym then
          begin
            pd := tprocsym(p).first_procdef;
            tstoreddef(pd.rettype.def).concatstabto(taasmoutput(arg));
          end;
      end;


    function tobjectdef.stabstring : pchar;
      var anc : tobjectdef;
          state:Trecord_stabgen_state;
          ts : string;
      begin
        if not (objecttype=odt_class) or writing_class_record_stab then
          begin
            state.staballoc:=memsizeinc;
            getmem(state.stabstring,state.staballoc);
            strpcopy(state.stabstring,'s'+tostr(tobjectsymtable(symtable).datasize));
            if assigned(childof) then
              begin
                {only one ancestor not virtual, public, at base offset 0 }
                {       !1           ,    0       2         0    ,       }
                strpcopy(strend(state.stabstring),'!1,020,'+childof.classnumberstring+';');
              end;
            {virtual table to implement yet}
            state.recoffset:=0;
            state.stabsize:=strlen(state.stabstring);
            symtable.foreach(@field_addname,@state);
            if (oo_has_vmt in objectoptions) then
              if not assigned(childof) or not(oo_has_vmt in childof.objectoptions) then
                 begin
                    ts:='$vf'+classnumberstring+':'+tstoreddef(vmtarraytype.def).numberstring+','+tostr(vmt_offset*8)+';';
                    strpcopy(state.stabstring+state.stabsize,ts);
                    inc(state.stabsize,length(ts));
                 end;
            symtable.foreach(@proc_addname,@state);
            if (oo_has_vmt in objectoptions) then
              begin
                 anc := self;
                 while assigned(anc.childof) and (oo_has_vmt in anc.childof.objectoptions) do
                   anc := anc.childof;
                 { just in case anc = self }
                 ts:=';~%'+anc.classnumberstring+';';
              end
            else
              ts:=';';
            strpcopy(state.stabstring+state.stabsize,ts);
            inc(state.stabsize,length(ts));
            reallocmem(state.stabstring,state.stabsize+1);
            stabstring:=state.stabstring;
          end
        else
          begin
            stabstring:=strpnew('*'+classnumberstring);
          end;
      end;

   procedure tobjectdef.set_globalnb;
     begin
         globalnb:=PglobalTypeCount^;
         inc(PglobalTypeCount^);
         { classes need two type numbers, the globalnb is set to the ptr }
         if objecttype=odt_class then
           begin
             globalnb:=PGlobalTypeCount^;
             inc(PglobalTypeCount^);
           end;
     end;


   function tobjectdef.classnumberstring : string;
     begin
       if objecttype=odt_class then
         begin
           if globalnb=0 then
             numberstring;
           dec(globalnb);
           classnumberstring:=numberstring;
           inc(globalnb);
         end
       else
         classnumberstring:=numberstring;
     end;


    function tobjectdef.allstabstring : pchar;
      var
        stabchar : string[2];
        ss,st : pchar;
        sname : string;
      begin
        ss := stabstring;
        getmem(st,strlen(ss)+512);
        stabchar := 't';
        if deftype in tagtypes then
          stabchar := 'Tt';
        if assigned(typesym) then
          sname := typesym.name
        else
          sname := ' ';
        if writing_class_record_stab then
          strpcopy(st,'"'+sname+':'+stabchar+classnumberstring+'=')
        else
          strpcopy(st,'"'+sname+':'+stabchar+numberstring+'=');
        strpcopy(strecopy(strend(st),ss),'",'+tostr(N_LSYM)+',0,0,0');
        allstabstring := strnew(st);
        freemem(st,strlen(ss)+512);
        strdispose(ss);
      end;


    procedure tobjectdef.concatstabto(asmlist : taasmoutput);
      var
        oldtypesym : tsym;
        stab_str   : pchar;
        anc        : tobjectdef;
      begin
        if (stab_state in [stab_state_writing,stab_state_written]) then
          exit;
        stab_state:=stab_state_writing;
        tstoreddef(vmtarraytype.def).concatstabto(asmlist);
        { first the parents }
        anc:=self;
        while assigned(anc.childof) do
          begin
            anc:=anc.childof;
            anc.concatstabto(asmlist);
          end;
        symtable.foreach(@field_concatstabto,asmlist);
        symtable.foreach(@proc_concatstabto,asmlist);
        stab_state:=stab_state_used;
        if objecttype=odt_class then
          begin
            { Write the record class itself }
            writing_class_record_stab:=true;
            inherited concatstabto(asmlist);
            writing_class_record_stab:=false;
            { Write the invisible pointer class }
            oldtypesym:=typesym;
            typesym:=nil;
            stab_str := allstabstring;
            asmList.concat(Tai_stabs.Create(stab_str));
            typesym:=oldtypesym;
          end
        else
          inherited concatstabto(asmlist);
      end;
{$endif GDB}


    function tobjectdef.needs_inittable : boolean;
      begin
         case objecttype of
            odt_class :
              needs_inittable:=false;
            odt_interfacecom:
              needs_inittable:=true;
            odt_interfacecorba:
              needs_inittable:=is_related(interface_iunknown);
            odt_object:
              needs_inittable:=tobjectsymtable(symtable).needs_init_final;
            else
              internalerror(200108267);
         end;
      end;


    function tobjectdef.members_need_inittable : boolean;
      begin
        members_need_inittable:=tobjectsymtable(symtable).needs_init_final;
      end;


    procedure tobjectdef.count_published_properties(sym:tnamedindexitem;arg:pointer);
      begin
         if needs_prop_entry(tsym(sym)) and
            (tsym(sym).typ<>fieldvarsym) then
           inc(count);
      end;


    procedure tobjectdef.write_property_info(sym : tnamedindexitem;arg:pointer);
      var
         proctypesinfo : byte;

      procedure writeproc(proc : tsymlist; shiftvalue : byte);

        var
           typvalue : byte;
           hp : psymlistitem;
           address : longint;
           def : tdef;
        begin
           if not(assigned(proc) and assigned(proc.firstsym))  then
             begin
                rttiList.concat(Tai_const.create(ait_const_ptr,1));
                typvalue:=3;
             end
           else if proc.firstsym^.sym.typ=fieldvarsym then
             begin
                address:=0;
                hp:=proc.firstsym;
                def:=nil;
                while assigned(hp) do
                  begin
                     case hp^.sltype of
                       sl_load :
                         begin
                           def:=tfieldvarsym(hp^.sym).vartype.def;
                           inc(address,tfieldvarsym(hp^.sym).fieldoffset);
                         end;
                       sl_subscript :
                         begin
                           if not(assigned(def) and (def.deftype=recorddef)) then
                             internalerror(200402171);
                           inc(address,tfieldvarsym(hp^.sym).fieldoffset);
                           def:=tfieldvarsym(hp^.sym).vartype.def;
                         end;
                       sl_vec :
                         begin
                           if not(assigned(def) and (def.deftype=arraydef)) then
                             internalerror(200402172);
                           def:=tarraydef(def).elementtype.def;
                           inc(address,def.size*hp^.value);
                         end;
                     end;
                     hp:=hp^.next;
                  end;
                rttiList.concat(Tai_const.create(ait_const_ptr,address));
                typvalue:=0;
             end
           else
             begin
                { When there was an error then procdef is not assigned }
                if not assigned(proc.procdef) then
                  exit;
                if not(po_virtualmethod in tprocdef(proc.procdef).procoptions) then
                  begin
                     rttiList.concat(Tai_const.createname(tprocdef(proc.procdef).mangledname,AT_FUNCTION,0));
                     typvalue:=1;
                  end
                else
                  begin
                     { virtual method, write vmt offset }
                     rttiList.concat(Tai_const.create(ait_const_ptr,
                       tprocdef(proc.procdef)._class.vmtmethodoffset(tprocdef(proc.procdef).extnumber)));
                     typvalue:=2;
                  end;
             end;
           proctypesinfo:=proctypesinfo or (typvalue shl shiftvalue);
        end;

      begin
         if needs_prop_entry(tsym(sym)) then
           case tsym(sym).typ of
              fieldvarsym:
                begin
{$ifdef dummy}
                   if not(tvarsym(sym).vartype.def.deftype=objectdef) or
                     not(tobjectdef(tvarsym(sym).vartype.def).is_class) then
                     internalerror(1509992);
                   { access to implicit class property as field }
                   proctypesinfo:=(0 shl 0) or (0 shl 2) or (0 shl 4);
                   rttiList.concat(Tai_const_symbol.Createname(tvarsym(sym.vartype.def.get_rtti_label),AT_DATA,0));
                   rttiList.concat(Tai_const.create(ait_const_ptr,tvarsym(sym.address)));
                   rttiList.concat(Tai_const.create(ait_const_ptr,tvarsym(sym.address)));
                   { by default stored }
                   rttiList.concat(Tai_const.Create_32bit(1));
                   { index as well as ... }
                   rttiList.concat(Tai_const.Create_32bit(0));
                   { default value are zero }
                   rttiList.concat(Tai_const.Create_32bit(0));
                   rttiList.concat(Tai_const.Create_16bit(count));
                   inc(count);
                   rttiList.concat(Tai_const.Create_8bit(proctypesinfo));
                   rttiList.concat(Tai_const.Create_8bit(length(tvarsym(sym.realname))));
                   rttiList.concat(Tai_string.Create(tvarsym(sym.realname)));
{$endif dummy}
                end;
              propertysym:
                begin
                   if ppo_indexed in tpropertysym(sym).propoptions then
                     proctypesinfo:=$40
                   else
                     proctypesinfo:=0;
                   rttiList.concat(Tai_const.Create_sym(tstoreddef(tpropertysym(sym).proptype.def).get_rtti_label(fullrtti)));
                   writeproc(tpropertysym(sym).readaccess,0);
                   writeproc(tpropertysym(sym).writeaccess,2);
                   { isn't it stored ? }
                   if not(ppo_stored in tpropertysym(sym).propoptions) then
                     begin
                        rttiList.concat(Tai_const.create_sym(nil));
                        proctypesinfo:=proctypesinfo or (3 shl 4);
                     end
                   else
                     writeproc(tpropertysym(sym).storedaccess,4);
                   rttiList.concat(Tai_const.Create_32bit(tpropertysym(sym).index));
                   rttiList.concat(Tai_const.Create_32bit(tpropertysym(sym).default));
                   rttiList.concat(Tai_const.Create_16bit(count));
                   inc(count);
                   rttiList.concat(Tai_const.Create_8bit(proctypesinfo));
                   rttiList.concat(Tai_const.Create_8bit(length(tpropertysym(sym).realname)));
                   rttiList.concat(Tai_string.Create(tpropertysym(sym).realname));
{$ifdef cpurequiresproperalignment}
                   rttilist.concat(Tai_align.Create(sizeof(TConstPtrUInt)));
{$endif cpurequiresproperalignment}
                end;
              else internalerror(1509992);
           end;
      end;


    procedure tobjectdef.generate_published_child_rtti(sym : tnamedindexitem;arg:pointer);
      begin
         if needs_prop_entry(tsym(sym)) then
          begin
            case tsym(sym).typ of
              propertysym:
                tstoreddef(tpropertysym(sym).proptype.def).get_rtti_label(fullrtti);
              fieldvarsym:
                tstoreddef(tfieldvarsym(sym).vartype.def).get_rtti_label(fullrtti);
              else
                internalerror(1509991);
            end;
          end;
      end;


    procedure tobjectdef.write_child_rtti_data(rt:trttitype);
      begin
         FRTTIType:=rt;
         case rt of
           initrtti :
             symtable.foreach(@generate_field_rtti,nil);
           fullrtti :
             symtable.foreach(@generate_published_child_rtti,nil);
           else
             internalerror(200108301);
         end;
      end;


    type
       tclasslistitem = class(TLinkedListItem)
          index : longint;
          p : tobjectdef;
       end;

    var
       classtablelist : tlinkedlist;
       tablecount : longint;

    function searchclasstablelist(p : tobjectdef) : tclasslistitem;

      var
         hp : tclasslistitem;

      begin
         hp:=tclasslistitem(classtablelist.first);
         while assigned(hp) do
           if hp.p=p then
             begin
                searchclasstablelist:=hp;
                exit;
             end
           else
             hp:=tclasslistitem(hp.next);
         searchclasstablelist:=nil;
      end;


    procedure tobjectdef.count_published_fields(sym:tnamedindexitem;arg:pointer);
      var
         hp : tclasslistitem;
      begin
         if needs_prop_entry(tsym(sym)) and
          (tsym(sym).typ=fieldvarsym) then
          begin
             if tfieldvarsym(sym).vartype.def.deftype<>objectdef then
               internalerror(0206001);
             hp:=searchclasstablelist(tobjectdef(tfieldvarsym(sym).vartype.def));
             if not(assigned(hp)) then
               begin
                  hp:=tclasslistitem.create;
                  hp.p:=tobjectdef(tfieldvarsym(sym).vartype.def);
                  hp.index:=tablecount;
                  classtablelist.concat(hp);
                  inc(tablecount);
               end;
             inc(count);
          end;
      end;


    procedure tobjectdef.writefields(sym:tnamedindexitem;arg:pointer);
      var
         hp : tclasslistitem;
      begin
         if needs_prop_entry(tsym(sym)) and
          (tsym(sym).typ=fieldvarsym) then
          begin
{$ifdef cpurequiresproperalignment}
             rttilist.concat(Tai_align.Create(sizeof(TConstPtrUInt)));
{$endif cpurequiresproperalignment}
             rttiList.concat(Tai_const.Create_32bit(tfieldvarsym(sym).fieldoffset));
             hp:=searchclasstablelist(tobjectdef(tfieldvarsym(sym).vartype.def));
             if not(assigned(hp)) then
               internalerror(0206002);
             rttiList.concat(Tai_const.Create_16bit(hp.index));
             rttiList.concat(Tai_const.Create_8bit(length(tfieldvarsym(sym).realname)));
             rttiList.concat(Tai_string.Create(tfieldvarsym(sym).realname));
          end;
      end;


    function tobjectdef.generate_field_table : tasmlabel;
      var
         fieldtable,
         classtable : tasmlabel;
         hp : tclasslistitem;

      begin
         classtablelist:=TLinkedList.Create;
         objectlibrary.getdatalabel(fieldtable);
         objectlibrary.getdatalabel(classtable);
         count:=0;
         tablecount:=0;
         maybe_new_object_file(rttiList);
         new_section(rttiList,sec_rodata,classtable.name,const_align(sizeof(aint)));
         { fields }
         symtable.foreach({$ifdef FPC}@{$endif}count_published_fields,nil);
         rttiList.concat(Tai_label.Create(fieldtable));
         rttiList.concat(Tai_const.Create_16bit(count));
{$ifdef cpurequiresproperalignment}
         rttilist.concat(Tai_align.Create(sizeof(TConstPtrUInt)));
{$endif cpurequiresproperalignment}
         rttiList.concat(Tai_const.Create_sym(classtable));
         symtable.foreach({$ifdef FPC}@{$endif}writefields,nil);

         { generate the class table }
         rttilist.concat(tai_align.create(const_align(sizeof(aint))));
         rttiList.concat(Tai_label.Create(classtable));
         rttiList.concat(Tai_const.Create_16bit(tablecount));
{$ifdef cpurequiresproperalignment}
         rttilist.concat(Tai_align.Create(sizeof(TConstPtrUInt)));
{$endif cpurequiresproperalignment}
         hp:=tclasslistitem(classtablelist.first);
         while assigned(hp) do
           begin
              rttiList.concat(Tai_const.Createname(tobjectdef(hp.p).vmt_mangledname,AT_DATA,0));
              hp:=tclasslistitem(hp.next);
           end;

         generate_field_table:=fieldtable;
         classtablelist.free;
      end;


    function tobjectdef.next_free_name_index : longint;
      var
         i : longint;
      begin
         if assigned(childof) and (oo_can_have_published in childof.objectoptions) then
           i:=childof.next_free_name_index
         else
           i:=0;
         count:=0;
         symtable.foreach(@count_published_properties,nil);
         next_free_name_index:=i+count;
      end;


    procedure tobjectdef.write_rtti_data(rt:trttitype);
      begin
         case objecttype of
            odt_class:
              rttiList.concat(Tai_const.Create_8bit(tkclass));
            odt_object:
              rttiList.concat(Tai_const.Create_8bit(tkobject));
            odt_interfacecom:
              rttiList.concat(Tai_const.Create_8bit(tkinterface));
            odt_interfacecorba:
              rttiList.concat(Tai_const.Create_8bit(tkinterfaceCorba));
          else
            exit;
          end;

         { generate the name }
         rttiList.concat(Tai_const.Create_8bit(length(objrealname^)));
         rttiList.concat(Tai_string.Create(objrealname^));
{$ifdef cpurequiresproperalignment}
         rttilist.concat(Tai_align.Create(sizeof(TConstPtrUInt)));
{$endif cpurequiresproperalignment}
         case rt of
           initrtti :
             begin
               rttiList.concat(Tai_const.Create_32bit(size));
               if objecttype in [odt_class,odt_object] then
                begin
                  count:=0;
                  FRTTIType:=rt;
                  symtable.foreach(@count_field_rtti,nil);
                  rttiList.concat(Tai_const.Create_32bit(count));
                  symtable.foreach(@write_field_rtti,nil);
                end;
             end;
           fullrtti :
             begin
               if (oo_has_vmt in objectoptions) and
                  not(objecttype in [odt_interfacecom,odt_interfacecorba]) then
                 rttiList.concat(Tai_const.Createname(vmt_mangledname,AT_DATA,0))
               else
                 rttiList.concat(Tai_const.create_sym(nil));

               { write owner typeinfo }
               if assigned(childof) and (oo_can_have_published in childof.objectoptions) then
                 rttiList.concat(Tai_const.Create_sym(childof.get_rtti_label(fullrtti)))
               else
                 rttiList.concat(Tai_const.create_sym(nil));

               { count total number of properties }
               if assigned(childof) and (oo_can_have_published in childof.objectoptions) then
                 count:=childof.next_free_name_index
               else
                 count:=0;

               { write it }
               symtable.foreach(@count_published_properties,nil);
               rttiList.concat(Tai_const.Create_16bit(count));

               { write unit name }
               rttiList.concat(Tai_const.Create_8bit(length(current_module.realmodulename^)));
               rttiList.concat(Tai_string.Create(current_module.realmodulename^));

{$ifdef cpurequiresproperalignment}
               rttilist.concat(Tai_align.Create(sizeof(TConstPtrUInt)));
{$endif cpurequiresproperalignment}

               { write published properties count }
               count:=0;
               symtable.foreach(@count_published_properties,nil);
               rttiList.concat(Tai_const.Create_16bit(count));

{$ifdef cpurequiresproperalignment}
               rttilist.concat(Tai_align.Create(sizeof(TConstPtrUInt)));
{$endif cpurequiresproperalignment}

               { count is used to write nameindex   }

               { but we need an offset of the owner }
               { to give each property an own slot  }
               if assigned(childof) and (oo_can_have_published in childof.objectoptions) then
                 count:=childof.next_free_name_index
               else
                 count:=0;

               symtable.foreach(@write_property_info,nil);
             end;
         end;
      end;


    function tobjectdef.is_publishable : boolean;
      begin
         is_publishable:=objecttype in [odt_class,odt_interfacecom,odt_interfacecorba];
      end;


{****************************************************************************
                             TIMPLEMENTEDINTERFACES
****************************************************************************}
    type
      tnamemap = class(TNamedIndexItem)
        newname: pstring;
        constructor create(const aname, anewname: string);
        destructor  destroy; override;
      end;

    constructor tnamemap.create(const aname, anewname: string);
      begin
        inherited createname(name);
        newname:=stringdup(anewname);
      end;

    destructor  tnamemap.destroy;
      begin
        stringdispose(newname);
        inherited destroy;
      end;


    type
      tprocdefstore = class(TNamedIndexItem)
        procdef: tprocdef;
        constructor create(aprocdef: tprocdef);
      end;

    constructor tprocdefstore.create(aprocdef: tprocdef);
      begin
        inherited create;
        procdef:=aprocdef;
      end;


    constructor timplintfentry.create(aintf: tobjectdef);
      begin
        inherited create;
        intf:=aintf;
        ioffset:=-1;
        namemappings:=nil;
        procdefs:=nil;
      end;


    constructor timplintfentry.create_deref(const d:tderef);
      begin
        inherited create;
        intf:=nil;
        intfderef:=d;
        ioffset:=-1;
        namemappings:=nil;
        procdefs:=nil;
      end;


    destructor  timplintfentry.destroy;
      begin
        if assigned(namemappings) then
          namemappings.free;
        if assigned(procdefs) then
          procdefs.free;
        inherited destroy;
      end;


    constructor timplementedinterfaces.create;
      begin
        finterfaces:=tindexarray.create(1);
      end;

    destructor  timplementedinterfaces.destroy;
      begin
        finterfaces.destroy;
      end;

    function  timplementedinterfaces.count: longint;
      begin
        count:=finterfaces.count;
      end;

    procedure timplementedinterfaces.checkindex(intfindex: longint);
      begin
        if (intfindex<1) or (intfindex>count) then
          InternalError(200006123);
      end;

    function  timplementedinterfaces.interfaces(intfindex: longint): tobjectdef;
      begin
        checkindex(intfindex);
        interfaces:=timplintfentry(finterfaces.search(intfindex)).intf;
      end;

    function  timplementedinterfaces.interfacesderef(intfindex: longint): tderef;
      begin
        checkindex(intfindex);
        interfacesderef:=timplintfentry(finterfaces.search(intfindex)).intfderef;
      end;

    function  timplementedinterfaces.ioffsets(intfindex: longint): longint;
      begin
        checkindex(intfindex);
        ioffsets:=timplintfentry(finterfaces.search(intfindex)).ioffset;
      end;

    procedure timplementedinterfaces.setioffsets(intfindex,iofs:longint);
      begin
        checkindex(intfindex);
        timplintfentry(finterfaces.search(intfindex)).ioffset:=iofs;
      end;

    function  timplementedinterfaces.searchintf(def: tdef): longint;
      var
        i: longint;
      begin
        i:=1;
        while (i<=count) and (tdef(interfaces(i))<>def) do inc(i);
        if i<=count then
          searchintf:=i
        else
          searchintf:=-1;
      end;


    procedure timplementedinterfaces.buildderef;
      var
        i: longint;
      begin
        for i:=1 to count do
          with timplintfentry(finterfaces.search(i)) do
            intfderef.build(intf);
      end;


    procedure timplementedinterfaces.deref;
      var
        i: longint;
      begin
        for i:=1 to count do
          with timplintfentry(finterfaces.search(i)) do
            intf:=tobjectdef(intfderef.resolve);
      end;

    procedure timplementedinterfaces.addintf_deref(const d:tderef;iofs:longint);
      var
        hintf : timplintfentry;
      begin
        hintf:=timplintfentry.create_deref(d);
        hintf.ioffset:=iofs;
        finterfaces.insert(hintf);
      end;

    procedure timplementedinterfaces.addintf(def: tdef);
      begin
        if not assigned(def) or (searchintf(def)<>-1) or (def.deftype<>objectdef) or
           not (tobjectdef(def).objecttype in [odt_interfacecom,odt_interfacecorba]) then
          internalerror(200006124);
        finterfaces.insert(timplintfentry.create(tobjectdef(def)));
      end;

    procedure timplementedinterfaces.clearmappings;
      var
        i: longint;
      begin
        for i:=1 to count do
          with timplintfentry(finterfaces.search(i)) do
            begin
              if assigned(namemappings) then
                namemappings.free;
              namemappings:=nil;
            end;
      end;

    procedure timplementedinterfaces.addmappings(intfindex: longint; const name, newname: string);
      begin
        checkindex(intfindex);
        with timplintfentry(finterfaces.search(intfindex)) do
          begin
            if not assigned(namemappings) then
              namemappings:=tdictionary.create;
            namemappings.insert(tnamemap.create(name,newname));
          end;
      end;

    function  timplementedinterfaces.getmappings(intfindex: longint; const name: string; var nextexist: pointer): string;
      begin
        checkindex(intfindex);
        if not assigned(nextexist) then
          with timplintfentry(finterfaces.search(intfindex)) do
            begin
              if assigned(namemappings) then
                nextexist:=namemappings.search(name)
              else
                nextexist:=nil;
            end;
        if assigned(nextexist) then
          begin
            getmappings:=tnamemap(nextexist).newname^;
            nextexist:=tnamemap(nextexist).listnext;
          end
        else
          getmappings:='';
      end;

    procedure timplementedinterfaces.clearimplprocs;
      var
        i: longint;
      begin
        for i:=1 to count do
          with timplintfentry(finterfaces.search(i)) do
            begin
              if assigned(procdefs) then
                procdefs.free;
              procdefs:=nil;
            end;
      end;

    procedure timplementedinterfaces.addimplproc(intfindex: longint; procdef: tprocdef);
      begin
        checkindex(intfindex);
        with timplintfentry(finterfaces.search(intfindex)) do
          begin
            if not assigned(procdefs) then
              procdefs:=tindexarray.create(4);
            procdefs.insert(tprocdefstore.create(procdef));
          end;
      end;

    function  timplementedinterfaces.implproccount(intfindex: longint): longint;
      begin
        checkindex(intfindex);
        with timplintfentry(finterfaces.search(intfindex)) do
          if assigned(procdefs) then
            implproccount:=procdefs.count
          else
            implproccount:=0;
      end;

    function  timplementedinterfaces.implprocs(intfindex: longint; procindex: longint): tprocdef;
      begin
        checkindex(intfindex);
        with timplintfentry(finterfaces.search(intfindex)) do
          if assigned(procdefs) then
            implprocs:=tprocdefstore(procdefs.search(procindex)).procdef
          else
            internalerror(200006131);
      end;

    function  timplementedinterfaces.isimplmergepossible(intfindex, remainindex: longint; var weight: longint): boolean;
      var
        possible: boolean;
        i: longint;
        iiep1: TIndexArray;
        iiep2: TIndexArray;
      begin
        checkindex(intfindex);
        checkindex(remainindex);
        iiep1:=timplintfentry(finterfaces.search(intfindex)).procdefs;
        iiep2:=timplintfentry(finterfaces.search(remainindex)).procdefs;
        if not assigned(iiep1) then { empty interface is mergeable :-) }
          begin
            possible:=true;
            weight:=0;
          end
        else
          begin
            possible:=assigned(iiep2) and (iiep1.count<=iiep2.count);
            i:=1;
            while (possible) and (i<=iiep1.count) do
              begin
                possible:=
                  (tprocdefstore(iiep1.search(i)).procdef=tprocdefstore(iiep2.search(i)).procdef);
                inc(i);
              end;
            if possible then
              weight:=iiep1.count;
          end;
        isimplmergepossible:=possible;
      end;


{****************************************************************************
                                TFORWARDDEF
****************************************************************************}

   constructor tforwarddef.create(const s:string;const pos : tfileposinfo);
     var
       oldregisterdef : boolean;
     begin
        { never register the forwarddefs, they are disposed at the
          end of the type declaration block }
        oldregisterdef:=registerdef;
        registerdef:=false;
        inherited create;
        registerdef:=oldregisterdef;
        deftype:=forwarddef;
        tosymname:=stringdup(s);
        forwardpos:=pos;
     end;


    function tforwarddef.gettypename:string;
      begin
        gettypename:='unresolved forward to '+tosymname^;
      end;

     destructor tforwarddef.destroy;
      begin
        if assigned(tosymname) then
          stringdispose(tosymname);
        inherited destroy;
      end;


{****************************************************************************
                                  TERRORDEF
****************************************************************************}

   constructor terrordef.create;
     begin
        inherited create;
        deftype:=errordef;
     end;


    procedure terrordef.ppuwrite(ppufile:tcompilerppufile);
      begin
        { Can't write errordefs to ppu }
        internalerror(200411063);
      end;


{$ifdef GDB}
    function terrordef.stabstring : pchar;
      begin
         stabstring:=strpnew('error'+numberstring);
      end;

    procedure terrordef.concatstabto(asmlist : taasmoutput);
      begin
        { No internal error needed, an normal error is already
          thrown }
      end;
{$endif GDB}

    function terrordef.gettypename:string;

      begin
         gettypename:='<erroneous type>';
      end;

    function terrordef.getmangledparaname:string;

      begin
         getmangledparaname:='error';
      end;


{****************************************************************************
                           Definition Helpers
****************************************************************************}

    function is_interfacecom(def: tdef): boolean;
      begin
        is_interfacecom:=
          assigned(def) and
          (def.deftype=objectdef) and
          (tobjectdef(def).objecttype=odt_interfacecom);
      end;

    function is_interfacecorba(def: tdef): boolean;
      begin
        is_interfacecorba:=
          assigned(def) and
          (def.deftype=objectdef) and
          (tobjectdef(def).objecttype=odt_interfacecorba);
      end;

    function is_interface(def: tdef): boolean;
      begin
        is_interface:=
          assigned(def) and
          (def.deftype=objectdef) and
          (tobjectdef(def).objecttype in [odt_interfacecom,odt_interfacecorba]);
      end;


    function is_class(def: tdef): boolean;
      begin
        is_class:=
          assigned(def) and
          (def.deftype=objectdef) and
          (tobjectdef(def).objecttype=odt_class);
      end;

    function is_object(def: tdef): boolean;
      begin
        is_object:=
          assigned(def) and
          (def.deftype=objectdef) and
          (tobjectdef(def).objecttype=odt_object);
      end;

    function is_cppclass(def: tdef): boolean;
      begin
        is_cppclass:=
          assigned(def) and
          (def.deftype=objectdef) and
          (tobjectdef(def).objecttype=odt_cppclass);
      end;

    function is_class_or_interface(def: tdef): boolean;
      begin
        is_class_or_interface:=
          assigned(def) and
          (def.deftype=objectdef) and
          (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba]);
      end;

end.
{
  $Log$
  Revision 1.289  2005-01-16 14:47:26  florian
    * typeinfo in typedata is now aligned

  Revision 1.288  2005/01/09 15:05:29  peter
    * fix interface vtbl optimization
    * replace ugly pointer construct of ioffset()

  Revision 1.287  2005/01/03 17:55:57  florian
    + first batch of patches to support tdef.getcopy fully

  Revision 1.286  2004/12/30 14:36:29  florian
    * alignment fixes for sparc

  Revision 1.285  2004/12/27 15:54:54  florian
    * fixed class field info alignment

  Revision 1.284  2004/12/07 15:41:11  peter
    * modified algorithm for shortening manglednames to fix compilation
      of procedures with a lot of longtypenames that are equal, see
      tw343

  Revision 1.283  2004/12/07 13:52:54  michael
    * Convert array of widechar to pwidechar instead of pchar

  Revision 1.282  2004/12/05 12:28:11  peter
    * procvar handling for tp procvar mode fixed
    * proc to procvar moved from addrnode to typeconvnode
    * inlininginfo is now allocated only for inline routines that
      can be inlined, introduced a new flag po_has_inlining_info

  Revision 1.281  2004/12/03 15:57:39  peter
    * int64 can also be put in a register

  Revision 1.280  2004/11/30 18:13:39  jonas
    * patch from Peter to fix inlining of case statements

  Revision 1.279  2004/11/22 22:01:19  peter
    * fixed varargs
    * replaced dynarray with tlist

  Revision 1.278  2004/11/21 21:51:31  peter
    * manglednames for nested procedures include full parameters from
      the parents to prevent double manglednames

  Revision 1.277  2004/11/21 17:54:59  peter
    * ttempcreatenode.create_reg merged into .create with parameter
      whether a register is allowed
    * funcret_paraloc renamed to funcretloc

  Revision 1.276  2004/11/21 17:17:04  florian
    * changed funcret location back to tlocation

  Revision 1.275  2004/11/21 16:33:19  peter
    * fixed message methods
    * fixed typo with win32 dll import from implementation
    * released external check

  Revision 1.274  2004/11/17 22:41:41  peter
    * make some checks EXTDEBUG only for now so linux cycles again

  Revision 1.273  2004/11/17 22:21:35  peter
  mangledname setting moved to place after the complete proc declaration is read
  import generation moved to place where body is also parsed (still gives problems with win32)

  Revision 1.272  2004/11/16 22:09:57  peter
  * _mangledname for symbols moved only to symbols that really need it
  * overload number removed, add function result type to the mangledname fo
    procdefs

  Revision 1.271  2004/11/15 23:35:31  peter
    * tparaitem removed, use tparavarsym instead
    * parameter order is now calculated from paranr value in tparavarsym

  Revision 1.270  2004/11/11 19:31:33  peter
    * fixed compile of powerpc,sparc,arm

  Revision 1.269  2004/11/08 22:09:59  peter
    * tvarsym splitted

  Revision 1.268  2004/11/06 17:44:47  florian
    + additional extdebug check for wrong add_reg_instructions added
    * too long manglednames are cut off at 200 chars using a crc

  Revision 1.267  2004/11/05 21:07:13  florian
    * vmt offset of objects is no properly aligned when necessary

  Revision 1.266  2004/11/04 17:58:48  peter
  elecount also on 32bit needs the qword part to prevent overflow

  Revision 1.265  2004/11/04 17:09:54  peter
  fixed debuginfo for variables in staticsymtable

  Revision 1.264  2004/11/03 09:46:34  florian
    * fixed writing of para locations for procedures with explicit locations for parameters

  Revision 1.263  2004/11/01 23:30:11  peter
    * support > 32bit accesses for x86_64
    * rewrote array size checking to support 64bit

  Revision 1.262  2004/11/01 15:33:12  florian
    * fixed type information for dyn. arrays on 64 bit systems

  Revision 1.261  2004/10/31 21:45:03  peter
    * generic tlocation
    * move tlocation to cgutils

  Revision 1.260  2004/10/26 15:02:33  peter
    * align arraydef rtti

  Revision 1.259  2004/10/15 09:14:17  mazen
  - remove $IFDEF DELPHI and related code
  - remove $IFDEF FPCPROCVAR and related code

  Revision 1.258  2004/10/10 21:08:55  peter
    * parameter regvar fixes

  Revision 1.257  2004/10/04 21:23:15  florian
    * rtti alignment fixed

  Revision 1.256  2004/09/21 23:36:51  hajny
    * SetTextLineEnding implemented, FileRec.Name position alignment for CPU64

  Revision 1.255  2004/09/21 17:25:12  peter
    * paraloc branch merged

  Revision 1.254  2004/09/14 16:33:17  peter
    * restart sorting of enums when deref is called, this is needed when
      a unit is reloaded

  Revision 1.253.4.1  2004/08/31 20:43:06  peter
    * paraloc patch

  Revision 1.253  2004/08/27 21:59:26  peter
  browser disabled
  uf_local_symtable ppu flag when a localsymtable is stored

  Revision 1.252  2004/08/17 16:29:21  jonas
    + padalgingment field for recordsymtables (saved by recorddefs)
    + support for Macintosh PowerPC alignment (if the first field of a record
      or union has an alignment > 4, then the record or union size must be
      padded to a multiple of this size)

  Revision 1.251  2004/08/15 15:05:16  peter
    * fixed padding of records to alignment

  Revision 1.250  2004/08/14 14:50:42  florian
    * fixed several sparc alignment issues
    + Jonas' inline node patch; non functional yet

  Revision 1.249  2004/08/07 14:52:45  florian
    * fixed web bug 3226: type p = type pointer;

  Revision 1.248  2004/07/19 19:15:50  florian
    * fixed funcretloc writing in units

  Revision 1.247  2004/07/14 21:37:41  olle
    - removed unused types

  Revision 1.246  2004/07/12 09:14:04  jonas
    * inline procedures at the node tree level, but only under some very
      limited circumstances for now (only procedures, and only if they have
      no or only vs_out/vs_var parameters).
    * fixed ppudump for inline procedures
    * fixed ppudump for ppc

  Revision 1.245  2004/07/09 22:17:32  peter
    * revert has_localst patch
    * replace aktstaticsymtable/aktglobalsymtable with current_module

  Revision 1.244  2004/07/06 19:52:04  peter
    * fix storing of localst in ppu

  Revision 1.243  2004/06/20 08:55:30  florian
    * logs truncated

  Revision 1.242  2004/06/18 15:16:46  peter
    * remove obsolete cardinal() typecasts

  Revision 1.241  2004/06/16 20:07:09  florian
    * dwarf branch merged

  Revision 1.240  2004/05/25 18:51:14  peter
    * range check error

  Revision 1.239  2004/05/23 20:57:10  peter
    * removed unused voidprocdef

  Revision 1.238  2004/05/23 15:23:30  peter
    * fixed qword(longint) that removed sign from the number
    * removed code in the compiler that relied on wrong qword(longint)
      code generation

}