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