procedure interpret; (*global code, tab, btab*) var ir: order; (*instruction buffer*) pc: integer; (*program counter*) ps: (run,fin,caschk,divchk,inxchk,stkchk,linchk,lngchk,redchk); t: integer; (*top stack index*) b: integer; (*base index*) lncnt, ocnt, blkcnt, chrcnt: integer; (*counters*) h1,h2,h3,h4: integer; fld: array [1..4] of integer; (*default field widths*) display: array [1..lmax] of integer; s: array [1..stacksize] of (*blockmark: *) record case 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 *) end ; begin (*interpret*) s[1].i := 0; s[2].i := 0; s[3].i := -1; s[4].i := btab[1].last; b := 0; display[1] := 0; t := btab[2].vsize - 1; pc := tab[s[4].i].adr; ps := run; lncnt := 0; ocnt := 0; chrcnt := 0; fld[1] := 10; fld[2] := 22; fld[3] := 10; fld[4] := 1; repeat ir := code[pc]; pc := pc+1; ocnt := ocnt + 1; case ir.f of 0: begin (*load address*) t := t+1; if t > stacksize then ps := stkchk else s[t].i := display[ir.x] + ir.y end ; 1: begin (*load value*) t := t+1; if t > stacksize then ps := stkchk else s[t] := s[display[ir.x] + ir.y] end ; 2: begin (*load indirect*) t := t+1; if t > stacksize then ps := stkchk else s[t] := s[s[display[ir.x] + ir.y].i] end ; 3: begin (*update display*) h1 := ir.y; h2 := ir.x; h3 := b; repeat display[h1] := h3; h1 := h1-1; h3 := s[h3+2].i until h1 = h2 end ; 8: case ir.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: begin if (s[t].i < 0) or (s[t].i > 127) then ps := inxchk else s[t].c := chr(s[t].i) end ; 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); 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 ps := stkchk else s[t].b := eof(input) end ; 18: begin t := t+1; if t > stacksize then ps := stkchk else s[t].b := eoln(input) end ; 19: end ; 9: s[t].i := s[t].i + ir.y; (*offset*) 10: pc := ir.y; (*jump*) 11: begin (*conditional jump*) if not s[t].b then pc := ir.y; t := t-1 end ; 12: begin (*switch*) h1 := s[t].i; t := t-1; h2 := ir.y; h3 := 0; repeat if code[h2].f <> 13 then begin h3 := 1; ps := caschk end else if code[h2].y = h1 then begin h3 := 1; pc := code[h2+1].y end else h2 := h2 + 2 until h3 <> 0 end ; 14: begin (*for1up*) h1 := s[t-1].i; if h1 <= s[t].i then s[s[t-2].i].i := h1 else begin t := t-3; pc := ir.y end end ; 15: begin (*for2up*) h2 := s[t-2].i; h1 := s[h2].i + 1; if h1 <= s[t].i then begin s[h2].i := h1; pc := ir.y end else t := t-3; end ; 16: begin (*for1down*) h1 := s[t-1].i; if h1 >= s[t].i then s[s[t-2].i].i := h1 else begin pc := ir.y; t := t-3 end end ; 17: begin (*for2down*) h2 := s[t-2].i; h1 := s[h2].i - 1; if h1 >= s[t].i then begin s[h2].i := h1; pc := ir.y end else t := t-3; end ; 18: begin (*mark stack*) h1 := btab[tab[ir.y].ref].vsize; if t+h1 > stacksize then ps := stkchk else begin t := t+5; s[t-1].i := h1-1; s[t].i := ir.y end end ; 19: begin (*call*) h1 := t - ir.y; (*h1 points to base*) h2 := s[h1+4].i; (*h2 points to tab*) h3 := tab[h2].lev; display[h3+1] := h1; h4 := s[h1+3].i + h1; s[h1+1].i := pc; s[h1+2].i := display[h3]; s[h1+3].i := b; for h3 := t+1 to h4 do s[h3].i := 0; b := h1; t := h4; pc := tab[h2].adr end ; 20: begin (*index1*) h1 := ir.y; (*h1 points to atab*) h2 := atab[h1].low; h3 := s[t].i; if h3 < h2 then ps := inxchk else if h3 > atab[h1].high then ps := inxchk else begin t := t-1; s[t].i := s[t].i + (h3-h2) end end ; 21: begin (*index*) h1 := ir.y; (*h1 points to atab*) h2 := atab[h1].low; h3 := s[t].i; if h3 < h2 then ps := inxchk else if h3 > atab[h1].high then ps := inxchk else begin t := t-1; s[t].i := s[t].i + (h3-h2)*atab[h1].elsize end end ; 22: begin (*load block*) h1 := s[t].i; t := t-1; h2 := ir.y + t; if h2 > stacksize then ps := stkchk else while t < h2 do begin t := t+1; s[t] := s[h1]; h1 := h1+1 end end ; 23: begin (*copy block*) h1 := s[t-1].i; h2 := s[t].i; h3 := h1 + ir.y; while h1 < h3 do begin s[h1] := s[h2]; h1 := h1+1; h2 := h2+1 end ; t := t-2 end ; 24: begin (*literal*) t := t+1; if t > stacksize then ps := stkchk else s[t].i := ir.y end ; 25: begin (*load real*) t := t+1; if t > stacksize then ps := stkchk else s[t].r := rconst[ir.y] end ; 64,65: begin t := t + 1; if t > stacksize then ps := stkchk else s[t].c := chr(ir.y) end; 26: begin (*float*) h1 := t - ir.y; s[h1].r := s[h1].i end ; 27: begin (*read*) if eof(input) then ps := redchk else case ir.y of 1: read(s[s[t].i].i); 2: read(s[s[t].i].r); 4: read(s[s[t].i].c); end ; t := t-1 end ; 28: begin (*write string*) h1 := s[t].i; h2 := ir.y; t := t-1; chrcnt := chrcnt+h1; if chrcnt > lineleng then ps := lngchk; repeat write(stab[h2]); h1 := h1-1; h2 := h2+1 until h1 = 0 end ; 29: begin (*writ1*) chrcnt := chrcnt + fld[ir.y]; if chrcnt > lineleng then ps := lngchk else case ir.y of 1: write(s[t].i: fld[1]); 2: write(s[t].r: fld[2]); 3: write(s[t].b: fld[3]); 4: write(s[t].c); end ; t := t-1 end ; 30: begin (*write2*) chrcnt := chrcnt + s[t].i; if chrcnt > lineleng then ps := lngchk else case ir.y of 1: write(s[t-1].i: s[t].i); 2: write(s[t-1].r: s[t].i); 3: write(s[t-1].b: s[t].i); 4: write(s[t-1].c: s[t].i); end ; t := t-2 end ; 31: ps := fin; 32: begin (*exit procedure*) t := b-1; pc := s[b+1].i; b := s[b+3].i end ; 33: begin (*exit function*) t := b; pc := s[b+1].i; b := s[b+3].i end ; 34: s[t] := s[s[t].i]; 35: s[t].b := not s[t].b; 36: s[t].i := - s[t].i; 66: s[t].r := - s[t].r; 37: begin chrcnt := chrcnt + s[t-1].i; if chrcnt > lineleng then ps := lngchk else write(s[t-2].r: s[t-1].i: s[t].i); t := t-3 end ; 38: begin (*store*) s[s[t-1].i] := s[t]; t := t-2 end ; 39: begin t := t-1; s[t].b := s[t].r = s[t+1].r end ; 40: begin t := t-1; s[t].b := s[t].r <> s[t+1].r end ; 41: begin t := t-1; s[t].b := s[t].r < s[t+1].r end ; 42: begin t := t-1; s[t].b := s[t].r <= s[t+1].r end ; 43: begin t := t-1; s[t].b := s[t].r > s[t+1].r end ; 44: begin t := t-1; s[t].b := s[t].r >= s[t+1].r end ; 45: begin t := t-1; s[t].b := s[t].i = s[t+1].i end ; 46: begin t := t-1; s[t].b := s[t].i <> s[t+1].i end ; 47: begin t := t-1; s[t].b := s[t].i < s[t+1].i end ; 48: begin t := t-1; s[t].b := s[t].i <= s[t+1].i end ; 49: begin t := t-1; s[t].b := s[t].i > s[t+1].i end ; 50: begin t := t-1; s[t].b := s[t].i >= s[t+1].i end ; 51: begin t := t-1; s[t].b := s[t].b or s[t+1].b end ; 52: begin t := t-1; s[t].i := s[t].i + s[t+1].i end ; 53: begin t := t-1; s[t].i := s[t].i - s[t+1].i end ; 54: begin t := t-1; s[t].r := s[t].r + s[t+1].r; end ; 55: begin t := t-1; s[t].r := s[t].r - s[t+1].r; end ; 56: begin t := t-1; s[t].b := s[t].b and s[t+1].b end ; 57: begin t := t-1; s[t].i := s[t].i * s[t+1].i end ; 58: begin t := t-1; if s[t+1].i = 0 then ps := divchk else s[t].i := s[t].i div s[t+1].i end ; 59: begin t := t-1; if s[t+1].i = 0 then ps := divchk else s[t].i := s[t].i mod s[t+1].i end ; 60: begin t := t-1; s[t].r := s[t].r * s[t+1].r; end ; 61: begin t := t-1; if s[t+1].r = 0.0 then ps := divchk else s[t].r := s[t].r / s[t+1].r; end ; 62: if eof(input) then ps := redchk else readln; 63: begin writeln; lncnt := lncnt + 1; chrcnt := 0; if lncnt > linelimit then ps := linchk end end (*case*) ; until ps <> run; if ps <> fin then begin writeln; write('0halt at', pc:5, ' because of '); case ps of caschk: writeln('undefined case'); divchk: writeln('division by 0'); inxchk: writeln('invalid index'); stkchk: writeln('storage overflow'); linchk: writeln('too much output'); lngchk: writeln('line too long'); redchk: writeln('reading past end of file'); end ; h1 := b; blkcnt := 10; (*post mortem dump*) repeat writeln; blkcnt := blkcnt - 1; if blkcnt = 0 then h1 := 0; h2 := s[h1+4].i; if h1<>0 then writeln(' ', tab[h2].name, ' called at', s[h1+1].i: 5); h2 := btab[tab[h2].ref].last; while h2 <> 0 do with tab[h2] do begin if obj = variable then if typ in stantyps then begin write(' ', name, ' = '); if normal then h3 := h1+adr else h3 := s[h1+adr].i; case typ of ints: writeln(s[h3].i); reals: writeln(s[h3].r); bools: writeln(s[h3].b); chars: writeln(s[h3].c); end end ; h2 := link end ; h1 := s[h1+3].i until h1 < 0; end ; writeln; writeln(ocnt, ' steps') end (*interpret*) ;