{
    $Id$

    This unit handles definitions

    Copyright (C) 1998-2000 by Daniel Mantione,
     member of the Free Pascal development team

    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.
 ****************************************************************************
}
{$ifdef TP}
  {$N+,E+,F+}
{$endif}

unit defs;

interface

uses    symtable,objects,cobjects,symtablt,globtype
{$ifdef i386}
        ,i386base
{$endif}
{$ifdef m68k}
        ,m68k
{$endif}
{$ifdef alpha}
        ,alpha
{$endif};

type    Targconvtyp=(act_convertable,act_equal,act_exact);

        Tvarspez=(vs_value,vs_const,vs_var);

        Tobjprop=(sp_public,sp_private,sp_protected,
                  sp_forwarddef,sp_static);
        Tobjpropset=set of Tobjprop;

        Tobjoption=(oo_is_abstract,         {The object/class has
                                             an abstract method => no
                                             instances can be created.}
                    oo_is_class,            {The object is a class.}
                    oo_has_virtual,         {The object/class has
                                             virtual methods.}
                    oo_has_private,         {The object has private members.}
                    oo_has_protected,       {The obejct has protected
                                             members.}
                    oo_isforward,           {The class is only a forward
                                             declared yet.}
                    oo_can_have_published,  {True, if the class has rtti, i.e.
                                             you can publish properties.}
                    oo_has_constructor,     {The object/class has a
                                             constructor.}
                    oo_has_destructor,      {The object/class has a
                                             destructor.}
                    oo_has_vmt,             {The object/class has a vmt.}
                    oo_has_msgstr,
                    oo_has_msgint,
                    oo_cppvmt);             {The object/class uses an C++
                                             compatible vmt, all members of
                                             the same class tree, must use
                                             then a C++ compatible vmt.}
        Tobjoptionset=set of Tobjoption;

        {Options for Tprocdef and Tprocvardef}
        Tprocoption=(povirtualmethod,   {Procedure is a virtual method.}
                     poclearstack,      {Use IBM flat calling convention.
                                         (Used by GCC.)}
                     poconstructor,     {Procedure is a constructor.}
                     podestructor,      {Procedure is a destructor.}
                     pointernproc,      {Procedure has compiler magic.}
                     poexports,         {Procedure is exported.}
                     poiocheck,         {IO checking should be done after
                                         a call to the procedure.}
                     poabstractmethod,  {Procedure is an abstract method.}
                     pointerrupt,       {Procedure is an interrupt handler.}
                     poinline,          {Procedure is an assembler macro.}
                     poassembler,       {Procedure is written in assembler.}
                     pooperator,        {Procedure defines an operator.}
                     poexternal,        {Procedure is external (in other
                                         object or lib)}
                     poleftright,       {Push parameters from left to right.}
                     poprocinit,        {Program initialization.}
                     postaticmethod,    {Static method.}
                     pooveridingmethod, {Method with override directive }
                     poclassmethod,     {Class method.}
                     pounitinit,        {Unit initialization }
                     pomethodpointer,   {Method pointer, only in procvardef,
                                         also used for 'with object do' }
                     pocdecl,           {Procedure uses C styled calling }
                     popalmossyscall,   {Procedure is a PalmOS system call }
                     pointernconst,     {Procedure has constant evaluator
                                         intern.}
                     poregister,        {Procedure uses register (fastcall)
                                         calling }
                     pounitfinalize,    {Unit finalization }
                     postdcall,         {Procedure uses stdcall
                                         call.}
                     pomsgstr,          {Method for string message
                                         handling.}
                     pomsgint,          {Method for int message handling.}
                     posavestdregs,     {Save std regs cdecl and stdcall
                                         need that !}
                     pocontainsself,    {Self is passed explicit to the
                                         compiler.}
                     posafecall);       {Safe call calling conventions }
        Tprocoptionset=set of Tprocoption;

        Tarrayoption=(ap_variant,ap_constructor,ap_arrayofconst);
        Tarrayoptionset=set of Tarrayoption;

        Pparameter=^Tparameter;
        Tparameter=object(Tobject)
            data:Psym;
            paratyp:Tvarspez;
            argconvtyp:Targconvtyp;
            convertlevel:byte;
            register:Tregister;
        end;

        Tfiletype=(ft_text,ft_typed,ft_untyped);

        Pfiledef=^Tfiledef;
        Tfiledef=object(Tdef)
            filetype:Tfiletype;
            typed_as:Pdef;
            constructor init(Aowner:Pcontainingsymtable;
                             ft:Tfiletype;tas:Pdef);
            constructor load(var s:Tstream);
            procedure deref;virtual;
            function gettypename:string;virtual;
            procedure setsize;
{$ifdef GDB}
            function stabstring:Pchar;virtual;
            procedure concatstabto(asmlist:Paasmoutput);virtual;
{$endif GDB}
            procedure store(var s:Tstream);virtual;
        end;

        Pformaldef=^Tformaldef;
        Tformaldef=object(Tdef)
            constructor init(Aowner:Pcontainingsymtable);
            constructor load(var s:Tstream);
            procedure store(var s:Tstream);virtual;
{$ifdef GDB}
            function stabstring:Pchar;virtual;
            procedure concatstabto(asmlist:Paasmoutput);virtual;
{$endif GDB}
            function gettypename:string;virtual;
        end;

        Perrordef=^Terrordef;
        Terrordef=object(Tdef)
{$ifdef GDB}
            function stabstring:Pchar;virtual;
{$endif GDB}
            function gettypename:string;virtual;
        end;

        Pabstractpointerdef=^Tabstractpointerdef;
        Tabstractpointerdef=object(Tdef)
            definition:Pdef;
            defsym:Psym;
            constructor init(Aowner:Pcontainingsymtable;def:Pdef);
            constructor load(var s:Tstream);
            procedure deref;virtual;
            procedure store(var s:Tstream);virtual;
{$ifdef GDB}
            function  stabstring:Pchar;virtual;
            procedure concatstabto(asmlist:Paasmoutput);virtual;
{$endif GDB}
        end;

        Ppointerdef=^Tpointerdef;
        Tpointerdef=object(Tabstractpointerdef)
            is_far:boolean;
            constructor initfar(Aowner:Pcontainingsymtable;def:Pdef);
            constructor load(var s:Tstream);
            procedure store(var s:Tstream);virtual;
            function gettypename:string;virtual;
        end;

        Pclassrefdef=^Tclassrefdef;
        Tclassrefdef=object(Tpointerdef)
{$ifdef GDB}
            function stabstring : pchar;virtual;
            procedure concatstabto(asmlist : paasmoutput);virtual;
{$endif GDB}
            function gettypename:string;virtual;
        end;

        Pobjectdef=^Tobjectdef;
        Tobjectdef=object(Tdef)
            childof:Pobjectdef;
            objname:Pstring;
            privatesyms,
            protectedsyms,
            publicsyms:Pobjectsymtable;
            options:Tobjoptionset;
            {To be able to have a variable vmt position
             and no vmt field for objects without virtuals }
            vmt_offset:longint;
            constructor init(const n:string;Aowner:Pcontainingsymtable;
                             parent:Pobjectdef);
            constructor load(var s:Tstream);
            procedure check_forwards;
            procedure insertvmt;
            function isrelated(d:Pobjectdef):boolean;
            function search(const s:string):Psym;
            function speedsearch(const s:string;
                                 speedvalue:longint):Psym;virtual;
            function size:longint;virtual;
            procedure store(var s:Tstream);virtual;
            function vmt_mangledname : string;
            function rtti_name : string;

            procedure set_parent(parent:Pobjectdef);
{$ifdef GDB}
            function stabstring : pchar;virtual;
{$endif GDB}
            procedure deref;virtual;

            function  needs_inittable:boolean;virtual;
            procedure write_init_data;virtual;
            procedure write_child_init_data;virtual;

            {Rtti }
            function  get_rtti_label:string;virtual;
            procedure generate_rtti;virtual;
            procedure write_rtti_data;virtual;
            procedure write_child_rtti_data;virtual;
            function next_free_name_index:longint;
            function is_publishable:boolean;virtual;
            destructor done;virtual;
        end;

        Parraydef=^Tarraydef;
        Tarraydef=object(Tdef)
            lowrange,
            highrange:Tconstant;
            definition:Pdef;
            rangedef:Pdef;
            options:Tarrayoptionset;
            constructor init(const l,h:Tconstant;rd:Pdef;
                             Aowner:Pcontainingsymtable);
            constructor load(var s:Tstream);
            function elesize:longint;
            function gettypename:string;virtual;
            procedure store(var s:Tstream);virtual;
{$ifdef GDB}
            function stabstring : pchar;virtual;
            procedure concatstabto(asmlist : paasmoutput);virtual;
{$endif GDB}
            procedure deref;virtual;
            function size : longint;virtual;
            { generates the ranges needed by the asm instruction BOUND (i386)
              or CMP2 (Motorola) }
            procedure genrangecheck;

            { returns the label of the range check string }
            function getrangecheckstring : string;
            function needs_inittable : boolean;virtual;
            procedure write_rtti_data;virtual;
            procedure write_child_rtti_data;virtual;
        private
            rangenr:longint;
        end;

        Penumdef=^Tenumdef;
        Tenumdef=object(Tdef)
            rangenr,
            minval,
            maxval:longint;
            has_jumps:boolean;
            symbols:Pcollection;
            basedef:Penumdef;
            constructor init(Aowner:Pcontainingsymtable);
            constructor init_subrange(Abasedef:Penumdef;Amin,Amax:longint;
                                      Aowner:Pcontainingsymtable);
            constructor load(var s:Tstream);
            procedure deref;virtual;
            procedure calcsavesize;
            function getrangecheckstring:string;
            procedure genrangecheck;
            procedure setmax(Amax:longint);
            procedure setmin(Amin:longint);
            procedure store(var s:Tstream);virtual;
{$ifdef GDB}
            function stabstring:Pchar;virtual;
{$endif GDB}
            procedure write_child_rtti_data;virtual;
            procedure write_rtti_data;virtual;
            function is_publishable : boolean;virtual;
            function  gettypename:string;virtual;
        end;

        Tbasetype=(uauto,uvoid,uchar,
                   u8bit,u16bit,u32bit,
                   s8bit,s16bit,s32bit,
                   bool8bit,bool16bit,bool32bit { uwchar,bool1bit,bitfield},
                   u64bit,s64bitint);

        Porddef=^Torddef;
        Torddef=object(Tdef)
            low,high:Tconstant;
            rangenr:longint;
            typ:Tbasetype;
            constructor init(t:tbasetype;l,h:Tconstant;
                             Aowner:Pcontainingsymtable);
            constructor load(var s:Tstream);
            procedure store(var s:Tstream);virtual;
            procedure setsize;

            { generates the ranges needed by the asm instruction BOUND }
            { or CMP2 (Motorola)                                       }
            procedure genrangecheck;
            { returns the label of the range check string }
            function getrangecheckstring : string;
            procedure write_rtti_data;virtual;
            function is_publishable:boolean;virtual;
            function gettypename:string;virtual;
{$ifdef GDB}
            function stabstring:Pchar;virtual;
{$endif GDB}
        end;

        {S80real is dependant on the cpu, s64comp is also
         dependant on the size (tp = 80bit for both)
         The EXTENDED format exists on the motorola FPU
         but it uses 96 bits instead of 80, with some
         unused bits within the number itself! Pretty
         complicated to support, so no support for the
         moment.
         S64comp is considered as a real because all
         calculations are done by the fpu.}

        Tfloattype=(s32real,s64real,s80real,s64comp,f16bit,f32bit);

        Pfloatdef=^Tfloatdef;
        Tfloatdef=object(tdef)
            typ:Tfloattype;
            constructor init(t:Tfloattype;Aowner:Pcontainingsymtable);
            constructor load(var s:Tstream);
            function is_publishable : boolean;virtual;
            procedure setsize;
{$ifdef GDB}
            function stabstring:Pchar;virtual;
{$endif GDB}
            procedure store(var s:Tstream);virtual;
            procedure write_rtti_data;virtual;
            function gettypename:string;virtual;
        end;

        Tsettype=(normset,smallset,varset);

        Psetdef=^Tsetdef;
        Tsetdef=object(Tdef)
            setof:Pdef;
            settype:Tsettype;
            constructor init(s:Pdef;high:longint;Aowner:Pcontainingsymtable);
            constructor load(var s:Tstream);
            procedure store(var s:Tstream);virtual;
{$ifdef GDB}
            function stabstring : pchar;virtual;
            procedure concatstabto(asmlist : paasmoutput);virtual;
{$endif GDB}
            procedure deref;virtual;
            function is_publishable : boolean;virtual;
            procedure write_rtti_data;virtual;
            procedure write_child_rtti_data;virtual;
            function gettypename:string;virtual;
        end;

        Precorddef=^Trecorddef;
        Trecorddef=object(Tdef)
            symtable:Precordsymtable;
            constructor init(s:Precordsymtable;Aowner:Pcontainingsymtable);
            constructor load(var s:Tstream);
            procedure store(var s:Tstream);virtual;
{$ifdef GDB}
            function stabstring : pchar;virtual;
            procedure concatstabto(asmlist : paasmoutput);virtual;
{$endif GDB}
            procedure deref;virtual;
            function  needs_inittable : boolean;virtual;
            procedure write_rtti_data;virtual;
            procedure write_init_data;virtual;
            procedure write_child_rtti_data;virtual;
            procedure write_child_init_data;virtual;
            function gettypename:string;virtual;
            destructor done;virtual;
        end;

        Pabstractprocdef=^Pabstractprocdef;
        Tabstractprocdef=object(Tdef)
            {Saves a definition to the return type }
            retdef:Pdef;
            fpu_used:byte;              {How many stack fpu must be empty.}
            options:Tprocoptionset;     {Save the procedure options.}
            parameters:Pcollection;
            constructor init(Aowner:Pcontainingsymtable);
            constructor load(var s:Tstream);
            destructor done;virtual;
            procedure deref;virtual;
            function demangled_paras:string;
            function para_size:longint;
            procedure store(var s:Tstream);virtual;
            procedure test_if_fpu_result;
 {$ifdef GDB}
            function stabstring : pchar;virtual;
            procedure concatstabto(asmlist : paasmoutput);virtual;
 {$endif GDB}
        end;

        Pprocvardef=^Pprocvardef;
        Tprocvardef=object(Tabstractprocdef)
            function size:longint;virtual;
 {$ifdef GDB}
            function stabstring:Pchar;virtual;
            procedure concatstabto(asmlist:Paasmoutput); virtual;
 {$endif GDB}
            procedure write_child_rtti_data;virtual;
            function is_publishable:boolean;virtual;
            procedure write_rtti_data;virtual;
            function gettypename:string;virtual;
        end;

        Pprocdef = ^Tprocdef;
        Tprocdef = object(tabstractprocdef)
           objprop:Tobjpropset;
           extnumber:longint;
           { where is this function defined, needed here because there
             is only one symbol for all overloaded functions }
           fileinfo:Tfileposinfo;
           { pointer to the local symbol table }
           localst:Pprocsymtable;
           _mangledname:Pstring;
           { it's a tree, but this not easy to handle }
           { used for inlined procs                   }
           code : pointer;
           { true, if the procedure is only declared }
           { (forward procedure) }
           references:Pcollection;
           forwarddef,
           { true if the procedure is declared in the interface }
           interfacedef : boolean;
           { check the problems of manglednames }
           count      : boolean;
           is_used    : boolean;
           { set which contains the modified registers }
           usedregisters:Tregisterset;
           constructor init(Aowner:Pcontainingsymtable);
           constructor load(var s:Tstream);
           procedure store(var s:Tstream);virtual;
 {$ifdef GDB}
           function cplusplusmangledname : string;
           function stabstring : pchar;virtual;
           procedure concatstabto(asmlist : paasmoutput);virtual;
 {$endif GDB}
           procedure deref;virtual;
           function mangledname:string;
           procedure setmangledname(const s:string);
           procedure load_references;
           function  write_references : boolean;
           destructor done;virtual;
        end;

var     cformaldef:Pformaldef;  {Unique formal definition.}
        voiddef:Porddef;        {Pointer to void (procedure) type      }
        cchardef:Porddef;       {Pointer to char type.}
        booldef:Porddef;        {Pointer to boolean type.}
        u8bitdef:Porddef;       {Pointer to 8-bit unsigned type.}
        u16bitdef:Porddef;      {Pointer to 16-bit unsigned type.}
        u32bitdef:Porddef;      {Pointer to 32-bit unsigned type.}
        s32bitdef:Porddef;      {Pointer to 32-bit signed type.}

implementation

uses    systems,symbols,verbose,globals,aasm,files;

const   {If you change one of the following contants,
         you have also to change the typinfo unit
         and the rtl/i386,template/rttip.inc files.}
        tkunknown       = 0;
        tkinteger       = 1;
        tkchar          = 2;
        tkenumeration   = 3;
        tkfloat         = 4;
        tkset           = 5;
        tkmethod        = 6;
        tksstring       = 7;
        tkstring        = tksstring;
        tklstring       = 8;
        tkastring       = 9;
        tkwstring       = 10;
        tkvariant       = 11;
        tkarray         = 12;
        tkrecord        = 13;
        tkinterface     = 14;
        tkclass         = 15;
        tkobject        = 16;
        tkwchar         = 17;
        tkbool          = 18;

        otsbyte         = 0;
        otubyte         = 1;
        otsword         = 2;
        otuword         = 3;
        otslong         = 4;
        otulong         = 5;

        ftsingle        = 0;
        ftdouble        = 1;
        ftextended      = 2;
        ftcomp          = 3;
        ftcurr          = 4;
        ftfixed16       = 5;
        ftfixed32       = 6;

{****************************************************************************
                                Tfiledef
****************************************************************************}

constructor Tfiledef.init(Aowner:Pcontainingsymtable;ft:Tfiletype;tas:Pdef);

begin
    inherited init(Aowner);
    filetype:=ft;
    typed_as:=tas;
    setsize;
end;

constructor Tfiledef.load(var s:Tstream);

begin
    inherited load(s);
{   filetype:=tfiletype(readbyte);
    if filetype=ft_typed then
        typed_as:=readdefref
    else
        typed_as:=nil;}
    setsize;
end;


procedure Tfiledef.deref;

begin
{   if filetype=ft_typed then
        resolvedef(typed_as);}
end;


procedure Tfiledef.setsize;

begin
    case filetype of
        ft_text:
            savesize:=572;
        ft_typed,ft_untyped:
            savesize:=316;
    end;
end;


procedure Tfiledef.store(var s:Tstream);

begin
{   inherited store(s);
    writebyte(byte(filetype));
    if filetype=ft_typed then
        writedefref(typed_as);
    current_ppu^.writeentry(ibfiledef);}
end;


function Tfiledef.gettypename : string;

begin
    case filetype of
        ft_untyped:
            gettypename:='File';
        ft_typed:
            gettypename:='File Of '+typed_as^.typename;
        ft_text:
            gettypename:='Text'
    end;
end;

{****************************************************************************
                                Tformaldef
****************************************************************************}

{Tformaldef is used for var parameters without a type.}

constructor Tformaldef.init(Aowner:Pcontainingsymtable);

begin
    inherited init(Aowner);
    savesize:=target_os.size_of_pointer;
end;


constructor Tformaldef.load(var s:Tstream);

begin
    inherited load(s);
    savesize:=target_os.size_of_pointer;
end;


procedure Tformaldef.store(var s:Tstream);

begin
    inherited store(s);
{   current_ppu^.writeentry(ibformaldef);}
end;

function Tformaldef.gettypename:string;

begin
    gettypename:='Var';
end;

{****************************************************************************
                                  Terrordef
****************************************************************************}

function Terrordef.gettypename:string;

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

{****************************************************************************
                             Tabstractpointerdef
****************************************************************************}

constructor Tabstractpointerdef.init(Aowner:Pcontainingsymtable;def:Pdef);

begin
    inherited init(Aowner);
    definition:=def;
    savesize:=target_os.size_of_pointer;
end;

constructor Tabstractpointerdef.load(var s:Tstream);

begin
    inherited load(s);
(*  {The real address in memory is calculated later (deref).}
    definition:=readdefref;             *)
    savesize:=target_os.size_of_pointer;
end;


procedure Tabstractpointerdef.deref;

begin
{   resolvedef(definition);}
end;


procedure Tabstractpointerdef.store(var s:Tstream);

begin
    inherited store(s);
{   writedefref(definition);
    current_ppu^.writeentry(ibpointerdef);}
end;


{****************************************************************************
                                 Tpointerdef
****************************************************************************}

constructor Tpointerdef.initfar(Aowner:Pcontainingsymtable;def:Pdef);

begin
   inherited init(Aowner,def);
   is_far:=true;
end;

constructor Tpointerdef.load(var s:Tstream);

begin
    inherited load(s);
{   is_far:=(readbyte<>0);}
end;

function Tpointerdef.gettypename : string;

begin
   gettypename:='^'+definition^.typename;
end;

procedure Tpointerdef.store(var s:Tstream);

begin
    inherited store(s);
{   writebyte(byte(is_far));}
end;

{****************************************************************************
                              Tclassrefdef
****************************************************************************}

function Tclassrefdef.gettypename:string;

begin
   gettypename:='Class of '+definition^.typename;
end;

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

constructor Tobjectdef.init(const n:string;Aowner:Pcontainingsymtable;
                            parent:Pobjectdef);

begin
    inherited init(Aowner);
    new(publicsyms,init);
    publicsyms^.name:=stringdup(n);
    publicsyms^.defowner:=@self;
    set_parent(parent);
    objname:=stringdup(n);
end;


procedure tobjectdef.set_parent(parent:Pobjectdef);

const   inherited_options=[oo_has_virtual,oo_has_private,oo_has_protected,
                           oo_has_constructor,oo_has_destructor];

begin
    {Nothing to do if the parent was not forward !}
    if childof=nil then
        begin
            childof:=parent;
            {Some options are inherited...}
            if parent<>nil then
                begin
                    options:=options+parent^.options*inherited_options;
                    {Add the data of the anchestor class.}
                    inc(publicsyms^.datasize,parent^.publicsyms^.datasize);
                    if parent^.privatesyms<>nil then
                        begin
                            if privatesyms=nil then
                                new(privatesyms,init);
                            inc(privatesyms^.datasize,
                             parent^.privatesyms^.datasize);
                        end;
                    if parent^.protectedsyms<>nil then
                        begin
                            if protectedsyms<>nil then
                                new(protectedsyms,init);
                            inc(protectedsyms^.datasize,
                             parent^.protectedsyms^.datasize);
                        end;
                    if oo_has_vmt in (options*parent^.options) then
                        publicsyms^.datasize:=publicsyms^.datasize-
                         target_os.size_of_pointer;
                    {If parent has a vmt field then
                     the offset is the same for the child PM }
                     if [oo_has_vmt,oo_is_class]*parent^.options<>[] then
                        begin
                            vmt_offset:=parent^.vmt_offset;
                            include(options,oo_has_vmt);
                        end;
                end;
            savesize:=publicsyms^.datasize;
        end;
end;

constructor Tobjectdef.load(var s:Tstream);

var oldread_member:boolean;

begin
    inherited load(s);
(*  savesize:=readlong;
    vmt_offset:=readlong;
    objname:=stringdup(readstring);
    childof:=pobjectdef(readdefref);
    options:=readlong;
    oldread_member:=read_member;
    read_member:=true;
    publicsyms:=new(psymtable,loadas(objectsymtable));
    read_member:=oldread_member;
    publicsyms^.defowner:=@self;
    { publicsyms^.datasize:=savesize; }
    publicsyms^.name := stringdup(objname^);

    { handles the predefined class tobject  }
    { the last TOBJECT which is loaded gets }
    { it !                                  }
    if (objname^='TOBJECT') and
      isclass and (childof=nil) then
      class_tobject:=@self;
    has_rtti:=true;*)
end;


procedure Tobjectdef.insertvmt;

begin
    if oo_has_vmt in options then
        internalerror($990803)
    else
        begin
            {First round up to aktpakrecords.}
            publicsyms^.datasize:=align(publicsyms^.datasize,
             aktpackrecords);
            vmt_offset:=publicsyms^.datasize;
            publicsyms^.datasize:=publicsyms^.datasize+
             target_os.size_of_pointer;
            include(options,oo_has_vmt);
        end;
end;

procedure Tobjectdef.check_forwards;

begin
    publicsyms^.check_forwards;
    if oo_isforward in options then
        begin
            { ok, in future, the forward can be resolved }
            message1(sym_e_class_forward_not_resolved,objname^);
            exclude(options,oo_isforward);
        end;
end;

{ true, if self inherits from d (or if they are equal) }
function Tobjectdef.isrelated(d:Pobjectdef):boolean;

var hp:Pobjectdef;

begin
    hp:=@self;
    isrelated:=false;
    while assigned(hp) do
        begin
            if hp=d then
                begin
                    isrelated:=true;
                    break;
                end;
            hp:=hp^.childof;
        end;
end;

function Tobjectdef.search(const s:string):Psym;

begin
    search:=speedsearch(s,getspeedvalue(s));
end;

function Tobjectdef.speedsearch(const s:string;speedvalue:longint):Psym;

var r:Psym;

begin
    r:=publicsyms^.speedsearch(s,speedvalue);
    if (r=nil) and (privatesyms<>nil) then
        r:=privatesyms^.speedsearch(s,speedvalue);
    if (r=nil) and (protectedsyms<>nil) then
        r:=protectedsyms^.speedsearch(s,speedvalue);
end;

function Tobjectdef.size:longint;

begin
    if oo_is_class in options then
        size:=target_os.size_of_pointer
    else
        size:=publicsyms^.datasize;
end;


procedure tobjectdef.deref;

var oldrecsyms:Psymtable;

begin
{   resolvedef(pdef(childof));
    oldrecsyms:=aktrecordsymtable;
    aktrecordsymtable:=publicsyms;
    publicsyms^.deref;
    aktrecordsymtable:=oldrecsyms;}
end;


function Tobjectdef.vmt_mangledname:string;

begin
    if oo_has_vmt in options then
        message1(parser_object_has_no_vmt,objname^);
        vmt_mangledname:='VMT_'+owner^.name^+'$_'+objname^;
end;

function Tobjectdef.rtti_name:string;

begin
    rtti_name:='RTTI_'+owner^.name^+'$_'+objname^;
end;

procedure Tobjectdef.store(var s:Tstream);

var oldread_member:boolean;

begin
    inherited store(s);
(*  writelong(size);
    writelong(vmt_offset);
    writestring(objname^);
    writedefref(childof);
    writelong(options);
    current_ppu^.writeentry(ibobjectdef);

    oldread_member:=read_member;
    read_member:=true;
    publicsyms^.writeas;
    read_member:=oldread_member;*)
end;

procedure tobjectdef.write_child_init_data;

begin
end;


procedure Tobjectdef.write_init_data;

var b:byte;

begin
    if oo_is_class in options then
        b:=tkclass
    else
        b:=tkobject;
    rttilist^.concat(new(Pai_const,init_8bit(b)));

    { generate the name }
    rttilist^.concat(new(Pai_const,init_8bit(length(objname^))));
    rttilist^.concat(new(Pai_string,init(objname^)));

(*  rttilist^.concat(new(Pai_const,init_32bit(size)));
    publicsyms^.foreach({$ifndef TP}@{$endif}count_inittable_fields);
    rttilist^.concat(new(Pai_const,init_32bit(count)));
    publicsyms^.foreach({$ifndef TP}@{$endif}write_field_inittable);*)
end;


function Tobjectdef.needs_inittable:boolean;

var oldb:boolean;

begin
    { there are recursive calls to needs_inittable possible, }
    { so we have to change to old value how else should      }
    { we do that ? check_rec_rtti can't be a nested          }
    { procedure of needs_rtti !                              }
(*  oldb:=binittable;
    binittable:=false;
    publicsyms^.foreach({$ifndef TP}@{$endif}check_rec_inittable);
    needs_inittable:=binittable;
    binittable:=oldb;*)
end;

destructor Tobjectdef.done;

begin
    if publicsyms<>nil then
        dispose(publicsyms,done);
    if privatesyms<>nil then
        dispose(privatesyms,done);
    if protectedsyms<>nil then
        dispose(protectedsyms,done);
    if oo_isforward in options then
        message1(sym_e_class_forward_not_resolved,objname^);
    stringdispose(objname);
    inherited done;
end;

var count:longint;

procedure count_published_properties(sym:Pnamedindexobject);
                                    {$ifndef fpc}far;{$endif}

begin
    if (typeof(sym^)=typeof(Tpropertysym)) and
     (ppo_published in Ppropertysym(sym)^.properties) then
        inc(count);
end;


procedure write_property_info(sym:Pnamedindexobject);{$ifndef fpc}far;{$endif}

var proctypesinfo : byte;

procedure writeproc(sym:Psym;def:Pdef;shiftvalue:byte);

var typvalue:byte;

begin
    if not(assigned(sym)) then
        begin
            rttilist^.concat(new(pai_const,init_32bit(1)));
            typvalue:=3;
        end
    else if typeof(sym^)=typeof(Tvarsym) then
        begin
            rttilist^.concat(new(pai_const,init_32bit(
             Pvarsym(sym)^.address)));
            typvalue:=0;
        end
    else
        begin
(*          if (pprocdef(def)^.options and povirtualmethod)=0 then
                begin
                    rttilist^.concat(new(pai_const_symbol,initname(pprocdef(def)^.mangledname)));
                    typvalue:=1;
                end
            else
                begin
                    {Virtual method, write vmt offset.}
                    rttilist^.concat(new(pai_const,
                     init_32bit(Pprocdef(def)^.extnumber*4+12)));
                    typvalue:=2;
                end;*)
        end;
    proctypesinfo:=proctypesinfo or (typvalue shl shiftvalue);
end;

begin
    if (typeof(sym^)=typeof(Tpropertysym)) and
     (ppo_indexed in Ppropertysym(sym)^.properties) then
        proctypesinfo:=$40
    else
        proctypesinfo:=0;
    if (typeof(sym^)=typeof(Tpropertysym)) and
            (ppo_published in Ppropertysym(sym)^.properties) then
        begin
            rttilist^.concat(new(pai_const_symbol,initname(
             Ppropertysym(sym)^.definition^.get_rtti_label)));
            writeproc(Ppropertysym(sym)^.readaccesssym,ppropertysym(sym)^.readaccessdef,0);
            writeproc(Ppropertysym(sym)^.writeaccesssym,ppropertysym(sym)^.writeaccessdef,2);
            { isn't it stored ? }
            if (ppo_stored in Ppropertysym(sym)^.properties) then
                begin
                    rttilist^.concat(new(pai_const,init_32bit(1)));
                    proctypesinfo:=proctypesinfo or (3 shl 4);
                end
            else
                writeproc(ppropertysym(sym)^.storedsym,ppropertysym(sym)^.storeddef,4);
            rttilist^.concat(new(pai_const,
             init_32bit(ppropertysym(sym)^.index)));
            rttilist^.concat(new(pai_const,
             init_32bit(ppropertysym(sym)^.default)));
            rttilist^.concat(new(pai_const,
             init_16bit(count)));
            inc(count);
            rttilist^.concat(new(pai_const,init_8bit(proctypesinfo)));
            rttilist^.concat(new(pai_const,
             init_8bit(length(ppropertysym(sym)^.name))));
            rttilist^.concat(new(pai_string,init(ppropertysym(sym)^.name)));
        end;
end;


procedure generate_published_child_rtti(sym:Pnamedindexobject);
                                        {$ifndef fpc}far;{$endif}

begin
    if (typeof(sym^)=typeof(Tpropertysym)) and
     (ppo_published in Ppropertysym(sym)^.properties) then
        Ppropertysym(sym)^.definition^.get_rtti_label;
end;


procedure tobjectdef.write_child_rtti_data;

begin
    publicsyms^.foreach({$ifndef TP}@{$endif}generate_published_child_rtti);
end;


procedure Tobjectdef.generate_rtti;

begin
{   getdatalabel(rtti_label);
    write_child_rtti_data;
    rttilist^.concat(new(pai_symbol,initname_global(rtti_name)));
    rttilist^.concat(new(pai_label,init(rtti_label)));
    write_rtti_data;}
end;


function Tobjectdef.next_free_name_index : longint;

var i:longint;

begin
    if (childof<>nil) and (oo_can_have_published in childof^.options) then
        i:=childof^.next_free_name_index
    else
        i:=0;
    count:=0;
    publicsyms^.foreach({$ifndef TP}@{$endif}count_published_properties);
    next_free_name_index:=i+count;
end;


procedure tobjectdef.write_rtti_data;

begin
    if oo_is_class in options then
        rttilist^.concat(new(pai_const,init_8bit(tkclass)))
    else
        rttilist^.concat(new(pai_const,init_8bit(tkobject)));

    {Generate the name }
    rttilist^.concat(new(pai_const,init_8bit(length(objname^))));
    rttilist^.concat(new(pai_string,init(objname^)));

    {Write class type }
    rttilist^.concat(new(pai_const_symbol,initname(vmt_mangledname)));

    { write owner typeinfo }
    if (childof<>nil) and (oo_can_have_published in childof^.options) then
        rttilist^.concat(new(pai_const_symbol,
         initname(childof^.get_rtti_label)))
    else
        rttilist^.concat(new(pai_const,init_32bit(0)));

    {Count total number of properties }
    if (childof<>nil) and (oo_can_have_published in childof^.options) then
        count:=childof^.next_free_name_index
    else
        count:=0;

    {Write it>}
    publicsyms^.foreach({$ifndef TP}@{$endif}count_published_properties);
    rttilist^.concat(new(Pai_const,init_16bit(count)));

    { write unit name }
    if owner^.name<>nil then
        begin
            rttilist^.concat(new(Pai_const,init_8bit(length(owner^.name^))));
            rttilist^.concat(new(Pai_string,init(owner^.name^)));
        end
    else
        rttilist^.concat(new(Pai_const,init_8bit(0)));

    { write published properties count }
    count:=0;
    publicsyms^.foreach({$ifndef TP}@{$endif}count_published_properties);
    rttilist^.concat(new(pai_const,init_16bit(count)));

    { count is used to write nameindex   }
    { but we need an offset of the owner }
    { to give each property an own slot  }
    if (childof<>nil) and (oo_can_have_published in childof^.options) then
        count:=childof^.next_free_name_index
    else
        count:=0;
    publicsyms^.foreach({$ifndef TP}@{$endif}write_property_info);
end;


function Tobjectdef.is_publishable:boolean;

begin
    is_publishable:=oo_is_class in options;
end;

function Tobjectdef.get_rtti_label:string;

begin
    get_rtti_label:=rtti_name;
end;

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

constructor Tarraydef.init(const l,h:Tconstant;rd:Pdef;
                           Aowner:Pcontainingsymtable);

begin
    inherited init(Aowner);
    lowrange:=l;
    highrange:=h;
    rangedef:=rd;
end;


constructor Tarraydef.load(var s:Tstream);

begin
    inherited load(s);
(*  deftype:=arraydef;
    { the addresses are calculated later }
    definition:=readdefref;
    rangedef:=readdefref;
    lowrange:=readlong;
    highrange:=readlong;
    IsArrayOfConst:=boolean(readbyte);*)
end;


function Tarraydef.getrangecheckstring:string;

begin
    if (cs_smartlink in aktmoduleswitches) then
        getrangecheckstring:='R_'+current_module^.modulename^+tostr(rangenr)
    else
        getrangecheckstring:='R_'+tostr(rangenr);
end;


procedure Tarraydef.genrangecheck;

begin
    if rangenr=0 then
        begin
            {Generates the data for range checking }
            getlabelnr(rangenr);
            if (cs_smartlink in aktmoduleswitches) then
                datasegment^.concat(new(pai_symbol,
                 initname_global(getrangecheckstring)))
            else
                datasegment^.concat(new(pai_symbol,
                 initname(getrangecheckstring)));
            datasegment^.concat(new(Pai_const,
             init_8bit(byte(lowrange.signed))));
            datasegment^.concat(new(Pai_const,
             init_32bit(lowrange.values)));
            datasegment^.concat(new(Pai_const,
             init_8bit(byte(highrange.signed))));
            datasegment^.concat(new(Pai_const,
             init_32bit(highrange.values)));
        end;
end;


procedure Tarraydef.deref;

begin
{   resolvedef(definition);
    resolvedef(rangedef);}
end;

procedure Tarraydef.store(var s:Tstream);

begin
    inherited store(s);
(*  writedefref(definition);
    writedefref(rangedef);
    writelong(lowrange);
    writelong(highrange);
    writebyte(byte(IsArrayOfConst));
    current_ppu^.writeentry(ibarraydef);*)
end;

function Tarraydef.elesize:longint;

begin
    elesize:=definition^.size;
end;


function Tarraydef.size:longint;

begin
    if (lowrange.signed) and (lowrange.values=-1) then
        internalerror($990804);
    if highrange.signed then
        begin
            {Check for overflow.}
            if (highrange.values-lowrange.values=$7fffffff) or
              (($7fffffff div elesize+elesize-1)>
               (highrange.values-lowrange.values)) then
                begin
{                   message(sym_segment_too_large);}
                    size:=1;
                end
            else
                size:=(highrange.values-lowrange.values+1)*elesize;
        end
    else
        begin
            {Check for overflow.}
            if (highrange.valueu-lowrange.valueu=$7fffffff) or
              (($7fffffff div elesize+elesize-1)>
               (highrange.valueu-lowrange.valueu)) then
                begin
{                   message(sym_segment_too_small);}
                    size:=1;
                end
            else
                size:=(highrange.valueu-lowrange.valueu+1)*elesize;
        end;
end;


function Tarraydef.needs_inittable:boolean;

begin
    needs_inittable:=definition^.needs_inittable;
end;


procedure Tarraydef.write_child_rtti_data;

begin
    definition^.get_rtti_label;
end;


procedure tarraydef.write_rtti_data;

begin
    rttilist^.concat(new(Pai_const,init_8bit(13)));
    write_rtti_name;
    { size of elements }
    rttilist^.concat(new(Pai_const,init_32bit(definition^.size)));
    { count of elements }
    rttilist^.concat(new(Pai_const,
     init_32bit(highrange.values-lowrange.values+1)));
    { element type }
    rttilist^.concat(new(Pai_const_symbol,
     initname(definition^.get_rtti_label)));
end;

function Tarraydef.gettypename:string;

var r:string;

begin
    if [ap_arrayofconst,ap_constructor]*options<>[] then
        gettypename:='array of const'
    else if (lowrange.signed) and (lowrange.values=-1) then
        gettypename:='Array Of '+definition^.typename
    else
        begin
            r:='array[$1..$2 Of $3]';
            if typeof(rangedef^)=typeof(Tenumdef) then
                with Penumdef(rangedef)^.symbols^ do
                    begin
                        replace(r,'$1',Penumsym(at(0))^.name);
                        replace(r,'$2',Penumsym(at(count-1))^.name);
                    end
            else
                begin
                    if lowrange.signed then
                        replace(r,'$1',tostr(lowrange.values))
                    else
                        replace(r,'$1',tostru(lowrange.valueu));
                    if highrange.signed then
                        replace(r,'$2',tostr(highrange.values))
                    else
                        replace(r,'$2',tostr(highrange.valueu));
                    replace(r,'$3',definition^.typename);
                end;
            gettypename:=r;
        end;
end;

{****************************************************************************
                                 Tenumdef
****************************************************************************}

constructor Tenumdef.init(Aowner:Pcontainingsymtable);

begin
    inherited init(Aowner);
    new(symbols,init(8,8));
    calcsavesize;
end;

constructor Tenumdef.init_subrange(Abasedef:Penumdef;Amin,Amax:longint;
                                   Aowner:Pcontainingsymtable);

begin
    inherited init(Aowner);
    minval:=Amin;
    maxval:=Amax;
    basedef:=Abasedef;
    symbols:=Abasedef^.symbols;
    calcsavesize;
end;


constructor Tenumdef.load(var s:Tstream);

begin
    inherited load(s);
(*  basedef:=penumdef(readdefref);
    minval:=readlong;
    maxval:=readlong;
    savesize:=readlong;*)
end;


procedure Tenumdef.calcsavesize;

begin
    if (aktpackenum=4) or (minval<0) or (maxval>65535) then
        savesize:=4
    else if (aktpackenum=2) or (minval<0) or (maxval>255) then
        savesize:=2
    else
        savesize:=1;
end;


procedure Tenumdef.setmax(Amax:longint);

begin
    maxval:=Amax;
    calcsavesize;
end;


procedure Tenumdef.setmin(Amin:longint);

begin
    minval:=Amin;
    calcsavesize;
end;


procedure tenumdef.deref;

begin
{   resolvedef(pdef(basedef));}
end;


procedure Tenumdef.store(var s:Tstream);

begin
    inherited store(s);
(*  writedefref(basedef);
    writelong(min);
    writelong(max);
    writelong(savesize);
    current_ppu^.writeentry(ibenumdef);*)
end;


function tenumdef.getrangecheckstring : string;
begin
   if (cs_smartlink in aktmoduleswitches) then
     getrangecheckstring:='R_'+current_module^.modulename^+tostr(rangenr)
   else
     getrangecheckstring:='R_'+tostr(rangenr);
end;


procedure tenumdef.genrangecheck;
begin
   if rangenr=0 then
     begin
        { generate two constant for bounds }
        getlabelnr(rangenr);
        if (cs_smartlink in aktmoduleswitches) then
          datasegment^.concat(new(pai_symbol,initname_global(getrangecheckstring)))
        else
          datasegment^.concat(new(pai_symbol,initname(getrangecheckstring)));
        datasegment^.concat(new(pai_const,init_32bit(minval)));
        datasegment^.concat(new(pai_const,init_32bit(maxval)));
     end;
end;

procedure Tenumdef.write_child_rtti_data;

begin
   if assigned(basedef) then
        basedef^.get_rtti_label;
end;


procedure Tenumdef.write_rtti_data;

var i:word;

begin
    rttilist^.concat(new(pai_const,init_8bit(tkEnumeration)));
    write_rtti_name;
    case savesize of
        1:
            rttilist^.concat(new(Pai_const,init_8bit(otUByte)));
        2:
            rttilist^.concat(new(Pai_const,init_8bit(otUWord)));
        4:
            rttilist^.concat(new(Pai_const,init_8bit(otULong)));
    end;
    rttilist^.concat(new(pai_const,init_32bit(minval)));
    rttilist^.concat(new(pai_const,init_32bit(maxval)));
    if assigned(basedef) then
        rttilist^.concat(new(pai_const_symbol,initname(basedef^.get_rtti_label)))
    else
        rttilist^.concat(new(pai_const,init_32bit(0)));
    for i:=0 to symbols^.count-1 do
        begin
            rttilist^.concat(new(Pai_const,
             init_8bit(length(Penumsym(symbols^.at(i))^.name))));
            rttilist^.concat(new(Pai_string,
             init(globals.lower(Penumsym(symbols^.at(i))^.name))));
        end;
    rttilist^.concat(new(pai_const,init_8bit(0)));
end;


function Tenumdef.is_publishable:boolean;

begin
    is_publishable:=true;
end;

function Tenumdef.gettypename:string;

var i:word;
    v:longint;
    r:string;

begin
    r:='(';
    for i:=0 to symbols^.count-1 do
        begin
            v:=Penumsym(symbols^.at(i))^.value;
            if (v>=minval) and (v<=maxval) then
                r:=r+Penumsym(symbols^.at(i))^.name+',';
        end;
    {Turn ',' into ')'.}
    r[length(r)]:=')';
end;

{****************************************************************************
                                 Torddef
****************************************************************************}


constructor Torddef.init(t:Tbasetype;l,h:Tconstant;
                         Aowner:Pcontainingsymtable);

begin
    inherited init(Aowner);
    low:=l;
    high:=h;
    typ:=t;
    setsize;
end;

constructor Torddef.load(var s:Tstream);

begin
    inherited load(s);
(*  typ:=tbasetype(readbyte);
    low:=readlong;
    high:=readlong;*)
    setsize;
end;


procedure Torddef.setsize;

begin
   if typ=uauto then
        begin
            {Generate a unsigned range if high<0 and low>=0 }
            if (low.values>=0) and (high.values<=255) then
                typ:=u8bit
            else if (low.signed) and (low.values>=-128) and (high.values<=127) then
                typ:=s8bit
            else if (low.values>=0) and (high.values<=65536) then
                typ:=u16bit
            else if (low.signed) and (low.values>=-32768) and (high.values<=32767) then
                typ:=s16bit
            else if low.signed then
                typ:=s32bit
            else
                typ:=u32bit
        end;
    case typ of
        u8bit,s8bit,uchar,bool8bit:
            savesize:=1;

        u16bit,s16bit,bool16bit:
            savesize:=2;

        s32bit,u32bit,bool32bit:
            savesize:=4;

        u64bit,s64bitint:
            savesize:=8;
        else
            savesize:=0;
    end;
   rangenr:=0;
end;

function Torddef.getrangecheckstring:string;

begin
    if (cs_smartlink in aktmoduleswitches) then
        getrangecheckstring:='R_'+current_module^.modulename^+tostr(rangenr)
    else
        getrangecheckstring:='R_'+tostr(rangenr);
end;

procedure Torddef.genrangecheck;

begin
   if rangenr=0 then
        begin
            {Generate two constant for bounds.}
            getlabelnr(rangenr);
            if (cs_smartlink in aktmoduleswitches) then
              datasegment^.concat(new(Pai_symbol,
               initname_global(getrangecheckstring)))
            else
              datasegment^.concat(new(Pai_symbol,
               initname(getrangecheckstring)));
            datasegment^.concat(new(Pai_const,init_8bit(byte(low.signed))));
            datasegment^.concat(new(Pai_const,init_32bit(low.values)));
            datasegment^.concat(new(Pai_const,init_8bit(byte(high.signed))));
            datasegment^.concat(new(Pai_const,init_32bit(high.values)));
        end;
end;


procedure Torddef.store(var s:Tstream);

begin
    inherited store(s);
(*  writebyte(byte(typ));
    writelong(low);
    writelong(high);
    current_ppu^.writeentry(iborddef);*)
end;


procedure Torddef.write_rtti_data;

const   trans:array[uchar..bool8bit] of byte=
            (otubyte,otubyte,otuword,otulong,
             otsbyte,otsword,otslong,otubyte);

begin
    case typ of
        bool8bit:
            rttilist^.concat(new(Pai_const,init_8bit(tkbool)));
        uchar:
            rttilist^.concat(new(Pai_const,init_8bit(tkchar)));
        else
            rttilist^.concat(new(Pai_const,init_8bit(tkinteger)));
    end;
    write_rtti_name;
    rttilist^.concat(new(Pai_const,init_8bit(byte(trans[typ]))));
    rttilist^.concat(new(Pai_const,init_32bit(low.values)));
    rttilist^.concat(new(Pai_const,init_32bit(high.values)));
end;

function Torddef.is_publishable:boolean;

begin
    is_publishable:=typ in [uchar..bool8bit];
end;

function Torddef.gettypename:string;

const   names:array[Tbasetype] of string[20]=('<unknown type>',
                'untyped','char','byte','word','dword','shortInt',
                'smallint','longInt','boolean','wordbool',
                'longbool','qword','int64');

begin
    gettypename:=names[typ];
end;

{****************************************************************************
                                Tfloatdef
****************************************************************************}

constructor Tfloatdef.init(t:Tfloattype;Aowner:Pcontainingsymtable);

begin
    inherited init(Aowner);
    typ:=t;
    setsize;
end;


constructor Tfloatdef.load(var s:Tstream);

begin
    inherited load(s);
(*  typ:=Tfloattype(readbyte);*)
    setsize;
end;


procedure tfloatdef.setsize;

begin
    case typ of
        f16bit:
            savesize:=2;
        f32bit,
        s32real:
            savesize:=4;
        s64real:
            savesize:=8;
        s80real:
            savesize:=extended_size;
        s64comp:
            savesize:=8;
        else
            savesize:=0;
    end;
end;


procedure Tfloatdef.store(var s:Tstream);

begin
    inherited store(s);
(*  writebyte(byte(typ));
    current_ppu^.writeentry(ibfloatdef);*)
end;

procedure Tfloatdef.write_rtti_data;

const   translate:array[Tfloattype] of byte=
            (ftsingle,ftdouble,ftextended,ftcomp,ftfixed16,ftfixed32);
begin
    rttilist^.concat(new(Pai_const,init_8bit(tkfloat)));
    write_rtti_name;
    rttilist^.concat(new(Pai_const,init_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','fixed','shortfixed');

begin
   gettypename:=names[typ];
end;

{***************************************************************************
                                   Tsetdef
***************************************************************************}

{ For i386 smallsets work,
  for m68k there are problems
  can be test by compiling with -dusesmallset PM }
{$ifdef i386}
{$define usesmallset}
{$endif i386}

constructor Tsetdef.init(s:Pdef;high:longint;Aowner:Pcontainingsymtable);

begin
    inherited init(Aowner);
    setof:=s;
    if high<32 then
        begin
            settype:=smallset;
            savesize:=4;
        end
    else if high<256 then
            begin
                settype:=normset;
                savesize:=32;
            end
{$ifdef testvarsets}
    else if high<$10000 then
        begin
            settype:=varset;
            savesize:=4*((high+31) div 32);
        end
{$endif testvarsets}
    else
        message(sym_e_ill_type_decl_set);
end;


constructor Tsetdef.load(var s:Tstream);

begin
    inherited load(s);
(*  setof:=readdefref;
    settype:=tsettype(readbyte);
    case settype of
        normset:
            savesize:=32;
        varset:
            savesize:=readlong;
        smallset:
            savesize:=sizeof(longint);
    end;*)
end;


procedure Tsetdef.store(var s:Tstream);

begin
    inherited store(s);
(*  writedefref(setof);
    writebyte(byte(settype));
    if settype=varset then
        writelong(savesize);
    current_ppu^.writeentry(ibsetdef);*)
end;


procedure Tsetdef.deref;

begin
{   resolvedef(setof);}
end;


procedure Tsetdef.write_rtti_data;

begin
    rttilist^.concat(new(pai_const,init_8bit(tkset)));
    write_rtti_name;
    rttilist^.concat(new(pai_const,init_8bit(otuLong)));
    rttilist^.concat(new(pai_const_symbol,initname(setof^.get_rtti_label)));
end;


procedure Tsetdef.write_child_rtti_data;

begin
    setof^.get_rtti_label;
end;


function Tsetdef.is_publishable:boolean;

begin
    is_publishable:=settype=smallset;
end;

function Tsetdef.gettypename:string;

begin
   gettypename:='set of '+setof^.typename;
end;
{***************************************************************************
                                  Trecorddef
***************************************************************************}

constructor Trecorddef.init(s:Precordsymtable;Aowner:Pcontainingsymtable);

begin
    inherited init(Aowner);
    symtable:=s;
    savesize:=symtable^.datasize;
end;


constructor Trecorddef.load(var s:Tstream);

var oldread_member:boolean;
begin
(*  inherited load(s);
    savesize:=readlong;
    oldread_member:=read_member;
    read_member:=true;
    symtable:=new(psymtable,loadas(recordsymtable));
    read_member:=oldread_member;
    symtable^.defowner := @self;*)
end;


destructor Trecorddef.done;

begin
    if symtable<>nil then
        dispose(symtable,done);
    inherited done;
end;

var
 binittable : boolean;

procedure check_rec_inittable(s:Pnamedindexobject);

begin
    if (typeof(s^)=typeof(Tvarsym)) and
     ((typeof((Pvarsym(s)^.definition^))<>typeof(Tobjectdef)) or
      not (oo_is_class in Pobjectdef(Pvarsym(s)^.definition)^.options)) then
        binittable:=pvarsym(s)^.definition^.needs_inittable;
end;


function Trecorddef.needs_inittable:boolean;

var oldb:boolean;

begin
    { there are recursive calls to needs_rtti possible, }
    { so we have to change to old value how else should }
    { we do that ? check_rec_rtti can't be a nested     }
    { procedure of needs_rtti !                         }
    oldb:=binittable;
    binittable:=false;
    symtable^.foreach({$ifndef TP}@{$endif}check_rec_inittable);
    needs_inittable:=binittable;
    binittable:=oldb;
end;


procedure Trecorddef.deref;

var oldrecsyms:Psymtable;

begin
(*   oldrecsyms:=aktrecordsymtable;
   aktrecordsymtable:=symtable;
   { now dereference the definitions }
   symtable^.deref;
   aktrecordsymtable:=oldrecsyms;*)
end;


procedure Trecorddef.store(var s:Tstream);

var oldread_member:boolean;

begin
(*  oldread_member:=read_member;
    read_member:=true;
    inherited store(s);
    writelong(savesize);
    current_ppu^.writeentry(ibrecorddef);
    self.symtable^.writeas;
    read_member:=oldread_member;*)
end;

procedure count_inittable_fields(sym:Pnamedindexobject);
                                {$ifndef fpc}far;{$endif}

begin
   if (typeof(sym^)=typeof(Tvarsym)) and
    (Pvarsym(sym)^.definition^.needs_inittable) then
        inc(count);
end;


procedure count_fields(sym:Pnamedindexobject);{$ifndef fpc}far;{$endif}

begin
   inc(count);
end;


procedure write_field_inittable(sym:Pnamedindexobject);
                                {$ifndef fpc}far;{$endif}

begin
    if (typeof(sym^)=typeof(Tvarsym)) and
     Pvarsym(sym)^.definition^.needs_inittable then
        begin
            rttilist^.concat(new(Pai_const_symbol,
             init(pvarsym(sym)^.definition^.get_inittable_label)));
            rttilist^.concat(new(Pai_const,
             init_32bit(pvarsym(sym)^.address)));
        end;
end;


procedure write_field_rtti(sym:Pnamedindexobject);{$ifndef fpc}far;{$endif}

begin
    rttilist^.concat(new(Pai_const_symbol,
     initname(Pvarsym(sym)^.definition^.get_rtti_label)));
    rttilist^.concat(new(Pai_const,
     init_32bit(Pvarsym(sym)^.address)));
end;


procedure generate_child_inittable(sym:Pnamedindexobject);
                                   {$ifndef fpc}far;{$endif}


begin
    if (typeof(sym^)=typeof(Tvarsym)) and
        Pvarsym(sym)^.definition^.needs_inittable then
    {Force inittable generation }
        Pvarsym(sym)^.definition^.get_inittable_label;
end;


procedure generate_child_rtti(sym:Pnamedindexobject);
                              {$ifndef fpc}far;{$endif}

begin
    Pvarsym(sym)^.definition^.get_rtti_label;
end;

procedure Trecorddef.write_child_rtti_data;

begin
    symtable^.foreach({$ifndef TP}@{$endif}generate_child_rtti);
end;


procedure Trecorddef.write_child_init_data;

begin
    symtable^.foreach({$ifndef TP}@{$endif}generate_child_inittable);
end;


procedure Trecorddef.write_rtti_data;

begin
    rttilist^.concat(new(pai_const,init_8bit(tkrecord)));
    write_rtti_name;
    rttilist^.concat(new(pai_const,init_32bit(size)));
    count:=0;
    symtable^.foreach({$ifndef TP}@{$endif}count_fields);
    rttilist^.concat(new(pai_const,init_32bit(count)));
    symtable^.foreach({$ifndef TP}@{$endif}write_field_rtti);
end;


procedure Trecorddef.write_init_data;

begin
    rttilist^.concat(new(pai_const,init_8bit(14)));
    write_rtti_name;
    rttilist^.concat(new(pai_const,init_32bit(size)));
    count:=0;
    symtable^.foreach({$ifndef TP}@{$endif}count_inittable_fields);
    rttilist^.concat(new(pai_const,init_32bit(count)));
    symtable^.foreach({$ifndef TP}@{$endif}write_field_inittable);
end;

function Trecorddef.gettypename:string;

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

{***************************************************************************
                            Tabstractprocdef
***************************************************************************}

constructor Tabstractprocdef.init(Aowner:Pcontainingsymtable);

begin
    inherited init(Aowner);
    retdef:=voiddef;
    savesize:=target_os.size_of_pointer;
end;

constructor Tabstractprocdef.load(var s:Tstream);

var count,i:word;

begin
    inherited load(s);
(*  retdef:=readdefref;
    fpu_used:=readbyte;
    options:=readlong;
    count:=readword;
    new(parameters);
    savesize:=target_os.size_of_pointer;
    for i:=1 to count do
        parameters^.readsymref;*)
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
    if (retdef<>nil) and (typeof(retdef^)=typeof(Tfloatdef)) and
     (Pfloatdef(retdef)^.typ in [f32bit,f16bit]) then
        fpu_used:=2;
end;

procedure Tabstractprocdef.deref;

var i:longint;

begin
    inherited deref;
{   resolvedef(retdef);}
    for i:=0 to parameters^.count-1 do
        Psym(parameters^.at(i))^.deref;
end;

function Tabstractprocdef.para_size:longint;

var i,l:longint;

begin
    l:=0;
    for i:=0 to parameters^.count-1 do
        inc(l,Pparamsym(parameters^.at(i))^.getpushsize);
    para_size:=l;
end;

procedure Tabstractprocdef.store(var s:Tstream);

var count,i:word;

begin
    inherited store(s);
{   writedefref(retdef);
    current_ppu^.do_interface_crc:=false;
    writebyte(fpu_used);
    writelong(options);
    writeword(parameters^.count);
    for i:=0 to parameters^.count-1 do
        begin
            writebyte(byte(hp^.paratyp));
            writesymfref(hp^.data);
        end;}
end;


function Tabstractprocdef.demangled_paras:string;

var i:longint;
    s:string;

procedure doconcat(p:Pparameter);

begin
    s:=s+p^.data^.name;
    if p^.paratyp=vs_var then
        s:=s+'var'
    else if p^.paratyp=vs_const then
        s:=s+'const';
end;

begin
    s:='(';
    for i:=0 to parameters^.count-1 do
        doconcat(parameters^.at(i));
    s[length(s)]:=')';
    demangled_paras:=s;
end;

destructor Tabstractprocdef.done;

begin
    dispose(parameters,done);
    inherited done;
end;

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

constructor Tprocdef.init(Aowner:Pcontainingsymtable);

begin
    inherited init(Aowner);
    fileinfo:=aktfilepos;
    extnumber:=-1;
    new(localst,init);
    if (cs_browser in aktmoduleswitches) and make_ref then
        begin
            new(references,init(2*owner^.index_growsize,
                                owner^.index_growsize));
            references^.insert(new(Pref,init(tokenpos)));
        end;
    {First, we assume that all registers are used }
    usedregisters:=[low(Tregister)..high(Tregister)];
    forwarddef:=true;
end;


constructor Tprocdef.load(var s:Tstream);

var a:string;

begin
    inherited load(s);
(*  usedregisters:=readlong;

    a:=readstring;
    setstring(_mangledname,s);

    extnumber:=readlong;
    nextoerloaded:=pprocdef(readdefref);
    _class := pobjectdef(readdefref);
    readposinfo(fileinfo);

    if (cs_link_deffile in aktglobalswitches)
     and (poexports in options) then
        deffile.ddexport(mangledname);

    count:=true;*)
end;


const local_symtable_index : longint = $8001;

procedure tprocdef.load_references;

var pos:Tfileposinfo;
    pdo:Pobjectdef;
    move_last:boolean;

begin
(*  move_last:=lastwritten=lastref;
    while (not current_ppu^.endofentry) do
        begin
            readposinfo(pos);
            inc(refcount);
            lastref:=new(pref,init(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 is_in_current then
        begin
{$ifndef NOLOCALBROWSER}
            pdo:=_class;
            new(parast,loadas(parasymtable));
            parast^.next:=owner;
            parast^.load_browser;
            new(localst,loadas(localsymtable));
            localst^.next:=parast;
            localst^.load_browser;
{$endif NOLOCALBROWSER}
        end;*)
end;


function Tprocdef.write_references:boolean;

var ref:Pref;
    pdo:Pobjectdef;
    move_last:boolean;

begin
(*  move_last:=lastwritten=lastref;
    if move_last and (((current_module^.flags and uf_local_browser)=0)
     or not is_in_current) then
        exit;
    {Write address of this symbol }
    writedefref(@self);
    {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
                    writeposinfo(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;
    current_ppu^.writeentry(ibdefref);
    write_references:=true;
    if ((current_module^.flags and uf_local_browser)<>0)
     and is_in_current then
        begin
            pdo:=_class;
            if (owner^.symtabletype<>localsymtable) then
            while assigned(pdo) do
                begin
                    if pdo^.publicsyms<>aktrecordsymtable then
                        begin
                            pdo^.publicsyms^.unitid:=local_symtable_index;
                            inc(local_symtable_index);
                        end;
                    pdo:=pdo^.childof;
                end;

            {We need TESTLOCALBROWSER para and local symtables
             PPU files are then easier to read PM.}
            inc(local_symtable_index);
            parast^.write_browser;
            if not assigned(localst) then
                localst:=new(psymtable,init);
            localst^.writeas;
            localst^.unitid:=local_symtable_index;
            inc(local_symtable_index);
            localst^.write_browser;
            {Decrement for.}
            local_symtable_index:=local_symtable_index-2;
            pdo:=_class;
            if (owner^.symtabletype<>localsymtable) then
                while assigned(pdo) do
                    begin
                        if pdo^.publicsyms<>aktrecordsymtable then
                            dec(local_symtable_index);
                        pdo:=pdo^.childof;
                    end;
        end;*)
end;

destructor Tprocdef.done;

begin
    if references<>nil then
        dispose(references,done);
    if (localst<>nil) and (typeof(localst^)<>typeof(Timplsymtable)) then
        dispose(localst,done);
{   if (poinline in options) and (code,nil) then
        disposetree(ptree(code));}
    if _mangledname<>nil then
        disposestr(_mangledname);
    inherited done;
end;


procedure Tprocdef.store(var s:Tstream);

begin
(*  inherited store(s);
    current_ppu^.do_interface_crc:=false;
    writelong(usedregisters);
    writestring(mangledname);
    current_ppu^.do_interface_crc:=true;
    writelong(extnumber);
    if (options and pooperator) = 0 then
        writedefref(nextoverloaded)
    else
        begin
            {Only write the overloads from the same unit }
            if assigned(nextoverloaded) and
             (nextoverloaded^.owner=owner) then
                writedefref(nextoverloaded)
            else
                writedefref(nil);
        end;
    writedefref(_class);
    writeposinfo(fileinfo);
    if (poinline and options) then
        begin
            {We need to save
                - the para and the local symtable
                - the code ptree !! PM
               writesymtable(parast);
               writesymtable(localst);
               writeptree(ptree(code));
               }
        end;
    current_ppu^.writeentry(ibprocdef);*)
end;

procedure Tprocdef.deref;

begin
{   inherited deref;
    resolvedef(pdef(nextoverloaded));
    resolvedef(pdef(_class));}
end;


function Tprocdef.mangledname:string;

var i:word;
    a:byte;
    s:Pprocsym;
    r:string;

begin
    if _mangledname<>nil then
        mangledname:=_mangledname^
    else
        begin
            {If the procedure is in a unit, we start with the unitname.}
            if current_module^.is_unit then
                r:='_'+current_module^.modulename^
            else
                r:='';
            a:=length(r);
            {If we are a method we add the name of the object we are
             belonging to.}
            if (Pprocsym(sym)^._class<>nil) then
                r:=r+'_M'+Pprocsym(sym)^._class^.sym^.name+'_M';
            {Then we add the names of the procedures we are defined in
             (for the case we are a nested procedure).}
            s:=Pprocsym(sym)^.sub_of;
            while typeof(s^.owner^)=typeof(Tprocsymtable) do
                begin
                    insert('_$'+s^.name,r,a);
                    s:=s^.sub_of;
                end;
            r:=r+'_'+sym^.name;
            {Add the types of all parameters.}
            for i:=0 to parameters^.count-1 do
                begin
                    r:=r+'$'+Pparameter(parameters^.at(i))^.data^.name;
                end;
        end;
end;

procedure Tprocdef.setmangledname(const s:string);

begin
    if _mangledname<>nil then
        disposestr(_mangledname);
    _mangledname:=stringdup(s);
    if localst<>nil then
        begin
            stringdispose(localst^.name);
            localst^.name:=stringdup('locals of '+s);
        end;
end;


{***************************************************************************
                                 Tprocvardef
***************************************************************************}


function Tprocvardef.size:longint;

begin
    if pomethodpointer in options then
        size:=2*target_os.size_of_pointer
    else
        size:=target_os.size_of_pointer;
end;


{$ifdef GDB}
function tprocvardef.stabstring : pchar;
var
   nss : pchar;
   i : word;
   param : pdefcoll;
begin
  i := 0;
  param := para1;
  while assigned(param) do
    begin
    inc(i);
    param := param^.next;
    end;
  getmem(nss,1024);
  { it is not a function but a function pointer !! (PM) }

  strpcopy(nss,'*f'+retdef^.numberstring{+','+tostr(i)}+';');
  param := para1;
  i := 0;
  { 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 }
  (* 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^.data^.numberstring+','+vartyp+';');
    strcat(nss,pst);
    strdispose(pst);
    param := param^.next;
    end; *)
  {strpcopy(strend(nss),';');}
  stabstring := strnew(nss);
  freemem(nss,1024);
end;


procedure tprocvardef.concatstabto(asmlist : paasmoutput);
begin
   if ( not assigned(sym) or sym^.isusedinstab or (cs_gdb_dbx in aktglobalswitches))
     and not is_def_stab_written then
     inherited concatstabto(asmlist);
   is_def_stab_written:=true;
end;
{$endif GDB}


procedure Tprocvardef.write_rtti_data;
begin
   {!!!!!!!}
end;


procedure Tprocvardef.write_child_rtti_data;
begin
   {!!!!!!!!}
end;


function Tprocvardef.is_publishable:boolean;

begin
    is_publishable:=pomethodpointer in options;
end;

function Tprocvardef.gettypename:string;

begin
   gettypename:='<procedure variable type>'
end;

end.