{
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}
interface
uses
{$IFNDEF USE_FAKE_SYSUTILS}
sysutils,
{$ELSE}
fksysutl,
{$ENDIF}
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;
type
tmsgqueueevent = procedure(s:string;v,w:longint) of object;
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 ShowStatus;
function ErrorCount:longint;
procedure SetErrorFlags(const s:string);
procedure GenerateError;
procedure Internalerror(i:longint);
procedure Comment(l:longint;s:ansistring);
function MessagePchar(w:longint):pchar;
procedure Message(w:longint;onqueue:tmsgqueueevent=nil);
procedure Message1(w:longint;const s1:string;onqueue:tmsgqueueevent=nil);
procedure Message2(w:longint;const s1,s2:string;onqueue:tmsgqueueevent=nil);
procedure Message3(w:longint;const s1,s2,s3:string;onqueue:tmsgqueueevent=nil);
procedure Message4(w:longint;const s1,s2,s3,s4:string;onqueue:tmsgqueueevent=nil);
procedure MessagePos(const pos:tfileposinfo;w:longint;onqueue:tmsgqueueevent=nil);
procedure MessagePos1(const pos:tfileposinfo;w:longint;const s1:string;onqueue:tmsgqueueevent=nil);
procedure MessagePos2(const pos:tfileposinfo;w:longint;const s1,s2:string;onqueue:tmsgqueueevent=nil);
procedure MessagePos3(const pos:tfileposinfo;w:longint;const s1,s2,s3:string;onqueue:tmsgqueueevent=nil);
procedure MessagePos4(const pos:tfileposinfo;w:longint;const s1,s2,s3,s4:string;onqueue:tmsgqueueevent=nil);
{ message calls with codegenerror support }
procedure cgmessage(t : longint);
procedure cgmessage1(t : longint;const s : string);
procedure cgmessage2(t : longint;const s1,s2 : string);
procedure cgmessage3(t : longint;const s1,s2,s3 : string);
procedure CGMessagePos(const pos:tfileposinfo;t:longint);
procedure CGMessagePos1(const pos:tfileposinfo;t:longint;const s1:string);
procedure CGMessagePos2(const pos:tfileposinfo;t:longint;const s1,s2:string);
procedure CGMessagePos3(const pos:tfileposinfo;t:longint;const s1,s2,s3:string);
procedure FlushOutput;
procedure InitVerbose;
procedure DoneVerbose;
implementation
uses
comphook,fmodule;
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
{ close old redirection file because FileRedirection is handled in both passes }
if status.use_redir then
close(status.redirfile);
assign(status.redirfile,fn);
{$I-}
append(status.redirfile);
if ioresult <> 0 then
begin
assign(status.redirfile,fn);
rewrite(status.redirfile);
end;
{$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;
'B' : begin
if inverse then
status.print_source_path:=false
else
status.print_source_path:=true;
end;
'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;
'Z' : begin
if inverse then
status.use_stderr:=false
else
status.use_stderr:=true;
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;
'S' : if inverse then
status.verbosity:=status.verbosity and (not V_TimeStamps)
else
status.verbosity:=status.verbosity or V_TimeStamps;
'V' : PrepareReport;
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;
var
module : tmodulebase;
begin
{ fix status }
status.currentline:=current_filepos.line;
status.currentcolumn:=current_filepos.column;
module:=get_module(current_filepos.moduleindex);
if assigned(module) and
assigned(module.sourcefiles) and
((module.unit_index<>lastmoduleidx) or
(current_filepos.fileindex<>lastfileidx)) then
begin
{ update status record }
status.currentmodule:=module.modulename^;
status.currentsource:=module.sourcefiles.get_file_name(current_filepos.fileindex);
status.currentsourcepath:=module.sourcefiles.get_file_path(current_filepos.fileindex);
{ update lastfileidx only if name known PM }
if status.currentsource<>'' then
lastfileidx:=current_filepos.fileindex
else
lastfileidx:=0;
lastmoduleidx:=module.unit_index;
end;
status.compiling_current:=assigned(compiling_module) and
(module=compiling_module) and
(compiling_module.state in [ms_compile,ms_second_compile]);
end;
procedure ShowStatus;
begin
UpdateStatus;
if do_status() then
raise ECompilerAbort.Create;
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);
raise ECompilerAbort.Create;
end;
procedure Comment(l:longint;s:ansistring);
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
raise ECompilerAbort.Create;
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;
raise ECompilerAbort.Create;
end;
end;
Procedure Msg2Comment(s:ansistring;w:longint;onqueue:tmsgqueueevent);
var
idx,i,v : longint;
dostop : boolean;
doqueue : boolean;
begin
{Reset}
dostop:=false;
doqueue:=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)
else
inc(status.countWarnings);
end;
'N' :
begin
v:=v or V_Note;
if status.errornote then
inc(status.errorcount)
else
inc(status.countNotes);
end;
'H' :
begin
v:=v or V_Hint;
if status.errorhint then
inc(status.errorcount)
else
inc(status.countHints);
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
begin
doqueue := onqueue <> nil;
if not doqueue then
exit;
end;
if (v and V_LineInfoMask)<>0 then
v:=v or V_LineInfo;
{ fix status }
UpdateStatus;
{ Fix replacements }
DefaultReplacements(s);
if doqueue then
begin
onqueue(s,v,w);
exit;
end;
{ show comment }
if do_comment(v,s) or dostop then
raise ECompilerAbort.Create;
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;
raise ECompilerAbort.Create;
end;
end;
function MessagePchar(w:longint):pchar;
begin
MaybeLoadMessageFile;
MessagePchar:=msg^.GetPchar(w)
end;
procedure Message(w:longint;onqueue:tmsgqueueevent=nil);
begin
MaybeLoadMessageFile;
Msg2Comment(msg^.Get(w,[]),w,onqueue);
end;
procedure Message1(w:longint;const s1:string;onqueue:tmsgqueueevent=nil);
begin
MaybeLoadMessageFile;
Msg2Comment(msg^.Get(w,[s1]),w,onqueue);
end;
procedure Message2(w:longint;const s1,s2:string;onqueue:tmsgqueueevent=nil);
begin
MaybeLoadMessageFile;
Msg2Comment(msg^.Get(w,[s1,s2]),w,onqueue);
end;
procedure Message3(w:longint;const s1,s2,s3:string;onqueue:tmsgqueueevent=nil);
begin
MaybeLoadMessageFile;
Msg2Comment(msg^.Get(w,[s1,s2,s3]),w,onqueue);
end;
procedure Message4(w:longint;const s1,s2,s3,s4:string;onqueue:tmsgqueueevent=nil);
begin
MaybeLoadMessageFile;
Msg2Comment(msg^.Get(w,[s1,s2,s3,s4]),w,onqueue);
end;
procedure MessagePos(const pos:tfileposinfo;w:longint;onqueue:tmsgqueueevent=nil);
var
oldpos : tfileposinfo;
begin
oldpos:=current_filepos;
current_filepos:=pos;
MaybeLoadMessageFile;
Msg2Comment(msg^.Get(w,[]),w,onqueue);
current_filepos:=oldpos;
end;
procedure MessagePos1(const pos:tfileposinfo;w:longint;const s1:string;onqueue:tmsgqueueevent=nil);
var
oldpos : tfileposinfo;
begin
oldpos:=current_filepos;
current_filepos:=pos;
MaybeLoadMessageFile;
Msg2Comment(msg^.Get(w,[s1]),w,onqueue);
current_filepos:=oldpos;
end;
procedure MessagePos2(const pos:tfileposinfo;w:longint;const s1,s2:string;onqueue:tmsgqueueevent=nil);
var
oldpos : tfileposinfo;
begin
oldpos:=current_filepos;
current_filepos:=pos;
MaybeLoadMessageFile;
Msg2Comment(msg^.Get(w,[s1,s2]),w,onqueue);
current_filepos:=oldpos;
end;
procedure MessagePos3(const pos:tfileposinfo;w:longint;const s1,s2,s3:string;onqueue:tmsgqueueevent=nil);
var
oldpos : tfileposinfo;
begin
oldpos:=current_filepos;
current_filepos:=pos;
MaybeLoadMessageFile;
Msg2Comment(msg^.Get(w,[s1,s2,s3]),w,onqueue);
current_filepos:=oldpos;
end;
procedure MessagePos4(const pos:tfileposinfo;w:longint;const s1,s2,s3,s4:string;onqueue:tmsgqueueevent=nil);
var
oldpos : tfileposinfo;
begin
oldpos:=current_filepos;
current_filepos:=pos;
MaybeLoadMessageFile;
Msg2Comment(msg^.Get(w,[s1,s2,s3,s4]),w,onqueue);
current_filepos:=oldpos;
end;
{*****************************************************************************
override the message calls to set codegenerror
*****************************************************************************}
procedure cgmessage(t : longint);
var
olderrorcount : longint;
begin
if not(codegenerror) then
begin
olderrorcount:=Errorcount;
verbose.Message(t);
codegenerror:=olderrorcount<>Errorcount;
end;
end;
procedure cgmessage1(t : longint;const s : string);
var
olderrorcount : longint;
begin
if not(codegenerror) then
begin
olderrorcount:=Errorcount;
verbose.Message1(t,s);
codegenerror:=olderrorcount<>Errorcount;
end;
end;
procedure cgmessage2(t : longint;const s1,s2 : string);
var
olderrorcount : longint;
begin
if not(codegenerror) then
begin
olderrorcount:=Errorcount;
verbose.Message2(t,s1,s2);
codegenerror:=olderrorcount<>Errorcount;
end;
end;
procedure cgmessage3(t : longint;const s1,s2,s3 : string);
var
olderrorcount : longint;
begin
if not(codegenerror) then
begin
olderrorcount:=Errorcount;
verbose.Message3(t,s1,s2,s3);
codegenerror:=olderrorcount<>Errorcount;
end;
end;
procedure cgmessagepos(const pos:tfileposinfo;t : longint);
var
olderrorcount : longint;
begin
if not(codegenerror) then
begin
olderrorcount:=Errorcount;
verbose.MessagePos(pos,t);
codegenerror:=olderrorcount<>Errorcount;
end;
end;
procedure cgmessagepos1(const pos:tfileposinfo;t : longint;const s1 : string);
var
olderrorcount : longint;
begin
if not(codegenerror) then
begin
olderrorcount:=Errorcount;
verbose.MessagePos1(pos,t,s1);
codegenerror:=olderrorcount<>Errorcount;
end;
end;
procedure cgmessagepos2(const pos:tfileposinfo;t : longint;const s1,s2 : string);
var
olderrorcount : longint;
begin
if not(codegenerror) then
begin
olderrorcount:=Errorcount;
verbose.MessagePos2(pos,t,s1,s2);
codegenerror:=olderrorcount<>Errorcount;
end;
end;
procedure cgmessagepos3(const pos:tfileposinfo;t : longint;const s1,s2,s3 : string);
var
olderrorcount : longint;
begin
if not(codegenerror) then
begin
olderrorcount:=Errorcount;
verbose.MessagePos3(pos,t,s1,s2,s3);
codegenerror:=olderrorcount<>Errorcount;
end;
end;
procedure FlushOutput;
begin
if not (Status.Use_StdErr) then (* StdErr is flushed after every line *)
begin
if Status.Use_Redir then
Flush(Status.RedirFile)
else
Flush(Output);
end;
end;
{*****************************************************************************
Initialization
*****************************************************************************}
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;
Status.codesize:=-1;
Status.datasize:=-1;
Loadprefixes;
lastfileidx:=-1;
lastmoduleidx:=-1;
status.currentmodule:='';
status.currentsource:='';
status.currentsourcepath:='';
status.compiling_current:=false;
compiling_module:=nil;
{ Register internalerrorproc for cutils/cclasses }
internalerrorproc:=@internalerror;
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.
syntax highlighted by Code2HTML, v. 0.9.1