{ Facilis 0.20                                    file: INTERPRT.PAS     }
{$R-}

overlay procedure interpret;

var
     b,b0: integer;   { base index }
  h1,h2,h3,h4,h5,h6: integer;   { temporaries }
     blkcnt, chrcnt: integer;   { counters }
 jumpbase: integer;   { address of jump table }
    sbuff: string[80];
       ps: (run,fin,stkchk,caschk,divchk,inxchk,redchk,strchk,syschk);

  fld    : array [1..4] of integer;     { default field widths }
  s      : array [0..stacksize] of      { blockmark:               }
       record
         case cn:types of               {    s[b+0] = fct result   }
         ints:  (  i: integer);         {    s[b+1] = return adr   }
         reals: (  r: real);            {    s[b+2] = static link  }
         bools: (  b: boolean);         {    s[b+3] = dynamic link }
         chars: (  c: char);            {    s[b+4] = table index  }
         strngs:(s,p: integer);         {    s[b+5] = string ptr   }
       end;

  procedure dump;

  var    p,h3 :integer;

  begin
    h3:=tab[h2].lev;
    writeln(psout);writeln(psout);
    writeln(psout,'        calling ',tab[h2].name);
    writeln(psout,'          level ',h3:4);
    writeln(psout,' start of  code ',pc:4);
    writeln(psout);writeln(psout);
    writeln(psout,' contents of display '); writeln(psout);

    for p:=h3+1 downto 1 do writeln(psout,p:4,display[p]:6);

    writeln(psout);writeln(psout);
    writeln(psout,' top of stack   ',t:4,' frame base ':14,b:4);
    writeln(psout);writeln(psout);
    writeln(psout,'stack contents':20); writeln(psout);

    for  p:=t  downto  1  do writeln(psout,p:14,s[p].i:8);

    writeln(psout,'< = = = >':22)
  end; {  dump  }

  function get(var s:integer; t:integer): boolean;

  var v:integer;

  begin
    v := ((t+3) div 16 +1)*16;
    if (v < 1) or (v shr 4 > maxavail)
    then begin ps := strchk; get := false; end
    else begin
      get := true;
      getmem(spnt,v); s := seg(spnt^);
      memw[s:0] := t;
      memw[s:2] := v-4;
    end
  end;

  procedure free(p:integer);

  begin
    tpnt := ptr(p,0);
    freemem(tpnt,memw[p:2]+4)
  end;

  procedure link(j:integer);

  var i: integer;

  begin
    b0 := b;
    i := tab[s[b0+4].i].lev;
    while j<b0 do begin
      b0 := display[i]; i := i-1; end;
    s[j].p := s[b0+5].i;
    s[b0+5].i := j;
    s[j].cn := strngs
  end;

function scopy(lf,rt:integer): boolean;

var h1,h2,h3,h4: integer;

begin
  scopy := true;
  h1 := s[lf].s;
  h2 := memw[h1:2];
  h3 := s[rt].s;
  h4 := memw[h3:0];
  if (h1 = 0) or (h2 < h4) or (h2 >= h4+16)
  then begin
    if h1=0 then link(lf)
            else if h2<>0 then free(h1);
    if not get(h1,h4) then scopy := false;
    s[lf].s := h1;
  end else memw[h1:0] := h4;
  if ps = run then move(mem[h3:4],mem[h1:4],h4)
end;

label start,loop,windup,
     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,
     27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,
     51,52,53,54,55,56,57,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,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,
     99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,
     117,118,119,120,121,122,123,124,125,126,127,128,129,130,131,132,133,134,
     135,136,137,138,139,140,141,142,143,144,145,146,147,148,149,150,151,152,
     153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,
     171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,
     189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,
     207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,
     225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,
     243,244,245,246,247,248,249,250,251,252,253,254,255;

begin { interpret }
  inline(              { find base address of jump table }
    $b8/*+12/          { MOV AX,*+12     }
    $89/$86/jumpbase ); { MOV [BP]jumpbase,AX }
  goto start;
  goto windup;
{ each of these GOTOs compiles to a JMP to one of the interpreter routines }
  goto   0;goto   1;goto   2;goto   3;goto   4;goto   5;goto   6;goto   7;
  goto   8;goto   9;goto  10;goto  11;goto  12;goto  13;goto  14;goto  15;
  goto  16;goto  17;goto  18;goto  19;goto  20;goto  21;goto  22;goto  23;
  goto  24;goto  25;goto  26;goto  27;goto  28;goto  29;goto  30;goto  31;
  goto  32;goto  33;goto  34;goto  35;goto  36;goto  37;goto  38;goto  39;
  goto  40;goto  41;goto  42;goto  43;goto  44;goto  45;goto  46;goto  47;
  goto  48;goto  49;goto  50;goto  51;goto  52;goto  53;goto  54;goto  55;
  goto  56;goto  57;goto  58;goto  59;goto  60;goto  61;goto  62;goto  63;
  goto  64;goto  65;goto  66;goto  67;goto  68;goto  69;goto  70;goto  71;
  goto  72;goto  73;goto  74;goto  75;goto  76;goto  77;goto  78;goto  79;
  goto  80;goto  81;goto  82;goto  83;goto  84;goto  85;goto  86;goto  87;
  goto  88;goto  89;goto  90;goto  91;goto  92;goto  93;goto  94;goto  95;
  goto  96;goto  97;goto  98;goto  99;goto 100;goto 101;goto 102;goto 103;
  goto 104;goto 105;goto 106;goto 107;goto 108;goto 109;goto 110;goto 111;
  goto 112;goto 113;goto 114;goto 115;goto 116;goto 117;goto 118;goto 119;
  goto 120;goto 121;goto 122;goto 123;goto 124;goto 125;goto 126;goto 127;
  goto 128;goto 129;goto 130;goto 131;goto 132;goto 133;goto 134;goto 135;
  goto 136;goto 137;goto 138;goto 139;goto 140;goto 141;goto 142;goto 143;
  goto 144;goto 145;goto 146;goto 147;goto 148;goto 149;goto 150;goto 151;
  goto 152;goto 153;goto 154;goto 155;goto 156;goto 157;goto 158;goto 159;
  goto 160;goto 161;goto 162;goto 163;goto 164;goto 165;goto 166;goto 167;
  goto 168;goto 169;goto 170;goto 171;goto 172;goto 173;goto 174;goto 175;
  goto 176;goto 177;goto 178;goto 179;goto 180;goto 181;goto 182;goto 183;
  goto 184;goto 185;goto 186;goto 187;goto 188;goto 189;goto 190;goto 191;
  goto 192;goto 193;goto 194;goto 195;goto 196;goto 197;goto 198;goto 199;
  goto 200;goto 201;goto 202;goto 203;goto 204;goto 205;goto 206;goto 207;
  goto 208;goto 209;goto 210;goto 211;goto 212;goto 213;goto 214;goto 215;
  goto 216;goto 217;goto 218;goto 219;goto 220;goto 221;goto 222;goto 223;
  goto 224;goto 225;goto 226;goto 227;goto 228;goto 229;goto 230;goto 231;
  goto 232;goto 233;goto 234;goto 235;goto 236;goto 237;goto 238;goto 239;
  goto 240;goto 241;goto 242;goto 243;goto 244;goto 245;goto 246;goto 247;
  goto 248;goto 249;goto 250;goto 251;goto 252;goto 253;goto 254;goto 255;

start:
      s[1].i := 0;    s[2].i := 0;
      s[3].i := -1;   s[4].i := btab[1].last;
  display[1] := 0;         t := btab[2].vsize - 1;
           b := 0;        pc := tab[s[4].i].adr;
      chrcnt := 0;        ps := run;

      fld[1] := 8;    fld[2] := 20;
      fld[3] := 8;    fld[4] := 1;

  if t > stacksize
  then begin
    ps := stkchk; goto windup; end;
  fillchar(s[5],(t-4)*sizeof(s[1]),0);

loop:            { here starts the main loop of the interpreter }
Inline(
   $8B/$3E/pc              { MOV DI,pc       ;get program counter }
  /$FF/$06/pc              { INC (W)pc }
  /$D1/$E7                 { SHL DI,=1       ;*4 (bytes per p-code) }
  /$D1/$E7                 { SHL DI,=1       ;index into code array }
  /$81/$C7/code            { ADD DI,=code    ;leave ptr to p-code in DI }
  /$8B/$45/2               { MOV AX,[DI]2    ;get y operand }
  /$A3/y                   { MOV y,AX }
  /$8A/$1D                 { MOV BL,[DI]     ;get opcode }
  /$88/$1E/opcode          { MOV opcode,BL }
  /$32/$FF                 { XOR BH,BH       ;leave opcode in BX }
  /$8B/$F3                 { MOV SI,BX       ;*3 (bytes per JMP) }
  /$03/$F3                 { ADD SI,BX }
  /$03/$F3                 { ADD SI,BX }
  /$03/$B6/jumpbase        { ADD SI,[BP]jumpbase ;index into jump table }
  /$FF/$E6                 { JMP SI          ;jump through table }
  );


    0: { load address }
      inline(
        $8A/$45/1                  { MOV AL,[DI]1    ;get x operand }
       /$A2/x );                   { MOV x,AL }
      t := t+1;
      if t > stacksize
      then begin
        ps := stkchk; goto windup; end
      else s[t].i := display[x] + y;
      goto loop;

    1: { load value }
      inline(
        $8A/$45/1                  { MOV AL,[DI]1    ;get x operand }
       /$A2/x );                   { MOV x,AL }
      t := t+1;
      if t > stacksize
      then begin
        ps := stkchk; goto windup; end
      else s[t] := s[display[x] + y];
      goto loop;

    2: { load indirect }
      inline(
        $8A/$45/1                  { MOV AL,[DI]1    ;get x operand }
       /$A2/x );                   { MOV x,AL }
      t := t+1;
      if t > stacksize
      then begin
        ps := stkchk; goto windup; end
        else s[t] := s[s[display[x] + y].i];
      goto loop;

    3: { update display }
      inline(
        $8A/$45/1                  { MOV AL,[DI]1    ;get x operand }
       /$A2/x );                   { MOV x,AL }
      h1 := y; h2 := x; h3 := b;
      repeat
        display[h1] := h3; h1 := h1-1; h3 := s[h3+2].i
      until h1 = h2;
      goto loop;

    4:5:6: ps := syschk; goto windup;

    7: case y and 3 of    { concatenation }
      0: begin   {char+char}
           if not get(h1,2) then goto windup;
           mem[h1:4] := s[t-1].i;
           mem[h1:5] := s[t].i;
           t := t-1;
           s[t].i := h1;
         end;
      1: begin   {string+char}
           h1 := s[t-1].i;
           h2 := memw[h1:0];
           if not get(h3,h2+1) then goto windup;
           move(mem[h1:4],mem[h3:4],h2);
           if (y and 4) = 4 then free(h1);
           mem[h3:h2+4] := s[t].i;
           t := t-1;
           s[t].i := h3;
         end;
      2: begin   {char+string}
           h1 := s[t].i;
           h2 := memw[h1:0];
           if not get(h4,h2+1) then goto windup;
           move(mem[h1:4],mem[h4:5],h2);
           mem[h4:4] := s[t-1].i;
           if (y and 8) = 8 then free(h1);
           t := t-1;
           s[t].i := h4;
         end;
      3: begin   {string+string}
           h5 := s[t-1].i;
           h6 := s[t].i;
           h3 := memw[h5:0];
           h4 := memw[h6:0];
           if not get(h2,h3+h4) then goto windup;
           move(mem[h5:4],mem[h2:4],h3);
           move(mem[h6:4],mem[h2:h3+4],h4);
           if (y and 4) = 4 then free(h5);
           if (y and 8) = 8 then free(h6);
           t := t-1;
           s[t].i := h2;
         end;
       end;
       goto loop;

    8: if y < 10 then
       case y of
      0: s[t].i := abs(s[t].i);
      1: s[t].r := abs(s[t].r);
      2: s[t].i := sqr(s[t].i);
      3: s[t].r := sqr(s[t].r);
      4: s[t].b := odd(s[t].i);
      5: s[t].c := chr(s[t].i);
      6: s[t].i := ord(s[t].c);
      7: s[t].c := succ(s[t].c);
      8: s[t].c := pred(s[t].c);
      9: s[t].i := round(s[t].r);
       end

       else if y < 20 then
       case y of
     10: s[t].i := trunc(s[t].r);
     11: s[t].r := sin(s[t].r);
     12: s[t].r := cos(s[t].r);
     13: s[t].r := exp(s[t].r);
     14: s[t].r := ln(s[t].r);
     15: s[t].r := sqrt(s[t].r);
     16: s[t].r := arctan(s[t].r);
     17: begin
           t := t+1;
           if t > stacksize
           then begin
             ps := stkchk; goto windup; end
           else s[t].b := eof(prd)
         end;
     18: begin
           t := t+1;
           if t > stacksize
           then begin
             ps := stkchk; goto windup; end
           else s[t].b := eoln(prd)
         end;
     19: begin
           t := t+1;
           if t > stacksize
           then begin
             ps := stkchk; goto windup; end
           else s[t].i := maxavail
         end;

       end
       else if y < 33 then
       case y of

     20: s[t].i := memw[s[t].i:0];
     21: begin
           h1 := s[t].i;
           s[t].i := memw[h1:0];
           spnt := ptr(h1,0); freemem(spnt,memw[h1:2]+4)
         end;
     22: s[t].i := 1;
     23: begin
           h1 := s[t-2].i;
           h4 := memw[h1:0];
           h2 := s[t-1].i;
           if (h2 < 1) or (h2 > h4)
           then begin h4 := 0; h2 := 2; end;
           h3 := s[t].i;
           if h3 > h4-h2+1 then h3 := h4-h2+1;
           if h3 < 0 then h3 := 0;
           if not get(h5,h3) then goto windup;
           move(mem[h1:h2+3],mem[h5:4],h3);
           s[t-2].i := h5;
           t := t-2;
         end;
     24: begin
           h1 := s[t-2].i;
           h4 := memw[h1:0];
           h2 := s[t-1].i;
           if (h2 < 1) or (h2 > h4)
           then memw[h1:0] := 0
           else begin
             h3 := s[t].i;
             if h3 > h4-h2+1 then h3 := h4-h2+1;
             if h3 < 0 then h3 := 0;
             move(mem[h1:h2+3],mem[h1:4],h3);
             memw[h1:0] := h3;
           end;
           t := t-2;
         end;

     25: begin
           if not get(h1,1) then goto windup;
           if (s[t-1].i = 1) and (s[t].i > 0)
           then mem[h1:4] := s[t-2].i
           else memw[h1:0] := 0;
           s[t-2].i := h1;
           t := t-2;
         end;

 26,27,30,31:
         begin
           h1 := s[t-1].i;
           h2 := s[t].i;   t := t-1;
           h6 := memw[h1:0]+4;
           h3 := memw[h2:0]+5-h6;
           if (h3<=0) or (h6=4)
           then s[t].i := 0
           else begin
             h4 := 0;
             while h4<h3 do begin
               h5 := 4;
               while (h5<h6) and (mem[h1:h5]=mem[h2:h4+h5]) do h5 := h5+1;
               if h5=h6 then h3:=h4-1 else h4 := h4+1;
             end;
             if h3=h4 then s[t].i := 0 else s[t].i := h4+1;
           end;
           if odd(y) then free(h1);
           if y > 29 then free(h2);
         end;

  28,32: begin
           h1 := s[t-1].i;
           h2 := s[t].i;
           h3 := memw[h2:0]+4;
           h4 := 4;
           while (h4<h3) and (mem[h2:h4]<>h1) do h4 := h4+1;
           if y=32 then free(h3);
           t := t-1;
           if h4<h3 then s[t].i := h4-3 else s[t].i := 0;
         end;

       end
       else if y < 40 then
       case y of

  33,34: begin
           if y=34 then str(s[t].r:18,sbuff)
                      else str(s[t].i:1,sbuff);
           h2 := length(sbuff);
           if not get(h1,h2) then goto windup;
           move(sbuff[1],mem[h1:4],h2);
           s[t].i := h1
         end;

35,36,37,38:
         begin
           h1 := s[t].i;
           h2 := memw[h1:0]; sbuff := '';
           move(mem[h1:4],sbuff[1],h2);
           sbuff[0] := chr(h2);
           if y < 37 then val(sbuff,s[t].i,h5)
                        else val(sbuff,s[t].r,h5);
           if not odd(y) then free(h1)
         end;

         else begin
                ps := syschk; goto windup;
              end;

       end ; { functions }
       goto loop;

    9: s[t].i := s[t].i + y;   { offset }
       goto loop;

   10: pc := y;  { jump }
       goto loop;

   11: { conditional jump }
         if not s[t].b then pc := y;
         t := t-1;
       goto loop;

   12: { switch }
         h1 := s[t].i;      t := t-1;
         h2 := y;       h3 := 0;
         repeat
           if code[h2].f <> 13
           then begin
             ps := caschk; goto windup; end
           else if code[h2].y = h1
                    then begin
                      h3 := 1;
                      pc := code[h2+1].y
                    end else h2 := h2 + 2
         until h3 <> 0;
       goto loop;

   13: ps := syschk; goto windup;  {case marker}

   14: { for1up }
         h1 := s[t-1].i;
         if<