Simtel MSDOS 1992 June/SIMTEL_0692.cdr/msdos/pascal/qparser.arc/CALCDBUG.PAS

Pascal/Delphi Source File | 1985-07-26 | 6KB | 217 lines

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

  {******************}
  procedure WRSTRING(STX: int);
    { writes a string to the report file, stored at
      stx in the string table. }
  begin
    while strtab[stx]<>chr(eos) do begin
      write(rfile, strtab[stx]);
      stx := stx+1;
    end
  end;

  {******************}
  procedure WRSYMBOL(var SYM: symbol);
    { write out a symbol name. }
    var SX: int;
  begin
    sx := 1;
    while (sx <= maxtoklen) and (sym[sx] <> ' ') do begin
      write(rfile, sym[sx]);
      sx := sx+1
    end
  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 IDEBUG;  forward;

  {******************}
  procedure DUMP_SYM(INDENT: int; SYMP: symtabp);
    { 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
      write(rfile, ' ':indent);
      wrsymbol(sym);
      write(rfile, ' (', symtypename[symt], ' ', level:1, ' ');
      case symt of
        reserved, symerr: ;
        user:     write(rfile, 'undeclared');
        { add application-specific type cases here }
        {========= added real_variable for calcskel ===============}
        real_variable: write(rfile, rval);
        ELSE  write(rfile, 'other type')
      end;
      write(rfile, ')');
    end
  end;

  {*****************}
  procedure DUMP_SEM(INDENT: int; SEMSTK: semrecp);
    { output a semantic stack record. }
  begin
    if semstk<>nil then begin
      with semstk^ do begin
        write(rfile, ' ': indent);
        write(rfile, semtypename[semt], ': ');
        case semt of
          other:  ;
          strng:  wrstring(stx);
          ident:  dump_sym(indent+2, symp);
          fixed:  write(rfile, numval:1);
          float:  write(rfile, rval:10);
          ELSE    write(rfile, ' ... user form')
        end
      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 stackx>15 then begin
          writeln(rfile, '  ###');
          ll := stackx-15;
        end
        else
        ll := 1;
        for sx := ll to stackx do begin
          write(rfile, ' ' {, stack[sx]:3, ' '} );
          if sx=stackx then
            tl := wrtok(insym[cstate])
          else
          tl := wrtok(insym[stack[sx+1]]);
          write(rfile, ' ':maxtoklen-tl+1);
          dump_sem(0, semstack[sx]);
          writeln(rfile);
        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;
      { asks for a symbol, then dumps the symbol table entry for it }
      var SP:  symtabp;
          STR:  symbol;
          LINE:  string80;
          SX:  int;
    begin
      write('What symbol? ');
      readln(line);
      for sx := 1 to maxtoklen do
        str[sx] := ' ';
      for sx := 1 to length(line) do
        str[sx] := upshift(line[sx]);
      sp := findsym(str);
      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
      case upshift(resp(
           'I(dentifier, D(ebug level, A(ll symbols, C(ontinue? ')) of
        'I':  show_sym;
        'A':  dump_all;
        'D':  set_debug;
        'C':  quit := true;
      ELSE ;
      end
    end
  end { idebug };