(**************************************************************
*                                                             *
*     Dieses Programm verfolgt die Ver{nderung einer          *
*                                                             *
*     Variablen innerhalb eines laufenden Programms           *
*                                                             *
*                                                             *
*     Christoph Meyer, Moltkestr 48a, 4400 Muenster           *
*                11.09.86                                     *
*                                                             *
**************************************************************)


{ you may include this source anywhere in YOUR source }

{$U-,I-,R-}   { do not trace this part, don't change that! }

{ REQUIRES COMPILING THE MAIN PROGRAM WITH U+ OPTION !! }


{ NOTE: you can NOT trace 'call by value' parameters because }
{ these parameters have no address !! }


{ procedure debugger_init                                     }
{       (a:integer; ty:db_types; c:db_compares; d,t:boolean); }
{  the parameters are:                                        }
{     a= address of variable      ty= type of this variable   }
{     c= comparsion               d = display each alteration }
{     t= trace up to value and show the statement in source   }
{    for type declarations see below                          }


const
  bs=^h;

type
  db_types    = (db_integer, db_byte, db_char, db_boolean);
           { types with may be traced in this Version         }

  db_compares = (eq, lt, gt, le, ge, neq);
           { trigger if value in address is (comp) tracevalue }

var
  trace_int   : integer;      {   set to values to trace for  }
  trace_byt   : byte;
  trace_chr   : char;
  trace_bool  : boolean;

  { internals }
  display,                    { display each new alteration   }
  trace       : boolean;      { trace for value according to  }
                              { comparator                    }
                              { and show in source if reached }

  rst38       : integer absolute $39;
  oldrst38    : integer;
  address     : integer;      { trace address                 }
  comp        : db_compares;  { determines tracevalue reached }
  typ         : db_types;     { type to trace                 }
  calling     : integer;      { address to go back after      }
                              { a RST38                       }
  db_int      : integer;
  db_byt      : byte;
  db_chr      : char;
  db_bool     : boolean;
  t_int       : ^integer;
  t_byt       : ^byte;
  t_chr       : ^char;
  t_bool      : ^boolean;

procedure hexbyte(b:byte);    { write b as hex byte to        }
                              { console, turbo  3.0           }
begin
 write('$');
 inline($3a/b/$cd/$b4/$04);
end;

procedure hexinteger(i:integer); { write b as 2-byte hex to   }
                                 { console, turbo 3.0         }
begin
  write('$');
  inline($2a/i/$cd/$af/$04);
end;

procedure clear(i:integer);
var
  j:integer;
begin
  for j:=1 to i do write(bs);
  for j:=1 to i do write(' ');
  for j:=1 to i do write(bs);
end;

procedure getnewval(t:db_types);
var
  i,e:integer;
  b:boolean;
  c:char;
  s:string[10];
begin
  cbreak:=false;      { undocumented turbo 3.0  feature:      }
                      { lokal (*$C-*) !!                      }
  write(' new value?:');
  case t of
    db_integer: begin
                  buflen:=6;
                  repeat
                    read(s);       { May be a hex  value,     }
                                   { eg: $1234                }
                    val(s,i,e);    { val allows '$' !!!       }
                    if e=0 then t_int^:=i
                    else clear(length(s));
                  until e=0;
                  clear(12+length(s));
                end;
    db_byte   : begin
                  buflen:=4;
                  repeat
                    read(s);
                    val(s,i,e);
                    if e=0 then t_byt^:=i
                    else clear(length(s));
                  until e=0;
                  clear(12+length(s));
                end;
    db_char   : begin
                  buflen:=1;
                  read(t_chr^);
                  clear(13);
                end;
    db_boolean: begin
                  buflen:=1;
                  repeat
                    read(c);
                    c:=upcase(c);
                    if c='T' then t_bool^:=true
                    else if c='F' then t_bool^:=false
                    else clear(1);
                  until c in ['T','F'];
                  clear(13);
                end;
  end;
  cbreak:=true;
end;

procedure show_val(t:db_types);
begin
  write('Value:');
  case t of
    db_integer : begin
                   hexinteger(t_int^);
                   write('/');
                   write(t_int^:6);
                 end;
    db_byte    : begin
                   hexbyte(t_byt^);
                   write('/');
                   write(t_byt^:4);
                 end;
    db_char    : begin
                   if (ord(t_chr^)>=20) and
                      (ord(t_chr^)<128) then write(t_chr^)
                   else write(' ');
                   write(' ');
                   hexbyte(ord(t_chr^));
                 end;
    db_boolean : write(t_bool^:5);
  end;
end;

function query(t:db_types):boolean;
var
  ch:char; 
begin
  read(kbd,ch);
  ch:=upcase(ch);
  if ch=#27 then begin
    query:=true;
    exit;
  end else if ch='Q' then display:=false
  else if ch='S' then getnewval(t);
  case t of
    db_integer : clear(18);
    db_byte    : clear(14);
    db_char    : clear(11);
    db_boolean : clear(11);
  end;
  query:=false;
end;

function db_compare(t:db_types; c:db_compares):boolean;
var
  yes:boolean;
begin
  yes:=false;
  case c of
    eq : case t of
           db_integer  : yes:=trace_int = t_int^;
           db_byte     : yes:=trace_byt = t_byt^;
           db_char     : yes:=trace_chr = t_chr^;
           db_boolean  : yes:=trace_bool = t_bool^;
         end;
    lt : case t of
           db_integer  : yes:=trace_int > t_int^;
           db_byte     : yes:=trace_byt > t_byt^;
           db_char     : yes:=trace_chr > t_chr^;
           db_boolean  : yes:=trace_bool > t_bool^;
         end;
    gt : case t of
           db_integer  : yes:=trace_int < t_int^;
           db_byte     : yes:=trace_byt < t_byt^;
           db_char     : yes:=trace_chr < t_chr^;
           db_boolean  : yes:=trace_bool < t_bool^;
         end;
    ge : case t of
           db_integer  : yes:=trace_int <= t_int^;
           db_byte     : yes:=trace_byt <= t_byt^;
           db_char     : yes:=trace_chr <= t_chr^;
           db_boolean  : yes:=trace_bool <= t_bool^;
         end;
    le : case t of
           db_integer  : yes:=trace_int >= t_int^;
           db_byte     : yes:=trace_byt >= t_byt^;
           db_char     : yes:=trace_chr >= t_chr^;
           db_boolean  : yes:=trace_bool >= t_bool^;
         end;
   neq : case t of
           db_integer  : yes:=trace_int <> t_int^;
           db_byte     : yes:=trace_byt <> t_byt^;
           db_char     : yes:=trace_chr <> t_chr^;
           db_boolean  : yes:=trace_bool <> t_bool^;
         end;
  end;
  db_compare:=yes;
end;

procedure debugger_init
          (a:integer; ty:db_types; c:db_compares; d,t:boolean);
begin
  address:=a;
  typ:=ty;
  display:=d;
  trace:=t;
  comp:=c;
  oldrst38:=rst38;
end;

procedure debugg;
label
  leave;  { sorry, but it's so easy }
var
  zeige:boolean;
begin
  inline(          (*    ; get calling address from stack    *)
  $E3/             (*    ex      (sp),hl         ; get addr  *)
  $22/calling/     (*    ld      (calling),hl    ; save addr *)
  $E3/             (*    ex      (sp),hl         ; back      *)
  $F5/             (*    push    af              ; save all  *)
  $C5/             (*    push    bc                          *)
  $D5/             (*    push    de                          *)
  $E5/             (*    push    hl                          *)
  $DD/$E5/         (*    push    ix                          *)
  $FD/$E5);        (*    push    iy                          *)
       { up to now, there was no reason to save    }
       { the other register set, too               }

  zeige:=false; { show only when value has changed }
  case typ of
    db_integer  : begin
                    t_int:=ptr(address);
                    zeige:=t_int^ <> db_int;
                  end;
    db_byte     : begin
                    t_byt:=ptr(address);
                    zeige:=t_byt^ <> db_byt;
                  end;
    db_char     : begin
                    t_chr:=ptr(address);
                    zeige:=t_chr^ <> db_chr;
                  end;
    db_boolean  : begin
                    t_bool:=ptr(address);
                    zeige:=t_bool^ <> db_bool;
                  end;
  end;

  if zeige then begin
    if display then begin
      show_val(typ);
      if query(typ) then goto leave;
    end;
    if trace then begin
      if db_compare(typ,comp) then begin
        writeln;
        write(^g'Trace value reached !');
        goto leave;
      end;
    end;
  end;

  case typ of  { store new value }
    db_integer  : db_int:=t_int^;
    db_byte     : db_byt:=t_byt^;
    db_char     : db_chr:=t_chr^;
    db_boolean  : db_bool:=t_bool^;
  end;

  inline(          (*  ; normal exit, restore register       *)
  $FD/$E1/         (*    pop     iy                          *)
  $DD/$E1/         (*    pop     ix                          *)
  $E1/             (*    pop     hl                          *)
  $D1/             (*    pop     de                          *)
  $C1/             (*    pop     bc                          *)
  $F1/             (*    pop     af                          *)
  $C9);            (*    ret                                 *)

  leave:
  inline(          (*  ; set runtime error and leave         *)
  $2A/calling/     (*    ld      hl,(calling)    ; address   *)
  $E5/             (*    push    hl              ; needed    *)
  $3E/$33/         (*    ld      a,033h     ; my runtime-err *)
  $C3/$27/$20);    (*    jp      goturbo                     *)

end;

procedure debugger_on;
begin
  rst38:=addr(debugg);
end;

procedure debugger_off;
begin
  rst38:=oldrst38;
end;

{$U+,I+,R+}  { now trace again }