freepascal.compiler/compiler/verb_def.pas

{
    $Id$
    Copyright (c) 1998 by Peter Vreman

    This unit handles the default verbose routines

    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 verb_def;
interface

procedure SetRedirectFile(const fn:string);

procedure _stop;
Function  _comment(Level:Longint;const s:string):boolean;
function  _internalerror(i : longint) : boolean;

implementation
uses
  verbose,globals,
  strings,dos;

const
  { RHIDE expect gcc like error output }
  rh_errorstr='error: ';
  rh_warningstr='warning: ';
  fatalstr='Fatal: ';
  errorstr='Error: ';
  warningstr='Warning: ';
  notestr='Note: ';
  hintstr='Hint: ';

var
  redirexitsave : pointer;
  redirtext : boolean;
  redirfile : text;

{****************************************************************************
                       Extra Handlers for default compiler
****************************************************************************}

procedure DoneRedirectFile;{$ifndef FPC}far;{$ENDIF}
begin
  exitproc:=redirexitsave;
  if redirtext then
   close(redirfile);
end;


procedure SetRedirectFile(const fn:string);
begin
  assign(redirfile,fn);
  {$I-}
   rewrite(redirfile);
  {$I+}
  redirtext:=(ioresult=0);
  if redirtext then
   begin
     redirexitsave:=exitproc;
     exitproc:=@DoneRedirectFile;
   end;
end;


{****************************************************************************
                         Predefined default Handlers
****************************************************************************}


{ predefined handler to stop the compiler }
procedure _stop;
begin
  halt(1);
end;


Function _comment(Level:Longint;const s:string):boolean;
var
  hs : string;
begin
  _comment:=false; { never stop }
  if (verbosity and Level)=Level then
   begin
   { Status info?, Called every line }
     if ((Level and V_Status)<>0) and (s='') then
      begin
        if (status.compiledlines=1) then
          WriteLn(memavail shr 10,' Kb Free');
        if (status.currentline>0) and (status.currentline mod 100=0) then
{$ifdef FPC}
          WriteLn(status.currentline,' ',memavail shr 10,'/',system.heapsize shr 10,' Kb Free');
{$else}
          WriteLn(status.currentline,' ',memavail shr 10,' Kb Free');
{$endif}
      end
     else
   { Message }
      begin
        hs:='';
        if not(use_rhide) then
          begin
            if (verbosity and Level)=V_Hint then
              hs:=hintstr;
            if (verbosity and Level)=V_Note then
              hs:=notestr;
            if (verbosity and Level)=V_Warning then
              hs:=warningstr;
            if (verbosity and Level)=V_Error then
              hs:=errorstr;
            if (verbosity and Level)=V_Fatal then
              hs:=fatalstr;
          end
        else
          begin
            if (verbosity and Level)=V_Hint then
              hs:=rh_warningstr;
            if (verbosity and Level)=V_Note then
              hs:=rh_warningstr;
            if (verbosity and Level)=V_Warning then
              hs:=rh_warningstr;
            if (verbosity and Level)=V_Error then
              hs:=rh_errorstr;
            if (verbosity and Level)=V_Fatal then
              hs:=rh_errorstr;
          end;
        if (Level<=V_ShowFile) and (status.currentline>0) then
         begin
           if Use_Rhide then
             hs:=lower(bstoslash(status.currentsource))+':'+tostr(status.currentline)+': '+hs
           else
             hs:=status.currentsource+'('+tostr(status.currentline)+','+tostr(status.currentcolumn)+') '+hs;
         end;
      { add the message to the text }
        hs:=hs+s;
{$ifdef FPC}
        if UseStdErr then
         begin
           writeln(stderr,hs);
           flush(stderr);
         end
        else
{$endif}
         begin
           if redirtext then
            writeln(redirfile,hs)
           else
            writeln(hs);
         end;
      end;
   end;
end;


function _internalerror(i : longint) : boolean;
begin
  _comment(V_Fatal,'Internal error '+tostr(i));
  _internalerror:=true;
end;


begin
{$ifdef FPC}
  do_stop:=@_stop;
  do_comment:=@_comment;
  do_internalerror:=@_internalerror;
{$else}
  do_stop:=_stop;
  do_comment:=_comment;
  do_internalerror:=_internalerror;
{$endif}
end.
{
  $Log$
  Revision 1.13  1998-07-14 14:47:12  peter
    * released NEWINPUT

  Revision 1.12  1998/07/07 11:20:19  peter
    + NEWINPUT for a better inputfile and scanner object

  Revision 1.11  1998/06/19 15:40:00  peter
    * bp7 fix

  Revision 1.10  1998/06/16 11:32:19  peter
    * small cosmetic fixes

  Revision 1.9  1998/05/23 01:21:33  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
    * splitted cgi386 a bit (codeseg to large for bp7)
    * nasm, tasm works again. nasm moved to ag386nsm.pas

  Revision 1.8  1998/05/21 19:33:38  peter
    + better procedure directive handling and only one table

  Revision 1.7  1998/05/12 10:47:01  peter
    * moved printstatus to verb_def
    + V_Normal which is between V_Error and V_Warning and doesn't have a
      prefix like error: warning: and is included in V_Default
    * fixed some messages
    * first time parameter scan is only for -v and -T
    - removed old style messages

  Revision 1.6  1998/05/11 13:07:58  peter
    + $ifdef NEWPPU for the new ppuformat
    + $define GDB not longer required
    * removed all warnings and stripped some log comments
    * no findfirst/findnext anymore to remove smartlink *.o files

  Revision 1.5  1998/04/30 15:59:43  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

  Revision 1.4  1998/04/29 10:34:09  pierre
    + added some code for ansistring (not complete nor working yet)
    * corrected operator overloading
    * corrected nasm output
    + started inline procedures
    + added starstarn : use ** for exponentiation (^ gave problems)
    + started UseTokenInfo cond to get accurate positions
}