(*
                               P CODE INTERPRETER
                               ------------------
                                        
                              for UCSD Pascal I.5
                              -------------------
*)

(*$C Copyright 1981 Chris Wilson *)
(* copied from Call A.P.P.L.E. in depth vol 2: Pascal. *)

program decode;

const
  esc = 27;

type
  word = packed record
           case integer of
               0: (b: packed array[0..1] of 0..255);
               1: (c: packed array[0..1] of char);
               2: (h: packed array[0..3] of 0..15);
               3: (i: integer);
               4: (p: ^ word)
         end;

  mtypes = (undef,pcodemost,pcodeleast,
            pdp11,m8080,z80,ga440,m6502,
            m6800,ti9900);

  sdrecord = record
               diskinfo: array[0..15] of
                           record
                             codeleng,
                             codeaddr: integer
                           end;
              segname: array[0..15] of
                         packed array[0..7] of char;
              segkind: array[0..15] of
                         (linked,hostseg,
                         segproc,unitseg,
                         seprtseg,unlinkedintrins,
                         linkedintrins,dataseg);
             textaddr: array[0..15] of integer;
              seginfo: packed array [0..15] of
                         packed record
                           segnum: 0..255;
                            mtype: mtypes;
                           unused: 0..1;
                          version: 0..7
                         end;
            end;

freeunion = record
                case integer of
                  1: (buf: packed array[0..511] of 0..255);
                  2: (dict: sdrecord)
            end;

  string1 = packed array[0..1] of char;

  string3 = packed array[0..3] of char;

  string7 = string[7];

    ptype = (ub,sb,db,b,w,x0,x1,x2,x3,x4,x5,x6,x7,xx);

    oprec = record
              mnemonic: string[7];
                    p1,
                    p2: ptype
            end;

var  pdcount,
   firstaddr,
  firstblock,
currentblock: integer;
        addr: string3;
           f: text;
  sourcefile: file;
  sourcename,
    destname: string;
      opcode: array[0..255] of oprec;
         buf: packed array[0..511] of 0..255;
          sd: freeunion;
          pd: array[0..149] of integer;
    hexdigit: packed array[0..15] of char;

  function typespace:boolean;

  var
    ch:char;
    
  begin
    if destname = 'console:'
      then
        begin
          writeln;
          write('<space> to continue ');
          {unitclear(1);}
          reset(keyboard);
          repeat
            read(keyboard,ch)
          until (ch = ' ') or (ch = chr(esc));
          typespace:=ch = ' ';
          writeln;
        end
      else typespace:=true;
  end; (* of typespace *)

  procedure skip;

  begin
    if destname = 'console:'
      then page(f)
      else writeln(f)
  end; (* of skip *)

  procedure int(s:string; var i:integer);
    
    var
      p:integer;
      t:real;
    
    begin
      while pos(' ',s) > 0
        do delete(s,pos(' ',s),1);
      p:=1;
      while (p <= length(s))
        do
          begin
            if not (s[p] in ['0'..'9'])
              then delete(s,p,1)
              else p:=p+1;
          end;
      t:=0;
      while (length(s) > 0)
        do
          begin
            p:=ord(s[1]) - ord('0');
            t:=( t * 10 ) + p;
            delete(s,1,1);
          end;
      if t > maxint
        then t:=maxint;
      if t < -maxint
        then t:=-maxint;
      i:=trunc(t);
    end;{int}

  procedure readblock(loc: integer);

  begin
    if loc < firstaddr then
      repeat
        currentblock:=pred(currentblock);
        firstaddr:=firstaddr-512
      until loc >= firstaddr
    else if loc >= (firstaddr+512) then
      repeat
        currentblock:=succ(currentblock);
        firstaddr:=firstaddr+512
      until loc < (firstaddr+512);
    if blockread(sourcefile,buf,1,currentblock) <> 1 then 
    begin
      writeln('blockread: error in reading sourcefile');
      exit(decode)
    end
  end; (* of readblock *)

  function byteval(loc:integer): integer;

  begin
    if (loc >= firstaddr) and (loc < firstaddr+512) then
      byteval:=buf[loc - firstaddr]
    else
      begin
        readblock(loc);
        byteval:=byteval(loc)
      end
  end; (*of byteval *)

  function wordval(loc: integer):integer;

  var  w:word;

  begin
    w.b[0]:=byteval(loc);
    w.b[1]:=byteval(succ(loc));
    wordval:=w.i
  end;

  procedure hexbyte(value: integer; var hex: string1);

  var w:word;

  begin
    w.i:=value;
    hex[0]:=hexdigit[w.h[1]];
    hex[1]:=hexdigit[w.h[0]]
  end; (* of hexbyte *)

  procedure hexword(value: integer; var hex: string3);

  var w:word;

  begin
    w.i:=value;
    hex[0]:=hexdigit[w.h[3]];
    hex[1]:=hexdigit[w.h[2]];
    hex[2]:=hexdigit[w.h[1]];
    hex[3]:=hexdigit[w.h[0]]
  end;  (* of hexword *)

  procedure decodeproc(proc: integer); 

  var
    lastipcret,   (* sabmod - ipc when wait last invoked *)
    l_count,      { line count rws}
    ipc,
    jtab,
    lexlevel,
    enteric,
    exitic,
    paramsize,
    datasize,
    lastcode:integer;
    bythex:string1;
    hex:string3;

    procedure oneop; 

    var      i,
           min,
           max:integer;
          byte:string1;
           hex:string3;

      procedure handledb; 

      begin
        ipc:=succ(ipc);
        hexbyte(byteval(ipc),byte);
        write(f,byte:3)
      end;  (* of handledb *)

      procedure handleb;

      begin
        ipc:=succ(ipc);
        if byteval(ipc) > 127 then
        begin
          hexbyte(byteval(ipc)-128,byte);
          write(f,byte:3);
          ipc:=succ(ipc);
          hexbyte(byteval(ipc),byte);
          write(f,byte)
        end
        else
        begin
          hexbyte(byteval(ipc),byte);
          write(f,byte:3)
        end
      end; (* of handleb *)

      procedure handlew;

      begin
        hexbyte(byteval(ipc+2),byte);
        write(f,byte:3);
        hexbyte(byteval(ipc+1),byte);
        write(f,byte);
        ipc:=ipc+2
      end; (* of handlew *)

      procedure handlecsp;

      var s:string;

      begin
        s:='';
        case byteval(ipc) of
          0: s:= ' (iocheck)';
          1: s:= ' (new)';
          2: s:= ' (moveleft)';
          3: s:= ' (moveright)';
          4: s:= ' (exit)';
          5: s:= ' (unitread)';
          6: s:= ' (unitwrite)';
          7: s:= ' (idsearch)';
          8: s:= ' (treesearch)';
          9: s:= ' (time)';
         10: s:= ' (fillchar)';
         11: s:= ' (scan)';
         21: s:= ' (load resident segment ?)';
         22: s:= ' (release stack space ?)';
         23: s:= ' (trunc)';
         24: s:= ' (round)';
         25: s:= ' (sine)';
         26: s:= ' (cos)';
         27: s:= ' (log)';
         28: s:= ' (atan)';
         29: s:= ' (ln)';
         30: s:= ' (exp)';
         31: s:= ' (sqt)';
         32: s:= ' (mark)';
         33: s:= ' (release)';
         34: s:= ' (ioresult)';
         35: s:= ' (unitbusy)';
         36: s:= ' (pwroften)';
         37: s:= ' (unitwait)';
         38: s:= ' (unitclear)';
         39: s:= ' (halt)';
         40: s:= ' (memavail)'
        end; (* of case *)
        write(f,s)
      end; (* of handlecsp *)

      procedure handlecxp;

      var s:string;

      begin
        handledb;
        if byteval(pred(ipc)) = 0 then
        begin
          s:='';
          case byteval(ipc) of
            2: s:= ' (execerror)';
            3: s:= ' (build fib)';
            4: s:= ' (freeset)';
            5: s:= ' (fopen)';
            6: s:= ' (close)';
            7: s:= ' (get)';
            8: s:= ' (put)';
            9: s:= ' (xseek)';
           10: s:= ' (eof)';
           11: s:= ' (eoln)';
           12: s:= ' (read integer)';
           13: s:= ' (write integer)';
           14: s:= ' (read real)';
           15: s:= ' (write real)';
           16: s:= ' (read char)';
           17: s:= ' (write char)';
           18: s:= ' (read string)';
           19: s:= ' (write string)';
           20: s:= ' (write array of char)';
           21: s:= ' (readln)';
           22: s:= ' (writeln)';
           23: s:= ' (concat)';
           24: s:= ' (insert)';
           25: s:= ' (copy)';
           26: s:= ' (delete)';
           27: s:= ' (pos)';
           28: s:= ' (block read/write)';
           29: s:= ' (gotoxy)'
          end; (* of case *)
          write(f,s)
        end
      end; (* of handlecxp *)

    begin (* oneop *)
      write(f,'{ '); {for inverse compilation activities}
      with opcode[byteval(ipc)]
        do
          begin
            hexword(ipc,hex);
            hexbyte(byteval(ipc),byte);
            write(f,hex,' ',mnemonic,' (',byte,')',' ':7-length(mnemonic));
            case p1 of
              ub,sb,db: handledb;
                     b: handleb;
                     w: handlew
            end; (* of case *)
            case p2 of
              ub,sb,db: handledb;
                     b: handleb;
                     w: handlew;
                    x0: handlecsp;
                    x1: begin
                          (* lsa, lsp *)
                          write(f,' ''');
                          for i:=1 to byteval(ipc)
                            do
                              begin
                                ipc:=succ(ipc);
                                if i mod 59 = 0
                                  then
                                    begin
                                      writeln(f,'''');
                                      write(f,' ':21, '''')
                                    end;
                                if byteval(ipc) > 31
                                  then write(f,chr(byteval(ipc)))
                                  else write(f,'.');
                              end;
                          write(f,'''');
                        end;
                    x2: begin
                          (* XJP *)
                          if not odd(ipc) then
                            ipc:=succ(ipc);
                          handlew;
                          handlew;
                          handlew;
                          min:=wordval(ipc-5);
                          max:=wordval(ipc-3);
                          for i:= min to max
                            do
                              begin
                                writeln(f);
                                write(f,' ':19);
                                handlew;
                                hexword(pred(ipc)-wordval(pred(ipc)),hex);
                                write(f,' )',hex,')')
                              end
                        end;
                    x3: begin
                          (* equ etc *)
                          case byteval(ipc) of
                            2: write (f,' (real)');
                            4: write (f,' (string)');
                            6: write (f,' (boolean)');
                            8: write (f,' (set)');
                           10: begin
                                 handleb;
                                 write (f,' (byte array)')
                               end;
                           12: begin
                                 handleb;
                                 write (f,' (word)')
                               end
                          end (* of case *);
                        end;
                    x4: begin
                          (* LDC *)
                          max:=byteval(ipc);
                          if not odd(ipc)
                            then ipc:=succ(ipc);
                          for i:=1 to max
                            do
                              begin
                                writeln(f);
                                write(f,' ':19);
                                handlew
                              end
                        end;
                    x5: handlecxp;
                    x6: begin
                          (* fjp, ujp, efj, nfj *)
                          i:=byteval(ipc);
                          if i < 128 then
                            hexword(succ(ipc)+i,hex)
                          else
                          begin
                            i:=jtab-(256-i);
                            hexword(i-wordval(i),hex)
                          end;
                          write(f,' (',hex,')')
                        end;
                    x7: (* rnp,rbp *)
                        if ipc >= exitic then
                          lastcode:=ipc;
            end (* of case *)
          end; (* with *)
      write(f,' }'); {for inverse compilation activities}
      writeln(f);
    end; (* of oneop *)

  begin (* decodeproc *)
    jtab:=pd[proc];
    if jtab < 0
      then
        begin
          writeln;
          writeln('>>> procedure address bad! <<<')
        end
      else
        begin
          lexlevel:=byteval(succ(jtab));
          if lexlevel > 127
           then lexlevel:=lexlevel - 256;
          enteric:=(jtab-2)-wordval(jtab-2);
          exitic:=(jtab-4)-wordval(jtab-4);
          paramsize:=wordval(jtab-6);
          datasize:=wordval(jtab-8);
          lastcode:=jtab-9;
          skip;
          writeln(f,'procedure code');
          writeln(f,'========= ====');
          writeln(f);
          {RWS mod:}
          write  (f,'Procedure: ',byteval(jtab):4);
          if byteval(jtab) = 0
            then write  (f,'Native code procedure.');
          writeln(f);
          writeln(f,'Lex Level: ',lexlevel:4);
          hexword(enteric,hex);
          writeln(f,'Enter I C: ',enteric:4,' (',hex,')');
          hexword(exitic,hex);
          writeln(f,'Exit  I C: ',exitic:4,' (',hex,')');
          hexword(paramsize,hex);
          writeln(f,'Paramsize: ',paramsize:4,' (',hex,')');
          hexword(datasize,hex);
          writeln(f,'Data size: ',datasize:4,' (',hex,')');
          writeln(f);
          ipc:=enteric;
          lastipcret:=ipc;
          l_count:=1;
          if lexlevel < -1
            then writeln('>>> Lex Level Bad! <<<')
            else
              if enteric < 0
                then writeln('>>> Enter I C Bad! <<<')
                else
                  if exitic < 0
                    then writeln('>>> Exit I C Bad! <<<')
                    else
                      begin
                        if not typespace
                          then exit(decodeproc);
                        if byteval(jtab) = 0
                          then
                            begin
                              repeat
                                if (ipc - lastipcret) >= 256
                                   then
                                     begin
                                       if not typespace
                                         then exit(decodeproc);
                                       lastipcret:=ipc;
                                       writeln(f);
                                     end;
                                if ((ipc - lastipcret) mod 16) = 0
                                  then
                                    begin
                                      writeln(f);
                                      hexword(ipc,hex);
                                      write(f,'<',hex,'>  ');
                                    end;
                                hexbyte(byteval(ipc),bythex);
                                write(f,bythex,' ');
                                ipc:=succ(ipc)
                              until ipc > lastcode;
                              writeln(f);
                            end
                          else
                            repeat
                              oneop;
                              (* rws mod: *)
                              if (l_count mod 16) = 0
                                 then
                                   begin
                                     if not typespace
                                       then exit(decodeproc);
                                     lastipcret:=ipc;
                                   end;
                              l_count:=succ(l_count);
                              ipc:=succ(ipc)
                            until ipc > lastcode
                      end;
        end;
    if typespace
      then ;
  end; (* of decodeproc *)

  procedure chooseproc;

  var
    i:integer;
    done:boolean;
    s:string;

  begin
    repeat
      page(output);
      writeln('procedure to decode: ');
      writeln;
      writeln('[1..',pdcount,']');
      writeln;
      writeln;
      writeln('<ret> to Exit');
      writeln;
      write('procedure: ');
      readln(s);
      done:= (length(s) = 0);
      int(s,i);
      if not done
        then
          if (i >= 1) and (i <= pdcount)
            then decodeproc(i)
    until done
  end; (* of chooseproc *)

  procedure readprocdict(seg: integer);

  var        i,
           loc,
     seglength:integer;
           hex:string3;

  begin
    with sd.dict do
    begin
      firstaddr:=0;
      firstblock:=diskinfo[seg].codeaddr;
      currentblock:=firstblock;
      seglength:=diskinfo[seg].codeleng
    end;
    loc:=pred(seglength);
    readblock(loc);
    pdcount:=byteval(loc);
    loc:=pred(loc);
    skip;
    writeln(f,'Procedure Dictionary:');
    writeln(f,'========= ===========');
    writeln(f);
    writeln(f,'Segment ',byteval(loc));
    writeln(f,'Procedure Count ',pdcount);
    writeln(f);
    for i:=1 to pdcount do
    begin
      loc:=loc-2;
      pd[i]:=loc-wordval(loc);
      hexword(pd[i],hex);
      writeln(f,'Procedure ',i:2,', Address ',pd[i]:5,' (',hex,')');
      (*sabmod*)
      if i mod 16 = 0
        then
          {RWS mod}
          if not typespace
            then exit(readprocdict);
    end;
    if not typespace
      then exit(readprocdict);
    chooseproc
  end; (* of readprocdict *)

  procedure choosesegment;

  var
    i:integer;
    answer:char;
    done:boolean;
    s:string;

  begin
    with sd.dict do
    repeat
      page(output);
      writeln('segment to analyse: ');
      writeln;
      for i:= 0 to 15 do
        if segname[i] <> '        ' then
          writeln(i:2,' ',segname[i]);
      writeln;
      writeln('<ret> to Exit');
      writeln;
      write('Segment: ');
      readln(s);
      done:= (length(s) = 0);
      int(s,i);
      if not done
        then
          if (i >= 0) and (i <= 15)
            then readprocdict(i)
    until done
  end; (* choosesegment *)

  procedure readsegdict;

  var   i:integer;
        s:string;

  begin
    if blockread(sourcefile,sd.buf,1,0) <> 1
      then
        begin
         writeln('Error in Reading Segment Dictionary ');
         exit(decode)
        end;
    with sd.dict
      do
        begin
          i:=0;
          skip;
          writeln(f,'Segment Dictionary:');
          writeln(f,'======= ===========');
          repeat
            if segname[i] <> '        '
              then
                {with seginfo[i] do}
                  begin
                    write(f,'Segment No: ',i{segnum}:2);
                    with diskinfo[i]
                      do write(f,'  Length ',codeleng:5,
                                 '  Address ',codeaddr:5);
                    {writeln(f,'System Version = ',version);}
                    s:='';
                    {case mtype of
                      undef: s:='Undefined';
                      pcodemost: s:='P-Code (Most sig 1st)';
                      pcodeleast: s:='P-Code (Least sig 1st)';
                      pdp11: s:='PDP-11';
                      m8080: s:='8080';
                      z80: s:='Z80';
                      ga440: s:='GA440';
                      m6502: s:='6502';
                      m6800: s:='6800';
                      ti9900: s:='9900'
                    end;} (* of case *)
                    {writeln(f,'Code type is ',s);}
                    s:='';
                    case segkind[i] of
                      linked: s:='Linked';
                      hostseg: s:='Host Segment';
                      segproc: s:='Segment Procedure';
                      unitseg: s:='Unit Segment';
                      seprtseg: s:='Separate Segment';
                      unlinkedintrins: s:='Unlinked Intrinsic';
                      linkedintrins: s:='Linked Intrinsic';
                      dataseg: s:='Data Segment'
                    end; (* of case *)
                    writeln(f,' ':2,segname[i],' (',s,')');
                  end;
            i:=succ(i)
            (* sabmod *)
            {if (i mod ) = 2
              then
                if not typespace
                  then exit(readsegdict);}
          until i > 15
        end;
    if not typespace
      then exit(readsegdict);
    choosesegment
  end; (* of readsegdict *)

  procedure initialise;

  var   i:integer;
        s:string7;

    procedure init(op:integer;mne:string7;x1,x2:ptype);
    begin
      with opcode[op]
        do
          begin
            mnemonic:=mne;
            p1:=x1;
            p2:=x2
          end
    end;  (* of init *)

    procedure init1;

    begin
      init(128,'ABI    ',xx,xx);
      init(129,'ABR    ',xx,xx);
      init(130,'ADI    ',xx,xx);
      init(131,'ADR    ',xx,xx);
      init(132,'AND    ',xx,xx);
      init(133,'DIF    ',xx,xx);
      init(134,'DVI    ',xx,xx);
      init(135,'DVR    ',xx,xx);
      init(136,'CHK    ',xx,xx);
      init(137,'FLO    ',xx,xx);
      init(138,'FLT    ',xx,xx);
      init(139,'INN    ',xx,xx);
      init(140,'INT    ',xx,xx);
      init(141,'IOR    ',xx,xx);
      init(142,'MODI   ',xx,xx);
      init(143,'MPI    ',xx,xx);
      init(144,'MPR    ',xx,xx);
      init(145,'NGI    ',xx,xx);
      init(146,'NGR    ',xx,xx);
      init(147,'NOT    ',xx,xx);
      init(148,'SRS    ',xx,xx);
      init(149,'SBI    ',xx,xx);
      init(150,'SBR    ',xx,xx);
      init(151,'SGS    ',xx,xx);
      init(152,'SQI    ',xx,xx);
      init(153,'SQR    ',xx,xx);
      init(154,'STO    ',xx,xx);
      init(155,'IXS    ',xx,xx);
      init(156,'UNI    ',xx,xx);
      init(157,'S2P    ',xx,xx);
      init(158,'CSP    ',ub,x0);
      init(159,'LDCN   ',xx,xx);
      init(160,'ADJ    ',ub,xx);
      init(161,'FJP    ',sb,x6);
      init(162,'INC    ', b,xx);
      init(163,'IND    ', b,xx);
      init(164,'IXA    ', b,xx);
      init(165,'LAO    ', b,xx);
      init(166,'LCA    ',ub,x1);
      init(167,'LDO    ', b,xx);
      init(168,'MOV    ', b,xx);
      init(169,'MVB    ', b,xx);
      init(170,'SAS    ',ub,xx);
      init(171,'SRO    ', b,xx);
      init(172,'XJP    ',xx,x2);
      init(173,'RNP    ',db,x7);
      init(174,'CIP    ',ub,xx);
      init(175,'EQU    ',db,x3);
    end;

    procedure init2;

    begin
      init(176,'GEQ    ',db,x3);
      init(177,'GRT    ',db,x3);
      init(178,'LDA    ',db, b);
      init(179,'LDC    ',ub,x4);
      init(180,'LEQ    ',db,x3);
      init(181,'LES    ',db,x3);
      init(182,'LOD    ',db, b);
      init(183,'NEQ    ',db,x3);
      init(184,'STR    ',db, b);
      init(185,'UJP    ',sb,x6);
      init(186,'LDP    ',xx,xx);
      init(187,'STP    ',xx,xx);
      init(188,'LDM    ',ub,xx);
      init(189,'STM    ',ub,xx);
      init(190,'LDB    ',xx,xx);
      init(191,'STB    ',xx,xx);
      init(192,'IXP    ',ub,ub);
      init(193,'RBP    ',db,x7);
      init(194,'CBP    ',ub,xx);
      init(195,'EQUI   ',xx,xx);
      init(196,'GEQI   ',xx,xx);
      init(197,'GRTI   ',xx,xx);
      init(198,'LLA    ', b,xx);
      init(199,'LDCI   ', w,xx);
      init(200,'LEQI   ',xx,xx);
      init(201,'LESI   ',xx,xx);
      init(202,'LDL    ', b,xx);
      init(203,'NEQI   ',xx,xx);
      init(204,'STL    ', b,xx);
      init(205,'CXP    ',ub,x5);
      init(206,'CLP    ',ub,xx);
      init(207,'CGP    ',ub,xx);
      init(208,'S1P    ',xx,xx);
      init(209,'IXB    ',xx,xx);
      init(210,'BYT    ',xx,xx);
      init(211,'EFJ    ',sb,x6);
      init(212,'NFJ    ',sb,x6);
      init(213,'BPT    ', b,xx);
      init(214,'XIT    ',xx,xx);
      init(215,'NOP    ',xx,xx);
    end;

    procedure init3;

    begin
      init(216,'SLDL1  ',xx,xx);
      init(217,'SLDL2  ',xx,xx);
      init(218,'SLDL3  ',xx,xx);
      init(219,'SLDL4  ',xx,xx);
      init(220,'SLDL5  ',xx,xx);
      init(221,'SLDL6  ',xx,xx);
      init(222,'SLDL7  ',xx,xx);
      init(223,'SLDL8  ',xx,xx);
      init(224,'SLDL9  ',xx,xx);
      init(225,'SLDL10 ',xx,xx);
      init(226,'SLDL11 ',xx,xx);
      init(227,'SLDL12 ',xx,xx);
      init(228,'SLDL13 ',xx,xx);
      init(229,'SLDL14 ',xx,xx);
      init(230,'SLDL15 ',xx,xx);
      init(231,'SLDL16 ',xx,xx);
      init(232,'SLDO1  ',xx,xx);
      init(233,'SLDO2  ',xx,xx);
      init(234,'SLDO3  ',xx,xx);
      init(235,'SLDO4  ',xx,xx);
      init(236,'SLDO5  ',xx,xx);
      init(237,'SLDO6  ',xx,xx);
      init(238,'SLDO7  ',xx,xx);
      init(239,'SLDO8  ',xx,xx);
      init(240,'SLDO9  ',xx,xx);
      init(241,'SLDO10 ',xx,xx);
      init(242,'SLDO11 ',xx,xx);
      init(243,'SLDO12 ',xx,xx);
      init(244,'SLDO13 ',xx,xx);
      init(245,'SLDO14 ',xx,xx);
      init(246,'SLDO15 ',xx,xx);
      init(247,'SLDO16 ',xx,xx);
      init(248,'SIND0  ',xx,xx);
      init(249,'SIND1  ',xx,xx);
      init(250,'SIND2  ',xx,xx);
      init(251,'SIND3  ',xx,xx);
      init(252,'SIND4  ',xx,xx);
      init(253,'SIND5  ',xx,xx);
      init(254,'SIND6  ',xx,xx);
      init(255,'SIND7  ',xx,xx)
    end;
  
{$R-}
  procedure str(num:integer;var l:string);

    var i:-1..4;
        ch:string[1];
        line:string;
        
    function pwrof(p,n:integer):integer;
        begin
          if n < 0 then n:=abs(n);
          if n = 0 then pwrof:=1 else pwrof:=p*pwrof(p,n-1)
        end;{pwrof}
    
    begin
      if num < 0
        then line:='-'
        else line:='';
      num:=abs(num);
      if num = 0
        then line:='0'
        else
          begin
            i:=4;
            while (i >= 0)
                  and ((num div pwrof(10,i)) = 0)
              do i:=i-1;
            ch:=' ';
            while i >= 0
              do
                begin
                  ch[1]:=chr((num div pwrof(10,i))+ord('0'));
                  num:=num mod pwrof(10,i);
                  line:=concat(line,ch);
                  i:=i-1
                end;
          end;
      l:=line
    end;{str}
{$R-}
  
  begin (*initialise*)
    for i:=0 to 127 do
    begin
      str(i,s);
      while length(s) < 3
        do s:=concat(s,' ');
      s:=concat('SLDC',s);
      init(i,s,xx,xx)
    end;
    init1;
    init2;
    init3
  end; (* of initiaise *)

begin (* Main Program *)
  hexdigit:='0123456789ABCDEF';
  page(output);
  writeln('Decode, Copyright 1981, Chris Wilson ');
  writeln;
  writeln('Typed in 23/8/84 by Stuart Bell');
  writeln;
  writeln('Modified for I.5 by Stuart Bell & Richard Stearn');
  writeln;
  writeln('Initialising....');
  initialise;
  writeln;
  write('Source File: ');
  readln(sourcename);
  if sourcename=''
    then exit(program);
  if pos('.code',sourcename)=0
    then
      if pos('system.',sourcename)=0
        then sourcename:=concat(sourcename,'.code');
  writeln;
  write('Destination File: ');
  readln(destname);
  if destname=''
    then destname:='console:'
    else
      if pos('.text',destname) = 0
        then destname:=concat(destname,'.text');
  reset(sourcefile,sourcename);
  rewrite(f,destname);
  readsegdict;
  writeln(f);
  close(f,lock)
end.

{if seginfo[i].mtype <> pcodeleast
            then
              begin
                writeln('Segment not P-Code (Least)');
                if seginfo[i].mtype in [undef,pcodemost]
                  then
                    begin
                      write('Try to decode anyway? (y/n) ');
                      readln(answer);
                      if answer in ['Y','y'] then readprocdict(i)
                    end
                  else
                    if typespace
                      then ;
              end 
            else}