%begin;            !decode for new imp
   %include "Sysinc:command.inc"
   %option "Noopen"
   %constinteger h = 16_FFFF
   %owninteger end = 0
   %recordformat parmfm(%shortinteger dsno, dact, ssno, sact, %c
                        %integer p1, p2, p3, p4, p5, p6)
   %recordformat procfm(%short   line, last line,
                        %integer ca, ca limit, table, table limit)
   %constinteger max procs = 300
   %record(procfm)%array proc(0:max procs)
   %record(procfm)%name thisp
   %integer ca, q, line, procs
   %integer event head, event limit
   %integer line head, line limit
   %recordformat hdfm(%shortinteger p1, p2)
   %recordformat headfm(%shortinteger pure size, gla size, code disp,
                                      lit disp, registers, main ep,
                        %record(hdfm) reloc, defs, specs, ldiag, vdiag)
   %ownrecord(headfm)%name head

   %integer j
   %integer code base, gla base
   %integer file base
   %integer current line
   %integer control
   %routinespec hex(%integer n)

   %string(15) controls, grot
   %string(63) source file, object file, listing file
   %routine connect object file(%string(63) file)
      %record(parmfm) p
      %integer k
      string(addr(p_sact)) = file
      svc(10, p)
      %if p_p1 # 0 %start
         select output(0)
         printstring("*Cannot load ".file)
         newline
         %stop
      %finish
      file base = p_p2;      !really seg+16
      gla base = p_p3
      head == record(file base)
      code base = (head_code disp&X'FFFF')*2+file base
      k = head_ldiag_p1
      k = k&16_7fff*2
      %signal 13,1 %if k = 0
      line head = k+head_ldiag_p2*2+file base
      line limit = k-2+file base
      event head = shortinteger(code base-2)&H*2+code base
      event limit = code base-2
!      line head = line head-shortinteger(line head)&H*2;      !????????
   %end
   %routine  hex(%integer n)
      %integer  j,k
      %for j = 1, 1, 4 %cycle
         k = n>>12&15;  n = n<<4
         %if k < 10 %then k = k+'0' %else k = k-10+'A'
         print symbol(k)
      %repeat
   %end
%routine decode line(%integer pc, to)
   %conststring(5)%array opcode(0:255) =
       "", "BALR", "BTCR", "BFCR", "NR  ", "CLR ", "OR  ", "XR  ",
   "LR  ", "CR  ", "AR  ", "SR  ", "MHR ", "DHR ", "", "",
   "SRLS", "SLLS", "CHVR", ""(5),
   "LPSWR", ""(3), "MR  ", "DR  ", ""(2),
   "BTBS", "BTFS", "BFBS", "BFFS", "LIS ", "LCS ", "AIS ", "SIS ",
   "LER ", "CER ", "AER ", "SER ", "MER ", "DER ", "FXR ", "FLR ",
    ""(4), "EXHR", ""(11),
   "STH ", "BAL ", "BTC ", "BFC ", "NH  ", "CLH ", "OH  ", "XH  ",
   "LH  ", "CH  ", "AH  ", "SH  ", "MH  ", "DH  ", "", "",
   "ST  ", "AM  ", ""(2), "N   ", "CL  ", "O   ", "X   ",
   "L   ", "C   ", "A   ", "S   ", "M   ", "D   ", "CRC12", "CRC16",
   "STE ", "AHM ", "",     "",     "ATL ", "ABL ", "RTL ", "RBL ",
   "LE  ", "CE  ", "AE  ", "SE  ", "ME  ", "DE  ", ""(2),
      "", "STME", "LME ", "LHL ", "TBT ", "SBT ", "RBT ", "CBT ",
       ""(8),
       ""(16),
   "SRHLS", "SLHLS", "STBR", "LBR ", "EXBR", "EPSR", "WBR ", "RBR ",
   "WHR ", "RHR ", "WDR ", "RDR ", "", "SSR ", "OCR ", "",
   ""(16),
   ""(16),
   "BXH ", "BXLE", "LPSW", "THI ", "NHI ", "CLHI", "OHI ", "XHI ",
   "LHI ", "CHI ", "AHI ", "SHI ", "SRHL", "SLHL", "SRHA", "SLHA",
   "STM ", "LM  ", "STB ", "LB  ", "CLB ", "AL  ", "WB  ", "RB  ",
   "WH  ", "RH  ", "WD  ", "RD  ", "", "SS  ", "OC  ", "",
   "TS  ", "SVC ", "SINT", "SCP ",  ""(2), "LA  ", "TLATE",
       "",     "", "RRL ", "RLL ", "SRL ", "SLL ", "SRA ", "SLA ",
    ""(3), "TI  ", "NI  ", "CLI ", "OI  ", "XI  ",
   "LI  ", "CI  ", "AI  ", "SI  ", ""(4)

   %routine show cc(%integer op, m)
      %if op = X'43' %start
         printstring("  GE") %and %return %if m=1
         printstring("  LE") %and %return %if m=2
         printstring("  EQ") %and %return %if m=3
      %else
         printstring("  LT") %and %return %if m=1
         printstring("  GT") %and %return %if m=2
         printstring("  NE") %and %return %if m=3
      %finish
      write(m, 3)
   %end
   %routine decode
      %switch ops(0:15)
      %integer n, r1, x, d, op, x2, xop
      %string(7) opc
!
      n = shortinteger(pc);  pc = pc+2
      print string("        | ")
      hex(pc-2-code base);  printstring("  ")
      op = n>>8&255;  opc = opcode(op)
      r1 = n>>4&15;  x = n&15
      hex(n);
      %if length(opc) = 0 %start
         newline;  %return
      %finish
      xop = op>>4
      ->ops(xop)

ops(0):ops(1):ops(2):ops(3):ops(9):;  ! rr and short formats
      spaces(8+2);  printstring(opc)
      %if x'20' <= op <= x'23' %start
         show cc(op, r1);  printsymbol(',')
         x = -x %if op&1 = 0;   ! ...it's a backward jump
         space
         hex(pc-2-code base+x*2)
      %else
         write(r1, 3);  printsymbol(',')
         write(x, 4)
      %finish
      newline;  %return

ops(12):       ! bxh, bxle, lpsw or halfword immediate
   %if op&15 >= 3 %start
      d = shortinteger(pc);  pc = pc+2;  hex(d)
      spaces(4)
      ->do ri
   %finish

ops(4):ops(5):ops(6):ops(7):ops(13):ops(14):  ! rx formats
   d = shortinteger(pc);  pc = pc+2;  hex(d)
   %if d&x'8000' # 0 %start;   !  pc relative
      d = (d<<1&x'8000')!(d&x'7FFF')
      spaces(4+2);  printstring(opc)
      %if op = X'42' %or op = X'43' %start
         show cc(op, r1)
      %else
        write(r1, 3)
      %finish
      printsymbol(',')
      space
      hex(pc-code base+d)
      %if x # 0 %start;   ! indexing specified
         printsymbol('(');  write(x, -2)
         printsymbol(')')
      %finish
   %else
      %if d&x'4000' = 0 %start;         ! 32-bit form
         spaces(4+2);  printstring(opc)
         %if op = X'42' %or op = X'43' %start
            show cc(op, r1)
         %else
          write(r1, 3)
         %finish
         printsymbol(',')
         write(d, 4)
         %if x # 0 %start
            printsymbol('(');  write(x, -2);  printsymbol(')')
         %finish
      %else;                            ! 48-bit form
         x2 = (d>>8)&15
         n = shortinteger(pc);  pc = pc+2;  hex(n)
         d = ((d&255)<<16) ! (n&x'FFFF')
         spaces(0+2);  printstring(opc)
         %if op = X'42' %or op = X'43' %start
            show cc(op, r1)
         %else
            write(r1, 3)
         %finish
         printsymbol(',')
         d = d ! x'FF000000' %if d&x'00800000' # 0;   ! -ve displacement
         write(d, 4)
         %if x # 0 %start
            printsymbol('(')
            write(x, -2)
            %if x2 # 0 %start;  ! second index specified?
               printsymbol(',')
               write(x2, -2)
            %finish
            printsymbol(')')
         %finish
      %finish
   %finish
   newline;  %return
!
ops(15):    ! full-word immediate
      n = shortinteger(pc)&X'FFFF';  pc = pc+2
      d = shortinteger(pc)&X'FFFF';  pc = pc+2
      hex(n);  hex(d)
      d = (n<<16) ! d
do ri:spaces(2);  printstring(opc)
      write(r1, 3)
      printsymbol(',')
      write(d, 4)
      %if x # 0 %start
         printsymbol('(');  write(x, -2);  printsymbol(')')
      %finish
      newline
%end;      ! decode

   decode %while pc < to
%end;      !decode line
%routine print next line
   %integer s
   %on 9 %start
      end = 1;  %return
   %finish
   current line = current line+1
   %return %if end # 0
   readsymbol(s)
   end = 1 %and %return %if s < 0
   write(current line, 4);  space
   %cycle
      %if s < 0 %start
         printstring(" **end**")
         end = 1
         s = nl
      %finish
      printsymbol(s)
      %return %If s = nl
      readsymbol(s)
   %repeat
%end
%routine find line(%integer line)
   %integer p
   %record(procfm)%name pr
   %for p = procs, -1, 0 %cycle
      pr == proc(p)
      %exit %if pr_line <= Line <= pr_last line
   %repeat
   thisp == Pr
%end
%routine next line(%record(procfm)%name pr)
   %integer n, linc, cinc
   line = pr_line
   ca = pr_ca
   q = pr_table
   %cycle
      q = q+2
      %if q >= pr_table limit %start
         ca = pr_ca limit
         %return
      %finish
      n = shortinteger(q)
      %exit %if n >= 0
      line = n&16_7fff;      !reset
   %repeat
   linc = n&16_1f
   cinc = n>>5*2
   line = line+linc
   ca = ca+cinc
%end
%routine extract blocks
   %integer n, ln, ep, lp, nep, nlp
   %record(Procfm)%name pr
   procs = 0;  proc(0) = 0
   ep = event head
   lp = Line head
   %cycle
      procs = procs+1;  pr == proc(procs)
      pr_ca limit = ep
      nep = ep-shortinteger(ep)&H*2
      ep = nep
      nep = nep+6 %if shortinteger(nep+2) >= 0
      nep = nep+4
      pr_ca = nep
      nlp = lp-shortinteger(lp)&H*2
      pr_table limit = lp;  lp = nlp
      nlp = nlp+2 %until shortinteger(nlp) # 0
      ln = shortinteger(nlp)&H
      pr_line = ln
      q = nlp
      %cycle
         pr_table = q
         next line(pr)
         pr_line = Line
      %repeat %until pr_ca limit <= ca
      pr_last line = line
      pr_line = ln
      pr_table = nlp
   %repeat %Until ep = event limit
   procs = procs-1;         !strip of perm
%end
%routine decode file
   %record(procfm)%name p
   %on %event 9 %start
      %return
   %finish
   extract blocks
   current line = 0
   %cycle
      print next line
      find line(current line)
      p == thisp
      next line(p)
      decode line(p_ca, ca);  p_ca = ca
      %while current line+1 # line %cycle
         find line(current line+1)
         %exit %if thisp ## p
         print next line
      %repeat %until end # 0
      p_line = line
      p_table = q
   %repeat %until end # 0
%end
%routine decode glap
%end

   object file = Command_In2
   listing file = Command_Out1
   source file = Command_In1
   %if object file = "" %start
      object file = source file %unless sourcefile -> objectfile.(".").grot
      objectfile = objectfile.".EXE"
   %finish
   connect object file(object file)
   listing file = "T:" %if listing file = ""
   open output(1, listing file)
   open input(1, source file)
   select input(1);  select output(1)
   printstring("Decode of object file ")
   printstring(object file)
   newlines(2)
   controls = Command_Parameter

   decode file
   decode glap

%endofprogram
