1 (*Assembler and interpreter of Pascal code*)
     2 (*K. Jensen, N. Wirth, Ch. Jacobi, ETH May 76*)
     3
     4 program pcode(input,output,prd,prr);
     5 
     6 (* Note for the implementation.
     7    ===========================
     8 This interpreter is written for the case where all the fundamental types
     9 take one storage unit.
    10 In an actual implementation, the handling of the sp pointer has to take
    11 into account the fact that the types may have lengths different from one:
    12 in push and pop operations the sp has to be increased and decreased not
    13 by 1, but by a number depending on the type concerned.
    14 However, where the number of units of storage has been computed by the
    15 compiler, the value must not be corrected, since the lengths of the types
    16 involved have already been taken into account.
    17          *)
    18 
    19 
    20 label 1;
    21 const codemax     = 8650;
    22       pcmax       = 17500;
    23       maxstk      = 13650; (* size of variable store *)
    24       overi       = 13655; (* size of integer constant table = 5 *)
    25       overr       = 13660; (* size of real constant table = 5 *)
    26       overs       = 13730; (* size of set constant table = 70 *)
    27       overb       = 13820;
    28       overm       = 18000;
    29       maxstr      = 18001;
    30       largeint    = 26144;
    31       begincode   = 3;
    32       inputadr    = 5;
    33       outputadr   = 6;
    34       prdadr      = 7;
    35       prradr      = 8;
    36       duminst     = 62;
    37 
    38 type  bit4        = 0..15;
    39       bit6        = 0..127;
    40       bit20       = -26143..26143;
    41       datatype    = (undef,int,reel,bool,sett,adr,mark,car);
    42       address     = -1..maxstr;
    43       beta        = packed array[1..25] of char; (*error message*)
    44       settype     = set of 0..58;
    45       alfa        = packed array[1..10] of char;
    46 
    47 var   code        : array[0..codemax] of   (* the program *)
    48                       packed record  op1    :bit6;
    49                                      p1     :bit4;
    50                                      q1     :bit20;
    51                                      op2    :bit6;
    52                                      p2     :bit4;
    53                                      q2     :bit20
    54                              end;
    55       pc          : 0..pcmax;  (*program address register*)
    56       op : bit6; p : bit4; q : bit20;  (*instruction register*)
    57 
    58       store       : array [0..overm] of
    59                       record case datatype of
    60                                int :(vi :integer);
    61                                reel:(vr :real);
    62                                bool:(vb :boolean);
    63                                sett:(vs :settype);
    64                                car :(vc :char);
    65                                adr :(va :address);
    66                                      (*address in store*)
    67                                mark:(vm :integer)
    68                       end;
    69       mp,sp,np,ep : address;  (* address registers *)
    70       (*mp  points to beginning of a data segment
    71         sp  points to top of the stack
    72         ep  points to the maximum extent of the stack
    73         np  points to top of the dynamically allocated area*)
    74 
    75       interpreting: boolean;
    76       prd,prr     : text;(*prd for read only, prr for write only *)
    77 
    78       instr       : array[bit6] of alfa; (* mnemonic instruction codes *)
    79       cop         : array[bit6] of integer;
    80       sptable     : array[0..20] of alfa; (*standard functions and procedures*)
    81 
    82      (*locally used for interpreting one instruction*)
    83       ad,ad1      : address;
    84       b           : boolean;
    85       i,j,i1,i2   : integer;
    86       c           : char;
    87 
    88 (*--------------------------------------------------------------------*)
    89 
    90 procedure load;
    91    const maxlabel = 1850;
    92    type  labelst  = (entered,defined); (*label situation*)
    93          labelrg  = 0..maxlabel;       (*label range*)
    94          labelrec = record
    95                        val: address;
    96                         st: labelst
    97                     end;
    98    var  icp,rcp,scp,bcp,mcp  : address;  (*pointers to next free position*)
    99         word : array[1..10] of char; i  : integer;  ch  : char;
   100         labeltab: array[labelrg] of labelrec;
   101         labelvalue: address;
   102 
   103    procedure init;
   104       var i: integer;
   105    begin instr[ 0]:='lod       ';       instr[ 1]:='ldo       ';
   106          instr[ 2]:='str       ';       instr[ 3]:='sro       ';
   107          instr[ 4]:='lda       ';       instr[ 5]:='lao       ';
   108          instr[ 6]:='sto       ';       instr[ 7]:='ldc       ';
   109          instr[ 8]:='...       ';       instr[ 9]:='ind       ';
   110          instr[10]:='inc       ';       instr[11]:='mst       ';
   111          instr[12]:='cup       ';       instr[13]:='ent       ';
   112          instr[14]:='ret       ';       instr[15]:='csp       ';
   113          instr[16]:='ixa       ';       instr[17]:='equ       ';
   114          instr[18]:='neq       ';       instr[19]:='geq       ';
   115          instr[20]:='grt       ';       instr[21]:='leq       ';
   116          instr[22]:='les       ';       instr[23]:='ujp       ';
   117          instr[24]:='fjp       ';       instr[25]:='xjp       ';
   118          instr[26]:='chk       ';       instr[27]:='eof       ';
   119          instr[28]:='adi       ';       instr[29]:='adr       ';
   120          instr[30]:='sbi       ';       instr[31]:='sbr       ';
   121          instr[32]:='sgs       ';       instr[33]:='flt       ';
   122          instr[34]:='flo       ';       instr[35]:='trc       ';
   123          instr[36]:='ngi       ';       instr[37]:='ngr       ';
   124          instr[38]:='sqi       ';       instr[39]:='sqr       ';
   125          instr[40]:='abi       ';       instr[41]:='abr       ';
   126          instr[42]:='not       ';       instr[43]:='and       ';
   127          instr[44]:='ior       ';       instr[45]:='dif       ';
   128          instr[46]:='int       ';       instr[47]:='uni       ';
   129          instr[48]:='inn       ';       instr[49]:='mod       ';
   130          instr[50]:='odd       ';       instr[51]:='mpi       ';
   131          instr[52]:='mpr       ';       instr[53]:='dvi       ';
   132          instr[54]:='dvr       ';       instr[55]:='mov       ';
   133          instr[56]:='lca       ';       instr[57]:='dec       ';
   134          instr[58]:='stp       ';       instr[59]:='ord       ';
   135          instr[60]:='chr       ';       instr[61]:='ujc       ';
   136 
   137          sptable[ 0]:='get       ';     sptable[ 1]:='put       ';
   138          sptable[ 2]:='rst       ';     sptable[ 3]:='rln       ';
   139          sptable[ 4]:='new       ';     sptable[ 5]:='wln       ';
   140          sptable[ 6]:='wrs       ';     sptable[ 7]:='eln       ';
   141          sptable[ 8]:='wri       ';     sptable[ 9]:='wrr       ';
   142          sptable[10]:='wrc       ';     sptable[11]:='rdi       ';
   143          sptable[12]:='rdr       ';     sptable[13]:='rdc       ';
   144          sptable[14]:='sin       ';     sptable[15]:='cos       ';
   145          sptable[16]:='exp       ';     sptable[17]:='log       ';
   146          sptable[18]:='sqt       ';     sptable[19]:='atn       ';
   147          sptable[20]:='sav       ';
   148 
   149          cop[ 0] := 105;  cop[ 1] :=  65;
   150          cop[ 2] :=  70;  cop[ 3] :=  75;
   151          cop[ 6] :=  80;  cop[ 9] :=  85;
   152          cop[10] :=  90;  cop[26] :=  95;
   153          cop[57] := 100;
   154 
   155          pc  := begincode;
   156          icp := maxstk + 1;
   157          rcp := overi + 1;
   158          scp := overr + 1;
   159          bcp := overs + 2;
   160          mcp := overb + 1;
   161          for i:= 1 to 10 do word[i]:= ' ';
   162          for i:= 0 to maxlabel do
   163              with labeltab[i] do begin val:=-1; st:= entered end;
   164          reset(prd);
   165    end;(*init*)
   166 
   167    procedure errorl(string: beta); (*error in loading*)
   168    begin writeln;
   169       write(string);
   170       halt
   171    end; (*errorl*)
   172 
   173    procedure update(x: labelrg); (*when a label definition lx is found*)
   174       var curr,succ: -1..pcmax;  (*resp. current element and successor element
   175                                    of a list of future references*)
   176           endlist: boolean;
   177    begin
   178       if labeltab[x].st=defined then errorl(' duplicated label ')
   179       else begin
   180              if labeltab[x].val<>-1 then (*forward reference(s)*)
   181              begin curr:= labeltab[x].val; endlist:= false;
   182                 while not endlist do
   183                       with code[curr div 2] do
   184                       begin
   185                         if odd(curr) then begin succ:= q2;
   186                                                 q2:= labelvalue
   187                                           end
   188                                      else begin succ:= q1;
   189                                                 q1:= labelvalue
   190                                           end;
   191                         if succ=-1 then endlist:= true
   192                                    else curr:= succ
   193                       end;
   194              end;
   195              labeltab[x].st := defined;
   196              labeltab[x].val:= labelvalue;
   197            end
   198    end;(*update*)
   199 
   200    procedure assemble; forward;
   201 
   202    procedure generate;(*generate segment of code*)
   203       var x: integer; (* label number *)
   204           again: boolean;
   205    begin
   206       again := true;
   207       while again do
   208             begin read(prd,ch);(* first character of line*)
   209                   case ch of
   210                        'i': readln(prd);
   211                        'l': begin read(prd,x);
   212                                   if not eoln(prd) then read(prd,ch);
   213                                   if ch='=' then read(prd,labelvalue)
   214                                             else labelvalue:= pc;
   215                                   update(x); readln(prd);
   216                             end;
   217                        'q': begin again := false; readln(prd) end;
   218                        ' ': begin read(prd,ch); assemble end
   219                   end;
   220             end
   221    end; (*generate*)
   222 
   223    procedure assemble; (*translate symbolic code into machine code and store*)
   224       label 1;  (*goto 1 for instructions without code generation*)
   225       var name :alfa;  b :boolean;  r :real;  s :settype;
   226           c1 :char;  i,s1,lb,ub :integer;
   227 
   228       procedure lookup(x: labelrg); (* search in label table*)
   229       begin case labeltab[x].st of
   230                 entered: begin q := labeltab[x].val;
   231                            labeltab[x].val := pc
   232                          end;
   233                 defined: q:= labeltab[x].val
   234             end(*case label..*)
   235       end;(*lookup*)
   236 
   237       procedure labelsearch;
   238          var x: labelrg;
   239       begin while (ch<>'l') and not eoln(prd) do read(prd,ch);
   240             read(prd,x); lookup(x)
   241       end;(*labelsearch*)
   242 
   243       procedure getname;
   244       begin  word[1] := ch;
   245          read(prd,word[2],word[3]);
   246          if not eoln(prd) then read(prd,ch) (*next character*);
   247          pack(word,1,name)
   248       end; (*getname*)
   249 
   250       procedure typesymbol;
   251          var i: integer;
   252       begin
   253         if ch <> 'i' then
   254           begin
   255             case ch of
   256               'a': i := 0;
   257               'r': i := 1;
   258               's': i := 2;
   259               'b': i := 3;
   260               'c': i := 4;
   261             end;
   262             op := cop[op]+i;
   263          end;
   264       end (*typesymbol*) ;
   265 
   266    begin  p := 0;  q := 0;  op := 0;
   267       getname;
   268       instr[duminst] := name;
   269       while instr[op]<>name do op := op+1;
   270       if op = duminst then errorl(' illegal instruction     ');
   271 
   272       case op of  (* get parameters p,q *)
   273 
   274          (*equ,neq,geq,grt,leq,les*)
   275          17,18,19,
   276          20,21,22: begin case ch of
   277                              'a': ; (*p = 0*)
   278                              'i': p := 1;
   279                              'r': p := 2;
   280                              'b': p := 3;
   281                              's': p := 4;
   282                              'c': p := 6;
   283                              'm': begin p := 5;
   284                                     read(prd,q)
   285                                   end
   286                          end
   287                    end;
   288 
   289          (*lod,str*)
   290          0,2: begin typesymbol; read(prd,p,q)
   291               end;
   292 
   293          4  (*lda*): read(prd,p,q);
   294 
   295          12 (*cup*): begin read(prd,p); labelsearch end;
   296 
   297          11 (*mst*): read(prd,p);
   298 
   299          14 (*ret*): case ch of
   300                           'p': p:=0;
   301                           'i': p:=1;
   302                           'r': p:=2;
   303                           'c': p:=3;
   304                           'b': p:=4;
   305                           'a': p:=5
   306                      end;
   307 
   308          (*lao,ixa,mov*)
   309          5,16,55: read(prd,q);
   310 
   311          (*ldo,sro,ind,inc,dec*)
   312          1,3,9,10,57: begin typesymbol; read(prd,q)
   313                       end;
   314 
   315          (*ujp,fjp,xjp*)
   316          23,24,25: labelsearch;
   317 
   318          13 (*ent*): begin read(prd,p); labelsearch end;
   319 
   320          15 (*csp*): begin for i:=1 to 9 do read(prd,ch); getname;
   321                            while name<>sptable[q] do  q := q+1
   322                      end;
   323 
   324          7 (*ldc*): begin case ch of  (*get q*)
   325                                'i': begin  p := 1;  read(prd,i);
   326                                       if abs(i)>=largeint then
   327                                       begin  op := 8;
   328                                         store[icp].vi := i;  q := maxstk;
   329                                         repeat  q := q+1  until store[q].vi=i;
   330                                         if q=icp then
   331                                         begin  icp := icp+1;
   332                                           if icp=overi then
   333                                             errorl(' integer table overflow  ');
   334                                         end
   335                                       end  else q := i
   336                                     end;
   337 
   338                                'r': begin  op := 8; p := 2;
   339                                       read(prd,r);
   340                                       store[rcp].vr := r;  q := overi;
   341                                       repeat  q := q+1  until store[q].vr=r;
   342                                       if q=rcp then
   343                                       begin  rcp := rcp+1;
   344                                         if rcp = overr then
   345                                           errorl(' real table overflow     ');
   346                                         end
   347                                       end;
   348 
   349                                'n': ; (*p,q = 0*)
   350 
   351                                'b': begin p := 3;  read(prd,q)  end;
   352 
   353                                'c': begin p := 6;
   354                                       repeat read(prd,ch); until ch <> ' ';
   355                                       if ch <> '''' then
   356                                         errorl(' illegal character       ');
   357                                       read(prd,ch);  q := ord(ch);
   358                                       read(prd,ch);
   359                                       if ch <> '''' then
   360                                         errorl(' illegal character       ');
   361                                       end;
   362                                '(': begin  op := 8;  p := 4;
   363                                       s := [ ];  read(prd,ch);
   364                                       while ch<>')' do
   365                                       begin read(prd,s1,ch); s := s + [s1]
   366                                       end;
   367                                       store[scp].vs := s;  q := overr;
   368                                       repeat  q := q+1  until store[q].vs=s;
   369                                       if q=scp then
   370                                       begin  scp := scp+1;
   371                                         if scp=overs then
   372                                           errorl(' set table overflow      ');
   373                                       end
   374                                     end
   375                           end (*case*)
   376                      end;
   377 
   378          26 (*chk*): begin typesymbol;
   379                        read(prd,lb,ub);
   380                        if op = 95 then q := lb
   381                        else
   382                          begin
   383                            store[bcp-1].vi := lb; store[bcp].vi := ub;
   384                            q := overs;
   385                            repeat  q := q+2
   386                            until (store[q-1].vi=lb)and (store[q].vi=ub);
   387                            if q=bcp then
   388                            begin  bcp := bcp+2;
   389                              if bcp=overb then
   390                                errorl(' boundary table overflow ');
   391                            end
   392                          end
   393                    end;
   394 
   395          56 (*lca*): begin
   396                        if mcp + 16 >= overm then
   397                          errorl(' multiple table overflow ');
   398                        mcp := mcp+16;
   399                        q := mcp;
   400                        for i := 0 to 15 (*stringlgth*) do
   401                        begin read(prd,ch);
   402                          store[q+i].vc := ch
   403                        end;
   404                      end;
   405 
   406          6 (*sto*): typesymbol;
   407 
   408          27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,
   409          48,49,50,51,52,53,54,58:  ;
   410 
   411          (*ord,chr*)
   412          59,60: goto 1;
   413 
   414          61 (*ujc*): ; (*must have same length as ujp*)
   415 
   416       end; (*case*)
   417 
   418       (* store instruction *)
   419       with code[pc div 2] do
   420          if odd(pc) then
   421          begin  op2 := op; p2 := p; q2 := q
   422          end  else
   423          begin  op1 := op; p1 := p; q1 := q
   424          end;
   425       pc := pc+1;
   426       1: readln(prd);
   427    end; (*assemble*)
   428 
   429 begin (*load*)
   430    init;
   431    generate;
   432    pc := 0;
   433    generate;
   434 end; (*load*)
   435 
   436 (*------------------------------------------------------------------------*)
   437 
   438 procedure pmd;
   439    var s :integer; i: integer;
   440 
   441    procedure pt;
   442    begin  write(s:6);
   443       if abs(store[s].vi) < maxint then write(store[s].vi)
   444       else write('too big ');
   445       s := s - 1;
   446       i := i + 1;
   447       if i = 4 then
   448          begin writeln(output); i := 0 end;
   449    end; (*pt*)
   450 
   451 begin
   452    write(' pc =',pc-1:5,' op =',op:3,'  sp =',sp:5,'  mp =',mp:5,
   453         '  np =',np:5);
   454    writeln; writeln('--------------------------------------');
   455 
   456    s := sp; i := 0;
   457    while s>=0 do pt;
   458    s := maxstk;
   459    while s>=np do pt;
   460 end; (*pmd*)
   461 
   462 procedure errori(string: beta);
   463 begin writeln; writeln(string);
   464       pmd; goto 1
   465 end;(*errori*)
   466 
   467 function base(ld :integer):address;
   468    var ad :address;
   469 begin  ad := mp;
   470    while ld>0 do
   471    begin  ad := store[ad+1].vm;  ld := ld-1
   472    end;
   473    base := ad
   474 end; (*base*)
   475 
   476 procedure compare;
   477 (*comparing is only correct if result by comparing integers will be*)
   478 begin
   479   i1 := store[sp].va;
   480   i2 := store[sp+1].va;
   481   i := 0; b := true;
   482   while b and (i<>q) do
   483     if store[i1+i].vi = store[i2+i].vi then i := i+1
   484     else b := false
   485 end; (*compare*)
   486 
   487 procedure callsp;
   488    var line: boolean; adptr,adelnt: address;
   489        i: integer;
   490 
   491    procedure readi(var f:text);
   492       var ad: address;
   493    begin ad:= store[sp-1].va;
   494          read(f,store[ad].vi);
   495          store[store[sp].va].vc := f^;
   496          sp:= sp-2
   497    end;(*readi*)
   498 
   499    procedure readr(var f: text);
   500       var ad: address;
   501    begin ad:= store[sp-1].va;
   502          read(f,store[ad].vr);
   503          store[store[sp].va].vc := f^;
   504          sp:= sp-2
   505    end;(*readr*)
   506 
   507    procedure readc(var f: text);
   508       var c: char; ad: address;
   509    begin read(f,c);
   510          ad:= store[sp-1].va;
   511          store[ad].vc := c;
   512          store[store[sp].va].vc := f^;
   513          store[store[sp].va].vi := ord(f^);
   514          sp:= sp-2
   515    end;(*readc*)
   516 
   517    procedure writestr(var f: text);
   518       var i,j,k: integer;
   519           ad: address;
   520    begin ad:= store[sp-3].va;
   521          k := store[sp-2].vi; j := store[sp-1].vi;
   522          (* j and k are numbers of characters *)
   523          if k>j then for i:=1 to k-j do write(f,' ')
   524          else j:= k;
   525          for i := 0 to j-1 do write(f,store[ad+i].vc);
   526          sp:= sp-4
   527    end;(*writestr*)
   528 
   529    procedure getfile(var f: text);
   530       var ad: address;
   531    begin ad:=store[sp].va;
   532          get(f); store[ad].vc := f^;
   533          sp:=sp-1
   534    end;(*getfile*)
   535 
   536    procedure putfile(var f: text);
   537       var ad: address;
   538    begin ad:= store[sp].va;
   539          f^:= store[ad].vc; put(f);
   540          sp:= sp-1;
   541    end;(*putfile*)
   542 
   543 begin (*callsp*)
   544       case q of
   545            0 (*get*): case store[sp].va of
   546                            5: getfile(input);
   547                            6: errori(' get on output file      ');
   548                            7: getfile(prd);
   549                            8: errori(' get on prr file  ')
   550                       end;
   551            1 (*put*): case store[sp].va of
   552                            5: errori(' put on read file ');
   553                            6: putfile(output);
   554                            7: errori(' put on prd file  ');
   555                            8: putfile(prr)
   556                       end;
   557            2 (*rst*): begin
   558                         (*for testphase*)
   559                         np := store[sp].va; sp := sp-1
   560                       end;
   561            3 (*rln*): begin case store[sp].va of
   562                                  5: begin readln(input);
   563                                       store[inputadr].vc := input^
   564                                     end;
   565                                  6: errori(' readln on output file   ');
   566                                  7: begin readln(input);
   567                                       store[inputadr].vc := input^
   568                                     end;
   569                                  8: errori(' readln on prr file      ')
   570                             end;
   571                             sp:= sp-1
   572                       end;
   573            4 (*new*): begin ad:= np-store[sp].va;
   574                       (*top of stack gives the length in units of storage *)
   575                             if ad <= ep then
   576                               errori(' store overflow   ');
   577                             np:= ad; ad:= store[sp-1].va;
   578                             store[ad].va := np;
   579                             sp:=sp-2
   580                       end;
   581            5 (*wln*): begin case store[sp].va of
   582                                  5: errori(' writeln on input file   ');
   583                                  6: writeln(output);
   584                                  7: errori(' writeln on prd file     ');
   585                                  8: writeln(prr)
   586                             end;
   587                             sp:= sp-1
   588                       end;
   589            6 (*wrs*): case store[sp].va of
   590                            5: errori(' write on input file     ');
   591                            6: writestr(output);
   592                            7: errori(' write on prd file       ');
   593                            8: writestr(prr)
   594                       end;
   595            7 (*eln*): begin case store[sp].va of
   596                                  5: line:= eoln(input);
   597                                  6: errori(' eoln output file ');
   598                                  7: line:=eoln(prd);
   599                                  8: errori(' eoln on prr file ')
   600                             end;
   601                             store[sp].vb := line
   602                        end;
   603            8 (*wri*): begin case store[sp].va of
   604                                  5: errori(' write on input file     ');
   605                                  6: write(output,
   606                                           store[sp-2].vi: store[sp-1].vi);
   607                                  7: errori(' write on prd file       ');
   608                                  8: write(prr,
   609                                           store[sp-2].vi: store[sp-1].vi)
   610                             end;
   611                             sp:=sp-3
   612                        end;
   613            9 (*wrr*): begin case store[sp].va of
   614                                  5: errori(' write on input file     ');
   615                                  6: write(output,
   616                                           store[sp-2].vr: store[sp-1].vi);
   617                                  7: errori(' write on prd file       ');
   618                                  8: write(prr,
   619                                           store[sp-2].vr: store[sp-1].vi)
   620                             end;
   621                             sp:=sp-3
   622                        end;
   623            10(*wrc*): begin case store[sp].va of
   624                                  5: errori(' write on input file     ');
   625                                  6: write(output,store[sp-2].vc:
   626                                           store[sp-1].vi);
   627                                  7: errori(' write on prd file       ');
   628                                  8: write(prr,chr(store[sp-2].vi):
   629                                           store[sp-1].vi);
   630                             end;
   631                             sp:=sp-3
   632                        end;
   633            11(*rdi*): case store[sp].va of
   634                            5: readi(input);
   635                            6: errori(' read on output file     ');
   636                            7: readi(prd);
   637                            8: errori(' read on prr file ')
   638                        end;
   639            12(*rdr*): case store[sp].va of
   640                            5: readr(input);
   641                            6: errori(' read on output file     ');
   642                            7: readr(prd);
   643                            8: errori(' read on prr file ')
   644                        end;
   645            13(*rdc*): case store[sp].va of
   646                            5: readc(input);
   647                            6: errori(' read on output file     ');
   648                            7: readc(prd);
   649                            8: errori(' read on prr file ')
   650                        end;
   651            14(*sin*): store[sp].vr:= sin(store[sp].vr);
   652            15(*cos*): store[sp].vr:= cos(store[sp].vr);
   653            16(*exp*): store[sp].vr:= exp(store[sp].vr);
   654            17(*log*): store[sp].vr:= ln(store[sp].vr);
   655            18(*sqt*): store[sp].vr:= sqrt(store[sp].vr);
   656            19(*atn*): store[sp].vr:= arctan(store[sp].vr);
   657            20(*sav*): begin ad:=store[sp].va;
   658                             store[ad].va := np;
   659                             sp:= sp-1
   660                       end;
   661       end;(*case q*)
   662 end;(*callsp*)
   663 
   664 begin (* main *)
   665   rewrite(prr);
   666   load; (* assembles and stores code *)
   667   (* writeln(output); for testing *)
   668   pc := 0; sp := -1; mp := 0; np := maxstk+1; ep := 5;
   669   store[inputadr].vc := input^;
   670   store[prdadr].vc := prd^;
   671   interpreting := true;
   672 
   673   while interpreting do
   674   begin
   675     (*fetch*)
   676     with code[pc div 2] do
   677       if odd(pc) then
   678       begin op := op2; p := p2; q := q2
   679       end else
   680       begin op := op1; p := p1; q := q1
   681       end;
   682     pc := pc+1;
   683 
   684     (*execute*)
   685     case op of
   686 
   687          105,106,107,108,109,
   688          0 (*lod*): begin  ad := base(p) + q;
   689                       sp := sp+1;
   690                       store[sp] := store[ad]
   691                     end;
   692 
   693          65,66,67,68,69,
   694          1 (*ldo*): begin
   695                       sp := sp+1;
   696                       store[sp] := store[q]
   697                     end;
   698 
   699          70,71,72,73,74,
   700          2 (*str*): begin  store[base(p)+q] := store[sp];
   701                       sp := sp-1
   702                     end;
   703 
   704          75,76,77,78,79,
   705          3 (*sro*): begin  store[q] := store[sp];
   706                       sp := sp-1
   707                     end;
   708 
   709          4 (*lda*): begin sp := sp+1;
   710                       store[sp].va := base(p) + q
   711                     end;
   712 
   713          5 (*lao*): begin sp := sp+1;
   714                       store[sp].va := q
   715                     end;
   716 
   717          80,81,82,83,84,
   718          6 (*sto*): begin
   719                       store[store[sp-1].va] := store[sp];
   720                       sp := sp-2;
   721                     end;
   722 
   723          7 (*ldc*): begin sp := sp+1;
   724                       if p=1 then
   725                       begin store[sp].vi := q;
   726                       end else
   727                       if p = 6 then store[sp].vc := chr(q)
   728                       else
   729                         if p = 3 then store[sp].vb := q = 1
   730                         else (* load nil *) store[sp].va := maxstr
   731                     end;
   732 
   733          8 (*lci*): begin sp := sp+1;
   734                       store[sp] := store[q]
   735                     end;
   736 
   737          85,86,87,88,89,
   738          9 (*ind*): begin ad := store[sp].va + q;
   739                       (* q is a number of storage units *)
   740                       store[sp] := store[ad]
   741                     end;
   742 
   743          90,91,92,93,94,
   744          10 (*inc*): store[sp].vi := store[sp].vi+q;
   745 
   746          11 (*mst*): begin (*p=level of calling procedure minus level of called
   747                              procedure + 1;  set dl and sl, increment sp*)
   748                        (* then length of this element is
   749                           max(intsize,realsize,boolsize,charsize,ptrsize *)
   750                        store[sp+2].vm := base(p);
   751                        (* the length of this element is ptrsize *)
   752                        store[sp+3].vm := mp;
   753                        (* idem *)
   754                        store[sp+4].vm := ep;
   755                        (* idem *)
   756                        sp := sp+5
   757                      end;
   758 
   759          12 (*cup*): begin (*p=no of locations for parameters, q=entry point*)
   760                        mp := sp-(p+4);
   761                        store[mp+4].vm := pc;
   762                        pc := q
   763                      end;
   764 
   765          13 (*ent*): if p = 1 then
   766                          begin sp := mp + q; (*q = length of dataseg*)
   767                            if sp > np then errori(' store overflow   ');
   768                          end
   769                        else
   770                          begin ep := sp+q;
   771                            if ep > np then errori(' store overflow   ');
   772                          end;
   773                          (*q = max space required on stack*)
   774 
   775          14 (*ret*): begin case p of
   776                                 0: sp:= mp-1;
   777                                 1,2,3,4,5: sp:= mp
   778                            end;
   779                            pc := store[mp+4].vm;
   780                            ep := store[mp+3].vm;
   781                            mp:= store[mp+2].vm;
   782                      end;
   783 
   784          15 (*csp*): callsp;
   785 
   786          16 (*ixa*): begin
   787                        i := store[sp].vi;
   788                        sp := sp-1;
   789                        store[sp].va := q*i+store[sp].va;
   790                      end;
   791 
   792          17 (*equ*): begin  sp := sp-1;
   793                        case p of
   794                             1: store[sp].vb := store[sp].vi = store[sp+1].vi;
   795                             0: store[sp].vb := store[sp].va = store[sp+1].va;
   796                             6: store[sp].vb := store[sp].vc = store[sp+1].vc;
   797                             2: store[sp].vb := store[sp].vr = store[sp+1].vr;
   798                             3: store[sp].vb := store[sp].vb = store[sp+1].vb;
   799                             4: store[sp].vb := store[sp].vs = store[sp+1].vs;
   800                             5: begin  compare;
   801                                  store[sp].vb := b;
   802                                end;
   803                        end; (*case p*)
   804                      end;
   805 
   806          18 (*neq*): begin  sp := sp-1;
   807                        case p of
   808                             0: store[sp].vb := store[sp].va <> store[sp+1].va;
   809                             1: store[sp].vb := store[sp].vi <> store[sp+1].vi;
   810                             6: store[sp].vb := store[sp].vc <> store[sp+1].vc;
   811                             2: store[sp].vb := store[sp].vr <> store[sp+1].vr;
   812                             3: store[sp].vb := store[sp].vb <> store[sp+1].vb;
   813                             4: store[sp].vb := store[sp].vs <> store[sp+1].vs;
   814                             5: begin  compare;
   815                                  store[sp].vb := not b;
   816                                end
   817                        end; (*case p*)
   818                      end;
   819 
   820          19 (*geq*): begin  sp := sp-1;
   821                        case p of
   822                             0: errori(' <,<=,>,>= for address   ');
   823                             1: store[sp].vb := store[sp].vi >= store[sp+1].vi;
   824                             6: store[sp].vb := store[sp].vc >= store[sp+1].vc;
   825                             2: store[sp].vb := store[sp].vr >= store[sp+1].vr;
   826                             3: store[sp].vb := store[sp].vb >= store[sp+1].vb;
   827                             4: store[sp].vb := store[sp].vs >= store[sp+1].vs;
   828                             5: begin compare;
   829                                  store[sp].vb := b or
   830                                    (store[i1+i].vi >= store[i2+i].vi)
   831                                end
   832                        end; (*case p*)
   833                      end;
   834 
   835          20 (*grt*): begin  sp := sp-1;
   836                        case p of
   837                             0: errori(' <,<=,>,>= for address   ');
   838                             1: store[sp].vb := store[sp].vi > store[sp+1].vi;
   839                             6: store[sp].vb := store[sp].vc > store[sp+1].vc;
   840                             2: store[sp].vb := store[sp].vr > store[sp+1].vr;
   841                             3: store[sp].vb := store[sp].vb > store[sp+1].vb;
   842                             4: errori(' set inclusion    ');
   843                             5: begin  compare;
   844                                  store[sp].vb := not b and
   845                                   (store[i1+i].vi > store[i2+i].vi)
   846                                end
   847                        end; (*case p*)
   848                      end;
   849 
   850          21 (*leq*): begin  sp := sp-1;
   851                        case p of
   852                             0: errori(' <,<=,>,>= for address   ');
   853                             1: store[sp].vb := store[sp].vi <= store[sp+1].vi;
   854                             6: store[sp].vb := store[sp].vc <= store[sp+1].vc;
   855                             2: store[sp].vb := store[sp].vr <= store[sp+1].vr;
   856                             3: store[sp].vb := store[sp].vb <= store[sp+1].vb;
   857                             4: store[sp].vb := store[sp].vs <= store[sp+1].vs;
   858                             5: begin  compare;
   859                                  store[sp].vb := b or
   860                                    (store[i1+i].vi <= store[i2+i].vi)
   861                                end;
   862                        end; (*case p*)
   863                      end;
   864 
   865          22 (*les*): begin  sp := sp-1;
   866                        case p of
   867                             0: errori(' <,<=,>,>= for address   ');
   868                             1: store[sp].vb := store[sp].vi < store[sp+1].vi;
   869                             6: store[sp].vb := store[sp].vc < store[sp+1].vc;
   870                             2: store[sp].vb := store[sp].vr < store[sp+1].vr;
   871                             3: store[sp].vb := store[sp].vb < store[sp+1].vb;
   872                             5: begin  compare;
   873                                  store[sp].vb := not b and
   874                                    (store[i1+i].vi < store[i2+i].vi)
   875                                end
   876                        end; (*case p*)
   877                      end;
   878 
   879          23 (*ujp*): pc := q;
   880 
   881          24 (*fjp*): begin  if not store[sp].vb then pc := q;
   882                        sp := sp-1
   883                      end;
   884 
   885          25 (*xjp*): begin
   886                        pc := store[sp].vi + q;
   887                        sp := sp-1
   888                      end;
   889 
   890          95 (*chka*): if (store[sp].va < np) or
   891                          (store[sp].va > (maxstr-q)) then
   892                         errori(' bad pointer value       ');
   893 
   894          96,97,98,99,
   895          26 (*chk*): if (store[sp].vi < store[q-1].vi) or
   896                         (store[sp].vi > store[q].vi) then
   897                         errori(' value out of range      ');
   898 
   899          27 (*eof*): begin  i := store[sp].vi;
   900                        if i=inputadr then
   901                        begin store[sp].vb := eof(input);
   902                        end else errori(' code in error    ')
   903                      end;
   904 
   905          28 (*adi*): begin  sp := sp-1;
   906                        store[sp].vi := store[sp].vi + store[sp+1].vi
   907                      end;
   908 
   909          29 (*adr*): begin  sp := sp-1;
   910                        store[sp].vr := store[sp].vr + store[sp+1].vr
   911                      end;
   912 
   913          30 (*sbi*): begin sp := sp-1;
   914                        store[sp].vi := store[sp].vi - store[sp+1].vi
   915                      end;
   916 
   917          31 (*sbr*): begin  sp := sp-1;
   918                        store[sp].vr := store[sp].vr - store[sp+1].vr
   919                      end;
   920 
   921          32 (*sgs*): store[sp].vs := [store[sp].vi];
   922 
   923          33 (*flt*): store[sp].vr := store[sp].vi;
   924 
   925          34 (*flo*): store[sp-1].vr := store[sp-1].vi;
   926 
   927          35 (*trc*): store[sp].vi := trunc(store[sp].vr);
   928 
   929          36 (*ngi*): store[sp].vi := -store[sp].vi;
   930 
   931          37 (*ngr*): store[sp].vr := -store[sp].vr;
   932 
   933          38 (*sqi*): store[sp].vi := sqr(store[sp].vi);
   934 
   935          39 (*sqr*): store[sp].vr := sqr(store[sp].vr);
   936 
   937          40 (*abi*): store[sp].vi := abs(store[sp].vi);
   938 
   939          41 (*abr*): store[sp].vr := abs(store[sp].vr);
   940 
   941          42 (*not*): store[sp].vb := not store[sp].vb;
   942 
   943          43 (*and*): begin  sp := sp-1;
   944                        store[sp].vb := store[sp].vb and store[sp+1].vb
   945                      end;
   946 
   947          44 (*ior*): begin  sp := sp-1;
   948                        store[sp].vb := store[sp].vb or store[sp+1].vb
   949                      end;
   950 
   951          45 (*dif*): begin  sp := sp-1;
   952                        store[sp].vs := store[sp].vs - store[sp+1].vs
   953                      end;
   954 
   955          46 (*int*): begin  sp := sp-1;
   956                        store[sp].vs := store[sp].vs * store[sp+1].vs
   957                      end;
   958 
   959          47 (*uni*): begin  sp := sp-1;
   960                        store[sp].vs := store[sp].vs + store[sp+1].vs
   961                      end;
   962 
   963          48 (*inn*): begin
   964                        sp := sp - 1; i := store[sp].vi;
   965                        store[sp].vb := i in store[sp+1].vs;
   966                      end;
   967 
   968          49 (*mod*): begin  sp := sp-1;
   969                        store[sp].vi := store[sp].vi mod store[sp+1].vi
   970                      end;
   971 
   972          50 (*odd*): store[sp].vb := odd(store[sp].vi);
   973 
   974          51 (*mpi*): begin  sp := sp-1;
   975                        store[sp].vi := store[sp].vi * store[sp+1].vi
   976                      end;
   977 
   978          52 (*mpr*): begin  sp := sp-1;
   979                        store[sp].vr := store[sp].vr * store[sp+1].vr
   980                      end;
   981 
   982          53 (*dvi*): begin  sp := sp-1;
   983                        store[sp].vi := store[sp].vi div store[sp+1].vi
   984                      end;
   985 
   986          54 (*dvr*): begin  sp := sp-1;
   987                        store[sp].vr := store[sp].vr / store[sp+1].vr
   988                      end;
   989 
   990          55 (*mov*): begin i1 := store[sp-1].va;
   991                        i2 := store[sp].va; sp := sp-2;
   992                        for i := 0 to q-1 do store[i1+i] := store[i2+i]
   993                        (* q is a number of storage units *)
   994                      end;
   995 
   996          56 (*lca*): begin  sp := sp+1;
   997                        store[sp].va := q;
   998                      end;
   999 
  1000          100,101,102,103,104,
  1001          57 (*dec*): store[sp].vi := store[sp].vi-q;
  1002 
  1003          58 (*stp*): interpreting := false;
  1004 
  1005          59 (*ord*): (*only used to change the tagfield*)
  1006                      begin
  1007                      end;
  1008 
  1009          60 (*chr*): begin
  1010                      end;
  1011 
  1012          61 (*ujc*): errori(' case - error     ');
  1013     end
  1014   end; (*while interpreting*)
  1015 
  1016 1 :
  1017 end.