paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-07-22 23:36:05 +02:00
Code Issues Packages Projects Releases Wiki Activity
05f2be0455
fpc/compiler/new/symtable/defs.pas
daniel 590de0e5d7 + Brand new symtable: 
+ Less memory usage
  + Less code
  - No debug information yet
  - No unit support yet
1999-08-05 17:33:16 +00:00

2546 lines
70 KiB
ObjectPascal
Raw Blame History

{
$Id$
This unit handles definitions
Copyright (C) 1999 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.
Reference in New Issue View Git Blame Copy Permalink