{ $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; {$ifdef nextfield} nextsym:=nil; {$endif nextfield} setname(n); typ:=abstractsym; properties:=current_object_option; {$ifdef GDB} isstabwritten := false; {$endif GDB} fileinfo:=tokenpos; {$ifdef UseBrowser} defref:=nil; lastwritten:=nil; refcount:=0; if (cs_browser in aktmoduleswitches) and make_ref then begin defref:=new(pref,init(defref,@tokenpos)); inc(refcount); end; lastref:=defref; {$endif UseBrowser} end; constructor tsym.load; begin left:=nil; right:=nil; setname(readstring); typ:=abstractsym; fillchar(fileinfo,sizeof(fileinfo),0); if object_options then properties:=symprop(readbyte) else properties:=sp_public; {$ifdef UseBrowser} lastref:=nil; defref:=nil; lastwritten:=nil; refcount:=0; {$endif UseBrowser} {$ifdef GDB} isstabwritten := false; {$endif GDB} end; {$ifdef UseBrowser} procedure tsym.load_references; var pos : tfileposinfo; move_last : boolean; begin move_last:=lastwritten=lastref; while (not current_ppu^.endofentry) do begin readposinfo(pos); inc(refcount); lastref:=new(pref,init(lastref,@pos)); lastref^.is_written:=true; if refcount=1 then defref:=lastref; end; if move_last then lastwritten:=lastref; end; { big problem here : wrong refs were written because of interface parsing of other units PM moduleindex must be checked !! } function tsym.write_references : boolean; var ref : pref; symref_written,move_last : boolean; begin write_references:=false; if lastwritten=lastref then exit; { should we update lastref } move_last:=true; symref_written:=false; { write symbol refs } if assigned(lastwritten) then ref:=lastwritten else ref:=defref; while assigned(ref) do begin if ref^.moduleindex=current_module^.unit_index then begin { write address to this symbol } if not symref_written then begin writesymref(@self); symref_written:=true; end; writeposinfo(ref^.posinfo); ref^.is_written:=true; if move_last then lastwritten:=ref; end else if not ref^.is_written then move_last:=false else if move_last then lastwritten:=ref; ref:=ref^.nextref; end; if symref_written then current_ppu^.writeentry(ibsymref); write_references:=symref_written; end; procedure tsym.add_to_browserlog; begin if assigned(defref) then begin Browse.AddLog('***'+name+'***'); Browse.AddLogRefs(defref); end; end; {$endif UseBrowser} destructor tsym.done; begin {$ifdef tp} if not(use_big) then {$endif tp} strdispose(_name); {$ifdef UseBrowser} if assigned(defref) then dispose(defref,done); {$endif UseBrowser} if assigned(left) then dispose(left,done); if assigned(right) then dispose(right,done); end; procedure tsym.write; begin writestring(name); if object_options then writebyte(byte(properties)); end; procedure tsym.deref; begin end; function tsym.name : string; {$ifdef tp} var s : string; b : byte; {$endif} 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} if assigned(_name) then name:=strpas(_name) else 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 there 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(fileinfo.line)+',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; constructor tlabelsym.load; begin tsym.load; typ:=labelsym; { this is all dummy it is only used for local browsing } number:=nil; defined:=true; end; destructor tlabelsym.done; begin inherited done; end; function tlabelsym.mangledname : string; begin { this also sets the is_used field } mangledname:=lab2str(number); end; procedure tlabelsym.write; begin if owner^.symtabletype in [unitsymtable,globalsymtable] then Message(sym_e_ill_label_decl) else begin tsym.write; current_ppu^.writeentry(iblabelsym); end; end; {**************************************************************************** TUNITSYM ****************************************************************************} constructor tunitsym.init(const n : string;ref : punitsymtable); var old_make_ref : boolean; begin old_make_ref:=make_ref; make_ref:=false; inherited init(n); make_ref:=old_make_ref; typ:=unitsym; unitsymtable:=ref; prevsym:=ref^.unitsym; ref^.unitsym:=@self; refs:=0; end; constructor tunitsym.load; begin tsym.load; typ:=unitsym; unitsymtable:=punitsymtable(current_module^.globalsymtable); prevsym:=nil; end; destructor tunitsym.done; begin if assigned(unitsymtable) and (unitsymtable^.unitsym=@self) then unitsymtable^.unitsym:=prevsym; inherited done; end; procedure tunitsym.write; begin tsym.write; current_ppu^.writeentry(ibunitsym); 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+definition^.demangled_paras; end; procedure tprocsym.write_parameter_lists; var p : pprocdef; begin p:=definition; while assigned(p) do begin { force the error to be printed } Verbose.Message1(sym_b_param_list,name+p^.demangled_paras); p:=p^.nextoverloaded; end; end; procedure tprocsym.check_forward; var pd : pprocdef; oldaktfilepos : tfileposinfo; begin { don't check if errors !! } if status.errorcount>0 then exit; pd:=definition; while assigned(pd) do begin if pd^.forwarddef then begin oldaktfilepos:=aktfilepos; aktfilepos:=fileinfo; if assigned(pd^._class) then Message1(sym_e_forward_not_resolved,pd^._class^.name^+'.'+name+demangledparas(pd^.demangled_paras)) else Message1(sym_e_forward_not_resolved,name+pd^.demangled_paras); aktfilepos:=oldaktfilepos; end; pd:=pd^.nextoverloaded; end; end; procedure tprocsym.deref; var t : ttoken; last : pprocdef; begin resolvedef(pdef(definition)); if (definition^.options and pooperator) <> 0 then begin last:=definition; while assigned(last^.nextoverloaded) do last:=last^.nextoverloaded; for t:=first_overloaded to last_overloaded do if (name=overloaded_names[t]) then begin if assigned(overloaded_operators[t]) then last^.nextoverloaded:=overloaded_operators[t]^.definition; overloaded_operators[t]:=@self; end; end; end; procedure tprocsym.write; begin tsym.write; writedefref(pdef(definition)); current_ppu^.writeentry(ibprocsym); end; {$ifdef UseBrowser} procedure tprocsym.load_references; var prdef : pprocdef; begin inherited load_references; prdef:=definition; { take care about operators !! } while assigned(prdef) and (prdef^.owner=definition^.owner) do begin prdef^.load_references; prdef:=prdef^.nextoverloaded; end; end; function tprocsym.write_references : boolean; var prdef : pprocdef; begin write_references:=false; if not inherited write_references then exit; write_references:=true; prdef:=definition; while assigned(prdef) and (prdef^.owner=definition^.owner) do begin prdef^.write_references; prdef:=prdef^.nextoverloaded; end; end; procedure tprocsym.add_to_browserlog; var prdef : pprocdef; begin inherited add_to_browserlog; prdef:=definition; while assigned(prdef) do begin pprocdef(prdef)^.add_to_browserlog; prdef:=pprocdef(prdef)^.nextoverloaded; end; end; {$endif UseBrowser} {$ifdef GDB} function tprocsym.stabstring : pchar; Var RetType : Char; Obj,Info : String; stabsstr : string; p : pchar; 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; stabsstr:=definition^.mangledname; getmem(p,length(stabsstr)+255); strpcopy(p,'"'+obj+':'+RetType +definition^.retdef^.numberstring+info+'",'+tostr(n_function) +',0,'+ tostr(aktfilepos.line) +','); strpcopy(strend(p),stabsstr); stabstring:=strnew(p); freemem(p,length(stabsstr)+255); 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 inherited init(n); typ:=programsym; end; {**************************************************************************** TERRORSYM ****************************************************************************} constructor terrorsym.init; begin inherited 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; storedsym:=nil; storeddef:=nil; index:=0; default:=0; end; destructor tpropertysym.done; begin inherited done; end; constructor tpropertysym.load; begin inherited load; typ:=propertysym; proptype:=readdefref; options:=readlong; index:=readlong; default:=readlong; { it's hack ... } readaccesssym:=psym(stringdup(readstring)); writeaccesssym:=psym(stringdup(readstring)); storedsym:=psym(stringdup(readstring)); { now the defs: } readaccessdef:=readdefref; writeaccessdef:=readdefref; storeddef:=readdefref; end; procedure tpropertysym.deref; begin resolvedef(proptype); resolvedef(readaccessdef); resolvedef(writeaccessdef); resolvedef(storeddef); { 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; if pstring(storedsym)^<>'' then begin srsym:=search_class_member(pobjectdef(owner^.defowner),pstring(storedsym)^); if not(assigned(srsym)) then srsym:=generrorsym; end else srsym:=nil; stringdispose(pstring(storedsym)); storedsym:=srsym; end; function tpropertysym.getsize : longint; begin getsize:=0; end; procedure tpropertysym.write; begin tsym.write; writedefref(proptype); writelong(options); writelong(index); writelong(default); if assigned(readaccesssym) then writestring(readaccesssym^.name) else writestring(''); if assigned(writeaccesssym) then writestring(writeaccesssym^.name) else writestring(''); if assigned(storedsym) then writestring(storedsym^.name) else writestring(''); writedefref(readaccessdef); writedefref(writeaccessdef); writedefref(storeddef); current_ppu^.writeentry(ibpropertysym); 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 ****************************************************************************} constructor tfuncretsym.init(const n : string;approcinfo : pointer{pprocinfo}); begin tsym.init(n); typ:=funcretsym; funcretprocinfo:=approcinfo; funcretdef:=pprocinfo(approcinfo)^.retdef; { address valid for ret in param only } { otherwise set by insert } address:=pprocinfo(approcinfo)^.retoffset; end; {$ifdef GDB} procedure tfuncretsym.concatstabto(asmlist : paasmoutput); begin { Nothing to do here, it is done in genexitcode } end; {$endif GDB} {**************************************************************************** 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 tsym.write; writebyte(byte(varspez)); if read_member then writelong(address); writedefref(definition); writebyte(var_options and (not vo_regable)); writebyte(byte(abstyp)); case abstyp of tovar : writestring(ref^.name); toasm : writestring(asmname^); toaddr : writelong(address); end; current_ppu^.writeentry(ibabsolutesym); 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; _mangledname:=nil; varspez:=vs_value; address:=0; {$ifdef VALUEPARA} localaddress:=-1; islocalcopy:=false; {$endif} refs:=0; is_valid := 1; var_options:=0; { can we load the value into a register ? } case p^.deftype of pointerdef, enumdef, procvardef : var_options:=var_options or vo_regable; orddef : case porddef(p)^.typ of u8bit,u16bit,u32bit, bool8bit,bool16bit,bool32bit, s8bit,s16bit,s32bit : var_options:=var_options or vo_regable; else var_options:=var_options and not vo_regable; end; else var_options:=var_options and not vo_regable; end; reg:=R_NO; end; constructor tvarsym.init_dll(const n : string;p : pdef); begin { The tvarsym is necessary for 0.99.5 (PFV) } tvarsym.init(n,p); var_options:=var_options or vo_is_dll_var; end; constructor tvarsym.init_C(const n,mangled : string;p : pdef); begin { The tvarsym is necessary for 0.99.5 (PFV) } tvarsym.init(n,p); var_options:=var_options or vo_is_C_var; setmangledname(mangled); end; constructor tvarsym.load; begin tsym.load; typ:=varsym; _mangledname:=nil; reg:=R_NO; refs := 0; is_valid := 1; varspez:=tvarspez(readbyte); if read_member then address:=readlong else address:=0; {$ifdef VALUEPARA} localaddress:=-1; islocalcopy:=false; {$endif} definition:=readdefref; var_options:=readbyte; if (var_options and vo_is_C_var)<>0 then setmangledname(readstring); end; procedure tvarsym.deref; begin resolvedef(definition); end; procedure tvarsym.write; begin tsym.write; writebyte(byte(varspez)); if read_member then writelong(address); writedefref(definition); { symbols which are load are never candidates for a register, turn of the regable } writebyte(var_options and (not vo_regable)); if (var_options and vo_is_C_var)<>0 then writestring(mangledname); current_ppu^.writeentry(ibvarsym); end; procedure tvarsym.setmangledname(const s : string); begin _mangledname:=strpnew(s); end; function tvarsym.mangledname : string; var prefix : string; begin if assigned(_mangledname) then begin mangledname:=strpas(_mangledname); exit; end; case owner^.symtabletype of staticsymtable : if (cs_smartlink in aktmoduleswitches) then prefix:='_'+owner^.name^+'$$$_' else prefix:='_'; unitsymtable, globalsymtable : prefix:='U_'+owner^.name^+'_'; else Message(sym_e_invalid_call_tvarsymmangledname); end; mangledname:=prefix+name; end; {$ifndef VALUEPARA} 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 : begin if is_open_array(definition) then getsize:=target_os.size_of_pointer+target_os.size_of_longint else getsize:=definition^.size; end; vs_var : begin { open arrays push also the high valye } if is_open_array(definition) or is_open_string(definition) then getsize:=target_os.size_of_pointer+target_os.size_of_longint else getsize:=target_os.size_of_pointer; end; vs_const : begin case definition^.deftype of stringdef, recorddef, objectdef, setdef : getsize:=target_os.size_of_pointer; arraydef : begin { open arrays push also the high valye } if is_open_array(definition) then getsize:=target_os.size_of_pointer+target_os.size_of_longint else getsize:=target_os.size_of_pointer; end; else getsize:=definition^.size; end; end; end; end else getsize:=0; end; {$else} function tvarsym.getsize : longint; begin if assigned(definition) and (varspez=vs_value) then getsize:=definition^.size else getsize:=0; end; function tvarsym.getpushsize : longint; begin if assigned(definition) then begin case varspez of vs_var : begin { open arrays push also the high valye } if is_open_array(definition) or is_open_string(definition) then getpushsize:=target_os.size_of_pointer+target_os.size_of_longint else getpushsize:=target_os.size_of_pointer; end; vs_value, vs_const : begin case definition^.deftype of setdef, stringdef, recorddef, objectdef : getpushsize:=target_os.size_of_pointer; arraydef : if is_open_array(definition) then getpushsize:=target_os.size_of_pointer+target_os.size_of_longint else getpushsize:=target_os.size_of_pointer; else getpushsize:=definition^.size; end; end; end; end else getpushsize:=0; end; {$endif} procedure tvarsym.insert_in_data; var l,modulo : longint; begin if (var_options and vo_is_external)<>0 then exit; { 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 } var_options:=var_options and not vo_regable; 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 oo_is_abstract)<>0) then Message(sym_e_no_instance_of_abstract_object); } l:=getsize; case owner^.symtabletype of stt_exceptsymtable: { can contain only one symbol, address calculated later } ; localsymtable : 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; staticsymtable : begin if (cs_smartlink in aktmoduleswitches) then bsssegment^.concat(new(pai_cut,init)); {$ifdef GDB} if cs_debuginfo in aktmoduleswitches then concatstabto(bsssegment); {$endif GDB} if (cs_smartlink in aktmoduleswitches) or ((var_options and vo_is_c_var)<>0) then bsssegment^.concat(new(pai_datablock,init_global(mangledname,l))) else bsssegment^.concat(new(pai_datablock,init(mangledname,l))); { increase datasize } inc(owner^.datasize,l); { this symbol can't be loaded to a register } var_options:=var_options and not vo_regable; end; globalsymtable : begin if (cs_smartlink in aktmoduleswitches) then bsssegment^.concat(new(pai_cut,init)); {$ifdef GDB} if cs_debuginfo in aktmoduleswitches then concatstabto(bsssegment); {$endif GDB} bsssegment^.concat(new(pai_datablock,init_global(mangledname,l))); inc(owner^.datasize,l); { this symbol can't be loaded to a register } var_options:=var_options and not vo_regable; end; recordsymtable, objectsymtable : begin { this symbol can't be loaded to a register } var_options:=var_options and not vo_regable; { align record and object fields } if (l=1) or (aktpackrecords=1) then begin address:=owner^.datasize; inc(owner^.datasize,l) end else if (l=2) or (aktpackrecords=2) then begin owner^.datasize:=(owner^.datasize+1) and (not 1); address:=owner^.datasize; inc(owner^.datasize,l) end else if (l<=4) or (aktpackrecords=4) then begin owner^.datasize:=(owner^.datasize+3) and (not 3); address:=owner^.datasize; inc(owner^.datasize,l); end else if (l<=8) or (aktpackrecords=8) then begin owner^.datasize:=(owner^.datasize+7) and (not 7); address:=owner^.datasize; inc(owner^.datasize,l); end else if (l<=16) or (aktpackrecords=16) then begin owner^.datasize:=(owner^.datasize+15) and (not 15); address:=owner^.datasize; inc(owner^.datasize,l); end else if (l<=32) or (aktpackrecords=32) then begin owner^.datasize:=(owner^.datasize+31) and (not 31); address:=owner^.datasize; inc(owner^.datasize,l); end; end; parasymtable : begin {$ifdef VALUEPARA} { here we need the size of a push instead of the size of the data } l:=getpushsize; {$endif} address:=owner^.datasize; owner^.datasize:=align(owner^.datasize+l,target_os.stackalignment); 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 inc(owner^.datasize); address:=owner^.datasize; inc(owner^.datasize,l); end; 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 (cs_gdb_gsym in aktglobalswitches) then st := 'G' else st := 'S'; stabstring := strpnew('"'+owner^.name^+'__'+name+':'+ +definition^.numberstring+'",'+ tostr(N_LCSYM)+',0,'+tostr(fileinfo.line)+','+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 (cs_gdb_gsym in aktglobalswitches) then st := 'G' else st := 'S'; stabstring := strpnew('"'+name+':'+st +definition^.numberstring+'",'+ tostr(N_LCSYM)+',0,'+tostr(fileinfo.line)+','+mangledname); end else if owner^.symtabletype = staticsymtable then begin stabstring := strpnew('"'+name+':S' +definition^.numberstring+'",'+ tostr(N_LCSYM)+',0,'+tostr(fileinfo.line)+','+mangledname); end else if (owner^.symtabletype=parasymtable) then begin case varspez of vs_value : st := 'p'; vs_var : st := 'v'; {$ifdef VALUEPARA} vs_const : if push_addr_param(definition) then {$else} vs_const : if dont_copy_const_param(definition) then {$endif} 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(fileinfo.line)+','+ 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(fileinfo.line)+','+tostr(GDB_i386index[reg])); end else {$endif i386} stabstring := strpnew('"'+name+':' +definition^.numberstring+'",'+ tostr(N_LSYM)+',0,'+tostr(fileinfo.line)+',-'+tostr(address)) else stabstring := inherited stabstring; end; procedure tvarsym.concatstabto(asmlist : paasmoutput); {$ifdef i386} var stab_str : pchar; {$endif i386} 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(fileinfo.line)+','+tostr(GDB_i386index[reg])); asmlist^.concat(new(pai_stabs,init(stab_str))); end; {$endif i386} end; {$endif GDB} destructor tvarsym.done; begin strdispose(_mangledname); inherited done; end; {**************************************************************************** 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; function ttypedconstsym.getsize : longint; begin if assigned(definition) then getsize:=definition^.size else getsize:=0; end; procedure ttypedconstsym.deref; begin resolvedef(definition); end; procedure ttypedconstsym.write; begin tsym.write; writedefref(definition); writestring(prefix^); current_ppu^.writeentry(ibtypedconstsym); 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 } { solved, the ansis string is moved to consts (FK) } really_insert_in_data; end; procedure ttypedconstsym.really_insert_in_data; begin if owner^.symtabletype=globalsymtable then begin if (cs_smartlink in aktmoduleswitches) then datasegment^.concat(new(pai_cut,init)); {$ifdef GDB} if cs_debuginfo in aktmoduleswitches then concatstabto(datasegment); {$endif GDB} datasegment^.concat(new(pai_symbol,init_global(mangledname))); end else if owner^.symtabletype<>unitsymtable then begin if (cs_smartlink in aktmoduleswitches) then datasegment^.concat(new(pai_cut,init)); {$ifdef GDB} if cs_debuginfo in aktmoduleswitches then concatstabto(datasegment); {$endif GDB} if (cs_smartlink in aktmoduleswitches) 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 (cs_gdb_gsym in aktglobalswitches) and (owner^.symtabletype in [unitsymtable,globalsymtable]) then st := 'G' else st := 'S'; stabstring := strpnew('"'+name+':'+st+ definition^.numberstring+'",'+tostr(n_STSYM)+',0,'+ tostr(fileinfo.line)+','+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 : pbestreal; ps : pnormalset; 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^:=readreal; value:=longint(pd); end; constset : begin definition:=readdefref; new(ps); readnormalset(ps^); value:=longint(ps); end; else Message1(unit_f_ppu_invalid_entry,tostr(ord(consttype))); end; end; destructor tconstsym.done; begin case consttype of conststring : stringdispose(pstring(value)); constreal : dispose(pbestreal(value)); constset : dispose(pnormalset(value)); end; inherited done; end; function tconstsym.mangledname : string; begin mangledname:=name; end; procedure tconstsym.deref; begin if consttype in [constord,constset] then resolvedef(pdef(definition)); end; procedure tconstsym.write; begin 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 : writereal(pbestreal(value)^); constset : begin writedefref(definition); writenormalset(pointer(value)^); end; else internalerror(13); end; current_ppu^.writeentry(ibconstsym); 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(pbestreal(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(fileinfo.line)+',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; if def^.min>v then def^.setmin(v); if def^.max never use p^.loc.location:=p^.left^.loc.location; + finally I added now by default that ra386dir translates global and unit symbols + added a first field in tsymtable and a nextsym field in tsym (this allows to obtain ordered type info for records and objects in gdb !) Revision 1.54 1998/10/19 08:55:07 pierre * wrong stabs info corrected once again !! + variable vmt offset with vmt field only if required implemented now !!! Revision 1.53 1998/10/16 08:51:53 peter + target_os.stackalignment + stack can be aligned at 2 or 4 byte boundaries Revision 1.52 1998/10/08 17:17:32 pierre * current_module old scanner tagged as invalid if unit is recompiled + added ppheap for better info on tracegetmem of heaptrc (adds line column and file index) * several memory leaks removed ith help of heaptrc !! Revision 1.51 1998/10/08 13:48:50 peter * fixed memory leaks for do nothing source * fixed unit interdependency Revision 1.50 1998/10/06 17:16:56 pierre * some memory leaks fixed (thanks to Peter for heaptrc !) Revision 1.49 1998/10/01 09:22:55 peter * fixed value openarray * ungettemp of arrayconstruct Revision 1.48 1998/09/26 17:45:44 peter + idtoken and only one token table Revision 1.47 1998/09/24 15:11:17 peter * fixed enum for not GDB Revision 1.46 1998/09/23 15:39:13 pierre * browser bugfixes was adding a reference when looking for the symbol if -bSYM_NAME was used Revision 1.45 1998/09/21 08:45:24 pierre + added vmt_offset in tobjectdef.write for fututre use (first steps to have objects without vmt if no virtual !!) + added fpu_used field for tabstractprocdef : sets this level to 2 if the functions return with value in FPU (is then set to correct value at parsing of implementation) THIS MIGHT refuse some code with FPU expression too complex that were accepted before and even in some cases that don't overflow in fact ( like if f : float; is a forward that finally in implementation only uses one fpu register !!) Nevertheless I think that it will improve security on FPU operations !! * most other changes only for UseBrowser code (added symtable references for record and objects) local switch for refs to args and local of each function (static symtable still missing) UseBrowser still not stable and probably broken by the definition hash array !! Revision 1.44 1998/09/18 16:03:47 florian * some changes to compile with Delphi Revision 1.43 1998/09/18 08:01:38 pierre + improvement on the usebrowser part (does not work correctly for now) Revision 1.42 1998/09/07 19:33:25 florian + some stuff for property rtti added: - NameIndex of the TPropInfo record is now written correctly - the DEFAULT/NODEFAULT keyword is supported now - the default value and the storedsym/def are now written to the PPU fiel Revision 1.41 1998/09/07 18:46:12 peter * update smartlinking, uses getdatalabel * renamed ptree.value vars to value_str,value_real,value_set Revision 1.40 1998/09/07 17:37:04 florian * first fixes for published properties Revision 1.39 1998/09/05 22:11:02 florian + switch -vb * while/repeat loops accept now also word/longbool conditions * makebooltojump did an invalid ungetregister32, fixed Revision 1.38 1998/09/01 12:53:26 peter + aktpackenum Revision 1.37 1998/09/01 07:54:25 pierre * UseBrowser a little updated (might still be buggy !!) * bug in psub.pas in function specifier removed * stdcall allowed in interface and in implementation (FPC will not yet complain if it is missing in either part because stdcall is only a dummy !!) Revision 1.36 1998/08/25 13:09:26 pierre * corrected mangling sheme : cvar add Cprefix to the mixed case name whereas export or public use direct name Revision 1.35 1998/08/25 12:42:46 pierre * CDECL changed to CVAR for variables specifications are read in structures also + started adding GPC compatibility mode ( option -Sp) * names changed to lowercase Revision 1.34 1998/08/21 14:08:53 pierre + TEST_FUNCRET now default (old code removed) works also for m68k (at least compiles) Revision 1.33 1998/08/20 12:53:27 peter * object_options are always written for object syms Revision 1.32 1998/08/20 09:26:46 pierre + funcret setting in underproc testing compile with _dTEST_FUNCRET Revision 1.31 1998/08/17 10:10:12 peter - removed OLDPPU Revision 1.30 1998/08/13 10:57:29 peter * constant sets are now written correctly to the ppufile Revision 1.29 1998/08/11 15:31:42 peter * write extended to ppu file * new version 0.99.7 Revision 1.28 1998/08/11 14:07:27 peter * fixed pushing of high value for openarray Revision 1.27 1998/08/10 14:50:31 peter + localswitches, moduleswitches, globalswitches splitting Revision 1.26 1998/08/10 10:18:35 peter + Compiler,Comphook unit which are the new interface units to the compiler Revision 1.25 1998/07/30 11:18:19 florian + first implementation of try ... except on .. do end; * limitiation of 65535 bytes parameters for cdecl removed Revision 1.24 1998/07/20 18:40:16 florian * handling of ansi string constants should now work Revision 1.23 1998/07/14 21:37:24 peter * fixed packrecords as discussed at the alias Revision 1.22 1998/07/14 14:47:08 peter * released NEWINPUT Revision 1.21 1998/07/13 21:17:38 florian * changed to compile with TP Revision 1.20 1998/07/10 00:00:05 peter * fixed ttypesym bug finally * fileinfo in the symtable and better using for unused vars Revision 1.19 1998/07/07 17:40:39 peter * packrecords 4 works * word aligning of parameters Revision 1.18 1998/07/07 11:20:15 peter + NEWINPUT for a better inputfile and scanner object Revision 1.17 1998/06/24 14:48:40 peter * ifdef newppu -> ifndef oldppu Revision 1.16 1998/06/19 15:40:42 peter * removed cosntructor/constructor warning and 0.99.5 recompiles it again Revision 1.15 1998/06/17 14:10:18 peter * small os2 fixes * fixed interdependent units with newppu (remake3 under linux works now) Revision 1.14 1998/06/16 08:56:34 peter + targetcpu * cleaner pmodules for newppu Revision 1.13 1998/06/15 15:38:10 pierre * small bug in systems.pas corrected + operators in different units better hanlded Revision 1.12 1998/06/15 14:23:44 daniel * Reverted my changes. Revision 1.10 1998/06/13 00:10:18 peter * working browser and newppu * some small fixes against crashes which occured in bp7 (but not in fpc?!) Revision 1.9 1998/06/12 16:15:35 pierre * external name 'C_var'; export name 'intern_C_var'; cdecl; cdecl;external; are now supported only with -Sv switch Revision 1.8 1998/06/11 10:11:59 peter * -gb works again Revision 1.7 1998/06/09 16:01:51 pierre + added procedure directive parsing for procvars (accepted are popstack cdecl and pascal) + added C vars with the following syntax var C calias 'true_c_name';(can be followed by external) reason is that you must add the Cprefix which is target dependent Revision 1.6 1998/06/08 22:59:53 peter * smartlinking works for win32 * some defines to exclude some compiler parts Revision 1.5 1998/06/04 23:52:02 peter * m68k compiles + .def file creation moved to gendef.pas so it could also be used for win32 Revision 1.4 1998/06/04 09:55:46 pierre * demangled name of procsym reworked to become independant of the mangling scheme Revision 1.3 1998/06/03 22:14:20 florian * problem with sizes of classes fixed (if the anchestor was declared forward, the compiler doesn't update the child classes size) Revision 1.2 1998/05/28 14:40:29 peter * fixes for newppu, remake3 works now with it Revision 1.1 1998/05/27 19:45:09 peter * symtable.pas splitted into includefiles * symtable adapted for $ifndef OLDPPU }