[Back to MEMORY SWAG index] [Back to Main SWAG index] [Original]
{---------------------------------------------------------}
{ Project : Call Stack Reporter }
{ Auteur : Ir. G.W. van der Vegt }
{ Hondsbroek 57 }
{ 6121 XB Born }
{---------------------------------------------------------}
{ Datum .tijd Revisie }
{ 920713.2100 Creatie. }
{ 920715.2330 Trace at normal exit (exitcode=0) removed.}
{ 920805.2230 Path removed from filename in trace }
{ 920806.2200 Blanks filled in, RunTime Library routines}
{ now traced to. }
{ 921026.2000 Textmode(lastmode) added to default }
{ Csr_report. Objects & overlay tracing }
{ tested. }
{ 921118.1400 Exitcode doesn't trigger trace anymore }
{ 931114.1430 Keyboard flush in exitprocedure }
{ 940201.2200 Made independed of Routines. }
{---------------------------------------------------------}
{ To do Trace Virtual Methode Table (VMT) }
{---------------------------------------------------------}
{$D+}
{$L+}
{---------------------------------------------------------}
{----This unit gives the line numbers & filenames at error}
{ The result is a list of the call stack as produced by}
{ the Turbo Pascal IDE. }
{ }
{ The internal text mode report function can be }
{ replaced by another one located in your program. }
{ This could be a graphics mode or printer version. It }
{ must be compiled far (so use $F+ & $F- around it. }
{ It's called once for each call level. }
{ }
{ This program parses the MAP file to obtain the }
{ line numbers. It searches for the MAP file in the }
{ programs startup directory as obtained by }
{ PARAMSTR(0). }
{---------------------------------------------------------}
{ To obtain all possible info compile with the }
{ following setting : }
{ }
{ OPTIONS/LINKER/MAP FILE = DETAILED }
{ OPTION/COMPILE/DEBUG INFO = ON }
{ }
{ The last can also be forced by the $D+ compiler }
{ directive . }
{ }
{ This version traces procedures, functions through }
{ the main program and it's (overlayed) units. It also }
{ traces static methodes but not virtual methodes. }
{ When tracing static methodes a phantom entry with }
{ an call address located oon the heap is generated. }
{ The trace is stopped at the first call to a virtual }
{ methode. In a future version VMT tracing will be }
{ added as soon as I start using virtual methodes. }
{---------------------------------------------------------}
UNIT CSR_01;
INTERFACE
{---------------------------------------------------------}
{----TYPES }
{---------------------------------------------------------}
TYPE
Csr_repfunc = PROCEDURE(level : Word;csr : STRING);
{---------------------------------------------------------}
{----VARIABLES }
{---------------------------------------------------------}
VAR
Csr_reporter : Csr_repfunc;
{---------------------------------------------------------}
{----PROCEDURES/FUNCTIONS }
{---------------------------------------------------------}
PROCEDURE Csr_report(level : Word;csr : STRING);
{---------------------------------------------------------}
IMPLEMENTATION
Uses
CRT,
DOS;
VAR
ext : extstr;
dir : dirstr;
nam : namestr;
mapfile : BOOLEAN;
map : Text;
ft : BOOLEAN;
CONST
space = #32;
{---------------------------------------------------------}
{----SUPPORT PROCEDURES & FUNCTIONS }
{---------------------------------------------------------}
FUNCTION Istr(i,n : INTEGER;pad : CHAR) : STRING;
VAR
s : STRING;
BEGIN
Str(i:n,s);
IF (pad<>space)
THEN
WHILE (Pos(space,s)>0) DO
s[Pos(space,s)]:=pad;
Istr:=s;
END; {of Istr}
{---------------------------------------------------------}
FUNCTION Wstr(w : WORD;n : INTEGER) : STRING;
VAR
s : STRING;
BEGIN
Str(w:n,s);
Wstr:=s;
END; {of Wstr}
{---------------------------------------------------------}
FUNCTION Sstr(s : STRING;n : INTEGER) : STRING;
VAR
tmp : STRING;
BEGIN
tmp:=s;
IF n>=0
THEN WHILE (Length(tmp)<+n) DO Insert(space,tmp,1)
ELSE WHILE (Length(tmp)<-n) DO tmp:=tmp+space;
Sstr:=tmp;
END; {of Sstr}
{---------------------------------------------------------}
PROCEDURE Beep;
BEGIN
Sound(500);
Delay(20);
Nosound;
END; {of Beep}
{---------------------------------------------------------}
FUNCTION Word2Hex(w : Word) : STRING;
const
hexChars : array [0..$F] of Char = '0123456789ABCDEF';
begin
Word2Hex :=hexChars[Hi(w) shr 4]+hexChars[Hi(w) and $F]+
hexChars[Lo(w) shr 4]+hexChars[Lo(w) and $F];
end; {of Word2Hex}
{---------------------------------------------------------}
Function Hex2Word(h : String) : word;
const
hexChars : String[16] = '0123456789ABCDEF';
var
f : word;
begin
f := 0;
while length(h) > 0 do
begin
if pos(Copy(h,1,1),HexChars) = 0
then f := 0
Else f := (f*16)+pos(H[1],Hexchars)-1;
delete(h,1,1);
end;
Hex2Word:= f;
end; {of Hex2Word}
{---------------------------------------------------------}
FUNCTION Ptr2Hex(p : POINTER) : STRING;
BEGIN
IF (p=nil)
THEN Ptr2Hex := ' NIL '
else Ptr2Hex := Word2hex(Seg(P^))+':'+Word2hex(Ofs(P^));
END; {of Ptr2Hex}
{---------------------------------------------------------}
Procedure FlushKbd;
Begin
MemW[$40:$1C]:=MemW[$40:$1A];
End; {of Fluskkbd}
{---------------------------------------------------------}
{----STACK TRACE ROUTINES START HERE }
{---------------------------------------------------------}
FUNCTION BPreg : WORD;
INLINE($55/$58); {Push BP, Pop AX}
{---------------------------------------------------------}
Procedure Findlineno(first,near : BOOLEAN;dep : Word;p : Pointer);
VAR
tmp : String[80];
line : Integer;
adr : String[9];
ch : Char;
fn : STRING[80];
un : STRING[80];
errseg,
errofs : Word;
s,
lastun,
lastpr,
lastfn : STRING[80];
lastnr : Word;
call : STRING[4];
BEGIN
IF near
THEN call:='near'
ELSE call:='far ';
errseg:=Hex2word(Copy(Ptr2hex(p),1,4));
errofs:=Hex2word(Copy(Ptr2hex(p),6,4));
lastnr:=0;
lastfn:='';
lastpr:='';
lastun:='';
Assign(map,dir+nam+'.MAP');
{$I-} Reset(map); {$I+}
IF (IOResult=0)
THEN
BEGIN
{----Fist try on unit/program name}
s:='';
{
00000H 00096H 00097H VALTOREN CODE
Address Publics by Value
}
WHILE NOT(Eof(map) OR
(Pos('Publics by Value',s)>0) OR
(Pos('Line numbers' ,s)>0)) DO
BEGIN
Readln(map,s);
IF (Length(s)>=45) AND (s[7]='H')
THEN
BEGIN
IF (Errseg=Hex2Word(Copy(s,2,4))) {AND
(Copy(s,42,4)='CODE')}
THEN lastun:=Copy(s,23,18);
END;
END;
{----Strip Trailing Blanks}
WHILE (Length(lastun)>0) AND
(lastun[Length(lastun)]=#32) DO
Delete(lastun,Length(lastun),1);
{----Second Try to find procedure name}
s:='';
{
Address Publics by Value
0000:0000 @
000A:00CB MENU_INIT
}
WHILE NOT(Eof(map) OR
(Pos('Line numbers',s)>0)) DO
BEGIN
Readln(map,s);
IF (Length(s)>=18) AND (s[6]=':')
THEN
BEGIN
IF (Errseg=Hex2Word(Copy(s,2,4)))
THEN
BEGIN
IF (lastpr='')
THEN lastpr:=Copy(s,18,Length(s)-17)
ELSE
IF (Errofs>=Hex2Word(Copy(s,7,4)))
THEN lastpr:=Copy(s,18,Length(s)-17);
END;
END;
END;
{----Strip Trailing Blanks}
WHILE (Length(lastpr)>0) AND
(lastpr[Length(lastpr)]=#32) DO
Delete(lastpr,Length(lastpr),1);
{----Third try on line numbers & sourcefile names}
REPEAT
{
Line numbers for TEST_ERROR(TEST_ERR.PAS) segment TEST_ERROR
}
IF (Pos('Line numbers',s)>0)
THEN
BEGIN
Delete(s,1,17);
un:=Copy(s,1,Pos('(',s)-1);
Delete(s,1,Pos('(',s));
fn:=Copy(s,1,Pos(')',s)-1);
While Pos('\',fn)>0 DO Delete (fn,1,Pos('\',fn));
Readln(map);
REPEAT
{
15 0000:0008 16 0000:0017 18 0000:00C4 28 0000:00D2
}
Read(map,line);
Read(map,ch);
Read(map,adr);
IF (Errseg=Hex2Word(Copy(adr,1,4)))
THEN
BEGIN
lastfn:=fn;
IF (Errofs>=Hex2Word(Copy(adr,6,4)))
THEN lastnr:=line;
END;
If Eoln(map)
Then Readln(map);
UNTIL Eoln(map);
END;
IF NOT(eof(map))
THEN Readln(map,s);
UNTIL Eof(map) OR ((lastnr<>0) OR (lastfn<>''));
Close(map);
Beep;
IF (lastfn<>'') AND ((errseg<>0) OR (errofs<>0))
THEN
{----Report Line Number & Source File}
BEGIN
WHILE (length(lastfn)<12) DO Insert(#32,lastfn,1);
If first
THEN
Csr_reporter(dep,'Runtime error '+Istr(exitcode,3,'0')+
' in line '+Wstr(lastnr,4)+
' of '+lastfn+
' at '+Word2hex(errseg)+':'+Word2Hex(errofs)+'.')
ELSE
Csr_reporter(dep,' Called '+call+' from line '+Wstr(lastnr,4)+
' of '+lastfn+
' at '+Word2hex(errseg)+':'+Word2Hex(errofs)+'.');
END
ELSE
BEGIN
IF (lastun<>'') OR (lastpr<>'')
THEN
{----Report Unit/Program Name & Procedure name}
BEGIN
IF (Pos('@',lastpr)>0)
THEN s:=lastun+'.MAIN'
ELSE s:=lastun+'.'+lastpr;
WHILE (Length(s)>25) DO
Delete(s,Length(s),1);
If first
THEN
Csr_reporter(dep,'Runtime error '+Istr(exitcode,3,'0')+
' in '+Sstr(s,25)+
' at '+Word2hex(errseg)+':'+Word2Hex(errofs)+'.')
ELSE
Csr_reporter(dep,' Called '+call+' from '+Sstr(s,25)+
' at '+Word2hex(errseg)+':'+Word2Hex(errofs)+'.');
END
ELSE
{----Report Error Address Only}
BEGIN
If first
THEN
Csr_reporter(dep,'Runtime error '+Istr(exitcode,3,'0')+
' '+
' '+
' at '+Word2hex(errseg)+':'+Word2Hex(errofs)+'.')
ELSE
Csr_reporter(dep,' Called '+call+' from line '+
' '+
' at '+Word2hex(errseg)+':'+Word2Hex(errofs)+'.');
END;
END;
END
ELSE
{----Report Error Addres Only}
Csr_reporter(dep,'Runtime error '+Istr(exitcode,0,'0')+
' at '+Word2hex(errseg)+':'+Word2Hex(errofs)+'.')
END; {of Findlineno}
{---------------------------------------------------------}
{$F+}
VAR
exitsave : POINTER;
PROCEDURE Myexit;
VAR
ch : Char;
cdiv,
csmin,
cs,
sp,
ss : WORD;
p : Pointer;
dep : WORD;
j : INTEGER;
BEGIN
Flushkbd;
Exitproc:=exitsave;
IF (exitcode=0) OR (erroraddr=NIL) THEN Exit;
sp:=BPreg;
ss:=SSeg;
{----Calculate calling depth}
dep:=0;
p:=Ptr(ss,sp);
WHILE MemW[ss:Ofs(p^)]<>0 DO
BEGIN
IF (Mem[cs:MemW[ss:Ofs(p^)+2]-3]<>$E8)
THEN cs:=MemW[ss:Ofs(p^)+4];
p:=Ptr(ss,MemW[ss:Ofs(p^)]);
Inc(dep);
END;
p:=Ptr(ss,sp);
cdiv :=Cseg-cs;
csmin:=cs;
cs :=Cseg;
{----Report Runtime address}
Findlineno(true,true,dep,erroraddr);
Dec(dep);
{----Calculate cseg at runtime error}
cs:=csmin+Seg(erroraddr^);
{----Prevent Turbo Pascal from reporting}
Erroraddr:=NIL;
If NOT(mapfile) THEN Exit;
{----Skip Runtime error handler entry}
IF (MemW[ss:Ofs(p^)]<>0)
THEN p:=Ptr(ss,MemW[ss:Ofs(p^)]);
{----Report Call Stack}
WHILE MemW[ss:Ofs(p^)]<>0 DO
BEGIN
{----Test for near call instruction 3 bytes before return address}
IF (Mem[cs:MemW[ss:Ofs(p^)+2]-3]=$E8)
{----Trace a near call}
THEN Findlineno(false,true,dep,Ptr(WORD(Cs+Cdiv-Cseg),MemW[ss:Ofs(p^)+2]-3))
ELSE
{----Trace a far call}
BEGIN
Cs:=MemW[ss:Ofs(p^)+4];
Findlineno(false,false,dep,Ptr(WORD(Cs+Cdiv-Cseg),MemW[ss:Ofs(p^)+2]-3));
END;
{----Increment stackpointer}
p:=Ptr(ss,MemW[ss:Ofs(p^)]);
Dec(dep);
END;
END; {of Myexit}
{---------------------------------------------------------}
PROCEDURE Csr_report(level : Word;csr : STRING);
BEGIN
IF ft
THEN
BEGIN
Textmode(lastmode);
ft:=false;
END;
Writeln(csr+' (',level,')');
END; {of Csr_report}
{$F-}
{---------------------------------------------------------}
BEGIN
exitsave:=Exitproc;
exitproc:=@Myexit;
csr_reporter:=Csr_report;
Fsplit(Paramstr(0),dir,nam,ext);
Assign(map,dir+nam+'.MAP');
{$I-} Reset(map); {$I+}
IF (IOResult=0)
THEN
BEGIN
mapfile:=true;
Close(map);
END
ELSE mapfile:=false;
ft:=true;
END.
{ STACK UNIT NEEDED FOR CRS_01}
UNIT Stack1;
INTERFACE
PROCEDURE test2(VAR i : Integer);
IMPLEMENTATION
VAR
i : INTEGER;
{---------------------------------------------------------}
PROCEDURE test2(VAR i : Integer);
PROCEDURE test4(i : INTEGER);
VAR
tmp : Integer;
BEGIN
tmp:=0;
i:=1 div tmp;
END;
BEGIN
test4(i);
END;
{---------------------------------------------------------}
BEGIN
i:=1;
END.
{ ------------------------------- DEMO ------------------------}
{---------------------------------------------------------}
PROGRAM Csrtst;
USES
CRT,
Csr_01,
Stack1;
{---------------------------------------------------------}
PROCEDURE test3;
VAR
i : INTEGER;
BEGIN
test2(i);
END;
{---------------------------------------------------------}
PROCEDURE test4;
BEGIN
test3
END;
{---------------------------------------------------------}
BEGIN
clrscr;
test4;
END.
[Back to MEMORY SWAG index] [Back to Main SWAG index] [Original]