Program DisGusta;
{ This program is a disassembler for p-code programs produced with }
{  the public domain Augusta Ada subset compiler. }

{$R+ } { turn on subscript and type checking }

Const
  dis_version = '1.0';
  nl          = #13#10; {characters to start a new line }
Type
  String5     = string[5];
Var
  header    : record
                code_size  : integer; {code size in bytes}
                max_record : integer; {number of 128-byte records in the file }
                max_proc   : integer; {number of procedures }
                version    : integer; {code file version number}
              end;
  proctable : array[1..256] of record
                offset          : integer; { offset from CS to proc code}
                local_var_bytes : integer; { # of bytes needed for local vars }
                parm_bytes      : integer; { # of bytes needed for parameters }
                level           : byte;    { lexical level of the procedure }
              end;
  code_file                     : file of byte; { the program file }
  listing                       : text;         { the listing file }
  Z,CP                          : integer; { work variables }


Procedure Load_Program;
{ gets the name of the p-code file, opens it, and reads in the }
{  header and procedure table; opens the listing file. }
var
  name          : string[32]; { filename }
  temp1,temp2   : byte;       { work variables }
  temp3,temp4   : byte;
  I             : integer;
  N             : string[1];
  error,original: boolean;    { true when an error occured somewhere }
begin
  { loop through the opening process until a valid file is found }
  Repeat
   error := false;

  { present the intro screen }
  clrscr; writeln('D i s g u s t a',nl,'Version ',dis_version);

  { get the filename and make sure it's available }
  repeat
    sound(660); delay(300); nosound;
    write(nl,'Input filename ? ');
    {$I-} readln(name); assign(code_file,name); reset(code_file); {$I+}
  until IOResult=0;

  { load the header block and make sure it's an augusta code file }
  with header do begin
    read(code_file, temp1,temp2,temp3,temp4);
    code_size := temp2*256 + temp1 - 1920;
    max_record := temp4*256 + temp3;
    read(code_file, temp1,temp2,temp3,temp4);
    max_proc := temp2*256 + temp1; version := temp4*256 + temp3;
  end;
  read(code_file, temp1,temp2,temp3,temp4);
  if not ((temp1=89) and (temp2=4) and (temp3=0) and (temp4=0))
     or (filesize(code_file)<1921) then begin
    writeln(name,' is not a valid Augusta p-code file.');
    delay(1000); error := true;
    end

  { read in only as many proc table entries as  the header says exist }
  else begin
    seek(code_file,128);{ skip 116 unused header bytes to the proc table}
    for I:=1 to header.max_proc do
      with proctable[i] do begin
        read(code_file, temp1,temp2,temp3,temp4);
        offset := (temp2 shl 8) + temp1;
        local_var_bytes := (temp4 shl 8) + temp3;
        read(code_file, temp1,temp2,level);
        parm_bytes := (temp2 shl 8) + temp1;
      end;
  end;
  close(code_file);
  Until error=false;

  { leave the code file open now that we know it's legal }
  assign(code_file,name); reset(code_file);
  { find an original name for the listing file }
  Z := pos('.',name);
  if Z>0 then delete(name,Z,31);
  name := name + '.dis';
  {$I-}
    Z := 0;
    repeat
      assign(listing,name); reset(listing);
      if ioresult<>0 then
        original := true
      else begin
        close(listing);
        str(Z,N);
        name[length(name)] := N;
        Z := Z + 1;
        original := false;
      end;
    until original or (Z>9);
  {$I+}
  assign(listing,name); rewrite(listing);
  writeln(nl,'Listing file will be named ',#39,name,#39);
end;

Function Get_byte(var offset: integer): integer;
{ gets the byte at Offset into Byte1 and increments Offset to the next byte }
var
  ch: byte;
begin
  offset := offset + 1; read(code_file,ch); get_byte := ch;
end;

Function Get_Word(offset: integer): integer;
{ gets the word at Offset, leaving Offset as it was on entry }
var
  ch,ch2: byte;
begin
  read(code_file,ch,ch2); get_word := ch + (ch2 shl 8);
end;

Procedure Interpret_Code;
{ interprets the op-code in byte1, using additional bytes and }
{ adjusting CP accordingly. }
var
  byte1         : byte;    { gets the op-code byte }
  temp1,temp2,I : integer; { local work variables }

  procedure Load_Or_Store;
  begin
    temp2 := get_word(CP);
    case byte1 of
      1: writeln(listing,'LDCI ',temp2);
      2: writeln(listing,'LDL ',temp2);
      3: writeln(listing,'LLA ',temp2);
      4: begin writeln(listing,'LDB'); CP := CP - 2; end;
      5: writeln(listing,'LDO ',temp2);
      6: writeln(listing,'LAO ',temp2);
      8: begin
           temp1 := get_byte(CP);
           writeln(listing,'LOD ',temp1,' ',temp2);
         end;
      9: begin
           temp1 := get_byte(CP);
           writeln(listing,'LOA ',temp1,' ',temp2);
         end;
    end;
    CP := CP + 2;
  end; { load_or_store }

  Procedure Jump;
  begin
    temp1 := get_word(CP); CP := CP + 2;
    case byte1 of
      37: writeln(listing,'UJP ',temp1,' -> ',(temp1+CP));
      38: writeln(listing,'FJP ',temp1,' -> ',(temp1+CP));
      39: begin
            temp2 := get_word(CP); I := get_word(CP+2);
            writeln(listing,'XJP ',temp1,',',temp2,' ',I,' -> ',(I+CP));
            CP := CP + 4;
          end;
    end;
  end;

begin
  { get an op-code byte from the buffer }
  byte1 := get_byte(CP);
  write(listing,(CP-1):5,':  ',byte1:6,'    ');

  case byte1 of               { Note- indented procedures are repeats from }
     1..10: load_or_store;    {  a previous line. }
        11: writeln(listing,'STO');
        12: writeln(listing,'SINDO');
        13: begin
              temp1 := get_byte(CP);
              write(listing,'LCA ',temp1,#32#39);
              while temp1>0 do begin
                temp2 := get_byte(CP);
                write(listing,char(temp2)); temp1 := temp1 - 1;
              end;
              writeln(listing,#39);
            end;
        14: writeln(listing,'SAS');
        15: begin
              writeln(listing,'EOP'); CP := -1; { flag CP on end-of-proc }
            end;
        16: writeln(listing,'AND');
        17: writeln(listing,'OR');
        18: writeln(listing,'NOT');
        19: writeln(listing,'ADI');
        20: writeln(listing,'NGI');
        21: writeln(listing,'SBI');
        22: writeln(listing,'MPI');
        23: writeln(listing,'DVI');
        24: writeln(listing,'IND');
        25: writeln(listing,'EQUI');
        26: writeln(listing,'NEQI');
        27: writeln(listing,'LEQI');
        28: writeln(listing,'LESI');
        29: writeln(listing,'GEQI');
        30: writeln(listing,'GTRI');
        31: writeln(listing,'EQUSTR');
        32: writeln(listing,'NEQSTR');
        33: writeln(listing,'LEQSTR');
        34: writeln(listing,'LESSTR');
        35: writeln(listing,'GEQSTR');
        36: writeln(listing,'GTRSTR');
    37..39: jump;
        40: begin temp1 := get_byte(CP); writeln(listing,'CLP ',temp1); end;
        41: begin temp1 := get_byte(CP); writeln(listing,'CGP ',temp1); end;
        43: writeln(listing,'RET');
        45: writeln(listing,'MODI');
        46: writeln(listing,'RNP');
        42: begin temp1 := get_byte(CP); writeln(listing,'CSP ',temp1); end;
        47: writeln(listing,'RNP');
        48: begin temp1 := get_byte(CP); writeln(listing,'IXA ',temp1); end;
    49..56: writeln(listing,'SLDL',(byte1-49));
        57: begin temp1 := get_byte(CP); writeln(listing,'SLDO ',temp1); end;
        58: begin temp1 := get_byte(CP); writeln(listing,'SLAO ',temp1); end;
        59: begin temp1 := get_byte(CP); writeln(listing,'SLLA ',temp1); end;
        60: begin temp1 := get_byte(CP); writeln(listing,'SLDL ',temp1); end;
        61: begin temp1 := get_byte(CP); writeln(listing,'SLDC ',temp1); end;
        63: writeln(listing,'SLDCN1');
    64..79: writeln(listing,'SLDC',(byte1-64));
        80: begin
              temp1 := get_word(CP);
              writeln(listing,'INCL ',temp1); CP := CP + 2;
            end;
        81: begin
              temp1 := get_word(CP);
              writeln(listing,'DECL ',temp1); CP := CP + 2;
            end;
      else  writeln(listing,'???');
  end;
end;

BEGIN

  load_program;
  Z := 0;
  while Z<header.max_proc do begin
    Z := Z + 1;
    writeln(listing,nl,'Procedure ',Z);
    with proctable[Z] do begin
      writeln(listing,'   Offset=',offset,', ',local_var_bytes,
        ' bytes local variables, ',parm_bytes,' bytes parameters, Level ',
        level,nl);
      CP := offset; seek(code_file,CP+1920);
    end;
    writeln(listing,'Offset   Opcode   Mnemonic (and parameters)');
    while CP>-1 do interpret_code;
  end;
  writeln(listing);
  close(code_file);
  close(listing);

END.