The Education Master 1994 (4th Edition)/EDUCATIONS_MASTER_4TH_EDITION.bin/files/progscal/tinypasc/tudbug.pas

Pascal/Delphi Source File | 1986-02-17 | 5.3 KB | 202 lines

  { TUDBUG:  Skeleton file debugging routines. }
  { Copyright (C) 1986 by QCAD Systems Inc., All Rights Reserved. }

  {******************}
  procedure WRSYMBOL(var SYM: symbol);
    { write out a symbol name. }
  begin
    write(rfile, sym);
    end;

  {******************}
  function WRTOK(TX: int): int;
    { writes the print name of the TX'th token, returning
      the number of characters output. }
    var TL: int;
  begin
    tx := tokx[tx];
    tl := 0;
    while tokchar[tx] <> chr(0) do begin
      write(rfile, tokchar[tx]);
      tx := tx+1;
      tl := tl+1
      end;
    wrtok := tl;
    end;

  {****************}
  procedure WRPROD(PRX: int);
    { write out the PRX'th production (a series of tokens). }
    var TL: int;
  begin
    prx := prodx[prx];
    tl := wrtok(prods[prx]);
    write(rfile, ' ->');
    prx := prx+1;
    while prods[prx]<>0 do begin
      write(rfile, ' ');
      tl := wrtok(prods[prx]);
      prx := prx+1;
      end
    end;

  {******************}
  procedure DUMP_SYM(INDENT: int; SYMP: symtabp;
                     NTAG: string31);
    { output information on the given symbol table entry.  this can
      be extended to handle user-defined symbol types (e.g. functions
      and variables). }
  begin
    if symp<>nil then
    with symp^ do begin
      writeln(rfile);
      write(rfile, ' ':indent, ntag, ': ');
      wrsymbol(sym);
      write(rfile, ' (', sym_names[symt], ')');
      case symt of
        var_type: write(rfile, ' VADDR=', vaddr:1);
        func_type:
          write(rfile, ' FADDR=', faddr:1, ' PBYTES=', pbytes:1,
                       ' IS_ACTUAL=', is_actual,
                       ' IS_SYSTEM=', is_system);
        ELSE ;
        end
      end
    end;

  {*****************}
  procedure DUMP_SEM(INDENT: int; SEMSTK: semrecp;
                     NTAG: string31);
    { output a semantic stack record. }
  begin
    if semstk<>nil then
    with semstk^ do begin
      writeln(rfile);
      write(rfile, ' ':indent);
      write(rfile, sem_names[semt], ': ');
      case semt of
        other:  ;
        ident:  dump_sym(indent+2, symp, 'symp');
        fixed:  write(rfile, numval:1);
        ELSE  write(rfile, ' ... user form')
        end
      end
    end;

  {*********************}
  procedure STK_DUMP(KIND: string8;  var STACK: state_stack;
                     STACKX: int;  CSTATE: int);
    { produce a symbolic dump of the parser stack. }
    var SX, TL, LL: int;
  begin
    if debug>2 then begin
      write(rfile, kind {, ', state ', cstate:1} );
      if cstate>=readstate then begin
        write(rfile, ', on token ');
        tl := wrtok(token);
        end;
      writeln(rfile, ', memavail ', memavail:1);
      end;
    if cstate<readstate then begin
      { reduce state }
      if debug>1 then begin  {complete stack dump}
        if tos>15 then begin
          writeln(rfile, '  ###');
          sx := tos-15;
          end
        else
        sx := 1;
        while sx<=tos do begin
          tl:=0;
          write(rfile, tos-sx:3, ': ');
          tl:=tl+5;
         {write(rfile, stack[sx]:3, ' ');
          tl:=tl+4; }
          if sx=tos then
            tl := tl+wrtok(insym[cstate])
          else
          tl := tl+wrtok(insym[stack[sx+1]]);
          dump_sem(6, sem[sx], '');
          writeln(rfile);
          sx:=sx+1;
          end
        end;
      wrprod(cstate);
      writeln(rfile)
      end;
    { don't let this roll off the top of the screen }
    idebug
    end;

  {****************}
  procedure IDEBUG;
    { interactive debugging support }
    var QUIT:  boolean;

    {..................}
    procedure SHOW_SYM;
      label 1;
      { asks for a symbol, then dumps the symbol table entry for it }
      var SP:  symtabp;
          LINE:  string80;
          SX:  integer;
    begin
      1:
      write('What symbol? ');
      readln(line);
      if length(line)>sizeof(symbol) then goto 1;
      sp := findsym(symtab, line);
      if sp<>nil then
        dump_sym(0, sp, '')
      else
        writeln('Unknown symbol');
      writeln;
      end;

    {.................}
    procedure DUMP_ALL;
      { show everything in the symbol table }
      var HX: int;
          SP: symtabp;
    begin
      for hx := 0 to hlimit do begin
        sp := symtab[hx];
        while sp<>nil do begin
          with sp^ do begin
            if not (symt in [reserved, symerr]) then begin
              { report only the nontrivial stuff }
              wrsymbol(sym);
              write(rfile, ' ');
              end;
            sp := next
            end
          end
        end;
      writeln(rfile);
      end;

    {................}
    procedure SET_DEBUG;
      { prompts for a debug level number }
    begin
      write('Set debug level to (0, 1, ...)? ');
      readln(debug);
      end;

  begin { idebug }
    quit := false;
    while not quit do begin
      writeln('Trace is ', trace);
      case upcase(resp(
  'I(dentifier, D(ebug level, A(ll symbols, T(race, C(ontinue? ')) of
        'I':  show_sym;
        'A':  dump_all;
        'D':  set_debug;
        'C':  quit := true;
        'T':  trace := not(trace);
        ELSE ;
        end
      end
    end { idebug };