mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-27 08:13:42 +02:00
afe0d5a50d
Come test_funcret improvements (not yet working)S: ----------------------------------------------------------------------
2431 lines
67 KiB
PHP
2431 lines
67 KiB
PHP
{
|
|
$Id$
|
|
Copyright (c) 1993-98 by Florian Klaempfl, Pierre Muller
|
|
|
|
Symbol table implementation for the defenitions
|
|
|
|
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.
|
|
****************************************************************************
|
|
}
|
|
|
|
{*************************************************************************************************************************
|
|
TDEF (base class for defenitions)
|
|
****************************************************************************}
|
|
|
|
constructor tdef.init;
|
|
begin
|
|
deftype:=abstractdef;
|
|
owner := nil;
|
|
next := nil;
|
|
number := 0;
|
|
if registerdef then
|
|
symtablestack^.registerdef(@self);
|
|
has_rtti:=false;
|
|
{$ifdef GDB}
|
|
is_def_stab_written := false;
|
|
globalnb := 0;
|
|
if assigned(lastglobaldef) then
|
|
begin
|
|
lastglobaldef^.nextglobal := @self;
|
|
previousglobal:=lastglobaldef;
|
|
end
|
|
else
|
|
begin
|
|
firstglobaldef := @self;
|
|
previousglobal := nil;
|
|
end;
|
|
lastglobaldef := @self;
|
|
nextglobal := nil;
|
|
sym := nil;
|
|
{$endif GDB}
|
|
end;
|
|
|
|
constructor tdef.load;
|
|
begin
|
|
{$ifdef GDB}
|
|
deftype:=abstractdef;
|
|
is_def_stab_written := false;
|
|
number := 0;
|
|
sym := nil;
|
|
owner := nil;
|
|
next := nil;
|
|
has_rtti:=false;
|
|
globalnb := 0;
|
|
if assigned(lastglobaldef) then
|
|
begin
|
|
lastglobaldef^.nextglobal := @self;
|
|
previousglobal:=lastglobaldef;
|
|
end
|
|
else
|
|
begin
|
|
firstglobaldef := @self;
|
|
previousglobal:=nil;
|
|
end;
|
|
lastglobaldef := @self;
|
|
nextglobal := nil;
|
|
{$endif GDB}
|
|
end;
|
|
|
|
destructor tdef.done;
|
|
begin
|
|
{$ifdef GDB}
|
|
{ first element ? }
|
|
if not(assigned(previousglobal)) then
|
|
begin
|
|
firstglobaldef := nextglobal;
|
|
firstglobaldef^.previousglobal:=nil;
|
|
end
|
|
else
|
|
begin
|
|
{ remove reference in the element before }
|
|
previousglobal^.nextglobal:=nextglobal;
|
|
end;
|
|
{ last element ? }
|
|
if not(assigned(nextglobal)) then
|
|
begin
|
|
lastglobaldef := previousglobal;
|
|
if assigned(lastglobaldef) then
|
|
lastglobaldef^.nextglobal:=nil;
|
|
end
|
|
else
|
|
nextglobal^.previousglobal:=previousglobal;
|
|
previousglobal:=nil;
|
|
nextglobal:=nil;
|
|
{$endif GDB}
|
|
end;
|
|
|
|
procedure tdef.write;
|
|
begin
|
|
{$ifdef GDB}
|
|
if globalnb = 0 then
|
|
begin
|
|
if assigned(owner) then
|
|
globalnb := owner^.getnewtypecount
|
|
else
|
|
begin
|
|
globalnb := PGlobalTypeCount^;
|
|
Inc(PGlobalTypeCount^);
|
|
end;
|
|
end;
|
|
{$endif GDB}
|
|
end;
|
|
|
|
function tdef.size : longint;
|
|
begin
|
|
size:=savesize;
|
|
end;
|
|
|
|
{$ifdef GDB}
|
|
procedure tdef.set_globalnb;
|
|
begin
|
|
globalnb :=PGlobalTypeCount^;
|
|
inc(PglobalTypeCount^);
|
|
end;
|
|
|
|
function tdef.stabstring : pchar;
|
|
|
|
begin
|
|
stabstring := strpnew('t'+numberstring+';');
|
|
end;
|
|
|
|
function tdef.numberstring : string;
|
|
var table : psymtable;
|
|
begin
|
|
{formal def have no type !}
|
|
if deftype = formaldef then
|
|
begin
|
|
numberstring := voiddef^.numberstring;
|
|
exit;
|
|
end;
|
|
if (not assigned(sym)) or (not sym^.isusedinstab) then
|
|
begin
|
|
{set even if debuglist is not defined}
|
|
if assigned(sym) then
|
|
sym^.isusedinstab := true;
|
|
if assigned(debuglist) and not is_def_stab_written then
|
|
concatstabto(debuglist);
|
|
end;
|
|
if not use_dbx then
|
|
begin
|
|
if globalnb = 0 then
|
|
set_globalnb;
|
|
numberstring := tostr(globalnb);
|
|
end
|
|
else
|
|
begin
|
|
if globalnb = 0 then
|
|
begin
|
|
if assigned(owner) then
|
|
globalnb := owner^.getnewtypecount
|
|
else
|
|
begin
|
|
globalnb := PGlobalTypeCount^;
|
|
Inc(PGlobalTypeCount^);
|
|
end;
|
|
end;
|
|
if assigned(sym) then
|
|
begin
|
|
table := sym^.owner;
|
|
if table^.unitid > 0 then
|
|
numberstring := '('+tostr(table^.unitid)+','
|
|
+tostr(sym^.definition^.globalnb)+')'
|
|
else
|
|
numberstring := tostr(globalnb);
|
|
exit;
|
|
end;
|
|
numberstring := tostr(globalnb);
|
|
end;
|
|
end;
|
|
|
|
function tdef.allstabstring : pchar;
|
|
var stabchar : string[2];
|
|
ss,st : pchar;
|
|
name : string;
|
|
sym_line_no : longint;
|
|
begin
|
|
ss := stabstring;
|
|
getmem(st,strlen(ss)+512);
|
|
stabchar := 't';
|
|
if deftype in tagtypes then
|
|
stabchar := 'Tt';
|
|
if assigned(sym) then
|
|
begin
|
|
name := sym^.name;
|
|
sym_line_no:=sym^.line_no;
|
|
end
|
|
else
|
|
begin
|
|
name := ' ';
|
|
sym_line_no:=0;
|
|
end;
|
|
strpcopy(st,'"'+name+':'+stabchar+numberstring+'=');
|
|
strpcopy(strecopy(strend(st),ss),'",'+tostr(N_LSYM)+',0,'+tostr(sym_line_no)+',0');
|
|
allstabstring := strnew(st);
|
|
freemem(st,strlen(ss)+512);
|
|
strdispose(ss);
|
|
end;
|
|
|
|
|
|
procedure tdef.concatstabto(asmlist : paasmoutput);
|
|
var stab_str : pchar;
|
|
begin
|
|
if ((sym = nil) or sym^.isusedinstab or use_dbx)
|
|
and not is_def_stab_written then
|
|
begin
|
|
If use_dbx then
|
|
begin
|
|
{ otherwise you get two of each def }
|
|
If assigned(sym) then
|
|
begin
|
|
if sym^.typ=typesym then
|
|
sym^.isusedinstab:=true;
|
|
if (sym^.owner = nil) or
|
|
((sym^.owner^.symtabletype = unitsymtable) and
|
|
punitsymtable(sym^.owner)^.dbx_count_ok) then
|
|
begin
|
|
{with DBX we get the definition from the other objects }
|
|
is_def_stab_written := true;
|
|
exit;
|
|
end;
|
|
end;
|
|
end;
|
|
{ to avoid infinite loops }
|
|
is_def_stab_written := true;
|
|
stab_str := allstabstring;
|
|
if asmlist = debuglist then do_count_dbx := true;
|
|
{ count_dbx(stab_str); moved to GDB.PAS}
|
|
asmlist^.concat(new(pai_stabs,init(stab_str)));
|
|
end;
|
|
end;
|
|
{$endif GDB}
|
|
|
|
procedure tdef.deref;
|
|
begin
|
|
end;
|
|
|
|
function tdef.needs_rtti : boolean;
|
|
begin
|
|
needs_rtti:=false;
|
|
end;
|
|
|
|
procedure tdef.generate_rtti;
|
|
begin
|
|
getlabel(rtti_label);
|
|
rttilist^.concat(new(pai_label,init(rtti_label)));
|
|
end;
|
|
|
|
function tdef.get_rtti_label : plabel;
|
|
begin
|
|
if not(has_rtti) then
|
|
generate_rtti;
|
|
{ I don't know what's the use of rtti_label
|
|
but this was missing (PM) }
|
|
get_rtti_label:=rtti_label;
|
|
end;
|
|
|
|
{*************************************************************************************************************************
|
|
TSTRINGDEF
|
|
****************************************************************************}
|
|
|
|
constructor tstringdef.init(l : byte);
|
|
|
|
begin
|
|
tdef.init;
|
|
string_typ:=shortstring;
|
|
deftype:=stringdef;
|
|
len:=l;
|
|
savesize:=len+1;
|
|
end;
|
|
|
|
constructor tstringdef.load;
|
|
|
|
begin
|
|
tdef.load;
|
|
string_typ:=shortstring;
|
|
deftype:=stringdef;
|
|
len:=readbyte;
|
|
savesize:=len+1;
|
|
end;
|
|
|
|
constructor tstringdef.longinit(l : longint);
|
|
|
|
begin
|
|
tdef.init;
|
|
string_typ:=longstring;
|
|
deftype:=stringdef;
|
|
len:=l;
|
|
savesize:=Sizeof(pointer);
|
|
end;
|
|
|
|
constructor tstringdef.longload;
|
|
|
|
begin
|
|
tdef.load;
|
|
deftype:=stringdef;
|
|
string_typ:=longstring;
|
|
len:=readlong;
|
|
savesize:=Sizeof(pointer);
|
|
end;
|
|
|
|
constructor tstringdef.ansiinit(l : longint);
|
|
|
|
begin
|
|
tdef.init;
|
|
string_typ:=ansistring;
|
|
deftype:=stringdef;
|
|
len:=l;
|
|
savesize:=sizeof(pointer);
|
|
end;
|
|
|
|
constructor tstringdef.ansiload;
|
|
|
|
begin
|
|
tdef.load;
|
|
deftype:=stringdef;
|
|
string_typ:=ansistring;
|
|
len:=readlong;
|
|
savesize:=sizeof(pointer);
|
|
end;
|
|
|
|
constructor tstringdef.wideinit(l : longint);
|
|
|
|
begin
|
|
tdef.init;
|
|
string_typ:=widestring;
|
|
deftype:=stringdef;
|
|
len:=l;
|
|
savesize:=sizeof(pointer);
|
|
end;
|
|
|
|
constructor tstringdef.wideload;
|
|
|
|
begin
|
|
tdef.load;
|
|
deftype:=stringdef;
|
|
string_typ:=ansistring;
|
|
len:=readlong;
|
|
savesize:=sizeof(pointer);
|
|
end;
|
|
|
|
function tstringdef.size : longint;
|
|
begin
|
|
size:=savesize;
|
|
end;
|
|
|
|
procedure tstringdef.write;
|
|
begin
|
|
{$ifndef NEWPPU}
|
|
case string_typ of
|
|
shortstring:
|
|
writebyte(ibstringdef);
|
|
longstring:
|
|
writebyte(iblongstringdef);
|
|
ansistring:
|
|
writebyte(ibansistringdef);
|
|
widestring:
|
|
writebyte(ibwidestringdef);
|
|
end;
|
|
{$endif}
|
|
tdef.write;
|
|
if string_typ=shortstring then
|
|
writebyte(len)
|
|
else
|
|
writelong(len);
|
|
{$ifdef NEWPPU}
|
|
case string_typ of
|
|
shortstring : ppufile^.writeentry(ibstringdef);
|
|
longstring : ppufile^.writeentry(iblongstringdef);
|
|
ansistring : ppufile^.writeentry(ibansistringdef);
|
|
widestring : ppufile^.writeentry(ibwidestringdef);
|
|
end;
|
|
{$endif}
|
|
end;
|
|
|
|
{$ifdef GDB}
|
|
function tstringdef.stabstring : pchar;
|
|
var
|
|
bytest,charst,longst : string;
|
|
begin
|
|
case string_typ of
|
|
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;
|
|
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;
|
|
ansistring : begin
|
|
{ an ansi string looks like a pchar easy !! }
|
|
stabstring:=strpnew('*'+typeglobalnumber('char'));
|
|
end;
|
|
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_rtti : boolean;
|
|
begin
|
|
needs_rtti:=string_typ in [ansistring,widestring];
|
|
end;
|
|
|
|
{*************************************************************************************************************************
|
|
TENUMDEF
|
|
****************************************************************************}
|
|
|
|
constructor tenumdef.init;
|
|
begin
|
|
tdef.init;
|
|
deftype:=enumdef;
|
|
max:=0;
|
|
savesize:=Sizeof(longint);
|
|
has_jumps:=false;
|
|
{$ifdef GDB}
|
|
first := Nil;
|
|
{$endif GDB}
|
|
end;
|
|
|
|
constructor tenumdef.load;
|
|
begin
|
|
tdef.load;
|
|
deftype:=enumdef;
|
|
max:=readlong;
|
|
savesize:=Sizeof(longint);
|
|
has_jumps:=false;
|
|
first := Nil;
|
|
end;
|
|
|
|
destructor tenumdef.done;
|
|
begin
|
|
inherited done;
|
|
end;
|
|
|
|
procedure tenumdef.write;
|
|
|
|
begin
|
|
{$ifndef NEWPPU}
|
|
writebyte(ibenumdef);
|
|
{$endif}
|
|
tdef.write;
|
|
writelong(max);
|
|
{$ifdef NEWPPU}
|
|
ppufile^.writeentry(ibenumdef);
|
|
{$endif}
|
|
end;
|
|
|
|
{$ifdef GDB}
|
|
function tenumdef.stabstring : pchar;
|
|
var st,st2 : pchar;
|
|
p : penumsym;
|
|
s : string;
|
|
memsize : word;
|
|
begin
|
|
memsize := memsizeinc;
|
|
getmem(st,memsize);
|
|
strpcopy(st,'e');
|
|
p := first;
|
|
while assigned(p) do
|
|
begin
|
|
s :=p^.name+':'+tostr(p^.value)+',';
|
|
{ place for the ending ';' also }
|
|
if (strlen(st)+length(s)+1<memsize) then
|
|
strpcopy(strend(st),s)
|
|
else
|
|
begin
|
|
getmem(st2,memsize+memsizeinc);
|
|
strcopy(st2,st);
|
|
freemem(st,memsize);
|
|
st := st2;
|
|
memsize := memsize+memsizeinc;
|
|
strpcopy(strend(st),s);
|
|
end;
|
|
p := p^.next;
|
|
end;
|
|
strpcopy(strend(st),';');
|
|
stabstring := strnew(st);
|
|
freemem(st,memsize);
|
|
end;
|
|
{$endif GDB}
|
|
|
|
{*************************************************************************************************************************
|
|
TORDDEF
|
|
****************************************************************************}
|
|
|
|
constructor torddef.init(t : tbasetype;v,b : longint);
|
|
begin
|
|
tdef.init;
|
|
deftype:=orddef;
|
|
low:=v;
|
|
high:=b;
|
|
typ:=t;
|
|
setsize;
|
|
end;
|
|
|
|
constructor torddef.load;
|
|
begin
|
|
tdef.load;
|
|
deftype:=orddef;
|
|
typ:=tbasetype(readbyte);
|
|
low:=readlong;
|
|
high:=readlong;
|
|
rangenr:=0;
|
|
setsize;
|
|
end;
|
|
|
|
procedure torddef.setsize;
|
|
begin
|
|
if typ=uauto then
|
|
begin
|
|
{ generate a unsigned range if high<0 and low>=0 }
|
|
if (low>=0) and (high<0) then
|
|
begin
|
|
savesize:=4;
|
|
typ:=u32bit;
|
|
end
|
|
else if (low>=0) and (high<=255) then
|
|
begin
|
|
savesize:=1;
|
|
typ:=u8bit;
|
|
end
|
|
else if (low>=-128) and (high<=127) then
|
|
begin
|
|
savesize:=1;
|
|
typ:=s8bit;
|
|
end
|
|
else if (low>=0) and (high<=65536) then
|
|
begin
|
|
savesize:=2;
|
|
typ:=u16bit;
|
|
end
|
|
else if (low>=-32768) and (high<=32767) then
|
|
begin
|
|
savesize:=2;
|
|
typ:=s16bit;
|
|
end
|
|
else
|
|
begin
|
|
savesize:=4;
|
|
typ:=s32bit;
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
case typ of
|
|
u8bit,s8bit,
|
|
uchar,bool8bit : savesize:=1;
|
|
u16bit,s16bit,
|
|
bool16bit : savesize:=2;
|
|
s32bit,u32bit,
|
|
bool32bit : savesize:=4;
|
|
else
|
|
savesize:=0;
|
|
end;
|
|
end;
|
|
{ there are no entrys for range checking }
|
|
rangenr:=0;
|
|
end;
|
|
|
|
procedure torddef.genrangecheck;
|
|
begin
|
|
if rangenr=0 then
|
|
begin
|
|
{ generate two constant for bounds }
|
|
getlabelnr(rangenr);
|
|
if (cs_smartlink in aktswitches) then
|
|
datasegment^.concat(new(pai_symbol,init_global('R_'+current_module^.mainsource^+tostr(rangenr))))
|
|
else
|
|
datasegment^.concat(new(pai_symbol,init('R_'+tostr(rangenr))));
|
|
if low<=high then
|
|
begin
|
|
datasegment^.concat(new(pai_const,init_32bit(low)));
|
|
datasegment^.concat(new(pai_const,init_32bit(high)));
|
|
end
|
|
{ for u32bit we need two bounds }
|
|
else
|
|
begin
|
|
datasegment^.concat(new(pai_const,init_32bit(low)));
|
|
datasegment^.concat(new(pai_const,init_32bit($7fffffff)));
|
|
inc(nextlabelnr);
|
|
if (cs_smartlink in aktswitches) then
|
|
datasegment^.concat(new(pai_symbol,init_global('R_'+current_module^.mainsource^+tostr(rangenr+1))))
|
|
else
|
|
datasegment^.concat(new(pai_symbol,init('R_'+tostr(rangenr+1))));
|
|
datasegment^.concat(new(pai_const,init_32bit($80000000)));
|
|
datasegment^.concat(new(pai_const,init_32bit(high)));
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure torddef.write;
|
|
begin
|
|
{$ifndef NEWPPU}
|
|
writebyte(iborddef);
|
|
{$endif}
|
|
tdef.write;
|
|
writebyte(byte(typ));
|
|
writelong(low);
|
|
writelong(high);
|
|
{$ifdef NEWPPU}
|
|
ppufile^.writeentry(iborddef);
|
|
{$endif}
|
|
end;
|
|
|
|
{$ifdef GDB}
|
|
function torddef.stabstring : pchar;
|
|
begin
|
|
case typ of
|
|
uvoid : stabstring := strpnew(numberstring+';');
|
|
{GDB 4.12 for go32 doesn't like boolean as range for 0 to 1 !!!}
|
|
bool8bit,
|
|
bool16bit,
|
|
bool32bit : stabstring := strpnew('r'+numberstring+';0;255;');
|
|
{ u32bit : stabstring := strpnew('r'+
|
|
s32bitdef^.numberstring+';0;-1;'); }
|
|
else
|
|
stabstring := strpnew('r'+s32bitdef^.numberstring+';'+tostr(low)+';'+tostr(high)+';');
|
|
end;
|
|
end;
|
|
{$endif GDB}
|
|
|
|
{*************************************************************************************************************************
|
|
TFLOATDEF
|
|
****************************************************************************}
|
|
|
|
constructor tfloatdef.init(t : tfloattype);
|
|
begin
|
|
tdef.init;
|
|
deftype:=floatdef;
|
|
typ:=t;
|
|
setsize;
|
|
end;
|
|
|
|
constructor tfloatdef.load;
|
|
begin
|
|
tdef.load;
|
|
deftype:=floatdef;
|
|
typ:=tfloattype(readbyte);
|
|
setsize;
|
|
end;
|
|
|
|
|
|
procedure tfloatdef.setsize;
|
|
begin
|
|
case typ of
|
|
f16bit:
|
|
savesize:=2;
|
|
f32bit,s32real:
|
|
savesize:=4;
|
|
s64real:
|
|
savesize:=8;
|
|
s64bit:
|
|
savesize:=8;
|
|
s80real:
|
|
savesize:=extended_size;
|
|
else savesize:=0;
|
|
end;
|
|
end;
|
|
|
|
procedure tfloatdef.write;
|
|
begin
|
|
{$ifndef NEWPPU}
|
|
writebyte(ibfloatdef);
|
|
{$endif}
|
|
tdef.write;
|
|
writebyte(byte(typ));
|
|
{$ifdef NEWPPU}
|
|
ppufile^.writeentry(ibfloatdef);
|
|
{$endif}
|
|
end;
|
|
|
|
{$ifdef GDB}
|
|
function tfloatdef.stabstring : pchar;
|
|
begin
|
|
case typ of
|
|
s32real,
|
|
s64real : stabstring := strpnew('r'+
|
|
s32bitdef^.numberstring+';'+tostr(savesize)+';0;');
|
|
{ for fixed real use longint instead to be able to }
|
|
{ debug something at least }
|
|
f32bit:
|
|
stabstring := s32bitdef^.stabstring;
|
|
f16bit:
|
|
stabstring := strpnew('r'+s32bitdef^.numberstring+';0;'+
|
|
tostr($ffff)+';');
|
|
{ found this solution in stabsread.c from GDB v4.16 }
|
|
s64bit : stabstring := strpnew('r'+
|
|
s32bitdef^.numberstring+';-'+tostr(savesize)+';0;');
|
|
{$ifdef i386}
|
|
{ under dos at least you must give a size of twelve instead of 10 !! }
|
|
{ this is probably do to the fact that in gcc all is pushed in 4 bytes size }
|
|
s80real : stabstring := strpnew('r'+s32bitdef^.numberstring+';12;0;');
|
|
{$endif i386}
|
|
else
|
|
internalerror(10005);
|
|
end;
|
|
end;
|
|
{$endif GDB}
|
|
|
|
{*************************************************************************************************************************
|
|
TFILEDEF
|
|
****************************************************************************}
|
|
|
|
constructor tfiledef.init(ft : tfiletype;tas : pdef);
|
|
begin
|
|
inherited init;
|
|
deftype:=filedef;
|
|
filetype:=ft;
|
|
typed_as:=tas;
|
|
setsize;
|
|
end;
|
|
|
|
constructor tfiledef.load;
|
|
begin
|
|
tdef.load;
|
|
deftype:=filedef;
|
|
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 target_info.target of
|
|
target_LINUX:
|
|
begin
|
|
case filetype of
|
|
ft_text : savesize:=432;
|
|
ft_typed,ft_untyped : savesize:=304;
|
|
end;
|
|
end;
|
|
target_Win32:
|
|
begin
|
|
case filetype of
|
|
ft_text : savesize:=434;
|
|
ft_typed,ft_untyped : savesize:=306;
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
case filetype of
|
|
ft_text : savesize:=256;
|
|
ft_typed,ft_untyped : savesize:=128;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure tfiledef.write;
|
|
begin
|
|
{$ifndef NEWPPU}
|
|
writebyte(ibfiledef);
|
|
{$endif}
|
|
tdef.write;
|
|
writebyte(byte(filetype));
|
|
if filetype=ft_typed then
|
|
writedefref(typed_as);
|
|
{$ifdef NEWPPU}
|
|
ppufile^.writeentry(ibfiledef);
|
|
{$endif}
|
|
end;
|
|
|
|
{$ifdef GDB}
|
|
function tfiledef.stabstring : pchar;
|
|
var Handlebitsize,namesize : longint;
|
|
Handledef :string;
|
|
begin
|
|
{$IfDef GDBknowsfiles}
|
|
case filetyp of
|
|
ft_typed : stabstring := strpnew('d'+typed_as^.numberstring{+';'});
|
|
ft_untyped : stabstring := strpnew('d'+voiddef^.numberstring{+';'});
|
|
ft_text : stabstring := strpnew('d'+cchardef^.numberstring{+';'});
|
|
end;
|
|
{$Else }
|
|
{based on
|
|
filerec = record
|
|
handle : word;
|
|
mode : word;
|
|
recsize : word;
|
|
_private : array[1..26] of byte;
|
|
userdata : array[1..16] of byte;
|
|
name : string[79 or 255 for linux]; }
|
|
if (target_info.target=target_GO32V1) or
|
|
(target_info.target=target_GO32V2) then
|
|
namesize:=79
|
|
else
|
|
namesize:=255;
|
|
|
|
if (target_info.target=target_Win32) then
|
|
begin
|
|
Handledef:='longint';
|
|
Handlebitsize:=32;
|
|
end
|
|
else
|
|
begin
|
|
Handledef:='word';
|
|
HandleBitSize:=16;
|
|
end;
|
|
|
|
{ the buffer part is still missing !! (PM) }
|
|
{ but the string could become too long !! }
|
|
stabstring := strpnew('s'+tostr(savesize)+
|
|
'HANDLE:'+typeglobalnumber(Handledef)+',0,'+tostr(HandleBitSize)+';'+
|
|
'MODE:'+typeglobalnumber('word')+','+tostr(HandleBitSize)+',16;'+
|
|
'RECSIZE:'+typeglobalnumber('word')+','+tostr(HandleBitSize+16)+',16;'+
|
|
'_PRIVATE:ar'+typeglobalnumber('word')+';1;26;'+typeglobalnumber('byte')
|
|
+','+tostr(HandleBitSize+32)+',208;'+
|
|
'USERDATA:ar'+typeglobalnumber('word')+';1;16;'+typeglobalnumber('byte')
|
|
+','+tostr(HandleBitSize+240)+',128;'+
|
|
{ 'NAME:s'+tostr(namesize+1)+
|
|
'length:'+typeglobalnumber('byte')+',0,8;'+
|
|
'st:ar'+typeglobalnumber('word')+';1;'
|
|
+tostr(namesize)+';'+typeglobalnumber('char')+',8,'+tostr(8*namesize)+';;'+}
|
|
'NAME:ar'+typeglobalnumber('word')+';0;'
|
|
+tostr(namesize)+';'+typeglobalnumber('char')+
|
|
','+tostr(HandleBitSize+368)+','+tostr(8*(namesize+1))+';;');
|
|
{$EndIf}
|
|
end;
|
|
|
|
procedure tfiledef.concatstabto(asmlist : paasmoutput);
|
|
begin
|
|
{ most file defs are unnamed !!! }
|
|
if ((sym = nil) or sym^.isusedinstab or use_dbx) and not is_def_stab_written then
|
|
begin
|
|
if assigned(typed_as) then forcestabto(asmlist,typed_as);
|
|
inherited concatstabto(asmlist);
|
|
end;
|
|
end;
|
|
{$endif GDB}
|
|
|
|
{*************************************************************************************************************************
|
|
TPOINTERDEF
|
|
****************************************************************************}
|
|
|
|
constructor tpointerdef.init(def : pdef);
|
|
begin
|
|
inherited init;
|
|
deftype:=pointerdef;
|
|
definition:=def;
|
|
savesize:=Sizeof(pointer);
|
|
end;
|
|
|
|
constructor tpointerdef.load;
|
|
begin
|
|
tdef.load;
|
|
deftype:=pointerdef;
|
|
{ the real address in memory is calculated later (deref) }
|
|
definition:=readdefref;
|
|
savesize:=Sizeof(pointer);
|
|
end;
|
|
|
|
procedure tpointerdef.deref;
|
|
begin
|
|
resolvedef(definition);
|
|
end;
|
|
|
|
procedure tpointerdef.write;
|
|
begin
|
|
{$ifndef NEWPPU}
|
|
writebyte(ibpointerdef);
|
|
{$endif}
|
|
tdef.write;
|
|
writedefref(definition);
|
|
{$ifdef NEWPPU}
|
|
ppufile^.writeentry(ibpointerdef);
|
|
{$endif}
|
|
end;
|
|
|
|
{$ifdef GDB}
|
|
function tpointerdef.stabstring : pchar;
|
|
begin
|
|
stabstring := strpnew('*'+definition^.numberstring);
|
|
end;
|
|
|
|
procedure tpointerdef.concatstabto(asmlist : paasmoutput);
|
|
var st,nb : string;
|
|
sym_line_no : longint;
|
|
begin
|
|
if ( (sym=nil) or sym^.isusedinstab or use_dbx) and not is_def_stab_written then
|
|
begin
|
|
if assigned(definition) then
|
|
if definition^.deftype in [recorddef,objectdef] then
|
|
begin
|
|
is_def_stab_written := true;
|
|
{to avoid infinite recursion in record with next-like fields }
|
|
nb := definition^.numberstring;
|
|
is_def_stab_written := false;
|
|
if not definition^.is_def_stab_written then
|
|
begin
|
|
if assigned(definition^.sym) then
|
|
begin
|
|
if assigned(sym) then
|
|
begin
|
|
st := sym^.name;
|
|
sym_line_no:=sym^.line_no;
|
|
end
|
|
else
|
|
begin
|
|
st := ' ';
|
|
sym_line_no:=0;
|
|
end;
|
|
st := '"'+st+':t'+numberstring+'=*'+definition^.numberstring
|
|
+'=xs'+definition^.sym^.name+':",'+tostr(N_LSYM)+',0,'+tostr(sym_line_no)+',0';
|
|
if asmlist = debuglist then do_count_dbx := true;
|
|
asmlist^.concat(new(pai_stabs,init(strpnew(st))));
|
|
end;
|
|
end else inherited concatstabto(asmlist);
|
|
is_def_stab_written := true;
|
|
end else
|
|
begin
|
|
forcestabto(asmlist,definition);
|
|
inherited concatstabto(asmlist);
|
|
end;
|
|
end;
|
|
end;
|
|
{$endif GDB}
|
|
|
|
{*************************************************************************************************************************
|
|
TCLASSREFDEF
|
|
****************************************************************************}
|
|
|
|
constructor tclassrefdef.init(def : pdef);
|
|
begin
|
|
inherited init(def);
|
|
deftype:=classrefdef;
|
|
definition:=def;
|
|
savesize:=Sizeof(pointer);
|
|
end;
|
|
|
|
constructor tclassrefdef.load;
|
|
begin
|
|
inherited load;
|
|
deftype:=classrefdef;
|
|
end;
|
|
|
|
procedure tclassrefdef.write;
|
|
begin
|
|
{$ifndef NEWPPU}
|
|
writebyte(ibclassrefdef);
|
|
{$endif}
|
|
tdef.write;
|
|
writedefref(definition);
|
|
{$ifdef NEWPPU}
|
|
ppufile^.writeentry(ibclassrefdef);
|
|
{$endif}
|
|
end;
|
|
|
|
{$ifdef GDB}
|
|
function tclassrefdef.stabstring : pchar;
|
|
begin
|
|
stabstring:=strpnew('');
|
|
end;
|
|
|
|
procedure tclassrefdef.concatstabto(asmlist : paasmoutput);
|
|
begin
|
|
end;
|
|
{$endif GDB}
|
|
|
|
{***********************************************************************************
|
|
TSETDEF
|
|
***************************************************************************}
|
|
|
|
constructor tsetdef.init(s : pdef;high : longint);
|
|
begin
|
|
inherited init;
|
|
deftype:=setdef;
|
|
setof:=s;
|
|
if high<32 then
|
|
begin
|
|
settype:=smallset;
|
|
savesize:=Sizeof(longint);
|
|
end
|
|
else
|
|
if high<256 then
|
|
begin
|
|
settype:=normset;
|
|
savesize:=32;
|
|
end
|
|
else
|
|
{$ifdef testvarsets}
|
|
if high<$10000 then
|
|
begin
|
|
settype:=varset;
|
|
savesize:=4*((high+31) div 32);
|
|
end
|
|
else
|
|
{$endif testvarsets}
|
|
Message(sym_e_ill_type_decl_set);
|
|
end;
|
|
|
|
constructor tsetdef.load;
|
|
begin
|
|
tdef.load;
|
|
deftype:=setdef;
|
|
setof:=readdefref;
|
|
settype:=tsettype(readbyte);
|
|
case settype of
|
|
normset : savesize:=32;
|
|
varset : savesize:=readlong;
|
|
smallset : savesize:=Sizeof(longint);
|
|
end;
|
|
end;
|
|
|
|
procedure tsetdef.write;
|
|
begin
|
|
{$ifndef NEWPPU}
|
|
writebyte(ibsetdef);
|
|
{$endif}
|
|
tdef.write;
|
|
writedefref(setof);
|
|
writebyte(byte(settype));
|
|
if settype=varset then
|
|
writelong(savesize);
|
|
{$ifdef NEWPPU}
|
|
ppufile^.writeentry(ibsetdef);
|
|
{$endif}
|
|
end;
|
|
|
|
{$ifdef GDB}
|
|
function tsetdef.stabstring : pchar;
|
|
begin
|
|
stabstring := strpnew('S'+setof^.numberstring);
|
|
end;
|
|
|
|
procedure tsetdef.concatstabto(asmlist : paasmoutput);
|
|
|
|
begin
|
|
if ( not assigned(sym) or sym^.isusedinstab or use_dbx) and
|
|
not is_def_stab_written then
|
|
begin
|
|
if assigned(setof) then
|
|
forcestabto(asmlist,setof);
|
|
inherited concatstabto(asmlist);
|
|
end;
|
|
end;
|
|
{$endif GDB}
|
|
|
|
procedure tsetdef.deref;
|
|
begin
|
|
resolvedef(setof);
|
|
end;
|
|
|
|
{***********************************************************************************
|
|
TFORMALDEF
|
|
***************************************************************************}
|
|
|
|
constructor tformaldef.init;
|
|
|
|
begin
|
|
inherited init;
|
|
deftype:=formaldef;
|
|
savesize:=Sizeof(pointer);
|
|
end;
|
|
|
|
constructor tformaldef.load;
|
|
|
|
begin
|
|
tdef.load;
|
|
deftype:=formaldef;
|
|
savesize:=Sizeof(pointer);
|
|
end;
|
|
|
|
procedure tformaldef.write;
|
|
|
|
begin
|
|
{$ifndef NEWPPU}
|
|
writebyte(ibformaldef);
|
|
{$endif}
|
|
tdef.write;
|
|
{$ifdef NEWPPU}
|
|
ppufile^.writeentry(ibformaldef);
|
|
{$endif}
|
|
end;
|
|
|
|
{$ifdef GDB}
|
|
function tformaldef.stabstring : pchar;
|
|
|
|
begin
|
|
stabstring := strpnew('formal'+numberstring+';');
|
|
end;
|
|
|
|
|
|
procedure tformaldef.concatstabto(asmlist : paasmoutput);
|
|
|
|
begin
|
|
{ formaldef can't be stab'ed !}
|
|
end;
|
|
{$endif GDB}
|
|
|
|
{***********************************************************************************
|
|
TARRAYDEF
|
|
***************************************************************************}
|
|
|
|
constructor tarraydef.init(l,h : longint;rd : pdef);
|
|
|
|
begin
|
|
tdef.init;
|
|
deftype:=arraydef;
|
|
lowrange:=l;
|
|
highrange:=h;
|
|
rangedef:=rd;
|
|
rangenr:=0;
|
|
definition:=nil;
|
|
end;
|
|
|
|
constructor tarraydef.load;
|
|
|
|
begin
|
|
tdef.load;
|
|
deftype:=arraydef;
|
|
{ the addresses are calculated later }
|
|
definition:=readdefref;
|
|
rangedef:=readdefref;
|
|
lowrange:=readlong;
|
|
highrange:=readlong;
|
|
rangenr:=0;
|
|
end;
|
|
|
|
procedure tarraydef.genrangecheck;
|
|
|
|
begin
|
|
if rangenr=0 then
|
|
begin
|
|
{ generates the data for range checking }
|
|
getlabelnr(rangenr);
|
|
datasegment^.concat(new(pai_symbol,init('R_'+tostr(rangenr))));
|
|
datasegment^.concat(new(pai_const,init_32bit(lowrange)));
|
|
datasegment^.concat(new(pai_const,init_32bit(highrange)));
|
|
end;
|
|
end;
|
|
|
|
procedure tarraydef.deref;
|
|
|
|
begin
|
|
resolvedef(definition);
|
|
resolvedef(rangedef);
|
|
end;
|
|
|
|
procedure tarraydef.write;
|
|
|
|
begin
|
|
{$ifndef NEWPPU}
|
|
writebyte(ibarraydef);
|
|
{$endif}
|
|
tdef.write;
|
|
writedefref(definition);
|
|
writedefref(rangedef);
|
|
writelong(lowrange);
|
|
writelong(highrange);
|
|
{$ifdef NEWPPU}
|
|
ppufile^.writeentry(ibarraydef);
|
|
{$endif}
|
|
end;
|
|
|
|
{$ifdef GDB}
|
|
function tarraydef.stabstring : pchar;
|
|
begin
|
|
stabstring := strpnew('ar'+rangedef^.numberstring+';'
|
|
+tostr(lowrange)+';'+tostr(highrange)+';'+definition^.numberstring);
|
|
end;
|
|
|
|
procedure tarraydef.concatstabto(asmlist : paasmoutput);
|
|
|
|
begin
|
|
if (not assigned(sym) or sym^.isusedinstab or use_dbx)
|
|
and not is_def_stab_written then
|
|
begin
|
|
{when array are inserted they have no definition yet !!}
|
|
if assigned(definition) then
|
|
inherited concatstabto(asmlist);
|
|
end;
|
|
end;
|
|
{$endif GDB}
|
|
|
|
function tarraydef.elesize : longint;
|
|
begin
|
|
elesize:=definition^.size;
|
|
end;
|
|
|
|
function tarraydef.size : longint;
|
|
begin
|
|
size:=(highrange-lowrange+1)*elesize;
|
|
end;
|
|
|
|
function tarraydef.needs_rtti : boolean;
|
|
|
|
begin
|
|
needs_rtti:=definition^.needs_rtti;
|
|
end;
|
|
|
|
{***********************************************************************************
|
|
TRECDEF
|
|
***************************************************************************}
|
|
|
|
constructor trecdef.init(p : psymtable);
|
|
|
|
begin
|
|
tdef.init;
|
|
deftype:=recorddef;
|
|
symtable:=p;
|
|
savesize:=symtable^.datasize;
|
|
symtable^.defowner := @self;
|
|
end;
|
|
|
|
constructor trecdef.load;
|
|
var
|
|
oldread_member : boolean;
|
|
begin
|
|
tdef.load;
|
|
deftype:=recorddef;
|
|
savesize:=readlong;
|
|
oldread_member:=read_member;
|
|
read_member:=true;
|
|
symtable:=new(psymtable,loadasstruct(recordsymtable));
|
|
read_member:=oldread_member;
|
|
symtable^.defowner := @self;
|
|
end;
|
|
|
|
destructor trecdef.done;
|
|
|
|
begin
|
|
if assigned(symtable) then dispose(symtable,done);
|
|
inherited done;
|
|
end;
|
|
|
|
var
|
|
brtti : boolean;
|
|
|
|
procedure check_rec_rtti(s : psym);
|
|
|
|
begin
|
|
if (s^.typ=varsym) and (pvarsym(s)^.definition^.needs_rtti) then
|
|
brtti:=true;
|
|
end;
|
|
|
|
function trecdef.needs_rtti : 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:=brtti;
|
|
brtti:=false;
|
|
symtable^.foreach(check_rec_rtti);
|
|
needs_rtti:=brtti;
|
|
brtti:=oldb;
|
|
end;
|
|
|
|
procedure trecdef.deref;
|
|
var
|
|
hp : pdef;
|
|
oldrecsyms : psymtable;
|
|
begin
|
|
oldrecsyms:=aktrecordsymtable;
|
|
aktrecordsymtable:=symtable;
|
|
{ now dereference the definitions }
|
|
hp:=symtable^.rootdef;
|
|
while assigned(hp) do
|
|
begin
|
|
hp^.deref;
|
|
|
|
{ set owner }
|
|
hp^.owner:=symtable;
|
|
|
|
hp:=hp^.next;
|
|
end;
|
|
{$ifdef tp}
|
|
symtable^.foreach(derefsym);
|
|
{$else}
|
|
symtable^.foreach(@derefsym);
|
|
{$endif}
|
|
aktrecordsymtable:=oldrecsyms;
|
|
end;
|
|
|
|
procedure trecdef.write;
|
|
var
|
|
oldread_member : boolean;
|
|
begin
|
|
oldread_member:=read_member;
|
|
read_member:=true;
|
|
{$ifndef NEWPPU}
|
|
writebyte(ibrecorddef);
|
|
{$endif}
|
|
tdef.write;
|
|
writelong(savesize);
|
|
{$ifdef NEWPPU}
|
|
ppufile^.writeentry(ibrecorddef);
|
|
{$endif}
|
|
self.symtable^.writeasstruct;
|
|
read_member:=oldread_member;
|
|
end;
|
|
|
|
{$ifdef GDB}
|
|
Const StabRecString : pchar = Nil;
|
|
StabRecSize : longint = 0;
|
|
RecOffset : Longint = 0;
|
|
|
|
procedure addname(p : psym);
|
|
var
|
|
news, newrec : pchar;
|
|
begin
|
|
{ static variables from objects are like global objects }
|
|
if ((p^.properties and sp_static)<>0) then
|
|
exit;
|
|
If p^.typ = varsym then
|
|
begin
|
|
newrec := strpnew(p^.name+':'+pvarsym(p)^.definition^.numberstring
|
|
+','+tostr(pvarsym(p)^.address*8)+','
|
|
+tostr(pvarsym(p)^.definition^.size*8)+';');
|
|
if strlen(StabRecString) + strlen(newrec) >= StabRecSize-256 then
|
|
begin
|
|
getmem(news,stabrecsize+memsizeinc);
|
|
strcopy(news,stabrecstring);
|
|
freemem(stabrecstring,stabrecsize);
|
|
stabrecsize:=stabrecsize+memsizeinc;
|
|
stabrecstring:=news;
|
|
end;
|
|
strcat(StabRecstring,newrec);
|
|
strdispose(newrec);
|
|
{This should be used for case !!}
|
|
RecOffset := RecOffset + pvarsym(p)^.definition^.size;
|
|
end;
|
|
end;
|
|
|
|
function trecdef.stabstring : pchar;
|
|
Var oldrec : pchar;
|
|
oldsize : longint;
|
|
begin
|
|
oldrec := stabrecstring;
|
|
oldsize:=stabrecsize;
|
|
GetMem(stabrecstring,memsizeinc);
|
|
stabrecsize:=memsizeinc;
|
|
strpcopy(stabRecString,'s'+tostr(savesize));
|
|
RecOffset := 0;
|
|
{$ifdef tp}
|
|
symtable^.foreach(addname);
|
|
{$else}
|
|
symtable^.foreach(@addname);
|
|
{$endif}
|
|
{ FPC doesn't want to convert a char to a pchar}
|
|
{ is this a bug ? }
|
|
strpcopy(strend(StabRecString),';');
|
|
stabstring := strnew(StabRecString);
|
|
Freemem(stabrecstring,stabrecsize);
|
|
stabrecstring := oldrec;
|
|
stabrecsize:=oldsize;
|
|
end;
|
|
|
|
procedure trecdef.concatstabto(asmlist : paasmoutput);
|
|
|
|
begin
|
|
if (not assigned(sym) or sym^.isusedinstab or use_dbx) and
|
|
(not is_def_stab_written) then
|
|
inherited concatstabto(asmlist);
|
|
end;
|
|
|
|
{$endif GDB}
|
|
|
|
{***********************************************************************************
|
|
TABSTRACTPROCDEF
|
|
***************************************************************************}
|
|
|
|
constructor tabstractprocdef.init;
|
|
|
|
begin
|
|
inherited init;
|
|
para1:=nil;
|
|
{$ifdef StoreFPULevel}
|
|
fpu_used:=255;
|
|
{$endif StoreFPULevel}
|
|
options:=0;
|
|
retdef:=voiddef;
|
|
savesize:=Sizeof(pointer);
|
|
end;
|
|
|
|
destructor tabstractprocdef.done;
|
|
|
|
var
|
|
hp : pdefcoll;
|
|
|
|
begin
|
|
hp:=para1;
|
|
while assigned(hp) do
|
|
begin
|
|
para1:=hp^.next;
|
|
dispose(hp);
|
|
hp:=para1;
|
|
end;
|
|
inherited done;
|
|
end;
|
|
|
|
procedure tabstractprocdef.concatdef(p : pdef;vsp : tvarspez);
|
|
|
|
var
|
|
hp : pdefcoll;
|
|
|
|
begin
|
|
new(hp);
|
|
hp^.paratyp:=vsp;
|
|
hp^.data:=p;
|
|
hp^.next:=para1;
|
|
para1:=hp;
|
|
end;
|
|
|
|
procedure tabstractprocdef.deref;
|
|
var
|
|
hp : pdefcoll;
|
|
begin
|
|
inherited deref;
|
|
resolvedef(retdef);
|
|
hp:=para1;
|
|
while assigned(hp) do
|
|
begin
|
|
resolvedef(hp^.data);
|
|
hp:=hp^.next;
|
|
end;
|
|
end;
|
|
|
|
constructor tabstractprocdef.load;
|
|
var
|
|
last,hp : pdefcoll;
|
|
count,i : word;
|
|
begin
|
|
tdef.load;
|
|
retdef:=readdefref;
|
|
{$ifdef StoreFPULevel}
|
|
fpu_used:=readbyte;
|
|
{$endif StoreFPULevel}
|
|
options:=readlong;
|
|
count:=readword;
|
|
para1:=nil;
|
|
savesize:=Sizeof(pointer);
|
|
for i:=1 to count do
|
|
begin
|
|
new(hp);
|
|
hp^.paratyp:=tvarspez(readbyte);
|
|
hp^.data:=readdefref;
|
|
hp^.next:=nil;
|
|
if para1=nil then
|
|
para1:=hp
|
|
else
|
|
last^.next:=hp;
|
|
last:=hp;
|
|
end;
|
|
end;
|
|
|
|
function tabstractprocdef.para_size : longint;
|
|
var
|
|
pdc : pdefcoll;
|
|
l : longint;
|
|
begin
|
|
l:=0;
|
|
pdc:=para1;
|
|
while assigned(pdc) do
|
|
begin
|
|
case pdc^.paratyp of
|
|
vs_value : l:=l+pdc^.data^.size+(pdc^.data^.size mod 2);
|
|
vs_var : l:=l+sizeof(pointer);
|
|
vs_const : if dont_copy_const_param(pdc^.data) then
|
|
l:=l+sizeof(pointer)
|
|
else
|
|
l:=l+pdc^.data^.size+(pdc^.data^.size mod 2);
|
|
end;
|
|
pdc:=pdc^.next;
|
|
end;
|
|
para_size:=l;
|
|
end;
|
|
|
|
procedure tabstractprocdef.write;
|
|
|
|
var
|
|
count : word;
|
|
hp : pdefcoll;
|
|
|
|
begin
|
|
tdef.write;
|
|
writedefref(retdef);
|
|
{$ifdef StoreFPULevel}
|
|
writebyte(FPU_used);
|
|
{$endif StoreFPULevel}
|
|
writelong(options);
|
|
hp:=para1;
|
|
count:=0;
|
|
while assigned(hp) do
|
|
begin
|
|
inc(count);
|
|
hp:=hp^.next;
|
|
end;
|
|
writeword(count);
|
|
hp:=para1;
|
|
while assigned(hp) do
|
|
begin
|
|
writebyte(byte(hp^.paratyp));
|
|
writedefref(hp^.data);
|
|
hp:=hp^.next;
|
|
end;
|
|
end;
|
|
|
|
function tabstractprocdef.demangled_paras : string;
|
|
var s : string;
|
|
p : pdefcoll;
|
|
begin
|
|
s:='';
|
|
p:=para1;
|
|
if assigned(p) then
|
|
begin
|
|
s:=s+'(';
|
|
while assigned(p) do
|
|
begin
|
|
if assigned(p^.data^.sym) then
|
|
s:=s+p^.data^.sym^.name
|
|
else if p^.paratyp=vs_var then
|
|
s:=s+'var'
|
|
else if p^.paratyp=vs_const then
|
|
s:=s+'const';
|
|
p:=p^.next;
|
|
if assigned(p) then
|
|
s:=s+','
|
|
else
|
|
s:=s+')';
|
|
end;
|
|
end;
|
|
demangled_paras:=s;
|
|
end;
|
|
|
|
{$ifdef GDB}
|
|
function tabstractprocdef.stabstring : pchar;
|
|
begin
|
|
stabstring := strpnew('abstractproc'+numberstring+';');
|
|
end;
|
|
|
|
procedure tabstractprocdef.concatstabto(asmlist : paasmoutput);
|
|
|
|
begin
|
|
if (not assigned(sym) or sym^.isusedinstab or use_dbx)
|
|
and not is_def_stab_written then
|
|
begin
|
|
if assigned(retdef) then forcestabto(asmlist,retdef);
|
|
inherited concatstabto(asmlist);
|
|
end;
|
|
end;
|
|
{$endif GDB}
|
|
|
|
{***********************************************************************************
|
|
TPROCDEF
|
|
***************************************************************************}
|
|
|
|
constructor tprocdef.init;
|
|
|
|
begin
|
|
inherited init;
|
|
deftype:=procdef;
|
|
_mangledname:=nil;
|
|
nextoverloaded:=nil;
|
|
extnumber:=-1;
|
|
localst:=new(psymtable,init(localsymtable));
|
|
parast:=new(psymtable,init(parasymtable));
|
|
{ this is used by insert
|
|
to check same names in parast and localst }
|
|
localst^.next:=parast;
|
|
{$ifdef UseBrowser}
|
|
defref:=nil;
|
|
if make_ref then
|
|
add_new_ref(defref,@tokenpos);
|
|
lastref:=defref;
|
|
lastwritten:=nil;
|
|
refcount:=1;
|
|
{$endif UseBrowser}
|
|
|
|
{ first, we assume, that all registers are used }
|
|
{$ifdef i386}
|
|
usedregisters:=$ff;
|
|
{$endif i386}
|
|
{$ifdef m68k}
|
|
usedregisters:=$FFFF;
|
|
{$endif}
|
|
{$ifdef alpha}
|
|
usedregisters_int:=$ffffffff;
|
|
usedregisters_fpu:=$ffffffff;
|
|
{$endif alpha}
|
|
forwarddef:=true;
|
|
_class := nil;
|
|
end;
|
|
|
|
constructor tprocdef.load;
|
|
|
|
var
|
|
s : string;
|
|
|
|
begin
|
|
{ deftype:=procdef; this is at the wrong place !! }
|
|
inherited load;
|
|
deftype:=procdef;
|
|
{$ifdef i386}
|
|
usedregisters:=readbyte;
|
|
{$endif i386}
|
|
{$ifdef m68k}
|
|
usedregisters:=readword;
|
|
{$endif}
|
|
{$ifdef alpha}
|
|
usedregisters_int:=readlong;
|
|
usedregisters_fpu:=readlong;
|
|
{$endif alpha}
|
|
|
|
s:=readstring;
|
|
setstring(_mangledname,s);
|
|
|
|
extnumber:=readlong;
|
|
nextoverloaded:=pprocdef(readdefref);
|
|
_class := pobjectdef(readdefref);
|
|
|
|
if gendeffile and ((options and poexports)<>0) then
|
|
writeln(deffile,#9+mangledname);
|
|
|
|
parast:=nil;
|
|
localst:=nil;
|
|
forwarddef:=false;
|
|
{$ifdef UseBrowser}
|
|
if (current_module^.flags and uf_uses_browser)<>0 then
|
|
load_references
|
|
else
|
|
begin
|
|
lastref:=nil;
|
|
lastwritten:=nil;
|
|
defref:=nil;
|
|
refcount:=0;
|
|
end;
|
|
{$endif UseBrowser}
|
|
end;
|
|
|
|
{$ifdef UseBrowser}
|
|
procedure tprocdef.load_references;
|
|
|
|
var fileindex : word;
|
|
b : byte;
|
|
l,c : longint;
|
|
|
|
begin
|
|
b:=readbyte;
|
|
refcount:=0;
|
|
lastref:=nil;
|
|
lastwritten:=nil;
|
|
defref:=nil;
|
|
while b=ibref do
|
|
begin
|
|
fileindex:=readword;
|
|
l:=readlong;
|
|
c:=readword;
|
|
inc(refcount);
|
|
lastref:=new(pref,load(lastref,fileindex,l,c));
|
|
if refcount=1 then defref:=lastref;
|
|
b:=readbyte;
|
|
end;
|
|
if b <> ibend then
|
|
{ Message(unit_f_ppu_read);
|
|
message disappeared ?? }
|
|
Comment(V_fatal,'error in load_reference');
|
|
end;
|
|
|
|
procedure tprocdef.write_references;
|
|
|
|
var ref : pref;
|
|
|
|
begin
|
|
{ references do not change the ppu caracteristics }
|
|
{ this only save the references to variables/functions }
|
|
{ defined in the unit what about the others }
|
|
ppufile^.do_crc:=false;
|
|
if assigned(lastwritten) then
|
|
ref:=lastwritten
|
|
else
|
|
ref:=defref;
|
|
while assigned(ref) do
|
|
begin
|
|
writebyte(ibref);
|
|
writeword(ref^.posinfo.fileindex);
|
|
writelong(ref^.posinfo.line);
|
|
writeword(ref^.posinfo.column);
|
|
ref:=ref^.nextref;
|
|
end;
|
|
lastwritten:=lastref;
|
|
writebyte(ibend);
|
|
ppufile^.do_crc:=true;
|
|
end;
|
|
|
|
procedure tprocdef.write_external_references;
|
|
|
|
var ref : pref;
|
|
|
|
begin
|
|
ppufile^.do_crc:=false;
|
|
if lastwritten=lastref then exit;
|
|
writebyte(ibextdefref);
|
|
writedefref(@self);
|
|
if assigned(lastwritten) then
|
|
ref:=lastwritten
|
|
else
|
|
ref:=defref;
|
|
while assigned(ref) do
|
|
begin
|
|
writebyte(ibref);
|
|
writeword(ref^.posinfo.fileindex);
|
|
writelong(ref^.posinfo.line);
|
|
writeword(ref^.posinfo.column);
|
|
ref:=ref^.nextref;
|
|
end;
|
|
lastwritten:=lastref;
|
|
writebyte(ibend);
|
|
ppufile^.do_crc:=true;
|
|
end;
|
|
|
|
procedure tprocdef.write_ref_to_file(var f : text);
|
|
|
|
var ref : pref;
|
|
i : longint;
|
|
|
|
begin
|
|
ref:=defref;
|
|
if assigned(ref) then
|
|
begin
|
|
for i:=1 to reffile_indent do
|
|
system.write(f,' ');
|
|
writeln(f,'***',mangledname);
|
|
end;
|
|
inc(reffile_indent,2);
|
|
while assigned(ref) do
|
|
begin
|
|
for i:=1 to reffile_indent do
|
|
system.write(f,' ');
|
|
writeln(f,ref^.get_file_line);
|
|
ref:=ref^.nextref;
|
|
end;
|
|
dec(reffile_indent,2);
|
|
end;
|
|
{$endif UseBrowser}
|
|
|
|
destructor tprocdef.done;
|
|
|
|
begin
|
|
if assigned(parast) then
|
|
dispose(parast,done);
|
|
if assigned(localst) then
|
|
dispose(localst,done);
|
|
if
|
|
{$ifdef tp}
|
|
not(use_big) and
|
|
{$endif}
|
|
assigned(_mangledname) then
|
|
strdispose(_mangledname);
|
|
inherited done;
|
|
end;
|
|
|
|
procedure tprocdef.write;
|
|
|
|
begin
|
|
{$ifndef NEWPPU}
|
|
writebyte(ibprocdef);
|
|
{$endif}
|
|
inherited write;
|
|
{$ifdef i386}
|
|
writebyte(usedregisters);
|
|
{$endif i386}
|
|
{$ifdef m68k}
|
|
writeword(usedregisters);
|
|
{$endif}
|
|
{$ifdef alpha}
|
|
writelong(usedregisters_int);
|
|
writelong(usedregisters_fpu);
|
|
{$endif alpha}
|
|
writestring(mangledname);
|
|
writelong(extnumber);
|
|
writedefref(nextoverloaded);
|
|
writedefref(_class);
|
|
{$ifdef NEWPPU}
|
|
ppufile^.writeentry(ibprocdef);
|
|
{$endif}
|
|
{$ifdef UseBrowser}
|
|
if (current_module^.flags and uf_uses_browser)<>0 then
|
|
write_references;
|
|
{$endif UseBrowser}
|
|
end;
|
|
|
|
{$ifdef GDB}
|
|
procedure addparaname(p : psym);
|
|
var vs : char;
|
|
begin
|
|
if pvarsym(p)^.varspez = vs_value then vs := '1'
|
|
else vs := '0';
|
|
strpcopy(strend(StabRecString),p^.name+':'+pvarsym(p)^.definition^.numberstring+','+vs+';');
|
|
end;
|
|
|
|
function tprocdef.stabstring : pchar;
|
|
var param : pdefcoll;
|
|
i : word;
|
|
vartyp : char;
|
|
oldrec : pchar;
|
|
begin
|
|
oldrec := stabrecstring;
|
|
getmem(StabRecString,1024);
|
|
param := para1;
|
|
i := 0;
|
|
while assigned(param) do
|
|
begin
|
|
inc(i);
|
|
param := param^.next;
|
|
end;
|
|
strpcopy(StabRecString,'f'+retdef^.numberstring);
|
|
if i>0 then
|
|
begin
|
|
strpcopy(strend(StabRecString),','+tostr(i)+';');
|
|
if assigned(parast) then
|
|
{$IfDef TP}
|
|
parast^.foreach(addparaname)
|
|
{$Else}
|
|
parast^.foreach(@addparaname)
|
|
{$EndIf}
|
|
else
|
|
begin
|
|
param := para1;
|
|
i := 0;
|
|
while assigned(param) do
|
|
begin
|
|
inc(i);
|
|
if param^.paratyp = vs_value then vartyp := '1' else vartyp := '0';
|
|
{Here we have lost the parameter names !!}
|
|
{using lower case parameters }
|
|
strpcopy(strend(stabrecstring),'p'+tostr(i)
|
|
+':'+param^.data^.numberstring+','+vartyp+';');
|
|
param := param^.next;
|
|
end;
|
|
end;
|
|
{strpcopy(strend(StabRecString),';');}
|
|
end;
|
|
stabstring := strnew(stabrecstring);
|
|
freemem(stabrecstring,1024);
|
|
stabrecstring := oldrec;
|
|
end;
|
|
|
|
procedure tprocdef.concatstabto(asmlist : paasmoutput);
|
|
begin
|
|
end;
|
|
{$endif GDB}
|
|
|
|
procedure tprocdef.deref;
|
|
begin
|
|
inherited deref;
|
|
resolvedef(pdef(nextoverloaded));
|
|
resolvedef(pdef(_class));
|
|
end;
|
|
|
|
function tprocdef.mangledname : string;
|
|
{$ifdef tp}
|
|
var
|
|
oldpos : longint;
|
|
s : string;
|
|
b : byte;
|
|
{$endif tp}
|
|
begin
|
|
{$ifdef tp}
|
|
if use_big then
|
|
begin
|
|
symbolstream.seek(longint(_mangledname));
|
|
symbolstream.read(b,1);
|
|
symbolstream.read(s[1],b);
|
|
s[0]:=chr(b);
|
|
mangledname:=s;
|
|
end
|
|
else
|
|
{$endif}
|
|
mangledname:=strpas(_mangledname);
|
|
end;
|
|
|
|
{$IfDef GDB}
|
|
function tprocdef.cplusplusmangledname : string;
|
|
var
|
|
s,s2 : string;
|
|
param : pdefcoll;
|
|
begin
|
|
s := sym^.name;
|
|
if _class <> nil then
|
|
begin
|
|
s2 := _class^.name^;
|
|
s := s+'__'+tostr(length(s2))+s2;
|
|
end else s := s + '_';
|
|
param := para1;
|
|
while assigned(param) do
|
|
begin
|
|
s2 := param^.data^.sym^.name;
|
|
s := s+tostr(length(s2))+s2;
|
|
param := param^.next;
|
|
end;
|
|
cplusplusmangledname:=s;
|
|
end;
|
|
{$EndIf GDB}
|
|
|
|
|
|
procedure tprocdef.setmangledname(const s : string);
|
|
begin
|
|
if {$ifdef tp}not(use_big) and{$endif} (assigned(_mangledname)) then
|
|
strdispose(_mangledname);
|
|
setstring(_mangledname,s);
|
|
{$ifdef UseBrowser}
|
|
if assigned(parast) then
|
|
begin
|
|
stringdispose(parast^.name);
|
|
parast^.name:=stringdup('args of '+s);
|
|
end;
|
|
if assigned(localst) then
|
|
begin
|
|
stringdispose(localst^.name);
|
|
localst^.name:=stringdup('locals of '+s);
|
|
end;
|
|
{$endif UseBrowser}
|
|
end;
|
|
|
|
{***********************************************************************************
|
|
TPROCVARDEF
|
|
***************************************************************************}
|
|
|
|
constructor tprocvardef.init;
|
|
begin
|
|
inherited init;
|
|
deftype:=procvardef;
|
|
end;
|
|
|
|
constructor tprocvardef.load;
|
|
begin
|
|
inherited load;
|
|
deftype:=procvardef;
|
|
end;
|
|
|
|
procedure tprocvardef.write;
|
|
begin
|
|
{$ifndef NEWPPU}
|
|
writebyte(ibprocvardef);
|
|
{$endif}
|
|
{ here we cannot get a real good value so just give something }
|
|
{ plausible (PM) }
|
|
{$ifdef StoreFPULevel}
|
|
if is_fpu(retdef) then
|
|
fpu_used:=3
|
|
else
|
|
fpu_used:=0;
|
|
{$endif StoreFPULevel}
|
|
inherited write;
|
|
{$ifdef NEWPPU}
|
|
ppufile^.writeentry(ibprocvardef);
|
|
{$endif}
|
|
end;
|
|
|
|
function tprocvardef.size : longint;
|
|
|
|
begin
|
|
if (options and pomethodpointer)=0 then
|
|
size:=sizeof(pointer)
|
|
else
|
|
size:=2*sizeof(pointer);
|
|
end;
|
|
|
|
{$ifdef GDB}
|
|
function tprocvardef.stabstring : pchar;
|
|
var
|
|
nss : pchar;
|
|
i : word;
|
|
vartyp : char;
|
|
pst : pchar;
|
|
param : pdefcoll;
|
|
begin
|
|
i := 0;
|
|
param := para1;
|
|
while assigned(param) do
|
|
begin
|
|
inc(i);
|
|
param := param^.next;
|
|
end;
|
|
getmem(nss,1024);
|
|
strpcopy(nss,'f'+retdef^.numberstring+','+tostr(i)+';');
|
|
param := para1;
|
|
i := 0;
|
|
while assigned(param) do
|
|
begin
|
|
inc(i);
|
|
if param^.paratyp = vs_value then vartyp := '1' else vartyp := '0';
|
|
{Here we have lost the parameter names !!}
|
|
pst := strpnew('p'+tostr(i)+':'+param^.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 use_dbx)
|
|
and not is_def_stab_written then
|
|
inherited concatstabto(asmlist);
|
|
is_def_stab_written:=true;
|
|
end;
|
|
{$endif GDB}
|
|
|
|
{***************************************************************************
|
|
TOBJECTDEF
|
|
***************************************************************************}
|
|
|
|
{$ifdef GDB}
|
|
const
|
|
vtabletype : word = 0;
|
|
vtableassigned : boolean = false;
|
|
{$endif GDB}
|
|
|
|
constructor tobjectdef.init(const n : string;c : pobjectdef);
|
|
|
|
begin
|
|
tdef.init;
|
|
deftype:=objectdef;
|
|
childof:=c;
|
|
options:=0;
|
|
{ privatesyms:=new(psymtable,init(objectsymtable));
|
|
protectedsyms:=new(psymtable,init(objectsymtable)); }
|
|
publicsyms:=new(psymtable,init(objectsymtable));
|
|
publicsyms^.name := stringdup(n);
|
|
{ add the data of the anchestor class }
|
|
if assigned(childof) then
|
|
begin
|
|
publicsyms^.datasize:=
|
|
publicsyms^.datasize-4+childof^.publicsyms^.datasize;
|
|
end;
|
|
name:=stringdup(n);
|
|
savesize := publicsyms^.datasize;
|
|
publicsyms^.defowner:=@self;
|
|
end;
|
|
|
|
constructor tobjectdef.load;
|
|
var
|
|
oldread_member : boolean;
|
|
begin
|
|
tdef.load;
|
|
deftype:=objectdef;
|
|
savesize:=readlong;
|
|
name:=stringdup(readstring);
|
|
childof:=pobjectdef(readdefref);
|
|
options:=readlong;
|
|
oldread_member:=read_member;
|
|
read_member:=true;
|
|
if (options and (oo_hasprivate or oo_hasprotected))<>0 then
|
|
object_options:=true;
|
|
publicsyms:=new(psymtable,loadasstruct(objectsymtable));
|
|
object_options:=false;
|
|
publicsyms^.defowner:=@self;
|
|
publicsyms^.datasize:=savesize;
|
|
publicsyms^.name := stringdup(name^);
|
|
read_member:=oldread_member;
|
|
|
|
{ handles the predefined class tobject }
|
|
{ the last TOBJECT which is loaded gets }
|
|
{ it ! }
|
|
if (name^='TOBJECT') and not(cs_compilesystem in aktswitches) and
|
|
isclass and (childof=pointer($ffffffff)) then
|
|
class_tobject:=@self;
|
|
end;
|
|
|
|
procedure tobjectdef.check_forwards;
|
|
|
|
begin
|
|
publicsyms^.check_forwards;
|
|
if (options and oo_isforward)<>0 then
|
|
begin
|
|
{ ok, in future, the forward can be resolved }
|
|
Message1(sym_e_class_forward_not_resolved,name^);
|
|
options:=options and not(oo_isforward);
|
|
end;
|
|
end;
|
|
|
|
destructor tobjectdef.done;
|
|
|
|
begin
|
|
{!!!!
|
|
if assigned(privatesyms) then
|
|
dispose(privatesyms,done);
|
|
if assigned(protectedsyms) then
|
|
dispose(protectedsyms,done); }
|
|
if assigned(publicsyms) then
|
|
dispose(publicsyms,done);
|
|
if (options and oo_isforward)<>0 then
|
|
Message1(sym_e_class_forward_not_resolved,name^);
|
|
stringdispose(name);
|
|
tdef.done;
|
|
end;
|
|
|
|
{ true, if self inherits from d (or if they are equal) }
|
|
function tobjectdef.isrelated(d : pobjectdef) : boolean;
|
|
|
|
var
|
|
hp : pobjectdef;
|
|
|
|
begin
|
|
hp:=@self;
|
|
while assigned(hp) do
|
|
begin
|
|
if hp=d then
|
|
begin
|
|
isrelated:=true;
|
|
exit;
|
|
end;
|
|
hp:=hp^.childof;
|
|
end;
|
|
isrelated:=false;
|
|
end;
|
|
|
|
function tobjectdef.size : longint;
|
|
|
|
begin
|
|
if (options and oois_class)<>0 then
|
|
size:=sizeof(pointer)
|
|
|
|
else
|
|
size:=publicsyms^.datasize;
|
|
end;
|
|
|
|
procedure tobjectdef.deref;
|
|
|
|
var
|
|
hp : pdef;
|
|
oldrecsyms : psymtable;
|
|
|
|
begin
|
|
resolvedef(pdef(childof));
|
|
oldrecsyms:=aktrecordsymtable;
|
|
aktrecordsymtable:=publicsyms;
|
|
{ nun die Definitionen dereferenzieren }
|
|
hp:=publicsyms^.rootdef;
|
|
while assigned(hp) do
|
|
begin
|
|
hp^.deref;
|
|
|
|
{Besitzer setzen }
|
|
hp^.owner:=publicsyms;
|
|
|
|
hp:=hp^.next;
|
|
end;
|
|
{$ifdef tp}
|
|
publicsyms^.foreach(derefsym);
|
|
{$else}
|
|
publicsyms^.foreach(@derefsym);
|
|
{$endif}
|
|
aktrecordsymtable:=oldrecsyms;
|
|
end;
|
|
|
|
function tobjectdef.vmt_mangledname : string;
|
|
|
|
{DM: I get a nil pointer on the owner name. I don't know if this
|
|
mayhappen, and I have therefore fixed the problem by doing nil pointer
|
|
checks.}
|
|
|
|
var s1,s2:string;
|
|
|
|
begin
|
|
if owner^.name=nil then
|
|
s1:=''
|
|
else
|
|
s1:=owner^.name^;
|
|
if name=nil then
|
|
s2:=''
|
|
else
|
|
s2:=name^;
|
|
vmt_mangledname:='VMT_'+s1+'$_'+s2;
|
|
end;
|
|
|
|
function tobjectdef.isclass : boolean;
|
|
begin
|
|
isclass:=(options and oois_class)<>0;
|
|
end;
|
|
|
|
procedure tobjectdef.write;
|
|
var
|
|
oldread_member : boolean;
|
|
begin
|
|
oldread_member:=read_member;
|
|
read_member:=true;
|
|
{$ifndef NEWPPU}
|
|
writebyte(ibobjectdef);
|
|
{$endif}
|
|
tdef.write;
|
|
writelong(size);
|
|
writestring(name^);
|
|
writedefref(childof);
|
|
writelong(options);
|
|
{$ifdef NEWPPU}
|
|
ppufile^.writeentry(ibobjectdef);
|
|
{$endif}
|
|
if (options and (oo_hasprivate or oo_hasprotected))<>0 then
|
|
object_options:=true;
|
|
publicsyms^.writeasstruct;
|
|
object_options:=false;
|
|
read_member:=oldread_member;
|
|
end;
|
|
|
|
{$ifdef GDB}
|
|
procedure addprocname(p :psym);
|
|
var virtualind,argnames : string;
|
|
news, newrec : pchar;
|
|
pd,ipd : pprocdef;
|
|
lindex : longint;
|
|
para : pdefcoll;
|
|
arglength : byte;
|
|
sp : char;
|
|
|
|
begin
|
|
If p^.typ = procsym then
|
|
begin
|
|
pd := pprocsym(p)^.definition;
|
|
{ this will be used for full implementation of object stabs
|
|
not yet done }
|
|
ipd := pd;
|
|
while assigned(ipd^.nextoverloaded) do ipd := ipd^.nextoverloaded;
|
|
if (pd^.options and povirtualmethod) <> 0 then
|
|
begin
|
|
lindex := pd^.extnumber;
|
|
{doesnt seem to be necessary
|
|
lindex := lindex or $80000000;}
|
|
virtualind := '*'+tostr(lindex)+';'+ipd^._class^.numberstring+';'
|
|
end else virtualind := '.';
|
|
{ arguments are not listed here }
|
|
{we don't need another definition}
|
|
para := pd^.para1;
|
|
argnames := '';
|
|
while assigned(para) do
|
|
begin
|
|
if para^.data^.deftype = formaldef then
|
|
begin
|
|
if para^.paratyp=vs_var then
|
|
argnames := argnames+'3var'
|
|
else if para^.paratyp=vs_const then
|
|
argnames:=argnames+'5const';
|
|
end
|
|
else
|
|
begin
|
|
{ if the arg definition is like (v: ^byte;..
|
|
there is no sym attached to data !!! }
|
|
if assigned(para^.data^.sym) then
|
|
begin
|
|
arglength := length(para^.data^.sym^.name);
|
|
argnames := argnames + tostr(arglength)+para^.data^.sym^.name;
|
|
end
|
|
else
|
|
begin
|
|
argnames:=argnames+'11unnamedtype';
|
|
end;
|
|
end;
|
|
para := para^.next;
|
|
end;
|
|
ipd^.is_def_stab_written := true;
|
|
{ here 2A must be changed for private and protected }
|
|
{ 0 is private 1 protected and 2 public }
|
|
if (p^.properties and sp_private)<>0 then sp:='0'
|
|
else if (p^.properties and sp_protected)<>0 then sp:='1'
|
|
else sp:='2';
|
|
newrec := strpnew(p^.name+'::'+ipd^.numberstring
|
|
+'=##'+pd^.retdef^.numberstring+';:'+argnames+';'+sp+'A'
|
|
+virtualind+';');
|
|
{ get spare place for a string at the end }
|
|
if strlen(StabRecString) + strlen(newrec) >= StabRecSize-256 then
|
|
begin
|
|
getmem(news,stabrecsize+memsizeinc);
|
|
strcopy(news,stabrecstring);
|
|
freemem(stabrecstring,stabrecsize);
|
|
stabrecsize:=stabrecsize+memsizeinc;
|
|
stabrecstring:=news;
|
|
end;
|
|
strcat(StabRecstring,newrec);
|
|
{freemem(newrec,memsizeinc); }
|
|
strdispose(newrec);
|
|
{This should be used for case !!}
|
|
RecOffset := RecOffset + pd^.size;
|
|
end;
|
|
end;
|
|
|
|
function tobjectdef.stabstring : pchar;
|
|
var anc : pobjectdef;
|
|
oldrec : pchar;
|
|
oldrecsize : longint;
|
|
str_end : string;
|
|
begin
|
|
oldrec := stabrecstring;
|
|
oldrecsize:=stabrecsize;
|
|
stabrecsize:=memsizeinc;
|
|
GetMem(stabrecstring,stabrecsize);
|
|
strpcopy(stabRecString,'s'+tostr(size));
|
|
if assigned(childof) then
|
|
{only one ancestor not virtual, public, at base offset 0 }
|
|
{ !1 , 0 2 0 , }
|
|
strpcopy(strend(stabrecstring),'!1,020,'+childof^.numberstring+';');
|
|
{virtual table to implement yet}
|
|
RecOffset := 0;
|
|
{$ifdef tp}
|
|
publicsyms^.foreach(addname);
|
|
{$else}
|
|
publicsyms^.foreach(@addname);
|
|
{$endif tp}
|
|
if (options and oo_hasvirtual) <> 0 then
|
|
if not assigned(childof) or ((childof^.options and oo_hasvirtual) = 0) then
|
|
begin
|
|
str_end:='$vf'+numberstring+':'+typeglobalnumber('vtblarray')+',0;';
|
|
strpcopy(strend(stabrecstring),'$vf'+numberstring+':'+typeglobalnumber('vtblarray')+',0;');
|
|
end;
|
|
{$ifdef tp}
|
|
publicsyms^.foreach(addprocname);
|
|
{$else}
|
|
publicsyms^.foreach(@addprocname);
|
|
{$endif tp }
|
|
if (options and oo_hasvirtual) <> 0 then
|
|
begin
|
|
anc := @self;
|
|
while assigned(anc^.childof) and ((anc^.childof^.options and oo_hasvirtual) <> 0) do
|
|
anc := anc^.childof;
|
|
str_end:=';~%'+anc^.numberstring+';';
|
|
end
|
|
else
|
|
str_end:=';';
|
|
strpcopy(strend(stabrecstring),str_end);
|
|
stabstring := strnew(StabRecString);
|
|
freemem(stabrecstring,stabrecsize);
|
|
stabrecstring := oldrec;
|
|
stabrecsize:=oldrecsize;
|
|
end;
|
|
{$endif GDB}
|
|
|
|
{****************************************************************************
|
|
TERRORDEF
|
|
****************************************************************************}
|
|
|
|
constructor terrordef.init;
|
|
begin
|
|
tdef.init;
|
|
deftype:=errordef;
|
|
end;
|
|
|
|
{$ifdef GDB}
|
|
function terrordef.stabstring : pchar;
|
|
begin
|
|
stabstring:=strpnew('error'+numberstring);
|
|
end;
|
|
{$endif GDB}
|
|
|
|
{
|
|
$Log$
|
|
Revision 1.4 1998-06-04 09:55:45 pierre
|
|
* demangled name of procsym reworked to become independant of the mangling scheme
|
|
|
|
Come test_funcret improvements (not yet working)S: ----------------------------------------------------------------------
|
|
|
|
Revision 1.3 1998/06/03 22:49:03 peter
|
|
+ wordbool,longbool
|
|
* rename bis,von -> high,low
|
|
* moved some systemunit loading/creating to psystem.pas
|
|
|
|
Revision 1.2 1998/05/31 14:13:37 peter
|
|
* fixed call bugs with assembler readers
|
|
+ OPR_SYMBOL to hold a symbol in the asm parser
|
|
* fixed staticsymtable vars which were acessed through %ebp instead of
|
|
name
|
|
|
|
Revision 1.1 1998/05/27 19:45:09 peter
|
|
* symtable.pas splitted into includefiles
|
|
* symtable adapted for $ifdef NEWPPU
|
|
|
|
}
|
|
|