[fpc-pascal]error.pas from russia at freepascal.org ;)

[Alex Dexter]

{$I compdefs.inc}
unit Error;

interface

implementation

var
  ExitAddress : pointer;

type
PtrRec = record               // Pointer record type
    Ofs: Longint;
  end;

procedure ErrorExit;
 var
  FileName: String;
  LineNo: Longint;
 begin
  if ErrorAddr<>nil then
  if ExitCode<>0 then
  begin
   Assign(output,'');
   Rewrite(output);
   begin
    WriteLn(output,'Program terminated with specific error #'+Addspaces(int2str(ExitCode),3,'0',true)+'.');
    case ExitCode of
     1..18     : Write(output,^G+'DOS ERROR: ');
     100..106  : Write(output,^G+'I/O ERROR: ');
     150..162,
     200..216  : Write(output,^G+'CRITICAL ERROR: ');
    end;
    case ExitCode of
     001: Writeln(output,'Invalid function number.');
     002: Writeln(output,'File not found.');
     003: Writeln(output,'Path not found.');
     004: Writeln(output,'Too many open files.');
     005: Writeln(output,'File access denied.');
     006: Writeln(output,'Invalid file handle.');
     012: Writeln(output,'Invalid file access code.');
     015: Writeln(output,'Invalid drive number.');
     016: Writeln(output,'Cannot remove current directory.');
     017: Writeln(output,'Cannot rename across drives.');
     018: Writeln(output,'No More Files.');
     100: Writeln(output,'Disk read error.');
     101: Writeln(output,'Disk write error.');
     102: Writeln(output,'File not assigned.');
     103: Writeln(output,'File not open.');
     104: Writeln(output,'File not open for input.');
     105: Writeln(output,'File not open for output.');
     106: Writeln(output,'Invalid numeric format.');
     150: Writeln(output,'Disk is write-protected.');
     151: Writeln(output,'Unknown unit.');
     152: Writeln(output,'Drive not ready.');
     153: Writeln(output,'Unknown command.');
     154: Writeln(output,'CRC error in data.');
     155: Writeln(output,'Bad drive request structure length.');
     156: Writeln(output,'Disk seek error.');
     157: Writeln(output,'Unknown media type.');
     158: Writeln(output,'Sector not found.');
     159: Writeln(output,'Printer out of paper.');
     160: Writeln(output,'Device write fault.');
     161: Writeln(output,'Device read fault.');
     162: Writeln(output,'Hardware failure.');
     200: Writeln(output,'Division by zero.');
     201: Writeln(output,'Range check error.');
     202: Writeln(output,'Stack overflow error.');
     203: Writeln(output,'Heap overflow error.');
     204: Writeln(output,'Invalid pointer operation.');
     205: Writeln(output,'Floating point overflow.');
     206: Writeln(output,'Floating point underflow.');
     207: Writeln(output,'Invalid floating point operation.');
     208: Writeln(output,'Overlay manager not installed.');
     209: Writeln(output,'Overlay file read error.');
     210: Writeln(output,'Object not initialized.');
     211: Writeln(output,'Call to abstract method.');
     212: Writeln(output,'Stream registration error.');
     213: Writeln(output,'Collection index out of range.');
     214: Writeln(output,'Collection overflow error.');
     215: Writeln(output,'Arithmetic overflow error.');
     216: Writeln(output,'General Protection fault.');
     else WriteLn(output,^G+'Unknown Error.');
    end;
    if GetLocationInfo(ErrorAddr,FileName,LineNo)<>nil
    then writeLn(output,'Exception in '+filename+'#'+int2str(lineno-1));

    if exitcode in [150..162,200..216] then Writeln(output,^G+'Please send message to author!');
    ErrorAddr:=nil;
    ExitCode:=0;
    Close(output);
   end;
  end;
  ExitProc:=ExitAddress;
 end;

begin
  ExitAddress:=ExitProc;
  ExitProc:=@ErrorExit;
end.


This version for VP, but may be use with any BP-like compiler. Fully worked source.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://lists.freepascal.org/pipermail/fpc-pascal/attachments/20000922/876baf1c/attachment.html>