paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-06-07 16:19:41 +02:00
Code Issues Packages Projects Releases Wiki Activity
9ef9f62da1
fpc/compiler/new/symtable/defs.pas
daniel a511be87c4 * Changed names of procedures flags 
*  Changed VMT generation
2000-03-16 12:52:47 +00:00

3149 lines
88 KiB
ObjectPascal
Raw Blame History

{
$Id$
Copyright (C) 1998-2000 by Daniel Mantione
and other members of the Free Pascal development team
This unit handles 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.
****************************************************************************
}
{$ifdef TP}
{$N+,E+,F+}
{$endif}
unit defs;
interface
uses symtable,objects,{$IFDEF TP}xobjects,{$ENDIF}
cobjects,symtablt,globtype
{$ifdef i386}
,cpubase
{$endif}
{$ifdef m68k}
,m68k
{$endif}
{$ifdef alpha}
,alpha
{$endif};
type Targconvtyp=(act_convertable,act_equal,act_exact);
Tvarspez=(vs_value,vs_const,vs_var);
Tobjoption=(oo_has_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_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.}
{When has_virtual is set, has_vmt is also set....
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;
{Calling convention for tprocdef and Tprocvardef.}
Tproccalloption=(po_call_none,
po_call_clearstack, {Use IBM flat calling
convention. (Used by GCC.)}
po_call_leftright, {Push parameters from left to
right.}
po_call_cdecl, {Procedure uses C styled
calling.}
po_call_register, {Procedure uses register
(fastcall) calling.}
po_call_stdcall, {Procedure uses stdcall
call.}
po_call_safecall, {Safe call calling
conventions.}
po_call_palmossyscall, {Procedure is a PalmOS
system call.}
po_call_system,
po_call_inline, {Procedure is an assembler
macro.}
po_call_internproc, {Procedure has compiler
magic.}
po_call_internconst); {Procedure has constant
evaluator intern.}
Tproccalloptionset=set of Tproccalloption;
{Basic type for tprocdef and tprocvardef }
Tproctypeoption=(po_type_none,
po_type_proginit, {Program initialization.}
po_type_unitinit, {Unit initialization.}
po_type_unitfinalize, {Unit finalization.}
po_type_constructor, {Procedure is a constructor.}
po_type_destructor, {Procedure is a destructor.}
po_type_operator); {Procedure defines an
operator.}
{Other options for Tprocdef and Tprocvardef.}
Tprocoption=(po_none,
po_classmethod, {Class method.}
po_virtualmethod, {Procedure is a virtual method.}
po_abstractmethod, {Procedure is an abstract method.}
po_staticmethod, {Static method.}
po_overridingmethod, {Method with override directive.}
po_methodpointer, {Method pointer, only in procvardef, also
used for 'with object do'.}
po_containsself, {Self is passed explicit to the
compiler.}
po_interrupt, {Procedure is an interrupt handler.}
po_iocheck, {IO checking should be done after a call
to the procedure.}
po_assembler, {Procedure is written in assembler.}
po_msgstr, {Method for string message handling.}
po_msgint, {Method for int message handling.}
po_exports, {Procedure has export directive (needed
for OS/2).}
po_external, {Procedure is external (in other object
or lib).}
po_savestdregs, {Save std regs cdecl and stdcall need
that!}
po_saveregisters); {Save all registers }
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;
definition: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 TP}
constructor init(Aowner:Pcontainingsymtable);
{$ENDIF}
{$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 TP}
constructor init(Aowner:Pcontainingsymtable;def:Pdef);
{$ENDIF TP}
{$ifdef GDB}
function stabstring : pchar;virtual;
procedure concatstabto(asmlist : paasmoutput);virtual;
{$endif GDB}
function gettypename:string;virtual;
end;
Pvmtentry=^Tvmtentry;
Pglobalvmtentry=^Tglobalvmtentry;
Plocalvmtentry=^Tlocalvmtentry;
Pobjectdef=^Tobjectdef;
Pabstractprocdef=^Pabstractprocdef;
Pprocvardef=^Tprocvardef;
Pprocdef = ^Tprocdef;
Tvmtentry=object(Tobject)
owner:Pobjectdef;
constructor init(Aowner:Pobjectdef);
function mangledname:string;virtual;
end;
Tglobalvmtentry=object(Tvmtentry)
constructor init(Aowner:Pobjectdef;proc:Pprocdef);
function mangledname:string;virtual;
private
def:Pprocdef;
end;
Tlocalvmtentry=object(Tvmtentry)
constructor init(Aowner:Pobjectdef;proc:Pprocdef);
function mangledname:string;virtual;
private
name:Pstring;
end;
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;
{Contains Tvmtentry objects to describe the layout of the vmt.}
vmt_layout:Pcollection;
constructor init(const n:string;Aowner:Pcontainingsymtable;
parent:Pobjectdef;isclass:boolean);
constructor load(var s:Tstream);
procedure check_forwards;
function insert(Asym:Psym):boolean;
procedure insertvmt;
function is_related(d:Pobjectdef):boolean;
function search(const s:string;search_protected:boolean):Psym;
function speedsearch(const s:string;speedvalue:longint;
search_protected:boolean):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,
s64bit,u64bit,s64bitint,uwidechar);
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)
definition: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;
{String types}
Tstringtype=(st_default,st_shortstring,st_longstring,
st_ansistring,st_widestring);
{This object needs to be splitted into multiple objects,
one for each stringtype. This is because all code in this
object is different for all string types.}
Pstringdef=^Tstringdef;
Tstringdef=object(Tdef)
string_typ:Tstringtype;
len:longint;
constructor shortinit(l:byte;Aowner:Pcontainingsymtable);
constructor shortload(var s:Tstream);
constructor longinit(l:longint;Aowner:Pcontainingsymtable);
constructor longload(var s:Tstream);
constructor ansiinit(l:longint;Aowner:Pcontainingsymtable);
constructor ansiload(var s:Tstream);
constructor wideinit(l:longint;Aowner:Pcontainingsymtable);
constructor wideload(var s:Tstream);
function stringtypname:string;
function size:longint;virtual;
procedure store(var s:Tstream);virtual;
function gettypename:string;virtual;
function is_publishable : boolean;virtual;
{ debug }
{$ifdef GDB}
function stabstring:Pchar;virtual;
procedure concatstabto(asmlist : Paasmoutput);virtual;
{$endif GDB}
{ init/final }
function needs_inittable : boolean;virtual;
{ rtti }
procedure write_rtti_data;virtual;
end;
Tabstractprocdef=object(Tdef)
{Saves a definition to the return type }
retdef:Pdef;
fpu_used:byte; {How many stack fpu must be empty.}
proctype:Tproctypeoption;
options:Tprocoptionset; {Save the procedure options.}
calloptions:Tproccalloptionset;
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;
Tprocvardef=object(Tabstractprocdef)
{$IFDEF TP}
constructor init(Aowner:Pcontainingsymtable);
{$ENDIF TP}
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;
{This datastructure is used to store the message information
when a procedure is declared as:
;message 'str';
;message int;
;virtual int;
}
Tmessageinf=record
case integer of
0:(str:Pchar);
1:(i:longint);
end;
{This object can be splitted into a Tprocdef, for normal procedures,
a Tmethoddef for methods, and a Tinlinedprocdef and a
Tinlinedmethoddef for inlined procedures.}
Tprocdef = object(tabstractprocdef)
messageinf:Tmessageinf;
{ 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;
vmt_index:longint;
{ 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;
Pforwarddef=^Tforwarddef;
Tforwarddef=object(Tdef)
tosymname:string;
forwardpos:Tfileposinfo;
constructor init(Aowner:Pcontainingsymtable;
const s:string;const pos:Tfileposinfo);
function gettypename:string;virtual;
end;
{Relevant options for assigning a proc or a procvar to a procvar.}
const po_compatibility_options=[
po_classmethod,
po_staticmethod,
po_methodpointer,
po_containsself,
po_interrupt,
po_iocheck,
po_exports
];
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.}
cu64bitdef:Porddef; {Pointer to 64 bit unsigned def.}
cs64bitdef:Porddef; {Pointer to 64 bit signed def.}
voidpointerdef, {Pointer for Void-Pointerdef.}
charpointerdef, {Pointer for Char-Pointerdef.}
voidfarpointerdef:ppointerdef;
s32floatdef : pfloatdef; {Pointer for realconstn.}
s64floatdef : pfloatdef; {Pointer for realconstn.}
s80floatdef : pfloatdef; {Pointer to type of temp. floats.}
s32fixeddef : pfloatdef; {Pointer to type of temp. fixed.}
cshortstringdef, {Pointer to type of short string const.}
openshortstringdef, {Pointer to type of an openshortstring,
needed for readln().}
clongstringdef, {Pointer to type of long string const.}
cansistringdef, {Pointer to type of ansi string const.}
cwidestringdef:Pstringdef; {Pointer to type of wide string const.}
openchararraydef:Parraydef; {Pointer to type of an open array of
char, needed for readln().}
cfiledef:Pfiledef; {Get the same definition for all files
used for stabs.}
implementation
uses systems,symbols,verbose,globals,aasm,files,strings;
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);
{$IFDEF TP}setparent(typeof(Tdef));{$ENDIF}
filetype:=ft;
definition:=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 '+definition^.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);
{$IFDEF TP}setparent(typeof(Tdef));{$ENDIF}
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
****************************************************************************}
{$IFDEF TP}
constructor Terrordef.init(Aowner:Pcontainingsymtable);
begin
inherited init(Aowner);
setparent(typeof(Tdef));
end;
{$ENDIF TP}
function Terrordef.gettypename:string;
begin
gettypename:='<erroneous type>';
end;
{****************************************************************************
Tabstractpointerdef
****************************************************************************}
constructor Tabstractpointerdef.init(Aowner:Pcontainingsymtable;def:Pdef);
begin
inherited init(Aowner);
{$IFDEF TP}setparent(typeof(Tdef));{$ENDIF}
include(properties,dp_ret_in_acc);
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);
{$IFDEF TP}setparent(typeof(Tabstractpointerdef));{$ENDIF}
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
****************************************************************************}
{$IFDEF TP}
constructor Tclassrefdef.init(Aowner:Pcontainingsymtable;def:Pdef);
begin
inherited init(Aowner,def);
setparent(typeof(Tpointerdef));
end;
{$ENDIF TP}
function Tclassrefdef.gettypename:string;
begin
gettypename:='Class of '+definition^.typename;
end;
{***************************************************************************
TVMTENTRY
***************************************************************************}
constructor Tvmtentry.init(Aowner:Pobjectdef);
begin
inherited init;
{$IFDEF TP}setparent(typeof(Tobject));{$ENDIF}
owner:=Aowner;
end;
function Tvmtentry.mangledname:string;
begin
abstract;
end;
{***************************************************************************
TGLOBALVMTENTRY
***************************************************************************}
constructor Tglobalvmtentry.init(Aowner:Pobjectdef;proc:Pprocdef);
begin
inherited init(Aowner);
{$IFDEF TP}setparent(typeof(Tvmtentry));{$ENDIF TP}
def:=proc;
end;
function Tglobalvmtentry.mangledname:string;
begin
mangledname:=def^.mangledname;
end;
{***************************************************************************
TLOCALVMTENTRY
***************************************************************************}
constructor Tlocalvmtentry.init(Aowner:Pobjectdef;proc:Pprocdef);
begin
inherited init(Aowner);
{$IFDEF TP}setparent(typeof(Tvmtentry));{$ENDIF TP}
if po_abstractmethod in proc^.options then
name:=stringdup('FPC_ABSTRACTERROR')
else
name:=stringdup(proc^.mangledname);
end;
function Tlocalvmtentry.mangledname:string;
begin
mangledname:=name^;
end;
{***************************************************************************
TOBJECTDEF
***************************************************************************}
constructor Tobjectdef.init(const n:string;Aowner:Pcontainingsymtable;
parent:Pobjectdef;isclass:boolean);
begin
inherited init(Aowner);
{$IFDEF TP}setparent(typeof(Tdef));{$ENDIF}
new(publicsyms,init);
publicsyms^.name:=stringdup(n);
publicsyms^.defowner:=@self;
set_parent(parent);
objname:=stringdup(n);
if isclass then
begin
include(properties,dp_ret_in_acc);
include(options,oo_is_class);
end;
end;
procedure tobjectdef.set_parent(parent:Pobjectdef);
const inherited_options=[oo_has_virtual,
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_virtual 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_virtual,oo_is_class]*parent^.options<>[] then
begin
vmt_offset:=parent^.vmt_offset;
include(options,oo_has_virtual);
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;
var o:Pobjectdef;
c:Pcollection;
i:word;
begin
if vmt_layout<>nil then
internalerror($990803);
{Make room for a vmtlink in the object.
First round up to aktpakrecords.}
publicsyms^.datasize:=align(publicsyms^.datasize,
packrecordalignment[aktpackrecords]);
vmt_offset:=publicsyms^.datasize;
publicsyms^.datasize:=publicsyms^.datasize+
target_os.size_of_pointer;
{Set up the vmt layout collection.
First search for a vmt in a parent object.}
o:=childof;
c:=nil;
while o<>nil do
begin
if o^.vmt_layout<>nil then
begin
c:=vmt_layout;
break;
end;
o:=o^.childof;
end;
if c=nil then
new(vmt_layout,init(8,8))
else
begin
{We should copy the vmt layout of our parent object. Our vmt
layout will change as soon as methods are overridden or when
new virtual methods are added.}
new(vmt_layout,init(c^.limit,8));
for i:=0 to c^.count-1 do
vmt_layout^.insert(c^.at(i));
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.is_related(d:Pobjectdef):boolean;
var hp:Pobjectdef;
begin
hp:=@self;
is_related:=false;
while assigned(hp) do
begin
if hp=d then
begin
is_related:=true;
break;
end;
hp:=hp^.childof;
end;
end;
function Tobjectdef.insert(Asym:Psym):boolean;
var speedvalue:longint;
s:Psym;
op:Tobjpropset;
begin
{First check if the symbol already exists.}
s:=privatesyms^.speedsearch(Asym^.name,Asym^.speedvalue);
if s=nil then
protectedsyms^.speedsearch(Asym^.name,Asym^.speedvalue);
if s=nil then
publicsyms^.speedsearch(Asym^.name,Asym^.speedvalue);
if s<>nil then
duplicatesym(sym)
else
begin
{Asym is a Tprocsym, Tvarsym or Tpropertysym.}
if Asym^.is_object(typeof(Tprocsym)) then
op:=Pprocsym(Asym)^.objprop
else if Asym^.is_object(typeof(Tvarsym)) then
op:=Pvarsym(Asym)^.objprop
else if Asym^.is_object(typeof(Tpropertysym)) then
op:=Ppropertysym(Asym)^.objprop;
if sp_private in op then
insert:=privatesyms^.insert(Asym)
else if sp_protected in op then
insert:=protectedsyms^.insert(Asym)
else if sp_public in op then
insert:=publicsyms^.insert(Asym);
end;
end;
function Tobjectdef.search(const s:string;search_protected:boolean):Psym;
begin
search:=speedsearch(s,getspeedvalue(s),search_protected);
end;
function Tobjectdef.speedsearch(const s:string;speedvalue:longint;
search_protected:boolean):Psym;
var r:Psym;
begin
r:=publicsyms^.speedsearch(s,speedvalue);
{Privatesyms should be set to nil after compilation of the unit.
This way, private syms are not found by objects in other units.}
if (r=nil) and (privatesyms<>nil) then
r:=privatesyms^.speedsearch(s,speedvalue);
if (r=nil) and search_protected 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 not(oo_has_virtual 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;
var i:longint;
ve:Pvmtentry;
begin
{We should be carefull when disposing the vmt_layout; there are
vmt entries in it which are from methods of our ancestor, we
should not dispose these. So first set them to nil.}
for i:=0 to vmt_layout^.count do
if Pvmtentry(vmt_layout^.at(i))^.owner<>@self then
vmt_layout^.atput(i,nil);
dispose(vmt_layout,done);
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 sym^.is_object(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(proc:Pcollection;shiftvalue:byte);
var typvalue:byte;
begin
if proc=nil then
begin
rttilist^.concat(new(pai_const,init_32bit(1)));
typvalue:=3;
end
else if Psym(proc^.at(0))^.is_object(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)^.readaccess,0);
writeproc(Ppropertysym(sym)^.writeaccess,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)^.storedaccess,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);
{$IFDEF TP}setparent(typeof(Tdef));{$ENDIF}
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_create_smart 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_create_smart in aktmoduleswitches) then
datasegment^.concat(new(pai_symbol,
initname_global(getrangecheckstring,10)))
else
datasegment^.concat(new(pai_symbol,
initname(getrangecheckstring,10)));
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);
{$IFDEF TP}setparent(typeof(Tdef));{$ENDIF}
include(properties,dp_ret_in_acc);
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_create_smart 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_create_smart in aktmoduleswitches) then
datasegment^.concat(new(Pai_symbol,
initname_global(getrangecheckstring,8)))
else
datasegment^.concat(new(Pai_symbol,
initname(getrangecheckstring,8)));
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);
{$IFDEF TP}setparent(typeof(Tdef));{$ENDIF}
include(properties,dp_ret_in_acc);
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_create_smart 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_create_smart in aktmoduleswitches) then
datasegment^.concat(new(Pai_symbol,
initname_global(getrangecheckstring,10)))
else
datasegment^.concat(new(Pai_symbol,
initname(getrangecheckstring,10)));
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','card64','widechar');
begin
gettypename:=names[typ];
end;
{****************************************************************************
Tfloatdef
****************************************************************************}
constructor Tfloatdef.init(t:Tfloattype;Aowner:Pcontainingsymtable);
begin
inherited init(Aowner);
{$IFDEF TP}setparent(typeof(Tdef));{$ENDIF}
if t=f32bit then
include(properties,dp_ret_in_acc);
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);
{$IFDEF TP}setparent(typeof(Tdef));{$ENDIF}
definition:=s;
if high<32 then
begin
settype:=smallset;
savesize:=4;
include(properties,dp_ret_in_acc);
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(definition^.get_rtti_label)));
end;
procedure Tsetdef.write_child_rtti_data;
begin
definition^.get_rtti_label;
end;
function Tsetdef.is_publishable:boolean;
begin
is_publishable:=settype=smallset;
end;
function Tsetdef.gettypename:string;
begin
gettypename:='set of '+definition^.typename;
end;
{***************************************************************************
Trecorddef
***************************************************************************}
constructor Trecorddef.init(s:Precordsymtable;Aowner:Pcontainingsymtable);
begin
inherited init(Aowner);
{$IFDEF TP}setparent(typeof(Tdef));{$ENDIF}
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;
{***************************************************************************
Tstringprocdef
***************************************************************************}
constructor Tstringdef.shortinit(l:byte;Aowner:Pcontainingsymtable);
begin
inherited init(Aowner);
{$IFDEF TP}setparent(typeof(Tdef));{$ENDIF}
string_typ:=st_shortstring;
len:=l;
savesize:=len+1;
end;
constructor Tstringdef.shortload(var s:Tstream);
begin
inherited load(s);
string_typ:=st_shortstring;
{ len:=readbyte;
savesize:=len+1;}
end;
constructor Tstringdef.longinit(l:longint;Aowner:Pcontainingsymtable);
begin
inherited init(Aowner);
string_typ:=st_longstring;
len:=l;
savesize:=target_os.size_of_pointer;
end;
constructor Tstringdef.longload(var s:Tstream);
begin
inherited load(s);
string_typ:=st_longstring;
{ len:=readlong;
savesize:=target_os.size_of_pointer;}
end;
constructor tstringdef.ansiinit(l:longint;Aowner:Pcontainingsymtable);
begin
inherited init(Aowner);
include(properties,dp_ret_in_acc);
string_typ:=st_ansistring;
len:=l;
savesize:=target_os.size_of_pointer;
end;
constructor Tstringdef.ansiload(var s:Tstream);
begin
inherited load(s);
string_typ:=st_ansistring;
{ len:=readlong;
savesize:=target_os.size_of_pointer;}
end;
constructor Tstringdef.wideinit(l:longint;Aowner:Pcontainingsymtable);
begin
inherited init(Aowner);
include(properties,dp_ret_in_acc);
string_typ:=st_widestring;
len:=l;
savesize:=target_os.size_of_pointer;
end;
constructor Tstringdef.wideload(var s:Tstream);
begin
inherited load(s);
string_typ:=st_widestring;
{ len:=readlong;
savesize:=target_os.size_of_pointer;}
end;
function Tstringdef.stringtypname:string;
const typname:array[tstringtype] of string[8]=
('','SHORTSTR','LONGSTR','ANSISTR','WIDESTR');
begin
stringtypname:=typname[string_typ];
end;
function tstringdef.size:longint;
begin
size:=savesize;
end;
procedure Tstringdef.store(var s:Tstream);
begin
inherited store(s);
{ if string_typ=st_shortstring then
writebyte(len)
else
writelong(len);
case string_typ of
st_shortstring:
current_ppu^.writeentry(ibshortstringdef);
st_longstring:
current_ppu^.writeentry(iblongstringdef);
st_ansistring:
current_ppu^.writeentry(ibansistringdef);
st_widestring:
current_ppu^.writeentry(ibwidestringdef);
end;}
end;
{$ifdef GDB}
function tstringdef.stabstring : pchar;
var
bytest,charst,longst : string;
begin
case string_typ of
st_shortstring:
begin
charst := typeglobalnumber('char');
{ this is what I found in stabs.texinfo but
gdb 4.12 for go32 doesn't understand that !! }
{$IfDef GDBknowsstrings}
stabstring := strpnew('n'+charst+';'+tostr(len));
{$else}
bytest := typeglobalnumber('byte');
stabstring := strpnew('s'+tostr(len+1)+'length:'+bytest
+',0,8;st:ar'+bytest
+';1;'+tostr(len)+';'+charst+',8,'+tostr(len*8)+';;');
{$EndIf}
end;
st_longstring:
begin
charst := typeglobalnumber('char');
{ this is what I found in stabs.texinfo but
gdb 4.12 for go32 doesn't understand that !! }
{$IfDef GDBknowsstrings}
stabstring := strpnew('n'+charst+';'+tostr(len));
{$else}
bytest := typeglobalnumber('byte');
longst := typeglobalnumber('longint');
stabstring := strpnew('s'+tostr(len+5)+'length:'+longst
+',0,32;dummy:'+bytest+',32,8;st:ar'+bytest
+';1;'+tostr(len)+';'+charst+',40,'+tostr(len*8)+';;');
{$EndIf}
end;
st_ansistring:
begin
{ an ansi string looks like a pchar easy !! }
stabstring:=strpnew('*'+typeglobalnumber('char'));
end;
st_widestring:
begin
{ an ansi string looks like a pchar easy !! }
stabstring:=strpnew('*'+typeglobalnumber('char'));
end;
end;
end;
procedure tstringdef.concatstabto(asmlist : paasmoutput);
begin
inherited concatstabto(asmlist);
end;
{$endif GDB}
function tstringdef.needs_inittable : boolean;
begin
needs_inittable:=string_typ in [st_ansistring,st_widestring];
end;
function tstringdef.gettypename : string;
const
names : array[tstringtype] of string[20] = ('',
'ShortString','LongString','AnsiString','WideString');
begin
gettypename:=names[string_typ];
end;
procedure tstringdef.write_rtti_data;
begin
case string_typ of
st_ansistring:
begin
rttilist^.concat(new(pai_const,init_8bit(tkAString)));
write_rtti_name;
end;
st_widestring:
begin
rttilist^.concat(new(pai_const,init_8bit(tkWString)));
write_rtti_name;
end;
st_longstring:
begin
rttilist^.concat(new(pai_const,init_8bit(tkLString)));
write_rtti_name;
end;
st_shortstring:
begin
rttilist^.concat(new(pai_const,init_8bit(tkSString)));
write_rtti_name;
rttilist^.concat(new(pai_const,init_8bit(len)));
end;
end;
end;
function tstringdef.is_publishable : boolean;
begin
is_publishable:=true;
end;
{***************************************************************************
Tabstractprocdef
***************************************************************************}
constructor Tabstractprocdef.init(Aowner:Pcontainingsymtable);
begin
inherited init(Aowner);
{$IFDEF TP}setparent(typeof(Tdef));{$ENDIF}
include(properties,dp_ret_in_acc);
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);
{$IFDEF TP}setparent(typeof(Tabstractprocdef));{$ENDIF}
fileinfo:=aktfilepos;
vmt_index:=-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 po_msgstr in options then
strdispose(messageinf.str);
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
***************************************************************************}
{$IFDEF TP}
constructor Tprocvardef.init(Aowner:Pcontainingsymtable);
begin
setparent(typeof(Tabstractprocdef));
end;
{$ENDIF TP}
function Tprocvardef.size:longint;
begin
if po_methodpointer 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:=po_methodpointer in options;
end;
function Tprocvardef.gettypename:string;
begin
gettypename:='<procedure variable type>'
end;
{****************************************************************************
Tforwarddef
****************************************************************************}
constructor tforwarddef.init(Aowner:Pcontainingsymtable;
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 init(Aowner);
{$IFDEF TP}setparent(typeof(Tdef));{$ENDIF}
{ registerdef:=oldregisterdef;}
tosymname:=s;
forwardpos:=pos;
end;
function tforwarddef.gettypename:string;
begin
gettypename:='unresolved forward to '+tosymname;
end;
end.
{
$Log$
Revision 1.6 2000-03-16 12:52:47 daniel
* Changed names of procedures flags
* Changed VMT generation
Revision 1.5 2000/03/11 21:11:24 daniel
* Ported hcgdata to new symtable.
* Alignment code changed as suggested by Peter
+ Usage of my is operator replacement, is_object
Revision 1.4 2000/03/01 11:43:55 daniel
* Some more work on the new symtable.
+ Symtable stack unit 'symstack' added.
}
Reference in New Issue View Git Blame Copy Permalink