(* This file was mangled by Mangler 1.35 (c) Copyright 1993-1994 by Berend de Boer *)
{ Created : 01-06-'90
Last changes :
91-07-10 Adapted for use in TP6.0 and Turbo Vision
92-07-02 Added log file ferr where an application can write error codes to
92-12-04 Added code to clear IOResult so an errormessage can be written to
the log file
93-01-18 Installed a simple Heap function to return 1 when a request for
memory could not be fulfilled
93-01-28 Deleted statements which disposed an Application if an error was
detected
93-05-05 Added a dump stack procedure
93-12-01 Added a hook for the Post Mortem Debugger, simple change the
procedure variable HandleRunTimeError
94-03-17 Renamed InstallExitHandler to InitBBError
94-05-16 Adapted to Windows target
94-10-24 Improved stack walking with better near call detection
Expects that an application object was running
}
{$IFDEF MSDOS}
{$O+,F+,D-}
{$ENDIF}
{$I-,V-,Q-,R-,S-}
unit BBError;
interface
uses
Objects,
{$IFDEF Windows}
BBFile
{$ELSE}
Dos
{$ENDIF};
const
FatalErrorText:string[128] = 'Fatal error. Errorcode: ';
type
HandleRunTimeErrorProcedureType = procedure(StackFrame : word);
DumpStackProcedureType = procedure(Addr : pointer; StackFrame : word);
var
ferr : text;
HandleRunTimeError : HandleRunTimeErrorProcedureType;
DumpStack : DumpStackProcedureType;
function GetLogicalAddr(Addr : pointer) : pointer;
function IsValidPtr(Addr : pointer) : Boolean;
procedure LogError(const s : string);
function InitBBError(const AFileName : PathStr; bAppend : Boolean) : Boolean;
IMPLEMENTATION USES {$IFNDEF MsDos}WINAPI , {$ENDIF}{$IFNDEF Windows}BBFILE , {$ENDIF}BBGUI , BBUTIL ;
FUNCTION GETLOGICALADDR (ADDR:POINTER):POINTER ;ASSEMBLER;ASM {} {$IFNDEF MsDos} {} MOV DX , WORD PTR ADDR+ 2 {}
CMP DX , 0 {} JE @@end {} VERR DX {} JE @@selok {} XOR DX , DX {} JMP @@end {} @@selok : {} MOV ES , DX {}
MOV DX , WORD PTR ES : [ 0 ] {} @@end : {} MOV AX , WORD PTR ADDR{} {$ENDIF} {} {$IFDEF MsDos} {}
MOV CX , WORD PTR ADDR{} MOV BX , WORD PTR ADDR+ 2 {} MOV AX , OVRLOADLIST{} @@0 : {} OR AX , AX {} JE @@3 {}
MOV ES , AX {} MOV AX , ES : WORD PTR 16 {} OR AX , AX {} JE @@1 {} SUB AX , BX {} JA @@1 {} NEG AX {} CMP AX , 1000h {}
JAE @@1 {} MOV DX , 16 {} MUL DX {} ADD AX , CX {} JC @@1 {} CMP AX , ES : WORD PTR 8 {} JB @@2 {} @@1 : {}
MOV AX , ES : WORD PTR 20 {} JMP @@0 {} @@2 : {} MOV CX , AX {} MOV BX , ES {} @@3 : {} SUB BX , PREFIXSEG{}
SUB BX , 10h {} MOV AX , CX {} MOV DX , BX {} {$ENDIF} {} END;FUNCTION ISVALIDPTR (ADDR:POINTER):BOOLEAN ;ASSEMBLER;
ASM {} {$IFNDEF MsDos} {} XOR AX , AX {} MOV DX , WORD PTR ADDR+ 2 {} CMP DX , 0 {} JE @@exit {} VERR DX {} JNE @@exit {}
INC AX {} @@exit : {} {$ELSE} {} MOV AX , 1 {} {$ENDIF} {} END;PROCEDURE O100I0IOIOl (OOlIl0OOIIOO:POINTER;
O100llIl00IOl:WORD);FAR;VAR O101O01III1II:WORD;O100Ol00I:POINTER;OI11OO1I0:WORD;PROCEDURE O1011O1IO1O10
(OOlIl0OOIIOO:POINTER);BEGIN WITH PTRREC(OOlIl0OOIIOO) DO WRITELN (FERR , ' ', HEXSTR (SEG ), ':', HEXSTR (OFS ));END ;
FUNCTION OOIO11111111 :BOOLEAN ;VAR OOIl0I00O1O0:POINTER;BEGIN OOIO11111111 := FALSE ;IF O100Ol00I =NIL THEN EXIT ;
PTRREC (OOIl0I00O1O0 ). OFS := PTRREC (OOlIl0OOIIOO ). OFS ;{$IFDEF MsDos}PTRREC (OOIl0I00O1O0 ). SEG := OI11OO1I0 ;
{$ELSE}IF GETSELECTORLIMIT (OI11OO1I0 )<= PTRREC (OOIl0I00O1O0 ). OFS THEN EXIT ;PTRREC (OOIl0I00O1O0 ). SEG :=
ALLOCSELECTOR (OI11OO1I0 );IF PTRREC (OOIl0I00O1O0 ). SEG =0 THEN EXIT ;
{$ENDIF}WITH PTRREC(OOIl0I00O1O0) DO OOIO11111111 := (MEMW [ SSEG :O100llIl00IOl + 4 ] =O101O01III1II )OR ((OFS >= 5 )AND
(MEM [ SEG :OFS - 3 ] =$E8 )AND (MEM [ SEG :OFS - 5 ] <> $9A ));{$IFNDEF MsDos}FREESELECTOR (PTRREC (OOIl0I00O1O0 ). SEG
);{$ENDIF}END ;BEGIN IF NOT ISFILEOPEN (FERR )THEN EXIT ;LOGERROR ('**Stack dump. Callers shown only**');IF ODD
(O100llIl00IOl )THEN DEC (O100llIl00IOl );O101O01III1II := MEMW [ SSEG :O100llIl00IOl ] ;IF ODD (O101O01III1II )THEN DEC
(O101O01III1II );O100Ol00I := OOlIl0OOIIOO ;OI11OO1I0 := PTRREC (O100Ol00I ). SEG ;WHILE (O101O01III1II > O100llIl00IOl
)AND (MEMW [ SSEG :O100llIl00IOl ] <> 0 ) DO BEGIN PTRREC (OOlIl0OOIIOO ). OFS := MEMW [ SSEG :O100llIl00IOl + 2 ] ;IF
OOIO11111111 THEN PTRREC (OOlIl0OOIIOO ). SEG := PTRREC (O100Ol00I ). SEG ELSE BEGIN OI11OO1I0 := MEMW [ SSEG
:O100llIl00IOl + 4 ] ;PTRREC (OOlIl0OOIIOO ). SEG := MEMW [ SSEG :O100llIl00IOl + 4 ] ;OOlIl0OOIIOO := GETLOGICALADDR
(OOlIl0OOIIOO );IF OOlIl0OOIIOO =NIL THEN BREAK ;{$IFNDEF MsDos}IF PTRREC (OOlIl0OOIIOO ). SEG =0 THEN PTRREC
(OOlIl0OOIIOO ). SEG := PTRREC (O100Ol00I ). SEG ;{$ENDIF}END ;O100llIl00IOl := O101O01III1II ;O1011O1IO1O10
(OOlIl0OOIIOO );O101O01III1II := MEMW [ SSEG :O100llIl00IOl ] ;IF ODD (O101O01III1II )THEN DEC (O101O01III1II );
O100Ol00I := OOlIl0OOIIOO ;END ;FLUSH (FERR );END ;PROCEDURE LOGERROR (CONST S:STRING );VAR OIOO:INTEGER;BEGIN IF
ISFILEOPEN (FERR )THEN BEGIN OIOO := IORESULT ;WRITELN (FERR , GETDATESTR , ' ', GETTIMESTR , ' ', S );FLUSH (FERR );
END ;END ;PROCEDURE O10O0I0llIOl0 (O100llIl00IOl:WORD);FAR;BEGIN WRITE (FERR , GETDATESTR , ' ', GETTIMESTR , ' ');
WRITE (FERR , 'Errorcode = ', EXITCODE , ' ');WRITELN (FERR , 'Erroraddr = ', HEXSTR (PTRREC (ERRORADDR ). SEG ), ':',
HEXSTR (PTRREC (ERRORADDR ). OFS ));WRITELN (FERR , 'MaxAvail = ', MAXAVAIL );WRITELN (FERR , 'MemAvail = ', MEMAVAIL );
DUMPSTACK (ERRORADDR , O100llIl00IOl );CLOSE (FERR );APPEND (FERR );INFOBOX (FATALERRORTEXT + STRW (EXITCODE ), 0 );
END ;VAR O1lO11Il00lI:POINTER;PROCEDURE OIO0OO1100O ;FAR;VAR OIOO:WORD;OIO1OO11I1:WORD;BEGIN ASM {} MOV AX , BP {}
SHR AX , 1 {} SHL AX , 1 {} MOV OIO1OO11I1, AX {} END;EXITPROC := O1lO11Il00lI ;OIOO := IORESULT ;IF (EXITCODE =0 )OR
(ERRORADDR =NIL )THEN BEGIN LOGERROR ('MemAvail when program ended: '+ STRL (MEMAVAIL ));WRITELN (FERR ,
'Program ended on ', GETDATESTR , ' at ', GETTIMESTR );CLOSE (FERR );EXIT ;END ;HANDLERUNTIMEERROR (OIO1OO11I1 );CLOSE
(FERR );END ;{$IFNDEF MsDos}FUNCTION O1011I1OlOIO1 (OI1OIIIl0lO1:WORD):INTEGER ;FAR;BEGIN O1011I1OlOIO1 := 1 ;END ;
{$ENDIF}FUNCTION INITBBERROR (CONST AFILENAME:PATHSTR;BAPPEND:BOOLEAN):BOOLEAN ;BEGIN INITBBERROR := FALSE ;O1lO11Il00lI
:= EXITPROC ;EXITPROC := @ OIO0OO1100O ;DUMPSTACK := O100I0IOIOl ;HANDLERUNTIMEERROR := O10O0I0llIOl0 ;ASSIGN (FERR ,
AFILENAME );IF (NOT BAPPEND )OR (NOT FILEEXIST (AFILENAME ))THEN REWRITE (FERR )ELSE APPEND (FERR );IF IOERROR (AFILENAME
, 0 )THEN EXIT ;WRITELN (FERR );WRITELN (FERR , '** Program started on ', GETDATESTR , ' at ', GETTIMESTR , ' **');
{$IFNDEF MsDos}HEAPERROR := @ O1011I1OlOIO1 ;{$ENDIF}INITBBERROR := IORESULT =0 ;END ;END .
