# {$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 'u' 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.