paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-11-04 10:19:31 +01:00
Code Issues Packages Projects Releases Wiki Activity
49e539ac8d
fpc/compiler/verbose.pas
peter f4b818fc1d * removed funcretn,funcretsym, function result is now in varsym 
and aliases for result and function name are added using absolutesym
  * vs_hidden parameter for funcret passed in parameter
  * vs_hidden fixes
  * writenode changed to printnode and released from extdebug
  * -vp option added to generate a tree.log with the nodetree
  * nicer printnode for statements, callnode
2003-04-25 20:59:33 +00:00

757 lines
21 KiB
ObjectPascal
Raw Blame History

{
$Id$
Copyright (c) 1998-2002 by Peter Vreman
This unit handles the verbose management
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.
****************************************************************************
}
unit verbose;
{$i fpcdefs.inc}
{ Don't include messages in the executable }
{$ifdef Delphi}
{$define EXTERN_MSG}
{$endif}
interface
uses
cutils,
globals,finput,
cmsgs;
{$ifndef EXTERN_MSG}
{$i msgtxt.inc}
{$endif}
{$i msgidx.inc}
Const
{ Levels }
V_None = $0;
V_Fatal = $1;
V_Error = $2;
V_Normal = $4; { doesn't show a text like Error: }
V_Warning = $8;
V_Note = $10;
V_Hint = $20;
V_LineInfoMask = $fff;
{ From here by default no line info }
V_Info = $1000;
V_Status = $2000;
V_Used = $4000;
V_Tried = $8000;
V_Conditional = $10000;
V_Debug = $20000;
V_Executable = $40000;
V_LevelMask = $fffffff;
V_All = V_LevelMask;
V_Default = V_Fatal + V_Error + V_Normal;
{ Flags }
V_LineInfo = $10000000;
var
msg : pmessage;
const
msgfilename : string = '';
procedure SetRedirectFile(const fn:string);
function SetVerbosity(const s:string):boolean;
procedure PrepareReport;
function CheckVerbosity(v:longint):boolean;
procedure SetCompileModule(p:tmodulebase);
procedure Stop;
procedure ShowStatus;
function ErrorCount:longint;
procedure SetErrorFlags(const s:string);
procedure GenerateError;
procedure Internalerror(i:longint);
procedure Comment(l:longint;s:string);
function MessagePchar(w:longint):pchar;
procedure Message(w:longint);
procedure Message1(w:longint;const s1:string);
procedure Message2(w:longint;const s1,s2:string);
procedure Message3(w:longint;const s1,s2,s3:string);
procedure Message4(w:longint;const s1,s2,s3,s4:string);
procedure MessagePos(const pos:tfileposinfo;w:longint);
procedure MessagePos1(const pos:tfileposinfo;w:longint;const s1:string);
procedure MessagePos2(const pos:tfileposinfo;w:longint;const s1,s2:string);
procedure MessagePos3(const pos:tfileposinfo;w:longint;const s1,s2,s3:string);
procedure MessagePos4(const pos:tfileposinfo;w:longint;const s1,s2,s3,s4:string);
procedure InitVerbose;
procedure DoneVerbose;
implementation
uses
comphook;
var
compiling_module : tmodulebase;
{****************************************************************************
Extra Handlers for default compiler
****************************************************************************}
procedure DoneRedirectFile;
begin
if status.use_redir then
begin
close(status.redirfile);
status.use_redir:=false;
end;
if status.use_bugreport then
begin
close(status.reportbugfile);
status.use_bugreport:=false;
end;
end;
procedure SetRedirectFile(const fn:string);
begin
assign(status.redirfile,fn);
{$I-}
append(status.redirfile);
if ioresult <> 0 then
rewrite(status.redirfile);
{$I+}
status.use_redir:=(ioresult=0);
end;
procedure PrepareReport;
var
fn : string;
begin
if status.use_bugreport then
exit;
fn:='fpcdebug.txt';
assign(status.reportbugfile,fn);
{$I-}
append(status.reportbugfile);
if ioresult <> 0 then
rewrite(status.reportbugfile);
{$I+}
status.use_bugreport:=(ioresult=0);
if status.use_bugreport then
writeln(status.reportbugfile,'FPC bug report file');
end;
function CheckVerbosity(v:longint):boolean;
begin
CheckVerbosity:=status.use_bugreport or
((status.verbosity and (v and V_LevelMask))=(v and V_LevelMask));
end;
function SetVerbosity(const s:string):boolean;
var
m : Longint;
i : Integer;
inverse : boolean;
c : char;
begin
Setverbosity:=false;
val(s,m,i);
if (i=0) and (s<>'') then
status.verbosity:=m
else
begin
i:=1;
while i<=length(s) do
begin
c:=upcase(s[i]);
inverse:=false;
{ on/off ? }
if (i<length(s)) then
case s[i+1] of
'-' : begin
inc(i);
inverse:=true;
end;
'+' : inc(i);
end;
{ handle switch }
case c of
{ Special cases }
'A' : status.verbosity:=V_All;
'0' : status.verbosity:=V_Default;
'P' : begin
if inverse then
paraprintnodetree:=0
else
paraprintnodetree:=1;
end;
'R' : begin
if inverse then
begin
status.use_gccoutput:=false;
status.use_stderr:=false;
end
else
begin
status.use_gccoutput:=true;
status.use_stderr:=true;
end;
end;
{ Normal cases - do an or }
'E' : if inverse then
status.verbosity:=status.verbosity and (not V_Error)
else
status.verbosity:=status.verbosity or V_Error;
'I' : if inverse then
status.verbosity:=status.verbosity and (not V_Info)
else
status.verbosity:=status.verbosity or V_Info;
'W' : if inverse then
status.verbosity:=status.verbosity and (not V_Warning)
else
status.verbosity:=status.verbosity or V_Warning;
'N' : if inverse then
status.verbosity:=status.verbosity and (not V_Note)
else
status.verbosity:=status.verbosity or V_Note;
'H' : if inverse then
status.verbosity:=status.verbosity and (not V_Hint)
else
status.verbosity:=status.verbosity or V_Hint;
'L' : if inverse then
status.verbosity:=status.verbosity and (not V_Status)
else
status.verbosity:=status.verbosity or V_Status;
'U' : if inverse then
status.verbosity:=status.verbosity and (not V_Used)
else
status.verbosity:=status.verbosity or V_Used;
'T' : if inverse then
status.verbosity:=status.verbosity and (not V_Tried)
else
status.verbosity:=status.verbosity or V_Tried;
'C' : if inverse then
status.verbosity:=status.verbosity and (not V_Conditional)
else
status.verbosity:=status.verbosity or V_Conditional;
'D' : if inverse then
status.verbosity:=status.verbosity and (not V_Debug)
else
status.verbosity:=status.verbosity or V_Debug;
'X' : if inverse then
status.verbosity:=status.verbosity and (not V_Executable)
else
status.verbosity:=status.verbosity or V_Executable;
end;
inc(i);
end;
end;
if status.verbosity=0 then
status.verbosity:=V_Default;
setverbosity:=true;
end;
procedure Loadprefixes;
function loadprefix(w:longint):string;
var
s : string;
idx : longint;
begin
s:=msg^.get(w);
idx:=pos('_',s);
if idx>0 then
Loadprefix:=Copy(s,idx+1,255)
else
Loadprefix:=s;
end;
begin
{ Load the prefixes }
fatalstr:=Loadprefix(general_i_fatal);
errorstr:=Loadprefix(general_i_error);
warningstr:=Loadprefix(general_i_warning);
notestr:=Loadprefix(general_i_note);
hintstr:=Loadprefix(general_i_hint);
end;
procedure LoadMsgFile(const fn:string);
begin
{ reload the internal messages if not already loaded }
{$ifndef EXTERN_MSG}
if not msg^.msgintern then
msg^.LoadIntern(@msgtxt,msgtxtsize);
{$endif}
if not msg^.LoadExtern(fn) then
begin
{$ifdef EXTERN_MSG}
writeln('Fatal: Cannot find error message file.');
halt(3);
{$else}
msg^.LoadIntern(@msgtxt,msgtxtsize);
{$endif}
end;
{ reload the prefixes using the new messages }
Loadprefixes;
end;
procedure MaybeLoadMessageFile;
begin
{ Load new message file }
if (msgfilename<>'') then
begin
LoadMsgFile(msgfilename);
msgfilename:='';
end;
end;
procedure SetCompileModule(p:tmodulebase);
begin
compiling_module:=p;
end;
var
lastfileidx,
lastmoduleidx : longint;
Procedure UpdateStatus;
begin
{ fix status }
status.currentline:=aktfilepos.line;
status.currentcolumn:=aktfilepos.column;
if assigned(compiling_module) and
assigned(compiling_module.sourcefiles) and
((compiling_module.unit_index<>lastmoduleidx) or
(aktfilepos.fileindex<>lastfileidx)) then
begin
{ update status record }
status.currentmodule:=compiling_module.modulename^;
status.currentsource:=compiling_module.sourcefiles.get_file_name(aktfilepos.fileindex);
status.currentsourcepath:=compiling_module.sourcefiles.get_file_path(aktfilepos.fileindex);
{ update lastfileidx only if name known PM }
if status.currentsource<>'' then
lastfileidx:=aktfilepos.fileindex
else
lastfileidx:=0;
lastmoduleidx:=compiling_module.unit_index;
end;
if assigned(compiling_module) then
status.compiling_current:=(compiling_module.state in [ms_compile,ms_second_compile]);
end;
procedure stop;
begin
do_stop{$ifdef FPCPROCVAR}(){$endif};
end;
procedure ShowStatus;
begin
UpdateStatus;
if do_status{$ifdef FPCPROCVAR}(){$endif} then
stop;
end;
function ErrorCount:longint;
begin
ErrorCount:=status.errorcount;
end;
procedure SetErrorFlags(const s:string);
var
code : integer;
i,j,l : longint;
begin
{ empty string means error count = 1 for backward compatibility (PFV) }
if s='' then
begin
status.maxerrorcount:=1;
exit;
end;
i:=0;
while (i<length(s)) do
begin
inc(i);
case s[i] of
'0'..'9' :
begin
j:=i;
while (j<=length(s)) and (s[j] in ['0'..'9']) do
inc(j);
val(copy(s,i,j-i),l,code);
if code<>0 then
l:=1;
status.maxerrorcount:=l;
i:=j;
end;
'w','W' :
status.errorwarning:=true;
'n','N' :
status.errornote:=true;
'h','H' :
status.errorhint:=true;
end;
end;
end;
procedure GenerateError;
begin
inc(status.errorcount);
end;
procedure internalerror(i : longint);
begin
UpdateStatus;
do_internalerror(i);
inc(status.errorcount);
stop;
end;
procedure Comment(l:longint;s:string);
var
dostop : boolean;
begin
dostop:=((l and V_Fatal)<>0);
if ((l and V_Error)<>0) or
(status.errorwarning and ((l and V_Warning)<>0)) or
(status.errornote and ((l and V_Note)<>0)) or
(status.errorhint and ((l and V_Hint)<>0)) then
inc(status.errorcount);
{ check verbosity level }
if not CheckVerbosity(l) then
exit;
if (l and V_LineInfoMask)<>0 then
l:=l or V_LineInfo;
{ Create status info }
UpdateStatus;
{ Fix replacements }
DefaultReplacements(s);
{ show comment }
if do_comment(l,s) or dostop then
stop;
if (status.errorcount>=status.maxerrorcount) and not status.skip_error then
begin
Message1(unit_f_errors_in_unit,tostr(status.errorcount));
status.skip_error:=true;
stop;
end;
end;
Procedure Msg2Comment(s:string);
var
idx,i,v : longint;
dostop : boolean;
begin
{Reset}
dostop:=false;
v:=0;
{Parse options}
idx:=pos('_',s);
if idx=0 then
v:=V_Normal
else
if (idx >= 1) And (idx <= 5) then
begin
for i:=1 to idx do
begin
case upcase(s[i]) of
'F' :
begin
v:=v or V_Fatal;
inc(status.errorcount);
dostop:=true;
end;
'E' :
begin
v:=v or V_Error;
inc(status.errorcount);
end;
'O' :
v:=v or V_Normal;
'W':
begin
v:=v or V_Warning;
if status.errorwarning then
inc(status.errorcount);
end;
'N' :
begin
v:=v or V_Note;
if status.errornote then
inc(status.errorcount);
end;
'H' :
begin
v:=v or V_Hint;
if status.errorhint then
inc(status.errorcount);
end;
'I' :
v:=v or V_Info;
'L' :
v:=v or V_LineInfo;
'U' :
v:=v or V_Used;
'T' :
v:=v or V_Tried;
'C' :
v:=v or V_Conditional;
'D' :
v:=v or V_Debug;
'X' :
v:=v or V_Executable;
'S' :
dostop:=true;
'_' : ;
end;
end;
end;
Delete(s,1,idx);
{ check verbosity level }
if not CheckVerbosity(v) then
exit;
if (v and V_LineInfoMask)<>0 then
v:=v or V_LineInfo;
{ fix status }
UpdateStatus;
{ Fix replacements }
DefaultReplacements(s);
{ show comment }
if do_comment(v,s) or dostop then
stop;
if (status.errorcount>=status.maxerrorcount) and not status.skip_error then
begin
Message1(unit_f_errors_in_unit,tostr(status.errorcount));
status.skip_error:=true;
stop;
end;
end;
function MessagePchar(w:longint):pchar;
begin
MaybeLoadMessageFile;
MessagePchar:=msg^.GetPchar(w)
end;
procedure Message(w:longint);
begin
MaybeLoadMessageFile;
Msg2Comment(msg^.Get(w));
end;
procedure Message1(w:longint;const s1:string);
begin
MaybeLoadMessageFile;
Msg2Comment(msg^.Get1(w,s1));
end;
procedure Message2(w:longint;const s1,s2:string);
begin
MaybeLoadMessageFile;
Msg2Comment(msg^.Get2(w,s1,s2));
end;
procedure Message3(w:longint;const s1,s2,s3:string);
begin
MaybeLoadMessageFile;
Msg2Comment(msg^.Get3(w,s1,s2,s3));
end;
procedure Message4(w:longint;const s1,s2,s3,s4:string);
begin
MaybeLoadMessageFile;
Msg2Comment(msg^.Get4(w,s1,s2,s3,s4));
end;
procedure MessagePos(const pos:tfileposinfo;w:longint);
var
oldpos : tfileposinfo;
begin
oldpos:=aktfilepos;
aktfilepos:=pos;
MaybeLoadMessageFile;
Msg2Comment(msg^.Get(w));
aktfilepos:=oldpos;
end;
procedure MessagePos1(const pos:tfileposinfo;w:longint;const s1:string);
var
oldpos : tfileposinfo;
begin
oldpos:=aktfilepos;
aktfilepos:=pos;
MaybeLoadMessageFile;
Msg2Comment(msg^.Get1(w,s1));
aktfilepos:=oldpos;
end;
procedure MessagePos2(const pos:tfileposinfo;w:longint;const s1,s2:string);
var
oldpos : tfileposinfo;
begin
oldpos:=aktfilepos;
aktfilepos:=pos;
MaybeLoadMessageFile;
Msg2Comment(msg^.Get2(w,s1,s2));
aktfilepos:=oldpos;
end;
procedure MessagePos3(const pos:tfileposinfo;w:longint;const s1,s2,s3:string);
var
oldpos : tfileposinfo;
begin
oldpos:=aktfilepos;
aktfilepos:=pos;
MaybeLoadMessageFile;
Msg2Comment(msg^.Get3(w,s1,s2,s3));
aktfilepos:=oldpos;
end;
procedure MessagePos4(const pos:tfileposinfo;w:longint;const s1,s2,s3,s4:string);
var
oldpos : tfileposinfo;
begin
oldpos:=aktfilepos;
aktfilepos:=pos;
MaybeLoadMessageFile;
Msg2Comment(msg^.Get4(w,s1,s2,s3,s4));
aktfilepos:=oldpos;
end;
procedure InitVerbose;
begin
{ Init }
msg:=new(pmessage,Init(20,msgidxmax));
if msg=nil then
begin
writeln('Fatal: MsgIdx Wrong');
halt(3);
end;
{$ifndef EXTERN_MSG}
msg^.LoadIntern(@msgtxt,msgtxtsize);
{$else EXTERN_MSG}
LoadMsgFile(exepath+'errore.msg');
{$endif EXTERN_MSG}
FillChar(Status,sizeof(TCompilerStatus),0);
status.verbosity:=V_Default;
Status.MaxErrorCount:=50;
Loadprefixes;
lastfileidx:=-1;
lastmoduleidx:=-1;
status.currentmodule:='';
status.currentsource:='';
status.currentsourcepath:='';
status.compiling_current:=false;
end;
procedure DoneVerbose;
begin
if assigned(msg) then
begin
dispose(msg,Done);
msg:=nil;
end;
DoneRedirectFile;
end;
initialization
finalization
{ Be sure to close the redirect files to flush all data }
DoneRedirectFile;
end.
{
$Log$
Revision 1.26 2003-04-25 20:59:35 peter
* removed funcretn,funcretsym, function result is now in varsym
and aliases for result and function name are added using absolutesym
* vs_hidden parameter for funcret passed in parameter
* vs_hidden fixes
* writenode changed to printnode and released from extdebug
* -vp option added to generate a tree.log with the nodetree
* nicer printnode for statements, callnode
Revision 1.25 2003/04/22 14:33:38 peter
* removed some notes/hints
Revision 1.24 2003/01/09 21:52:38 peter
* merged some verbosity options.
* V_LineInfo is a verbosity flag to include line info
Revision 1.23 2002/12/29 14:57:50 peter
* unit loading changed to first register units and load them
afterwards. This is needed to support uses xxx in yyy correctly
* unit dependency check fixed
Revision 1.22 2002/11/15 01:58:54 peter
* merged changes from 1.0.7 up to 04-11
- -V option for generating bug report tracing
- more tracing for option parsing
- errors for cdecl and high()
- win32 import stabs
- win32 records<=8 are returned in eax:edx (turned off by default)
- heaptrc update
- more info for temp management in .s file with EXTDEBUG
Revision 1.21 2002/10/05 12:43:29 carl
* fixes for Delphi 6 compilation
(warning : Some features do not work under Delphi)
Revision 1.20 2002/08/18 19:59:03 peter
* renamed local current_module to compiling_module because it
confused a lot in gdb
Revision 1.19 2002/05/18 13:34:21 peter
* readded missing revisions
Revision 1.18 2002/05/16 19:46:47 carl
+ defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
+ try to fix temp allocation (still in ifdef)
+ generic constructor calls
+ start of tassembler / tmodulebase class cleanup
}
Reference in New Issue View Git Blame Copy Permalink