{$T+,R-,U-,D- > Source for ARM (Was Communicator) Pascal Disassembler

Differences from normal BBC Disasm2
-----------------------------------

1 : 4 byte pointers (not yet Bruce)
2 : S_call now takes two byte proc. no.
3 : code1/0 -> f/call
4 : S_init got 2b stack parm following
5 : const reals now 8 byte
6 : array_access has only byte no. of indices, NO stack decrement
7 : &FF = ARM code identifying byte
}

program bldisasm (input, output, bee_ell);

label 999;

const
  pshK_ptr   = 1;
  pshK_int   = 2;
  pshK_rea   = 3;
  pshK_set   = 4;
  locK_ildS  = 7;
  locK_ildL  = 49;
  array_acc  = &42;
  jmp_now    = 68;
  jmp_false  = 69;
  br_now     = 70;
  br_false   = 71;
  CheckInt   = 76;
  Debug_Name = 77;
  S_return   = &7D;
  S_init     = 175;
  S_Exit     = 176;
  S_enterS   = 179;
  S_funcret  = 181;
  S_enterL   = 221;
  the_foul_GOTO = 72;
  jmp_code_base = 241;
  PrResFl       = 166;
  PrResXFl      = 167; {&A7}
  PrRewFl       = 170;
  PrRewXFl      = 171; {&AB}

type
   byte = 0..255;
   strarr =  packed array [byte, 1..10] of char;
   fstring = packed array [1..30] of char;
   ftype   = packed array [1..6]  of char;
   threecases = 1..3;

var opcode   : byte;

    mnemonic : record case threecases of
                    1 : (int : integer);
                    2 : (ptr : ^strarr);
                    3 : (arr : packed array [0..3] of byte)
               end;

    CP, offset, i, j, addr : integer;

    bee_ell  : packed file of byte;


function gbyte : byte;
begin
  offset := succ (offset);
  read (bee_ell, gbyte)
end;


function gword : integer;
begin
  gword := gbyte+gbyte*256
end;


function gint : integer;
var fujjit : record
             case boolean of
              true  : (a : packed array [0..3] of byte );
              false : (int : integer)
             end;
    i : integer;

begin
  for i := 0 to 3 do fujjit.a[i] := gbyte;
  gint := fujjit.int
end;


function greal : real;
var fujjit : record
             case boolean of
              true  : (a : packed array [0..4] of byte );
              false : (rea : real)
             end;
    i : integer;

begin
  for i := 0 to 4 do fujjit.a[i] := gbyte;
  greal := fujjit.rea
end;


procedure WrByte_MinSpaces;
begin
  write (~gbyte : 1)
end;


procedure WrWord_MinSpaces;
begin
  write (~gword : 1)
end;


procedure init;
var i : integer;
    blfile, outfile : fstring;

  procedure badfile (x : ftype);
  begin
    writeln ('Bad ', x, ' filename.'); goto 999
  end;

  procedure getfname (var fname : fstring; errstr : ftype);
  begin
    i := 1;
    while not eoln (input) and (input^ <> ' ') and (i <= 30) do
      begin
        read (fname[i]);
        i := succ (i)
      end;

    if i > 30
    then badfile (errstr)
    else fname[i] := chr (13)
  end;

begin
  getfname (blfile, ' input');
  if i= 1 then badfile (' input');
  while not eoln (input) and (input^ = ' ') do get (input);
  getfname (outfile, 'output');

  reset (bee_ell, blfile);
  rewrite (output, outfile);

  offset := 0;

  {initialise mnemonic}

  mnemonic.int := code0 (&FFF4, &83, 0, 0); {read OSHWM - point at data}

  mnemonic.int := mnemonic.arr[2]*256+mnemonic.arr[1]+3;

  {integer = &PYXA; so mnemonic.arr[0] = A,... XY+3=posn of data}
end;


procedure dump_block (length, offset : integer);
var i : integer;

  procedure block_line (length : integer);
  var i : integer;
      line : packed array [1..12] of byte;

  begin
    if length > 0 then
    begin
      write ('            ');
      for i := 1 to length do line [i] := gbyte;
      for i := 1 to length do write (~line[i] : 3);

      for i := 0 to 12-length do write ('   ');

      for i := 1 to length do
         if (32 <= line[i]) and (line[i] <= 126)
         then write (chr (line[i]))
         else write ('.');
      writeln
    end
  end;

begin
  writeln (~length : 1);
  length := length-offset; {for jmp_code_base}
  for i := 1 to length DIV 12 do block_line (12);
  block_line (length MOD 12)
end;


procedure printenter (level : byte; AR, SPoff : integer);
begin
  writeln ('DispL ', ~level : 1, ', AR ', ~AR : 1, ', SP +:= ', ~Spoff : 1)
end;


begin {Main Program}

init;

repeat
  CP := offset; opcode := gbyte;

  write (~CP : 5, ~opcode : 5, '   ', mnemonic.ptr^ [opcode], '   ');


  if opcode in [&00, &05, &08, &09, &0A, &0B, &0C, &0D, &0E, &0F,
                &10, &11, &12, &13, &14, &15, &16, &17, &1F, &28,
                &29, &2E, &50, &9E, &A1, &A5, &A9, &B2, &B4, &D3,
                &D4, &D9, &DA, &DF, &E3, &E7, &F4, &F7, &F8, &FD]
  {all the 1-byte operanders}
  then
    begin WrByte_MinSpaces; writeln end

  else
    if opcode in [&4A, &51, &E0, &F5, &F6]
    then
      begin
        WrByte_MinSpaces; write (',');
        WrByte_MinSpaces; writeln
      end


  else
    if opcode in [&06, &32, &33, &34, &35, &36, &37, &38, &39, &3A,
                  &3B, &3C, &3D, &3E, &3F, &40, &41, &49, &4E, &4F,
                  &52, &53, &6C, &6D, &6E, &6F, &70, &71, &7C, &9C, &B6,
                  &B7, &B8, &B9, &BA, &BB, &BC, &BD, &DC, &DE, &E1]
    then
      begin WrWord_MinSpaces; writeln end


  else
    if opcode in [&D5, &D6, &D7, &D8]  {case opcode ?}
    then
      begin
        write (': Otherwise label ');
        WrWord_MinSpaces;
        writeln;

        if odd (opcode)

        then  {jump table}
        begin
          if opcode = &D5
          then begin j := gbyte; addr := gbyte end
          else begin j := gint ; addr := gword end;
          j := j-1;
          for i := 1 to addr do writeln (~i+j : 19, ' : ', ~gword : 4)
        end

        else  {test list}
        begin
          if opcode = &D6
          then addr := gbyte
          else addr := gword;

          for i := 1 to addr do
          begin
            if opcode = &D6
            then write (~gbyte : 19)
            else write (~gint : 19);

            writeln (' : ', ~gword : 4)
          end
        end
      end


  else
    case opcode of

      pshK_ptr : writeln (~gword {gint} : 1);


      pshK_int : writeln (~gint : 1);


      pshK_rea : writeln (~gint : 8, ~gint : 8)


      CheckInt : writeln (~gint : 1, ',', ~gint : 1);


      Debug_Name :
        begin
          for i := 1 to gbyte do write (chr (gbyte));
          writeln
        end;


      S_enterS : printenter (gbyte, gbyte, gbyte); {1 byte AR, SP offset}


      S_enterL : printenter (gbyte, gword, gword); {2 byte AR, SP offset}


      locK_ildS, pshK_set : dump_block (gbyte, 0);


      locK_ildL : dump_block (gword, 0);

      array_acc : begin WrByte_MinSpaces; writeln (' index(es)') end;

      jmp_code_base :
        begin
          dump_block (gword, 3);
          writeln;
          offset := 0
        end;


      the_foul_GOTO :
        begin
          WrWord_MinSpaces;
          write (', new level ');
          WrByte_MinSpaces;
          write (', SP := base + ');
          WrWord_MinSpaces;
          writeln
        end;


      S_init :
        begin
          if gbyte <> 0 then write ('with cmdtail, ');
          write ('ProcTab at ');
          WrWord_MinSpaces;
          write (', stack ');
          WrWord_MinSpaces;
          writeln;
        end;


      S_Exit :
         begin
           writeln;
           writeln;
           writeln ('ProcTab :');
           i := 0;
           addr := gword;
           repeat
             writeln  (~i : 7, ' : ', ~addr : 4);
             i := i + 1;
             addr := gword
           until addr = &FFFF;
         end;


      S_return :
         begin
           writeln;
           writeln
         end;


      S_funcret :
         begin
           write ('from ');
           WrWord_MinSpaces;
           write (', ');
           WrByte_MinSpaces;
           writeln (' byte(s)');
           writeln
         end;


      br_now :
         begin
           i := gbyte;
           if i > 127 then i := i-256; {sign-extend}
           writeln (~(i+CP) : 1);
           writeln
         end;


      br_false :
         begin
           i := gbyte;
           if i > 127 then i := i-256; {sign-extend}
           writeln (~(i+CP) : 1)
         end;


      jmp_now :
         begin
           WrWord_MinSpaces;
           writeln;
           writeln
         end;


      jmp_false :
         begin
           WrWord_MinSpaces;
           writeln
         end;


      PrResFl, PrResXFl, PrRewFl, PrRewXFl :
         begin
           if gbyte = 0
           then write ('Text')
           else write ('Non-text');

           write (', comp size ');
           WrWord_MinSpaces;

           if odd (opcode) then
           begin
             write (', name length ');
             WrByte_MinSpaces
           end;

           writeln
         end;


    end {case} otherwise writeln


until eof (bee_ell);

999 : {Abort label}

end.