{$W- }
program intprint (input, output, int, dat, lst);
{INTPRINT: print the intermediate code and data
 files written by pass 1 of the NBS Pascal compiler.
 
 08 Jun 79 - Bill Heidebrecht, TRW DSSG
 Corresponds to NBS Pascal compiler version 1.5g.
 Revised 23 Oct 80 for version 1.6g.
 18-Oct-83 by Paul Lustgraaf for RT-11 V1.6G
 
 This version of INTPRINT asks the user
 to select the procedures to be printed.
 Allowed user responses are:
  Y - print the current procedure;
  N - do not print;
  E - wrapup files and exit.
 } 
var
  nch: integer;
  PrintData, SelectProcs, prnt, done: boolean;
  ch: char;
  int, dat, lst: text;
 
 
procedure nextch;
begin
  ch := int@;
  nch := ord(ch);
  get(int)
end {nextch};
 
procedure outmne (opcode: integer);
const mtabsize = 179;
type mtabtype = array [0..mtabsize] of array [0..4] of char;
const mtab = mtabtype(                                             {opcode}
  'nop  ','xch  ','del  ','optn ','error','ident','proc ','end  ', {0 - 7}
  'null ','refer','stol ','stor ','stof ','error','error','error', {8 - 15}
  'succ ','pred ','error','error','error','error','error','error', {16 - 23}
  'uceq ','ucne ','ucgt ','ucle ','ucge ','uclt ','umax ','umin ', {24 - 31}
  'iadd ','isub ','imul ','idiv ','imod ','isqr ','error','error', {32 - 39}
  'ineg ','iabs ','iodd ','error','ceil ','floor','error','error', {40 - 47}
  'error','error','error','error','error','error','error','error', {48 - 55}
  'iceq ','icne ','icgt ','icle ','icge ','iclt ','imax ','imin ', {56 - 63}
  'fadd ','fsub ','fmul ','fdiv ','error','fsqr ','error','error', {64 - 71}
  'fneg ','fabs ','float','trunc','round','error','error','error', {72 - 79}
  'error','error','error','error','error','error','error','error', {80 - 87}
  'fceq ','fcne ','fcgt ','fcle ','fcge ','fclt ','fmax ','fmin ', {88 - 95}
  'not  ','error','error','error','error','error','error','error', {96 - 103}
  'eqv  ','xor  ','nimp ','rimp ','imp  ','nrimp','or   ','and  ', {104 - 111}
  'compl','union','inter','sdiff','error','sgens','sadel','empty', {112 - 119}
  'sceq ','scne ','scgt ','scle ','scge ','sclt ','in   ','sany ', {120 - 127}
  'error','error','error','field','ofset','indir','index','movem', {128 - 135}
  'error','error','invok','error','rtemp','dtemp','error','error', {136 - 143}
  'if   ','case ','entry','loop ','exit ','for  ','error','error', {144 - 151}
  'seq  ','error','error','error','error','error','error','error', {152 - 159}
  'error','error','liter','rdata','litd ','error','error','error', {160 - 167}
  'vceq ','vcne ','vcgt ','vcle ','vcge ','vclt ','error','error', {168 - 175}
  'varbl','param','call ','error');                                {176 - 179}
 
begin {outmne}
  write(lst, mtab[opcode]:5, '  ')
end {outmne};
 
procedure outc (c: char);
begin
  if prnt then write(lst, c)
end {outc};
 
procedure out8;
{ output numeric value of 8 bit byte }
begin
  nextch; if prnt then write(lst, nch)
end {out8};
 
procedure out16;
{ output numeric value of 16 bit word }
var i: integer;
begin
  nextch; i := nch*256;
  nextch; if prnt then write(lst, nch+i)
end {out16};
 
procedure outlevel;
begin
  if prnt then write(lst, nch mod 16)
end {outlevel};
 
procedure outsize;
begin
  nextch;
  if prnt then write(lst, ':', nch)
end {outsize};
 
procedure outds;
begin
  outsize;
  outc(','); out16
end {outds};
 
procedure ask_user;
var ch: char;
begin
  write('?');
  readln(ch);
  prnt := (ch='Y') or (ch='y');
  if (ch='E') or (ch='e') then done := true
end {ask_user};
 
 
procedure scancode;
var
  i, n, opcode, opcode2: integer;
begin {scancode}
  writeln(lst, ' Code');
  writeln(lst, ' ----');
  writeln(lst);
  while not done do
  begin
    nextch;
    opcode := nch;
    if opcode > 223 then opcode2 := 179 {error}
      else if opcode > 207 then opcode2 := 178 {call}
      else if opcode > 191 then opcode2 := 177 {param}
      else if opcode > 175 then opcode2 := 176 {varbl}
      else opcode2 := opcode;
    if opcode2 = 5 {ident} then
    begin
      prnt := true;
      writeln(lst);
      write(lst,' ')
    end;
    if prnt then
    begin
      writeln(lst);
      write(lst,opcode:4,'  '); {print op code number}
      outmne(opcode2)                 {print mnemonic}
    end;
 
case opcode2 of
  0,1,2,4: ;
 
  3: begin {optn}
	out8;  outc(',');
	out16
     end;
 
  5: begin {ident}
       if SelectProcs then writeln;
       nextch; n := nch;
       outc('''');
       for i := 1 to n do
       begin
         nextch;
         write(lst,ch);
         if SelectProcs then write(ch)
       end;
       outc('''');
       if SelectProcs then ask_user
     end;
 
  6: {proc} out8;
 
  7: begin {end}
       out8;  outc(','); if nch=0 then done:=true;
       out8;  outc(',');
       out16; outc(',');
       out16; outc(',');
       out16
     end;
 
  8,9,10,11,12,13,14,15,16,17,18,19,20,
  21,22,23,24,25,26,27,28,29,30,31,32,33,34,
  35,36,37,38,39,40,41,42,43,44,45,46,47,48,
  49,50,51,52,53,54,55,56,57,58,59,60,61,
  62,63,64,65,66,67,68,69,70,71,72,73,74,75,
  76,77,78,79,80,81,82,83,84,85,86,87,88,89,
  90,91,92,93,94,95,96,97,98,99,100,
  101,102,103,104,105,106,107,108,109,110,
  111,112,113,114,115,116,117,118,119,120,
  121,122,123,124,125,126,127,128,129,130: ;
 
  131,132,133,134,135: {field,ofset,indir,index,movem}
     outds;
 
  136,137: ;
 
  138: begin {invok}
         out8; outc(','); out8
       end;
 
  139: ;
 
  140,141: out8; {rtemp,dtemp}
 
  142,143,144: ;
 
  145: begin {case}
         out8; outc(','); out8
       end;
 
  146,147,152: out8; {entry,loop,seq}
 
  148,149: ; {exit,for}
 
  150,151,153,154,155,156,157,158,159,160,161: ;
 
  162: out16; {liter}
 
  163: begin {rdata}
         out16
       end;
 
  164: begin {litd}
         for i := 1 to 3 do
         begin
           out16; outc(',')
         end;
         out16
       end;
 
  165,166,167,174,175: ;
 
  168,169,170,171,172,173: {vector ops}
      outds;
 
  176,177: begin {varbl,param}
             outlevel; outds
           end;
 
  178: begin {call}
         outlevel; outsize;
         outc('('); out8; outc(')');
         outc(','); out8
       end;
 
  179:
 
end {case};
 
    if eof(int) then done := true
  end {while not done}
 
end {scancode};
 
 
procedure scandata;
const nbytes = 8 {bytes printed per line};
var
  i, n, dataloc, lineloc: integer;
  bytes: array [1..nbytes] of char;
  ch, byt: char;
  allzero,finished: boolean;
begin {scandata}
  writeln(lst);
  writeln(lst);
  writeln(lst,' Data');
  writeln(lst,' ----');
  writeln(lst);
  dataloc := 0;
  lineloc := 0;
  finished := eof(dat);
  while not finished do
  begin
    n := 0;
    allzero := true;
    repeat {collect enough data for 1 line}
      ch := dat@; get(dat);
      dataloc := dataloc + 1;
      n := n + 1;
      bytes[n] := ch;
      if ch<>chr(0) then allzero:=false;
      finished := eof(dat);
    until finished or (n = nbytes);
    if (n > 0) and (not allzero) then
    begin {print the line}
      write(lst, lineloc:6, ': ');
      for i := 1 to n do
      {print bytes}
      begin
        byt := bytes[i];
        write(lst, ord(byt):4);
        if (byt >= ' ') and (byt <= '~')
          then write(lst, ' ''', byt, ''' ')
          else write(lst, '     ');
      end;
      writeln(lst);
    end {of print the line};
    lineloc := lineloc + n;
  end {while not finished};
  writeln(lst);
  write(lst,' *** eof ***');
end {scandata};
 
function yesno : boolean;
var ch : char;
begin
  readln(ch);
  yesno := (ch='Y') or (ch='y');
end; {yesno}

procedure options;
begin
  PrintData := false;
  SelectProcs := false;
  writeln('Do you wish to select which procedures to print?');
  if yesno then SelectProcs := true;
  writeln('Do you wish to print the data file?');
  if yesno then PrintData := true;
end {options};
 
procedure openfiles;
begin
  reset(int,"PASINT.TMP");
  rewrite(lst,"LP:ITP.LST",2)
end {openfiles};
 
begin {intprint}
  openfiles;
  options;
  done := eof(int); prnt := true;
  scancode;
  if PrintData then
  begin
    reset(dat,"PASDAT.TMP");
    scandata
  end;
  writeln(lst);
  writeln;
  writeln('end intprt')
end.