386 lines
11 KiB
OpenEdge ABL
386 lines
11 KiB
OpenEdge ABL
#
|
|
{$d+}
|
|
program asprint(prog,output);
|
|
|
|
const
|
|
|
|
{ header words }
|
|
NTEXT = 1;
|
|
NDATA = 2;
|
|
NPROC = 3;
|
|
ENTRY = 4;
|
|
NLINE = 5;
|
|
SZDATA = 6;
|
|
|
|
escape1 = 254; { escape to secondary opcodes }
|
|
escape2 = 255; { escape to tertiary opcodes }
|
|
|
|
type
|
|
byte= 0..255; { memory is an array of bytes }
|
|
adr= {0..maxadr} long; { the range of addresses }
|
|
word= {0..maxuint} long;{ the range of unsigned integers }
|
|
size= 0..32766; { the range of sizes is the positive offsets }
|
|
sword= {-signbit..maxsint} long; { the range of signed integers }
|
|
full= {-maxuint..maxuint} long; { intermediate results need this range }
|
|
double={-maxdbl..maxdbl} long; { double precision range }
|
|
insclass=(prim,second,tert); { tells which opcode table is in use }
|
|
instype=(implic,explic); { does opcode have implicit or explicit operand }
|
|
iflags= (mini,short,sbit,wbit,zbit,ibit);
|
|
ifset= set of iflags;
|
|
|
|
mnem = ( NON,
|
|
AAR, ADF, ADI, ADP, ADS, ADU,XAND, ASP, ASS, BEQ,
|
|
BGE, BGT, BLE, BLM, BLS, BLT, BNE, BRA, CAI, CAL,
|
|
CFF, CFI, CFU, CIF, CII, CIU, CMF, CMI, CMP, CMS,
|
|
CMU, COM, CSA, CSB, CUF, CUI, CUU, DCH, DEC, DEE,
|
|
DEL, DUP, DUS, DVF, DVI, DVU, EXG, FEF, FIF, FIL,
|
|
GTO, INC, INE, INL, INN, IOR, LAE, LAL, LAR, LDC,
|
|
LDE, LDF, LDL, LFR, LIL, LIM, LIN, LNI, LOC, LOE,
|
|
LOF, LOI, LOL, LOR, LOS, LPB, LPI, LXA, LXL, MLF,
|
|
MLI, MLU, MON, NGF, NGI, NOP, RCK, RET, RMI, RMU,
|
|
ROL, ROR, RTT, SAR, SBF, SBI, SBS, SBU, SDE, SDF,
|
|
SDL,XSET, SIG, SIL, SIM, SLI, SLU, SRI, SRU, STE,
|
|
STF, STI, STL, STR, STS, TEQ, TGE, TGT, TLE, TLT,
|
|
TNE, TRP, XOR, ZEQ, ZER, ZGE, ZGT, ZLE, ZLT, ZNE,
|
|
ZRE, ZRF, ZRL);
|
|
|
|
dispatch = record
|
|
iflag: ifset;
|
|
instr: mnem;
|
|
case instype of
|
|
implic: (implicit:sword);
|
|
explic: (ilength:byte);
|
|
end;
|
|
|
|
var
|
|
{ variables indicating the size of words and addresses }
|
|
wsize: integer; { number of bytes in a word }
|
|
asize: integer; { number of bytes in an address }
|
|
pdsize: integer; { size of procedure descriptor in bytes = 2*asize }
|
|
|
|
pc,lb,sp,hp,pd: adr; { internal machine registers }
|
|
i: integer; { integer scratch variable }
|
|
s,t :word; { scratch variables }
|
|
sz:size; { scratch variables }
|
|
ss,st: sword; { scratch variables }
|
|
k :double; { scratch variables }
|
|
j:size; { scratch variable used as index }
|
|
a,b:adr; { scratch variable used for addresses }
|
|
dt,ds:double; { scratch variables for double precision }
|
|
found:boolean; { scratch }
|
|
opcode: byte;
|
|
iclass: insclass;
|
|
dispat: array[insclass, byte] of dispatch ;
|
|
insr: mnem; { holds the instructionnumber }
|
|
header: array[1..8] of adr;
|
|
|
|
prog: file of byte; { program and initialized data }
|
|
|
|
procedure getit; { start the ball rolling }
|
|
var cset:set of char;
|
|
f:ifset;
|
|
insno:byte;
|
|
iclass: insclass;
|
|
nops:integer;
|
|
opcode:byte;
|
|
i,j,n:integer;
|
|
wtemp:sword;
|
|
count:integer;
|
|
repc:adr;
|
|
nexta,firsta:adr;
|
|
elem:byte;
|
|
amount,ofst:size;
|
|
c:char;
|
|
|
|
function readb(n:integer):double;
|
|
var b:byte;
|
|
begin
|
|
if eof(prog) then
|
|
begin writeln('Premature EOF on EM load file') ; halt end;
|
|
read(prog,b); if n>1 then readb:=readb(n-1)*256+b else readb:=b
|
|
end;
|
|
|
|
function readbyte:byte;
|
|
begin readbyte:=readb(1) end;
|
|
|
|
procedure skipbyte;
|
|
var dummy: byte;
|
|
begin dummy:=readb(1) end;
|
|
|
|
function readword:word;
|
|
begin readword:=readb(wsize) end;
|
|
|
|
function readadr:adr;
|
|
begin readadr:=readb(asize) end;
|
|
|
|
function ifind(ordinal:byte):mnem;
|
|
var loopvar:mnem;
|
|
found:boolean;
|
|
begin ifind:=NON;
|
|
loopvar:=insr; found:=false;
|
|
repeat
|
|
if ordinal=ord(loopvar) then
|
|
begin found:=true; ifind:=loopvar end;
|
|
if loopvar<>ZRL then loopvar:=succ(loopvar) else loopvar:=NON;
|
|
until found or (loopvar=insr) ;
|
|
end;
|
|
|
|
procedure readhdr;
|
|
type hdrw=0..32767 ; { 16 bit header words }
|
|
var hdr: hdrw;
|
|
i: integer;
|
|
begin
|
|
for i:=0 to 7 do
|
|
begin hdr:=readb(2);
|
|
case i of
|
|
0: if hdr<>3757 then { 07255 }
|
|
begin writeln('Not an em load file'); halt end;
|
|
1: writeln('Test flags: ',hdr);
|
|
2: if hdr<>0 then
|
|
begin writeln('Unsolved references: ',hdr) end;
|
|
3: if hdr<>3 then
|
|
begin writeln('Incorrect load file version') end;
|
|
4: wsize:=hdr ;
|
|
5: begin asize:=hdr ; pdsize:= asize+asize end;
|
|
6,7:
|
|
if hdr<>0 then
|
|
begin writeln('First header entry ',i,', is ',hdr) end;
|
|
end
|
|
end;
|
|
writeln('word size',wsize,', pointer size',asize)
|
|
end;
|
|
|
|
procedure noinit;
|
|
begin writeln('Illegal initialization'); halt end;
|
|
|
|
procedure readint(a:adr;s:size);
|
|
const mrange = 4;
|
|
var i:size;
|
|
val:double;
|
|
cont: array[1..mrange] of byte;
|
|
begin { construct integer out of byte sequence }
|
|
if s<=mrange then
|
|
begin
|
|
for i:=1 to s do cont[i]:=readbyte ;
|
|
if cont[s]>=128 then val:=cont[s]-256 else val:=cont[s];
|
|
for i:= s-1 downto 1 do val:= val*256 + cont[i];
|
|
writeln(', value ',val)
|
|
end
|
|
else
|
|
begin
|
|
write(', bytes(little endian) ');
|
|
for i:=1 to s do write(readbyte:4) ;
|
|
writeln
|
|
end
|
|
end;
|
|
|
|
procedure readuns(a:adr;s:size);
|
|
const mrange=3;
|
|
var i:size;
|
|
val:double;
|
|
cont: array[1..mrange] of byte;
|
|
begin { construct unsigned integer out of byte sequence }
|
|
if s<=mrange then
|
|
begin
|
|
for i:=1 to s do cont[i]:=readbyte ;
|
|
val:=0;
|
|
for i:= s downto 1 do val:= val*256 + cont[i];
|
|
writeln(', value ',val)
|
|
end
|
|
else
|
|
begin
|
|
write(', bytes(little endian) ');
|
|
for i:=1 to s do write(readbyte:4) ;
|
|
writeln
|
|
end
|
|
end;
|
|
|
|
procedure readfloat(a:adr;s:size);
|
|
var i:size; b:byte;
|
|
begin { construct float out of string}
|
|
i:=0;
|
|
repeat { eat the bytes, construct the value and intialize at a }
|
|
write(chr(readbyte)); i:=i+1;
|
|
until b=0 ;
|
|
end;
|
|
|
|
begin
|
|
|
|
#ifdef INSRT
|
|
{ initialize tables }
|
|
for iclass:=prim to tert do
|
|
for i:=0 to 255 do
|
|
with dispat[iclass][i] do
|
|
begin instr:=NON; iflag:=[zbit] end;
|
|
|
|
{ read instruction table file. see appendix B }
|
|
{ The table read here is a simple transformation of the table on page xx }
|
|
{ - instruction names were transformed to numbers }
|
|
{ - the '-' flag was transformed to an 'i' flag for 'w' type instructions }
|
|
{ - the 'S' flag was added for instructions having signed operands }
|
|
reset(tables);
|
|
insr:=NON;
|
|
repeat
|
|
read(tables,insno) ; cset:=[]; f:=[];
|
|
insr:=ifind(insno);
|
|
if insr=NON then begin writeln('Incorrect table'); halt end;
|
|
repeat read(tables,c) until c<>' ' ;
|
|
repeat
|
|
cset:=cset+[c];
|
|
read(tables,c)
|
|
until c=' ' ;
|
|
if 'm' in cset then f:=f+[mini];
|
|
if 's' in cset then f:=f+[short];
|
|
if '-' in cset then f:=f+[zbit];
|
|
if 'i' in cset then f:=f+[ibit];
|
|
if 'S' in cset then f:=f+[sbit];
|
|
if 'w' in cset then f:=f+[wbit];
|
|
if (mini in f) or (short in f) then read(tables,nops) else nops:=1 ;
|
|
readln(tables,opcode);
|
|
if ('4' in cset) or ('8' in cset) then
|
|
begin iclass:=tert end
|
|
else if 'e' in cset then
|
|
begin iclass:=second end
|
|
else iclass:=prim;
|
|
for i:=0 to nops-1 do
|
|
begin
|
|
with dispat[iclass,opcode+i] do
|
|
begin
|
|
iflag:=f; instr:=insr;
|
|
if '2' in cset then ilength:=2
|
|
else if '4' in cset then ilength:=4
|
|
else if '8' in cset then ilength:=8
|
|
else if (mini in f) or (short in f) then
|
|
begin
|
|
if 'N' in cset then wtemp:=-1-i else wtemp:=i ;
|
|
if 'o' in cset then wtemp:=wtemp+1 ;
|
|
if short in f then wtemp:=wtemp*256 ;
|
|
implicit:=wtemp
|
|
end
|
|
end
|
|
end
|
|
until eof(tables);
|
|
|
|
#endif
|
|
{ read in program text, data and procedure descriptors }
|
|
reset(prog);
|
|
readhdr; { verify first header }
|
|
for i:=1 to 8 do header[i]:=readadr; { read second header }
|
|
writeln('textsize ',header[NTEXT],', datasize ',header[SZDATA]);
|
|
writeln('data descriptors: ',header[NDATA]);
|
|
writeln('procedure descriptors: ',header[NPROC]);
|
|
writeln('entry procedure: ',header[ENTRY]);
|
|
if header[7]<>0 then writeln('Second header entry 7 is ',header[7]);
|
|
if header[8]<>0 then writeln('Second header entry 8 is ',header[8]);
|
|
{ read program text }
|
|
for i:=0 to header[NTEXT]-1 do skipbyte;
|
|
{ read data blocks }
|
|
writeln; writeln('Data descriptors:');
|
|
nexta:=0;
|
|
for i:=1 to header[NDATA] do
|
|
begin
|
|
n:=readbyte;
|
|
write(nexta:5,'- ');
|
|
if n<>0 then
|
|
begin
|
|
elem:=readbyte; firsta:=nexta;
|
|
case n of
|
|
1: { uninitialized words }
|
|
begin
|
|
writeln(elem,' uninitialised word(s)');
|
|
nexta:= nexta+ elem*wsize ;
|
|
end;
|
|
2: { initialized bytes }
|
|
begin
|
|
write(elem,' initialised byte(s)');
|
|
for j:=1 to elem do
|
|
begin
|
|
if j mod 10 = 1 then
|
|
begin writeln ; write(nexta:6,':') end ;
|
|
write(readbyte:4); nexta:=nexta+1
|
|
end;
|
|
writeln
|
|
end;
|
|
3: { initialized words }
|
|
begin
|
|
write(elem,' initialised word(s)');
|
|
for j:=1 to elem do
|
|
begin
|
|
if j mod 8 = 1 then
|
|
begin writeln ; write(nexta:6,':') end ;
|
|
write(readword:9); nexta:=nexta+wsize
|
|
end;
|
|
writeln
|
|
end;
|
|
4,5: { instruction and data pointers }
|
|
begin
|
|
if n=4 then
|
|
write(elem,' initialised data pointers')
|
|
else
|
|
write(elem,' initialised instruction pointers');
|
|
for j:=1 to elem do
|
|
begin
|
|
if j mod 8 = 1 then
|
|
begin writeln ; write(nexta:6,':') end ;
|
|
write(readadr:9); nexta:=nexta+asize
|
|
end;
|
|
writeln
|
|
end;
|
|
6: { signed integers }
|
|
begin
|
|
write(elem,'-byte signed integer ');
|
|
readint(nexta,elem); nexta:=nexta+elem
|
|
end;
|
|
7: { unsigned integers }
|
|
begin
|
|
write(elem,'-byte unsigned integer ');
|
|
readuns(nexta,elem); nexta:=nexta+elem
|
|
end;
|
|
8: { floating point numbers }
|
|
begin
|
|
write(elem,'-byte floating point number ');
|
|
readfloat(nexta,elem); nexta:=nexta+elem
|
|
end;
|
|
end
|
|
end
|
|
else
|
|
begin
|
|
repc:=readadr;
|
|
amount:=nexta-firsta;
|
|
writeln(repc,' copies of the data from ',firsta:2,' to ',nexta:2);
|
|
nexta:= nexta + repc*amount ;
|
|
end
|
|
end;
|
|
if header[SZDATA]<>nexta then writeln('Data initialization error');
|
|
{ read descriptor table }
|
|
pd:=header[NTEXT];
|
|
for i:=1 to header[NPROC]*pdsize do skipbyte;
|
|
end;
|
|
|
|
begin getit;
|
|
#ifdef RTC
|
|
repeat
|
|
opcode := nextpc; { fetch the first byte of the instruction }
|
|
if opcode=escape1 then iclass:=second
|
|
else if opcode=escape2 then iclass:=tert
|
|
else iclass:=prim;
|
|
if iclass<>prim then opcode := nextpc;
|
|
with dispat[iclass][opcode] do
|
|
begin insr:=instr;
|
|
if not (zbit in iflag) then
|
|
if ibit in iflag then k:=pop else
|
|
begin
|
|
if mini in iflag then k:=implicit else
|
|
begin
|
|
if short in iflag then k:=implicit+nextpc else
|
|
begin k:=nextpc;
|
|
if (sbit in iflag) and (k>=128) then k:=k-256;
|
|
for i:=2 to ilength do k:=256*k + nextpc
|
|
end
|
|
end;
|
|
if wbit in iflag then k:=k*wsize;
|
|
end
|
|
end;
|
|
#endif
|
|
end.
|