mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-10-31 04:31:35 +01:00
564 lines
16 KiB
ObjectPascal
564 lines
16 KiB
ObjectPascal
{
|
|
$Id$
|
|
Copyright (c) 1993-98 by the FPC development team
|
|
|
|
Support routines for the browser
|
|
|
|
This program is free software; you can redistribute it and/or modify
|
|
it under the terms of the GNU General Public License as published by
|
|
the Free Software Foundation; either version 2 of the License, or
|
|
(at your option) any later version.
|
|
|
|
This program is distributed in the hope that it will be useful,
|
|
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
GNU General Public License for more details.
|
|
|
|
You should have received a copy of the GNU General Public License
|
|
along with this program; if not, write to the Free Software
|
|
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|
|
|
|
****************************************************************************
|
|
}
|
|
{$ifdef TP}
|
|
{$N+,E+}
|
|
{$endif}
|
|
unit browser;
|
|
|
|
interface
|
|
uses
|
|
cobjects,files;
|
|
|
|
const
|
|
{$ifdef TP}
|
|
logbufsize = 1024;
|
|
{$else}
|
|
logbufsize = 16384;
|
|
{$endif}
|
|
type
|
|
pref = ^tref;
|
|
tref = object
|
|
nextref : pref;
|
|
posinfo : tfileposinfo;
|
|
moduleindex : word;
|
|
is_written : boolean;
|
|
constructor init(ref:pref;pos:pfileposinfo);
|
|
destructor done; virtual;
|
|
function get_file_line : string;
|
|
end;
|
|
|
|
pbrowser=^tbrowser;
|
|
tbrowser=object
|
|
fname : string;
|
|
logopen : boolean;
|
|
stderrlog : boolean;
|
|
f : file;
|
|
elements_to_list : pstringqueue;
|
|
buf : pchar;
|
|
bufidx : longint;
|
|
identidx : longint;
|
|
constructor init;
|
|
destructor done;
|
|
procedure setfilename(const fn:string);
|
|
procedure createlog;
|
|
procedure flushlog;
|
|
procedure addlog(const s:string);
|
|
procedure addlogrefs(p:pref);
|
|
procedure closelog;
|
|
procedure ident;
|
|
procedure unident;
|
|
procedure browse_symbol(const sr : string);
|
|
procedure list_elements;
|
|
procedure list_debug_infos;
|
|
end;
|
|
|
|
var
|
|
browse : tbrowser;
|
|
|
|
procedure InitBrowser;
|
|
procedure DoneBrowser;
|
|
function get_source_file(moduleindex,fileindex : word) : pinputfile;
|
|
|
|
implementation
|
|
|
|
uses
|
|
comphook,globals,symtable,systems,verbose;
|
|
|
|
{****************************************************************************
|
|
TRef
|
|
****************************************************************************}
|
|
|
|
|
|
constructor tref.init(ref :pref;pos : pfileposinfo);
|
|
begin
|
|
nextref:=nil;
|
|
if assigned(pos) then
|
|
posinfo:=pos^;
|
|
if assigned(current_module) then
|
|
moduleindex:=current_module^.unit_index;
|
|
if assigned(ref) then
|
|
ref^.nextref:=@self;
|
|
is_written:=false;
|
|
end;
|
|
|
|
|
|
destructor tref.done;
|
|
var
|
|
inputfile : pinputfile;
|
|
begin
|
|
inputfile:=get_source_file(moduleindex,posinfo.fileindex);
|
|
if inputfile<>nil then
|
|
dec(inputfile^.ref_count);
|
|
if assigned(nextref) then
|
|
dispose(nextref,done);
|
|
nextref:=nil;
|
|
end;
|
|
|
|
|
|
function tref.get_file_line : string;
|
|
var
|
|
inputfile : pinputfile;
|
|
begin
|
|
get_file_line:='';
|
|
inputfile:=get_source_file(moduleindex,posinfo.fileindex);
|
|
if assigned(inputfile) then
|
|
if status.use_gccoutput then
|
|
{ for use with rhide
|
|
add warning so that it does not interpret
|
|
this as an error !! }
|
|
get_file_line:=lower(inputfile^.name^)
|
|
+':'+tostr(posinfo.line)+': warning: '+tostr(posinfo.column)+':'
|
|
else
|
|
get_file_line:=inputfile^.name^
|
|
+'('+tostr(posinfo.line)+','+tostr(posinfo.column)+')'
|
|
else
|
|
if status.use_gccoutput then
|
|
get_file_line:='file_unknown:'
|
|
+tostr(posinfo.line)+': warning: '+tostr(posinfo.column)+':'
|
|
else
|
|
get_file_line:='file_unknown('
|
|
+tostr(posinfo.line)+','+tostr(posinfo.column)+')'
|
|
end;
|
|
|
|
{****************************************************************************
|
|
TBrowser
|
|
****************************************************************************}
|
|
|
|
constructor tbrowser.init;
|
|
begin
|
|
fname:=FixFileName('browser.log');
|
|
logopen:=false;
|
|
elements_to_list:=new(pstringqueue,init);
|
|
end;
|
|
|
|
|
|
destructor tbrowser.done;
|
|
begin
|
|
if logopen then
|
|
closelog;
|
|
dispose(elements_to_list,done);
|
|
end;
|
|
|
|
|
|
procedure tbrowser.setfilename(const fn:string);
|
|
begin
|
|
fname:=FixFileName(fn);
|
|
end;
|
|
|
|
|
|
procedure tbrowser.createlog;
|
|
begin
|
|
if logopen then
|
|
closelog;
|
|
assign(f,fname);
|
|
{$I-}
|
|
rewrite(f,1);
|
|
{$I+}
|
|
if ioresult<>0 then
|
|
exit;
|
|
logopen:=true;
|
|
getmem(buf,logbufsize);
|
|
bufidx:=0;
|
|
identidx:=0;
|
|
end;
|
|
|
|
|
|
procedure tbrowser.flushlog;
|
|
begin
|
|
if logopen then
|
|
if not stderrlog then
|
|
blockwrite(f,buf^,bufidx)
|
|
else
|
|
begin
|
|
buf[bufidx]:=#0;
|
|
{$ifndef TP}
|
|
write(stderr,buf);
|
|
{$else TP}
|
|
write(buf);
|
|
{$endif TP}
|
|
end;
|
|
bufidx:=0;
|
|
end;
|
|
|
|
|
|
procedure tbrowser.closelog;
|
|
begin
|
|
if logopen then
|
|
begin
|
|
flushlog;
|
|
close(f);
|
|
freemem(buf,logbufsize);
|
|
logopen:=false;
|
|
end;
|
|
end;
|
|
|
|
procedure tbrowser.list_elements;
|
|
|
|
begin
|
|
|
|
stderrlog:=true;
|
|
getmem(buf,logbufsize);
|
|
logopen:=true;
|
|
while not elements_to_list^.empty do
|
|
browse_symbol(elements_to_list^.get);
|
|
flushlog;
|
|
logopen:=false;
|
|
freemem(buf,logbufsize);
|
|
stderrlog:=false;
|
|
end;
|
|
|
|
procedure tbrowser.list_debug_infos;
|
|
{$ifndef debug}
|
|
begin
|
|
end;
|
|
{$else debug}
|
|
var
|
|
hp : pmodule;
|
|
ff : pinputfile;
|
|
begin
|
|
hp:=pmodule(loaded_units.first);
|
|
while assigned(hp) do
|
|
begin
|
|
addlog('Unit '+hp^.modulename^+' has index '+tostr(hp^.unit_index));
|
|
ff:=hp^.sourcefiles^.files;
|
|
while assigned(ff) do
|
|
begin
|
|
addlog('File '+ff^.name^+' index '+tostr(ff^.ref_index));
|
|
ff:=ff^.ref_next;
|
|
end;
|
|
hp:=pmodule(hp^.next);
|
|
end;
|
|
end;
|
|
{$endif debug}
|
|
|
|
procedure tbrowser.addlog(const s:string);
|
|
begin
|
|
if not logopen then
|
|
exit;
|
|
{ add ident }
|
|
if (identidx>0) and not stderrlog then
|
|
begin
|
|
if bufidx+identidx>logbufsize then
|
|
flushlog;
|
|
fillchar(buf[bufidx],identidx,' ');
|
|
inc(bufidx,identidx);
|
|
end;
|
|
{ add text }
|
|
if bufidx+length(s)>logbufsize-2 then
|
|
flushlog;
|
|
move(s[1],buf[bufidx],length(s));
|
|
inc(bufidx,length(s));
|
|
{ add crlf }
|
|
buf[bufidx]:=target_os.newline[1];
|
|
inc(bufidx);
|
|
if length(target_os.newline)=2 then
|
|
begin
|
|
buf[bufidx]:=target_os.newline[2];
|
|
inc(bufidx);
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure tbrowser.addlogrefs(p:pref);
|
|
var
|
|
ref : pref;
|
|
begin
|
|
ref:=p;
|
|
Ident;
|
|
while assigned(ref) do
|
|
begin
|
|
Browse.AddLog(ref^.get_file_line);
|
|
ref:=ref^.nextref;
|
|
end;
|
|
Unident;
|
|
end;
|
|
|
|
|
|
procedure tbrowser.browse_symbol(const sr : string);
|
|
var
|
|
sym,symb : psym;
|
|
symt : psymtable;
|
|
hp : pmodule;
|
|
s,ss : string;
|
|
p : byte;
|
|
|
|
procedure next_substring;
|
|
begin
|
|
p:=pos('.',s);
|
|
if p>0 then
|
|
begin
|
|
ss:=copy(s,1,p-1);
|
|
s:=copy(s,p+1,255);
|
|
end
|
|
else
|
|
begin
|
|
ss:=s;
|
|
s:='';
|
|
end;
|
|
addlog('substring : '+ss);
|
|
end;
|
|
begin
|
|
{ don't create a new reference when
|
|
looking for the symbol !! }
|
|
make_ref:=false;
|
|
s:=sr;
|
|
symt:=symtablestack;
|
|
next_substring;
|
|
if assigned(symt) then
|
|
begin
|
|
sym:=symt^.search(ss);
|
|
if sym=nil then
|
|
sym:=symt^.search(upper(ss));
|
|
end
|
|
else
|
|
sym:=nil;
|
|
if assigned(sym) and (sym^.typ=unitsym) and (s<>'') then
|
|
begin
|
|
addlog('Unitsym found !');
|
|
symt:=punitsym(sym)^.unitsymtable;
|
|
if assigned(symt) then
|
|
begin
|
|
next_substring;
|
|
sym:=symt^.search(ss);
|
|
end
|
|
else
|
|
sym:=nil;
|
|
end;
|
|
if not assigned(sym) then
|
|
begin
|
|
symt:=nil;
|
|
{ try all loaded_units }
|
|
hp:=pmodule(loaded_units.first);
|
|
while assigned(hp) do
|
|
begin
|
|
if hp^.modulename^=upper(ss) then
|
|
begin
|
|
symt:=hp^.globalsymtable;
|
|
break;
|
|
end;
|
|
hp:=pmodule(hp^.next);
|
|
end;
|
|
if not assigned(symt) then
|
|
begin
|
|
addlog('!!!Symbol '+ss+' not found !!!');
|
|
make_ref:=true;
|
|
exit;
|
|
end
|
|
else
|
|
begin
|
|
next_substring;
|
|
sym:=symt^.search(ss);
|
|
if sym=nil then
|
|
sym:=symt^.search(upper(ss));
|
|
end;
|
|
end;
|
|
|
|
while assigned(sym) and (s<>'') do
|
|
begin
|
|
next_substring;
|
|
case sym^.typ of
|
|
typesym :
|
|
begin
|
|
if ptypesym(sym)^.definition^.deftype in [recorddef,objectdef] then
|
|
begin
|
|
if ptypesym(sym)^.definition^.deftype=recorddef then
|
|
symt:=precdef(ptypesym(sym)^.definition)^.symtable
|
|
else
|
|
symt:=pobjectdef(ptypesym(sym)^.definition)^.publicsyms;
|
|
sym:=symt^.search(ss);
|
|
if sym=nil then
|
|
sym:=symt^.search(upper(ss));
|
|
end;
|
|
end;
|
|
varsym :
|
|
begin
|
|
if pvarsym(sym)^.definition^.deftype in [recorddef,objectdef] then
|
|
begin
|
|
if pvarsym(sym)^.definition^.deftype=recorddef then
|
|
symt:=precdef(pvarsym(sym)^.definition)^.symtable
|
|
else
|
|
symt:=pobjectdef(pvarsym(sym)^.definition)^.publicsyms;
|
|
sym:=symt^.search(ss);
|
|
if sym=nil then
|
|
sym:=symt^.search(upper(ss));
|
|
end;
|
|
end;
|
|
procsym :
|
|
begin
|
|
symt:=pprocsym(sym)^.definition^.parast;
|
|
symb:=symt^.search(ss);
|
|
if symb=nil then
|
|
symb:=symt^.search(upper(ss));
|
|
if not assigned(symb) then
|
|
begin
|
|
symt:=pprocsym(sym)^.definition^.parast;
|
|
sym:=symt^.search(ss);
|
|
if symb=nil then
|
|
symb:=symt^.search(upper(ss));
|
|
end
|
|
else
|
|
sym:=symb;
|
|
end;
|
|
{else
|
|
sym^.add_to_browserlog;}
|
|
end;
|
|
end;
|
|
if assigned(sym) then
|
|
sym^.add_to_browserlog
|
|
else
|
|
addlog('!!!Symbol '+ss+' not found !!!');
|
|
make_ref:=true;
|
|
end;
|
|
|
|
procedure tbrowser.ident;
|
|
begin
|
|
inc(identidx,2);
|
|
end;
|
|
|
|
|
|
procedure tbrowser.unident;
|
|
begin
|
|
dec(identidx,2);
|
|
end;
|
|
|
|
{****************************************************************************
|
|
Helpers
|
|
****************************************************************************}
|
|
|
|
|
|
function get_source_file(moduleindex,fileindex : word) : pinputfile;
|
|
|
|
var
|
|
hp : pmodule;
|
|
f : pinputfile;
|
|
|
|
begin
|
|
hp:=pmodule(loaded_units.first);
|
|
while assigned(hp) and (hp^.unit_index<>moduleindex) do
|
|
hp:=pmodule(hp^.next);
|
|
get_source_file:=nil;
|
|
if not assigned(hp) then
|
|
exit;
|
|
f:=pinputfile(hp^.sourcefiles^.files);
|
|
while assigned(f) do
|
|
begin
|
|
if f^.ref_index=fileindex then
|
|
begin
|
|
get_source_file:=f;
|
|
exit;
|
|
end;
|
|
f:=pinputfile(f^.ref_next);
|
|
end;
|
|
end;
|
|
|
|
procedure InitBrowser;
|
|
begin
|
|
browse.init;
|
|
end;
|
|
|
|
procedure DoneBrowser;
|
|
begin
|
|
browse.done;
|
|
end;
|
|
|
|
end.
|
|
{
|
|
$Log$
|
|
Revision 1.12 1998-10-09 16:36:01 pierre
|
|
* some memory leaks specific to usebrowser define fixed
|
|
* removed tmodule.implsymtable (was like tmodule.localsymtable)
|
|
|
|
Revision 1.11 1998/10/08 17:17:09 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.10 1998/09/28 16:57:12 pierre
|
|
* changed all length(p^.value_str^) into str_length(p)
|
|
to get it work with and without ansistrings
|
|
* changed sourcefiles field of tmodule to a pointer
|
|
|
|
Revision 1.9 1998/09/23 15:38:59 pierre
|
|
* browser bugfixes
|
|
was adding a reference when looking for the symbol
|
|
if -bSYM_NAME was used
|
|
|
|
Revision 1.8 1998/09/22 17:13:42 pierre
|
|
+ browsing updated and developed
|
|
records and objects fields are also stored
|
|
|
|
Revision 1.7 1998/09/21 08:45:05 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.6 1998/09/01 07:54:16 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.5 1998/06/13 00:10:04 peter
|
|
* working browser and newppu
|
|
* some small fixes against crashes which occured in bp7 (but not in
|
|
fpc?!)
|
|
|
|
Revision 1.4 1998/06/11 10:11:57 peter
|
|
* -gb works again
|
|
|
|
Revision 1.3 1998/05/20 09:42:32 pierre
|
|
+ UseTokenInfo now default
|
|
* unit in interface uses and implementation uses gives error now
|
|
* only one error for unknown symbol (uses lastsymknown boolean)
|
|
the problem came from the label code !
|
|
+ first inlined procedures and function work
|
|
(warning there might be allowed cases were the result is still wrong !!)
|
|
* UseBrower updated gives a global list of all position of all used symbols
|
|
with switch -gb
|
|
|
|
Revision 1.2 1998/04/30 15:59:39 pierre
|
|
* GDB works again better :
|
|
correct type info in one pass
|
|
+ UseTokenInfo for better source position
|
|
* fixed one remaining bug in scanner for line counts
|
|
* several little fixes
|
|
}
|
|
|