home *** CD-ROM | disk | FTP | other *** search
/ AmigActive 2 / AACD 2.iso / AACD / Programming / fpc / compiler / verb_def.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1998-09-24  |  6.9 KB  |  283 lines
  1. {
  2.     $Id: verb_def.pas,v 1.2 1998/03/28 23:09:57 florian Exp $
  3.     Copyright (c) 1998 by Peter Vreman
  4.  
  5.     This unit handles the default verbose routines
  6.  
  7.     This program is free software; you can redistribute it and/or modify
  8.     it under the terms of the GNU General Public License as published by
  9.     the Free Software Foundation; either version 2 of the License, or
  10.     (at your option) any later version.
  11.  
  12.     This program is distributed in the hope that it will be useful,
  13.     but WITHOUT ANY WARRANTY; without even the implied warranty of
  14.     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15.     GNU General Public License for more details.
  16.  
  17.     You should have received a copy of the GNU General Public License
  18.     along with this program; if not, write to the Free Software
  19.     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21.  ****************************************************************************
  22. }
  23. unit verb_def;
  24. interface
  25. uses verbose;
  26.  
  27. {$define allow_oldstyle}
  28.  
  29. var
  30.   UseStdErr : boolean;
  31. procedure SetRedirectFile(const fn:string);
  32.  
  33. procedure _stop;
  34. procedure _comment(Level:Longint;const s:string);
  35. {$ifdef allow_oldstyle}
  36. function _warning(w : tmsgconst) : boolean;
  37. function _note(w : tmsgconst) : boolean;
  38. function _error(w : tmsgconst) : boolean;
  39. function _fatalerror(w : tmsgconst) : boolean;
  40. function _internalerror(i : longint) : boolean;
  41. {$endif}
  42.  
  43. implementation
  44. uses
  45.   strings,dos,cobjects,systems,globals,files;
  46.  
  47. const
  48. {$ifdef USE_RHIDE}
  49.   { RHIDE expect gcc like error output }
  50.   fatalstr='fatal: ';
  51.   errorstr='error: ';
  52.   warningstr='warning: ';
  53.   notestr='warning: ';
  54.   hintstr='warning: ';
  55. {$else}
  56.   fatalstr='Fatal Error: ';
  57.   errorstr='Error: ';
  58.   warningstr='Warning: ';
  59.   notestr='Note: ';
  60.   hintstr='Hint: ';
  61. {$endif USE_RHIDE}
  62.  
  63. var
  64.   redirexitsave : pointer;
  65.   redirtext : boolean;
  66.   redirfile : text;
  67.  
  68. {****************************************************************************
  69.                        Extra Handlers for default compiler
  70. ****************************************************************************}
  71.  
  72. procedure DoneRedirectFile;{$ifndef FPC}far;{$ENDIF}
  73. begin
  74.   exitproc:=redirexitsave;
  75.   if redirtext then
  76.    close(redirfile);
  77. end;
  78.  
  79.  
  80. procedure SetRedirectFile(const fn:string);
  81. begin
  82.   assign(redirfile,fn);
  83.   {$I-}
  84.    rewrite(redirfile);
  85.   {$I+}
  86.   redirtext:=(ioresult=0);
  87.   if redirtext then
  88.    begin
  89.      redirexitsave:=exitproc;
  90.      exitproc:=@DoneRedirectFile;
  91.    end;
  92. end;
  93.  
  94.  
  95. {****************************************************************************
  96.                          Predefined default Handlers
  97. ****************************************************************************}
  98.  
  99.  
  100. { predefined handler to stop the compiler }
  101. procedure _stop;
  102. begin
  103.   halt(1);
  104. end;
  105.  
  106.  
  107. Procedure _comment(Level:Longint;const s:string);
  108. var
  109.   hs : string;
  110. {$ifdef USE_RHIDE}
  111.   i  : longint;
  112. {$endif}
  113. begin
  114.   if (verbosity and Level)=Level then
  115.    begin
  116.    {Create hs}
  117.      hs:='';
  118.      if (verbosity and Level)=V_Hint then
  119.       hs:=hintstr;
  120.      if (verbosity and Level)=V_Note then
  121.       hs:=notestr;
  122.      if (verbosity and Level)=V_Warning then
  123.       hs:=warningstr;
  124.      if (verbosity and Level)=V_Error then
  125.       hs:=errorstr;
  126.      if (verbosity and Level)=V_Fatal then
  127.       hs:=fatalstr;
  128.      if (Level<$100) and Assigned(current_module) and
  129.         Assigned(current_module^.current_inputfile) then
  130.       hs:=current_module^.current_inputfile^.get_file_line+' '+hs;
  131. {$ifdef USE_RHIDE}
  132.      if (Level<$100) then
  133.       begin
  134.         i:=length(hs)+1;
  135.         hs:=hs+lowercase(Copy(s,1,5))+Copy(s,6,255);
  136.       end
  137.      else
  138. {$endif USE_RHIDE}
  139.       hs:=hs+s;
  140. {$ifdef FPC}
  141.      if UseStdErr and (Level<$100) then
  142.       begin
  143.         writeln(stderr,hs);
  144.         flush(stderr);
  145.       end
  146.      else
  147. {$ENDIF}
  148.       begin
  149.         if redirtext then
  150.          writeln(redirfile,hs)
  151.         else
  152.          writeln(hs);
  153.       end;
  154.    end;
  155. end;
  156.  
  157.  
  158. function _internalerror(i : longint) : boolean;
  159. begin
  160.   comment(V_Fatal,'Internal error '+tostr(i));
  161.   _internalerror:=true;
  162. end;
  163.  
  164. {****************************************************************************
  165.                                  Old Style
  166. ****************************************************************************}
  167.  
  168.  
  169. {$ifdef allow_oldstyle}
  170.  
  171. procedure ShowExtError(l:longint;w:tmsgconst);
  172. var
  173.   s : string;
  174. begin
  175. {fix the string to be written }
  176.   s:=msg^.get(ord(w));
  177.   if assigned(exterror) then
  178.    begin
  179.      s:=s+strpas(exterror);
  180.      strdispose(exterror);
  181.      exterror:=nil;
  182.    end;
  183.   _comment(l,s);
  184. end;
  185.  
  186.  
  187. { predefined handler for warnings }
  188. function _warning(w : tmsgconst) : boolean;
  189. begin
  190.   ShowExtError(V_Warning,w);
  191.   _warning:=false;
  192. end;
  193.  
  194.  
  195. function _note(w : tmsgconst) : boolean;
  196. begin
  197.   ShowExtError(V_Note,w);
  198.   _note:=false;
  199. end;
  200.  
  201.  
  202. function _error(w : tmsgconst) : boolean;
  203. begin
  204.   ShowExtError(V_Error,w);
  205.   _error:=(errorcount>50);
  206. end;
  207.  
  208.  
  209. function _fatalerror(w : tmsgconst) : boolean;
  210. begin
  211.   ShowExtError(V_Error,w);
  212.   _fatalerror:=true;
  213. end;
  214.  
  215. {$endif}
  216.  
  217. begin
  218. {$ifdef FPC}
  219.   do_stop:=@_stop;
  220.   do_comment:=@_comment;
  221.   {$ifdef allow_oldstyle}
  222.      do_note:=@_note;
  223.      do_warning:=@_warning;
  224.      do_error:=@_error;
  225.      do_fatalerror:=@_fatalerror;
  226.      do_internalerror:=@_internalerror;
  227.   {$endif}
  228. {$else}
  229.   do_stop:=_stop;
  230.   do_comment:=_comment;
  231.   {$ifdef allow_oldstyle}
  232.      do_note:=_note;
  233.      do_warning:=_warning;
  234.      do_error:=_error;
  235.      do_fatalerror:=_fatalerror;
  236.      do_internalerror:=_internalerror;
  237.   {$endif}
  238. {$endif}
  239. end.
  240. {
  241.   $Log: verb_def.pas,v $
  242.   Revision 1.2  1998/03/28 23:09:57  florian
  243.     * secondin bugfix (m68k and i386)
  244.     * overflow checking bugfix (m68k and i386) -- pretty useless in
  245.       secondadd, since everything is done using 32-bit
  246.     * loading pointer to routines hopefully fixed (m68k)
  247.     * flags problem with calls to RTL internal routines fixed (still strcmp
  248.       to fix) (m68k)
  249.     * #ELSE was still incorrect (didn't take care of the previous level)
  250.     * problem with filenames in the command line solved
  251.     * problem with mangledname solved
  252.     * linking name problem solved (was case insensitive)
  253.     * double id problem and potential crash solved
  254.     * stop after first error
  255.     * and=>test problem removed
  256.     * correct read for all float types
  257.     * 2 sigsegv fixes and a cosmetic fix for Internal Error
  258.     * push/pop is now correct optimized (=> mov (%esp),reg)
  259.  
  260.   Revision 1.1.1.1  1998/03/25 11:18:15  root
  261.   * Restored version
  262.  
  263.   Revision 1.6  1998/03/10 16:43:34  peter
  264.     * fixed Fatal error writting
  265.  
  266.   Revision 1.5  1998/03/10 01:17:30  peter
  267.     * all files have the same header
  268.     * messages are fully implemented, EXTDEBUG uses Comment()
  269.     + AG... files for the Assembler generation
  270.  
  271.   Revision 1.4  1998/03/06 00:53:02  peter
  272.     * replaced all old messages from errore.msg, only ExtDebug and some
  273.       Comment() calls are left
  274.     * fixed options.pas
  275.  
  276.   Revision 1.3  1998/03/04 17:34:15  michael
  277.   + Changed ifdef FPK to ifdef FPC
  278.  
  279.   Revision 1.2  1998/03/03 16:45:25  peter
  280.     + message support for assembler parsers
  281.  
  282. }
  283.