From 7b28ebd6ef8c5f6588b98b10b6d144099d3c252d Mon Sep 17 00:00:00 2001 From: peter Date: Wed, 27 May 1998 19:45:02 +0000 Subject: [PATCH] * symtable.pas splitted into includefiles * symtable adapted for $ifdef NEWPPU --- compiler/files.pas | 14 +- compiler/parser.pas | 11 +- compiler/pexpr.pas | 12 +- compiler/pmodules.pas | 10 +- compiler/ppu.pas | 37 +- compiler/symdef.inc | 2376 +++++++++++++++++++++++++++++++++++++++++ compiler/symppu.inc | 541 ++++++++++ compiler/symsym.inc | 1695 +++++++++++++++++++++++++++++ 8 files changed, 4669 insertions(+), 27 deletions(-) create mode 100644 compiler/symdef.inc create mode 100644 compiler/symppu.inc create mode 100644 compiler/symsym.inc diff --git a/compiler/files.pas b/compiler/files.pas index 01deaf11de..e48482d3a3 100644 --- a/compiler/files.pas +++ b/compiler/files.pas @@ -411,10 +411,10 @@ unit files; Message1(unit_d_ppu_crc,tostr(ppufile^.header.checksum)); { Unitname } b:=ppufile^.readentry; - if b=ibunitname then + if b=ibmodulename then begin - stringdispose(unitname); - unitname:=stringdup(ppufile^.getstring); + stringdispose(modulename); + modulename:=stringdup(ppufile^.getstring); b:=ppufile^.readentry; end; @@ -487,7 +487,7 @@ unit files; begin if (flags and uf_smartlink)<>0 then begin - objfiletime:=getnamedfiletime(arfilename^); + objfiletime:=getnamedfiletime(libfilename^); if (ppufiletime<0) or (objfiletime<0) or (ppufiletime>objfiletime) then do_compile:=true; end @@ -927,7 +927,11 @@ unit files; end. { $Log$ - Revision 1.13 1998-05-23 01:21:05 peter + Revision 1.14 1998-05-27 19:45:02 peter + * symtable.pas splitted into includefiles + * symtable adapted for $ifdef NEWPPU + + Revision 1.13 1998/05/23 01:21:05 peter + aktasmmode, aktoptprocessor, aktoutputformat + smartlink per module $SMARTLINK-/+ (like MMX) and moved to aktswitches + $LIBNAME to set the library name where the unit will be put in diff --git a/compiler/parser.pas b/compiler/parser.pas index ce1728e71a..1828d95c60 100644 --- a/compiler/parser.pas +++ b/compiler/parser.pas @@ -297,8 +297,9 @@ unit parser; { init code generator for a new module } codegen_newmodule; +{$ifdef GDB} reset_gdb_info; - +{$endif GDB} { global switches are read, so further changes aren't allowed } current_module^.in_main:=true; @@ -429,7 +430,9 @@ done: if dispose_asm_lists then codegen_donemodule; +{$ifdef GDB} reset_gdb_info; +{$endif GDB} { restore symtable state } {$ifdef UseBrowser} if (compile_level>1) then @@ -508,7 +511,11 @@ done: end. { $Log$ - Revision 1.18 1998-05-23 01:21:15 peter + Revision 1.19 1998-05-27 19:45:04 peter + * symtable.pas splitted into includefiles + * symtable adapted for $ifdef NEWPPU + + Revision 1.18 1998/05/23 01:21:15 peter + aktasmmode, aktoptprocessor, aktoutputformat + smartlink per module $SMARTLINK-/+ (like MMX) and moved to aktswitches + $LIBNAME to set the library name where the unit will be put in diff --git a/compiler/pexpr.pas b/compiler/pexpr.pas index 58ae22b285..059dbd7ffd 100644 --- a/compiler/pexpr.pas +++ b/compiler/pexpr.pas @@ -1448,7 +1448,7 @@ unit pexpr; do_firstpass(p1); case p1^.treetype of ordconstn : begin - if p1^.resulttype=s32bitdef then + if porddef(p1^.resulttype)=s32bitdef then p1^.resulttype:=u8bitdef; if pd=nil then pd:=p1^.resulttype; @@ -1460,7 +1460,7 @@ unit pexpr; consume(POINTPOINT); p3:=comp_expr(true); do_firstpass(p3); - if p3^.resulttype=s32bitdef then + if porddef(p3^.resulttype)=s32bitdef then p3^.resulttype:=u8bitdef; if not(is_equal(pd,p3^.resulttype)) then Message(parser_e_typeconflict_in_set) @@ -1485,7 +1485,7 @@ unit pexpr; end; else begin - if p1^.resulttype=s32bitdef then + if porddef(p1^.resulttype)=s32bitdef then p1^.resulttype:=u8bitdef; if pd=nil then pd:=p1^.resulttype; @@ -1745,7 +1745,11 @@ unit pexpr; end. { $Log$ - Revision 1.20 1998-05-26 07:53:59 pierre + Revision 1.21 1998-05-27 19:45:05 peter + * symtable.pas splitted into includefiles + * symtable adapted for $ifdef NEWPPU + + Revision 1.20 1998/05/26 07:53:59 pierre * bug fix for empty sets (nil pd was dereferenced ) Revision 1.19 1998/05/25 17:11:43 pierre diff --git a/compiler/pmodules.pas b/compiler/pmodules.pas index f9c731534c..44dd99376f 100644 --- a/compiler/pmodules.pas +++ b/compiler/pmodules.pas @@ -308,7 +308,7 @@ unit pmodules; hp^.ppufile:=nil; { recompile or give an fatal error } if not(hp^.sources_avail) then - Message1(unit_f_cant_compile_unit,hp^.unitname^) + Message1(unit_f_cant_compile_unit,hp^.modulename^) else begin {$ifdef TEST_TEMPCLOSE} @@ -330,7 +330,7 @@ unit pmodules; Message(unit_f_too_much_units); end; { ok, now load the unit } - hp^.symtable:=new(punitsymtable,load(hp^.unitname^)); + hp^.symtable:=new(punitsymtable,load(hp^.modulename^)); { if this is the system unit insert the intern symbols } make_ref:=false; if compile_system then @@ -1110,7 +1110,11 @@ unit pmodules; end. { $Log$ - Revision 1.15 1998-05-23 01:21:22 peter + Revision 1.16 1998-05-27 19:45:06 peter + * symtable.pas splitted into includefiles + * symtable adapted for $ifdef NEWPPU + + Revision 1.15 1998/05/23 01:21:22 peter + aktasmmode, aktoptprocessor, aktoutputformat + smartlink per module $SMARTLINK-/+ (like MMX) and moved to aktswitches + $LIBNAME to set the library name where the unit will be put in diff --git a/compiler/ppu.pas b/compiler/ppu.pas index 8f775f2220..96d9f67614 100644 --- a/compiler/ppu.pas +++ b/compiler/ppu.pas @@ -33,7 +33,7 @@ const {$endif} {ppu entries} - ibunitname = 1; + ibmodulename = 1; ibsourcefile = 2; ibloadunit_int = 3; ibloadunit_imp = 4; @@ -43,6 +43,9 @@ const ibstaticlibs = 8; ibdbxcount = 9; ibref = 10; + ibenddefs = 250; + ibendsyms = 251; + ibendheader = 252; ibentry = 254; ibend = 255; {syms} @@ -107,8 +110,8 @@ type pppufile=^tppufile; tppufile=object f : file; - error, - writing : boolean; + mode : byte; {0 - Closed, 1 - Reading, 2 - Writing} + error : boolean; fname : string; fsize : longint; @@ -235,7 +238,7 @@ constructor tppufile.init(fn:string); begin fname:=fn; change_endian:=false; - writing:=false; + Mode:=0; NewHeader; getmem(buf,ppubufsize); end; @@ -250,7 +253,7 @@ end; procedure tppufile.flush; begin - if writing then + if Mode=2 then writebuf; end; @@ -259,11 +262,15 @@ procedure tppufile.close; var i : word; begin - Flush; - {$I-} - system.close(f); - {$I+} - i:=ioresult; + if Mode<>0 then + begin + Flush; + {$I-} + system.close(f); + {$I+} + i:=ioresult; + Mode:=0; + end; end; @@ -346,7 +353,7 @@ begin {reset buffer} bufstart:=i; bufsize:=0; - writing:=false; + Mode:=1; open:=true; end; @@ -508,6 +515,7 @@ begin {$I+} if ioresult<>0 then exit; + Mode:=2; {write header for sure} blockwrite(f,header,sizeof(tppuheader)); bufsize:=ppubufsize; @@ -515,7 +523,6 @@ begin crc:=$ffffffff; do_crc:=true; size:=0; - writing:=true; create:=true; end; @@ -644,7 +651,11 @@ end; end. { $Log$ - Revision 1.1 1998-05-12 10:56:07 peter + Revision 1.2 1998-05-27 19:45:08 peter + * symtable.pas splitted into includefiles + * symtable adapted for $ifdef NEWPPU + + Revision 1.1 1998/05/12 10:56:07 peter + the ppufile object unit } \ No newline at end of file diff --git a/compiler/symdef.inc b/compiler/symdef.inc new file mode 100644 index 0000000000..4e4cf3ca0c --- /dev/null +++ b/compiler/symdef.inc @@ -0,0 +1,2376 @@ +{ + $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=0 } + if (von>=0) and (bis<0) then + begin + savesize:=4; + typ:=u32bit; + end + else if (von>=0) and (bis<=255) then + begin + savesize:=1; + typ:=u8bit; + end + else if (von>=-128) and (bis<=127) then + begin + savesize:=1; + typ:=s8bit; + end + else if (von>=0) and (bis<=65536) then + begin + savesize:=2; + typ:=u16bit; + end + else if (von>=-32768) and (bis<=32767) then + begin + savesize:=2; + typ:=s16bit; + end + else + begin + savesize:=4; + typ:=s32bit; + end; + end + else + case typ of + uchar,u8bit,bool8bit,s8bit : savesize:=1; + u16bit,s16bit : savesize:=2; + s32bit,u32bit : savesize:=4; + else savesize:=0; + 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 von<=bis then + begin + datasegment^.concat(new(pai_const,init_32bit(von))); + datasegment^.concat(new(pai_const,init_32bit(bis))); + end + { for u32bit we need two bounds } + else + begin + datasegment^.concat(new(pai_const,init_32bit(von))); + 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(bis))); + end; + end; + end; + + procedure torddef.write; + begin +{$ifndef NEWPPU} + writebyte(iborddef); +{$endif} + tdef.write; + writebyte(byte(typ)); + writelong(von); + writelong(bis); +{$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 : stabstring := strpnew('r'+numberstring+';0;255;'); + { u32bit : stabstring := strpnew('r'+ + s32bitdef^.numberstring+';0;-1;'); } + else + stabstring := strpnew('r'+s32bitdef^.numberstring+';'+tostr(von)+';'+tostr(bis)+';'); + 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; + +{$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 + argnames := argnames+'3var' + 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.1 1998-05-27 19:45:09 peter + * symtable.pas splitted into includefiles + * symtable adapted for $ifdef NEWPPU + +} + \ No newline at end of file diff --git a/compiler/symppu.inc b/compiler/symppu.inc new file mode 100644 index 0000000000..0140d04e88 --- /dev/null +++ b/compiler/symppu.inc @@ -0,0 +1,541 @@ +{ + $Id$ + Copyright (c) 1993-98 by Florian Klaempfl, Pierre Muller + + Implementation of the reading of PPU Files for the symtable + + 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. + **************************************************************************** +} + + const +{$ifdef FPC} + ppubufsize=32768; +{$ELSE} + {$IFDEF USEOVERLAY} + ppubufsize=512; + {$ELSE} + ppubufsize=4096; + {$ENDIF} +{$ENDIF} + +{***************************************************************************** + PPU Writing +*****************************************************************************} + +{$ifdef NEWPPU} + + procedure writebyte(b:byte); + begin + ppufile.putbyte(b); + end; + + procedure writeword(w:word); + begin + ppufile.putword(w); + end; + + procedure writelong(l:longint); + begin + ppufile.putlongint(l); + end; + + procedure writedouble(d:double); + begin + ppufile.putdata(d,sizeof(double)); + end; + + procedure writestring(const s:string); + begin + ppufile.putstring(s); + end; + + procedure writeset(var s); {You cannot pass an array[0..31] of byte!} + begin + ppufile.putdata(s,32); + end; + + procedure writecontainer(var p:tstringcontainer;id:byte;hold:boolean); + var + hcontainer : tstringcontainer; + s : string; + begin + if hold then + hcontainer.init; + while not p.empty do + begin + s:=p.get; + ppufile.putstring(s); + if hold then + hcontainer.insert(s); + end; + ppufile.writeentry(id); + if hold then + p:=hcontainer; + end; + + procedure writeposinfo(const p:tfileposinfo); + begin + writeword(p.fileindex); + writelong(p.line); + writeword(p.column); + end; + + procedure writedefref(p : pdef); + begin + if p=nil then + ppufile.putlongint($ffffffff) + else + begin + if (p^.owner^.symtabletype in [recordsymtable,objectsymtable]) then + ppufile.putword($ffff) + else + ppufile.putword(p^.owner^.unitid); + ppufile.putword(p^.number); + end; + end; + + +{$ifdef UseBrowser} + procedure writesymref(p : psym); + begin + if p=nil then + writelong($ffffffff) + else + begin + if (p^.owner^.symtabletype in [recordsymtable,objectsymtable]) then + writeword($ffff) + else + writeword(p^.owner^.unitid); + writeword(p^.indexnb); + end; + end; +{$endif UseBrowser} + + procedure writeunitas(const s : string;unit_symtable : punitsymtable); +{$ifdef UseBrowser} + var + pus : punitsymtable; +{$endif UseBrowser} + begin + Message1(unit_u_ppu_write,s); + + { create unit flags } + with Current_Module^ do + begin + if cs_smartlink in aktswitches then + begin + flags:=flags or uf_smartlink; + if SplitName(ppufilename^)<>SplitName(libfilename^) then + flags:=flags or uf_in_library; + end; + if use_dbx then + flags:=flags or uf_uses_dbx; + if target_os.endian=en_big_endian then + flags:=flags or uf_big_endian; +{$ifdef UseBrowser} + if use_browser then + flags:=flags or uf_uses_browser; +{$endif UseBrowser} + end; + + ppufile.init(s); + ppufile.change_endian:=source_os.endian<>target_os.endian; + if not ppufile.create then + Message(unit_f_ppu_cannot_write); + unit_symtable^.writeasunit; +{$ifdef UseBrowser} + { write all new references to old unit elements } + pus:=punitsymtable(unit_symtable^.next); + if use_browser then + while assigned(pus) do + begin + if pus^.symtabletype = unitsymtable then + pus^.write_external_references; + pus:=punitsymtable(pus^.next); + end; +{$endif UseBrowser} + ppufile.flush; + { create and write header } + ppufile.header.size:=ppufile.size; + ppufile.header.checksum:=ppufile.crc; + ppufile.header.compiler:=wordversion; + ppufile.header.target:=word(target_info.target); + ppufile.header.flags:=current_module^.flags; + ppufile.writeheader; + { save crc in current_module also } + current_module^.crc:=ppufile.crc; + { close } + ppufile.close; + ppufile.done; + end; + + +{$else NEWPPU} + + procedure writebyte(b:byte); + begin + ppufile.write_data(b,1); + end; + + procedure writeword(w:word); + begin + ppufile.write_data(w,2); + end; + + procedure writelong(l:longint); + begin + ppufile.write_data(l,4); + end; + + procedure writedouble(d:double); + begin + ppufile.write_data(d,sizeof(double)); + end; + + procedure writestring(s : string); + begin + ppufile.write_data(s,length(s)+1); + end; + + procedure writeset(var s); {You cannot pass an array[0..31] of byte!} + begin + ppufile.write_data(s,32); + end; + + procedure writecontainer(var p:tstringcontainer;id:byte;hold:boolean); + var + hcontainer : tstringcontainer; + s : string; + begin + if hold then + hcontainer.init; + while not p.empty do + begin + writebyte(id); + s:=p.get; + writestring(s); + if hold then + hcontainer.insert(s); + end; + if hold then + p:=hcontainer; + end; + + procedure writeposinfo(const p:tfileposinfo); + begin + writeword(p.fileindex); + writelong(p.line); + writeword(p.column); + end; + + procedure writedefref(p : pdef); + begin + if p=nil then + writelong($ffffffff) + else + begin + if (p^.owner^.symtabletype in [recordsymtable,objectsymtable]) then + writeword($ffff) + else + writeword(p^.owner^.unitid); + writeword(p^.number); + end; + end; + + +{$ifdef UseBrowser} + procedure writesymref(p : psym); + begin + if p=nil then + writelong($ffffffff) + else + begin + if (p^.owner^.symtabletype in [recordsymtable,objectsymtable]) then + writeword($ffff) + else + writeword(p^.owner^.unitid); + writeword(p^.indexnb); + end; + end; +{$endif UseBrowser} + + + procedure writeunitas(const s : string;unit_symtable : punitsymtable); +{$ifdef UseBrowser} + var + pus : punitsymtable; +{$endif UseBrowser} + begin + Message1(unit_u_ppu_write,s); + + { create unit flags } + with Current_Module^ do + begin + if cs_smartlink in aktswitches then + begin + flags:=flags or uf_smartlink; + if SplitName(ppufilename^)<>SplitName(libfilename^) then + flags:=flags or uf_in_library; + end; + if use_dbx then + flags:=flags or uf_uses_dbx; + if target_os.endian=en_big_endian then + flags:=flags or uf_big_endian; +{$ifdef UseBrowser} + if use_browser then + flags:=flags or uf_uses_browser; +{$endif UseBrowser} + end; + + { open en init ppufile } + ppufile.init(s,ppubufsize); + ppufile.change_endian:=source_os.endian<>target_os.endian; + ppufile.rewrite; + if ioresult<>0 then + Message(unit_f_ppu_cannot_write); + { create and write header } + unitheader[8]:=char(byte(target_info.target)); + unitheader[9]:=char(current_module^.flags); + ppufile.write_data(unitheader,sizeof(unitheader)); + ppufile.clear_crc; + ppufile.do_crc:=true; + unit_symtable^.writeasunit; + ppufile.flush; + ppufile.do_crc:=false; +{$ifdef UseBrowser} + { write all new references to old unit elements } + pus:=punitsymtable(unit_symtable^.next); + if use_browser then + while assigned(pus) do + begin + if pus^.symtabletype = unitsymtable then + pus^.write_external_references; + pus:=punitsymtable(pus^.next); + end; +{$endif UseBrowser} + { writes the checksum } + ppufile.seek(10); + current_module^.crc:=ppufile.getcrc; + ppufile.write_data(current_module^.crc,4); + ppufile.flush; + ppufile.done; + end; + +{$endif NEWPPU} + +{***************************************************************************** + PPU Reading +*****************************************************************************} + +{$ifdef NEWPPU} + function readbyte:byte; + begin + readbyte:=current_module^.ppufile^.getbyte; + if current_module^.ppufile^.error then + Message(unit_f_ppu_read_error); + end; + + function readword:word; + begin + readword:=current_module^.ppufile^.getword; + if current_module^.ppufile^.error then + Message(unit_f_ppu_read_error); + end; + + function readlong:longint; + begin + readlong:=current_module^.ppufile^.getlongint; + if current_module^.ppufile^.error then + Message(unit_f_ppu_read_error); + end; + + function readdouble : double; + var + d : double; + begin + current_module^.ppufile^.getdata(d,sizeof(double)); + if current_module^.ppufile^.error then + Message(unit_f_ppu_read_error); + readdouble:=d; + end; + + function readstring : string; + begin + readstring:=current_module^.ppufile^.getstring; + if current_module^.ppufile^.error then + Message(unit_f_ppu_read_error); + end; + + procedure readset(var s); {You cannot pass an array [0..31] of byte.} + begin + current_module^.ppufile^.getdata(s,32); + if current_module^.ppufile^.error then + Message(unit_f_ppu_read_error); + end; + + procedure readcontainer(var p:tstringcontainer); + begin + p.init; + while not current_module^.ppufile^.endofentry do + p.insert(current_module^.ppufile^.getstring); + end; + + procedure readposinfo(var p:tfileposinfo); + begin + p.fileindex:=readword; + p.line:=readlong; + p.column:=readword; + end; + + function readdefref : pdef; + var + hd : pdef; + begin + longint(hd):=readword; + longint(hd):=longint(hd) or (longint(readword) shl 16); + readdefref:=hd; + end; + +{$ifdef UseBrowser} + function readsymref : psym; + var + hd : psym; + begin + longint(hd):=readword; + longint(hd):=longint(hd) or (longint(readword) shl 16); + readsymref:=hd; + end; +{$endif} + + +{$else NEWPPU} + + + function readbyte : byte; + + var + count : longint; + b : byte; + + begin + current_module^.ppufile^.read_data(b,sizeof(byte),count); + readbyte:=b; + if count<>1 then + Message(unit_f_ppu_read_error); + end; + + function readword : word; + + var + count : longint; + w : word; + + begin + current_module^.ppufile^.read_data(w,sizeof(word),count); + readword:=w; + if count<>sizeof(word) then + Message(unit_f_ppu_read_error); + end; + + function readlong : longint; + + var + count,l : longint; + + begin + current_module^.ppufile^.read_data(l,sizeof(longint),count); + readlong:=l; + if count<>sizeof(longint) then + Message(unit_f_ppu_read_error); + end; + + function readdouble : double; + + var + count : longint; + d : double; + + begin + current_module^.ppufile^.read_data(d,sizeof(double),count); + readdouble:=d; + if count<>sizeof(double) then + Message(unit_f_ppu_read_error); + end; + + function readstring : string; + + var + s : string; + count : longint; + + begin + s[0]:=char(readbyte); + current_module^.ppufile^.read_data(s[1],ord(s[0]),count); + if count<>ord(s[0]) then + Message(unit_f_ppu_read_error); + readstring:=s; + end; + +{***SETCONST} + procedure readset(var s); {You cannot pass an array [0..31] of byte.} + + var count:longint; + + begin + current_module^.ppufile^.read_data(s,32,count); + if count<>32 then + Message(unit_f_ppu_read_error); + end; +{***} + + procedure readposinfo(var p:tfileposinfo); + begin + p.fileindex:=readword; + p.line:=readlong; + p.column:=readword; + end; + + + function readdefref : pdef; + var + hd : pdef; + begin + longint(hd):=readword; + longint(hd):=longint(hd) or (longint(readword) shl 16); + readdefref:=hd; + end; + +{$ifdef UseBrowser} + function readsymref : psym; + var + hd : psym; + begin + longint(hd):=readword; + longint(hd):=longint(hd) or (longint(readword) shl 16); + readsymref:=hd; + end; +{$endif UseBrowser} + +{$endif NEWPPU} + +{ + $Log$ + Revision 1.1 1998-05-27 19:45:09 peter + * symtable.pas splitted into includefiles + * symtable adapted for $ifdef NEWPPU + +} + \ No newline at end of file diff --git a/compiler/symsym.inc b/compiler/symsym.inc new file mode 100644 index 0000000000..a18e9825fa --- /dev/null +++ b/compiler/symsym.inc @@ -0,0 +1,1695 @@ +{ + $Id$ + Copyright (c) 1993-98 by Florian Klaempfl, Pierre Muller + + Implementation for the symbols types of the symtable + + 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. + **************************************************************************** +} + +{**************************************************************************** + TSYM (base for all symtypes) +****************************************************************************} + + constructor tsym.init(const n : string); + begin + left:=nil; + right:=nil; + setname(n); + typ:=abstractsym; + properties:=current_object_option; +{$ifdef GDB} + isstabwritten := false; +{$endif GDB} + if assigned(current_module) and assigned(current_module^.current_inputfile) then + line_no:=current_module^.current_inputfile^.line_no + else + line_no:=0; +{$ifdef UseBrowser} + defref:=nil; + lastwritten:=nil; + if make_ref then + add_new_ref(defref,@tokenpos); + lastref:=defref; + refcount:=1; +{$endif UseBrowser} + end; + + constructor tsym.load; + + begin + left:=nil; + right:=nil; + setname(readstring); + typ:=abstractsym; + if object_options then + properties:=symprop(readbyte) + else + properties:=sp_public; +{$ifdef UseBrowser} + lastref:=nil; + defref:=nil; + lastwritten:=nil; + refcount:=0; + if (current_module^.flags and uf_uses_browser)<>0 then + { references do not change the ppu caracteristics } + { this only save the references to variables/functions } + { defined in the unit what about the others } + load_references; +{$endif UseBrowser} +{$ifdef GDB} + isstabwritten := false; +{$endif GDB} + line_no:=0; + end; + +{$ifdef UseBrowser} + +{$ifdef NEWPPU} + + procedure tsym.load_references; + var + fileindex : word; + b : byte; + l,c : longint; + begin + b:=readentry; + if b=ibref then + begin + while (not ppufile.endofentry) do + begin + fileindex:=readword; + l:=readlong; + c:=readword; + inc(refcount); + lastref:=new(pref,load(lastref,fileindex,l,c)); + if refcount=1 then + defref:=lastref; + end; + end + else + Message(unit_f_ppu_read_error); + lastwritten:=lastref; + end; + + procedure tsym.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 + writeposinfo(ref^.posinfo); + ref:=ref^.nextref; + end; + lastwritten:=lastref; + ppufile.writeentry(ibref); + ppufile.do_crc:=true; + end; + + + procedure load_external_references; + var b : byte; + sym : psym; + prdef : pdef; + begin + b:=readentry; + if b=ibextsymref then + begin + sym:=readsymref; + resolvesym(sym); + sym^.load_references; + end; + ibextdefref : begin + prdef:=readdefref; + resolvedef(prdef); + if prdef^.deftype<>procdef then + Message(unit_f_ppu_read_error); + pprocdef(prdef)^.load_references; + end; + else + Message(unit_f_ppu_read_error); + end; + end; + + procedure tsym.write_external_references; + var ref : pref; + prdef : pdef; + begin + ppufile.do_crc:=false; + if lastwritten=lastref then + exit; + writesymref(@self); + writeentry(ibextsymref); + + write_references; + + if typ=procsym then + begin + prdef:=pprocsym(@self)^.definition; + while assigned(prdef) do + begin + pprocdef(prdef)^.write_external_references; + prdef:=pprocdef(prdef)^.nextoverloaded; + end; + end; + ppufile.do_crc:=true; + end; + +{$else NEWPPU} + + procedure tsym.load_references; + + var fileindex : word; + b : byte; + l,c : longint; + + begin + b:=readbyte; + 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; + lastwritten:=lastref; + if b <> ibend then + Message(unit_f_ppu_read_error); + end; + + procedure tsym.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 load_external_references; + + var b : byte; + sym : psym; + prdef : pdef; + begin + b:=readbyte; + while (b=ibextsymref) or (b=ibextdefref) do + begin + if b=ibextsymref then + begin + sym:=readsymref; + resolvesym(sym); + sym^.load_references; + b:=readbyte; + end + else + if b=ibextdefref then + begin + prdef:=readdefref; + resolvedef(prdef); + if prdef^.deftype<>procdef then + Message(unit_f_ppu_read_error); + pprocdef(prdef)^.load_references; + b:=readbyte; + end; + end; + if b <> ibend then + Message(unit_f_ppu_read_error); + end; + + procedure tsym.write_external_references; + var ref : pref; + prdef : pdef; + begin + ppufile.do_crc:=false; + if lastwritten=lastref then + exit; + writebyte(ibextsymref); + writesymref(@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); + if typ=procsym then + begin + prdef:=pprocsym(@self)^.definition; + while assigned(prdef) do + begin + pprocdef(prdef)^.write_external_references; + prdef:=pprocdef(prdef)^.nextoverloaded; + end; + end; + ppufile.do_crc:=true; + end; + +{$endif NEWPPU} + + procedure tsym.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,'***',name,'***'); + 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 tsym.done; + + begin +{$ifdef tp} + if not(use_big) then +{$endif tp} + strdispose(_name); + if assigned(left) then dispose(left,done); + if assigned(right) then dispose(right,done); + end; + + destructor tsym.single_done; + + begin +{$ifdef tp} + if not(use_big) then +{$endif tp} + strdispose(_name); + end; + + procedure tsym.write; + + begin + writestring(name); + if object_options then + writebyte(byte(properties)); +{$ifdef UseBrowser} + if (current_module^.flags and uf_uses_browser)<>0 then + write_references; +{$endif UseBrowser} + end; + + procedure tsym.deref; + + begin + end; + + function tsym.name : string; +{$ifdef tp} + var + s : string; + b : byte; +{$endif tp} + begin +{$ifdef tp} + if use_big then + begin + symbolstream.seek(longint(_name)); + symbolstream.read(b,1); + symbolstream.read(s[1],b); + s[0]:=chr(b); + name:=s; + end + else +{$endif} + name:=strpas(_name); + end; + + function tsym.mangledname : string; + begin + mangledname:=name; + end; + + procedure tsym.setname(const s : string); + begin + setstring(_name,s); + end; + + { for most symbol types ther is nothing to do at all } + procedure tsym.insert_in_data; + begin + end; + + +{$ifdef GDB} + function tsym.stabstring : pchar; + + begin + stabstring:=strpnew('"'+name+'",'+tostr(N_LSYM)+',0,'+tostr(line_no)+',0'); + end; + + procedure tsym.concatstabto(asmlist : paasmoutput); + + var stab_str : pchar; + begin + if not isstabwritten then + begin + stab_str := stabstring; + if asmlist = debuglist then do_count_dbx := true; + { count_dbx(stab_str); moved to GDB.PAS } + asmlist^.concat(new(pai_stabs,init(stab_str))); + isstabwritten:=true; + end; + end; +{$endif GDB} + +{**************************************************************************** + TLABELSYM +****************************************************************************} + + constructor tlabelsym.init(const n : string; l : plabel); + + begin + inherited init(n); + typ:=labelsym; + number:=l; + number^.is_used:=false; + number^.is_set:=true; + number^.refcount:=0; + defined:=false; + end; + + destructor tlabelsym.done; + + begin + if not(defined) then + Message1(sym_e_label_not_defined,name); + inherited done; + end; + + function tlabelsym.mangledname : string; + + begin + { this also sets the is_used field } + mangledname:=lab2str(number); + end; + + procedure tlabelsym.write; + + begin + Message(sym_e_ill_label_decl); + end; + +{**************************************************************************** + TUNITSYM +****************************************************************************} + + constructor tunitsym.init(const n : string;ref : punitsymtable); + + begin + tsym.init(n); + typ:=unitsym; + unitsymtable:=ref; + prevsym:=ref^.unitsym; + ref^.unitsym:=@self; + refs:=0; + end; + + destructor tunitsym.done; + begin + if assigned(unitsymtable) and (unitsymtable^.unitsym=@self) then + unitsymtable^.unitsym:=prevsym; + inherited done; + end; + + procedure tunitsym.write; + begin + end; + +{$ifdef GDB} + procedure tunitsym.concatstabto(asmlist : paasmoutput); + begin + {Nothing to write to stabs !} + end; +{$endif GDB} + +{**************************************************************************** + TPROCSYM +****************************************************************************} + + constructor tprocsym.init(const n : string); + + begin + tsym.init(n); + typ:=procsym; + definition:=nil; + owner:=nil; +{$ifdef GDB} + is_global := false; +{$endif GDB} + end; + + constructor tprocsym.load; + + begin + tsym.load; + typ:=procsym; + definition:=pprocdef(readdefref); +{$ifdef GDB} + is_global := false; +{$endif GDB} + end; + + destructor tprocsym.done; + + begin + check_forward; + tsym.done; + end; + + function tprocsym.mangledname : string; + + begin + mangledname:=definition^.mangledname; + end; + + + function tprocsym.demangledname:string; + begin + demangledname:=name+'('+demangledparas(definition^.mangledname)+')'; + end; + + + procedure tprocsym.check_forward; + + var + pd : pprocdef; + + begin + pd:=definition; + while assigned(pd) do + begin + if pd^.forwarddef then + begin +{$ifdef GDB} + if assigned(pd^._class) then + Message1(sym_e_forward_not_resolved,pd^._class^.name^+'.'+name+'('+demangledparas(pd^.mangledname)+')') + else +{$endif GDB} + Message1(sym_e_forward_not_resolved,demangledname) + end; + pd:=pd^.nextoverloaded; + end; + end; + + procedure tprocsym.deref; + var t : ttoken; + + begin + resolvedef(pdef(definition)); + for t:=PLUS to last_overloaded do + if (overloaded_operators[t]=nil) and + (name=overloaded_names[t]) then + overloaded_operators[t]:=@self; + end; + + procedure tprocsym.write; + begin +{$ifndef NEWPPU} + writebyte(ibprocsym); +{$endif} + tsym.write; + writedefref(pdef(definition)); +{$ifdef NEWPPU} + ppufile.writeentry(ibprocsym); +{$endif} + end; + +{$ifdef GDB} + function tprocsym.stabstring : pchar; + Var RetType : Char; + Obj,Info : String; + begin + obj := name; + info := ''; + if is_global then + RetType := 'F' + else + RetType := 'f'; + if assigned(owner) then + begin + if (owner^.symtabletype = objectsymtable) then + obj := owner^.name^+'__'+name; + if (owner^.symtabletype=localsymtable) and assigned(owner^.name) then + info := ','+name+','+owner^.name^; + end; + stabstring :=strpnew('"'+obj+':'+RetType + +definition^.retdef^.numberstring+info+'",'+tostr(n_function) + +',0,'+tostr(current_module^.current_inputfile^.line_no) + +','+definition^.mangledname); + end; + + procedure tprocsym.concatstabto(asmlist : paasmoutput); + begin + if (definition^.options and pointernproc) <> 0 then exit; + if not isstabwritten then + asmlist^.concat(new(pai_stabs,init(stabstring))); + isstabwritten := true; + if assigned(definition^.parast) then + definition^.parast^.concatstabto(asmlist); + if assigned(definition^.localst) then + definition^.localst^.concatstabto(asmlist); + definition^.is_def_stab_written := true; + end; +{$endif GDB} + + +{**************************************************************************** + TPROGRAMSYM +****************************************************************************} + + constructor tprogramsym.init(const n : string); + begin + tsym.init(n); + typ:=programsym; + end; + +{**************************************************************************** + TERRORSYM +****************************************************************************} + + constructor terrorsym.init; + begin + tsym.init(''); + typ:=errorsym; + end; + +{**************************************************************************** + TPROPERTYSYM +****************************************************************************} + + constructor tpropertysym.init(const n : string); + begin + inherited init(n); + typ:=propertysym; + options:=0; + proptype:=nil; + readaccessdef:=nil; + writeaccessdef:=nil; + readaccesssym:=nil; + writeaccesssym:=nil; + index:=$0; + end; + + destructor tpropertysym.done; + + begin + inherited done; + end; + + constructor tpropertysym.load; + + begin + inherited load; + typ:=propertysym; + proptype:=readdefref; + options:=readlong; + index:=readlong; + { it's hack ... } + readaccesssym:=psym(stringdup(readstring)); + writeaccesssym:=psym(stringdup(readstring)); + { now the defs: } + readaccessdef:=readdefref; + writeaccessdef:=readdefref; + end; + + procedure tpropertysym.deref; + + begin + resolvedef(proptype); + resolvedef(readaccessdef); + resolvedef(writeaccessdef); + { solve the hack we did in load: } + if pstring(readaccesssym)^<>'' then + begin + srsym:=search_class_member(pobjectdef(owner^.defowner),pstring(readaccesssym)^); + if not(assigned(srsym)) then + srsym:=generrorsym; + end + else + srsym:=nil; + stringdispose(pstring(readaccesssym)); + readaccesssym:=srsym; + if pstring(writeaccesssym)^<>'' then + begin + srsym:=search_class_member(pobjectdef(owner^.defowner),pstring(writeaccesssym)^); + if not(assigned(srsym)) then + srsym:=generrorsym; + end + else + srsym:=nil; + stringdispose(pstring(writeaccesssym)); + writeaccesssym:=srsym; + end; + + function tpropertysym.getsize : longint; + + begin + getsize:=0; + end; + + procedure tpropertysym.write; + + begin +{$ifndef NEWPPU} + writebyte(ibpropertysym); +{$endif} + tsym.write; + writedefref(proptype); + writelong(options); + writelong(index); + if assigned(readaccesssym) then + writestring(readaccesssym^.name) + else + writestring(''); + if assigned(writeaccesssym) then + writestring(writeaccesssym^.name) + else + writestring(''); + writedefref(readaccessdef); + writedefref(writeaccessdef); +{$ifdef NEWPPU} + ppufile.writeentry(ibpropertysym); +{$endif} + end; + +{$ifdef GDB} + function tpropertysym.stabstring : pchar; + begin + { !!!! don't know how to handle } + stabstring:=strpnew(''); + end; + + procedure tpropertysym.concatstabto(asmlist : paasmoutput); + begin + { !!!! don't know how to handle } + end; +{$endif GDB} + +{**************************************************************************** + TFUNCRETSYM +****************************************************************************} + +{$ifdef TEST_FUNCRET} + constructor tfuncretsym.init(const n : string;approcinfo : pprocinfo); + + begin + tsym.init(n); + funcretprocinfo:=approcinfo; + funcretdef:=approcinfo^.retdef; + { address valid for ret in param only } + { otherwise set by insert } + address:=approcinfo^.retoffset; + end; +{$endif TEST_FUNCRET} + +{**************************************************************************** + TABSOLUTESYM +****************************************************************************} + +{ constructor tabsolutesym.init(const s : string;p : pdef;newref : psym); + begin + inherited init(s,p); + ref:=newref; + typ:=absolutesym; + end; } + + constructor tabsolutesym.load; + + begin + tvarsym.load; + typ:=absolutesym; + ref:=nil; + address:=0; + asmname:=nil; + abstyp:=absolutetyp(readbyte); + absseg:=false; + case abstyp of + tovar : begin + asmname:=stringdup(readstring); + ref:=srsym; + end; + toasm : asmname:=stringdup(readstring); + toaddr : address:=readlong; + end; + end; + + procedure tabsolutesym.write; + + begin +{$ifndef NEWPPU} + writebyte(ibabsolutesym); +{$endif} + tsym.write; + writebyte(byte(varspez)); + if read_member then + writelong(address); + writedefref(definition); + writebyte(byte(abstyp)); + case abstyp of + tovar : writestring(ref^.name); + toasm : writestring(asmname^); + toaddr : writelong(address); + end; +{$ifdef NEWPPU} + ppufile.writeentry(ibabsolutesym); +{$endif} + end; + + procedure tabsolutesym.deref; + begin + resolvedef(definition); + if (abstyp=tovar) and (asmname<>nil) then + begin + { search previous loaded symtables } + getsym(asmname^,false); + if not(assigned(srsym)) then + getsymonlyin(owner,asmname^); + if not(assigned(srsym)) then + srsym:=generrorsym; + ref:=srsym; + stringdispose(asmname); + end; + end; + + function tabsolutesym.mangledname : string; + begin + case abstyp of + tovar : mangledname:=ref^.mangledname; + toasm : mangledname:=asmname^; + toaddr : mangledname:='$'+tostr(address); + else + internalerror(10002); + end; + end; + + procedure tabsolutesym.insert_in_data; + + begin + end; + + +{$ifdef GDB} + procedure tabsolutesym.concatstabto(asmlist : paasmoutput); + begin + { I don't know how to handle this !! } + end; +{$endif GDB} + +{**************************************************************************** + TVARSYM +****************************************************************************} + + constructor tvarsym.init(const n : string;p : pdef); + begin + tsym.init(n); + typ:=varsym; + definition:=p; + varspez:=vs_value; + address:=0; + refs:=0; + is_valid := 1; + { can we load the value into a register ? } + case p^.deftype of + pointerdef, + enumdef, + procvardef : regable:=true; + orddef : case porddef(p)^.typ of + u8bit,s32bit, + bool8bit,uchar, + s8bit,s16bit, + u16bit,u32bit : regable:=true; + else + regable:=false; + end; + else + regable:=false; + end; + reg:=R_NO; + end; + + constructor tvarsym.load; + + begin + tsym.load; + typ:=varsym; + varspez:=tvarspez(readbyte); + if read_member then + address:=readlong + else address:=0; + definition:=readdefref; + refs := 0; + is_valid := 1; + { symbols which are load are never candidates for a register } + regable:=false; + reg:=R_NO; + end; + + procedure tvarsym.deref; + + begin + resolvedef(definition); + end; + + procedure tvarsym.write; + + begin +{$ifndef NEWPPU} + writebyte(ibvarsym); +{$endif} + tsym.write; + writebyte(byte(varspez)); + + if read_member then + writelong(address); + + writedefref(definition); +{$ifdef NEWPPU} + ppufile.writeentry(ibvarsym); +{$endif} + end; + + function tvarsym.mangledname : string; + var + prefix : string; + begin + case owner^.symtabletype of + staticsymtable : if (cs_smartlink in aktswitches) then + prefix:='_'+owner^.name^+'$$$_' + else + prefix:='_'; + unitsymtable, + globalsymtable : prefix:='U_'+owner^.name^+'_'; + else + Message(sym_e_invalid_call_tvarsymmangledname); + end; + mangledname:=prefix+name; + end; + + function tvarsym.getsize : longint; + begin + { only if the definition is set, we could determine the } + { size, this is if an error occurs while reading the type } + { also used for operator, this allows not to allocate the } + { return size twice } + if assigned(definition) then + begin + case varspez of + vs_value : getsize:=definition^.size; + vs_var : getsize:=sizeof(pointer); + vs_const : begin + if (definition^.deftype in [stringdef,arraydef, + recorddef,objectdef,setdef]) then + getsize:=sizeof(pointer) + else + getsize:=definition^.size; + end; + end; + end + else + getsize:=0; + end; + + procedure tvarsym.insert_in_data; + var + l,modulo : longint; + begin + { handle static variables of objects especially } + if read_member and (owner^.symtabletype=objectsymtable) and + ((properties and sp_static)<>0) then + begin + { the data filed is generated in parser.pas + with a tobject_FIELDNAME variable } + { this symbol can't be loaded to a register } + regable:=false; + end + else if not(read_member) then + begin + { made problems with parameters etc. ! (FK) } + + { check for instance of an abstract object or class } + { + if (pvarsym(sym)^.definition^.deftype=objectdef) and + ((pobjectdef(pvarsym(sym)^.definition)^.options and oois_abstract)<>0) then + Message(sym_e_no_instance_of_abstract_object); + } + { bei einer lokalen Symboltabelle erst! erh”hen, da der } + { Wert in codegen.secondload dann mit minus verwendet } + { wird } + l:=getsize; + if owner^.symtabletype=localsymtable then + begin + is_valid := 0; + modulo:=owner^.datasize and 3; +{$ifdef m68k} + { word alignment required for motorola } + if (l=1) then + l:=2 + else +{$endif} + + if (l>=4) and (modulo<>0) then + inc(l,4-modulo) + else if (l>=2) and ((modulo and 1)<>0) then + inc(l,2-(modulo and 1)); + inc(owner^.datasize,l); + + address:=owner^.datasize; + end + else if owner^.symtabletype=staticsymtable then + begin + if (cs_smartlink in aktswitches) then + bsssegment^.concat(new(pai_cut,init)); +{$ifdef GDB} + if cs_debuginfo in aktswitches then + concatstabto(bsssegment); +{$endif GDB} + if (cs_smartlink in aktswitches) then + bsssegment^.concat(new(pai_datablock,init_global(mangledname,l))) + else + bsssegment^.concat(new(pai_datablock,init(mangledname,l))); + + inc(owner^.datasize,l); + + { this symbol can't be loaded to a register } + regable:=false; + end + else if owner^.symtabletype=globalsymtable then + begin + if (cs_smartlink in aktswitches) then + bsssegment^.concat(new(pai_cut,init)); +{$ifdef GDB} + if cs_debuginfo in aktswitches then + begin + concatstabto(bsssegment); + { this has to be added so that the debugger knows where to find + the global variable + Doesn't work !! + bsssegment^.concat(new(pai_symbol,init('_'+name))); } + end; +{$endif GDB} + bsssegment^.concat(new(pai_datablock,init_global(mangledname,l))); + inc(owner^.datasize,l); + + { this symbol can't be loaded to a register } + regable:=false; + end + else if owner^.symtabletype in [recordsymtable,objectsymtable] then + begin + { align record and object fields } + if aktpackrecords=2 then + begin + { align to word } + modulo:=owner^.datasize and 3; + if (l>=2) and ((modulo and 1)<>0) then + inc(owner^.datasize); + end + else if aktpackrecords=4 then + begin + { align to dword } + if (l>=3) and (modulo<>0) then + inc(owner^.datasize,4-modulo) + { or word } + else if (l=2) and ((modulo and 1)<>0) then + inc(owner^.datasize) + end; + address:=owner^.datasize; + inc(owner^.datasize,l); + + { this symbol can't be loaded to a register } + regable:=false; + end + else if owner^.symtabletype=parasymtable then + begin + address:=owner^.datasize; + + { intel processors don't know a byte push, } + { so is always a word pushed } + { so it must allways be even } + if (l and 1)<>0 then + inc(l); + inc(owner^.datasize,l); + end + else + begin + modulo:=owner^.datasize and 3 ; + if (l>=4) and (modulo<>0) then + inc(owner^.datasize,4-modulo) + else if (l>=2) and ((modulo and 1)<>0) then + { nice piece of code !! + inc(owner^.datasize,2-(datasize and 1)); + 2 - (datasize and 1) is allways 1 in this case + Florian when will your global stream analyser + find this out ?? } + inc(owner^.datasize); + address:=owner^.datasize; + inc(owner^.datasize,l); + end; + end + end; + +{$ifdef GDB} + function tvarsym.stabstring : pchar; + var + st : char; + begin + if (owner^.symtabletype = objectsymtable) and + ((properties and sp_static)<>0) then + begin + if use_gsym then st := 'G' else st := 'S'; + stabstring := strpnew('"'+owner^.name^+'__'+name+':'+ + +definition^.numberstring+'",'+ + tostr(N_LCSYM)+',0,'+tostr(line_no)+','+mangledname); + end + else if (owner^.symtabletype = globalsymtable) or + (owner^.symtabletype = unitsymtable) then + begin + { Here we used S instead of + because with G GDB doesn't look at the address field + but searches the same name or with a leading underscore + but these names don't exist in pascal !} + if use_gsym then st := 'G' else st := 'S'; + stabstring := strpnew('"'+name+':'+st + +definition^.numberstring+'",'+ + tostr(N_LCSYM)+',0,'+tostr(line_no)+','+mangledname); + end + else if owner^.symtabletype = staticsymtable then + begin + stabstring := strpnew('"'+name+':S' + +definition^.numberstring+'",'+ + tostr(N_LCSYM)+',0,'+tostr(line_no)+','+mangledname); + end + else if (owner^.symtabletype=parasymtable) then + begin + case varspez of + vs_value : st := 'p'; + vs_var : st := 'v'; + vs_const : if dont_copy_const_param(definition) then + st := 'v'{ should be 'i' but 'i' doesn't work } + else + st := 'p'; + end; + stabstring := strpnew('"'+name+':'+st + +definition^.numberstring+'",'+ + tostr(N_PSYM)+',0,'+tostr(line_no)+','+tostr(address+owner^.call_offset)) + {offset to ebp => will not work if the framepointer is esp + so some optimizing will make things harder to debug } + end + else if (owner^.symtabletype=localsymtable) then + {$ifdef i386} + if reg<>R_NO then + begin + { "eax", "ecx", "edx", "ebx", "esp", "ebp", "esi", "edi", "eip", "ps", "cs", "ss", "ds", "es", "fs", "gs", } + { this is the register order for GDB} + stabstring:=strpnew('"'+name+':r' + +definition^.numberstring+'",'+ + tostr(N_RSYM)+',0,'+tostr(line_no)+','+tostr(GDB_i386index[reg])); + end + else + {$endif i386} + stabstring := strpnew('"'+name+':' + +definition^.numberstring+'",'+ + tostr(N_LSYM)+',0,'+tostr(line_no)+',-'+tostr(address)) + else + stabstring := inherited stabstring; + end; + + procedure tvarsym.concatstabto(asmlist : paasmoutput); + var stab_str : pchar; + begin + inherited concatstabto(asmlist); +{$ifdef i386} + if (owner^.symtabletype=parasymtable) and + (reg<>R_NO) then + begin + { "eax", "ecx", "edx", "ebx", "esp", "ebp", "esi", "edi", "eip", "ps", "cs", "ss", "ds", "es", "fs", "gs", } + { this is the register order for GDB} + stab_str:=strpnew('"'+name+':r' + +definition^.numberstring+'",'+ + tostr(N_RSYM)+',0,'+tostr(line_no)+','+tostr(GDB_i386index[reg])); + asmlist^.concat(new(pai_stabs,init(stab_str))); + end; +{$endif i386} + end; +{$endif GDB} + +{**************************************************************************** + TTYPEDCONSTSYM +*****************************************************************************} + + constructor ttypedconstsym.init(const n : string;p : pdef); + + begin + tsym.init(n); + typ:=typedconstsym; + definition:=p; + prefix:=stringdup(procprefix); + end; + + constructor ttypedconstsym.load; + + begin + tsym.load; + typ:=typedconstsym; + definition:=readdefref; + prefix:=stringdup(readstring); + end; + + destructor ttypedconstsym.done; + + begin + stringdispose(prefix); + tsym.done; + end; + + function ttypedconstsym.mangledname : string; + + begin + mangledname:='TC_'+prefix^+'_'+name; + end; + + procedure ttypedconstsym.deref; + + begin + resolvedef(definition); + end; + + procedure ttypedconstsym.write; + + begin +{$ifndef NEWPPU} + writebyte(ibtypedconstsym); +{$endif} + tsym.write; + writedefref(definition); + writestring(prefix^); +{$ifdef NEWPPU} + ppufile.writeentry(ibtypedconstsym); +{$endif} + end; + + { for most symbol types ther is nothing to do at all } + procedure ttypedconstsym.insert_in_data; + + begin + { here there is a problem for ansistrings !! } + { we must write the label only after the 12 header bytes (PM) } + if not is_ansistring(definition) then + really_insert_in_data; + end; + + procedure ttypedconstsym.really_insert_in_data; + begin + if (cs_smartlink in aktswitches) then + datasegment^.concat(new(pai_cut,init)); + if owner^.symtabletype=globalsymtable then + begin +{$ifdef GDB} + if cs_debuginfo in aktswitches then + concatstabto(datasegment); +{$endif GDB} + datasegment^.concat(new(pai_symbol,init_global(mangledname))); + end + else + if owner^.symtabletype<>unitsymtable then + begin +{$ifdef GDB} + if cs_debuginfo in aktswitches then + concatstabto(datasegment); +{$endif GDB} + if (cs_smartlink in aktswitches) then + datasegment^.concat(new(pai_symbol,init_global(mangledname))) + else + datasegment^.concat(new(pai_symbol,init(mangledname))); + end; + end; + +{$ifdef GDB} + function ttypedconstsym.stabstring : pchar; + var + st : char; + begin + if use_gsym and (owner^.symtabletype in [unitsymtable,globalsymtable]) then + st := 'G' + else + st := 'S'; + stabstring := strpnew('"'+name+':'+st + +definition^.numberstring+'",'+tostr(n_STSYM)+',0,'+tostr(line_no)+','+mangledname); + end; +{$endif GDB} + +{**************************************************************************** + TCONSTSYM +****************************************************************************} + + constructor tconstsym.init(const n : string;t : tconsttype;v : longint;def : pdef); + + begin + tsym.init(n); + typ:=constsym; + definition:=def; + consttype:=t; + value:=v; + end; + + constructor tconstsym.load; + + var + pd : pdouble; + ps : pointer; {***SETCONST} + + begin + tsym.load; + typ:=constsym; + consttype:=tconsttype(readbyte); + case consttype of + constint, + constbool, + constchar : value:=readlong; + constord : begin + definition:=readdefref; + value:=readlong; + end; + conststring : value:=longint(stringdup(readstring)); + constreal : begin + new(pd); + pd^:=readdouble; + value:=longint(pd); + end; +{***SETCONST} + constseta : begin + getmem(ps,32); + readset(ps^); + value:=longint(ps); + end; +{***} + else Message1(unit_f_ppu_invalid_entry,tostr(ord(consttype))); + end; + end; + + destructor tconstsym.done; + begin + if consttype = conststring then stringdispose(pstring(value)); + inherited done; + end; + + function tconstsym.mangledname : string; + + begin + mangledname:=name; + end; + + procedure tconstsym.deref; + + begin + if consttype=constord then + resolvedef(pdef(definition)); + end; + + procedure tconstsym.write; + + begin +{$ifndef NEWPPU} + writebyte(ibconstsym); +{$endif} + tsym.write; + writebyte(byte(consttype)); + case consttype of + constint, + constbool, + constchar : writelong(value); + constord : begin + writedefref(definition); + writelong(value); + end; + conststring : writestring(pstring(value)^); + constreal : writedouble(pdouble(value)^); +{***SETCONST} + constseta: writeset(pointer(value)^); +{***} + else internalerror(13); + end; +{$ifdef NEWPPU} + ppufile.writeentry(ibconstsym); +{$endif} + end; + +{$ifdef GDB} + function tconstsym.stabstring : pchar; + var st : string; + begin + {even GDB v4.16 only now 'i' 'r' and 'e' !!!} + case consttype of + conststring : begin + { I had to remove ibm2ascii !! } + st := pstring(value)^; + {st := ibm2ascii(pstring(value)^);} + st := 's'''+st+''''; + end; + constbool, constint, constord, constchar : st := 'i'+tostr(value); + constreal : begin + system.str(pdouble(value)^,st); + st := 'r'+st; + end; + { if we don't know just put zero !! } + else st:='i0'; + {***SETCONST} + {constset:;} {*** I don't know what to do with a set.} + { sets are not recognized by GDB} + {***} + end; + stabstring := strpnew('"'+name+':c='+st+'",'+tostr(N_function)+',0,'+tostr(line_no)+',0'); + end; + + procedure tconstsym.concatstabto(asmlist : paasmoutput); + begin + if consttype <> conststring then + inherited concatstabto(asmlist); + end; +{$endif GDB} + +{**************************************************************************** + TENUMSYM +****************************************************************************} + + constructor tenumsym.init(const n : string;def : penumdef;v : longint); + begin + tsym.init(n); + typ:=enumsym; + definition:=def; + value:=v; +{$ifdef GDB} + order; +{$endif GDB} + end; + + constructor tenumsym.load; + + begin + tsym.load; + typ:=enumsym; + definition:=penumdef(readdefref); + value:=readlong; +{$ifdef GDB} + next := Nil; +{$endif GDB} + end; + + procedure tenumsym.deref; + + begin + resolvedef(pdef(definition)); +{$ifdef GDB} + order; +{$endif} + end; + +{$ifdef GDB} + procedure tenumsym.order; + var sym : penumsym; + begin + sym := definition^.first; + if sym = nil then + begin + definition^.first := @self; + next := nil; + exit; + end; + {reorder the symbols in increasing value } + if value < sym^.value then + begin + next := sym; + definition^.first := @self; + end else + begin + while (sym^.value <= value) and assigned(sym^.next) do + sym := sym^.next; + next := sym^.next; + sym^.next := @self; + end; + end; +{$endif GDB} + + procedure tenumsym.write; + + begin +{$ifndef NEWPPU} + writebyte(ibenumsym); +{$endif} + tsym.write; + writedefref(definition); + writelong(value); +{$ifdef NEWPPU} + ppufile.writeentry(ibenumsym); +{$endif} + end; + +{$ifdef GDB} + procedure tenumsym.concatstabto(asmlist : paasmoutput); + begin + {enum elements have no stab !} + end; +{$EndIf GDB} + +{**************************************************************************** + TTYPESYM +****************************************************************************} + + constructor ttypesym.init(const n : string;d : pdef); + + begin + tsym.init(n); + typ:=typesym; + definition:=d; +{$ifdef GDB} + isusedinstab := false; +{$endif GDB} + forwardpointer:=nil; + { this allows to link definitions with the type with declares } + { them } + if assigned(definition) then + if definition^.sym=nil then + definition^.sym:=@self; + end; + + constructor ttypesym.load; + + begin + tsym.load; + typ:=typesym; + forwardpointer:=nil; +{$ifdef GDB} + isusedinstab := false; +{$endif GDB} + definition:=readdefref; + end; + + destructor ttypesym.done; + + begin + if assigned(definition) then + if definition^.sym=@self then + definition^.sym:=nil; + inherited done; + end; + + procedure ttypesym.deref; + + begin + resolvedef(definition); + if assigned(definition) then + if definition^.sym=nil then + definition^.sym:=@self; + if definition^.deftype=recorddef then + precdef(definition)^.symtable^.name:=stringdup('record '+name); + {if definition^.deftype=objectdef then + pobjectdef(definition)^.publicsyms^.name:=stringdup('object '+name); + done in tobjectdef.load } + end; + + procedure ttypesym.write; + + begin +{$ifndef NEWPPU} + writebyte(ibtypesym); +{$endif} + tsym.write; + writedefref(definition); +{$ifdef NEWPPU} + ppufile.writeentry(ibtypesym); +{$endif} + end; + +{$ifdef GDB} + function ttypesym.stabstring : pchar; + var stabchar : string[2]; + short : string; + begin + if definition^.deftype in tagtypes then + stabchar := 'Tt' + else + stabchar := 't'; + short := '"'+name+':'+stabchar+definition^.numberstring + +'",'+tostr(N_LSYM)+',0,'+tostr(line_no)+',0'; + stabstring := strpnew(short); + end; + + procedure ttypesym.concatstabto(asmlist : paasmoutput); + begin + {not stabs for forward defs } + if assigned(definition) then + if (definition^.sym = @self) then + definition^.concatstabto(asmlist) + else + inherited concatstabto(asmlist); + end; +{$endif GDB} + +{**************************************************************************** + TSYSSYM +****************************************************************************} + + constructor tsyssym.init(const n : string;l : longint); + begin + inherited init(n); + typ:=syssym; + number:=l; + end; + + procedure tsyssym.write; + begin + end; + +{$ifdef GDB} + procedure tsyssym.concatstabto(asmlist : paasmoutput); + begin + end; +{$endif GDB} + +{**************************************************************************** + TMACROSYM +****************************************************************************} + + constructor tmacrosym.init(const n : string); + begin + inherited init(n); + defined:=true; + buftext:=nil; + buflen:=0; + end; + + destructor tmacrosym.done; + begin + if assigned(buftext) then + freemem(buftext,buflen); + inherited done; + end; + +{$ifdef GDB} + function typeglobalnumber(const s : string) : string; + + var st : string; + symt : psymtable; + old_make_ref : boolean; + begin + old_make_ref:=make_ref; + make_ref:=false; + typeglobalnumber := '0'; + srsym := nil; + if pos('.',s) > 0 then + begin + st := copy(s,1,pos('.',s)-1); + getsym(st,false); + st := copy(s,pos('.',s)+1,255); + if assigned(srsym) then + begin + if srsym^.typ = unitsym then + begin + symt := punitsym(srsym)^.unitsymtable; + srsym := symt^.search(st); + end else srsym := nil; + end; + end else st := s; + if srsym = nil then getsym(st,true); + if srsym^.typ<>typesym then + begin + Message(sym_e_type_id_expected); + exit; + end; + typeglobalnumber := ptypesym(srsym)^.definition^.numberstring; + make_ref:=old_make_ref; + end; +{$endif GDB} + +{ + $Log$ + Revision 1.1 1998-05-27 19:45:09 peter + * symtable.pas splitted into includefiles + * symtable adapted for $ifdef NEWPPU + +} + \ No newline at end of file