(*$c+,t-,d-,l+*)
(*Assembler and interpreter of Pascal code*)
(*K. Jensen, N. Wirth, Ch. Jacobi, ETH May 76*)

program pcode(input,output,prd,prr);

(* Note for the implementation.
   ===========================
This interpreter is written for the case where all the fundamental types
take one storage unit.
In an actual implementation, the handling of the sp pointer has to take
into account the fact that the types may have lengths different from one:
in push and pop operations the sp has to be increased and decreased not
by 1, but by a number depending on the type concerned.
However, where the number of units of storage has been computed by the
compiler, the value must not be corrected, since the lengths of the types
involved have already been taken into account.
                                                                 *)

(*********************************************************************

Adaption comments

Scott A. Moore samiam@moorecad.com

The purpose of my changes is to upgrade the code to ISO 7185.
Note that none of the changes are nonstandard, and in fact make the
code more, not less, standard.

- I detabbed it, at 8th tabs. Not everyone uses the same tab stops.
Use spaces please.

- In the "store" array, added "undef" case to record definition as
required by the standard.

- I removed unused variables in "assemble", "callsp", "load".

- I restored the number of spaces in various error strings to 25,
the length of beta. It looks like the program got tab expanded
incorrectly.

- Several opcodes that indicated different types were combined in the
original code. They worked because many of the basic variable types
were interchangable, such as integers and characters. This is not
true on other machines, and these needed to be broken out according
to type.

- Per the last item, 'ord' and 'chr' are no longer no-ops, so they
were added to both assemble and main (interpret).

The program originally came from this site:

http://www.cwi.nl/~steven/pascal.html

And they mention several changes made from the book form.

**********************************************************************)

label 1;
const codemax     =  100000(*8650*); (* increased this for testing [sam] *)
      pcmax       =  200000(*17500*);
      maxstk      =   30000(*13650*); (* size of variable store *)
      overi       =   40000(*13655*); (* size of integer constant table = 5 *)
      (* increased for testing [sam] *)
      overr       =   50000(*13660*); (* size of real constant table = 5 *)
      overs       =   60000(*13730*); (* size of set constant table = 70 *)
      overb       =   70000(*13820*);
      overm       = 1070000(*18000*); (* increased this for testing [sam] *)
      maxstr      = 1070001(*18001*); (* increased this for testing [sam] *)
      largeint    = 26144;
      begincode   = 3;
      inputadr    = 5;
      outputadr   = 6;
      prdadr      = 7;
      prradr      = 8;
      duminst     = 62;
      (* Parameterized length of strings in intermediate. It was already a 
        comment, just changed to a real number. [sam] *)
      stringlgth      = 200(*16*);
                
type  bit4        = 0..15;
      bit6        = 0..127;
      bit20       = -1080000..1080000(*-26143..26143*); (* increased for testing [sam] *)
      datatype    = (undef,int,reel,bool,sett,adr,mark,car);
      address     = -1..maxstr;
      beta        = packed array[1..25] of char; (*error message*)
      (* these types were added for CDC types [sam] *)
      settype     = set of 0..47;
      alfa        = packed array[1..10] of char;

var   code        : array[0..codemax] of   (* the program *)
                      packed record  op1    :bit6;
                                     p1     :bit4;
                                     q1     :bit20;
                                     op2    :bit6;
                                     p2     :bit4;
                                     q2     :bit20
                             end;
      pc           : 0..pcmax;   (*program address register*)
      op : bit6; p : bit4; q : bit20;  (*instruction register*)

      store        : array [0..overm] of
                       record case datatype of
                                (* added null case [sam] *)
                                undef:  ();
                                int     :(vi :integer);
                                reel    :(vr :real);
                                bool    :(vb :boolean);
                                (* changed settype to global type [sam] *)
                                sett    :(vs :settype);
                                car     :(vc :char);
                                adr     :(va :address);
                                          (*address in store*)
                                mark    :(vm :integer)
                        end;
       mp,sp,np,ep : address;  (* address registers *)
       (*mp  points to beginning of a data segment
         sp  points to top of the stack
         ep  points to the maximum extent of the stack
         np  points to top of the dynamically allocated area*)

       interpreting: boolean;
       prd,prr     : text;(*prd for read only, prr for write only *)

       instr       : array[bit6] of alfa; (* mnemonic instruction codes *)
       cop         : array[bit6] of integer;
       sptable     : array[0..20] of alfa; (*standard functions and procedures*)

      (*locally used for interpreting one instruction*)
       ad,ad1      : address;
       b           : boolean;
       i,j,i1,i2   : integer;
       c           : char;
       i3          : integer; (* [sam] for needed its own index *)

(*--------------------------------------------------------------------*)

procedure load;
   const maxlabel = 1850;
   type  labelst  = (entered,defined); (*label situation*)
         labelrg  = 0..maxlabel;       (*label range*)
         labelrec = record
                          val: address;
                           st: labelst
                    end;
   (* unused variables removed [sam] *)
   var  icp,rcp,scp,bcp,mcp  : address;  (*pointers to next free position*)
        word : array[1..10] of char; (*i  : integer;*) ch  : char;
        labeltab: array[labelrg] of labelrec;
        labelvalue: address;

   procedure init;
      var i: integer;
   begin instr[ 0]:='lod       ';       instr[ 1]:='ldo       ';
         instr[ 2]:='str       ';       instr[ 3]:='sro       ';
         instr[ 4]:='lda       ';       instr[ 5]:='lao       ';
         instr[ 6]:='sto       ';       instr[ 7]:='ldc       ';
         instr[ 8]:='...       ';       instr[ 9]:='ind       ';
         instr[10]:='inc       ';       instr[11]:='mst       ';
         instr[12]:='cup       ';       instr[13]:='ent       ';
         instr[14]:='ret       ';       instr[15]:='csp       ';
         instr[16]:='ixa       ';       instr[17]:='equ       ';
         instr[18]:='neq       ';       instr[19]:='geq       ';
         instr[20]:='grt       ';       instr[21]:='leq       ';
         instr[22]:='les       ';       instr[23]:='ujp       ';
         instr[24]:='fjp       ';       instr[25]:='xjp       ';
         instr[26]:='chk       ';       instr[27]:='eof       ';
         instr[28]:='adi       ';       instr[29]:='adr       ';
         instr[30]:='sbi       ';       instr[31]:='sbr       ';
         instr[32]:='sgs       ';       instr[33]:='flt       ';
         instr[34]:='flo       ';       instr[35]:='trc       ';
         instr[36]:='ngi       ';       instr[37]:='ngr       ';
         instr[38]:='sqi       ';       instr[39]:='sqr       ';
         instr[40]:='abi       ';       instr[41]:='abr       ';
         instr[42]:='not       ';       instr[43]:='and       ';
         instr[44]:='ior       ';       instr[45]:='dif       ';
         instr[46]:='int       ';       instr[47]:='uni       ';
         instr[48]:='inn       ';       instr[49]:='mod       ';
         instr[50]:='odd       ';       instr[51]:='mpi       ';
         instr[52]:='mpr       ';       instr[53]:='dvi       ';
         instr[54]:='dvr       ';       instr[55]:='mov       ';
         instr[56]:='lca       ';       instr[57]:='dec       ';
         instr[58]:='stp       ';       instr[59]:='ord       ';
         instr[60]:='chr       ';       instr[61]:='ujc       ';

         sptable[ 0]:='get       ';     sptable[ 1]:='put       ';
         sptable[ 2]:='rst       ';     sptable[ 3]:='rln       ';
         sptable[ 4]:='new       ';     sptable[ 5]:='wln       ';
         sptable[ 6]:='wrs       ';     sptable[ 7]:='eln       ';
         sptable[ 8]:='wri       ';     sptable[ 9]:='wrr       ';
         sptable[10]:='wrc       ';     sptable[11]:='rdi       ';
         sptable[12]:='rdr       ';     sptable[13]:='rdc       ';
         sptable[14]:='sin       ';     sptable[15]:='cos       ';
         sptable[16]:='exp       ';     sptable[17]:='log       ';
         sptable[18]:='sqt       ';     sptable[19]:='atn       ';
         sptable[20]:='sav       ';

         cop[ 0] := 105;  cop[ 1] :=  65;
         cop[ 2] :=  70;  cop[ 3] :=  75;
         cop[ 6] :=  80;  cop[ 9] :=  85;
         cop[10] :=  90;  cop[26] :=  95;
         cop[57] := 100;

         pc  := begincode;
         icp := maxstk + 1;
         rcp := overi + 1;
         scp := overr + 1;
         bcp := overs + 2;
         mcp := overb + 1;
         for i:= 1 to 10 do word[i]:= ' ';
         for i:= 0 to maxlabel do
             with labeltab[i] do begin val:=-1; st:= entered end;
         reset(prd);
   end;(*init*)

   procedure errorl(string: beta); (*error in loading*)
   begin writeln;
      write(string);
      halt
   end; (*errorl*)

   procedure update(x: labelrg); (*when a label definition lx is found*)
      var curr,succ: -1..pcmax;  (*resp. current element and successor element
                                   of a list of future references*)
          endlist: boolean;
   begin
      if labeltab[x].st=defined then errorl(' duplicated label        ')
      else begin
             if labeltab[x].val<>-1 then (*forward reference(s)*)
             begin curr:= labeltab[x].val; endlist:= false;
                while not endlist do
                      with code[curr div 2] do
                      begin
                         if odd(curr) then begin succ:= q2;
                                                 q2:= labelvalue
                                           end
                                      else begin succ:= q1;
                                                 q1:= labelvalue
                                           end;
                         if succ=-1 then endlist:= true
                                    else curr:= succ
                      end;
              end;
              labeltab[x].st := defined;
              labeltab[x].val:= labelvalue;
           end
   end;(*update*)

   procedure assemble; forward;

   procedure generate;(*generate segment of code*)
      var x: integer; (* label number *)
          again: boolean;
   begin
      again := true;
      while again do
            begin read(prd,ch);(* first character of line*)
                  case ch of
                       'i': readln(prd);
                       'l': begin read(prd,x);
                                  if not eoln(prd) then read(prd,ch);
                                  if ch='=' then read(prd,labelvalue)
                                            else labelvalue:= pc;
                                  update(x); readln(prd);
                            end;
                       'q': begin again := false; readln(prd) end;
                       ' ': begin read(prd,ch); assemble end
                  end;
            end
   end; (*generate*)

   (* removed unused variables [sam] *)
   procedure assemble; (*translate symbolic code into machine code and store*)
      (* this label no longer needed *)
      (*label 1;*)   (*goto 1 for instructions without code generation*)
      var name :alfa;  (*b :boolean;*)  r :real;  s :settype;
          (*c1 :char;*)  i,s1,lb,ub :integer;

      procedure lookup(x: labelrg); (* search in label table*)
      begin case labeltab[x].st of
                entered: begin q := labeltab[x].val;
                           labeltab[x].val := pc
                         end;
                defined: q:= labeltab[x].val
            end(*case label..*)
      end;(*lookup*)

      procedure labelsearch;
         var x: labelrg;
      begin while (ch<>'l') and not eoln(prd) do read(prd,ch);
            read(prd,x); lookup(x)
      end;(*labelsearch*)

      procedure getname;
      begin  word[1] := ch; 
         read(prd,word[2],word[3]);
         if not eoln(prd) then read(prd,ch) (*next character*);
         pack(word,1,name) 
      end; (*getname*)

      procedure typesymbol;
        var i: integer;
      begin
        if ch <> 'i' then
          begin
            case ch of
              'a': i := 0;
              'r': i := 1;
              's': i := 2;
              'b': i := 3;
              'c': i := 4;
            end;
            op := cop[op]+i;
          end;
      end (*typesymbol*) ;

   begin  p := 0;  q := 0;  op := 0;
      getname;
      instr[duminst] := name;
      while instr[op]<>name do op := op+1;
      if op = duminst then errorl(' illegal instruction     ');

(*;writeln('assemble: op: ', name:0, ' fc: ', ch, ' (', op:1, ')');*)
      case op of  (* get parameters p,q *)

          (*equ,neq,geq,grt,leq,les*)
          17,18,19,
          20,21,22: begin case ch of
                              'a': ; (*p = 0*)
                              'i': p := 1;
                              'r': p := 2;
                              'b': p := 3;
                              's': p := 4;
                              'c': p := 6;
                              'm': begin p := 5;
                                     read(prd,q)
                                   end
                          end
                    end;

          (*lod,str*)
          0,2: begin typesymbol; read(prd,p,q)
               end;

          4  (*lda*): read(prd,p,q);

          12 (*cup*): begin read(prd,p); labelsearch end;

          11 (*mst*): read(prd,p);

          14 (*ret*): case ch of
                            'p': p:=0;
                            'i': p:=1;
                            'r': p:=2;
                            'c': p:=3;
                            'b': p:=4;
                            'a': p:=5
                      end;

          (*lao,ixa,mov*)
          5,16,55: read(prd,q);

          (*ldo,sro,ind,inc,dec*)
          1,3,9,10,57: begin typesymbol; read(prd,q)
                       end;

          (*ujp,fjp,xjp*)
          23,24,25: labelsearch;

          13 (*ent*): begin read(prd,p); labelsearch end;

          15 (*csp*): begin for i:=1 to 9 do read(prd,ch); getname;
                           while name<>sptable[q] do  q := q+1
                      end;

          7 (*ldc*): begin case ch of  (*get q*)
                           'i': begin  p := 1;  read(prd,i);
                                   if abs(i)>=largeint then
                                   begin  op := 8;
                                      store[icp].vi := i;  q := maxstk;
                                      repeat  q := q+1  until store[q].vi=i;
                                      if q=icp then
                                      begin  icp := icp+1;
                                        if icp=overi then
                                          errorl(' integer table overflow  ');
                                      end
                                   end  else q := i
                                end;

                           'r': begin  op := 8; p := 2;
                                   read(prd,r);
                                   store[rcp].vr := r;  q := overi;
                                   repeat  q := q+1  until store[q].vr=r;
                                   if q=rcp then
                                   begin  rcp := rcp+1;
                                     if rcp = overr then
                                       errorl(' real table overflow     ');
                                   end
                                end;

                           'n': ; (*p,q = 0*)

                           'b': begin p := 3;  read(prd,q)  end;

                           'c': begin p := 6;
                                  repeat read(prd,ch); until ch <> ' ';
                                  if ch <> '''' then
                                    errorl(' illegal character       ');
                                  read(prd,ch);  q := ord(ch);
                                  read(prd,ch);
                                  if ch <> '''' then
                                    errorl(' illegal character       ');
                                end;
                           '(': begin  op := 8;  p := 4;
                                   s := [ ];  read(prd,ch);
                                   while ch<>')' do
                                   begin read(prd,s1,ch); s := s + [s1]
                                   end;
                                   store[scp].vs := s;  q := overr;
                                   repeat  q := q+1  until store[q].vs=s;
                                   if q=scp then
                                   begin  scp := scp+1;
                                      if scp=overs then
                                        errorl(' set table overflow      ');
                                   end
                                end
                           end (*case*)
                     end;

           26 (*chk*): begin typesymbol;
                         read(prd,lb,ub);
                         if op = 95 then q := lb
                         else
                         begin
                           store[bcp-1].vi := lb; store[bcp].vi := ub;
                           q := overs;
                           repeat  q := q+2
                           until (store[q-1].vi=lb)and (store[q].vi=ub);
                           if q=bcp then
                           begin  bcp := bcp+2;
                              if bcp=overb then
                                errorl(' boundary table overflow ');
                           end
                         end
                       end;

           56 (*lca*): begin
                         if mcp + stringlgth >= overm then
                           errorl(' multiple table overflow ');
                         mcp := mcp+stringlgth;
                         q := mcp;
                         (* changed to use global constant [sam] *)
                         for i := 0 to stringlgth-1 (*stringlgth*) do
                         begin read(prd,ch);
                           store[q+i].vc := ch
                         end;
                       end;

          6 (*sto*): typesymbol;

          (* added ord and chr back as operators [sam] *)

          27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,
          48,49,50,51,52,53,54,58, 60:  ; (*added chr*)

          59 (*ord*): begin case ch of
                              'i': p := 1;
                              'r': p := 2;
                              'b': p := 3;
                              's': p := 4;
                              'c': p := 6;
                          end
                    end;

          (* removed [sam] *)
          (*ord,chr*)
          (*59,60: goto 1;*)

          61 (*ujc*): ; (*must have same length as ujp*)

      end; (*case*)

      (* store instruction *)
      with code[pc div 2] do
         if odd(pc) then
         begin  op2 := op; p2 := p; q2 := q
         end  else
         begin  op1 := op; p1 := p; q1 := q
         end;
      pc := pc+1;
      (*1:*) readln(prd); (* removed this label [sam] *)
   end; (*assemble*)

begin (*load*)
   init;
   generate;
   pc := 0;
   generate;
end; (*load*)

(*------------------------------------------------------------------------*)

procedure pmd;
   var s :integer; i: integer;

   procedure pt;
   begin  write(s:6);
      if abs(store[s].vi) < maxint then write(store[s].vi)
      else write('too big ');
      s := s - 1;
      i := i + 1;
      if i = 4 then
         begin writeln(output); i := 0 end;
   end; (*pt*)

begin
   write(' pc =',pc-1:5,' op =',op:3,'  sp =',sp:5,'  mp =',mp:5,
        '  np =',np:5);
   writeln; writeln('--------------------------------------');

   s := sp; i := 0;
   while s>=0 do pt;
   s := maxstk;
   while s>=np do pt;
end; (*pmd*)

procedure errori(string: beta);
begin writeln; writeln(string);
      pmd; goto 1
end;(*errori*)

function base(ld :integer):address;
   var ad :address;
begin  ad := mp;
   while ld>0 do
   begin  ad := store[ad+1].vm;  ld := ld-1
   end;
   base := ad
end; (*base*)

procedure compare;
(*comparing is only correct if result by comparing integers will be*)
begin
  i1 := store[sp].va;
  i2 := store[sp+1].va;
  i := 0; b := true;
  while b and (i<>q) do
    if store[i1+i].vi = store[i2+i].vi then i := i+1
    else b := false
end; (*compare*)

(* unused variables removed [sam] *)
procedure callsp;
   var line: boolean; (*adptr(*,adelnt: address;*)
       (*i: integer;*)

   procedure readi(var f:text);
      var ad: address;
   begin ad:= store[sp-1].va;
         read(f,store[ad].vi);
         store[store[sp].va].vc := f^;
         sp:= sp-2
   end;(*readi*)

   procedure readr(var f: text);
      var ad: address;
   begin ad:= store[sp-1].va;
         read(f,store[ad].vr);
         store[store[sp].va].vc := f^;
         sp:= sp-2
   end;(*readr*)

   procedure readc(var f: text);
      var c: char; ad: address;
   begin read(f,c);
         ad:= store[sp-1].va;
         store[ad].vc := c;
         store[store[sp].va].vc := f^;
         store[store[sp].va].vi := ord(f^);
         sp:= sp-2
   end;(*readc*)

   procedure writestr(var f: text);
      var i,j,k: integer;
          ad: address;
   begin ad:= store[sp-3].va;
         k := store[sp-2].vi; j := store[sp-1].vi;
         (* j and k are numbers of characters *)
         if k>j then for i:=1 to k-j do write(f,' ')
                else j:= k;
         for i := 0 to j-1 do write(f,store[ad+i].vc);
         sp:= sp-4
   end;(*writestr*)

   procedure getfile(var f: text);
      var ad: address;
   begin ad:=store[sp].va;
         get(f); store[ad].vc := f^;
         sp:=sp-1
   end;(*getfile*)

   procedure putfile(var f: text);
      var ad: address;
   begin ad:= store[sp].va;
         f^:= store[ad].vc; put(f);
         sp:= sp-1;
   end;(*putfile*)

begin (*callsp*)
      case q of
           0 (*get*): case store[sp].va of
                           5: getfile(input);
                           6: errori(' get on output file      ');
                           7: getfile(prd);
                           8: errori(' get on prr file         ')
                      end;
           1 (*put*): case store[sp].va of
                           5: errori(' put on read file        ');
                           6: putfile(output);
                           7: errori(' put on prd file         ');
                           8: putfile(prr)
                      end;
           2 (*rst*): begin
                        (*for testphase*)
                        np := store[sp].va; sp := sp-1
                      end;
           3 (*rln*): begin case store[sp].va of
                                 5: begin readln(input);
                                      store[inputadr].vc := input^
                                    end;
                                 6: errori(' readln on output file   ');
                                 7: begin readln(input);
                                      store[inputadr].vc := input^
                                    end;
                                 8: errori(' readln on prr file      ')
                            end;
                            sp:= sp-1
                      end;
           4 (*new*): begin ad:= np-store[sp].va;
                      (*top of stack gives the length in units of storage *)
                            if ad <= ep then
                              errori(' store overflow          ');
                            np:= ad; ad:= store[sp-1].va;
                            store[ad].va := np;
                            sp:=sp-2
                      end;
           5 (*wln*): begin case store[sp].va of
                                 5: errori(' writeln on input file   ');
                                 6: writeln(output);
                                 7: errori(' writeln on prd file     ');
                                 8: writeln(prr)
                            end;
                            sp:= sp-1
                      end;
           6 (*wrs*): case store[sp].va of
                           5: errori(' write on input file     ');
                           6: writestr(output);
                           7: errori(' write on prd file       ');
                           8: writestr(prr)
                      end;
           7 (*eln*): begin case store[sp].va of
                                 5: line:= eoln(input);
                                 6: errori(' eoln output file        ');
                                 7: line:=eoln(prd);
                                 8: errori(' eoln on prr file        ')
                            end;
                            store[sp].vb := line
                      end;
           8 (*wri*): begin case store[sp].va of
                                 5: errori(' write on input file     ');
                                 6: write(output,
                                      store[sp-2].vi: store[sp-1].vi);
                                 7: errori(' write on prd file       ');
                                 8: write(prr,
                                      store[sp-2].vi: store[sp-1].vi)
                            end;
                            sp:=sp-3
                      end;
           9 (*wrr*): begin case store[sp].va of
                                 5: errori(' write on input file     ');
                                 6: write(output,
                                      store[sp-2].vr: store[sp-1].vi);
                                 7: errori(' write on prd file       ');
                                 8: write(prr,
                                      store[sp-2].vr: store[sp-1].vi)
                            end;
                            sp:=sp-3
                      end;
           10(*wrc*): begin case store[sp].va of
                                 5: errori(' write on input file     ');
                                 6: write(output,store[sp-2].vc:
                                      store[sp-1].vi);
                                 7: errori(' write on prd file       ');
                                 8: write(prr,chr(store[sp-2].vi):
                                      store[sp-1].vi);
                            end;
                            sp:=sp-3
                      end;
           11(*rdi*): case store[sp].va of
                           5: readi(input);
                           6: errori(' read on output file     ');
                           7: readi(prd);
                           8: errori(' read on prr file        ')
                      end;
           12(*rdr*): case store[sp].va of
                           5: readr(input);
                           6: errori(' read on output file     ');
                           7: readr(prd);
                           8: errori(' read on prr file        ')
                      end;
           13(*rdc*): case store[sp].va of
                           5: readc(input);
                           6: errori(' read on output file     ');
                           7: readc(prd);
                           8: errori(' read on prr file        ')
                      end;
           14(*sin*): store[sp].vr:= sin(store[sp].vr);
           15(*cos*): store[sp].vr:= cos(store[sp].vr);
           16(*exp*): store[sp].vr:= exp(store[sp].vr);
           17(*log*): store[sp].vr:= ln(store[sp].vr);
           18(*sqt*): store[sp].vr:= sqrt(store[sp].vr);
           19(*atn*): store[sp].vr:= arctan(store[sp].vr);
           20(*sav*): begin ad:=store[sp].va;
                         store[ad].va := np;
                         sp:= sp-1
                      end;
      end;(*case q*)
end;(*callsp*)

begin (* main *)
  (* Must comment out the next for self compile *)
  (* rewrite(prr); *)
  load; (* assembles and stores code *)
  writeln(output); (* for testing *)
  pc := 0; sp := -1; mp := 0; np := maxstk+1; ep := 5;
  store[inputadr].vc := input^;
  store[prdadr].vc := prd^;
  interpreting := true;

  while interpreting do
  begin
    (*fetch*)
    with code[pc div 2] do
      if odd(pc) then
      begin op := op2; p := p2; q := q2
      end else
      begin op := op1; p := p1; q := q1
      end;
    pc := pc+1;

    (*execute*)
(*;writeln('Execute: ', op:1, ' at: ', pc:1);*)
    case op of

          105,106,107,108,109,
          0 (*lod*): begin  ad := base(p) + q;
                      sp := sp+1;
                      store[sp] := store[ad]
                     end;

          65,66,67,68,69,
          1 (*ldo*): begin
                      sp := sp+1;
                      store[sp] := store[q]
                     end;

          70,71,72,73,74,
          2 (*str*): begin  store[base(p)+q] := store[sp];
                      sp := sp-1
                     end;

          75,76,77,78,79,
          3 (*sro*): begin  store[q] := store[sp];
                      sp := sp-1
                     end;

          4 (*lda*): begin sp := sp+1;
                      store[sp].va := base(p) + q
                     end;

          5 (*lao*): begin sp := sp+1;
                      store[sp].va := q
                     end;

          80,81,82,83,84,
          6 (*sto*): begin
                      store[store[sp-1].va] := store[sp];
                      sp := sp-2;
                     end;

          7 (*ldc*): begin sp := sp+1;
                      if p=1 then
                      begin store[sp].vi := q;
                      end else
                          if p = 6 then store[sp].vc := chr(q)
                          else
                            if p = 3 then store[sp].vb := q = 1
                            else (* load nil *) store[sp].va := maxstr
                     end;

          8 (*lci*): begin sp := sp+1;
                      store[sp] := store[q]
                     end;

          85,86,87,88,89,
          9 (*ind*): begin ad := store[sp].va + q;
                      (* q is a number of storage units *)
                      store[sp] := store[ad]
                     end;

          (* These were broken out according to type *)
          90,91,92,
          10 (*inc*): store[sp].vi := store[sp].vi+q;
          93 (*incb*): store[sp].vb := succ(store[sp].vb);
          94 (*incc*): store[sp].vc := chr(ord(store[sp].vc)+q);

          11 (*mst*): begin (*p=level of calling procedure minus level of called
                              procedure + 1;  set dl and sl, increment sp*)
                       (* then length of this element is
                          max(intsize,realsize,boolsize,charsize,ptrsize *)
                       store[sp+2].vm := base(p);
                       (* the length of this element is ptrsize *)
                       store[sp+3].vm := mp;
                       (* idem *)
                       store[sp+4].vm := ep;
                       (* idem *)
                       sp := sp+5
                      end;

          12 (*cup*): begin (*p=no of locations for parameters, q=entry point*)
                       mp := sp-(p+4);
                       store[mp+4].vm := pc;
                       pc := q
                      end;

          13 (*ent*): if p = 1 then
                        begin sp := mp + q; (*q = length of dataseg*)
                          if sp > np then errori(' store overflow          ');
                        end
                      else
                        begin ep := sp+q;
                          if ep > np then errori(' store overflow          ');
                        end;
                        (*q = max space required on stack*)

          14 (*ret*): begin case p of
                                 0: sp:= mp-1;
                                 1,2,3,4,5: sp:= mp
                            end;
                            pc := store[mp+4].vm;
                            ep := store[mp+3].vm;
                            mp:= store[mp+2].vm;
                      end;

          15 (*csp*): callsp;

          16 (*ixa*): begin
                       i := store[sp].vi;
                       sp := sp-1;
                       store[sp].va := q*i+store[sp].va;
                      end;

          17 (*equ*): begin  sp := sp-1;
                       case p of
                         1: store[sp].vb := store[sp].vi = store[sp+1].vi;
                         0: store[sp].vb := store[sp].va = store[sp+1].va;
                         6: store[sp].vb := store[sp].vc = store[sp+1].vc;
                         2: store[sp].vb := store[sp].vr = store[sp+1].vr;
                         3: store[sp].vb := store[sp].vb = store[sp+1].vb;
                         4: store[sp].vb := store[sp].vs = store[sp+1].vs;
                         5: begin  compare;
                               store[sp].vb := b;
                            end;
                       end; (*case p*)
                      end;

          18 (*neq*): begin  sp := sp-1;
                       case p of
                         0: store[sp].vb := store[sp].va <> store[sp+1].va;
                         1: store[sp].vb := store[sp].vi <> store[sp+1].vi;
                         6: store[sp].vb := store[sp].vc <> store[sp+1].vc;
                         2: store[sp].vb := store[sp].vr <> store[sp+1].vr;
                         3: store[sp].vb := store[sp].vb <> store[sp+1].vb;
                         4: store[sp].vb := store[sp].vs <> store[sp+1].vs;
                         5: begin  compare;
                               store[sp].vb := not b;
                            end
                       end; (*case p*)
                      end;

          19 (*geq*): begin  sp := sp-1;
                       case p of
                         0: errori(' <,<=,>,>= for address   ');
                         1: store[sp].vb := store[sp].vi >= store[sp+1].vi;
                         6: store[sp].vb := store[sp].vc >= store[sp+1].vc;
                         2: store[sp].vb := store[sp].vr >= store[sp+1].vr;
                         3: store[sp].vb := store[sp].vb >= store[sp+1].vb;
                         4: store[sp].vb := store[sp].vs >= store[sp+1].vs;
                         5: begin compare;
                              store[sp].vb := b or
                                (store[i1+i].vi >= store[i2+i].vi)
                            end
                       end; (*case p*)
                      end;

          20 (*grt*): begin  sp := sp-1;
                       case p of
                         0: errori(' <,<=,>,>= for address   ');
                         1: store[sp].vb := store[sp].vi > store[sp+1].vi;
                         6: store[sp].vb := store[sp].vc > store[sp+1].vc;
                         2: store[sp].vb := store[sp].vr > store[sp+1].vr;
                         3: store[sp].vb := store[sp].vb > store[sp+1].vb;
                         4: errori(' set inclusion           ');
                         5: begin  compare;
                              store[sp].vb := not b and
                                (store[i1+i].vi > store[i2+i].vi)
                            end
                       end; (*case p*)
                      end;

          21 (*leq*): begin  sp := sp-1;
                       case p of
                         0: errori(' <,<=,>,>= for address   ');
                         1: store[sp].vb := store[sp].vi <= store[sp+1].vi;
                         6: store[sp].vb := store[sp].vc <= store[sp+1].vc;
                         2: store[sp].vb := store[sp].vr <= store[sp+1].vr;
                         3: store[sp].vb := store[sp].vb <= store[sp+1].vb;
                         4: store[sp].vb := store[sp].vs <= store[sp+1].vs;
                         5: begin  compare;
                              store[sp].vb := b or
                                (store[i1+i].vi <= store[i2+i].vi)
                            end;
                       end; (*case p*)
                      end;

          22 (*les*): begin  sp := sp-1;
                       case p of
                         0: errori(' <,<=,>,>= for address   ');
                         1: store[sp].vb := store[sp].vi < store[sp+1].vi;
                         6: store[sp].vb := store[sp].vc < store[sp+1].vc;
                         2: store[sp].vb := store[sp].vr < store[sp+1].vr;
                         3: store[sp].vb := store[sp].vb < store[sp+1].vb;
                         5: begin  compare;
                              store[sp].vb := not b and
                                (store[i1+i].vi < store[i2+i].vi)
                            end
                       end; (*case p*)
                      end;

          23 (*ujp*): pc := q;

          24 (*fjp*): begin  if not store[sp].vb then pc := q;
                       sp := sp-1
                      end;

          25 (*xjp*): begin
                       pc := store[sp].vi + q;
                       sp := sp-1
                      end;

          95 (*chka*): if (store[sp].va < np) or
                          (store[sp].va > (maxstr-q)) then
                         errori(' bad pointer value       ');
          (* expanded these cases per type *)
          96,97,
          26 (*chk*): if (store[sp].vi < store[q-1].vi) or
                         (store[sp].vi > store[q].vi) then
                        errori(' value out of range      ');
          98 (*chkb*): if (store[sp].vb < store[q-1].vb) or
                          (store[sp].vb > store[q].vb) then
                        errori(' value out of range      ');
          99 (*chkc*): if (store[sp].vc < store[q-1].vc) or
                          (store[sp].vc > store[q].vc) then
                        errori(' value out of range      ');

          27 (*eof*): begin  i := store[sp].vi;
                       if i=inputadr then
                       begin store[sp].vb := eof(input);
                       end else errori(' code in error           ')
                      end;

          28 (*adi*): begin  sp := sp-1;
                       store[sp].vi := store[sp].vi + store[sp+1].vi
                      end;

          29 (*adr*): begin  sp := sp-1;
                       store[sp].vr := store[sp].vr + store[sp+1].vr
                      end;

          30 (*sbi*): begin sp := sp-1;
                       store[sp].vi := store[sp].vi - store[sp+1].vi
                      end;

          31 (*sbr*): begin  sp := sp-1;
                       store[sp].vr := store[sp].vr - store[sp+1].vr
                      end;

          32 (*sgs*): store[sp].vs := [store[sp].vi];

          33 (*flt*): store[sp].vr := store[sp].vi;

          34 (*flo*): store[sp-1].vr := store[sp-1].vi;

          35 (*trc*): store[sp].vi := trunc(store[sp].vr);

          36 (*ngi*): store[sp].vi := -store[sp].vi;

          37 (*ngr*): store[sp].vr := -store[sp].vr;

          38 (*sqi*): store[sp].vi := sqr(store[sp].vi);

          39 (*sqr*): store[sp].vr := sqr(store[sp].vr);

          40 (*abi*): store[sp].vi := abs(store[sp].vi);

          41 (*abr*): store[sp].vr := abs(store[sp].vr);

          42 (*not*): store[sp].vb := not store[sp].vb;

          43 (*and*): begin  sp := sp-1;
                       store[sp].vb := store[sp].vb and store[sp+1].vb
                      end;

          44 (*ior*): begin  sp := sp-1;
                       store[sp].vb := store[sp].vb or store[sp+1].vb
                      end;

          45 (*dif*): begin  sp := sp-1;
                       store[sp].vs := store[sp].vs - store[sp+1].vs
                      end;

          46 (*int*): begin  sp := sp-1;
                       store[sp].vs := store[sp].vs * store[sp+1].vs
                      end;

          47 (*uni*): begin  sp := sp-1;
                       store[sp].vs := store[sp].vs + store[sp+1].vs
                      end;

          48 (*inn*): begin
                       sp := sp - 1; i := store[sp].vi;
                       store[sp].vb := i in store[sp+1].vs;
                      end;

          49 (*mod*): begin  sp := sp-1;
                       store[sp].vi := store[sp].vi mod store[sp+1].vi
                      end;

          50 (*odd*): store[sp].vb := odd(store[sp].vi);

          51 (*mpi*): begin  sp := sp-1;
                       store[sp].vi := store[sp].vi * store[sp+1].vi
                      end;

          52 (*mpr*): begin  sp := sp-1;
                       store[sp].vr := store[sp].vr * store[sp+1].vr
                      end;

          53 (*dvi*): begin  sp := sp-1;
                       store[sp].vi := store[sp].vi div store[sp+1].vi
                      end;

          54 (*dvr*): begin  sp := sp-1;
                       store[sp].vr := store[sp].vr / store[sp+1].vr
                      end;

          55 (*mov*): begin i1 := store[sp-1].va;
                       i2 := store[sp].va; sp := sp-2;
                       for i3 := 0 to q-1 do store[i1+i3] := store[i2+i3]
                       (* q is a number of storage units *)
                      end;

          56 (*lca*): begin  sp := sp+1;
                       store[sp].va := q;
                      end;

          (* these were broken out by type [sam] *)
          100,101,102,
          57 (*dec*): store[sp].vi := store[sp].vi-q;
          103 (*decb*): store[sp].vb := pred(store[sp].vb);
          104 (*decc*): store[sp].vc := chr(ord(store[sp].vc)-q);

          58 (*stp*): interpreting := false;

          59 (*ord*): (*only used to change the tagfield*)
                      (*expanded back to take care of char and boolean cases
                        [sam]*)
                      begin
                         if p = 3 then store[sp].vi := ord(store[sp].vb)
                         else if p = 6 then store[sp].vi := ord(store[sp].vc)
                      end;

          60 (*chr*): store[sp].vc := chr(store[sp].vi); (*added chr back [sam]*)

          61 (*ujc*): errori(' case - error            ');
    end
  end; (*while interpreting*)

1 :
end.
