asprint.p 11 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386
  1. #
  2. {$d+}
  3. program asprint(prog,output);
  4. const
  5. { header words }
  6. NTEXT = 1;
  7. NDATA = 2;
  8. NPROC = 3;
  9. ENTRY = 4;
  10. NLINE = 5;
  11. SZDATA = 6;
  12. escape1 = 254; { escape to secondary opcodes }
  13. escape2 = 255; { escape to tertiary opcodes }
  14. type
  15. byte= 0..255; { memory is an array of bytes }
  16. adr= {0..maxadr} long; { the range of addresses }
  17. word= {0..maxuint} long;{ the range of unsigned integers }
  18. size= 0..32766; { the range of sizes is the positive offsets }
  19. sword= {-signbit..maxsint} long; { the range of signed integers }
  20. full= {-maxuint..maxuint} long; { intermediate results need this range }
  21. double={-maxdbl..maxdbl} long; { double precision range }
  22. insclass=(prim,second,tert); { tells which opcode table is in use }
  23. instype=(implic,explic); { does opcode have implicit or explicit operand }
  24. iflags= (mini,short,sbit,wbit,zbit,ibit);
  25. ifset= set of iflags;
  26. mnem = ( NON,
  27. AAR, ADF, ADI, ADP, ADS, ADU,XAND, ASP, ASS, BEQ,
  28. BGE, BGT, BLE, BLM, BLS, BLT, BNE, BRA, CAI, CAL,
  29. CFF, CFI, CFU, CIF, CII, CIU, CMF, CMI, CMP, CMS,
  30. CMU, COM, CSA, CSB, CUF, CUI, CUU, DCH, DEC, DEE,
  31. DEL, DUP, DUS, DVF, DVI, DVU, EXG, FEF, FIF, FIL,
  32. GTO, INC, INE, INL, INN, IOR, LAE, LAL, LAR, LDC,
  33. LDE, LDF, LDL, LFR, LIL, LIM, LIN, LNI, LOC, LOE,
  34. LOF, LOI, LOL, LOR, LOS, LPB, LPI, LXA, LXL, MLF,
  35. MLI, MLU, MON, NGF, NGI, NOP, RCK, RET, RMI, RMU,
  36. ROL, ROR, RTT, SAR, SBF, SBI, SBS, SBU, SDE, SDF,
  37. SDL,XSET, SIG, SIL, SIM, SLI, SLU, SRI, SRU, STE,
  38. STF, STI, STL, STR, STS, TEQ, TGE, TGT, TLE, TLT,
  39. TNE, TRP, XOR, ZEQ, ZER, ZGE, ZGT, ZLE, ZLT, ZNE,
  40. ZRE, ZRF, ZRL);
  41. dispatch = record
  42. iflag: ifset;
  43. instr: mnem;
  44. case instype of
  45. implic: (implicit:sword);
  46. explic: (ilength:byte);
  47. end;
  48. var
  49. { variables indicating the size of words and addresses }
  50. wsize: integer; { number of bytes in a word }
  51. asize: integer; { number of bytes in an address }
  52. pdsize: integer; { size of procedure descriptor in bytes = 2*asize }
  53. pc,lb,sp,hp,pd: adr; { internal machine registers }
  54. i: integer; { integer scratch variable }
  55. s,t :word; { scratch variables }
  56. sz:size; { scratch variables }
  57. ss,st: sword; { scratch variables }
  58. k :double; { scratch variables }
  59. j:size; { scratch variable used as index }
  60. a,b:adr; { scratch variable used for addresses }
  61. dt,ds:double; { scratch variables for double precision }
  62. found:boolean; { scratch }
  63. opcode: byte;
  64. iclass: insclass;
  65. dispat: array[insclass, byte] of dispatch ;
  66. insr: mnem; { holds the instructionnumber }
  67. header: array[1..8] of adr;
  68. prog: file of byte; { program and initialized data }
  69. procedure getit; { start the ball rolling }
  70. var cset:set of char;
  71. f:ifset;
  72. insno:byte;
  73. iclass: insclass;
  74. nops:integer;
  75. opcode:byte;
  76. i,j,n:integer;
  77. wtemp:sword;
  78. count:integer;
  79. repc:adr;
  80. nexta,firsta:adr;
  81. elem:byte;
  82. amount,ofst:size;
  83. c:char;
  84. function readb(n:integer):double;
  85. var b:byte;
  86. begin
  87. if eof(prog) then
  88. begin writeln('Premature EOF on EM load file') ; halt end;
  89. read(prog,b); if n>1 then readb:=readb(n-1)*256+b else readb:=b
  90. end;
  91. function readbyte:byte;
  92. begin readbyte:=readb(1) end;
  93. procedure skipbyte;
  94. var dummy: byte;
  95. begin dummy:=readb(1) end;
  96. function readword:word;
  97. begin readword:=readb(wsize) end;
  98. function readadr:adr;
  99. begin readadr:=readb(asize) end;
  100. function ifind(ordinal:byte):mnem;
  101. var loopvar:mnem;
  102. found:boolean;
  103. begin ifind:=NON;
  104. loopvar:=insr; found:=false;
  105. repeat
  106. if ordinal=ord(loopvar) then
  107. begin found:=true; ifind:=loopvar end;
  108. if loopvar<>ZRL then loopvar:=succ(loopvar) else loopvar:=NON;
  109. until found or (loopvar=insr) ;
  110. end;
  111. procedure readhdr;
  112. type hdrw=0..32767 ; { 16 bit header words }
  113. var hdr: hdrw;
  114. i: integer;
  115. begin
  116. for i:=0 to 7 do
  117. begin hdr:=readb(2);
  118. case i of
  119. 0: if hdr<>3757 then { 07255 }
  120. begin writeln('Not an em load file'); halt end;
  121. 1: writeln('Test flags: ',hdr);
  122. 2: if hdr<>0 then
  123. begin writeln('Unsolved references: ',hdr) end;
  124. 3: if hdr<>3 then
  125. begin writeln('Incorrect load file version') end;
  126. 4: wsize:=hdr ;
  127. 5: begin asize:=hdr ; pdsize:= asize+asize end;
  128. 6,7:
  129. if hdr<>0 then
  130. begin writeln('First header entry ',i,', is ',hdr) end;
  131. end
  132. end;
  133. writeln('word size',wsize,', pointer size',asize)
  134. end;
  135. procedure noinit;
  136. begin writeln('Illegal initialization'); halt end;
  137. procedure readint(a:adr;s:size);
  138. const mrange = 4;
  139. var i:size;
  140. val:double;
  141. cont: array[1..mrange] of byte;
  142. begin { construct integer out of byte sequence }
  143. if s<=mrange then
  144. begin
  145. for i:=1 to s do cont[i]:=readbyte ;
  146. if cont[s]>=128 then val:=cont[s]-256 else val:=cont[s];
  147. for i:= s-1 downto 1 do val:= val*256 + cont[i];
  148. writeln(', value ',val)
  149. end
  150. else
  151. begin
  152. write(', bytes(little endian) ');
  153. for i:=1 to s do write(readbyte:4) ;
  154. writeln
  155. end
  156. end;
  157. procedure readuns(a:adr;s:size);
  158. const mrange=3;
  159. var i:size;
  160. val:double;
  161. cont: array[1..mrange] of byte;
  162. begin { construct unsigned integer out of byte sequence }
  163. if s<=mrange then
  164. begin
  165. for i:=1 to s do cont[i]:=readbyte ;
  166. val:=0;
  167. for i:= s downto 1 do val:= val*256 + cont[i];
  168. writeln(', value ',val)
  169. end
  170. else
  171. begin
  172. write(', bytes(little endian) ');
  173. for i:=1 to s do write(readbyte:4) ;
  174. writeln
  175. end
  176. end;
  177. procedure readfloat(a:adr;s:size);
  178. var i:size; b:byte;
  179. begin { construct float out of string}
  180. i:=0;
  181. repeat { eat the bytes, construct the value and intialize at a }
  182. write(chr(readbyte)); i:=i+1;
  183. until b=0 ;
  184. end;
  185. begin
  186. #ifdef INSRT
  187. { initialize tables }
  188. for iclass:=prim to tert do
  189. for i:=0 to 255 do
  190. with dispat[iclass][i] do
  191. begin instr:=NON; iflag:=[zbit] end;
  192. { read instruction table file. see appendix B }
  193. { The table read here is a simple transformation of the table on page xx }
  194. { - instruction names were transformed to numbers }
  195. { - the '-' flag was transformed to an 'i' flag for 'w' type instructions }
  196. { - the 'S' flag was added for instructions having signed operands }
  197. reset(tables);
  198. insr:=NON;
  199. repeat
  200. read(tables,insno) ; cset:=[]; f:=[];
  201. insr:=ifind(insno);
  202. if insr=NON then begin writeln('Incorrect table'); halt end;
  203. repeat read(tables,c) until c<>' ' ;
  204. repeat
  205. cset:=cset+[c];
  206. read(tables,c)
  207. until c=' ' ;
  208. if 'm' in cset then f:=f+[mini];
  209. if 's' in cset then f:=f+[short];
  210. if '-' in cset then f:=f+[zbit];
  211. if 'i' in cset then f:=f+[ibit];
  212. if 'S' in cset then f:=f+[sbit];
  213. if 'w' in cset then f:=f+[wbit];
  214. if (mini in f) or (short in f) then read(tables,nops) else nops:=1 ;
  215. readln(tables,opcode);
  216. if ('4' in cset) or ('8' in cset) then
  217. begin iclass:=tert end
  218. else if 'e' in cset then
  219. begin iclass:=second end
  220. else iclass:=prim;
  221. for i:=0 to nops-1 do
  222. begin
  223. with dispat[iclass,opcode+i] do
  224. begin
  225. iflag:=f; instr:=insr;
  226. if '2' in cset then ilength:=2
  227. else if 'u' in cset then ilength:=2
  228. else if '4' in cset then ilength:=4
  229. else if '8' in cset then ilength:=8
  230. else if (mini in f) or (short in f) then
  231. begin
  232. if 'N' in cset then wtemp:=-1-i else wtemp:=i ;
  233. if 'o' in cset then wtemp:=wtemp+1 ;
  234. if short in f then wtemp:=wtemp*256 ;
  235. implicit:=wtemp
  236. end
  237. end
  238. end
  239. until eof(tables);
  240. #endif
  241. { read in program text, data and procedure descriptors }
  242. reset(prog);
  243. readhdr; { verify first header }
  244. for i:=1 to 8 do header[i]:=readadr; { read second header }
  245. writeln('textsize ',header[NTEXT],', datasize ',header[SZDATA]);
  246. writeln('data descriptors: ',header[NDATA]);
  247. writeln('procedure descriptors: ',header[NPROC]);
  248. writeln('entry procedure: ',header[ENTRY]);
  249. if header[7]<>0 then writeln('Second header entry 7 is ',header[7]);
  250. if header[8]<>0 then writeln('Second header entry 8 is ',header[8]);
  251. { read program text }
  252. for i:=0 to header[NTEXT]-1 do skipbyte;
  253. { read data blocks }
  254. writeln; writeln('Data descriptors:');
  255. nexta:=0;
  256. for i:=1 to header[NDATA] do
  257. begin
  258. n:=readbyte;
  259. write(nexta:5,'- ');
  260. if n<>0 then
  261. begin
  262. elem:=readbyte; firsta:=nexta;
  263. case n of
  264. 1: { uninitialized words }
  265. begin
  266. writeln(elem,' uninitialised word(s)');
  267. nexta:= nexta+ elem*wsize ;
  268. end;
  269. 2: { initialized bytes }
  270. begin
  271. write(elem,' initialised byte(s)');
  272. for j:=1 to elem do
  273. begin
  274. if j mod 10 = 1 then
  275. begin writeln ; write(nexta:6,':') end ;
  276. write(readbyte:4); nexta:=nexta+1
  277. end;
  278. writeln
  279. end;
  280. 3: { initialized words }
  281. begin
  282. write(elem,' initialised word(s)');
  283. for j:=1 to elem do
  284. begin
  285. if j mod 8 = 1 then
  286. begin writeln ; write(nexta:6,':') end ;
  287. write(readword:9); nexta:=nexta+wsize
  288. end;
  289. writeln
  290. end;
  291. 4,5: { instruction and data pointers }
  292. begin
  293. if n=4 then
  294. write(elem,' initialised data pointers')
  295. else
  296. write(elem,' initialised instruction pointers');
  297. for j:=1 to elem do
  298. begin
  299. if j mod 8 = 1 then
  300. begin writeln ; write(nexta:6,':') end ;
  301. write(readadr:9); nexta:=nexta+asize
  302. end;
  303. writeln
  304. end;
  305. 6: { signed integers }
  306. begin
  307. write(elem,'-byte signed integer ');
  308. readint(nexta,elem); nexta:=nexta+elem
  309. end;
  310. 7: { unsigned integers }
  311. begin
  312. write(elem,'-byte unsigned integer ');
  313. readuns(nexta,elem); nexta:=nexta+elem
  314. end;
  315. 8: { floating point numbers }
  316. begin
  317. write(elem,'-byte floating point number ');
  318. readfloat(nexta,elem); nexta:=nexta+elem
  319. end;
  320. end
  321. end
  322. else
  323. begin
  324. repc:=readadr;
  325. amount:=nexta-firsta;
  326. writeln(repc,' copies of the data from ',firsta:2,' to ',nexta:2);
  327. nexta:= nexta + repc*amount ;
  328. end
  329. end;
  330. if header[SZDATA]<>nexta then writeln('Data initialization error');
  331. { read descriptor table }
  332. pd:=header[NTEXT];
  333. for i:=1 to header[NPROC]*pdsize do skipbyte;
  334. end;
  335. begin getit;
  336. #ifdef RTC
  337. repeat
  338. opcode := nextpc; { fetch the first byte of the instruction }
  339. if opcode=escape1 then iclass:=second
  340. else if opcode=escape2 then iclass:=tert
  341. else iclass:=prim;
  342. if iclass<>prim then opcode := nextpc;
  343. with dispat[iclass][opcode] do
  344. begin insr:=instr;
  345. if not (zbit in iflag) then
  346. if ibit in iflag then k:=pop else
  347. begin
  348. if mini in iflag then k:=implicit else
  349. begin
  350. if short in iflag then k:=implicit+nextpc else
  351. begin k:=nextpc;
  352. if (sbit in iflag) and (k>=128) then k:=k-256;
  353. for i:=2 to ilength do k:=256*k + nextpc
  354. end
  355. end;
  356. if wbit in iflag then k:=k*wsize;
  357. end
  358. end;
  359. #endif
  360. end.