2 { This is an interpreter for EM. It serves as a specification for the
3 EM machine. This interpreter must run on a machine which supports
4 arithmetic with words and memory offsets.
6 Certain aspects are over specified. In particular:
8 1. The representation of an address on the stack need not be the
9 numerical value of the memory location.
11 2. The state of the stack is not defined after a trap has aborted
12 an instruction in the middle. For example, it is officially un-
13 defined whether the second operand of an ADD instruction has
14 been popped or not if the first one is undefined ( -32768 or
17 3. The memory layout is implementation dependent. Only the most
18 basic checks are performed whenever memory is accessed.
20 4. The representation of an integer or set on the stack is not fixed
23 5. The format and existence of the procedure descriptors depends on
26 6. The result of the compare operators CMI etc. are -1, 0 and 1
27 here, but other negative and positive values will do and they
28 need not be the same each time.
30 7. The shift count for SHL, SHR, ROL and ROR must be in the range 0
31 to object size in bits - 1. The effect of a count not in this
34 8. This interpreter does not work for double word integers, although
35 any decent EM implementation will include double word arithmetic.
62 program em(tables,prog,core,input,output);
64 program em(tables,prog,input,output);
71 t15 = 32768; { 2**15 }
72 t15m1 = 32767; { 2**15 -1 }
73 t16 = 65536; { 2**16 }
74 t16m1 = 65535; { 2**16 -1 }
75 t31m1 = 2147483647; { 2**31 -1 }
77 { constants indicating the size of words and addresses }
78 wsize = 2; { number of bytes in a word }
79 asize = 2; { number of bytes in an address }
80 fsize = 4; { number of bytes in a floating point number }
81 maxret =4; { number of words in the return value area }
83 signbit = t15; { the power of two indicating the sign bit }
84 negoff = t16; { the next power of two }
85 maxsint = t15m1; { the maximum signed integer }
86 maxuint = t16m1; { the maximum unsigned integer }
87 maxdbl = t31m1; { the maximum double signed integer }
88 maxadr = t16m1; { the maximum address }
89 maxoffs = t15m1; { the maximum offset from an address }
90 maxbitnr= 15; { the number of the highest bit }
92 lineadr = 0; { address of the line number }
93 fileadr = 4; { address of the file name }
94 maxcode = 8191; { highest byte in code address space }
95 maxdata = 8191; { highest byte in data address space }
97 { format of status save area }
98 statd = 4; { how far is static link from lb }
99 dynd = 2; { how far is dynamic link from lb }
100 reta = 0; { how far is the return address from lb }
101 savsize = 4; { size of save area in bytes }
103 { procedure descriptor format }
104 pdlocs = 0; { offset for size of local variables in bytes }
105 pdbase = asize; { offset for the procedure base }
106 pdsize = 4; { size of procedure descriptor in bytes = 2*asize }
116 escape1 = 254; { escape to secondary opcodes }
117 escape2 = 255; { escape to tertiary opcodes }
118 undef = signbit; { the range of integers is -32767 to +32767 }
121 EARRAY = 0; ERANGE = 1; ESET = 2; EIOVFL = 3;
122 EFOVFL = 4; EFUNFL = 5; EIDIVZ = 6; EFDIVZ = 7;
123 EIUND = 8; EFUND = 9; ECONV = 10; ESTACK = 16;
124 EHEAP = 17; EILLINS = 18; EODDZ = 19; ECASE = 20;
125 EMEMFLT = 21; EBADPTR = 22; EBADPC = 23; EBADLAE = 24;
126 EBADMON = 25; EBADLIN = 26; EBADGTO = 27;
130 ----------------------------------------------------------------------------}
132 {---------------------------------------------------------------------------}
135 bitval= 0..1; { one bit }
136 bitnr= 0..maxbitnr; { bits in machine words are numbered 0 to 15 }
137 byte= 0..255; { memory is an array of bytes }
138 adr= {0..maxadr} long; { the range of addresses }
139 word= {0..maxuint} long;{ the range of unsigned integers }
140 offs= -maxoffs..maxoffs; { the range of signed offsets from addresses }
141 size= 0..maxoffs; { the range of sizes is the positive offsets }
142 sword= {-signbit..maxsint} long; { the range of signed integers }
143 full= {-maxuint..maxuint} long; { intermediate results need this range }
144 double={-maxdbl..maxdbl} long; { double precision range }
145 bftype= (andf,iorf,xorf); { tells which boolean operator needed }
146 insclass=(prim,second,tert); { tells which opcode table is in use }
147 instype=(implic,explic); { does opcode have implicit or explicit operand }
148 iflags= (mini,short,sbit,wbit,zbit,ibit);
149 ifset= set of iflags;
152 AAR, ADF, ADI, ADP, ADS, ADU,XAND, ASP, ASS, BEQ,
153 BGE, BGT, BLE, BLM, BLS, BLT, BNE, BRA, CAI, CAL,
154 CFF, CFI, CFU, CIF, CII, CIU, CMF, CMI, CMP, CMS,
155 CMU, COM, CSA, CSB, CUF, CUI, CUU, DCH, DEC, DEE,
156 DEL, DUP, DUS, DVF, DVI, DVU, EXG, FEF, FIF, FIL,
157 GTO, INC, INE, INL, INN, IOR, LAE, LAL, LAR, LDC,
158 LDE, LDF, LDL, LFR, LIL, LIM, LIN, LNI, LOC, LOE,
159 LOF, LOI, LOL, LOR, LOS, LPB, LPI, LXA, LXL, MLF,
160 MLI, MLU, MON, NGF, NGI, NOP, RCK, RET, RMI, RMU,
161 ROL, ROR, RTT, SAR, SBF, SBI, SBS, SBU, SDE, SDF,
162 SDL,XSET, SIG, SIL, SIM, SLI, SLU, SRI, SRU, STE,
163 STF, STI, STL, STR, STS, TEQ, TGE, TGT, TLE, TLT,
164 TNE, TRP, XOR, ZEQ, ZER, ZGE, ZGT, ZLE, ZLT, ZNE,
171 implic: (implicit:sword);
172 explic: (ilength:byte);
177 code: packed array[0..maxcode] of byte; { code space }
178 data: packed array[0..maxdata] of byte; { data space }
179 retarea: array[1..maxret ] of word; { return area }
180 pc,lb,sp,hp,pd: adr; { internal machine registers }
181 i: integer; { integer scratch variable }
182 s,t :word; { scratch variables }
183 sz:size; { scratch variables }
184 ss,st: sword; { scratch variables }
185 k :double; { scratch variables }
186 j:size; { scratch variable used as index }
187 a,b:adr; { scratch variable used for addresses }
188 dt,ds:double; { scratch variables for double precision }
189 rt,rs,x,y:real; { scratch variables for real }
190 found:boolean; { scratch }
191 opcode: byte; { holds the opcode during execution }
192 iclass: insclass; { true for escaped opcodes }
193 dispat: array[insclass,byte] of dispatch;
194 retsize:size; { holds size of last LFR }
195 insr: mnem; { holds the instruction number }
196 halted: boolean; { normally false }
197 exitstatus:word; { parameter of MON 1 }
198 ignmask:word; { ignore mask for traps }
199 uerrorproc:adr; { number of user defined error procedure }
200 intrap:boolean; { Set when executing trap(), to catch recursive calls}
201 trapval:byte; { Set to number of last trap }
202 header: array[1..8] of adr;
204 tables: text; { description of EM instructions }
205 prog: file of byte; { program and initialized data }
207 core: file of byte; { post mortem dump }
212 {---------------------------------------------------------------------------}
213 { Various check routines }
214 {---------------------------------------------------------------------------}
216 { Only the most basic checks are performed. These routines are inherently
217 implementation dependent. }
219 procedure trap(n:byte); forward;
221 procedure writecore(n:byte); forward;
224 procedure memadr(a:adr);
225 begin if (a>maxdata) or ((a<sp) and (a>=hp)) then trap(EMEMFLT) end;
227 procedure wordadr(a:adr);
228 begin memadr(a); if (a mod wsize<>0) then trap(EBADPTR) end;
230 procedure chkadr(a:adr; s:size);
231 begin memadr(a); memadr(a+s-1); { assumption: size is ok }
233 then begin if a mod s<>0 then trap(EBADPTR) end
234 else if a mod wsize<>0 then trap(EBADPTR)
237 procedure newpc(a:double);
238 begin if (a<0) or (a>maxcode) then trap(EBADPC); pc:=a end;
240 procedure newsp(a:adr);
241 begin if (a>lb) or (a<hp) or (a mod wsize<>0) then trap(ESTACK); sp:=a end;
243 procedure newlb(a:adr);
244 begin if (a<sp) or (a mod wsize<>0) then trap(ESTACK); lb:=a end;
246 procedure newhp(a:adr);
247 begin if (a>sp) or (a>maxdata+1) or (a mod wsize<>0)
252 function argc(a:double):sword;
253 begin if (a<-signbit) or (a>maxsint) then trap(EILLINS); argc:=a end;
255 function argd(a:double):double;
256 begin if (a<-maxdbl) or (a>maxdbl) then trap(EILLINS); argd:=a end;
258 function argl(a:double):offs;
259 begin if (a<-maxoffs) or (a>maxoffs) then trap(EILLINS); argl:=a end;
261 function argg(k:double):adr;
262 begin if (k<0) or (k>maxadr) then trap(EILLINS); argg:=k end;
264 function argf(a:double):offs;
265 begin if (a<-maxoffs) or (a>maxoffs) then trap(EILLINS); argf:=a end;
267 function argn(a:double):word;
268 begin if (a<0) or (a>maxuint) then trap(EILLINS); argn:=a end;
270 function args(a:double):size;
271 begin if (a<=0) or (a>maxoffs)
273 else if (a mod wsize)<>0 then trap(EODDZ);
277 function argz(a:double):size;
278 begin if (a<0) or (a>maxoffs)
280 else if (a mod wsize)<>0 then trap(EODDZ);
284 function argo(a:double):size;
285 begin if (a<=0) or (a>maxoffs)
287 else if (a mod wsize<>0) and (wsize mod a<>0) then trap(EODDZ);
291 function argw(a:double):size;
292 begin if (a<=0) or (a>maxoffs) or (a>maxuint)
294 else if (a mod wsize)<>0 then trap(EODDZ);
298 function argp(a:double):size;
299 begin if (a<0) or (a>=header[NPROC]) then trap(EILLINS); argp:=a end;
301 function argr(a:double):word;
302 begin if (a<0) or (a>2) then trap(EILLINS); argr:=a end;
304 procedure argwf(s:double);
305 begin if argw(s)<>fsize then trap(EILLINS) end;
307 function szindex(s:double):integer;
308 begin s:=argw(s); if (s mod wsize <> 0) or (s>2*wsize) then trap(EILLINS);
312 function locadr(l:double):adr;
313 begin l:=argl(l); if l<0 then locadr:=lb+l else locadr:=lb+l+savsize end;
315 function signwd(w:word):sword;
316 begin if w = undef then trap(EIUND);
317 if w >= signbit then signwd:=w-negoff else signwd:=w
320 function dosign(w:word):sword;
321 begin if w >= signbit then dosign:=w-negoff else dosign:=w end;
323 function unsign(w:sword):word;
324 begin if w<0 then unsign:=w+negoff else unsign:=w end;
326 function chopw(dw:double):word;
327 begin chopw:=dw mod negoff end;
329 function fitsw(w:full;trapno:byte):word;
330 { checks whether value fits in signed word, returns unsigned representation}
332 if (w>maxsint) or (w<-signbit) then
334 if w<0 then fitsw:=negoff- (-w)mod negoff
335 else fitsw:=w mod negoff;
337 else fitsw:=unsign(w)
340 function fitd(w:full):double;
342 if abs(w) > maxdbl then trap(ECONV);
349 {---------------------------------------------------------------------------}
350 { Memory access routines }
351 {---------------------------------------------------------------------------}
353 { memw returns a machine word as an unsigned integer
354 memb returns a single byte as a positive integer: 0 <= memb <= 255
355 mems(a,s) fetches an object smaller than a word and returns a word
356 store(a,v) stores the word v at machine address a
357 storea(a,v) stores the address v at machine address a
358 storeb(a,b) stores the byte b at machine address a
359 stores(a,s,v) stores the s least significant bytes of a word at address a
360 memi returns an offset from the instruction space
361 Note that the procedure descriptors are part of instruction space.
362 nextpc returns the next byte addressed by pc, incrementing pc
364 lino changes the line number word.
365 filna changes the pointer to the file name.
367 All routines check to make sure the address is within range and valid for
368 the size of the object. If an addressing error is found, a trap occurs.
372 function memw(a:adr):word;
373 var b:word; i:integer;
374 begin wordadr(a); b:=0;
375 for i:=wsize-1 downto 0 do b:=256*b + data[a+i] ;
379 function memd(a:adr):double; { Always signed }
380 var b:double; i:integer;
381 begin wordadr(a); b:=data[a+2*wsize-1];
382 if b>=128 then b:=b-256;
383 for i:=2*wsize-2 downto 0 do b:=256*b + data[a+i] ;
387 function mema(a:adr):adr;
388 var b:adr; i:integer;
389 begin wordadr(a); b:=0;
390 for i:=asize-1 downto 0 do b:=256*b + data[a+i] ;
394 function mems(a:adr;s:size):word;
395 var i:integer; b:word;
396 begin chkadr(a,s); b:=0; for i:=1 to s do b:=b*256+data[a+s-i]; mems:=b end;
398 function memb(a:adr):byte;
399 begin memadr(a); memb:=data[a] end;
401 procedure store(a:adr; x:word);
404 for i:=0 to wsize-1 do
405 begin data[a+i]:=x mod 256; x:=x div 256 end
408 procedure storea(a:adr; x:adr);
411 for i:=0 to asize-1 do
412 begin data[a+i]:=x mod 256; x:=x div 256 end
415 procedure stores(a:adr;s:size;v:word);
418 for i:=0 to s-1 do begin data[a+i]:=v mod 256; v:=v div 256 end;
421 procedure storeb(a:adr; b:byte);
422 begin memadr(a); data[a]:=b end;
424 function memi(a:adr):adr;
425 var b:adr; i:integer;
426 begin if (a mod wsize<>0) or (a+asize-1>maxcode) then trap(EBADPTR); b:=0;
427 for i:=asize-1 downto 0 do b:=256*b + code[a+i] ;
431 function nextpc:byte;
432 begin if pc>=pd then trap(EBADPC); nextpc:=code[pc]; newpc(pc+1) end;
434 procedure lino(w:word);
435 begin store(lineadr,w) end;
437 procedure filna(a:adr);
438 begin storea(fileadr,a) end;
442 {---------------------------------------------------------------------------}
443 { Stack Manipulation Routines }
444 {---------------------------------------------------------------------------}
446 { push puts a word on the stack
447 pushsw takes a signed one word integer and pushes it on the stack
448 pop removes a machine word from the stack and delivers it as a word
449 popsw removes a machine word from the stack and delivers a signed integer
450 pusha pushes an address on the stack
451 popa removes a machine word from the stack and delivers it as an address
452 pushd pushes a double precision number on the stack
453 popd removes two machine words and returns a double precision integer
454 pushr pushes a float (floating point) number on the stack
455 popr removes several machine words and returns a float number
456 pushx puts an object of arbitrary size on the stack
457 popx removes an object of arbitrary size
460 procedure push(x:word);
461 begin newsp(sp-wsize); store(sp,x) end;
463 procedure pushsw(x:sword);
464 begin newsp(sp-wsize); store(sp,unsign(x)) end;
467 begin pop:=memw(sp); newsp(sp+wsize) end;
469 function popsw:sword;
470 begin popsw:=signwd(pop) end;
472 procedure pusha(x:adr);
473 begin newsp(sp-asize); storea(sp,x) end;
476 begin popa:=mema(sp); newsp(sp+asize) end;
478 procedure pushd(y:double);
479 begin { push double integer onto the stack } newsp(sp-2*wsize) end;
481 function popd:double;
482 begin { pop double integer from the stack } newsp(sp+2*wsize); popd:=0 end;
484 procedure pushr(z:real);
485 begin { Push a float onto the stack } newsp(sp-fsize) end;
488 begin { pop float from the stack } newsp(sp+fsize); popr:=0.0 end;
490 procedure pushx(objsize:size; a:adr);
494 then push(mems(a,objsize))
495 else for i:=1 to objsize div wsize do push(memw(a+objsize-wsize*i))
498 procedure popx(objsize:size; a:adr);
502 then stores(a,objsize,pop)
503 else for i:=1 to objsize div wsize do store(a-wsize+wsize*i,pop)
508 {---------------------------------------------------------------------------}
509 { Bit manipulation routines (extract, shift, rotate) }
510 {---------------------------------------------------------------------------}
512 procedure sleft(var w:sword); { 1 bit left shift }
513 begin w:= dosign(fitsw(2*w,EIOVFL)) end;
515 procedure suleft(var w:word); { 1 bit left shift }
516 begin w := chopw(2*w) end;
518 procedure sdleft(var d:double); { 1 bit left shift }
519 begin { shift two word signed integer } end;
521 procedure sright(var w:sword); { 1 bit right shift with sign extension }
522 begin if w >= 0 then w := w div 2 else w := (w-1) div 2 end;
524 procedure suright(var w:word); { 1 bit right shift without sign extension }
525 begin w := w div 2 end;
527 procedure sdright(var d:double); { 1 bit right shift }
528 begin { shift two word signed integer } end;
530 procedure rleft(var w:word); { 1 bit left rotate }
532 then w:=(w-t15)*2 + 1
536 procedure rright(var w:word); { 1 bit right rotate }
538 then w:=w div 2 + t15
542 function sextend(w:word;s:size):word;
545 for i:=1 to (wsize-s)*8 do rleft(w);
546 for i:=1 to (wsize-s)*8 do sright(w);
550 function bit(b:bitnr; w:word):bitval; { return bit b of the word w }
552 begin for i:= 1 to b do rright(w); bit:= w mod 2 end;
554 function bf(ty:bftype; w1,w2:word):word; { return boolean fcn of 2 words }
557 for i:= maxbitnr downto 0 do
560 andf: if bit(i,w1)+bit(i,w2) = 2 then j:=j+1;
561 iorf: if bit(i,w1)+bit(i,w2) > 0 then j:=j+1;
562 xorf: if bit(i,w1)+bit(i,w2) = 1 then j:=j+1
568 {---------------------------------------------------------------------------}
570 {---------------------------------------------------------------------------}
572 function arraycalc(c:adr):adr; { subscript calculation }
573 var j:full; objsize:size; a:adr;
574 begin j:= popsw - signwd(memw(c));
575 if (j<0) or (j>memw(c+wsize)) then trap(EARRAY);
576 objsize := argo(memw(c+wsize+wsize));
577 a := j*objsize+popa; chkadr(a,objsize);
583 {---------------------------------------------------------------------------}
584 { Double and Real Arithmetic }
585 {---------------------------------------------------------------------------}
587 { All routines for doubles and floats are dummy routines, since the format of
588 doubles and floats is not defined in EM.
591 function doadi(ds,dt:double):double;
592 begin { add two doubles } doadi:=0 end;
594 function dosbi(ds,dt:double):double;
595 begin { subtract two doubles } dosbi:=0 end;
597 function domli(ds,dt:double):double;
598 begin { multiply two doubles } domli:=0 end;
600 function dodvi(ds,dt:double):double;
601 begin { divide two doubles } dodvi:=0 end;
603 function dormi(ds,dt:double):double;
604 begin { modulo of two doubles } dormi:=0 end;
606 function dongi(ds:double):double;
607 begin { negative of a double } dongi:=0 end;
609 function doadf(x,y:real):real;
610 begin { add two floats } doadf:=0.0 end;
612 function dosbf(x,y:real):real;
613 begin { subtract two floats } dosbf:=0.0 end;
615 function domlf(x,y:real):real;
616 begin { multiply two floats } domlf:=0.0 end;
618 function dodvf(x,y:real):real;
619 begin { divide two floats } dodvf:=0.0 end;
621 function dongf(x:real):real;
622 begin { negate a float } dongf:=0.0 end;
624 procedure dofif(x,y:real;var intpart,fraction:real);
625 begin { dismember x*y into integer and fractional parts }
626 intpart:=0.0; { integer part of x*y, same sign as x*y }
628 { fractional part of x*y, 0<=abs(fraction)<1 and same sign as x*y }
631 procedure dofef(x:real;var mantissa:real;var exponent:sword);
632 begin { dismember x into mantissa and exponent parts }
633 mantissa:=0.0; { mantissa of x , >= 1/2 and <1 }
634 exponent:=0; { base 2 exponent of x }
641 {---------------------------------------------------------------------------}
643 {---------------------------------------------------------------------------}
645 procedure call(p:adr); { Perform the call }
648 newlb(sp);newsp(sp - memi(pd + pdsize*p + pdlocs));
649 newpc(memi(pd + pdsize*p+ pdbase))
652 procedure dotrap(n:byte);
655 if (uerrorproc=0) or intrap then
658 writeln('Recursive trap, first trap number was ', trapval:1);
659 writeln('Error ', n:1);
660 writeln('With',ord(insr):4,' arg ',k:1);
666 { Deposit all interpreter variables that need to be saved on
667 the stack. This includes all scratch variables that can
668 be in use at the moment and ( not possible in this interpreter )
669 the internal address of the interpreter where the error occurred.
670 This would make it possible to execute an RTT instruction totally
671 transparent to the user program.
672 It can, for example, occur within an ADD instruction that both
673 operands are undefined and that the result overflows.
674 Although this will generate 3 error traps it must be possible
678 intrap:=true; trapval:=n;
679 for i:=retsize div wsize downto 1 do push(retarea[i]);
680 push(retsize); { saved return area }
681 pusha(mema(fileadr)); { saved current file name pointer }
682 push(memw(lineadr)); { saved line number }
683 push(n); { push error number }
685 uerrorproc:=0; { reset signal }
686 call(a); { call the routine }
687 intrap:=false; { Do not catch recursive traps anymore }
688 goto 8888; { reenter main loop }
692 { This routine is invoked for overflow, and other run time errors.
693 For non-fatal errors, trap returns to the calling routine
696 if n>=16 then dotrap(n) else if bit(n,ignmask)=0 then dotrap(n);
700 { The restoration of file address and line number is not essential.
701 The restoration of the return save area is.
706 newsp(lb); lb:=maxdata+1 ; { to circumvent ESTACK for the popa + pop }
707 newpc(popa); newlb(popa); { So far a plain RET 0 }
708 n:=pop; if (n>=16) and (n<64) then
715 lino(pop); filna(popa); retsize:=pop;
716 for i:=1 to retsize div wsize do retarea[i]:=pop ;
720 {---------------------------------------------------------------------------}
722 {---------------------------------------------------------------------------}
725 procedure domon(entry:word);
732 if (entry<=0) or (entry>63) then entry:=63 ;
735 1: begin { exit } exitstatus:=pop; halted:=true end;
736 3: begin { read } dummy:=pop; { All input is from stdin }
737 rwptr:=popa; count:=popa;
739 while (not eof(input)) and (i<count) do
741 if eoln(input) then begin storeb(rwptr,10) ; count:=i end
742 else storeb(rwptr,ord(input^)) ;
743 get(input); rwptr:=rwptr+1 ; i:=i+1 ;
747 4: begin { write } dummy:=pop; { All output is to stdout }
748 rwptr:=popa; count:=popa;
750 begin token:=memb(rwptr); rwptr:=rwptr+1 ;
751 if token=10 then writeln else write(chr(token))
756 54: begin { ioctl, faked } dummy:=popa;dummy:=popa;dummy:=pop;push(0) end ;
757 2, 5, 6, 7, 8, 9, 10,
758 11, 12, 13, 14, 15, 16, 17, 18, 19, 20,
759 21, 22, 23, 24, 25, 26, 27, 28, 29, 30,
760 31, 32, 33, 34, 35, 36, 37, 38, 39, 40,
761 41, 42, 43, 44, 45, 46, 47, 48, 49, 50,
762 51, 52, 53, 55, 56, 57, 58, 59, 60,
764 begin push(22); push(22) end;
765 63: { exists only for the trap }
771 {---------------------------------------------------------------------------}
772 { Initialization and debugging }
773 {---------------------------------------------------------------------------}
775 procedure doident; { print line number and file name }
776 var a:adr; i,c:integer; found:boolean;
778 write('at line ',memw(lineadr):1,' ');
779 a:=mema(fileadr); if a<>0 then
780 begin i:=20; found:=false;
781 while (i<>0) and not found do
782 begin c:=memb(a); a:=a+1; found:=true; i:=i-1;
783 if (c>=48) and (c<=57) then
784 begin found:=false; write(chr(ord('0')+c-48)) end;
785 if (c>=65) and (c<=90) then
786 begin found:=false; write(chr(ord('A')+c-65)) end;
787 if (c>=97) and (c<=122) then
788 begin found:=false; write(chr(ord('a')+c-97)) end;
795 {---------------------------------------------------------------------------}
798 {This a not a part of the machine definition, but an ad hoc debugging method}
799 {---------------------------------------------------------------------------}
802 var ncoreb,i:integer;
804 procedure wrbyte(b:byte);
805 begin write(core,b); ncoreb:=ncoreb+1 end;
807 procedure wradr(a:adr);
809 begin for i:=1 to asize do begin wrbyte(a mod 256); a:=a div 256 end end;
812 rewrite(core); ncoreb:=0;
813 wrbyte(173); wrbyte(16); { Magic }
814 wrbyte(3);wrbyte(0); { Version }
815 wrbyte(wsize);wrbyte(0); { Wordsize }
816 wrbyte(asize);wrbyte(0); { Address size }
817 wradr(0); { Text size in dump }
818 wradr(maxdata+1); { Data size in dump }
822 wradr(pc); wradr(sp); wradr(lb); wradr(hp); wradr(pd); wradr(0){pb} ;
823 while ncoreb<>512 do wradr(0); { Fill }
824 for i:=0 to maxdata do wrbyte(data[i])
829 procedure initialize; { start the ball rolling }
830 { This is not part of the machine definition }
831 var cset:set of char;
846 function readb(n:integer):double;
848 begin read(prog,b); if n>1 then readb:=readb(n-1)*256+b else readb:=b end;
850 function readbyte:byte;
851 begin readbyte:=readb(1) end;
853 function readword:word;
854 begin readword:=readb(wsize) end;
856 function readadr:adr;
857 begin readadr:=readb(asize) end;
859 function ifind(ordinal:byte):mnem;
863 loopvar:=insr; found:=false;
865 if ordinal=ord(loopvar) then
866 begin found:=true; ifind:=loopvar end;
867 if loopvar<>ZRL then loopvar:=succ(loopvar) else loopvar:=NON;
868 until found or (loopvar=insr) ;
872 type hdrw=0..32767 ; { 16 bit header words }
879 0: if hdr<>3757 then { 07255 }
880 begin writeln('Not an em load file'); halt end;
882 begin writeln('Unsolved references'); halt end;
884 begin writeln('Incorrect load file version'); halt end;
885 4: if hdr<>wsize then
886 begin writeln('Incorrect word size'); halt end;
887 5: if hdr<>asize then
888 begin writeln('Incorrect pointer size'); halt end;
895 begin writeln('Illegal initialization'); halt end;
897 procedure readint(a:adr;s:size);
899 begin { construct integer out of byte sequence }
900 for i:=1 to s do { construct the value and initialize at a }
901 begin storeb(a,readbyte); a:=a+1 end
904 procedure readuns(a:adr;s:size);
905 begin { construct unsigned out of byte sequence }
906 readint(a,s) { identical to readint }
909 procedure readfloat(a:adr;s:size);
911 begin { construct float out of string}
912 if (s<>4) and (s<>8) then noinit; i:=0;
913 repeat { eat the bytes, construct the value and intialize at a }
921 uerrorproc:=0; intrap:=false;
923 { initialize tables }
924 for i:=0 to maxcode do code[i]:=0;
925 for i:=0 to maxdata do data[i]:=0;
926 for iclass:=prim to tert do
928 with dispat[iclass][i] do
929 begin instr:=NON; iflag:=[zbit] end;
931 { read instruction table file. see appendix B }
932 { The table read here is a simple transformation of the table on page xx }
933 { - instruction names were transformed to numbers }
934 { - the '-' flag was transformed to an 'i' flag for 'w' type instructions }
935 { - the 'S' flag was added for instructions having signed operands }
939 read(tables,insno) ; cset:=[]; f:=[];
941 if insr=NON then begin writeln('Incorrect table'); halt end;
942 repeat read(tables,c) until c<>' ' ;
947 if 'm' in cset then f:=f+[mini];
948 if 's' in cset then f:=f+[short];
949 if '-' in cset then f:=f+[zbit];
950 if 'i' in cset then f:=f+[ibit];
951 if 'S' in cset then f:=f+[sbit];
952 if 'w' in cset then f:=f+[wbit];
953 if (mini in f) or (short in f) then read(tables,nops) else nops:=1 ;
954 readln(tables,opcode);
955 if ('4' in cset) or ('8' in cset) then
956 begin iclass:=tert end
957 else if 'e' in cset then
958 begin iclass:=second end
960 for i:=0 to nops-1 do
962 with dispat[iclass,opcode+i] do
964 iflag:=f; instr:=insr;
965 if '2' in cset then ilength:=2
966 else if 'u' in cset then ilength:=2
967 else if '4' in cset then ilength:=4
968 else if '8' in cset then ilength:=8
969 else if (mini in f) or (short in f) then
971 if 'N' in cset then wtemp:=-1-i else wtemp:=i ;
972 if 'o' in cset then wtemp:=wtemp+1 ;
973 if short in f then wtemp:=wtemp*256 ;
980 { read in program text, data and procedure descriptors }
982 readhdr; { verify first header }
983 for i:=1 to 8 do header[i]:=readadr; { read second header }
984 hp:=maxdata+1; sp:=maxdata+1; lino(0);
985 { read program text }
986 if header[NTEXT]+header[NPROC]*pdsize>maxcode then
987 begin writeln('Text size too large'); halt end;
988 if header[SZDATA]>maxdata then
989 begin writeln('Data size too large'); halt end;
990 for i:=0 to header[NTEXT]-1 do code[i]:=readbyte;
993 for i:=1 to header[NDATA] do
998 elem:=readbyte; firsta:=nexta;
1000 1: { uninitialized words }
1002 begin store(nexta,undef); nexta:=nexta+wsize end;
1003 2: { initialized bytes }
1005 begin storeb(nexta,readbyte); nexta:=nexta+1 end;
1006 3: { initialized words }
1008 begin store(nexta,readword); nexta:=nexta+wsize end;
1009 4,5: { instruction and data pointers }
1011 begin storea(nexta,readadr); nexta:=nexta+asize end;
1012 6: { signed integers }
1013 begin readint(nexta,elem); nexta:=nexta+elem end;
1014 7: { unsigned integers }
1015 begin readuns(nexta,elem); nexta:=nexta+elem end;
1016 8: { floating point numbers }
1017 begin readfloat(nexta,elem); nexta:=nexta+elem end;
1023 amount:=nexta-firsta;
1024 for count:=1 to repc do
1026 for ofst:=0 to amount-1 do data[nexta+ofst]:=data[firsta+ofst];
1027 nexta:=nexta+amount;
1031 if header[SZDATA]<>nexta then writeln('Data initialization error');
1033 { read descriptor table }
1035 for i:=1 to header[NPROC]*pdsize do code[pd+i-1]:=readbyte;
1036 { call the entry point routine }
1037 ignmask:=0; { catch all traps, higher numbered traps cannot be ignored}
1039 lb:=maxdata; { illegal dynamic link }
1040 pc:=maxcode; { illegal return address }
1041 push(0); a:=sp; { No environment }
1042 push(0); b:=sp; { No args }
1046 call(argp(header[ENTRY]));
1050 {---------------------------------------------------------------------------}
1051 { MAIN LOOP OF THE INTERPRETER }
1052 {---------------------------------------------------------------------------}
1053 { It should be noted that the interpreter (microprogram) for an EM
1054 machine can be written in two fundamentally different ways: (1) the
1055 instruction operands are fetched in the main loop, or (2) the in-
1056 struction operands are fetched after the 256 way branch, by the exe-
1057 cution routines themselves. In this interpreter, method (1) is used
1058 to simplify the description of execution routines. The dispatch
1059 table dispat is used to determine how the operand is encoded. There
1060 are 4 possibilities:
1062 0. There is no operand
1063 1. The operand and instruction are together in 1 byte (mini)
1064 2. The operand is one byte long and follows the opcode byte(s)
1065 3. The operand is two bytes long and follows the opcode byte(s)
1066 4. The operand is four bytes long and follows the opcode byte(s)
1068 In this interpreter, the main loop determines the operand type,
1069 fetches it, and leaves it in the global variable k for the execution
1070 routines to use. Consequently, instructions such as LOL, which use
1071 three different formats, need only be described once in the body of
1073 However, for a production interpreter, or a hardware EM
1074 machine, it is probably better to use method (2), i.e. to let the
1075 execution routines themselves fetch their own operands. The reason
1076 for this is that each opcode uniquely determines the operand format,
1077 so no table lookup in the dispatch table is needed. The whole table
1078 is not needed. Method (2) therefore executes much faster.
1079 However, separate execution routines will be needed for LOL with
1080 a one byte offset, and LOL with a two byte offset. It is to avoid
1081 this additional clutter that method (1) is used here. In a produc-
1082 tion interpreter, it is envisioned that the main loop will fetch the
1083 next instruction byte, and use it as an index into a 256 word table
1084 to find the address of the interpreter routine to jump to. The
1085 routine jumped to will begin by fetching its operand, if any,
1086 without any table lookup, since it knows which format to expect.
1087 After doing the work, it returns to the main loop by jumping in-
1088 directly to a register that contains the address of the main loop.
1089 A slight variation on this idea is to have the register contain
1090 the address of the branch table, rather than the address of the main
1092 Another issue is whether the execution routines for LOL 0, LOL
1093 2, LOL 4, etc. should all be have distinct execution routines. Doing
1094 so provides for the maximum speed, since the operand is implicit in
1095 the routine itself. The disadvantage is that many nearly identical
1096 execution routines will then be needed. Another way of doing it is
1097 to keep the instruction byte fetched from memory (LOL 0, LOL 2, LOL
1098 4, etc.) in some register, and have all the LOL mini format instruc-
1099 tions branch to a common routine. This routine can then determine
1100 the operand by subtracting the code for LOL 0 from the register,
1101 leaving the true operand in the register (as a word quantity of
1102 course). This method makes the interpreter smaller, but is a bit
1105 To make this important point a little clearer, consider how a
1106 production interpreter for the PDP-11 might appear. Let us assume the
1107 following opcodes have been assigned:
1109 31: LOL -2 (2 bytes, i.e. next word)
1112 34: LOL b (format with a one byte offset)
1113 35: LOL w (format with a one word, i.e. two byte offset)
1115 Further assume that each of the 5 opcodes will have its own execution
1116 routine, i.e. we are making a tradeoff in favor of fast execution and
1117 a slightly larger interpreter.
1118 Register r5 is the em program counter.
1119 Register r4 is the em LB register
1120 Register r3 is the em SP register (the stack grows toward low core)
1121 Register r2 contains the interpreter address of the main loop
1123 The main loop looks like this:
1125 movb (r5)+,r0 /fetch the opcode into r0 and increment r5
1126 asl r0 /shift r0 left 1 bit. Now: -256<=r0<=+254
1127 jmp *table(r0) /jump to execution routine
1129 Notice that no operand fetching has been done. The execution routines for
1130 the 5 sample instructions given above might be as follows:
1132 lol2: mov -2(r4),-(sp) /push local -2 onto stack
1133 jmp (r2) /go back to main loop
1134 lol4: mov -4(r4),-(sp) /push local -4 onto stack
1135 jmp (r2) /go back to main loop
1136 lol6: mov -6(r4),-(sp) /push local -6 onto stack
1137 jmp (r2) /go back to main loop
1138 lolb: mov $177400,r0 /prepare to fetch the 1 byte operand
1139 bisb (r5)+,r0 /operand is now in r0
1140 asl r0 /r0 is now offset from LB in bytes, not words
1141 add r4,r0 /r0 is now address of the needed local
1142 mov (r0),-(sp) /push the local onto the stack
1144 lolw: clr r0 /prepare to fetch the 2 byte operand
1145 bisb (r5)+,r0 /fetch high order byte first !!!
1146 swab r0 /insert high order byte in place
1147 bisb (r5)+,r0 /insert low order byte in place
1148 asl r0 /convert offset to bytes, from words
1149 add r4,r0 /r0 is now address of needed local
1150 mov (r0),-(sp) /stack the local
1153 The important thing to notice is where and how the operand fetch occurred:
1154 lol2, lol4, and lol6, (the minis) have implicit operands
1155 lolb knew it had to fetch one byte, and did so without any table lookup
1156 lolw knew it had to fetch a word, and did so, high order byte first }
1160 {---------------------------------------------------------------------------}
1161 { Routines for the individual instructions }
1162 {---------------------------------------------------------------------------}
1168 LDC: pushd(argd(k));
1169 LOC: pushsw(argc(k));
1170 LOL: push(memw(locadr(k)));
1171 LOE: push(memw(argg(k)));
1172 LIL: push(memw(mema(locadr(k))));
1173 LOF: push(memw(popa+argf(k)));
1174 LAL: pusha(locadr(k));
1175 LAE: pusha(argg(k));
1176 LXL: begin a:=lb; for j:=1 to argn(k) do a:=mema(a+savsize); pusha(a) end;
1178 for j:=1 to argn(k) do a:= mema(a+savsize);
1181 LOI: pushx(argo(k),popa);
1182 LOS: begin k:=argw(k); if k<>wsize then trap(EILLINS);
1183 k:=pop; pushx(argo(k),popa)
1185 LDL: begin a:=locadr(k); push(memw(a+wsize)); push(memw(a)) end;
1186 LDE: begin k:=argg(k); push(memw(k+wsize)); push(memw(k)) end;
1187 LDF: begin k:=argf(k);
1188 a:=popa; push(memw(a+k+wsize)); push(memw(a+k))
1198 STL: store(locadr(k),pop);
1199 STE: store(argg(k),pop);
1200 SIL: store(mema(locadr(k)),pop);
1201 STF: begin a:=popa; store(a+argf(k),pop) end;
1202 STI: popx(argo(k),popa);
1203 STS: begin k:=argw(k); if k<>wsize then trap(EILLINS);
1204 k:=popa; popx(argo(k),popa)
1206 SDL: begin a:=locadr(k); store(a,pop); store(a+wsize,pop) end;
1207 SDE: begin k:=argg(k); store(k,pop); store(k+wsize,pop) end;
1208 SDF: begin k:=argf(k); a:=popa; store(a+k,pop); store(a+k+wsize,pop) end
1216 { SIGNED INTEGER ARITHMETIC }
1217 ADI: case szindex(argw(k)) of
1218 1: begin st:=popsw; ss:=popsw; push(fitsw(ss+st,EIOVFL)) end;
1219 2: begin dt:=popd; ds:=popd; pushd(doadi(ds,dt)) end;
1221 SBI: case szindex(argw(k)) of
1222 1: begin st:=popsw; ss:= popsw; push(fitsw(ss-st,EIOVFL)) end;
1223 2: begin dt:=popd; ds:=popd; pushd(dosbi(ds,dt)) end;
1225 MLI: case szindex(argw(k)) of
1226 1: begin st:=popsw; ss:= popsw; push(fitsw(ss*st,EIOVFL)) end;
1227 2: begin dt:=popd; ds:=popd; pushd(domli(ds,dt)) end;
1229 DVI: case szindex(argw(k)) of
1230 1: begin st:= popsw; ss:= popsw;
1231 if st=0 then trap(EIDIVZ) else pushsw(ss div st)
1233 2: begin dt:=popd; ds:=popd; pushd(dodvi(ds,dt)) end;
1235 RMI: case szindex(argw(k)) of
1236 1: begin st:= popsw; ss:=popsw;
1237 if st=0 then trap(EIDIVZ) else pushsw(ss - (ss div st)*st)
1239 2: begin dt:=popd; ds:=popd; pushd(dormi(ds,dt)) end
1241 NGI: case szindex(argw(k)) of
1242 1: begin st:=popsw; pushsw(-st) end;
1243 2: begin ds:=popd; pushd(dongi(ds)) end
1246 case szindex(argw(k)) of
1248 for i:= 1 to t do sleft(ss); pushsw(ss)
1253 case szindex(argw(k)) of
1255 for i:= 1 to t do sright(ss); pushsw(ss)
1258 for i:= 1 to t do sdright(ss); pushd(ss)
1269 { UNSIGNED INTEGER ARITHMETIC }
1270 ADU: case szindex(argw(k)) of
1271 1: begin t:=pop; s:= pop; push(chopw(s+t)) end;
1274 SBU: case szindex(argw(k)) of
1275 1: begin t:=pop; s:= pop; push(chopw(s-t)) end;
1278 MLU: case szindex(argw(k)) of
1279 1: begin t:=pop; s:= pop; push(chopw(s*t)) end;
1282 DVU: case szindex(argw(k)) of
1283 1: begin t:= pop; s:= pop;
1284 if t=0 then trap(EIDIVZ) else push(s div t)
1288 RMU: case szindex(argw(k)) of
1289 1: begin t:= pop; s:=pop;
1290 if t=0 then trap(EIDIVZ) else push(s - (s div t)*t)
1294 SLU: case szindex(argw(k)) of
1295 1: begin t:=pop; s:=pop;
1296 for i:= 1 to t do suleft(s); push(s)
1300 SRU: case szindex(argw(k)) of
1301 1: begin t:=pop; s:=pop;
1302 for i:= 1 to t do suright(s); push(s)
1312 { FLOATING POINT ARITHMETIC }
1313 ADF: begin argwf(k); rt:=popr; rs:=popr; pushr(doadf(rs,rt)) end;
1314 SBF: begin argwf(k); rt:=popr; rs:=popr; pushr(dosbf(rs,rt)) end;
1315 MLF: begin argwf(k); rt:=popr; rs:=popr; pushr(domlf(rs,rt)) end;
1316 DVF: begin argwf(k); rt:=popr; rs:=popr; pushr(dodvf(rs,rt)) end;
1317 NGF: begin argwf(k); rt:=popr; pushr(dongf(rt)) end;
1318 FIF: begin argwf(k); rt:=popr; rs:=popr;
1319 dofif(rt,rs,x,y); pushr(y); pushr(x)
1321 FEF: begin argwf(k); rt:=popr; dofef(rt,x,ss); pushr(x); pushsw(ss) end
1328 { POINTER ARITHMETIC }
1329 ADP: pusha(popa+argf(k));
1330 ADS: case szindex(argw(k)) of
1331 1: begin st:=popsw; pusha(popa+st) end;
1332 2: begin dt:=popd; pusha(popa+dt) end;
1336 case szindex(argw(k)) of
1337 1: push(fitsw(b-a,EIOVFL));
1348 { INCREMENT/DECREMENT/ZERO }
1349 INC: push(fitsw(popsw+1,EIOVFL));
1350 INL: begin a:=locadr(k); store(a,fitsw(signwd(memw(a))+1,EIOVFL)) end;
1351 INE: begin a:=argg(k); store(a,fitsw(signwd(memw(a))+1,EIOVFL)) end;
1352 DEC: push(fitsw(popsw-1,EIOVFL));
1353 DEL: begin a:=locadr(k); store(a,fitsw(signwd(memw(a))-1,EIOVFL)) end;
1354 DEE: begin a:=argg(k); store(a,fitsw(signwd(memw(a))-1,EIOVFL)) end;
1355 ZRL: store(locadr(k),0);
1356 ZRE: store(argg(k),0);
1357 ZER: for j:=1 to argw(k) div wsize do push(0);
1366 CII: begin s:=pop; t:=pop;
1367 if t<wsize then begin push(sextend(pop,t)); t:=wsize end;
1368 case szindex(argw(t)) of
1369 1: if szindex(argw(s))=2 then pushd(popsw);
1370 2: if szindex(argw(s))=1 then push(fitsw(popd,ECONV))
1373 CIU: case szindex(argw(pop)) of
1374 1: if szindex(argw(pop))=2 then push(unsign(popd mod negoff));
1377 CIF: begin argwf(pop);
1378 case szindex(argw(pop)) of 1:pushr(popsw); 2:pushr(popd) end
1380 CUI: case szindex(argw(pop)) of
1381 1: case szindex(argw(pop)) of
1382 1: begin s:=pop; if s>maxsint then trap(ECONV); push(s) end;
1385 2: case szindex(argw(pop)) of
1390 CUU: case szindex(argw(pop)) of
1391 1: if szindex(argw(pop))=2 then trap(EILLINS);
1394 CUF: begin argwf(pop);
1395 if szindex(argw(pop))=1 then pushr(pop) else trap(EILLINS)
1397 CFI: begin sz:=argw(pop); argwf(pop); rt:=popr;
1399 1: push(fitsw(trunc(rt),ECONV));
1400 2: pushd(fitd(trunc(rt)));
1403 CFU: begin sz:=argw(pop); argwf(pop); rt:=popr;
1405 1: push( chopw(trunc(abs(rt)-0.5)) );
1409 CFF: begin argwf(pop); argwf(pop) end
1420 for j:= 1 to k div wsize do
1421 begin a:=sp+k; t:=pop; store(a,bf(andf,memw(a),t)) end;
1425 for j:= 1 to k div wsize do
1426 begin a:=sp+k; t:=pop; store(a,bf(iorf,memw(a),t)) end;
1430 for j:= 1 to k div wsize do
1431 begin a:=sp+k; t:=pop; store(a,bf(xorf,memw(a),t)) end;
1435 for j:= 1 to k div wsize do
1437 store(sp+k-wsize*j, bf(xorf,memw(sp+k-wsize*j), negoff-1))
1440 ROL: begin k:=argw(k); if k<>wsize then trap(EILLINS);
1441 t:=pop; s:=pop; for i:= 1 to t do rleft(s); push(s)
1443 ROR: begin k:=argw(k); if k<>wsize then trap(EILLINS);
1444 t:=pop; s:=pop; for i:= 1 to t do rright(s); push(s)
1457 i:= t mod 8; t:= t div 8;
1459 begin trap(ESET); s:=0 end
1461 begin s:=memb(sp+t) end;
1462 newsp(sp+k); push(bit(i,s));
1467 i:= t mod 8; t:= t div 8;
1468 for j:= 1 to k div wsize do push(0);
1472 begin s:=1; for j:= 1 to i do rleft(s); storeb(sp+t,s) end
1482 begin k:=argw(k); if k<>wsize then trap(EILLINS); a:=popa;
1483 pushx(argo(memw(a+2*k)),arraycalc(a))
1486 begin k:=argw(k); if k<>wsize then trap(EILLINS); a:=popa;
1487 popx(argo(memw(a+2*k)),arraycalc(a))
1490 begin k:=argw(k); if k<>wsize then trap(EILLINS); a:=popa;
1500 CMI: case szindex(argw(k)) of
1501 1: begin st:=popsw; ss:=popsw;
1502 if ss<st then pushsw(-1) else if ss=st then push(0) else push(1)
1504 2: begin dt:=popd; ds:=popd;
1505 if ds<dt then pushsw(-1) else if ds=dt then push(0) else push(1)
1508 CMU: case szindex(argw(k)) of
1509 1: begin t:=pop; s:=pop;
1510 if s<t then pushsw(-1) else if s=t then push(0) else push(1)
1514 CMP: begin a:=popa; b:=popa;
1515 if b<a then pushsw(-1) else if b=a then push(0) else push(1)
1517 CMF: begin argwf(k); rt:=popr; rs:=popr;
1518 if rs<rt then pushsw(-1) else if rs=rt then push(0) else push(1)
1520 CMS: begin k:=argw(k);
1522 while (j < k) and (t=0) do
1523 begin if memw(sp+j) <> memw(sp+k+j) then t:=1;
1526 newsp(sp+wsize*k); push(t);
1529 TLT: if popsw < 0 then push(1) else push(0);
1530 TLE: if popsw <= 0 then push(1) else push(0);
1531 TEQ: if pop = 0 then push(1) else push(0);
1532 TNE: if pop <> 0 then push(1) else push(0);
1533 TGE: if popsw >= 0 then push(1) else push(0);
1534 TGT: if popsw > 0 then push(1) else push(0);
1538 procedure branchops;
1544 BLT: begin st:=popsw; if popsw < st then newpc(pc+k) end;
1545 BLE: begin st:=popsw; if popsw <= st then newpc(pc+k) end;
1546 BEQ: begin t :=pop ; if pop = t then newpc(pc+k) end;
1547 BNE: begin t :=pop ; if pop <> t then newpc(pc+k) end;
1548 BGE: begin st:=popsw; if popsw >= st then newpc(pc+k) end;
1549 BGT: begin st:=popsw; if popsw > st then newpc(pc+k) end;
1551 ZLT: if popsw < 0 then newpc(pc+k);
1552 ZLE: if popsw <= 0 then newpc(pc+k);
1553 ZEQ: if pop = 0 then newpc(pc+k);
1554 ZNE: if pop <> 0 then newpc(pc+k);
1555 ZGE: if popsw >= 0 then newpc(pc+k);
1556 ZGT: if popsw > 0 then newpc(pc+k)
1564 { PROCEDURE CALL GROUP }
1566 CAI: begin call(argp(popa)) end;
1567 RET: begin k:=argz(k); if k div wsize>maxret then trap(EILLINS);
1568 for j:= 1 to k div wsize do retarea[j]:=pop; retsize:=k;
1569 newsp(lb); lb:=maxdata+1; { To circumvent stack overflow error }
1574 if retsize=wsize then exitstatus:=retarea[1]
1575 else exitstatus:=undef
1580 LFR: begin k:=args(k); if k<>retsize then trap(EILLINS);
1581 for j:=k div wsize downto 1 do push(retarea[j]);
1590 { MISCELLANEOUS GROUP }
1592 begin if insr=ASS then
1593 begin k:=argw(k); if k<>wsize then trap(EILLINS); k:=popsw end;
1596 then for j:= 1 to -k div wsize do push(undef)
1600 begin if insr=BLS then
1601 begin k:=argw(k); if k<>wsize then trap(EILLINS); k:=pop end;
1604 for j := 1 to k div wsize do
1605 store(b-wsize+wsize*j,memw(a-wsize+wsize*j))
1607 CSA: begin k:=argw(k); if k<>wsize then trap(EILLINS);
1609 st:= popsw - signwd(memw(a+asize));
1610 if (st>=0) and (st<=memw(a+wsize+asize)) then
1611 b:=mema(a+2*wsize+asize+asize*st) else b:=mema(a);
1612 if b=0 then trap(ECASE) else newpc(b)
1614 CSB: begin k:=argw(k); if k<>wsize then trap(EILLINS); a:=popa;
1615 t:=pop; i:=1; found:=false;
1616 while (i<=memw(a+asize)) and not found do
1617 if t=memw(a+(asize+wsize)*i) then found:=true else i:=i+1;
1618 if found then b:=memw(a+(asize+wsize)*i+wsize) else b:=memw(a);
1619 if b=0 then trap(ECASE) else newpc(b);
1621 DCH: begin pusha(mema(popa+dynd)) end;
1623 begin if insr=DUS then
1624 begin k:=argw(k); if k<>wsize then trap(EILLINS); k:=pop end;
1626 for i:=1 to k div wsize do push(memw(sp+k-wsize));
1630 for i:=1 to k div wsize do push(memw(sp+k-wsize));
1631 for i:=0 to k div wsize - 1 do
1632 store(sp+k+i*wsize,memw(sp+k+k+i*wsize));
1633 for i:=1 to k div wsize do
1634 begin t:=pop ; store(sp+k+k-wsize,t) end;
1636 FIL: filna(argg(k));
1637 GTO: begin k:=argg(k);
1638 newlb(mema(k+2*asize)); newsp(mema(k+asize)); newpc(mema(k))
1642 LNI: lino(memw(0)+1);
1643 LOR: begin i:=argr(k);
1644 case i of 0:pusha(lb); 1:pusha(sp); 2:pusha(hp) end;
1646 LPB: pusha(popa+statd);
1648 NOP: writeln('NOP at line ',memw(0):5) ;
1650 case szindex(argw(k)) of
1651 1: if (signwd(memw(sp))<signwd(memw(a))) or
1652 (signwd(memw(sp))>signwd(memw(a+wsize))) then trap(ERANGE);
1653 2: if (memd(sp)<memd(a)) or
1654 (memd(sp)>memd(a+2*wsize)) then trap(ERANGE);
1658 SIG: begin a:=popa; pusha(uerrorproc); uerrorproc:=a end;
1660 STR: begin i:=argr(k);
1661 case i of 0: newlb(popa); 1: newsp(popa); 2: newhp(popa) end;
1668 {---------------------------------------------------------------------------}
1670 {---------------------------------------------------------------------------}
1675 opcode := nextpc; { fetch the first byte of the instruction }
1676 if opcode=escape1 then iclass:=second
1677 else if opcode=escape2 then iclass:=tert
1679 if iclass<>prim then opcode := nextpc;
1680 with dispat[iclass][opcode] do
1682 if not (zbit in iflag) then
1683 if ibit in iflag then k:=pop else
1685 if mini in iflag then k:=implicit else
1687 if short in iflag then k:=implicit+nextpc else
1689 if (sbit in iflag) and (k>=128) then k:=k-256;
1690 for i:=2 to ilength do k:=256*k + nextpc
1693 if wbit in iflag then k:=k*wsize;
1701 LDC,LOC,LOL,LOE,LIL,LOF,LAL,LAE,LXL,LXA,LOI,LOS,LDL,LDE,LDF,LPI:
1705 STL,STE,SIL,STF,STI,STS,SDL,SDE,SDF:
1708 { SIGNED INTEGER ARITHMETIC }
1709 ADI,SBI,MLI,DVI,RMI,NGI,SLI,SRI:
1712 { UNSIGNED INTEGER ARITHMETIC }
1713 ADU,SBU,MLU,DVU,RMU,SLU,SRU:
1716 { FLOATING POINT ARITHMETIC }
1717 ADF,SBF,MLF,DVF,NGF,FIF,FEF:
1720 { POINTER ARITHMETIC }
1724 { INCREMENT/DECREMENT/ZERO }
1725 INC,INL,INE,DEC,DEL,DEE,ZRL,ZRE,ZER,ZRF:
1729 CII,CIU,CIF,CUI,CUU,CUF,CFI,CFU,CFF:
1733 XAND,IOR,XOR,COM,ROL,ROR:
1745 CMI,CMU,CMP,CMF,CMS, TLT,TLE,TEQ,TNE,TGE,TGT:
1749 BRA, BLT,BLE,BEQ,BNE,BGE,BGT, ZLT,ZLE,ZEQ,ZNE,ZGE,ZGT:
1752 { PROCEDURE CALL GROUP }
1756 { MISCELLANEOUS GROUP }
1757 ASP,ASS,BLM,BLS,CSA,CSB,DCH,DUP,DUS,EXG,FIL,GTO,LIM,
1758 LIN,LNI,LOR,LPB,MON,NOP,RCK,RTT,SIG,SIM,STR,TRP:
1761 end; { end of case statement }
1762 if not ( (insr=RET) or (insr=ASP) or (insr=BRA) or (insr=GTO) ) then
1766 writeln('halt with exit status: ',exitstatus:1);