1BSD/pcs/block.i
procedure block(fsys: symset; isfun: boolean; level: integer);
type conrec =
record case tp: types of
ints,chars,bools: (i: integer);
reals: (r: real)
end ;
var dx: integer; (*data allocation index*)
prt: integer; (*t-index of this procedure*)
prb: integer; (*b-index of this procedure*)
x: integer;
procedure skip(fsys: symset; n: integer);
begin error(n);
while not (sy in fsys) do insymbol
end (*skip*) ;
procedure test(s1,s2: symset; n: integer);
begin if not (sy in s1) then
skip(s1+s2,n)
end (*test*) ;
procedure testsemicolon;
begin
if sy = semicolon then insymbol else
begin error(14);
if sy in [comma,colon] then insymbol
end ;
test([ident]+blockbegsys, fsys, 6)
end (*testsemicolon*) ;
procedure enter(id: alfa; k: object);
var j,l: integer;
begin if t = tmax then fatal(1) else
begin tab[0].name := id;
j := btab[display[level]].last; l := j;
while tab[j].name <> id do j := tab[j].link;
if j <> 0 then error(1) else
begin t := t+1;
with tab[t] do
begin name := id; link := l;
obj := k; typ := notyp; ref := 0; lev := level; adr := 0
end ;
btab[display[level]].last := t
end
end
end (*enter*) ;
function loc(id: alfa): integer;
var i,j: integer; (*locate id in table*)
begin i := level; tab[0].name := id; (*sentinel*)
repeat j := btab[display[i]].last;
while tab[j].name <> id do j := tab[j].link;
i := i-1;
until (i<0) or (j<>0);
if j = 0 then error(0); loc := j
end (*loc*) ;
procedure entervariable;
begin if sy = ident then
begin enter(id,variable); insymbol
end
else error(2)
end (*entervariable*) ;
procedure constant(fsys: symset; var c: conrec);
var x, sign: integer;
begin c.tp := notyp; c.i := 0;
test(constbegsys, fsys, 50);
if sy in constbegsys then
begin
if sy = charcon then
begin c.tp := chars; c.i := inum; insymbol
end
else
begin sign := 1;
if sy in [plus,minus] then
begin if sy = minus then sign := -1;
insymbol
end ;
if sy = ident then
begin x := loc(id);
if x <> 0 then
if tab[x].obj <> konstant then error(25) else
begin c.tp := tab[x].typ;
if c.tp = reals then c.r := sign*rconst[tab[x].adr]
else c.i := sign*tab[x].adr
end ;
insymbol
end
else
if sy = intcon then
begin c.tp := ints; c.i := sign*inum; insymbol
end else
if sy = realcon then
begin c.tp := reals; c.r := sign*rnum; insymbol
end else skip(fsys,50)
end;
test(fsys, [], 6)
end
end (*constant*) ;
procedure typ(fsys: symset; var tp: types; var rf, sz: integer);
var x: integer;
eltp: types; elrf: integer;
elsz, offset, t0,t1: integer;
procedure arraytyp(var aref,arsz: integer);
var eltp: types;
low, high: conrec;
elrf, elsz: integer;
begin constant([colon,rbrack,rparent,ofsy]+fsys, low);
if low.tp = reals then
begin error(27); low.tp := ints; low.i := 0
end ;
if sy = colon then insymbol else error(13);
constant([rbrack,comma,rparent,ofsy]+fsys, high);
if high.tp <> low.tp then
begin error(27); high.i := low.i
end ;
enterarray(low.tp, low.i, high.i); aref := a;
if sy = comma then
begin insymbol; eltp := arrays; arraytyp(elrf,elsz)
end else
begin
if sy = rbrack then insymbol else
begin error(12);
if sy = rparent then insymbol
end ;
if sy = ofsy then insymbol else error(8);
typ(fsys,eltp,elrf,elsz)
end ;
with atab[aref] do
begin arsz := (high-low+1)*elsz; size := arsz;
eltyp := eltp; elref := elrf; elsize := elsz
end ;
end (*arraytyp*) ;
begin (*typ*) tp := notyp; rf := 0; sz := 0;
test(typebegsys, fsys, 10);
if sy in typebegsys then
begin
if sy = ident then
begin x := loc(id);
if x <> 0 then
with tab[x] do
if obj <> type1 then error(29) else
begin tp := typ; rf := ref; sz := adr;
if tp = notyp then error(30)
end ;
insymbol
end else
if sy = arraysy then
begin insymbol;
if sy = lbrack then insymbol else
begin error(11);
if sy = lparent then insymbol
end ;
tp := arrays; arraytyp(rf,sz)
end else
begin (*records*) insymbol;
enterblock; tp := records; rf := b;
if level = lmax then fatal(5);
level := level+1; display[level] := b; offset := 0;
while sy <> endsy do
begin (*field section*)
if sy = ident then
begin t0 := t; entervariable;
while sy = comma do
begin insymbol; entervariable
end ;
if sy = colon then insymbol else error(5);
t1 := t;
typ(fsys+[semicolon,endsy,comma,ident],eltp,elrf,elsz);
while t0 < t1 do
begin t0 := t0+1;
with tab[t0] do
begin typ := eltp; ref := elrf; normal := true;
adr := offset; offset := offset + elsz
end
end
end ;
if sy <> endsy then
begin if sy = semicolon then insymbol else
begin error(14);
if sy = comma then insymbol
end ;
test([ident,endsy,semicolon], fsys, 6)
end
end ;
btab[rf].vsize := offset; sz := offset; btab[rf].psize := 0;
insymbol; level := level-1
end ;
test(fsys, [], 6)
end
end (*typ*) ;
procedure parameterlist; (*formal parameter list*)
var tp: types;
rf, sz, x, t0: integer;
valpar: boolean;
begin insymbol; tp := notyp; rf := 0; sz := 0;
test([ident, varsy], fsys+[rparent], 7);
while sy in [ident,varsy] do
begin if sy <> varsy then valpar := true else
begin insymbol; valpar := false
end ;
t0 := t; entervariable;
while sy = comma do
begin insymbol; entervariable;
end ;
if sy = colon then
begin insymbol;
if sy <> ident then error(2) else
begin x := loc(id); insymbol;
if x <> 0 then
with tab[x] do
if obj <> type1 then error(29) else
begin tp := typ; rf := ref;
if valpar then sz := adr else sz := 1
end ;
end ;
test([semicolon,rparent], [comma,ident]+fsys, 14)
end
else error(5);
while t0 < t do
begin t0 := t0+1;
with tab[t0] do
begin typ := tp; ref := rf;
normal := valpar; adr := dx; lev := level;
dx := dx + sz
end
end ;
if sy <> rparent then
begin if sy = semicolon then insymbol else
begin error(14);
if sy = comma then insymbol
end ;
test([ident,varsy], [rparent]+fsys, 6)
end
end (*while*) ;
if sy = rparent then
begin insymbol;
test([semicolon,colon], fsys, 6)
end
else error(4)
end (*parameterlist*) ;
procedure constantdeclaration;
var c: conrec;
begin insymbol;
test([ident], blockbegsys, 2);
while sy = ident do
begin enter(id,konstant); insymbol;
if sy = eql then insymbol else
begin error(16);
if sy = becomes then insymbol
end ;
constant([semicolon,comma,ident]+fsys,c);
tab[t].typ := c.tp; tab[t].ref := 0;
if c.tp = reals then
begin enterreal(c.r); tab[t].adr := c1 end
else tab[t].adr := c.i;
testsemicolon
end
end (*constantdeclaration*) ;
procedure typedeclaration;
var tp: types; rf, sz, t1: integer;
begin insymbol;
test([ident], blockbegsys, 2);
while sy = ident do
begin enter(id,type1); t1 := t; insymbol;
if sy = eql then insymbol else
begin error(16);
if sy = becomes then insymbol
end ;
typ([semicolon,comma,ident]+fsys, tp, rf, sz);
with tab[t1] do
begin typ := tp; ref := rf; adr := sz
end ;
testsemicolon
end
end (*typedeclaration*) ;
procedure variabledeclaration;
var t0, t1, rf, sz: integer;
tp: types;
begin insymbol;
while sy = ident do
begin t0 := t; entervariable;
while sy = comma do
begin insymbol; entervariable;
end ;
if sy = colon then insymbol else error(5);
t1 := t;
typ([semicolon,comma,ident]+fsys, tp, rf, sz);
while t0 < t1 do
begin t0 := t0+1;
with tab[t0] do
begin typ := tp; ref := rf;
lev := level; adr := dx; normal := true;
dx := dx + sz
end
end ;
testsemicolon
end
end (*variabledeclaration*) ;
procedure procdeclaration;
var isfun: boolean;
begin isfun := sy = functionsy; insymbol;
if sy <> ident then
begin error(2); id := ' '
end ;
if isfun then enter(id,funktion) else enter(id,prozedure);
tab[t].normal := true;
insymbol; block([semicolon]+fsys, isfun, level+1);
if sy = semicolon then insymbol else error(14);
emit(32+ord(isfun)) (*exit*)
end (*proceduredeclaration*) ;
(*---------------------------------------------------------statement--*)
procedure statement(fsys: symset);
var i: integer;
procedure expression(fsys: symset; var x: item); forward;
procedure selector(fsys: symset; var v:item);
var x: item; a,j: integer;
begin (*sy in [lparent, lbrack, period]*)
repeat
if sy = period then
begin insymbol; (*field selector*)
if sy <> ident then error(2) else
begin
if v.typ <> records then error(31) else
begin (*search field identifier*)
j := btab[v.ref] .last; tab[0].name := id;
while tab[j].name <> id do j := tab[j].link;
if j = 0 then error(0);
v.typ := tab[j].typ; v.ref := tab[j].ref;
a := tab[j].adr; if a <> 0 then emit1(9,a)
end ;
insymbol
end
end else
begin (*array selector*)
if sy <> lbrack then error(11);
repeat insymbol;
expression(fsys+[comma,rbrack], x);
if v.typ <> arrays then error(28) else
begin a := v.ref;
if atab[a].inxtyp <> x.typ then error(26) else
if atab[a].elsize = 1 then emit1(20,a) else emit1(21,a);
v.typ := atab[a].eltyp; v.ref := atab[a].elref
end
until sy <> comma;
if sy = rbrack then insymbol else
begin error(12); if sy = rparent then insymbol
end
end
until not (sy in [lbrack,lparent,period]);
test(fsys, [], 6)
end (*selector*) ;
procedure call(fsys: symset; i: integer);
var x: item;
lastp, cp, k: integer;
begin emit1(18,i); (*mark stack*)
lastp := btab[tab[i].ref].lastpar; cp := i;
if sy = lparent then
begin (*actual parameter list*)
repeat insymbol;
if cp >= lastp then error(39) else
begin cp := cp+1;
if tab[cp].normal then
begin (*value parameter*)
expression(fsys+[comma,colon,rparent], x);
if x.typ=tab[cp].typ then
begin
if x.ref <> tab[cp].ref then error(36) else
if x.typ = arrays then emit1(22,atab[x.ref].size) else
if x.typ = records then emit1(22,btab[x.ref].vsize)
end else
if (x.typ=ints) and (tab[cp].typ=reals) then
emit1(26,0) else
if x.typ<>notyp then error(36);
end else
begin (*variable parameter*)
if sy <> ident then error(2) else
begin k := loc(id); insymbol;
if k <> 0 then
begin if tab[k].obj <> variable then error(37);
x.typ := tab[k].typ; x.ref := tab[k].ref;
if tab[k].normal then emit2(0,tab[k].lev,tab[k].adr)
else emit2(1,tab[k].lev,tab[k].adr);
if sy in [lbrack,lparent,period] then
selector(fsys+[comma,colon,rparent], x);
if (x.typ<>tab[cp].typ) or (x.ref<>tab[cp].ref) then
error(36)
end
end
end
end ;
test([comma,rparent], fsys, 6)
until sy <> comma;
if sy = rparent then insymbol else error(4)
end ;
if cp < lastp then error(39); (*too few actual parameters*)
emit1(19, btab[tab[i].ref].psize-1);
if tab[i].lev < level then emit2(3, tab[i].lev, level)
end (*call*) ;
function resulttype(a,b: types): types;
begin
if (a>reals) or (b>reals) then
begin error(33); resulttype := notyp
end else
if (a=notyp) or (b=notyp) then resulttype := notyp else
if a=ints then
if b=ints then resulttype := ints else
begin resulttype := reals; emit1(26,1)
end
else
begin resulttype := reals;
if b=ints then emit1(26,0)
end
end (*resulttype*) ;
procedure expression;
var y:item; op:symbol;
procedure simpleexpression(fsys:symset; var x:item);
var y:item; op:symbol;
procedure term(fsys:symset; var x:item);
var y:item; op:symbol;
procedure factor(fsys:symset; var x:item);
var i,f: integer;
procedure standfct(n: integer);
var ts: typset;
begin (*standard function no. n*)
if sy = lparent then insymbol else error(9);
if n < 17 then
begin expression(fsys+[rparent],x);
case n of
(*abs,sqr*) 0,2: begin ts := [ints,reals]; tab[i].typ := x.typ;
if x.typ = reals then n := n+1
end ;
(*odd,chr*) 4,5: ts := [ints];
(*ord*) 6: begin
if x.typ = ints then n := 19;
ts := [ints,bools,chars];
end;
(*succ,pred*) 7,8: ts := [chars];
(*round,trunc*) 9,10,11,12,13,14,15,16:
(*sin,cos,...*) begin ts := [ints,reals];
if x.typ = ints then emit1(26,0)
end ;
end ;
if x.typ in ts then emit1(8,n) else
if x.typ <> notyp then error(48);
end else
(*eof,eoln*) begin (*n in [17,18]*)
if sy <> ident then error(2) else
if id <> 'input ' then error(0) else insymbol;
emit1(8,n);
end ;
x.typ := tab[i].typ;
if sy = rparent then insymbol else error(4)
end (*standfct*) ;
begin (*factor*) x.typ := notyp; x.ref := 0;
test(facbegsys, fsys, 58);
while sy in facbegsys do
begin
if sy = ident then
begin i := loc(id); insymbol;
with tab[i] do
case obj of
konstant: begin x.typ := typ; x.ref := 0;
case x.typ of
ints: emit1(24,adr);
reals: emit1(25,adr);
bools: emit1(64,adr);
chars: emit1(65,adr);
end;
end ;
variable: begin x.typ := typ; x.ref := ref;
if sy in [lbrack,lparent,period] then
begin if normal then f := 0 else f := 1;
emit2(f, lev, adr);
selector(fsys,x);
if x.typ in stantyps then emit(34)
end else
begin
if x.typ in stantyps then
if normal then f := 1 else f := 2
else
if normal then f := 0 else f := 1;
emit2(f, lev, adr)
end
end ;
type1, prozedure: error(44);
funktion :begin x.typ := typ;
if lev <> 0 then call(fsys, i)
else standfct(adr)
end
end (*case,with*)
end else
if sy in [charcon,intcon,realcon] then
begin
if sy = realcon then
begin x.typ := reals; enterreal(rnum);
emit1(25, c1)
end else
begin
if sy = charcon then begin
x.typ := chars;
emit1(65, inum);
end else begin
x.typ := ints;
emit1(24, inum);
end;
end ;
x.ref := 0; insymbol
end else
if sy = lparent then
begin insymbol; expression(fsys+[rparent], x);
if sy = rparent then insymbol else error(4)
end else
if sy = notsy then
begin insymbol; factor(fsys,x);
if x.typ=bools then emit(35) else
if x.typ<>notyp then error(32)
end ;
test(fsys, facbegsys, 6)
end (*while*)
end (*factor*) ;
begin (*term*)
factor(fsys+[times,rdiv,idiv,imod,andsy], x);
while sy in [times,rdiv,idiv,imod,andsy] do
begin op := sy; insymbol;
factor(fsys+[times,rdiv,idiv,imod,andsy], y);
if op = times then
begin x.typ := resulttype(x.typ, y.typ);
case x.typ of
notyp: ;
ints : emit(57);
reals: emit(60);
end
end else
if op = rdiv then
begin
if x.typ = ints then
begin emit1(26,1); x.typ := reals
end ;
if y.typ = ints then
begin emit1(26,0); y.typ := reals
end ;
if (x.typ=reals) and (y.typ=reals) then emit(61) else
begin if (x.typ<>notyp) and (y.typ<>notyp) then
error(33);
x.typ := notyp
end
end else
if op = andsy then
begin if (x.typ=bools) and (y.typ=bools) then
emit(56) else
begin if (x.typ<>notyp) and (y.typ<>notyp) then
error(32);
x.typ := notyp
end
end else
begin (*op in [idiv,imod]*)
if (x.typ=ints) and (y.typ=ints) then
if op=idiv then emit(58)
else emit(59) else
begin if (x.typ<>notyp) and (y.typ<>notyp) then
error(34);
x.typ := notyp
end
end
end
end (*term*) ;
begin (*simpleexpression*)
if sy in [plus,minus] then
begin op := sy; insymbol;
term(fsys+[plus,minus], x);
if x.typ > reals then error(33) else
if op = minus then
if x.typ = reals then
emit(66)
else
emit(36)
end else
term(fsys+[plus,minus,orsy], x);
while sy in [plus,minus,orsy] do
begin op := sy; insymbol;
term(fsys+[plus,minus,orsy], y);
if op = orsy then
begin
if (x.typ=bools) and (y.typ=bools) then emit(51) else
begin if (x.typ<>notyp) and (y.typ<>notyp) then
error(32);
x.typ := notyp
end
end else
begin x.typ := resulttype(x.typ, y.typ);
case x.typ of
notyp: ;
ints : if op = plus then emit(52)
else emit(53);
reals: if op = plus then emit(54)
else emit(55)
end
end
end
end (*simpleexpression*) ;
begin (*expression*)
simpleexpression(fsys+[eql,neq,lss,leq,gtr,geq], x);
if sy in [eql,neq,lss,leq,gtr,geq] then
begin op := sy; insymbol;
simpleexpression(fsys, y);
if (x.typ in [ notyp,ints,bools,chars]) and (x.typ = y.typ) then
case op of
eql: emit(45);
neq: emit(46);
lss: emit(47);
leq: emit(48);
gtr: emit(49);
geq: emit(50);
end else
begin if x.typ = ints then
begin x.typ := reals; emit1(26,1)
end else
if y.typ = ints then
begin y.typ := reals; emit1(26,0)
end ;
if (x.typ=reals) and (y.typ=reals) then
case op of
eql: emit(39);
neq: emit(40);
lss: emit(41);
leq: emit(42);
gtr: emit(43);
geq: emit(44);
end
else error(35)
end ;
x.typ := bools
end
end (*expression*) ;
procedure assignment(lv,ad: integer);
var x,y: item; f: integer;
(*tab[i].obj in [variable,prozedure]*)
begin x.typ := tab[i].typ; x.ref := tab[i].ref;
if tab[i].normal then f := 0 else f := 1;
emit2(f, lv, ad);
if sy in [lbrack,lparent,period] then
selector([becomes,eql]+fsys, x);
if sy = becomes then insymbol else
begin error(51); if sy = eql then insymbol
end ;
expression(fsys, y);
if x.typ = y.typ then
if x.typ in stantyps then emit(38) else
if x.ref <> y.ref then error(46) else
if x.typ = arrays then emit1(23, atab[x.ref].size)
else emit1(23, btab[x.ref].vsize)
else
if (x.typ=reals) and (y.typ=ints) then
begin emit1(26,0); emit(38)
end else
if (x.typ<>notyp) and (y.typ<>notyp) then error(46)
end (*assignment*) ;
procedure compoundstatement;
begin insymbol;
statement([semicolon,endsy]+fsys);
while sy in [semicolon]+statbegsys do
begin if sy = semicolon then insymbol else error(14);
statement([semicolon,endsy]+fsys)
end ;
if sy = endsy then insymbol else error(57)
end (*compoundstatemenet*) ;
procedure ifstatement;
var x: item; lc1,lc2: integer;
begin insymbol;
expression(fsys+[thensy,dosy], x);
if not (x.typ in [bools,notyp]) then error(17);
lc1 := lc; emit(11); (*jmpc*)
if sy = thensy then insymbol else
begin error(52); if sy = dosy then insymbol
end ;
statement(fsys+[elsesy]);
if sy = elsesy then
begin insymbol; lc2 := lc; emit(10);
code[lc1].y := lc; statement(fsys); code[lc2].y := lc
end
else code[lc1].y := lc
end (*ifstatement*) ;
procedure casestatement;
var x: item;
i,j,k,lc1: integer;
casetab: array [1..csmax] of
packed record val, lc: index end ;
exittab: array [1..csmax] of integer;
procedure caselabel;
var lab: conrec; k: integer;
begin constant(fsys+[comma,colon], lab);
if lab.tp <> x.typ then error(47) else
if i = csmax then fatal(6) else
begin i := i+1; k := 0;
casetab[i].val := lab.i; casetab[i].lc := lc;
repeat k := k+1 until casetab[k].val = lab.i;
if k < i then error(1); (*multiple definition*)
end
end (*caselabel*) ;
procedure onecase;
begin if sy in constbegsys then
begin caselabel;
while sy = comma do
begin insymbol; caselabel
end ;
if sy = colon then insymbol else error(5);
statement([semicolon,endsy]+fsys);
j := j+1; exittab[j] := lc; emit(10)
end
end (*onecase*) ;
begin insymbol; i := 0; j := 0;
expression(fsys+[ofsy,comma,colon], x);
if not (x.typ in [ints,bools,chars,notyp]) then error(23);
lc1 := lc; emit(12); (*jmpx*)
if sy = ofsy then insymbol else error(8);
onecase;
while sy = semicolon do
begin insymbol; onecase
end ;
code[lc1].y := lc;
for k := 1 to i do
begin emit1(13,casetab[k].val); emit1(13,casetab[k].lc)
end ;
emit1(10,0);
for k := 1 to j do code[exittab[k]].y := lc;
if sy = endsy then insymbol else error(57)
end (*casestatement*) ;
procedure repeatstatement;
var x: item; lc1: integer;
begin lc1 := lc;
insymbol; statement([semicolon,untilsy]+fsys);
while sy in [semicolon]+statbegsys do
begin if sy = semicolon then insymbol else error(14);
statement([semicolon,untilsy]+fsys)
end ;
if sy = untilsy then
begin insymbol; expression(fsys, x);
if not (x.typ in [bools,notyp]) then error(17);
emit1(11,lc1)
end
else error(53)
end (*repeatstatement*) ;
procedure whilestatement;
var x: item; lc1,lc2: integer;
begin insymbol; lc1 := lc;
expression(fsys+[dosy], x);
if not (x.typ in [bools,notyp]) then error(17);
lc2 := lc; emit(11);
if sy = dosy then insymbol else error(54);
statement(fsys); emit1(10,lc1); code[lc2].y := lc
end (*whilestatement*) ;
procedure forstatement;
var cvt: types; x: item;
i,f,lc1,lc2: integer;
begin insymbol;
if sy = ident then
begin i := loc(id); insymbol;
if i = 0 then cvt := ints else
if tab[i].obj = variable then
begin cvt := tab[i].typ;
if not tab[i].normal then error(37) else
emit2(0, tab[i].lev, tab[i].adr);
if not (cvt in [notyp,ints,bools,chars]) then error(18)
end else
begin error(37); cvt := ints
end
end else skip([becomes,tosy,downtosy,dosy]+fsys, 2);
if sy = becomes then
begin insymbol; expression([tosy,downtosy,dosy]+fsys, x);
if x.typ <> cvt then error(19);
end else skip([tosy,downtosy,dosy]+fsys, 51);
f := 14;
if sy in [tosy, downtosy] then
begin if sy = downtosy then f := 16;
insymbol; expression([dosy]+fsys, x);
if x.typ <> cvt then error(19)
end else skip([dosy]+fsys, 55);
lc1 := lc; emit(f);
if sy = dosy then insymbol else error(54);
lc2 := lc; statement(fsys);
emit1(f+1,lc2); code[lc1].y := lc
end (*forstatement*) ;
procedure standproc(n: integer);
var i,f: integer;
x,y: item;
begin
case n of
1,2: begin (*read*)
if not iflag then
begin error(20); iflag := true
end ;
if sy = lparent then
begin
repeat insymbol;
if sy <> ident then error(2) else
begin i := loc(id); insymbol;
if i <> 0 then
if tab[i].obj <> variable then error(37) else
begin x.typ := tab[i].typ; x.ref := tab[i].ref;
if tab[i].normal then f := 0 else f := 1;
emit2(f, tab[i].lev, tab[i].adr);
if sy in [lbrack,lparent,period] then
selector(fsys+[comma,rparent], x);
if x.typ in [ints,reals,chars,notyp] then
emit1(27, ord(x.typ)) else error(40)
end
end ;
test([comma,rparent], fsys, 6);
until sy <> comma;
if sy = rparent then insymbol else error(4)
end ;
if n = 2 then emit(62)
end ;
3,4: begin (*write*)
if sy = lparent then
begin
repeat insymbol;
if sy = string then
begin emit1(24,sleng); emit1(28,inum); insymbol
end else
begin expression(fsys+[comma,colon,rparent], x);
if not (x.typ in stantyps) then error(41);
if sy = colon then
begin insymbol;
expression(fsys+[comma,colon,rparent], y);
if y.typ <> ints then error(43);
if sy = colon then
begin if x.typ <> reals then error(42);
insymbol; expression(fsys+[comma,rparent], y);
if y.typ <> ints then error(43);
emit(37)
end
else emit1(30, ord(x.typ))
end
else emit1(29, ord(x.typ))
end
until sy <> comma;
if sy = rparent then insymbol else error(4)
end ;
if n = 4 then emit(63)
end ;
end (*case*)
end (*standproc*) ;
begin (*statement*)
if sy in statbegsys+[ident] then
case sy of
ident: begin i := loc(id); insymbol;
if i <> 0 then
case tab[i].obj of
konstant, type1: error(45);
variable: assignment(tab[i].lev, tab[i].adr);
prozedure:
if tab[i].lev <> 0 then call(fsys, i)
else standproc(tab[i].adr);
funktion:
if tab[i].ref = display[level] then
assignment(tab[i].lev+1, 0) else error(45)
end
end ;
beginsy: compoundstatement;
ifsy: ifstatement;
casesy: casestatement;
whilesy: whilestatement;
repeatsy: repeatstatement;
forsy: forstatement;
end;
test(fsys, [], 14)
end (*statement*) ;
begin (*block*) dx := 5; prt := t;
if level > lmax then fatal(5);
test([lparent,colon,semicolon], fsys, 7);
enterblock; display[level] := b; prb := b;
tab[prt].typ := notyp; tab[prt].ref := prb;
if sy = lparent then parameterlist;
btab[prb].lastpar := t; btab[prb].psize := dx;
if isfun then
if sy = colon then
begin insymbol; (*function type*)
if sy = ident then
begin x := loc(id); insymbol;
if x <> 0 then
if tab[x].obj <> type1 then error(29) else
if tab[x].typ in stantyps then tab[prt].typ := tab[x].typ
else error(15)
end else skip([semicolon]+fsys, 2)
end else error(5);
if sy = semicolon then insymbol else error(14);
repeat
if sy = constsy then constantdeclaration;
if sy = typesy then typedeclaration;
if sy = varsy then variabledeclaration;
btab[prb].vsize := dx;
while sy in [proceduresy,functionsy] do procdeclaration;
test([beginsy], blockbegsys+statbegsys, 56)
until sy in statbegsys;
tab[prt].adr := lc;
insymbol; statement([semicolon,endsy]+fsys);
while sy in [semicolon]+statbegsys do
begin if sy = semicolon then insymbol else error(14);
statement([semicolon,endsy]+fsys)
end ;
if sy = endsy then insymbol else error(57);
test(fsys+[period], [], 6)
end (*block*) ;