Category : Pascal Source Code
Archive   : FACILIS.ZIP
Filename : INTERPRT.PAS

 
Output of file : INTERPRT.PAS contained in archive : FACILIS.ZIP


{ FACILIS Version 0.10 }
overlay procedure interpret;

var ir: order; { instruction buffer }
pc: integer; { program counter }
t: integer; { top stack index }
b,b0: integer; { base index }
h1,h2,h3,h4,h5,h6: integer;
blkcnt, chrcnt: integer; { counters }
sbuff: string[80];
ps: (run,fin,caschk,divchk,inxchk,stkchk,redchk,strchk,syschk);

fld : array [1..4] of integer; { default field widths }
display: array [0..lmax] of integer;
s : array [1..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 }

procedure get(var s:integer; t:integer);

var v:integer;

begin
v := ((t+3) div 16 +1)*16;
if (v < 1) or (v shr 4 > maxavail)
then ps := strchk
else begin
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 := display[i]; i := i-1; end;
s[j].p := s[b0+5].i;
s[b0+5].i := j;
s[j].cn := strngs
end;

procedure scopy(lf,rt:integer);

var h1,h2,h3,h4: integer;

begin
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);
get(h1,h4);
s[lf].s := h1;
end else memw[h1:0] := h4;
move(mem[h3:4],mem[h1:4],h4)
end;

begin { interpret }
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;

fillchar(s[5],(t-4)*sizeof(s[1]),0);

repeat
ir := code[pc];
pc := pc+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 ;

7: case ir.y and 3 of { concatenation }
0: begin {char+char}
get(h1,2);
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];
get(h3,h2+1);
move(mem[h1:4],mem[h3:4],h2);
if (ir.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];
get(h4,h2+1);
move(mem[h1:4],mem[h4:5],h2);
mem[h4:4] := s[t-1].i;
if (ir.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];
get(h2,h3+h4);
move(mem[h5:4],mem[h2:4],h3);
move(mem[h6:4],mem[h2:h3+4],h4);
if (ir.y and 4) = 4 then free(h5);
if (ir.y and 8) = 8 then free(h6);
t := t-1;
s[t].i := h2;
end;
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: 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);
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(prd)
end;
18: begin
t := t+1;
if t > stacksize
then ps := stkchk else s[t].b := eoln(prd)
end;
19: begin
t := t+1;
if t > stacksize
then ps := stkchk else s[t].i := maxavail
end;
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;
get(h5,h3);
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
get(h1,1);
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

h5 := 4;
while (h5 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(ir.y) then free(h1);
if ir.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 (h4h1) do h4 := h4+1;
if ir.y=32 then free(h3);
t := t-1;
if h4

end;

33,34: begin
if ir.y=34 then str(s[t].r:18,sbuff)
else str(s[t].i:1,sbuff);
h2 := length(sbuff);
get(h1,h2);
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 ir.y < 37 then val(sbuff,s[t].i,h5)
else val(sbuff,s[t].r,h5);
if not odd(ir.y) then free(h1)
end;

else ps := syschk;

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+6; b0 := t; s[b0].i := 0;
s[t-2].i := h1-1; s[t-1].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;
fillchar(s[t+1],(h4-t)*sizeof(s[1]),0);
b := h1; t := h4;
pc := tab[h2].adr;
if stackdump then dump
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;
if s[h1].cn = strngs
then begin
s[t].s := 0;
scopy(t,h1); end
else 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
if s[h2].cn = strngs
then begin
s[h1].s := 0;
scopy(h1,h2); end
else 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 ;

26: begin { float }
h1 := t - ir.y;
s[h1].r := s[h1].i
end ;

27: begin { read }
case ir.y of
1: read(prd,s[s[t].i].i);
2: read(prd,s[s[t].i].r);
4: read(prd,s[s[t].i].c);
5: begin
read(prd,sbuff);
h1 := length(sbuff);
if h1=0
then h3 := nul
else begin
get(h3,h1);
move(sbuff[1],mem[h3:4],h1);
end;
h4 := s[t].i; h5 := s[h4].i;
if h5 = 0 then link(h4)
else if memw[h5:2] <> 0 then free(h5);
s[h4].i := h3;
end
end ;

t := t-1
end ;

29: begin { write1 }
chrcnt := chrcnt + fld[ir.y];
if chrcnt > lineleng
then begin
writeln(prr); chrcnt := 0; end;
case ir.y of
1: write(prr,s[t].i: fld[1]);
2: write(prr,s[t].r: fld[2]);
3: if s[t].b then write ('true':fld[3])
else write ('false':fld[3]);
4: write(prr,chr(s[t].i));
end ;
t := t-1
end ;

30: begin { write2 }
chrcnt := chrcnt + s[t].i;
if chrcnt > lineleng
then begin
writeln(prr); chrcnt := 0; end;
case ir.y of
1: write(prr,s[t-1].i: s[t].i);
2: write(prr,s[t-1].r: s[t].i);
3: if s[t-1].b then write ('true') else write ('false');
4: write(prr,chr(s[t-1].i): s[t].i);
end ;
t := t-2
end ;

31: begin { chars := strngs }
h1 := s[t].i;
if memw[h1:0] <> 1
then ps := strchk
else begin
s[s[t-1].i].i := mem[h1:4];
if (ir.y and 8) = 8 then free(h1)

end;
t := t-2;
end;

32: begin { string relations }
h2 := s[t-1].i;
h3 := s[t].i;
case ir.y and 3 of
1: begin {strngs~chars}
h4 := memw[h2:0];
if h4=0 then h5 := 64
else if h3>mem[h2:4] then h5 := 64
else if h3 else if h4=1 then h5 := 16
else h5 := 32;
end;
2: begin {chars~strngs}
h4 := memw[h3:0];
if h4=0 then h5 := 32
else if h2>mem[h3:4] then h5 := 32
else if h2 else if h4=1 then h5 := 16
else h5 := 64;
end;
3: begin {strngs~strngs}
h4 := memw[h2:0]; h1 :=0;
h5 := memw[h3:0];
if h5

while h1

if mem[h2:4+h1] <> mem[h3:4+h1]
then h4 := h1
else h1 := h1+1;
end;
if h4=h5
then if memw[h2:0]=memw[h3:0]
then h5 := 16
else if memw[h2:0] then h5 := 64 else h5 := 32
else if mem[h2:4+h1] then h5 := 64 else h5 := 32;
end;
end;
if (ir.y and 5) = 5 then free(h2);
if (ir.y and 10) = 10 then free(h3);
t := t-1;
s[t].b := (ir.y and h5) > 0;
end;

131: ps := fin;

132: begin { exit procedure }
h1 := s[b+5].i;
while h1 <> 0 do begin
free(s[h1].i);
h1 := s[h1].p; end;
t := b-1;
pc := s[b+1].i; b := s[b+3].i
end;

133: begin { exit function }
h1 := s[b+5].i;
while h1 <> 0 do begin
free(s[h1].i);
h1 := s[h1].p; end;
t := b;
pc := s[b+1].i; b := s[b+3].i
end;

134: s[t] := s[s[t].i];

135: s[t].b := not s[t].b;

136: s[t].i := - s[t].i;

137: begin
chrcnt := chrcnt + s[t-1].i;
if chrcnt > lineleng
then begin
writeln(prr); chrcnt := 0; end
else write(prr,s[t-2].r: s[t-1].i: s[t].i);
t := t-3
end ;

138: begin { store }
s[s[t-1].i] := s[t];
t := t-2
end ;

139: begin
t := t-1;
s[t].b := s[t].r = s[t+1].r
end ;

140: begin
t := t-1;
s[t].b := s[t].r <> s[t+1].r
end ;

141: begin
t := t-1;
s[t].b := s[t].r < s[t+1].r
end ;

142: begin
t := t-1;
s[t].b := s[t].r <= s[t+1].r
end ;

143: begin
t := t-1;
s[t].b := s[t].r > s[t+1].r
end ;

144: begin
t := t-1;
s[t].b := s[t].r >= s[t+1].r
end ;

145: begin
t := t-1;
s[t].b := s[t].i = s[t+1].i
end ;

146: begin
t := t-1;
s[t].b := s[t].i <> s[t+1].i
end ;

147: begin
t := t-1;
s[t].b := s[t].i < s[t+1].i
end ;

148: begin
t := t-1;
s[t].b := s[t].i <= s[t+1].i
end ;

149: begin
t := t-1;
s[t].b := s[t].i > s[t+1].i
end ;

150: begin
t := t-1;
s[t].b := s[t].i >= s[t+1].i
end ;

151: begin
t := t-1;
s[t].b := s[t].b or s[t+1].b
end ;

152: begin
t := t-1;
s[t].i := s[t].i + s[t+1].i
end ;

153: begin
t := t-1;
s[t].i := s[t].i - s[t+1].i
end ;

154: begin
t := t-1;
s[t].r := s[t].r + s[t+1].r
end ;

155: begin
t := t-1;
s[t].r := s[t].r - s[t+1].r
end ;

156: begin
t := t-1;
s[t].b := s[t].b and s[t+1].b
end ;

157: begin
t := t-1;
s[t].i := s[t].i * s[t+1].i
end ;

158: 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 ;

159: 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 ;

160: begin
t := t-1;
s[t].r := s[t].r * s[t+1].r
end ;

161: begin
t := t-1;
s[t].r := s[t].r / s[t+1].r
end ;

162: if eof(prd) then ps := redchk else readln;

163: begin
writeln(prr);
chrcnt := 0
end ;

164: s[t].r := - s[t].r;

165: begin { index strngs }
h1 := s[t-1].i;
h2 := s[t].i;
if (h2 <= 0) or (h2 > memw[h1:0])
then ps := inxchk
else begin
t := t-1;
s[t].i := mem[h1:h2+3]
end
end;

166: begin { strngs := temp }
h2 := s[t-1].i;
h1 := s[h2].i;
if h1=0 then link(h2)
else if memw[h1:2] <> 0 then free(h1);
s[h2].i := s[t].i;
t := t-2
end;

167: begin { convert array to string }
h1 := s[t].i;
get(h3,ir.y);
for h4 := 0 to ir.y-1 do mem[h3:4+h4] := ord(s[h1+h4].c);
s[t].i := h3
end;

168: begin { strngs := chars }
h2 := s[s[t-1].i].i;
if (h2=0) or (memw[h2:2] > 12) then begin
get(h3,1);
if h2=0 then link(s[t-1].i) else free(h2);
h2 := h3;
s[s[t-1].i].i := h2; end;
mem[h2:4] := s[t].i;
memw[h2:0] := 1;
t := t-2
end;

169: begin { strngs := strngs }
scopy(s[t-1].i, t);
t := t-2
end;

170,171:
begin { write string }
h3 := s[t].i; t := t-1;
h2 := memw[h3:0] + 4;
h1 := 4;
while h1 < h2 do begin
write(prr,chr(mem[h3:h1]));
h1 := h1+1;
end;

if ir.f = 171 then free(h3);
chrcnt := (chrcnt + h2 -4) mod lineleng
end ;

172: begin { string val param }
h1 := s[t].i;
h4 := memw[h1:0];
get(h2,h4);
move(mem[h1:4],mem[h2:4],h4);
s[t].i := h2;
s[t].p := s[b0].i;
s[b0].i := t
end;

173: begin { temp val param }
s[t].p := s[b0].i;
s[b0].i := t
end;

174,175:
begin { chararray := string }
h1 := s[t].i;
h2 := memw[h1:0];
h4 := s[t-1].i;
if h2>=ir.y
then for h3 := 0 to ir.y-1 do s[h4+h3].c := chr(mem[h1:4+h3])
else begin
for h3 := 0 to h2-1 do s[h4+h3].c := chr(mem[h1:4+h3]);
for h3 := h4+h2 to h4+ir.y-1 do s[h3].c := ' '
end;
if ir.f=175 then free(h1);
t := t-2
end;

176,177: { write string - defined field }
begin
h4 := s[t].i;
h3 := s[t-1].i;
h2 := memw[h3:0];
if h2>=h4 then h2 := h4
else repeat
write(prr,' ');
h4 := h4-1;
until h4=h2;
h1 := 4; h2 := h2+4;
while h1 < h2 do begin
write(prr,chr(mem[h3:h1]));
h1 := h1+1
end;
if ir.f=177 then free(h3);
if chrcnt = 0 then chrcnt := s[t].i mod lineleng;
end ;

else ps := syschk;

end { case } ;

until ps <> run;

if ps <> fin
then begin
writeln(prr);
write(prr,' halt at', pc-1:5, ' because of ');
case ps of
caschk: writeln(prr,'undefined case');
divchk: writeln(prr,'division by 0');
inxchk: writeln(prr,'invalid index');
stkchk: writeln(prr,'storage overflow');
redchk: writeln(prr,'reading past end of file');
strchk: writeln(prr,'string length error');
syschk: writeln(prr,'bug in compiler');
end ;
{ end; begin }
h1 := b; blkcnt := 10; { post mortem dump }
repeat
writeln(prr); blkcnt := blkcnt - 1;
if blkcnt = 0 then h1 := 0; h2 := s[h1+4].i;
if h1<>0
then writeln(prr,' ', 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 = vvariable
then if typ in stantyps
then begin
write(prr,' ', name, ' = ');
if normal then h3 := h1+adr else h3 := s[h1+adr].i;
case typ of
ints : writeln(prr,s[h3].i);
reals: writeln(prr,s[h3].r);
bools: if s[h3].b
then writeln(prr,'true')
else writeln(prr,'false');
chars: writeln(prr,chr(s[h3].i mod 64))
end
end ;
h2 := link
end ;
h1 := s[h1+3].i
until h1 < 0;
end ;

writeln(prr);

end ; { interpret }
d ;
h2 := link
end ;