Category : Miscellaneous Language Source Code
Archive   : ADA.ZIP
Filename : DISGUSTA.PAS

 
Output of file : DISGUSTA.PAS contained in archive : ADA.ZIP

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 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.