From fc2b415ad39f09d416dee5ebeebede17236c0775 Mon Sep 17 00:00:00 2001 From: Bill Joy Date: Wed, 23 Nov 1977 12:45:18 -0800 Subject: [PATCH] BSD 1 development Work on file pcs/globals.i Work on file pcs/block.i Work on file pcs/interpret.i Synthesized-from: 1bsd --- pcs/block.i | 942 ++++++++++++++++++++++++++++++++++++++++++++++++ pcs/globals.i | 93 +++++ pcs/interpret.i | 312 ++++++++++++++++ 3 files changed, 1347 insertions(+) create mode 100644 pcs/block.i create mode 100644 pcs/globals.i create mode 100644 pcs/interpret.i diff --git a/pcs/block.i b/pcs/block.i new file mode 100644 index 0000000000..ffe1054e95 --- /dev/null +++ b/pcs/block.i @@ -0,0 +1,942 @@ +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*) ; + diff --git a/pcs/globals.i b/pcs/globals.i new file mode 100644 index 0000000000..48bd1fc7bc --- /dev/null +++ b/pcs/globals.i @@ -0,0 +1,93 @@ +label 99; +const nkw = 27; (*no. of key words*) + TAB = tab; + alng = 10; (*no. of significant chars in identifiers*) + llng = 120; (*input line length*) + emax = 322; (*max exponent of real numbers*) + emin =-292; (*min exponent*) + kmax = 15; (*max no. of significant digits*) + tmax = 100; (*size of table*) + bmax = 20; (*size of block-table*) + amax = 30; (*size of array-table*) + c2max = 20; (*size of real constant table*) + csmax = 30; (*max no. of cases*) + cmax = 500; (*size of code*) + lmax = 7; (*maximum level*) + smax = 400; (*size of string-table*) + ermax = 58; (*max error no.*) + omax = 66; (*highest order code*) + xmax = 131071; (*2**17 - 1*) +{ shit, look at this number!!!!! + nmax = 281474976710655; (*2**48-1*) +} + nmax = maxint; + lineleng = 136; (*output line length*) + linelimit = 200; + stacksize = 200; + +type symbol = (intcon,realcon,charcon,string, + notsy,plus,minus,times,idiv,rdiv,imod,andsy,orsy, + eql,neq,gtr,geq,lss,leq, + lparent,rparent,lbrack,rbrack,comma,semicolon,period, + colon,becomes,constsy,typesy,varsy,functionsy, + proceduresy,arraysy,recordsy,programsy,ident, + beginsy,ifsy,casesy,repeatsy,whilesy,forsy, + endsy,elsesy,untilsy,ofsy,dosy,tosy,downtosy,thensy); + + index = -xmax .. +xmax; + alfa = packed array [1..alng] of char; + object = (konstant,variable,type1,prozedure,funktion); + types = (notyp,ints,reals,bools,chars,arrays,records); + symset = set of symbol; + typset = set of types; + item = record + typ: types; ref: index; + end ; + order = packed record + f: -omax..+omax; + x: -lmax..+lmax; + y: -nmax..+nmax; + end ; + +var sy: symbol; (*last symbol read by insymbol*) + id: alfa; (*identifier from insymbol*) + inum: integer; (*integer from insymbol*) + rnum: real; (*real number from insymbol*) + sleng: integer; (*string length*) + ch: char; (*last character read from source program*) + line: array [1..llng] of char; + cc: integer; (*character counter*) + lc: integer; (*program location counter*) + ll: integer; (*length of current line*) + errs: set of 0..ermax; + errpos: integer; + progname: alfa; + iflag, oflag: boolean; + constbegsys,typebegsys,blockbegsys,facbegsys,statbegsys: symset; + key: array [1..nkw] of alfa; + ksy: array [1..nkw] of symbol; + sps: array [char] of symbol; (*special symbols*) + + t,a,b,sx,c1,c2: integer; (*indices to tables*) + stantyps: typset; + display: array [0 .. lmax] of integer; + + tab: array [0 .. tmax] of (*identifier table*) + packed record + name: alfa; link: index; + obj: object; typ: types; + ref: index; normal: boolean; + lev: 0 .. lmax; adr: integer; + end ; + atab: array [1 .. amax] of (*array-table*) + packed record + inxtyp, eltyp: types; + elref, low, high, elsize, size: index; + end ; + btab: array [1 .. bmax] of (*block-table*) + packed record + last, lastpar, psize, vsize: index + end ; + stab: packed array [0..smax] of char; (*string table*) + rconst: array [1 .. c2max] of real; + code: array [0 .. cmax] of order; diff --git a/pcs/interpret.i b/pcs/interpret.i new file mode 100644 index 0000000000..7207590751 --- /dev/null +++ b/pcs/interpret.i @@ -0,0 +1,312 @@ +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*) ; -- 2.20.1