cperror.pas

生物信息学中的遗传数据分析的delphi源码。

{*******************************************************************
*                                                                  *
*  COMPONENT for MS DOS and Windows source code.                   *
*                                                                  *
*  (c) 1992, Roderic D. M. Page                                    *
*                                                                  *
*  Language: Turbo Pascal (Pascal with object-oriented extensions) *
*  Compiler: Turbo Pascal 6.0 (MS DOS)                             *
*            Turbo Pascal for Windows 1.0 (WINDOWS)                *
*                                                                  *
*  Notes:    Program interface is currently Windows specific.      *
*                                                                  *
*******************************************************************}

{*

   Error messages

    5 Sep 1991 Written
   10 Jun 1992 Uses Windows procs and resources.
	13 Feb 1993	Exit procedure installed.
*}


{$I CPDIR.INC}

{$IFNDEF BINDRESOURCES}
{$R CPERROR.RES}
{$ENDIF}

unit cperror;

{ Error messages }

interface

uses
	WinTypes,
	WinProcs,
	BWCC,
   	Strings,
	cpstream;
{
	cphex;}

type
   ErrorTypes = (STREAM, MEMORY, UNKNOWN);
      { Types of errors }

   ERROROBJ = object
      { Object encapsulating error reporting }
      Code  : integer;      { error code }
      Row   : integer;      { line in file }
      Col   : integer;      { column in file }
      LastCount: longint;   { previous position in text stream }
      Count : longint;      { current position in text stream }
      Kind  : ErrorTypes;   { type of error }
      Item  : array[0..80] of char; { offending token }
      constructor Init;
         { Set [[Code]] to [[erOK:cperror.erOK]] and clear [[Item]] }
      function NotOK:Boolean;
         {True if [[Code]] is not [[erOK:cperror.erOK]]}
      function UserAborted:Boolean;
         {True if [[Code]] = [[erUserAbort:cperror.erUserAbort]]}
      procedure UpDate (c:integer);
         {Set [[Code]] to <\b c> }
      procedure IOError (c:integer; i:string);
         {Sets [[Code]] to <\b c> and [[Item]] to <\b i> }
      procedure InputError (c:integer; i:string; var F: FILEPOSREC);
         {Sets the error code (<\b c>), offending token (<\b i>) and position
         in text stream (<\b F>) of an input error.}
      function Msg:PChar;
        {Return pointer to error message which are stored in a String Table
        resource.}
      function PosnString:string;
         {Return the string "([Row],[Col])"}
      private
      MsgBuf : array[0..256] of char;
	 end;

{$IFNDEF DEBUG}
procedure MyExit;far;
	{Exit procedure, displays a message box with the address of the
	 runtime error.}
{$ENDIF}

var
   ErrorRec: ERROROBJ;
      { Global instance of [ERROROBJ] }

const
   erOK                =   0; {}
   erUndocumented      = 150; {}

   erNoMemory          =  1;  {}

   erEndOfFile         = 10;{}
   erSyntax            = 11;{}
   erInvalidToken      = 12;{}
   erInvalidNumber     = 13;{}
   erNumber            = 14;{}
   erString            = 15;{}

   erBadCmd            = 20;{}
   erBadBlk            = 21;{}
   erSemiColon         = 22;{}
   erFileSpec          = 23;
   erFormat            = 24;
   erMissingLabel      = 25;
   erNotNexus          = 26;
   erComma             = 27;
   erTreeBlk           = 28;
   erProfileBlk        = 29;

   erNoFile            = 30;
   erEquals            = 31;
   erLabelHashOverflow = 32;
   erDuplicate         = 33;
   erMixRoot           = 34;
   erIncorrectFormat   = 35;
   erExpectingName     = 36;
   erImport            = 37;
   erIncorrectTable    = 38;
   erWrongCommand      = 39;

   erStkOverFlow       = 40;
   erUnbalanced        = 41;
   erMissingLPar       = 42;
   erStkNotEmpty       = 43;
   erHashOverflow      = 44;
   erUnknownLabel      = 46;
   erExtraPar          = 47;
   erInvalidLeafNumber = 48;

   erBufferFull        = 50;
   erBegin             = 51;
   erOutOfRange        = 52;
   erTooManyTaxa       = 53;

   erTitle             = 54;
   erTable             = 55;

   erTooManyTrees      = 56;

   
   erSetHashOverflow   = 60;
   erBadOutGrp         = 61;
   erPrunedOutGrp      = 62;
   erInvalidOutGrp     = 63;
   erNoCompare         = 64;

   erTAXABlock         = 70;
   erTooManyLabels     = 71;
   erTooFewLabels      = 72;
   erMissingLeaf       = 73;
   erRepeatedCommand   = 74;
   erBadModel          = 75;
   erBadSeed           = 76;
   erBadTrees          = 77;
   erBadRootedTaxa     = 78;
   erBadUnRootedTaxa   = 79;

   erNoModel           = 80;
   erNoNTrees          = 81;
   erNoNTaxa           = 82;
   erTooManyChars      = 83;
   erSymbol            = 84;

   erNoReconcile       = 85;
   erCOLON             = 86;
   erNORANGE           = 87;

   erUserAbort         = 99;

   erDiskRead          = 100;
   erDiskWrite         = 101;
   erNotAssigned       = 102;
   erFileNotOpen       = 103;
   erTextNotIn         = 104;
   erTextNotOut        = 105;
   erInvalidFormat     = 106;

function GetExitSave:Pointer;


implementation

const
   STRINGTABLE = 500; { Offset for id in resource file }

var
	ExitSave : Pointer; { Old vector }

function GetExitSave:Pointer;
begin
     GetExitSave := ExitSave;
end;

{-----------------------------Init-----------------------------------------}

   constructor ERROROBJ.Init;
   begin
      Code    := erOK;
      Item[0] := #0;
   end;

{-----------------------------Update---------------------------------------}

   procedure ERROROBJ.Update (c:integer);
   begin
      Code  := c;
   end;

{-----------------------------IOError--------------------------------------}

   procedure ERROROBJ.IOError (c:integer; i:string);
   begin
      Code := c;
      StrPCopy (Item, i);
   end;

{-----------------------------InputError-----------------------------------}

   procedure ERROROBJ.InputError (c:integer; i:string; var F: FILEPOSREC);
   begin
      Code      := c;
      StrPCopy (Item, i);
      Row       := F.Row;
      Col       := F.Col;
      LastCount := F.LastPosn;
      Count     := F.BytesRead;
   end;

{-----------------------------NotOK----------------------------------------}

   function ERROROBJ.NotOK:Boolean;
   begin
      NotOK := (Code <> erOK);
   end;

{-----------------------------UserAborted----------------------------------}

   function ERROROBJ.UserAborted:Boolean;
   begin
      UserAborted := (Code = erUserAbort);
   end;

{-----------------------------Msg------------------------------------------}

   { Load error message from resource }
   function ERROROBJ.Msg:PChar;
   var
      Buf      : array[0..128] of char;
      lpszItem : PChar;
   begin
      if (LoadString (HInstance, Code + STRINGTABLE,
         Buf, SizeOf (Buf) - 1) = 0) then
         StrCopy (Buf, 'Undocumented error.');

      if (StrPos (Buf, '%s') <> NIL) then begin
         lpszItem := @Item;
         wvsprintf (MsgBuf, Buf, lpszItem);
         end
      else StrCopy (MsgBuf, Buf);
      Msg := @MsgBuf;
   end;

{-----------------------------PosnString-----------------------------------}

   function ERROROBJ.PosnString:String;
   var
      s1, s2:string;
   begin
      Str (Row, s1);
      Str (Col, s2);
      PosnString := '(' + s1 + ',' + s2 + ')';
   end;

{$IFNDEF DEBUG}
{$F+}
procedure MyExit;
var
	szSeg : array[0..4] of char;
	szOff : array[0..4] of char;
	szNum : array[0..4] of char;
	buf : array[0..255] of char;

begin
	ExitProc := ExitSave; 	{Restore old vector}
	if (ExitCode <> 0) and (ErrorAddr <> nil) then begin
		Str (ExitCode, szNum);
{		Hex (szSeg, Seg (ErrorAddr^));}
{		Hex (szOff, Ofs (ErrorAddr^));}
		StrCopy (buf, 'Internal error ');
		StrCat (buf, szNum);
{		StrCat (buf, ' at ');
		StrCat (buf, szSeg);
		StrCat (buf, ':');
		StrCat (buf, szOff);}
		StrCat (buf, '.');
		StrCat (buf, #13);
		StrCat (buf, #13);
		StrCat (buf, '(');
		case ExitCode of
			200:	StrCat (buf, 'Division by zero');
			201:	StrCat (buf, 'Range check error');
			202:	StrCat (buf, 'Stack overflow error');
			203:	StrCat (buf, 'Heap overflow error');
			204:	StrCat (buf, 'Invalid pointer operation');
			205:	StrCat (buf, 'Floating point overflow');
			206:	StrCat (buf, 'Floating point underflow');
			207:	StrCat (buf, 'Invalid floating point operation');
			210:	StrCat (buf, 'Object not initialized');
			211:	StrCat (buf, 'Call to abstract method');
			212:	StrCat (buf, 'Stream registration error');
			213:	StrCat (buf, 'Collection index out of range');
			214:	StrCat (buf, 'Collection overflow error');
			end;
		StrCat (buf, ')');
		BWCCMessageBox (0, buf, 'COMPONENT Internal Error',
			mb_TaskModal or mb_OK or mb_IconExclamation);
		ErrorAddr := nil;
		end;  
end;
{$F-}	
{$ENDIF}	


begin
{$IFNDEF DEBUG}
	ExitSave := ExitProc;
	ExitProc := @MyExit;
{$ENDIF}
end.