home *** CD-ROM | disk | FTP | other *** search
/ CD/PC Actual 4 / CD_ACTUAL_4.iso / share / dos / programa / tmtpldos / tmtpldos.exe / SOURCES / DEBUG.PAS
Encoding:
Pascal/Delphi Source File  |  1996-07-24  |  1.4 KB  |  54 lines
  1. Unit Debug;
  2.  
  3. Interface
  4.  
  5.     Procedure print_call_stack (ebp, eip: dword; args: integer; skip: integer);
  6.  
  7. Implementation
  8.  
  9.     Uses strings, errcodes;
  10.  
  11.     procedure runerr_call_stack_proc (code, ebp, eip: dword);
  12.     begin
  13.         writeln (hex (ebP), ' ', hex (eip));
  14.         WriteLn ('RunError #', code, ' (', error_msg (code), ')');
  15.         print_call_stack (ebp, eip, 7, 0);
  16.     end;
  17.  
  18.     Procedure print_call_stack;
  19.         procedure print_frame;
  20.             var i: integer;
  21.         begin
  22.             write (hex (eip), ':');
  23.             for i := 1 to args do begin
  24.                 if ebp = 0 then begin write (' ** unavailable **'); break; end;
  25.                 write (' ', hex (memd [ebp+4+i*4]));
  26.             end;
  27.             writeln;
  28.         end;
  29.  
  30.         function next_frame: boolean;
  31.         begin
  32.             next_frame := false;
  33.             if (ebp <> 0) and (memd [ebp] <> ebp) then begin
  34.                 eip := memd [ebp+4];
  35.                 ebp := memd [ebp];
  36.                 next_frame := true;
  37.             end;
  38.         end;
  39.     Begin
  40.         repeat
  41.             if skip = 0 then begin
  42.                 writeln ('Calls stack:');
  43.                 writeln ('EIP       Args:');
  44.             end;
  45.             dec (skip);
  46.             if skip < 0 then print_frame;
  47.         until not next_frame;
  48.     End;
  49.  
  50. Begin
  51.     {$system}
  52.     System.%runerr_call_stack_proc_addr := @runerr_call_stack_proc;
  53. End.
  54.