doc/em/em.i

   1 .bp
   2 .AP "EM INTERPRETER"
   3 .nf
   4 .ft CW
   5 .lg 0
   6 .nr x \w'        '
   7 .ta \nxu +\nxu +\nxu +\nxu +\nxu +\nxu +\nxu +\nxu +\nxu +\nxu
   8
   9 { This  is an interpreter for EM.  It serves as  the official machine
  10   definition.  This interpreter must run on a machine which supports
  11   arithmetic with words and memory offsets.
  12
  13   Certain aspects of the definition are over specified.  In particular:
  14
  15     1. The representation of  an  address on the stack  need not be the
  16        numerical value of the memory location.
  17
  18     2. The state of  the stack is not defined  after a trap has aborted
  19        an instruction in the middle.  For example, it is officially un-
  20        defined  whether the second  operand of an  ADD  instruction has
  21        been popped  or  not  if the  first one is undefined ( -32768 or
  22        unsigned 32768).
  23
  24     3. The memory layout is implementation dependent. Only the most
  25        basic checks are performed whenever memory is accessed.
  26
  27     4. The representation of an integer or set on the stack is not fixed
  28        in bit order.
  29
  30     5. The format and existence of the procedure descriptors depends on
  31        the implementation.
  32
  33     6. The result of the compare operators  CMI etc.  are -1, 0  and  1
  34        here, but other negative  and  positive values will do  and they
  35        need not be the same each time.
  36
  37     7. The shift count for SHL, SHR, ROL and ROR must be in the range 0
  38        to object size in bits - 1.  The effect of a  count  not in this
  39        range is undefined.
  40 }
  41 .bp
  42 {$i256} {$d+}
  43 program em(tables,prog,input,output);
  44
  45 label 8888,9999;
  46
  47 const
  48   t15   = 32768;        { 2**15    }
  49   t15m1 = 32767;        { 2**15 -1 }
  50   t16   = 65536;        { 2**16    }
  51   t16m1 = 65535;        { 2**16 -1 }
  52   t31m1 = 2147483647;   { 2**31 -1 }
  53
  54   wsize = 2;            { number of bytes in a word }
  55   asize = 2;            { number of bytes in an address }
  56   fsize = 4;            { number of bytes in a floating point number }
  57   maxret =4;            { number of words in the return value area }
  58
  59   signbit = t15;        { the power of two indicating the sign bit }
  60   negoff  = t16;        { the next power of two }
  61   maxsint = t15m1;      { the maximum signed integer }
  62   maxuint = t16m1;      { the maximum unsigned integer }
  63   maxdbl  = t31m1;      { the maximum double signed integer }
  64   maxadr  = t16m1;      { the maximum address }
  65   maxoffs = t15m1;      { the maximum offset from an address }
  66   maxbitnr= 15;         { the number of the highest bit }
  67
  68   lineadr = 0;          { address of the line number }
  69   fileadr = 4;          { address of the file name }
  70   maxcode = 8191;       { highest byte in code address space }
  71   maxdata = 8191;       { highest byte in data address space }
  72
  73   { format of status save area }
  74   statd   = 4;          { how far is static link from lb }
  75   dynd    = 2;          { how far is dynamic link from lb }
  76   reta    = 0;          { how far is the return address from lb }
  77   savsize = 4;          { size of save area in bytes }
  78
  79   { procedure descriptor format }
  80   pdlocs  = 0;          { offset for size of local variables in bytes }
  81   pdbase  = asize;      { offset for the procedure base }
  82   pdsize  = 4;          { size of procedure descriptor in bytes = 2*asize }
  83
  84   { header words }
  85   NTEXT   = 1;
  86   NDATA   = 2;
  87   NPROC   = 3;
  88   ENTRY   = 4;
  89   NLINE   = 5;
  90   SZDATA  = 6;
  91
  92   escape1 = 254;        { escape to secondary opcodes }
  93   escape2 = 255;        { escape to tertiary opcodes }
  94   undef   = signbit;    { the range of integers is -32767 to +32767 }
  95
  96   { error codes }
  97   EARRAY   =  0; ERANGE   =  1; ESET     =  2; EIOVFL   =  3; EFOVFL   =  4;
  98   EFUNFL   =  5; EIDIVZ   =  6; EFDIVZ   =  7; EIUND    =  8; EFUND    =  9;
  99   ECONV    = 10; ESTACK   = 16; EHEAP    = 17; EILLINS  = 18; EODDZ    = 19;
 100   ECASE    = 20; EMEMFLT  = 21; EBADPTR  = 22; EBADPC   = 23; EBADLAE  = 24;
 101   EBADMON  = 25; EBADLIN  = 26; EBADGTO  = 27;
 102 .ne 20
 103 .bp
 104 {---------------------------------------------------------------------------}
 105 {                             Declarations                                  }
 106 {---------------------------------------------------------------------------}
 107
 108 type
 109   bitval= 0..1;             { one bit }
 110   bitnr=  0..maxbitnr;      { bits in machine words are numbered 0 to 15 }
 111   byte=   0..255;           { memory is an array of bytes }
 112   adr=    {0..maxadr} long; { the range of addresses }
 113   word=   {0..maxuint} long;{ the range of unsigned integers }
 114   offs=  -maxoffs..maxoffs; { the range of signed offsets from addresses }
 115   size=   0..maxoffs;       { the range of sizes is the positive offsets }
 116   sword= {-signbit..maxsint} long; { the range of signed integers }
 117   full=  {-maxuint..maxuint} long; { intermediate results need this range }
 118   double={-maxdbl..maxdbl} long;   { double precision range }
 119   bftype= (andf,iorf,xorf); { tells which boolean operator needed }
 120   insclass=(prim,second,tert); { tells which opcode table is in use }
 121   instype=(implic,explic);  { does opcode have implicit or explicit operand }
 122   iflags= (mini,short,sbit,wbit,zbit,ibit);
 123   ifset=  set of iflags;
 124
 125   mnem = ( NON,
 126            AAR, ADF, ADI, ADP, ADS, ADU,XAND, ASP, ASS, BEQ,
 127            BGE, BGT, BLE, BLM, BLS, BLT, BNE, BRA, CAI, CAL,
 128            CFF, CFI, CFU, CIF, CII, CIU, CMF, CMI, CMP, CMS,
 129            CMU, COM, CSA, CSB, CUF, CUI, CUU, DCH, DEC, DEE,
 130            DEL, DUP, DUS, DVF, DVI, DVU, EXG, FEF, FIF, FIL,
 131            GTO, INC, INE, INL, INN, IOR, LAE, LAL, LAR, LDC,
 132            LDE, LDF, LDL, LFR, LIL, LIM, LIN, LNI, LOC, LOE,
 133            LOF, LOI, LOL, LOR, LOS, LPB, LPI, LXA, LXL, MLF,
 134            MLI, MLU, MON, NGF, NGI, NOP, RCK, RET, RMI, RMU,
 135            ROL, ROR, RTT, SAR, SBF, SBI, SBS, SBU, SDE, SDF,
 136            SDL,XSET, SIG, SIL, SIM, SLI, SLU, SRI, SRU, STE,
 137            STF, STI, STL, STR, STS, TEQ, TGE, TGT, TLE, TLT,
 138            TNE, TRP, XOR, ZEQ, ZER, ZGE, ZGT, ZLE, ZLT, ZNE,
 139            ZRE, ZRF, ZRL);
 140
 141   dispatch = record
 142                 iflag: ifset;
 143                 instr: mnem;
 144                 case instype of
 145                 implic: (implicit:sword);
 146                 explic: (ilength:byte);
 147              end;
 148
 149
 150 var
 151   code: packed array[0..maxcode] of byte;      { code space }
 152   data: packed array[0..maxdata] of byte;      { data space }
 153   retarea: array[1..maxret ] of word;          { return area }
 154   pc,lb,sp,hp,pd: adr;  { internal machine registers }
 155   i: integer;           { integer scratch variable }
 156   s,t :word;            { scratch variables }
 157   sz:size;              { scratch variables }
 158   ss,st: sword;         { scratch variables }
 159   k :double;            { scratch variables }
 160   j:size;               { scratch variable used as index }
 161   a,b:adr;              { scratch variable used for addresses }
 162   dt,ds:double;         { scratch variables for double precision }
 163   rt,rs,x,y:real;       { scratch variables for real }
 164   found:boolean;        { scratch }
 165   opcode: byte;         { holds the opcode during execution }
 166   iclass: insclass;     { true for escaped opcodes }
 167   dispat: array[insclass,byte] of dispatch;
 168   retsize:size;         { holds size of last LFR }
 169   insr: mnem;           { holds the instruction number }
 170   halted: boolean;      { normally false }
 171   exitstatus:word;      { parameter of MON 1 }
 172   ignmask:word;         { ignore mask for traps }
 173   uerrorproc:adr;       { number of user defined error procedure }
 174   intrap:boolean;       { Set when executing trap(), to catch recursive calls}
 175   trapval:byte;         { Set to number of last trap }
 176   header: array[1..8] of adr;
 177
 178   tables: text;         { description of EM instructions }
 179   prog: file of byte;   { program and initialized data }
 180 .ne 20
 181 .sp 2
 182 {---------------------------------------------------------------------------}
 183 {                        Various check routines                             }
 184 {---------------------------------------------------------------------------}
 185
 186 { Only the most basic checks are performed. These routines are inherently
 187   implementation dependent. }
 188
 189 procedure trap(n:byte); forward;
 190
 191 procedure memadr(a:adr);
 192 begin if (a>maxdata) or ((a<sp) and (a>=hp)) then trap(EMEMFLT) end;
 193
 194 procedure wordadr(a:adr);
 195 begin memadr(a); if (a mod wsize<>0) then trap(EBADPTR) end;
 196
 197 procedure chkadr(a:adr; s:size);
 198 begin memadr(a); memadr(a+s-1); { assumption: size is ok }
 199       if s<wsize
 200       then begin if a mod s<>0  then trap(EBADPTR) end
 201       else       if a mod wsize<>0 then trap(EBADPTR)
 202 end;
 203
 204 procedure newpc(a:double);
 205 begin if (a<0) or (a>maxcode) then trap(EBADPC); pc:=a end;
 206
 207 procedure newsp(a:adr);
 208 begin if (a>lb) or (a<hp) or (a mod wsize<>0) then trap(ESTACK); sp:=a end;
 209
 210 procedure newlb(a:adr);
 211 begin if (a<sp) or (a mod wsize<>0) then trap(ESTACK); lb:=a end;
 212
 213 procedure newhp(a:adr);
 214 begin if (a>sp) or (a>maxdata+1) or (a mod wsize<>0)
 215       then trap(EHEAP)
 216       else hp:=a
 217 end;
 218
 219 function argc(a:double):sword;
 220 begin if (a<-signbit) or (a>maxsint) then trap(EILLINS); argc:=a end;
 221
 222 function argd(a:double):double;
 223 begin if (a<-maxdbl) or (a>maxdbl) then trap(EILLINS); argd:=a end;
 224
 225 function argl(a:double):offs;
 226 begin if (a<-maxoffs) or (a>maxoffs) then trap(EILLINS); argl:=a end;
 227
 228 function argg(k:double):adr;
 229 begin if (k<0) or (k>maxadr) then trap(EILLINS); argg:=k end;
 230
 231 function argf(a:double):offs;
 232 begin if (a<-maxoffs) or (a>maxoffs) then trap(EILLINS); argf:=a end;
 233
 234 function argn(a:double):word;
 235 begin if (a<0) or (a>maxuint) then trap(EILLINS); argn:=a end;
 236
 237 function args(a:double):size;
 238 begin if (a<=0) or (a>maxoffs)
 239         then trap(EODDZ)
 240         else if (a mod wsize)<>0 then trap(EODDZ);
 241       args:=a ;
 242 end;
 243
 244 function argz(a:double):size;
 245 begin if (a<0) or (a>maxoffs)
 246         then trap(EODDZ)
 247         else if (a mod wsize)<>0 then trap(EODDZ);
 248       argz:=a ;
 249 end;
 250
 251 function argo(a:double):size;
 252 begin if (a<=0) or (a>maxoffs)
 253         then trap(EODDZ)
 254         else if (a mod wsize<>0) and (wsize mod a<>0) then trap(EODDZ);
 255       argo:=a ;
 256 end;
 257
 258 function argw(a:double):size;
 259 begin if (a<=0) or (a>maxoffs) or (a>maxuint)
 260         then trap(EODDZ)
 261         else if (a mod wsize)<>0 then trap(EODDZ);
 262       argw:=a ;
 263 end;
 264
 265 function argp(a:double):size;
 266 begin if (a<0) or (a>=header[NPROC]) then trap(EILLINS); argp:=a end;
 267
 268 function argr(a:double):word;
 269 begin if (a<0) or (a>2) then trap(EILLINS); argr:=a end;
 270
 271 procedure argwf(s:double);
 272 begin if argw(s)<>fsize then trap(EILLINS) end;
 273
 274 function szindex(s:double):integer;
 275 begin s:=argw(s); if (s mod wsize <> 0) or (s>2*wsize) then trap(EILLINS);
 276       szindex:=s div wsize
 277 end;
 278
 279 function locadr(l:double):adr;
 280 begin l:=argl(l); if l<0 then locadr:=lb+l else locadr:=lb+l+savsize end;
 281
 282 function signwd(w:word):sword;
 283 begin if w = undef then trap(EIUND);
 284       if w >= signbit then signwd:=w-negoff else signwd:=w
 285 end;
 286
 287 function dosign(w:word):sword;
 288 begin if w >= signbit then dosign:=w-negoff else dosign:=w end;
 289
 290 function unsign(w:sword):word;
 291 begin if w<0 then unsign:=w+negoff else unsign:=w end;
 292
 293 function chopw(dw:double):word;
 294 begin chopw:=dw mod negoff end;
 295
 296 function fitsw(w:full;trapno:byte):word;
 297 { checks whether value fits in signed word, returns unsigned representation}
 298 begin
 299   if (w>maxsint) or (w<-signbit) then
 300     begin trap(trapno);
 301       if w<0 then fitsw:=negoff- (-w)mod negoff
 302              else fitsw:=w mod negoff;
 303     end
 304   else fitsw:=unsign(w)
 305 end;
 306
 307 function fitd(w:full):double;
 308 begin
 309   if abs(w) > maxdbl then trap(ECONV);
 310   fitd:=w
 311 end;
 312 .ne 20
 313 .sp 2
 314 {---------------------------------------------------------------------------}
 315 {                        Memory access routines                             }
 316 {---------------------------------------------------------------------------}
 317
 318 { memw returns a machine word as an unsigned integer
 319   memb returns a single byte as a positive integer: 0 <= memb <= 255
 320   mems(a,s) fetches an object smaller than a word and returns a word
 321   store(a,v) stores the word v at machine address a
 322   storea(a,v) stores the address v at machine address a
 323   storeb(a,b) stores the byte b at machine address a
 324   stores(a,s,v) stores the s least significant bytes of a word at address a
 325   memi returns an offset from the instruction space
 326        Note that the procedure descriptors are part of instruction space.
 327   nextpc returns the next byte addressed by pc, incrementing pc
 328
 329   lino changes the line number word.
 330   filna changes the pointer to the file name.
 331
 332   All routines check to make sure the address is within range and valid for
 333   the size of the object. If an addressing error is found, a trap occurs.
 334 }
 335
 336
 337 function memw(a:adr):word;
 338 var b:word; i:integer;
 339 begin wordadr(a); b:=0;
 340       for i:=wsize-1 downto 0 do b:=256*b + data[a+i] ;
 341       memw:=b
 342 end;
 343
 344 function memd(a:adr):double; { Always signed }
 345 var b:double; i:integer;
 346 begin wordadr(a); b:=data[a+2*wsize-1];
 347       if b>=128 then b:=b-256;
 348       for i:=2*wsize-2 downto 0 do b:=256*b + data[a+i] ;
 349       memd:=b
 350 end;
 351
 352 function mema(a:adr):adr;
 353 var b:adr; i:integer;
 354 begin wordadr(a); b:=0;
 355       for i:=asize-1 downto 0 do b:=256*b + data[a+i] ;
 356       mema:=b
 357 end;
 358
 359 function mems(a:adr;s:size):word;
 360 var i:integer; b:word;
 361 begin chkadr(a,s); b:=0; for i:=1 to s do b:=b*256+data[a+s-i]; mems:=b end;
 362
 363 function memb(a:adr):byte;
 364 begin memadr(a); memb:=data[a] end;
 365
 366 procedure store(a:adr; x:word);
 367 var i:integer;
 368 begin wordadr(a);
 369   for i:=0 to wsize-1 do
 370      begin data[a+i]:=x mod 256; x:=x div 256 end
 371 end;
 372
 373 procedure storea(a:adr; x:adr);
 374 var i:integer;
 375 begin wordadr(a);
 376   for i:=0 to asize-1 do
 377      begin data[a+i]:=x mod 256; x:=x div 256 end
 378 end;
 379
 380 procedure stores(a:adr;s:size;v:word);
 381 var i:integer;
 382 begin chkadr(a,s);
 383   for i:=0 to s-1 do begin data[a+i]:=v mod 256; v:=v div 256 end;
 384 end;
 385
 386 procedure storeb(a:adr; b:byte);
 387 begin memadr(a); data[a]:=b end;
 388
 389 function memi(a:adr):adr;
 390 var b:adr; i:integer;
 391 begin if (a mod wsize<>0) or (a+asize-1>maxcode) then trap(EBADPTR); b:=0;
 392       for i:=asize-1 downto 0 do b:=256*b + code[a+i] ;
 393       memi:=b
 394 end;
 395
 396 function nextpc:byte;
 397 begin if pc>=pd then trap(EBADPC); nextpc:=code[pc]; newpc(pc+1) end;
 398
 399 procedure lino(w:word);
 400 begin store(lineadr,w) end;
 401
 402 procedure filna(a:adr);
 403 begin storea(fileadr,a) end;
 404 .ne 20
 405 .sp 2
 406 {---------------------------------------------------------------------------}
 407 {                    Stack Manipulation Routines                            }
 408 {---------------------------------------------------------------------------}
 409
 410 { push puts a word on the stack
 411   pushsw takes a signed one word integer and pushes it on the stack
 412   pop removes a machine word from the stack and delivers it as a word
 413   popsw removes a machine word from the stack and delivers a signed integer
 414   pusha pushes an address on the stack
 415   popa removes a machine word from the stack and delivers it as an address
 416   pushd pushes a double precision number on the stack
 417   popd removes two machine words and returns a double precision integer
 418   pushr pushes a float (floating point) number on the stack
 419   popr removes several machine words and returns a float number
 420   pushx puts an object of arbitrary size on the stack
 421   popx removes an object of arbitrary size
 422                                                                           }
 423
 424 procedure push(x:word);
 425 begin newsp(sp-wsize); store(sp,x) end;
 426
 427 procedure pushsw(x:sword);
 428 begin newsp(sp-wsize); store(sp,unsign(x)) end;
 429
 430 function pop:word;
 431 begin pop:=memw(sp); newsp(sp+wsize) end;
 432
 433 function popsw:sword;
 434 begin popsw:=signwd(pop) end;
 435
 436 procedure pusha(x:adr);
 437 begin newsp(sp-asize); storea(sp,x) end;
 438
 439 function popa:adr;
 440 begin popa:=mema(sp); newsp(sp+asize) end;
 441
 442 procedure pushd(y:double);
 443 begin { push double integer onto the stack } newsp(sp-2*wsize) end;
 444
 445 function popd:double;
 446 begin { pop double integer from the stack } newsp(sp+2*wsize); popd:=0 end;
 447
 448 procedure pushr(z:real);
 449 begin { Push a float onto the stack } newsp(sp-fsize) end;
 450
 451 function popr:real;
 452 begin { pop float from the stack } newsp(sp+fsize); popr:=0.0 end;
 453
 454 procedure pushx(objsize:size; a:adr);
 455 var i:integer;
 456 begin
 457   if objsize<wsize
 458      then push(mems(a,objsize))
 459      else for i:=1 to objsize div wsize do push(memw(a+objsize-wsize*i))
 460 end;
 461
 462 procedure popx(objsize:size; a:adr);
 463 var i:integer;
 464 begin
 465   if objsize<wsize
 466      then stores(a,objsize,pop)
 467      else for i:=1 to objsize div wsize do store(a-wsize+wsize*i,pop)
 468 end;
 469 .ne 20
 470 .sp 2
 471 {---------------------------------------------------------------------------}
 472 {              Bit manipulation routines (extract, shift, rotate)           }
 473 {---------------------------------------------------------------------------}
 474
 475 procedure sleft(var w:sword);  { 1 bit left shift   }
 476 begin w:= dosign(fitsw(2*w,EIOVFL)) end;
 477
 478 procedure suleft(var w:word);  { 1 bit left shift   }
 479 begin w := chopw(2*w) end;
 480
 481 procedure sdleft(var d:double);  { 1 bit left shift   }
 482 begin { shift two word signed integer } end;
 483
 484 procedure sright(var w:sword);  { 1 bit right shift with sign extension }
 485 begin if w >= 0 then w := w div 2 else w := (w-1) div 2 end;
 486
 487 procedure suright(var w:word);    { 1 bit right shift without sign extension }
 488 begin w := w div 2 end;
 489
 490 procedure sdright(var d:double);  { 1 bit right shift   }
 491 begin { shift two word signed integer } end;
 492
 493 procedure rleft(var w:word);  { 1 bit left rotate }
 494 begin if w >= t15
 495         then w:=(w-t15)*2 + 1
 496         else w:=w*2
 497 end;
 498
 499 procedure rright(var w:word);  { 1 bit right rotate }
 500 begin if w mod 2 = 1
 501         then w:=w div 2 + t15
 502         else w:=w div 2
 503 end;
 504
 505 function sextend(w:word;s:size):word;
 506 var i:size;
 507 begin
 508   for i:=1 to (wsize-s)*8 do rleft(w);
 509   for i:=1 to (wsize-s)*8 do sright(w);
 510   sextend:=w;
 511 end;
 512
 513 function bit(b:bitnr; w:word):bitval; { return bit b of the word w }
 514 var i:bitnr;
 515 begin for i:= 1 to b do rright(w); bit:= w mod 2 end;
 516
 517 function bf(ty:bftype; w1,w2:word):word;  { return boolean fcn of 2 words }
 518 var i:bitnr; j:word;
 519 begin j:=0;
 520       for i:= maxbitnr downto 0 do
 521         begin j := 2*j;
 522               case ty of
 523                 andf: if bit(i,w1)+bit(i,w2) = 2 then j:=j+1;
 524                 iorf: if bit(i,w1)+bit(i,w2) > 0 then j:=j+1;
 525                 xorf: if bit(i,w1)+bit(i,w2) = 1 then j:=j+1
 526               end
 527         end;
 528       bf:=j
 529 end;
 530
 531 {---------------------------------------------------------------------------}
 532 {                           Array indexing                                  }
 533 {---------------------------------------------------------------------------}
 534
 535 function arraycalc(c:adr):adr; { subscript calculation }
 536 var j:full; objsize:size; a:adr;
 537 begin j:= popsw - signwd(memw(c));
 538   if (j<0) or (j>memw(c+wsize)) then trap(EARRAY);
 539   objsize := argo(memw(c+wsize+wsize));
 540   a := j*objsize+popa; chkadr(a,objsize);
 541   arraycalc:=a
 542 end;
 543 .ne 20
 544 .sp 2
 545 {---------------------------------------------------------------------------}
 546 {                       Double and Real Arithmetic                          }
 547 {---------------------------------------------------------------------------}
 548
 549 { All routines for doubles and floats are dummy routines, since the format of
 550   doubles and floats is not defined in EM.
 551 }
 552
 553 function doadi(ds,dt:double):double;
 554 begin { add two doubles } doadi:=0 end;
 555
 556 function dosbi(ds,dt:double):double;
 557 begin { subtract two doubles } dosbi:=0 end;
 558
 559 function domli(ds,dt:double):double;
 560 begin { multiply two doubles } domli:=0 end;
 561
 562 function dodvi(ds,dt:double):double;
 563 begin { divide two doubles } dodvi:=0 end;
 564
 565 function dormi(ds,dt:double):double;
 566 begin { modulo of two doubles } dormi:=0 end;
 567
 568 function dongi(ds:double):double;
 569 begin { negative of a double } dongi:=0 end;
 570
 571 function doadf(x,y:real):real;
 572 begin { add two floats } doadf:=0.0 end;
 573
 574 function dosbf(x,y:real):real;
 575 begin { subtract two floats } dosbf:=0.0 end;
 576
 577 function domlf(x,y:real):real;
 578 begin { multiply two floats } domlf:=0.0 end;
 579
 580 function dodvf(x,y:real):real;
 581 begin { divide two floats } dodvf:=0.0 end;
 582
 583 function dongf(x:real):real;
 584 begin { negate a float } dongf:=0.0 end;
 585
 586 procedure dofif(x,y:real;var intpart,fraction:real);
 587 begin { dismember x*y into integer and fractional parts }
 588   intpart:=0.0;  { integer part of x*y, same sign as x*y }
 589   fraction:=0.0;
 590         { fractional part of x*y, 0<=abs(fraction)<1 and same sign as x*y }
 591 end;
 592
 593 procedure dofef(x:real;var mantissa:real;var exponent:sword);
 594 begin { dismember x into mantissa and exponent parts }
 595   mantissa:=0.0;  { mantissa of x , >= 1/2 and <1 }
 596   exponent:=0;    { base 2 exponent of x }
 597 end;
 598 .bp
 599 {---------------------------------------------------------------------------}
 600 {                            Trap and Call                                  }
 601 {---------------------------------------------------------------------------}
 602
 603 procedure call(p:adr); { Perform the call }
 604 begin
 605   pusha(lb);pusha(pc);
 606   newlb(sp);newsp(sp - memi(pd + pdsize*p + pdlocs));
 607   newpc(memi(pd + pdsize*p+ pdbase))
 608 end;
 609
 610 procedure dotrap(n:byte);
 611 var i:size;
 612 begin
 613   if (uerrorproc=0) or intrap then
 614     begin
 615       if intrap then
 616         writeln('Recursive trap, first trap number was ', trapval:1);
 617       writeln('Error ', n:1);
 618       writeln('With',ord(insr):4,' arg ',k:1);
 619       goto 9999
 620     end;
 621   { Deposit all interpreter variables that need to be saved on
 622     the stack. This includes all scratch variables that can
 623     be in use at the moment and ( not possible in this interpreter )
 624     the internal address of the interpreter where the error occurred.
 625     This would make it possible to execute an RTT instruction totally
 626     transparent to the user program.
 627     It can, for example, occur within an ADD instruction that both
 628     operands are undefined and that the result overflows.
 629     Although this will generate 3 error traps it must be possible
 630     to ignore them all.
 631 }
 632   intrap:=true; trapval:=n;
 633   for i:=retsize div wsize downto 1 do push(retarea[i]);
 634   push(retsize);              { saved return area }
 635   pusha(mema(fileadr));       { saved current file name pointer }
 636   push(memw(lineadr));        { saved line number }
 637   push(n);                    { push error number }
 638   a:=argp(uerrorproc);
 639   uerrorproc:=0;              { reset signal }
 640   call(a);                    { call the routine }
 641   intrap:=false;              { Don't catch recursive traps anymore }
 642   goto 8888;                  { reenter main loop }
 643 end;
 644
 645 procedure trap;
 646 { This routine is invoked for overflow, and other run time errors.
 647   For non-fatal errors, trap returns to the calling routine
 648 }
 649 begin
 650   if n>=16 then dotrap(n) else if bit(n,ignmask)=0 then dotrap(n);
 651 end;
 652
 653 procedure dortt;
 654 { The restoration of file address and line number is not essential.
 655   The restoration of the return save area is.
 656 }
 657 var i:size;
 658     n:word;
 659 begin
 660   newsp(lb); lb:=maxdata+1 ; { to circumvent ESTACK for the popa + pop }
 661   newpc(popa); newlb(popa); { So far a plain RET 0 }
 662   n:=pop; if (n>=16) and (n<64) then goto 9999 ;
 663   lino(pop); filna(popa); retsize:=pop;
 664   for i:=1 to retsize div wsize do retarea[i]:=pop ;
 665 end;
 666 .sp 2
 667 {---------------------------------------------------------------------------}
 668 {                              monitor calls                                }
 669 {---------------------------------------------------------------------------}
 670
 671
 672 procedure domon(entry:word);
 673 var     index:  1..63;
 674         dummy:  double;
 675         count,rwptr:    adr;
 676         token:  byte;
 677         i:      integer;
 678 begin
 679   if (entry<=0) or (entry>63) then entry:=63 ;
 680   index:=entry;
 681   case index of
 682    1: begin { exit } exitstatus:=pop; halted:=true end;
 683    3: begin { read }  dummy:=pop; { All input is from stdin }
 684         rwptr:=popa; count:=popa;
 685         i:=0 ;
 686         while (not eof(input)) and (i<count) do
 687         begin
 688           if eoln(input) then begin storeb(rwptr,10) ; count:=i end
 689                          else storeb(rwptr,ord(input^)) ;
 690           get(input); rwptr:=rwptr+1 ; i:=i+1 ;
 691         end;
 692         pusha(i); push(0)
 693       end;
 694    4: begin { write } dummy:=pop; { All output is to stdout }
 695         rwptr:=popa; count:=popa;
 696         for i:=1 to count do
 697           begin token:=memb(rwptr); rwptr:=rwptr+1 ;
 698             if token=10 then writeln else write(chr(token))
 699           end ;
 700         pusha(count);
 701         push(0)
 702       end;
 703   54: begin { ioctl, faked } dummy:=popa;dummy:=popa;dummy:=pop;push(0) end ;
 704        2,          5,  6,  7,  8,  9, 10,
 705   11, 12, 13, 14, 15, 16, 17, 18, 19, 20,
 706   21, 22, 23, 24, 25, 26, 27, 28, 29, 30,
 707   31, 32, 33, 34, 35, 36, 37, 38, 39, 40,
 708   41, 42, 43, 44, 45, 46, 47, 48, 49, 50,
 709   51, 52, 53,     55, 56, 57, 58, 59, 60,
 710   61, 62:
 711       begin push(22); push(22) end;
 712   63: { exists only for the trap }
 713       trap(EBADMON)
 714   end
 715 end;
 716 .bp
 717 {---------------------------------------------------------------------------}
 718 {                       Initialization and debugging                        }
 719 {---------------------------------------------------------------------------}
 720
 721 procedure doident; { print line number and file name }
 722 var a:adr; i,c:integer; found:boolean;
 723 begin
 724   write('at line ',memw(lineadr):1,' ');
 725   a:=mema(fileadr); if a<>0 then
 726   begin i:=20; found:=false;
 727     while (i<>0) and not found do
 728     begin c:=memb(a); a:=a+1; found:=true; i:=i-1;
 729       if (c>=48) and (c<=57) then
 730         begin found:=false; write(chr(ord('0')+c-48)) end;
 731       if (c>=65) and (c<=90) then
 732         begin found:=false; write(chr(ord('A')+c-65)) end;
 733       if (c>=97) and (c<=122) then
 734         begin found:=false; write(chr(ord('a')+c-97)) end;
 735     end;
 736   end;
 737   writeln;
 738 end;
 739
 740 procedure initialize;  { start the ball rolling }
 741 { This is not part of the machine definition }
 742 var cset:set of char;
 743     f:ifset;
 744     iclass:insclass;
 745     insno:byte;
 746     nops:integer;
 747     opcode:byte;
 748     i,j,n:integer;
 749     wtemp:sword;
 750     count:integer;
 751     repc:adr;
 752     nexta,firsta:adr;
 753     elem:byte;
 754     amount,ofst:size;
 755     c:char;
 756
 757     function readb(n:integer):double;
 758     var b:byte;
 759     begin read(prog,b); if n>1 then readb:=readb(n-1)*256+b else readb:=b end;
 760
 761     function readbyte:byte;
 762     begin readbyte:=readb(1) end;
 763
 764     function readword:word;
 765     begin readword:=readb(wsize) end;
 766
 767     function readadr:adr;
 768     begin readadr:=readb(asize) end;
 769
 770     function ifind(ordinal:byte):mnem;
 771     var loopvar:mnem;
 772         found:boolean;
 773     begin ifind:=NON;
 774       loopvar:=insr; found:=false;
 775       repeat
 776         if ordinal=ord(loopvar) then
 777           begin found:=true; ifind:=loopvar end;
 778         if loopvar<>ZRL then loopvar:=succ(loopvar) else loopvar:=NON;
 779       until found or (loopvar=insr) ;
 780    end;
 781
 782     procedure readhdr;
 783     type hdrw=0..32767 ; { 16 bit header words }
 784     var  hdr: hdrw;
 785          i: integer;
 786     begin
 787       for i:=0 to 7 do
 788       begin hdr:=readb(2);
 789         case i of
 790         0: if hdr<>3757 then { 07255 }
 791            begin writeln('Not an em load file'); halt end;
 792         2: if hdr<>0 then
 793            begin writeln('Unsolved references'); halt end;
 794         3: if hdr<>3 then
 795            begin writeln('Incorrect load file version'); halt end;
 796         4: if hdr<>wsize then
 797            begin writeln('Incorrect word size'); halt end;
 798         5: if hdr<>asize then
 799            begin writeln('Incorrect pointer size'); halt end;
 800         1,6,7:;
 801         end
 802       end
 803     end;
 804
 805     procedure noinit;
 806     begin writeln('Illegal initialization'); halt end;
 807
 808     procedure readint(a:adr;s:size);
 809     var i:size;
 810     begin { construct integer out of byte sequence }
 811       for i:=1 to s do { construct the value and initialize at a }
 812         begin storeb(a,readbyte); a:=a+1 end
 813     end;
 814
 815     procedure readuns(a:adr;s:size);
 816     begin { construct unsigned out of byte sequence }
 817       readint(a,s) { identical to readint }
 818     end;
 819
 820     procedure readfloat(a:adr;s:size);
 821     var i:size; b:byte;
 822     begin { construct float out of string}
 823       if (s<>4) and (s<>8) then noinit; i:=0;
 824       repeat { eat the bytes, construct the value and intialize at a }
 825         b:=readbyte; i:=i+1;
 826       until b=0 ;
 827     end;
 828
 829 begin
 830   halted:=false;
 831   exitstatus:=undef;
 832   uerrorproc:=0; intrap:=false;
 833
 834   { initialize tables }
 835   for i:=0 to maxcode do code[i]:=0;
 836   for i:=0 to maxdata do data[i]:=0;
 837   for iclass:=prim to tert do
 838     for i:=0 to 255 do
 839       with dispat[iclass][i] do
 840         begin instr:=NON; iflag:=[zbit] end;
 841
 842   { read instruction table file. see appendix B }
 843   { The table read here is a simple transformation of the table on page xx }
 844   { - instruction names were transformed to numbers }
 845   { - the '-' flag was transformed to an 'i' flag for 'w' type instructions }
 846   { - the 'S' flag was added for instructions having signed operands }
 847   reset(tables);
 848   insr:=NON;
 849   repeat
 850     read(tables,insno) ; cset:=[]; f:=[];
 851     insr:=ifind(insno);
 852     if insr=NON then begin writeln('Incorrect table'); halt end;
 853     repeat read(tables,c) until c<>' ' ;
 854     repeat
 855       cset:=cset+[c];
 856       read(tables,c)
 857     until c=' ' ;
 858     if 'm' in cset then f:=f+[mini];
 859     if 's' in cset then f:=f+[short];
 860     if '-' in cset then f:=f+[zbit];
 861     if 'i' in cset then f:=f+[ibit];
 862     if 'S' in cset then f:=f+[sbit];
 863     if 'w' in cset then f:=f+[wbit];
 864     if (mini in f) or (short in f) then read(tables,nops) else nops:=1 ;
 865     readln(tables,opcode);
 866     if ('4' in cset) or ('8' in cset) then
 867       begin iclass:=tert end
 868     else if 'e' in cset then
 869       begin iclass:=second end
 870     else iclass:=prim;
 871     for i:=0 to nops-1 do
 872     begin
 873       with dispat[iclass,opcode+i] do
 874       begin
 875         iflag:=f; instr:=insr;
 876         if '2' in cset      then ilength:=2
 877         else if 'u' in cset then ilength:=2
 878         else if '4' in cset then ilength:=4
 879         else if '8' in cset then ilength:=8
 880         else if (mini in f) or (short in f) then
 881           begin
 882             if 'N' in cset then wtemp:=-1-i else wtemp:=i ;
 883             if 'o' in cset then wtemp:=wtemp+1 ;
 884             if short in f then wtemp:=wtemp*256 ;
 885             implicit:=wtemp
 886           end
 887       end
 888     end
 889   until eof(tables);
 890
 891   { read in program text, data and procedure descriptors }
 892   reset(prog);
 893   readhdr;                               { verify first header }
 894   for i:=1 to 8 do header[i]:=readadr;  { read second header }
 895   hp:=maxdata+1; sp:=maxdata+1; lino(0);
 896   { read program text }
 897   if header[NTEXT]+header[NPROC]*pdsize>maxcode then
 898     begin writeln('Text size too large'); halt end;
 899   if header[SZDATA]>maxdata then
 900     begin writeln('Data size too large'); halt end;
 901   for i:=0 to header[NTEXT]-1 do code[i]:=readbyte;
 902   { read data blocks }
 903   nexta:=0;
 904   for i:=1 to header[NDATA] do
 905     begin
 906       n:=readbyte;
 907       if n<>0 then
 908         begin
 909           elem:=readbyte; firsta:=nexta;
 910           case n of
 911           1: { uninitialized words }
 912              for j:=1 to elem do
 913              begin store(nexta,undef); nexta:=nexta+wsize end;
 914           2: { initialized bytes }
 915              for j:=1 to elem do
 916              begin storeb(nexta,readbyte); nexta:=nexta+1 end;
 917           3: { initialized words }
 918              for j:=1 to elem do
 919              begin store(nexta,readword); nexta:=nexta+wsize end;
 920           4,5: { instruction and data pointers }
 921              for j:=1 to elem do
 922              begin storea(nexta,readadr); nexta:=nexta+asize end;
 923           6: { signed integers }
 924              begin readint(nexta,elem); nexta:=nexta+elem end;
 925           7: { unsigned integers }
 926              begin readuns(nexta,elem); nexta:=nexta+elem end;
 927           8: { floating point numbers }
 928              begin readfloat(nexta,elem); nexta:=nexta+elem end;
 929           end
 930         end
 931       else
 932         begin
 933           repc:=readadr; amount:=nexta-firsta;
 934           for count:=1 to repc do
 935           begin
 936             for ofst:=0 to amount-1 do data[nexta+ofst]:=data[firsta+ofst];
 937             nexta:=nexta+amount;
 938           end
 939         end
 940     end;
 941   if header[SZDATA]<>nexta then writeln('Data initialization error');
 942   hp:=nexta;
 943   { read descriptor table }
 944   pd:=header[NTEXT];
 945   for i:=1 to header[NPROC]*pdsize do code[pd+i-1]:=readbyte;
 946   { call the entry point routine }
 947   ignmask:=0;      { catch all traps, higher numbered traps cannot be ignored}
 948   retsize:=0;
 949   lb:=maxdata;     { illegal dynamic link }
 950   pc:=maxcode;     { illegal return address }
 951   push(0); a:=sp;  { No environment }
 952   push(0); b:=sp;  { No args }
 953   pusha(a);        { envp }
 954   pusha(b);        { argv }
 955   push(0);         { argc }
 956   call(argp(header[ENTRY]));
 957 end;
 958 .bp
 959 {---------------------------------------------------------------------------}
 960 {                       MAIN LOOP OF THE INTERPRETER                        }
 961 {---------------------------------------------------------------------------}
 962 { It should be noted that the interpreter (microprogram) for  an  EM
 963   machine  can be written in two fundamentally different ways: (1) the
 964   instruction operands are fetched in the main loop, or  (2)  the  in-
 965   struction operands are fetched after the 256 way branch, by the exe-
 966   cution routines themselves.  In this interpreter, method (1) is used
 967   to  simplify  the  description  of execution  routines. The dispatch
 968   table dispat is used to determine how the operand is  encoded. There
 969   are 4 possibilities:
 970
 971      0. There is no operand
 972      1. The operand and  instruction are  together in 1  byte (mini)
 973      2. The operand is  one byte long and follows the opcode byte(s)
 974      3. The operand is two bytes long and follows the opcode byte(s)
 975      4. The operand is four bytes long and follows the opcode byte(s)
 976
 977   In  this  interpreter,  the  main  loop determines the operand type,
 978   fetches it, and leaves it in the global variable k for the execution
 979   routines  to use.  Consequently, instructions such as LOL, which use
 980   three different formats, need only be described once in the body  of
 981   the interpreter.
 982       However, for  a  production  interpreter,  or  a  hardware  EM
 983   machine,  it  is  probably better to use method (2), i.e. to let the
 984   execution routines themselves fetch their own operands.  The  reason
 985   for this is that each opcode uniquely determines the operand format,
 986   so no table lookup in the dispatch table is needed.  The whole table
 987   is not needed. Method (2) therefore executes much faster.
 988       However, separate execution routines will be needed for LOL with
 989   a one byte offset,  and  LOL with a two byte offset.  It is to avoid
 990   this additional clutter that method (1) is used here.  In a  produc-
 991   tion interpreter, it is envisioned that the main loop will fetch the
 992   next instruction byte, and use it as an index into a 256 word  table
 993   to  find  the  address  of  the interpreter routine to jump to.  The
 994   routine jumped to will  begin  by  fetching  its  operand,  if  any,
 995   without  any  table  lookup,  since it knows which format to expect.
 996   After doing the work, it returns to the main  loop  by  jumping  in-
 997   directly  to  a register that contains the address of the main loop.
 998       A slight variation on this idea is to have the  register contain
 999   the address of the branch table, rather than the address of the main
1000   loop.
1001       Another  issue  is whether the execution routines for LOL 0, LOL
1002   2, LOL 4, etc. should all be have distinct execution routines. Doing
1003   so  provides for the maximum speed, since the operand is implicit in
1004   the routine itself.  The disadvantage is that many nearly  identical
1005   execution  routines will then be needed.  Another way of doing it is
1006   to keep the instruction byte fetched from memory (LOL 0, LOL 2,  LOL
1007   4, etc.) in some register, and have all the LOL mini format instruc-
1008   tions branch to a common routine.  This routine can  then  determine
1009   the  operand  by  subtracting  the code for LOL 0 from the register,
1010   leaving the true operand in the register  (as  a  word  quantity  of
1011   course).   This  method  makes the interpreter smaller, but is a bit
1012   slower.
1013 .bp
1014        To make this important point a little clearer, consider how a
1015   production interpreter for the PDP-11 might appear.  Let us assume the
1016   following opcodes have been assigned:
1017
1018        31: LOL -2     (2 bytes, i.e. next word)
1019        32: LOL -4
1020        33: LOL -6
1021        34: LOL b      (format with a one byte offset)
1022        35: LOL w      (format with a one word, i.e. two byte offset)
1023
1024   Further assume that each of the 5 opcodes will have its own execution
1025   routine, i.e. we are making a tradeoff in favor of fast execution and
1026   a slightly larger interpreter.
1027        Register r5 is the em program counter.
1028        Register r4 is the em LB register
1029        Register r3 is the em SP register (the stack grows toward low core)
1030        Register r2 contains the interpreter address of the main loop
1031
1032   The main loop looks like this:
1033
1034        movb (r5)+,r0           /fetch the opcode into r0 and increment r5
1035        asl r0                  /shift r0 left 1 bit. Now: -256<=r0<=+254
1036        jmp *table(r0)          /jump to execution routine
1037
1038   Notice that no operand fetching has been done. The execution routines for
1039   the 5 sample instructions given above might be as follows:
1040
1041   lol2: mov -2(r4),-(sp)       /push local -2 onto stack
1042         jmp (r2)               /go back to main loop
1043   lol4: mov -4(r4),-(sp)       /push local -4 onto stack
1044         jmp (r2)               /go back to main loop
1045   lol6: mov -6(r4),-(sp)       /push local -6 onto stack
1046         jmp (r2)               /go back to main loop
1047   lolb: mov $177400,r0         /prepare to fetch the 1 byte operand
1048         bisb (r5)+,r0          /operand is now in r0
1049         asl r0                 /r0 is now offset from LB in bytes, not words
1050         add r4,r0              /r0 is now address of the needed local
1051         mov (r0),-(sp)         /push the local onto the stack
1052         jmp (r2)
1053   lolw: clr r0                 /prepare to fetch the 2 byte operand
1054         bisb (r5)+,r0          /fetch high order byte first !!!
1055         swab r0                /insert high order byte in place
1056         bisb (r5)+,r0          /insert low order byte in place
1057         asl r0                 /convert offset to bytes, from words
1058         add r4,r0              /r0 is now address of needed local
1059         mov (r0),-(sp)         /stack the local
1060         jmp (r2)               /done
1061
1062   The important thing to notice is where and how the operand fetch occurred:
1063        lol2, lol4, and lol6, (the mini's) have implicit operands
1064        lolb knew it had to fetch one byte, and did so without any table lookup
1065        lolw knew it had to fetch a word, and did so, high order byte first }
1066 .bp
1067 .sp 4
1068 {---------------------------------------------------------------------------}
1069 {           Routines for the individual instructions                        }
1070 {---------------------------------------------------------------------------}
1071 procedure loadops;
1072 var j:integer;
1073 begin
1074   case insr of
1075     { LOAD GROUP }
1076     LDC: pushd(argd(k));
1077     LOC: pushsw(argc(k));
1078     LOL: push(memw(locadr(k)));
1079     LOE: push(memw(argg(k)));
1080     LIL: push(memw(mema(locadr(k))));
1081     LOF: push(memw(popa+argf(k)));
1082     LAL: pusha(locadr(k));
1083     LAE: pusha(argg(k));
1084     LXL: begin a:=lb; for j:=1 to argn(k) do a:=mema(a+savsize); pusha(a) end;
1085     LXA: begin a:=lb;
1086            for j:=1 to argn(k) do a:= mema(a+savsize);
1087            pusha(a+savsize)
1088          end;
1089     LOI: pushx(argo(k),popa);
1090     LOS: begin k:=argw(k); if k<>wsize then trap(EILLINS);
1091            k:=pop; pushx(argo(k),popa)
1092          end;
1093     LDL: begin a:=locadr(k); push(memw(a+wsize)); push(memw(a)) end;
1094     LDE: begin k:=argg(k); push(memw(k+wsize)); push(memw(k)) end;
1095     LDF: begin k:=argf(k);
1096            a:=popa; push(memw(a+k+wsize)); push(memw(a+k))
1097          end;
1098     LPI: push(argp(k))
1099   end
1100 end;
1101
1102 procedure storeops;
1103 begin
1104   case insr of
1105     { STORE GROUP }
1106     STL: store(locadr(k),pop);
1107     STE: store(argg(k),pop);
1108     SIL: store(mema(locadr(k)),pop);
1109     STF: begin a:=popa; store(a+argf(k),pop) end;
1110     STI: popx(argo(k),popa);
1111     STS: begin k:=argw(k); if k<>wsize then trap(EILLINS);
1112            k:=popa; popx(argo(k),popa)
1113          end;
1114     SDL: begin a:=locadr(k); store(a,pop); store(a+wsize,pop) end;
1115     SDE: begin k:=argg(k); store(k,pop); store(k+wsize,pop) end;
1116     SDF: begin k:=argf(k); a:=popa; store(a+k,pop); store(a+k+wsize,pop) end
1117   end
1118 end;
1119
1120 procedure intarith;
1121 var i:integer;
1122 begin
1123   case insr of
1124     { SIGNED INTEGER ARITHMETIC }
1125     ADI: case szindex(argw(k)) of
1126          1: begin st:=popsw; ss:=popsw; push(fitsw(ss+st,EIOVFL)) end;
1127          2: begin dt:=popd; ds:=popd; pushd(doadi(ds,dt)) end;
1128          end ;
1129     SBI: case szindex(argw(k)) of
1130          1: begin st:=popsw; ss:= popsw; push(fitsw(ss-st,EIOVFL)) end;
1131          2: begin dt:=popd; ds:=popd; pushd(dosbi(ds,dt)) end;
1132          end ;
1133     MLI: case szindex(argw(k)) of
1134          1: begin st:=popsw; ss:= popsw; push(fitsw(ss*st,EIOVFL)) end;
1135          2: begin dt:=popd; ds:=popd; pushd(domli(ds,dt)) end;
1136          end ;
1137     DVI: case szindex(argw(k)) of
1138          1: begin st:= popsw; ss:= popsw;
1139                if st=0 then trap(EIDIVZ) else pushsw(ss div st)
1140             end;
1141          2: begin dt:=popd; ds:=popd; pushd(dodvi(ds,dt)) end;
1142          end;
1143     RMI: case szindex(argw(k)) of
1144          1: begin st:= popsw; ss:=popsw;
1145                if st=0 then trap(EIDIVZ) else pushsw(ss - (ss div st)*st)
1146             end;
1147          2: begin dt:=popd; ds:=popd; pushd(dormi(ds,dt)) end
1148          end;
1149     NGI: case szindex(argw(k)) of
1150          1: begin st:=popsw; pushsw(-st) end;
1151          2: begin ds:=popd; pushd(dongi(ds)) end
1152          end;
1153     SLI: begin t:=pop;
1154            case szindex(argw(k)) of
1155            1: begin ss:=popsw;
1156                  for i:= 1 to t do sleft(ss); pushsw(ss)
1157               end
1158            end
1159          end;
1160     SRI: begin t:=pop;
1161            case szindex(argw(k)) of
1162            1: begin ss:=popsw;
1163                  for i:= 1 to t do sright(ss); pushsw(ss)
1164               end;
1165            2: begin ds:=popd;
1166                  for i:= 1 to t do sdright(ss); pushd(ss)
1167               end
1168            end
1169          end
1170   end
1171 end;
1172
1173 procedure unsarith;
1174 var i:integer;
1175 begin
1176   case insr of
1177     { UNSIGNED INTEGER ARITHMETIC }
1178     ADU: case szindex(argw(k)) of
1179          1: begin t:=pop; s:= pop; push(chopw(s+t)) end;
1180          2: trap(EILLINS);
1181          end ;
1182     SBU: case szindex(argw(k)) of
1183          1: begin t:=pop; s:= pop; push(chopw(s-t)) end;
1184          2: trap(EILLINS);
1185          end ;
1186     MLU: case szindex(argw(k)) of
1187          1: begin t:=pop; s:= pop; push(chopw(s*t)) end;
1188          2: trap(EILLINS);
1189          end ;
1190     DVU: case szindex(argw(k)) of
1191          1: begin t:= pop; s:= pop;
1192                if t=0 then trap(EIDIVZ) else push(s div t)
1193             end;
1194          2: trap(EILLINS);
1195          end;
1196     RMU: case szindex(argw(k)) of
1197          1: begin t:= pop; s:=pop;
1198                if t=0 then trap(EIDIVZ) else push(s - (s div t)*t)
1199             end;
1200          2: trap(EILLINS);
1201          end;
1202     SLU: case szindex(argw(k)) of
1203          1: begin t:=pop; s:=pop;
1204                for i:= 1 to t do suleft(s); push(s)
1205             end;
1206          2: trap(EILLINS);
1207          end;
1208     SRU: case szindex(argw(k)) of
1209          1: begin t:=pop; s:=pop;
1210                for i:= 1 to t do suright(s); push(s)
1211             end;
1212          2: trap(EILLINS);
1213          end
1214   end
1215 end;
1216
1217 procedure fltarith;
1218 begin
1219   case insr of
1220     { FLOATING POINT ARITHMETIC }
1221     ADF: begin argwf(k); rt:=popr; rs:=popr; pushr(doadf(rs,rt)) end;
1222     SBF: begin argwf(k); rt:=popr; rs:=popr; pushr(dosbf(rs,rt)) end;
1223     MLF: begin argwf(k); rt:=popr; rs:=popr; pushr(domlf(rs,rt)) end;
1224     DVF: begin argwf(k); rt:=popr; rs:=popr; pushr(dodvf(rs,rt)) end;
1225     NGF: begin argwf(k); rt:=popr; pushr(dongf(rt)) end;
1226     FIF: begin argwf(k); rt:=popr; rs:=popr;
1227                dofif(rt,rs,x,y); pushr(y); pushr(x)
1228          end;
1229     FEF: begin argwf(k); rt:=popr; dofef(rt,x,ss); pushr(x); pushsw(ss) end
1230   end
1231 end;
1232
1233 procedure ptrarith;
1234 begin
1235   case insr of
1236     { POINTER ARITHMETIC }
1237     ADP: pusha(popa+argf(k));
1238     ADS: case szindex(argw(k)) of
1239          1: begin st:=popsw; pusha(popa+st) end;
1240          2: begin dt:=popd; pusha(popa+dt) end;
1241          end;
1242     SBS: begin
1243            a:=popa; b:=popa;
1244            case szindex(argw(k)) of
1245              1: push(fitsw(b-a,EIOVFL));
1246              2: pushd(b-a)
1247            end
1248          end
1249   end
1250 end;
1251
1252 procedure incops;
1253 var j:integer;
1254 begin
1255   case insr of
1256     { INCREMENT/DECREMENT/ZERO }
1257     INC: push(fitsw(popsw+1,EIOVFL));
1258     INL: begin a:=locadr(k); store(a,fitsw(signwd(memw(a))+1,EIOVFL)) end;
1259     INE: begin a:=argg(k); store(a,fitsw(signwd(memw(a))+1,EIOVFL)) end;
1260     DEC: push(fitsw(popsw-1,EIOVFL));
1261     DEL: begin a:=locadr(k); store(a,fitsw(signwd(memw(a))-1,EIOVFL)) end;
1262     DEE: begin a:=argg(k); store(a,fitsw(signwd(memw(a))-1,EIOVFL)) end;
1263     ZRL: store(locadr(k),0);
1264     ZRE: store(argg(k),0);
1265     ZER: for j:=1 to argw(k) div wsize do push(0);
1266     ZRF: pushr(0);
1267   end
1268 end;
1269
1270 procedure convops;
1271 begin
1272   case insr of
1273     { CONVERT GROUP }
1274     CII: begin s:=pop; t:=pop;
1275            if t<wsize then begin push(sextend(pop,t)); t:=wsize end;
1276            case szindex(argw(t)) of
1277            1: if szindex(argw(s))=2 then pushd(popsw);
1278            2: if szindex(argw(s))=1 then push(fitsw(popd,ECONV))
1279            end
1280          end;
1281     CIU: case szindex(argw(pop)) of
1282          1: if szindex(argw(pop))=2 then push(unsign(popd mod negoff));
1283          2: trap(EILLINS);
1284          end;
1285     CIF: begin argwf(pop);
1286            case szindex(argw(pop)) of 1:pushr(popsw); 2:pushr(popd) end
1287          end;
1288     CUI: case szindex(argw(pop)) of
1289          1: case szindex(argw(pop)) of
1290             1: begin s:=pop; if s>maxsint then trap(ECONV); push(s) end;
1291             2: trap(EILLINS);
1292             end;
1293          2: case szindex(argw(pop)) of
1294             1: pushd(pop);
1295             2: trap(EILLINS);
1296             end;
1297          end;
1298     CUU: case szindex(argw(pop)) of
1299          1: if szindex(argw(pop))=2 then trap(EILLINS);
1300          2: trap(EILLINS);
1301          end;
1302     CUF: begin argwf(pop);
1303            if szindex(argw(pop))=1 then pushr(pop) else trap(EILLINS)
1304          end;
1305     CFI: begin sz:=argw(pop); argwf(pop); rt:=popr;
1306            case szindex(sz) of
1307            1: push(fitsw(trunc(rt),ECONV));
1308            2: pushd(fitd(trunc(rt)));
1309            end
1310          end;
1311     CFU: begin sz:=argw(pop); argwf(pop); rt:=popr;
1312            case szindex(sz) of
1313            1: push( chopw(trunc(abs(rt)-0.5)) );
1314            2: trap(EILLINS);
1315            end
1316          end;
1317     CFF: begin argwf(pop); argwf(pop) end
1318   end
1319 end;
1320
1321 procedure logops;
1322 var i,j:integer;
1323 begin
1324   case insr of
1325     { LOGICAL GROUP }
1326     XAND:
1327          begin k:=argw(k);
1328            for j:= 1 to k div wsize do
1329              begin a:=sp+k; t:=pop; store(a,bf(andf,memw(a),t)) end;
1330          end;
1331     IOR:
1332          begin k:=argw(k);
1333            for j:= 1 to k div wsize do
1334              begin a:=sp+k; t:=pop; store(a,bf(iorf,memw(a),t)) end;
1335          end;
1336     XOR:
1337          begin k:=argw(k);
1338            for j:= 1 to k div wsize do
1339              begin a:=sp+k; t:=pop; store(a,bf(xorf,memw(a),t)) end;
1340          end;
1341     COM:
1342          begin k:=argw(k);
1343            for j:= 1 to k div wsize do
1344              begin
1345                store(sp+k-wsize*j, bf(xorf,memw(sp+k-wsize*j), negoff-1))
1346              end
1347          end;
1348     ROL: begin k:=argw(k); if k<>wsize then trap(EILLINS);
1349            t:=pop; s:=pop; for i:= 1 to t do rleft(s); push(s)
1350          end;
1351     ROR: begin k:=argw(k); if k<>wsize then trap(EILLINS);
1352            t:=pop; s:=pop; for i:= 1 to t do rright(s); push(s)
1353          end
1354   end
1355 end;
1356
1357 procedure setops;
1358 var i,j:integer;
1359 begin
1360   case insr of
1361     { SET GROUP }
1362     INN:
1363          begin k:=argw(k);
1364            t:=pop;
1365            i:= t mod 8; t:= t div 8;
1366            if t>=k then
1367              begin trap(ESET); s:=0 end
1368            else
1369              begin s:=memb(sp+t) end;
1370            newsp(sp+k); push(bit(i,s));
1371          end;
1372     XSET:
1373          begin k:=argw(k);
1374            t:=pop;
1375            i:= t mod 8; t:= t div 8;
1376            for j:= 1 to k div wsize do push(0);
1377            if t>=k then
1378              trap(ESET)
1379            else
1380              begin s:=1; for j:= 1 to i do rleft(s); storeb(sp+t,s) end
1381          end
1382   end
1383 end;
1384
1385 procedure arrops;
1386 begin
1387   case insr of
1388     { ARRAY GROUP }
1389     LAR:
1390          begin k:=argw(k); if k<>wsize then trap(EILLINS); a:=popa;
1391            pushx(argo(memw(a+2*k)),arraycalc(a))
1392          end;
1393     SAR:
1394          begin k:=argw(k); if k<>wsize then trap(EILLINS); a:=popa;
1395            popx(argo(memw(a+2*k)),arraycalc(a))
1396          end;
1397     AAR:
1398          begin k:=argw(k); if k<>wsize then trap(EILLINS); a:=popa;
1399            push(arraycalc(a))
1400          end
1401   end
1402 end;
1403
1404 procedure cmpops;
1405 begin
1406   case insr of
1407     { COMPARE GROUP }
1408     CMI: case szindex(argw(k)) of
1409          1: begin st:=popsw; ss:=popsw;
1410               if ss<st then pushsw(-1) else if ss=st then push(0) else push(1)
1411             end;
1412          2: begin dt:=popd; ds:=popd;
1413               if ds<dt then pushsw(-1) else if ds=dt then push(0) else push(1)
1414             end;
1415          end;
1416     CMU: case szindex(argw(k)) of
1417          1: begin t:=pop; s:=pop;
1418               if s<t then pushsw(-1) else if s=t then push(0) else push(1)
1419             end;
1420          2: trap(EILLINS);
1421          end;
1422     CMP: begin a:=popa; b:=popa;
1423           if b<a then pushsw(-1) else if b=a then push(0) else push(1)
1424          end;
1425     CMF: begin argwf(k); rt:=popr; rs:=popr;
1426            if rs<rt then pushsw(-1) else if rs=rt then push(0) else push(1)
1427          end;
1428     CMS: begin k:=argw(k);
1429            t:= 0; j:= 0;
1430            while (j < k) and (t=0) do
1431              begin if memw(sp+j) <> memw(sp+k+j) then t:=1;
1432                j:=j+wsize
1433              end;
1434            newsp(sp+wsize*k); push(t);
1435          end;
1436
1437     TLT: if popsw <  0 then push(1) else push(0);
1438     TLE: if popsw <= 0 then push(1) else push(0);
1439     TEQ: if pop   =  0 then push(1) else push(0);
1440     TNE: if pop   <> 0 then push(1) else push(0);
1441     TGE: if popsw >= 0 then push(1) else push(0);
1442     TGT: if popsw >  0 then push(1) else push(0);
1443   end
1444 end;
1445
1446 procedure branchops;
1447 begin
1448   case insr of
1449     { BRANCH GROUP }
1450     BRA: newpc(pc+k);
1451
1452     BLT: begin st:=popsw; if popsw <  st then newpc(pc+k) end;
1453     BLE: begin st:=popsw; if popsw <= st then newpc(pc+k) end;
1454     BEQ: begin t :=pop  ; if pop   =   t then newpc(pc+k) end;
1455     BNE: begin t :=pop  ; if pop   <>  t then newpc(pc+k) end;
1456     BGE: begin st:=popsw; if popsw >= st then newpc(pc+k) end;
1457     BGT: begin st:=popsw; if popsw >  st then newpc(pc+k) end;
1458
1459     ZLT: if popsw <  0 then newpc(pc+k);
1460     ZLE: if popsw <= 0 then newpc(pc+k);
1461     ZEQ: if pop   =  0 then newpc(pc+k);
1462     ZNE: if pop   <> 0 then newpc(pc+k);
1463     ZGE: if popsw >= 0 then newpc(pc+k);
1464     ZGT: if popsw >  0 then newpc(pc+k)
1465   end
1466 end;
1467
1468 procedure callops;
1469 var j:integer;
1470 begin
1471   case insr of
1472     { PROCEDURE CALL GROUP }
1473     CAL: call(argp(k));
1474     CAI: begin call(argp(popa)) end;
1475     RET: begin k:=argz(k); if k div wsize>maxret  then trap(EILLINS);
1476            for j:= 1 to k div wsize do retarea[j]:=pop; retsize:=k;
1477            newsp(lb); lb:=maxdata+1; { To circumvent stack overflow error }
1478            newpc(popa);
1479            if pc=maxcode then
1480            begin
1481              halted:=true;
1482              if retsize=wsize then exitstatus:=retarea[1]
1483                else exitstatus:=undef
1484           end
1485           else
1486              newlb(popa);
1487          end;
1488     LFR: begin k:=args(k); if k<>retsize then trap(EILLINS);
1489            for j:=k div wsize downto 1 do push(retarea[j]);
1490          end
1491   end
1492 end;
1493
1494 procedure miscops;
1495 var i,j:integer;
1496 begin
1497   case insr of
1498     { MISCELLANEOUS GROUP }
1499     ASP,ASS:
1500          begin if insr=ASS then
1501            begin k:=argw(k); if k<>wsize then trap(EILLINS); k:=popsw end;
1502            k:=argf(k);
1503            if k<0
1504              then for j:= 1 to -k div wsize do push(undef)
1505              else newsp(sp+k);
1506          end;
1507     BLM,BLS:
1508          begin if insr=BLS then
1509            begin k:=argw(k); if k<>wsize then trap(EILLINS); k:=pop end;
1510            k:=argz(k);
1511            b:=popa; a:=popa;
1512            for j := 1 to k div wsize do
1513              store(b-wsize+wsize*j,memw(a-wsize+wsize*j))
1514          end;
1515     CSA: begin k:=argw(k); if k<>wsize then trap(EILLINS);
1516            a:=popa;
1517            st:= popsw - signwd(memw(a+asize));
1518            if (st>=0) and (st<=memw(a+wsize+asize)) then
1519               b:=mema(a+2*wsize+asize+asize*st) else b:=mema(a);
1520            if b=0 then trap(ECASE) else newpc(b)
1521          end;
1522     CSB: begin k:=argw(k); if k<>wsize then trap(EILLINS); a:=popa;
1523            t:=pop; i:=1; found:=false;
1524            while (i<=memw(a+asize)) and not found do
1525              if t=memw(a+(asize+wsize)*i) then found:=true else i:=i+1;
1526            if found then b:=memw(a+(asize+wsize)*i+wsize) else b:=memw(a);
1527            if b=0 then trap(ECASE) else newpc(b);
1528          end;
1529     DCH: begin pusha(mema(popa+dynd)) end;
1530     DUP,DUS:
1531          begin if insr=DUS then
1532               begin k:=argw(k); if k<>wsize then trap(EILLINS); k:=pop end;
1533            k:=args(k);
1534            for i:=1 to k div wsize do push(memw(sp+k-wsize));
1535          end;
1536     EXG: begin
1537            k:=argw(k);
1538            for i:=1 to k div wsize do push(memw(sp+k-wsize));
1539            for i:=0 to k div wsize - 1 do
1540              store(sp+k+i*wsize,memw(sp+k+k+i*wsize));
1541            for i:=1 to k div wsize do
1542            begin t:=pop ; store(sp+k+k-wsize,t) end;
1543          end;
1544     FIL: filna(argg(k));
1545     GTO: begin k:=argg(k);
1546            newlb(mema(k+2*asize)); newsp(mema(k+asize)); newpc(mema(k))
1547          end;
1548     LIM: push(ignmask);
1549     LIN: lino(argn(k));
1550     LNI: lino(memw(0)+1);
1551     LOR: begin i:=argr(k);
1552            case i of 0:pusha(lb); 1:pusha(sp); 2:pusha(hp) end;
1553          end;
1554     LPB: pusha(popa+statd);
1555     MON: domon(pop);
1556     NOP: writeln('NOP at line ',memw(0):5) ;
1557     RCK: begin a:=popa;
1558            case szindex(argw(k)) of
1559            1: if (signwd(memw(sp))<signwd(memw(a))) or
1560                 (signwd(memw(sp))>signwd(memw(a+wsize))) then trap(ERANGE);
1561            2: if (memd(sp)<memd(a)) or
1562                 (memd(sp)>memd(a+2*wsize)) then trap(ERANGE);
1563            end
1564          end;
1565     RTT: dortt;
1566     SIG: begin a:=popa; pusha(uerrorproc); uerrorproc:=a end;
1567     SIM: ignmask:=pop;
1568     STR: begin i:=argr(k);
1569            case i of 0: newlb(popa); 1: newsp(popa); 2: newhp(popa) end;
1570          end;
1571     TRP: trap(pop)
1572   end
1573 end;
1574 .bp
1575 {---------------------------------------------------------------------------}
1576 {                               Main Loop                                   }
1577 {---------------------------------------------------------------------------}
1578
1579 begin initialize;
1580 8888:
1581   repeat
1582     opcode := nextpc;       { fetch the first byte of the instruction }
1583     if opcode=escape1 then iclass:=second
1584     else if opcode=escape2 then iclass:=tert
1585     else iclass:=prim;
1586     if iclass<>prim then opcode := nextpc;
1587     with dispat[iclass][opcode] do
1588       begin insr:=instr;
1589         if not (zbit in iflag) then
1590           if ibit in iflag then k:=pop else
1591             begin
1592               if mini in iflag then k:=implicit else
1593                 begin
1594                   if short in iflag then k:=implicit+nextpc else
1595                     begin k:=nextpc;
1596                       if (sbit in iflag) and (k>=128) then k:=k-256;
1597                       for i:=2 to ilength do k:=256*k + nextpc
1598                     end
1599                 end;
1600               if wbit in iflag then k:=k*wsize;
1601             end
1602       end;
1603 case insr of
1604
1605   NON: trap(EILLINS);
1606
1607   { LOAD GROUP }
1608   LDC,LOC,LOL,LOE,LIL,LOF,LAL,LAE,LXL,LXA,LOI,LOS,LDL,LDE,LDF,LPI:
1609       loadops;
1610
1611   { STORE GROUP }
1612   STL,STE,SIL,STF,STI,STS,SDL,SDE,SDF:
1613       storeops;
1614
1615   { SIGNED INTEGER ARITHMETIC }
1616   ADI,SBI,MLI,DVI,RMI,NGI,SLI,SRI:
1617       intarith;
1618
1619   { UNSIGNED INTEGER ARITHMETIC }
1620   ADU,SBU,MLU,DVU,RMU,SLU,SRU:
1621       unsarith;
1622
1623   { FLOATING POINT ARITHMETIC }
1624   ADF,SBF,MLF,DVF,NGF,FIF,FEF:
1625       fltarith;
1626
1627   { POINTER ARITHMETIC }
1628   ADP,ADS,SBS:
1629       ptrarith;
1630
1631   { INCREMENT/DECREMENT/ZERO }
1632   INC,INL,INE,DEC,DEL,DEE,ZRL,ZRE,ZER,ZRF:
1633       incops;
1634
1635   { CONVERT GROUP }
1636   CII,CIU,CIF,CUI,CUU,CUF,CFI,CFU,CFF:
1637       convops;
1638
1639   { LOGICAL GROUP }
1640  XAND,IOR,XOR,COM,ROL,ROR:
1641       logops;
1642
1643   { SET GROUP }
1644   INN,XSET:
1645       setops;
1646
1647   { ARRAY GROUP }
1648   LAR,SAR,AAR:
1649       arrops;
1650
1651   { COMPARE GROUP }
1652   CMI,CMU,CMP,CMF,CMS,  TLT,TLE,TEQ,TNE,TGE,TGT:
1653       cmpops;
1654
1655   { BRANCH GROUP }
1656   BRA,  BLT,BLE,BEQ,BNE,BGE,BGT,  ZLT,ZLE,ZEQ,ZNE,ZGE,ZGT:
1657       branchops;
1658
1659   { PROCEDURE CALL GROUP }
1660   CAL,CAI,RET,LFR:
1661       callops;
1662
1663   { MISCELLANEOUS GROUP }
1664   ASP,ASS,BLM,BLS,CSA,CSB,DCH,DUP,DUS,EXG,FIL,GTO,LIM,
1665   LIN,LNI,LOR,LPB,MON,NOP,RCK,RTT,SIG,SIM,STR,TRP:
1666       miscops;
1667
1668     end;        { end of case statement }
1669     if not ( (insr=RET) or (insr=ASP) or (insr=BRA) or (insr=GTO) ) then
1670         retsize:=0 ;
1671   until halted;
1672 9999:
1673   writeln('halt with exit status: ',exitstatus:1);
1674   doident;
1675 end.
1676 .ft P
1677 .lg 1
1678 .fi