home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / FACILIS2.ZIP / INTERPRT.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1980-01-01  |  34.9 KB  |  1,205 lines
  1. { Facilis 0.31                                    file: INTERPRT.PAS     }
  2. {$R-}
  3.  
  4. overlay procedure interpret;
  5.  
  6. var
  7.      b,b0: integer;   { base index }
  8.   h1,h2,h3,h4,h5,h6: integer;   { temporaries }
  9.      blkcnt, chrcnt: integer;   { counters }
  10.  jumpbase: integer;   { address of jump table }
  11.     sbuff: string[80];
  12.        ps: (run,fin,stkchk,caschk,divchk,inxchk,redchk,strchk,fnchk,syschk);
  13.  
  14.   fld    : array [1..4] of integer;     { default field widths }
  15.   s      : array [0..stacksize] of      { blockmark:               }
  16.        record
  17.          case cn:types of               {    s[b+0] = fct result   }
  18.          ints:  (  i: integer);         {    s[b+1] = return adr   }
  19.          reals: (  r: real);            {    s[b+2] = static link  }
  20.          bools: (  b: boolean);         {    s[b+3] = dynamic link }
  21.          chars: (  c: char);            {    s[b+4] = table index  }
  22.          strngs:(s,p: integer);         {    s[b+5] = string ptr   }
  23.        end;
  24.  
  25.   procedure dump;
  26.  
  27.   var    p,h3 :integer;
  28.  
  29.   begin
  30.     h3:=tab[h2].lev;
  31.     writeln(psout);writeln(psout);
  32.     writeln(psout,'        calling ',tab[h2].name);
  33.     writeln(psout,'          level ',h3:4);
  34.     writeln(psout,' start of  code ',pc:4);
  35.     writeln(psout);writeln(psout);
  36.     writeln(psout,' contents of display '); writeln(psout);
  37.  
  38.     for p:=h3+1 downto 1 do writeln(psout,p:4,display[p]:6);
  39.  
  40.     writeln(psout);writeln(psout);
  41.     writeln(psout,' top of stack   ',t:4,' frame base ':14,b:4);
  42.     writeln(psout);writeln(psout);
  43.     writeln(psout,'stack contents':20); writeln(psout);
  44.  
  45.     for  p:=t  downto  1  do writeln(psout,p:14,s[p].i:8);
  46.  
  47.     writeln(psout,'< = = = >':22)
  48.   end; {  dump  }
  49.  
  50.   function get(var s:integer; t:integer): boolean;
  51.  
  52.   var v:integer;
  53.  
  54.   begin
  55.     v := ((t+3) div 16 +1)*16;
  56.     if (v < 1) or (v shr 4 > maxavail)
  57.     then begin ps := strchk; get := false; end
  58.     else begin
  59.       get := true;
  60.       getmem(spnt,v); s := seg(spnt^);
  61.       memw[s:0] := t;
  62.       memw[s:2] := v-4;
  63.     end
  64.   end;
  65.  
  66.   procedure free(p:integer);
  67.  
  68.   begin
  69.     tpnt := ptr(p,0);
  70.     freemem(tpnt,memw[p:2]+4)
  71.   end;
  72.  
  73.   procedure link(j:integer);
  74.  
  75.   var i: integer;
  76.  
  77.   begin
  78.     b0 := b;
  79.     i := tab[s[b0+4].i].lev;
  80.     while j<b0 do begin
  81.       b0 := display[i]; i := i-1; end;
  82.     s[j].p := s[b0+5].i;
  83.     s[b0+5].i := j;
  84.     s[j].cn := strngs
  85.   end;
  86.  
  87. function scopy(lf,rt:integer): boolean;
  88.  
  89. var h1,h2,h3,h4: integer;
  90.  
  91. begin
  92.   scopy := true;
  93.   h1 := s[lf].s;
  94.   h2 := memw[h1:2];
  95.   h3 := s[rt].s;
  96.   h4 := memw[h3:0];
  97.   if (h1 = 0) or (h2 < h4) or (h2 >= h4+16)
  98.   then begin
  99.     if h1=0 then link(lf)
  100.             else if h2<>0 then free(h1);
  101.     if not get(h1,h4) then scopy := false;
  102.     s[lf].s := h1;
  103.   end else memw[h1:0] := h4;
  104.   if ps = run then move(mem[h3:4],mem[h1:4],h4)
  105. end;
  106.  
  107. label start,loop,windup,
  108.      0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,
  109.      27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,
  110.      51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,
  111.      75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,
  112.      99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,
  113.      117,118,119,120,121,122,123,124,125,126,127,128,129,130,131,132,133,134,
  114.      135,136,137,138,139,140,141,142,143,144,145,146,147,148,149,150,151,152,
  115.      153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,
  116.      171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,
  117.      189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,
  118.      207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,
  119.      225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,
  120.      243,244,245,246,247,248,249,250,251,252,253,254,255;
  121.  
  122. begin { interpret }
  123.   inline(              { find base address of jump table }
  124.     $b8/*+12/          { MOV AX,*+12     }
  125.     $89/$86/jumpbase ); { MOV [BP]jumpbase,AX }
  126.   goto start;
  127.   goto windup;
  128. { each of these GOTOs compiles to a JMP to one of the interpreter routines }
  129.   goto   0;goto   1;goto   2;goto   3;goto   4;goto   5;goto   6;goto   7;
  130.   goto   8;goto   9;goto  10;goto  11;goto  12;goto  13;goto  14;goto  15;
  131.   goto  16;goto  17;goto  18;goto  19;goto  20;goto  21;goto  22;goto  23;
  132.   goto  24;goto  25;goto  26;goto  27;goto  28;goto  29;goto  30;goto  31;
  133.   goto  32;goto  33;goto  34;goto  35;goto  36;goto  37;goto  38;goto  39;
  134.   goto  40;goto  41;goto  42;goto  43;goto  44;goto  45;goto  46;goto  47;
  135.   goto  48;goto  49;goto  50;goto  51;goto  52;goto  53;goto  54;goto  55;
  136.   goto  56;goto  57;goto  58;goto  59;goto  60;goto  61;goto  62;goto  63;
  137.   goto  64;goto  65;goto  66;goto  67;goto  68;goto  69;goto  70;goto  71;
  138.   goto  72;goto  73;goto  74;goto  75;goto  76;goto  77;goto  78;goto  79;
  139.   goto  80;goto  81;goto  82;goto  83;goto  84;goto  85;goto  86;goto  87;
  140.   goto  88;goto  89;goto  90;goto  91;goto  92;goto  93;goto  94;goto  95;
  141.   goto  96;goto  97;goto  98;goto  99;goto 100;goto 101;goto 102;goto 103;
  142.   goto 104;goto 105;goto 106;goto 107;goto 108;goto 109;goto 110;goto 111;
  143.   goto 112;goto 113;goto 114;goto 115;goto 116;goto 117;goto 118;goto 119;
  144.   goto 120;goto 121;goto 122;goto 123;goto 124;goto 125;goto 126;goto 127;
  145.   goto 128;goto 129;goto 130;goto 131;goto 132;goto 133;goto 134;goto 135;
  146.   goto 136;goto 137;goto 138;goto 139;goto 140;goto 141;goto 142;goto 143;
  147.   goto 144;goto 145;goto 146;goto 147;goto 148;goto 149;goto 150;goto 151;
  148.   goto 152;goto 153;goto 154;goto 155;goto 156;goto 157;goto 158;goto 159;
  149.   goto 160;goto 161;goto 162;goto 163;goto 164;goto 165;goto 166;goto 167;
  150.   goto 168;goto 169;goto 170;goto 171;goto 172;goto 173;goto 174;goto 175;
  151.   goto 176;goto 177;goto 178;goto 179;goto 180;goto 181;goto 182;goto 183;
  152.   goto 184;goto 185;goto 186;goto 187;goto 188;goto 189;goto 190;goto 191;
  153.   goto 192;goto 193;goto 194;goto 195;goto 196;goto 197;goto 198;goto 199;
  154.   goto 200;goto 201;goto 202;goto 203;goto 204;goto 205;goto 206;goto 207;
  155.   goto 208;goto 209;goto 210;goto 211;goto 212;goto 213;goto 214;goto 215;
  156.   goto 216;goto 217;goto 218;goto 219;goto 220;goto 221;goto 222;goto 223;
  157.   goto 224;goto 225;goto 226;goto 227;goto 228;goto 229;goto 230;goto 231;
  158.   goto 232;goto 233;goto 234;goto 235;goto 236;goto 237;goto 238;goto 239;
  159.   goto 240;goto 241;goto 242;goto 243;goto 244;goto 245;goto 246;goto 247;
  160.   goto 248;goto 249;goto 250;goto 251;goto 252;goto 253;goto 254;goto 255;
  161.  
  162. start:
  163.       s[1].i := 0;    s[2].i := 0;
  164.       s[3].i := -1;   s[4].i := btab[1].last;
  165.   display[1] := 0;         t := btab[2].vsize - 1;
  166.            b := 0;        pc := tab[s[4].i].adr;
  167.       chrcnt := 0;        ps := run;
  168.  
  169.       fld[1] := 8;    fld[2] := 20;
  170.       fld[3] := 8;    fld[4] := 1;
  171.  
  172.   if t > stacksize
  173.   then begin
  174.     ps := stkchk; goto windup; end;
  175.   fillchar(s[5],(t-4)*sizeof(s[1]),0);
  176.  
  177. loop:            { here starts the main loop of the interpreter }
  178. Inline(
  179.    $8B/$3E/pc              { MOV DI,pc       ;get program counter }
  180.   /$FF/$06/pc              { INC (W)pc }
  181.   /$D1/$E7                 { SHL DI,=1       ;*4 (bytes per p-code) }
  182.   /$D1/$E7                 { SHL DI,=1       ;index into code array }
  183.   /$81/$C7/code            { ADD DI,=code    ;leave ptr to p-code in DI }
  184.   /$8B/$45/2               { MOV AX,[DI]2    ;get y operand }
  185.   /$A3/y                   { MOV y,AX }
  186.   /$8A/$1D                 { MOV BL,[DI]     ;get opcode }
  187.   /$88/$1E/opcode          { MOV opcode,BL }
  188.   /$32/$FF                 { XOR BH,BH       ;leave opcode in BX }
  189.   /$8B/$F3                 { MOV SI,BX       ;*3 (bytes per JMP) }
  190.   /$03/$F3                 { ADD SI,BX }
  191.   /$03/$F3                 { ADD SI,BX }
  192.   /$03/$B6/jumpbase        { ADD SI,[BP]jumpbase ;index into jump table }
  193.   /$FF/$E6                 { JMP SI          ;jump through table }
  194.   );
  195.  
  196.  
  197.     0: { load address }
  198.       inline(
  199.         $8A/$45/1                  { MOV AL,[DI]1    ;get x operand }
  200.        /$A2/x );                   { MOV x,AL }
  201.       t := t+1;
  202.       if t > stacksize
  203.       then begin
  204.         ps := stkchk; goto windup; end
  205.       else s[t].i := display[x] + y;
  206.       goto loop;
  207.  
  208.     1: { load value }
  209.       inline(
  210.         $8A/$45/1                  { MOV AL,[DI]1    ;get x operand }
  211.        /$A2/x );                   { MOV x,AL }
  212.       t := t+1;
  213.       if t > stacksize
  214.       then begin
  215.         ps := stkchk; goto windup; end
  216.       else s[t] := s[display[x] + y];
  217.       goto loop;
  218.  
  219.     2: { load indirect }
  220.       inline(
  221.         $8A/$45/1                  { MOV AL,[DI]1    ;get x operand }
  222.        /$A2/x );                   { MOV x,AL }
  223.       t := t+1;
  224.       if t > stacksize
  225.       then begin
  226.         ps := stkchk; goto windup; end
  227.         else s[t] := s[s[display[x] + y].i];
  228.       goto loop;
  229.  
  230.     3: { update display }
  231.       inline(
  232.         $8A/$45/1                  { MOV AL,[DI]1    ;get x operand }
  233.        /$A2/x );                   { MOV x,AL }
  234.       h1 := y; h2 := x; h3 := b;
  235.       repeat
  236.         display[h1] := h3; h1 := h1-1; h3 := s[h3+2].i
  237.       until h1 = h2;
  238.       goto loop;
  239.  
  240.     4:5:6: ps := syschk; goto windup;
  241.  
  242.     7: case y and 3 of    { concatenation }
  243.       0: begin   {char+char}
  244.            if not get(h1,2) then goto windup;
  245.            mem[h1:4] := s[t-1].i;
  246.            mem[h1:5] := s[t].i;
  247.            t := t-1;
  248.            s[t].i := h1;
  249.          end;
  250.       1: begin   {string+char}
  251.            h1 := s[t-1].i;
  252.            h2 := memw[h1:0];
  253.            if not get(h3,h2+1) then goto windup;
  254.            move(mem[h1:4],mem[h3:4],h2);
  255.            if (y and 4) = 4 then free(h1);
  256.            mem[h3:h2+4] := s[t].i;
  257.            t := t-1;
  258.            s[t].i := h3;
  259.          end;
  260.       2: begin   {char+string}
  261.            h1 := s[t].i;
  262.            h2 := memw[h1:0];
  263.            if not get(h4,h2+1) then goto windup;
  264.            move(mem[h1:4],mem[h4:5],h2);
  265.            mem[h4:4] := s[t-1].i;
  266.            if (y and 8) = 8 then free(h1);
  267.            t := t-1;
  268.            s[t].i := h4;
  269.          end;
  270.       3: begin   {string+string}
  271.            h5 := s[t-1].i;
  272.            h6 := s[t].i;
  273.            h3 := memw[h5:0];
  274.            h4 := memw[h6:0];
  275.            if not get(h2,h3+h4) then goto windup;
  276.            move(mem[h5:4],mem[h2:4],h3);
  277.            move(mem[h6:4],mem[h2:h3+4],h4);
  278.            if (y and 4) = 4 then free(h5);
  279.            if (y and 8) = 8 then free(h6);
  280.            t := t-1;
  281.            s[t].i := h2;
  282.          end;
  283.        end;
  284.        goto loop;
  285.  
  286.     8: if y < 10 then
  287.        case y of
  288.       0: s[t].i := abs(s[t].i);
  289.       1: s[t].r := abs(s[t].r);
  290.       2: s[t].i := sqr(s[t].i);
  291.       3: s[t].r := sqr(s[t].r);
  292.       4: s[t].b := odd(s[t].i);
  293.       5: s[t].c := chr(s[t].i);
  294.       6: s[t].i := ord(s[t].c);
  295.       7: s[t].c := succ(s[t].c);
  296.       8: s[t].c := pred(s[t].c);
  297.       9: s[t].i := round(s[t].r);
  298.        end
  299.  
  300.        else if y < 20 then
  301.        case y of
  302.      10: s[t].i := trunc(s[t].r);
  303.      11: s[t].r := sin(s[t].r);
  304.      12: s[t].r := cos(s[t].r);
  305.      13: s[t].r := exp(s[t].r);
  306.      14: if s[t].r <= 0
  307.          then begin
  308.            ps := fnchk; goto windup; end
  309.          else s[t].r := ln(s[t].r);
  310.      15: if s[t].r < 0
  311.          then begin
  312.            ps := fnchk; goto windup; end
  313.          else s[t].r := sqrt(s[t].r);
  314.      16: s[t].r := arctan(s[t].r);
  315.      17: begin
  316.            t := t+1;
  317.            if t > stacksize
  318.            then begin
  319.              ps := stkchk; goto windup; end
  320.            else s[t].b := eof(prd)
  321.          end;
  322.      18: begin
  323.            t := t+1;
  324.            if t > stacksize
  325.            then begin
  326.              ps := stkchk; goto windup; end
  327.            else s[t].b := eoln(prd)
  328.          end;
  329.      19: begin
  330.            t := t+1;
  331.            if t > stacksize
  332.            then begin
  333.              ps := stkchk; goto windup; end
  334.            else s[t].i := maxavail
  335.          end;
  336.  
  337.        end
  338.        else if y < 33 then
  339.        case y of
  340.  
  341.      20: s[t].i := memw[s[t].i:0];
  342.      21: begin
  343.            h1 := s[t].i;
  344.            s[t].i := memw[h1:0];
  345.            spnt := ptr(h1,0); freemem(spnt,memw[h1:2]+4)
  346.          end;
  347.      22: s[t].i := 1;
  348.      23: begin
  349.            h1 := s[t-2].i;
  350.            h4 := memw[h1:0];
  351.            h2 := s[t-1].i;
  352.            if (h2 < 1) or (h2 > h4)
  353.            then begin h4 := 0; h2 := 2; end;
  354.            h3 := s[t].i;
  355.            if h3 > h4-h2+1 then h3 := h4-h2+1;
  356.            if h3 < 0 then h3 := 0;
  357.            if not get(h5,h3) then goto windup;
  358.            move(mem[h1:h2+3],mem[h5:4],h3);
  359.            s[t-2].i := h5;
  360.            t := t-2;
  361.          end;
  362.      24: begin
  363.            h1 := s[t-2].i;
  364.            h4 := memw[h1:0];
  365.            h2 := s[t-1].i;
  366.            if (h2 < 1) or (h2 > h4)
  367.            then memw[h1:0] := 0
  368.            else begin
  369.              h3 := s[t].i;
  370.              if h3 > h4-h2+1 then h3 := h4-h2+1;
  371.              if h3 < 0 then h3 := 0;
  372.              move(mem[h1:h2+3],mem[h1:4],h3);
  373.              memw[h1:0] := h3;
  374.            end;
  375.            t := t-2;
  376.          end;
  377.  
  378.      25: begin
  379.            if not get(h1,1) then goto windup;
  380.            if (s[t-1].i = 1) and (s[t].i > 0)
  381.            then mem[h1:4] := s[t-2].i
  382.            else memw[h1:0] := 0;
  383.            s[t-2].i := h1;
  384.            t := t-2;
  385.          end;
  386.  
  387.  26,27,30,31:
  388.          begin
  389.            h1 := s[t-1].i;
  390.            h2 := s[t].i;   t := t-1;
  391.            h6 := memw[h1:0]+4;
  392.            h3 := memw[h2:0]+5-h6;
  393.            if (h3<=0) or (h6=4)
  394.            then s[t].i := 0
  395.            else begin
  396.              h4 := 0;
  397.              while h4<h3 do begin
  398.                h5 := 4;
  399.                while (h5<h6) and (mem[h1:h5]=mem[h2:h4+h5]) do h5 := h5+1;
  400.                if h5=h6 then h3:=h4-1 else h4 := h4+1;
  401.              end;
  402.              if h3=h4 then s[t].i := 0 else s[t].i := h4+1;
  403.            end;
  404.            if odd(y) then free(h1);
  405.            if y > 29 then free(h2);
  406.          end;
  407.  
  408.   28,32: begin
  409.            h1 := s[t-1].i;
  410.            h2 := s[t].i;
  411.            h3 := memw[h2:0]+4;
  412.            h4 := 4;
  413.            while (h4<h3) and (mem[h2:h4]<>h1) do h4 := h4+1;
  414.            if y=32 then free(h3);
  415.            t := t-1;
  416.            if h4<h3 then s[t].i := h4-3 else s[t].i := 0;
  417.          end;
  418.  
  419.        end
  420.        else if y < 40 then
  421.        case y of
  422.  
  423.   33,34: begin
  424.            if y=34 then str(s[t].r:18,sbuff)
  425.                       else str(s[t].i:1,sbuff);
  426.            h2 := length(sbuff);
  427.            if not get(h1,h2) then goto windup;
  428.            move(sbuff[1],mem[h1:4],h2);
  429.            s[t].i := h1
  430.          end;
  431.  
  432. 35,36,37,38:
  433.          begin
  434.            h1 := s[t].i;
  435.            h2 := memw[h1:0]; sbuff := '';
  436.            move(mem[h1:4],sbuff[1],h2);
  437.            sbuff[0] := chr(h2);
  438.            if y < 37 then val(sbuff,s[t].i,h5)
  439.                         else val(sbuff,s[t].r,h5);
  440.            if not odd(y) then free(h1)
  441.          end;
  442.  
  443.      39: begin
  444.            t := t+1;
  445.            if t > stacksize
  446.            then begin
  447.              ps := stkchk; goto windup; end
  448.            else s[t].b := keypressed
  449.          end;
  450.  
  451.        end
  452.        else if y < 50
  453.        then case y of
  454.  
  455.      40: begin
  456.            h1 := s[t].i;
  457.            if h1 < 1
  458.            then begin
  459.              ps := fnchk; goto windup; end
  460.            else s[t].i := random(h1);
  461.          end;
  462.  
  463.      41: begin
  464.            t := t+1;
  465.            if t > stacksize
  466.            then begin
  467.              ps := stkchk; goto windup; end
  468.            else s[t].r := random
  469.          end;
  470.  
  471.      42: s[t].c := upcase(s[t].c);
  472.      43: randomize;
  473.      44: clrscr;
  474.  
  475.      45: begin
  476.            h1 := s[t-1].i;
  477.            h2 := s[t].i;
  478.            if (h1<1) or (h1>80) or (h2<1) or (h2>25)
  479.            then begin
  480.              ps := fnchk; goto windup; end
  481.            else begin
  482.              gotoxy(h1,h2);
  483.              chrcnt := h1;
  484.              t := t-2;
  485.            end;
  486.          end;
  487.  
  488.      46: begin
  489.            textcolor(s[t].i);
  490.            t := t-1;
  491.          end;
  492.  
  493.      47: begin
  494.            t := t+1;
  495.            if t > stacksize
  496.            then begin
  497.              ps := stkchk; goto windup; end
  498.            else begin
  499.              Inline(
  500.  $B2/$FF                    { MOV DL,=$FF }
  501. /$B4/$06                    { MOV AH,=6   ;DOS function 6 }
  502. /$CD/$21                    { INT $21                    }
  503. /$74/$0C                    { JZ notready               }
  504. /$A8/$FF                    { TEST AL,=$FF             }
  505. /$74/$10                    { JZ extend               }
  506. /$C7/$86/h1/$01/$00         { MOV (W)[BP]h1,=1 ;got a char }
  507. /$EB/$10                    { JMP (S)end                  }
  508.                             { notready:                  }
  509. /$C7/$86/h1/$00/$00         { MOV (W)[BP]h1,=0 ;no char }
  510. /$EB/$08                    { JMP (S)end               }
  511.                             { extend:          ;extended code }
  512. /$CD/$21                    { INT $21          ;get another   }
  513. /$C7/$86/h1/$02/$00         { MOV (W)[BP]h1,=2               }
  514.                             { end:           ;return length in h1 }
  515. /$32/$E4                    { XOR AH,AH      ;    char code in h2 }
  516. /$89/$86/h2  );             { MOV [BP]h2,AX                      }
  517.              if not get(h3,h1) then goto windup;
  518.              if h1=1 then mem[h3:4] := h2 else mem[h3:4] := 0;
  519.              mem[h3:5] := h2;
  520.              s[t].i := h3
  521.            end
  522.          end;
  523.  
  524.      48: begin
  525.            t := t+1;
  526.            s[t].i := wherex;
  527.          end;
  528.  
  529.      49: begin
  530.            t := t+1;
  531.            s[t].i := wherey;
  532.          end;
  533.  
  534.        end
  535.        else if y < 60
  536.        then case y of
  537.  
  538.      50: begin
  539.            delay(s[t].i);
  540.            t := t-1;
  541.          end;
  542.  
  543.      51: begin
  544.            textbackground(s[t].i);
  545.            t := t-1;
  546.          end;
  547.  
  548.      52: begin
  549.            sound(s[t].i);
  550.            t := t-1;
  551.          end;
  552.  
  553.      53: nosound;
  554.  
  555.        end
  556.        else begin
  557.               ps := syschk; goto windup;
  558.             end;
  559.  
  560.        goto loop;  { end of functions }
  561.  
  562.     9: s[t].i := s[t].i + y;   { offset }
  563.        goto loop;
  564.  
  565.    10: pc := y;  { jump }
  566.        goto loop;
  567.  
  568.    11: { conditional jump }
  569.          if not s[t].b then pc := y;
  570.          t := t-1;
  571.        goto loop;
  572.  
  573.    12: { switch }
  574.          h1 := s[t].i;      t := t-1;
  575.          h2 := y;       h3 := 0;
  576.          repeat
  577.            if code[h2].f <> 13
  578.            then begin
  579.              ps := caschk; goto windup; end
  580.            else if code[h2].y = h1
  581.                     then begin
  582.                       h3 := 1;
  583.                       pc := code[h2+1].y
  584.                     end else h2 := h2 + 2
  585.          until h3 <> 0;
  586.        goto loop;
  587.  
  588.    13: ps := syschk; goto windup;  {case marker}
  589.  
  590.    14: { for1up }
  591.          h1 := s[t-1].i;
  592.          if h1 <= s[t].i
  593.          then s[s[t-2].i].i := h1
  594.          else begin
  595.            t := t-3;
  596.            pc := y
  597.          end;
  598.        goto loop;
  599.  
  600.    15: { for2up }
  601.          h2 := s[t-2].i;
  602.          h1 := s[h2].i +1;
  603.          if h1 <= s[t].i
  604.          then begin
  605.            s[h2].i := h1; pc := y
  606.          end else t := t-3;
  607.        goto loop;
  608.  
  609.    16: { for1down }
  610.          h1 := s[t-1].i;
  611.          if h1 >= s[t].i
  612.          then s[s[t-2].i].i := h1
  613.          else begin
  614.            pc := y; t := t-3
  615.          end;
  616.        goto loop;
  617.  
  618.    17: { for2down }
  619.          h2 := s[t-2].i;
  620.          h1 := s[h2].i - 1;
  621.          if h1 >= s[t].i
  622.          then begin
  623.            s[h2].i := h1; pc := y
  624.          end else t := t-3;
  625.        goto loop;
  626.  
  627.    18: { mark stack }
  628.          h1 := btab[tab[y].ref].vsize;
  629.          if t+h1 > stacksize
  630.          then begin
  631.            ps := stkchk; goto windup; end
  632.          else begin
  633.            t := t+6;  b0 := t;  s[b0].i := 0;
  634.            s[t-2].i := h1-1;    s[t-1].i := y
  635.          end;
  636.        goto loop;
  637.  
  638.    19: { call }
  639.          h1 := t - y;             { h1 points to base }
  640.          h2 := s[h1+4].i;            { h2 points to tab }
  641.          h3 := tab[h2].lev;    display[h3+1] := h1;
  642.          h4 := s[h1+3].i + h1;
  643.          s[h1+1].i := pc;      s[h1+2].i := display[h3];
  644.          s[h1+3].i := b;
  645.          fillchar(s[t+1],(h4-t)*sizeof(s[1]),0);
  646.          b := h1;    t := h4;
  647.          pc := tab[h2].adr;
  648.          if stackdump then dump;
  649.        goto loop;
  650.  
  651.    20: { index1 }
  652.          h1 := y;      { h1 points to atab }
  653.          h2 := atab[h1].low;
  654.          h3 := s[t].i;
  655.          if h3 < h2
  656.          then begin
  657.            ps := inxchk; goto windup; end
  658.          else if h3 > atab[h1].high
  659.               then begin
  660.                 ps := inxchk; goto windup; end
  661.               else begin
  662.                 t := t-1;
  663.                 s[t].i := s[t].i + (h3-h2)
  664.               end;
  665.        goto loop;
  666.  
  667.    21: { index }
  668.          h1 := y;      { h1 points to atab }
  669.          h2 := atab[h1].low;
  670.          h3 := s[t].i;
  671.          if h3 < h2
  672.          then begin
  673.            ps := inxchk; goto windup; end
  674.          else if h3 > atab[h1].high
  675.               then begin
  676.                 ps := inxchk; goto windup; end
  677.               else begin
  678.                 t := t-1;
  679.                 s[t].i := s[t].i + (h3-h2)*atab[h1].elsize
  680.               end;
  681.        goto loop;
  682.  
  683.    22: { load block }
  684.          h1 := s[t].i;     t := t-1;
  685.          h2 := y + t;
  686.          if h2 > stacksize
  687.          then begin
  688.            ps := stkchk; goto windup; end
  689.          else while t < h2 do
  690.            begin
  691.              t := t+1;
  692.              if s[h1].cn = strngs
  693.              then begin
  694.                s[t].s := 0;
  695.                if not scopy(t,h1) then goto windup; end
  696.              else s[t] := s[h1];
  697.              h1 := h1+1
  698.            end;
  699.        goto loop;
  700.  
  701.    23: { copy block }
  702.          h1 := s[t-1].i;
  703.          h2 := s[t].i;
  704.          h3 := h1 + y;
  705.          while h1 < h3 do
  706.          begin
  707.            if s[h2].cn = strngs
  708.            then begin
  709.              s[h1].s := 0;
  710.              if not scopy(h1,h2) then goto windup; end
  711.            else s[h1] := s[h2];
  712.            h1 := h1+1;    h2 := h2+1
  713.          end;
  714.          t := t-2;
  715.        goto loop;
  716.  
  717.    24: { literal }
  718.          t := t+1;
  719.          if t > stacksize
  720.          then begin
  721.            ps := stkchk; goto windup; end
  722.          else s[t].i := y;
  723.        goto loop;
  724.  
  725.    25: { load real }
  726.          t := t+1;
  727.          if t > stacksize
  728.          then begin
  729.            ps := stkchk; goto windup; end
  730.          else s[t].r := rconst[y];
  731.        goto loop;
  732.  
  733.    26: { float }
  734.          h1 := t - y;
  735.          s[h1].r := s[h1].i;
  736.        goto loop;
  737.  
  738.    27: { read }
  739.          case y of
  740.         1: read(prd,s[s[t].i].i);
  741.         2: read(prd,s[s[t].i].r);
  742.         4: read(prd,s[s[t].i].c);
  743.         5: begin
  744.              read(prd,sbuff);
  745.              h1 := length(sbuff);
  746.              if h1=0
  747.              then h3 := nul
  748.              else begin
  749.                if not get(h3,h1) then goto windup;
  750.                move(sbuff[1],mem[h3:4],h1);
  751.              end;
  752.              h4 := s[t].i; h5 := s[h4].i;
  753.              if h5 = 0 then link(h4)
  754.                        else if memw[h5:2] <> 0 then free(h5);
  755.              s[h4].i := h3;
  756.            end
  757.          end ;
  758.  
  759.          t := t-1;
  760.        goto loop;
  761.  
  762.    28: ps := syschk; goto windup;
  763.  
  764.    29: { write1 }
  765.          chrcnt := chrcnt + fld[y];
  766.          if chrcnt > lineleng
  767.          then begin
  768.            writeln(prr); chrcnt := 0; end;
  769.          case y of
  770.              1: write(prr,s[t].i: fld[1]);
  771.              2: write(prr,s[t].r: fld[2]);
  772.              3: if s[t].b then write ('true':fld[3])
  773.                           else write ('false':fld[3]);
  774.              4: write(prr,chr(s[t].i));
  775.          end ;
  776.          if chrcnt = lineleng then chrcnt := 0;
  777.          t := t-1;
  778.        goto loop;
  779.  
  780.    30: { write2 }
  781.          chrcnt := chrcnt + s[t].i;
  782.          if chrcnt > lineleng
  783.          then begin
  784.            writeln(prr); chrcnt := 0; end;
  785.          case y of
  786.              1: write(prr,s[t-1].i: s[t].i);
  787.              2: write(prr,s[t-1].r: s[t].i);
  788.              3: if s[t-1].b then write ('true') else write ('false');
  789.              4: write(prr,chr(s[t-1].i): s[t].i);
  790.          end ;
  791.          if chrcnt = lineleng then chrcnt := 0;
  792.          t := t-2;
  793.        goto loop;
  794.  
  795.    31: { chars := strngs }
  796.          h1 := s[t].i;
  797.          if memw[h1:0] <> 1
  798.          then begin
  799.            ps := strchk; goto windup; end
  800.          else begin
  801.            s[s[t-1].i].i := mem[h1:4];
  802.            if (y and 8) = 8 then free(h1)
  803.          end;
  804.          t := t-2;
  805.        goto loop;
  806.  
  807.    32: { string relations }
  808.          h2 := s[t-1].i;
  809.          h3 := s[t].i;
  810.          case y and 3 of
  811.         1: begin  {strngs~chars}
  812.              h4 := memw[h2:0];
  813.              if h4=0 then h5 := 64
  814.              else if h3>mem[h2:4] then h5 := 64
  815.              else if h3<mem[h2:4] then h5 := 32
  816.              else if h4=1 then h5 := 16
  817.              else h5 := 32;
  818.            end;
  819.         2: begin  {chars~strngs}
  820.              h4 := memw[h3:0];
  821.              if h4=0 then h5 := 32
  822.              else if h2>mem[h3:4] then h5 := 32
  823.              else if h2<mem[h3:4] then h5 := 64
  824.              else if h4=1 then h5 := 16
  825.              else h5 := 64;
  826.            end;
  827.         3: begin  {strngs~strngs}
  828.              h4 := memw[h2:0]; h1 :=0;
  829.              h5 := memw[h3:0];
  830.              if h5<h4 then h4 := h5 else h5 := h4;
  831.              while h1<h4 do begin
  832.                if mem[h2:4+h1] <> mem[h3:4+h1]
  833.                then h4 := h1
  834.                else h1 := h1+1;
  835.              end;
  836.              if h4=h5
  837.              then if memw[h2:0]=memw[h3:0]
  838.                   then h5 := 16
  839.                   else if memw[h2:0]<memw[h3:0]
  840.                        then h5 := 64 else h5 := 32
  841.              else if mem[h2:4+h1]<mem[h3:4+h1]
  842.                   then h5 := 64 else h5 := 32;
  843.            end;
  844.          end;
  845.          if (y and 5) = 5 then free(h2);
  846.          if (y and 10) = 10 then free(h3);
  847.          t := t-1;
  848.          s[t].b := (y and h5) > 0;
  849.        goto loop;
  850.  
  851.   33:34:35:36:37:38:39:40:41:42:43:44:45:46:47:48:49:50:51:52:53:54:55:56:57:
  852.   58:59:60:61:62:63:64:65:66:67:68:69:70:71:72:73:74:75:76:77:78:79:80:81:82:
  853.   83:84:85:86:87:88:89:90:91:92:93:94:95:96:97:98:99:100:101:102:103:104:105:
  854.   106:107:108:109:110:111:112:113:114:115:116:117:118:119:120:121:122:123:124:
  855.   125:126:127:128:129:130: ps := syschk; goto windup;
  856.  
  857.   131: ps := fin;
  858.        goto windup;
  859.  
  860.   132: { exit procedure }
  861.          h1 := s[b+5].i;
  862.          while h1 <> 0 do begin
  863.            free(s[h1].i);
  864.            h1 := s[h1].p; end;
  865.          t := b-1;
  866.          pc := s[b+1].i;  b := s[b+3].i;
  867.        goto loop;
  868.  
  869.   133: { exit function }
  870.          h1 := s[b+5].i;
  871.          while h1 <> 0 do begin
  872.            free(s[h1].i);
  873.            h1 := s[h1].p; end;
  874.          t := b;
  875.          pc := s[b+1].i;  b := s[b+3].i;
  876.        goto loop;
  877.  
  878.   134: s[t] := s[s[t].i]; goto loop;
  879.  
  880.   135: s[t].b := not s[t].b; goto loop;
  881.  
  882.   136: s[t].i := - s[t].i; goto loop;
  883.  
  884.   137:
  885.          chrcnt := chrcnt + s[t-1].i;
  886.          if chrcnt > lineleng
  887.          then begin
  888.            writeln(prr); chrcnt := 0; end
  889.          else write(prr,s[t-2].r: s[t-1].i: s[t].i);
  890.          if chrcnt = lineleng then chrcnt := 0;
  891.          t := t-3;
  892.        goto loop;
  893.  
  894.   138: { store }
  895.          s[s[t-1].i] := s[t];
  896.          t := t-2;
  897.        goto loop;
  898.  
  899.   139:
  900.          t := t-1;
  901.          s[t].b := s[t].r = s[t+1].r;
  902.        goto loop;
  903.  
  904.   140:
  905.          t := t-1;
  906.          s[t].b := s[t].r <> s[t+1].r;
  907.        goto loop;
  908.  
  909.   141:
  910.          t := t-1;
  911.          s[t].b := s[t].r < s[t+1].r;
  912.        goto loop;
  913.  
  914.   142:
  915.          t := t-1;
  916.          s[t].b := s[t].r <= s[t+1].r;
  917.        goto loop;
  918.  
  919.   143:
  920.          t := t-1;
  921.          s[t].b := s[t].r > s[t+1].r;
  922.        goto loop;
  923.  
  924.   144:
  925.          t := t-1;
  926.          s[t].b := s[t].r >= s[t+1].r;
  927.        goto loop;
  928.  
  929.   145:
  930.          t := t-1;
  931.          s[t].b := s[t].i = s[t+1].i;
  932.        goto loop;
  933.  
  934.   146:
  935.          t := t-1;
  936.          s[t].b := s[t].i <> s[t+1].i;
  937.        goto loop;
  938.  
  939.   147:
  940.          t := t-1;
  941.          s[t].b := s[t].i < s[t+1].i;
  942.        goto loop;
  943.  
  944.   148:
  945.          t := t-1;
  946.          s[t].b := s[t].i <= s[t+1].i;
  947.        goto loop;
  948.  
  949.   149:
  950.          t := t-1;
  951.          s[t].b := s[t].i > s[t+1].i;
  952.        goto loop;
  953.  
  954.   150:
  955.          t := t-1;
  956.          s[t].b := s[t].i >= s[t+1].i;
  957.        goto loop;
  958.  
  959.   151:
  960.          t := t-1;
  961.          s[t].b := s[t].b or s[t+1].b;
  962.        goto loop;
  963.  
  964.   152:
  965.          t := t-1;
  966.          s[t].i := s[t].i + s[t+1].i;
  967.        goto loop;
  968.  
  969.   153:
  970.          t := t-1;
  971.          s[t].i := s[t].i - s[t+1].i;
  972.        goto loop;
  973.  
  974.   154:
  975.          t := t-1;
  976.          s[t].r := s[t].r + s[t+1].r;
  977.        goto loop;
  978.  
  979.   155:
  980.          t := t-1;
  981.          s[t].r := s[t].r - s[t+1].r;
  982.        goto loop;
  983.  
  984.   156:
  985.          t := t-1;
  986.          s[t].b := s[t].b and s[t+1].b;
  987.        goto loop;
  988.  
  989.   157:
  990.          t := t-1;
  991.          s[t].i := s[t].i * s[t+1].i;
  992.        goto loop;
  993.  
  994.   158:
  995.          t := t-1;
  996.          if s[t+1].i = 0
  997.          then begin
  998.            ps := divchk; goto windup; end
  999.          else s[t].i := s[t].i div s[t+1].i;
  1000.        goto loop;
  1001.  
  1002.   159:
  1003.          t := t-1;
  1004.          if s[t+1].i = 0
  1005.          then begin
  1006.            ps := divchk; goto windup; end
  1007.          else s[t].i := s[t].i mod s[t+1].i;
  1008.        goto loop;
  1009.  
  1010.   160:
  1011.          t := t-1;
  1012.          s[t].r := s[t].r * s[t+1].r;
  1013.        goto loop;
  1014.  
  1015.   161:
  1016.          t := t-1;
  1017.          s[t].r := s[t].r / s[t+1].r;
  1018.        goto loop;
  1019.  
  1020.   162: if eof(prd)
  1021.        then begin
  1022.               ps := redchk; goto windup; end
  1023.        else readln;
  1024.        goto loop;
  1025.  
  1026.   163:
  1027.          writeln(prr);
  1028.          chrcnt := 0;
  1029.        goto loop;
  1030.  
  1031.   164: s[t].r := - s[t].r; goto loop;
  1032.  
  1033.   165: { index strngs }
  1034.          h1 := s[t-1].i;
  1035.          h2 := s[t].i;
  1036.          if (h2 <= 0) or (h2 > memw[h1:0])
  1037.          then begin
  1038.            ps := inxchk; goto windup; end
  1039.          else begin
  1040.            t := t-1;
  1041.            s[t].i := mem[h1:h2+3]
  1042.          end;
  1043.        goto loop;
  1044.  
  1045.   166: { strngs := temp }
  1046.          h2 := s[t-1].i;
  1047.          h1 := s[h2].i;
  1048.          if h1=0 then link(h2)
  1049.                  else if memw[h1:2] <> 0 then free(h1);
  1050.          s[h2].i := s[t].i;
  1051.          t := t-2;
  1052.        goto loop;
  1053.  
  1054.   167: { convert array to string }
  1055.          h1 := s[t].i;
  1056.          if not get(h3,y) then goto windup;
  1057.          for h4 := 0 to y-1 do mem[h3:4+h4] := ord(s[h1+h4].c);
  1058.          s[t].i := h3;
  1059.        goto loop;
  1060.  
  1061.   168: { strngs := chars }
  1062.          h2 := s[s[t-1].i].i;
  1063.          if (h2=0) or (memw[h2:2] > 12) then begin
  1064.            if not get(h3,1) then goto windup;
  1065.            if h2=0 then link(s[t-1].i) else free(h2);
  1066.            h2 := h3;
  1067.            s[s[t-1].i].i := h2; end;
  1068.          mem[h2:4] := s[t].i;
  1069.          memw[h2:0] := 1;
  1070.          t := t-2;
  1071.        goto loop;
  1072.  
  1073.   169: { strngs := strngs }
  1074.          if not scopy(s[t-1].i, t) then goto windup;
  1075.          t := t-2;
  1076.        goto loop;
  1077.  
  1078.   170: 171: { write string }
  1079.          h3 := s[t].i; t := t-1;
  1080.          h2 := memw[h3:0] + 4;
  1081.          h1 := 4;
  1082.          while h1 < h2 do begin
  1083.            write(prr,chr(mem[h3:h1]));
  1084.            h1 := h1+1;
  1085.          end;
  1086.          if opcode = 171 then free(h3);
  1087.          chrcnt := (chrcnt + h2 -4) mod lineleng;
  1088.        goto loop;
  1089.  
  1090.   172: { string val param }
  1091.          h1 := s[t].i;
  1092.          h4 := memw[h1:0];
  1093.          if not get(h2,h4) then goto windup;
  1094.          move(mem[h1:4],mem[h2:4],h4);
  1095.          s[t].i := h2;
  1096.          s[t].p := s[b0].i;
  1097.          s[b0].i := t;
  1098.        goto loop;
  1099.  
  1100.   173: { temp val param }
  1101.          s[t].p := s[b0].i;
  1102.          s[b0].i := t;
  1103.        goto loop;
  1104.  
  1105.   174: 175: { chararray := string }
  1106.          h1 := s[t].i;
  1107.          h2 := memw[h1:0];
  1108.          h4 := s[t-1].i;
  1109.          if h2>=y
  1110.          then for h3 := 0 to y-1 do s[h4+h3].c := chr(mem[h1:4+h3])
  1111.          else begin
  1112.            for h3 := 0 to h2-1 do s[h4+h3].c := chr(mem[h1:4+h3]);
  1113.            for h3 := h4+h2 to h4+y-1 do s[h3].c := ' '
  1114.          end;
  1115.          if opcode=175 then free(h1);
  1116.          t := t-2;
  1117.        goto loop;
  1118.  
  1119.   176: 177:  { write string - defined field }
  1120.          h4 := s[t].i;
  1121.          h3 := s[t-1].i;
  1122.          h2 := memw[h3:0];
  1123.          if h2>=h4 then h2 := h4
  1124.                    else repeat
  1125.                      write(prr,' ');
  1126.                      h4 := h4-1;
  1127.                    until h4=h2;
  1128.          h1 := 4; h2 := h2+4;
  1129.          while h1 < h2 do begin
  1130.            write(prr,chr(mem[h3:h1]));
  1131.            h1 := h1+1
  1132.          end;
  1133.          if opcode=177 then free(h3);
  1134.          if chrcnt = 0 then chrcnt := s[t].i mod lineleng;
  1135.          t := t-2;
  1136.        goto loop;
  1137.  
  1138.   178:179:180:181:182:183:184:185:186:187:188:189:190:191:192:193:194:195:196:
  1139.   197:198:199:200:201:202:203:204:205:206:207:208:209:210:211:212:213:214:215:
  1140.   216:217:218:219:220:221:222:223:224:225:226:227:228:229:230:231:232:233:234:
  1141.   235:236:237:238:239:240:241:242:243:244:245:246:247:248:249:250:251:252:253:
  1142.   254:255: ps := syschk; goto windup;
  1143.  
  1144.  
  1145. windup:
  1146.   if ps <> fin
  1147.   then begin
  1148.     writeln(prr);
  1149.     write(prr,' halt at', pc-1:5, ' because of ');
  1150.     case ps of
  1151.       caschk: writeln(prr,'undefined case');
  1152.       divchk: writeln(prr,'division by 0');
  1153.       inxchk: writeln(prr,'invalid index');
  1154.       stkchk: writeln(prr,'storage overflow');
  1155.       redchk: writeln(prr,'reading past end of file');
  1156.       strchk: writeln(prr,'string length error');
  1157.        fnchk: writeln(prr,'function argument out of range');
  1158.       syschk: writeln(prr,'bug in compiler');
  1159.     end ;
  1160.   h1 := b; blkcnt := 10;   { post mortem dump }
  1161.   repeat
  1162.     writeln(prr); blkcnt := blkcnt - 1;
  1163.     if blkcnt = 0 then h1 := 0; h2 := s[h1+4].i;
  1164.     if h1<>0
  1165.     then writeln(prr,' ', tab[h2].name, ' called at', s[h1+1].i: 5);
  1166.     h2 := btab[tab[h2].ref].last;
  1167.     while h2 <> 0 do
  1168.       with tab[h2] do
  1169.       begin
  1170.         if obj = vvariable
  1171.         then if typ in stantyps
  1172.              then begin
  1173.                write(prr,'    ', name, ' = ');
  1174.                if normal then h3 := h1+adr else h3 := s[h1+adr].i;
  1175.                case typ of
  1176.                  ints : writeln(prr,s[h3].i);
  1177.                  reals: writeln(prr,s[h3].r);
  1178.                  bools: if s[h3].b
  1179.                         then writeln(prr,'true')
  1180.                         else writeln(prr,'false');
  1181.                  chars: writeln(prr,chr(s[h3].i mod 64));
  1182.                 strngs: begin
  1183.                           h3 := s[h3].i;
  1184.                           write('''');
  1185.                           h4 := memw[h3:0] + 4;
  1186.                           h5 := 4;
  1187.                           while h5 < h4 do begin
  1188.                             write(prr,chr(mem[h3:h5]));
  1189.                             h5 := h5+1;
  1190.                           end;
  1191.                           writeln('''');
  1192.                         end;
  1193.                end
  1194.              end ;
  1195.         h2 := link
  1196.       end ;
  1197.     h1 := s[h1+3].i
  1198.   until h1 < 0;
  1199.   end ;
  1200.  
  1201.   writeln(prr);
  1202.  
  1203. end ; { interpret }
  1204.  
  1205. {$R+}