{if next line is included the compiler itself is written in standard pascal}
{#define STANDARD 1}
+{if next line is included, the compiler won't generate static exchanges}
+#define NO_EXC 1
+
{Author: Johan Stevenson Version: 32}
{$l- : no source line numbers}
{$r- : no subrange checking}
{$s+ : test conformancy to standard}
#endif
-program pem(input,em,errors);
+program pem(input,output,em,errors);
{/*
This Pascal compiler produces EM code as described in
- A.S.Tanenbaum, J.W.Stevenson & H. van Staveren,
lp= ^labl;
bp= ^blockinfo;
np= ^nameinfo;
+#ifdef NO_EXC
+ mp= ^mmark;
+ op= ^outrec;
+#endif NO_EXC
{set types}
sos= set of symbol;
otherwise dlbno of label information}
end;
+#ifdef NO_EXC
+ outrec=record
+ next:op; {chain of records}
+ bytes:array[1..16] of byte;
+ cnt:0..16;
+ end;
+
+ mmark=record
+ next:mp; {chain of marks}
+ count,where:integer;
+ end;
+#endif NO_EXC
{-------------------------------------------------------------------}
var {the most frequent used externals are declared first}
sy:symbol; {last symbol}
em:file of byte; {the EM code}
errors:text; {the compilation errors}
source:fnarr;
+#ifdef NO_EXC
+ ohead: op; {head of outrec list}
+ mhead: mp; {head of marks list}
+ bcnt: integer;
+#define newmark setmark
+#define relmark(xx) freemark(xx)
+#else not NO_EXC
+#define newmark lino
+#define relmark(xx)
+#endif NO_EXC
{===================================================================}
{===================================================================}
+#ifdef NO_EXC
+procedure newoutrec;
+var p:op;
+begin
+ new(p);
+ bcnt := bcnt+1;
+ with p^ do begin cnt := 0; next := ohead end;
+ ohead := p
+end;
+
+procedure put1(b:byte);
+begin
+ if mhead = nil then write(em,b)
+ else begin
+ if ohead^.cnt = 16 then newoutrec;
+ with ohead^ do
+ begin cnt := cnt + 1; bytes[cnt] := b end
+ end
+end;
+#else not NO_EXC
procedure put1(b:byte);
begin write(em,b) end;
+#endif NO_EXC
procedure put2(i:integer);
var i1,i2:byte;
procedure laedlb(d:integer);
begin genop(op_lae); argdlb(d) end;
+#ifdef NO_EXC
+procedure reloutrec;
+var i,j,k:integer;
+ q, r, p:op;
+ m : mp;
+begin p := ohead; q := p;
+ if mhead <> nil then
+ begin
+ m := mhead; while m^.next <> nil do m := m^.next;
+ k := (bcnt - m^.where) + 1
+ end
+ else begin k := 0; ohead := nil; bcnt := 0 end;
+ for i := 1 to k do begin q := p; p := p^.next end;
+ if q <> p then q^.next := nil;
+ if p <> nil then
+ begin r := nil;
+ while p <> nil do
+ begin q := p^.next; p^.next := r; r := p; p := q end;
+ while r <> nil do with r^ do
+ begin
+ for j := 1 to cnt do write(em, bytes[j]);
+ r := next
+ end
+ end
+end;
+
+function setmark:integer;
+var p:mp; nm:boolean;
+begin nm := false;
+ if mhead <> nil then with mhead^ do
+ if (where = bcnt) and (ohead^.cnt = 0) then
+ begin count := count + 1; nm := true end;
+ if not nm then
+ begin new(p); newoutrec;
+ with p^ do
+ begin where := bcnt; count := 1; next := mhead end;
+ mhead := p;
+ end;
+ setmark := bcnt
+end;
+
+procedure freemark(m : integer);
+var p, q : mp;
+begin assert(mhead <> nil); p := mhead; q := p;
+ while p^.where <> m do
+ begin q := p; p := p^.next; assert(p <> nil) end;
+ with p^ do
+ begin assert(count > 0); count := count - 1; if count = 0 then
+ begin
+ if p = mhead then begin mhead := next; reloutrec end
+ else q^.next := next
+ end
+end end;
+
+procedure exchange(n,m:integer);
+var i:integer;
+ p,q,r:op;
+begin assert(m >= n);
+ if n <> m then
+ begin
+ p := ohead;
+ for i := bcnt downto m+1 do p := p^.next;
+ q := p;
+ for i := m downto n+1 do q := q^.next;
+ r := ohead; ohead := p^.next; p^.next := q^.next; q^.next := r
+ end
+end;
+#else not NO_EXC
procedure exchange(l1,l2:integer);
var d1,d2:integer;
begin d1:=l2-l1; d2:=lino-l2;
if (d1<>0) and (d2<>0) then
begin gencst(ps_exc,d1); argcst(d2) end
end;
+#endif NO_EXC
procedure newilb(i:integer);
begin lino:=lino+1;
procedure callnonstandard(fsys:sos; moreargs:boolean; fip:ip);
var nxt,lip:ip; l0,l1,l2,l3,sz:integer; lsp,savasp:sp;
begin with a do begin
- l0:=lino; l1:=l0; sz:=0; nxt:=fip^.parhead;
+ l0:=newmark; l1:=newmark; sz:=0; nxt:=fip^.parhead;
while moreargs do
begin
if nxt=nil then
else {call by reference}
begin variable(fsys); loadaddr; sz:=sz+sz_addr;
if samesect in nxt^.iflag then lsp:=savasp else
- begin savasp:=asp; l2:=lino;
+ begin savasp:=asp; l2:=newmark;
while formof(lsp,[carray])
and formof(asp,[arrays,carray]) do
if (compat(lsp^.inxtype,asp^.inxtype) > subeq) or
(lsp^.sflag<>asp^.sflag) then errasp(+0142) else
- begin l3:=lino; descraddr(asp^.arpos); exchange(l2,l3);
+ begin l3:=newmark; descraddr(asp^.arpos); exchange(l2,l3);
+ relmark(l3);
sz:=sz+sz_addr; asp:=asp^.aeltype; lsp:=lsp^.aeltype
- end
+ end;
+ relmark(l2)
end;
if not eqstruct(asp,lsp) then errasp(+0143);
if packbit then errasp(+0144);
end;
nxt:=nxt^.next
end;
- exchange(l0,l1); l1:=lino; moreargs:=find3(comma,fsys,+0145)
+ exchange(l0,l1);
+ relmark(l1);
+ l1:=newmark; moreargs:=find3(comma,fsys,+0145)
end;
+ relmark(l0); relmark(l1);
if nxt<>nil then error(+0146);
inita(procptr,0); pos:=fip^.pfpos;
if fip^.pfkind=formal then
end end;
procedure callrw(fsys:sos; lpar,w,ln:boolean);
-var l1,l2,errno:integer; ftype,lsp,fsp:sp; savlb:integer; m:libmnem;
-begin with b do begin savlb:=reglb; ftype:=textptr;
+var l1,l2,errno:integer; ftype,lsp,fsp:sp; (* savlb:integer;*) m:libmnem;
+begin with b do begin (* savlb:=reglb; *) ftype:=textptr;
inita(textptr,argv[ord(w)].ad); a.pos.lv:=0; fa:=a;
if lpar then
- begin l1:=lino; if w then expression(fsys+[colon1]) else variable(fsys);
- l2:=lino;
+ begin l1:=newmark; if w then expression(fsys+[colon1]) else variable(fsys);
+ l2:=newmark;
if formof(a.asp,[files]) then
begin ftype:=a.asp;
if (a.ak<>fixed) and (a.ak<>pfixed) then
begin if iop[w]=nil then error(+0155);
if w then callw(fsys,l1,l2) else callr(l1,l2)
end;
+ relmark(l1); relmark(l2);
while find3(comma,fsys,+0156) do with a do
- begin l1:=lino;
+ begin l1:=newmark;
if w then expression(fsys+[colon1]) else variable(fsys);
- l2:=lino;
+ l2:=newmark;
if ftype=textptr then
if w then callw(fsys,l1,l2) else callr(l1,l2)
else
begin errno:=+0157; fsp:=ftype^.filtype;
if w then force(fsp,errno) else
- begin store; lsp:=asp; l2:=lino end;
+ begin store; lsp:=asp; relmark(l2); l2 := newmark end;
fileaddr; gensp(WDW,sz_addr); gencst(op_lfr,sz_addr);
ak:=ploaded; packbit:=true; asp:=fsp;
if w then store else
begin force(lsp,errno); exchange(l1,l2) end;
fileaddr; if w then m:=PUTX else m:=GETX; gensp(m,sz_addr)
- end
+ end;
+ relmark(l1); relmark(l2);
end;
end
else
begin if ftype<>textptr then error(+0160);
fileaddr; if w then m:=WLN else m:=RLN; gensp(m,sz_addr)
end;
- reglb:=savlb
+ (* reglb:=savlb *)
end end;
procedure callnd(fsys:sos);
es:
expandnullset(fsp);
li,ri,rl,se:
- begin l2:=lino; lsp:=asp; asp:=fsp;
- convert(lsp,l1); exchange(l1,l2); asp:=lsp
+ begin l2:=newmark; lsp:=asp; asp:=fsp;
+ convert(lsp,l1); exchange(l1,l2); relmark(l2); asp:=lsp
end;
noteq:
errasp(+0184);
varpart:=false; ncst:=0; asp:=nullset;
for i:=1 to ncsw do cstpart[i]:=[];
if find2([notsy..lparent],fsys,+0189) then
- repeat l1:=lino;
+ repeat l1:=newmark;
setexpr(fsys+[colon2,comma],cst1,val1); cst12:=cst1;
if find3(colon2,fsys+[comma,notsy..lparent],+0190) then
begin setexpr(fsys+[comma,notsy..lparent],cst2,val2);
begin
if cst2 then gencst(op_loc,val2);
if cst1 then
- begin l2:=lino; gencst(op_loc,val1); exchange(l1,l2) end;
- l2:=lino; genasp(op_zer); exchange(l1,l2);
+ begin l2:=newmark; gencst(op_loc,val1); exchange(l1,l2);
+ relmark(l2);
+ end;
+ l2:=newmark; genasp(op_zer); exchange(l1,l2);
+ relmark(l2);
genasp(op_loc); gensp(BTS,3*sz_word)
end;
end
end
else
if varpart then genasp(op_ior) else varpart:=true;
+ relmark(l1);
until endofloop(fsys,[notsy..lparent],comma,+0191); {+0192}
ak:=loaded;
if ncst>0 then
procedure term(fsys:sos);
var lsy:symbol; lsp:sp; l1:integer; first:boolean;
-begin with a,b do begin first:=true; l1:=lino;
+begin with a,b do begin first:=true;
factor(fsys+[starsy..andsy]);
while find2([starsy..andsy],fsys,+0197) do
begin if first then begin load; first:=false end;
- lsy:=sy; insym; l1:=lino; lsp:=asp;
+ lsy:=sy; insym; l1:=newmark; lsp:=asp;
factor(fsys+[starsy..andsy]); load; convert(lsp,l1);
if asp<>nil then
case lsy of
end;
andsy:
if asp=boolptr then genasp(op_and) else errasp(+0202);
- end {case}
+ end; {case}
+ relmark(l1)
end {while}
end end;
procedure simpleexpression(fsys:sos);
var lsy:symbol; lsp:sp; l1:integer; signed,min,first:boolean;
-begin with a do begin l1:=lino; first:=true;
+begin with a do begin first:=true;
signed:=(sy=plussy) or (sy=minsy);
if signed then begin min:=sy=minsy; insym end else min:=false;
term(fsys + [minsy,plussy,orsy]); lsp:=desub(asp);
begin load; first:=false; asp:=lsp; negate end;
while find2([plussy,minsy,orsy],fsys,+0204) do
begin if first then begin load; first:=false end;
- lsy:=sy; insym; l1:=lino; lsp:=asp;
+ lsy:=sy; insym; l1:=newmark; lsp:=asp;
term(fsys+[minsy,plussy,orsy]); load; convert(lsp,l1);
if asp<>nil then
case lsy of
else errasp(+0206);
orsy:
if asp=boolptr then genasp(op_ior) else errasp(+0207);
- end {case}
+ end; {case}
+ relmark(l1)
end {while}
end end;
procedure expression; { fsys:sos }
var lsy:symbol; lsp:sp; l1,l2:integer;
-begin with a do begin l1:=lino;
+begin with a do begin l1:=newmark;
simpleexpression(fsys+[eqsy..insy]);
if find2([eqsy..insy],fsys,+0208) then
- begin lsy:=sy; insym; lsp:=asp; loadcheap; l2:=lino;
+ begin lsy:=sy; insym; lsp:=asp; loadcheap; l2:=newmark;
simpleexpression(fsys); loadcheap;
if lsy=insy then
begin
eqsy: genop(op_teq)
end
end;
+ relmark(l2);
asp:=boolptr; ak:=loaded
end;
+ relmark(l1)
end end;
{===================================================================}
procedure assignment(fsys:sos; fip:ip);
var la:attr; l1,l2:integer;
begin
- l1:=lino; selector(fsys+[becomes],fip,[assigned]); l2:=lino;
+ l1:=newmark; selector(fsys+[becomes],fip,[assigned]); l2:=newmark;
la:=a; nextif(becomes,+0216);
expression(fsys); loadcheap; checkasp(la.asp,+0217);
exchange(l1,l2); a:=la;
+ relmark(l1); relmark(l2);
if not formof(la.asp,[arrays..records]) then store else
begin loadaddr;
if la.asp^.form<>carray then genasp(op_blm) else
begin with b do begin
expression(fsys+[ofsy,semicolon,ident..plussy]); lsp:=a.asp; load;
if not nicescalar(desub(lsp)) then begin error(+0223); lsp:=nil end;
- l0:=lino; ilbno:=ilbno+1; ilb1:=ilbno;
+ l0:=newmark; ilbno:=ilbno+1; ilb1:=ilbno;
nextif(ofsy,+0224); head:=nil; max:=-MI2; min:=MI2; n:=0;
repeat ilbno:=ilbno+1; ilb2:=ilbno; {label of current case}
repeat i:=cstinteger(fsys+[comma,colon1,semicolon],lsp,+0225);
nextif(colon1,+0229); newilb(ilb2); statement(fsys+[semicolon]);
gencst(op_bra,ilb1);
until lastsemicolon(fsys,[ident..plussy],+0230); {+0231 +0232}
- assert n<>0; newilb(ilb1); l1:=lino;
+ assert n<>0; newilb(ilb1); l1:=newmark;
dlb:=newdlb; genop(ps_rom); argnil;
if (max div 3) - (min div 3) < n then
begin argcst(min); argcst(max-min);
while head<>nil do
begin argcst(head^.cslab);argilb(head^.csstart);head:=head^.next end;
end;
- argend; laedlb(dlb); gencst(m,sz_word); exchange(l0,l1)
+ argend; laedlb(dlb); gencst(m,sz_word); exchange(l0,l1);
+ relmark(l0); relmark(l1)
end end;
procedure repeatstatement(fsys:sos);
end end;
procedure forstatement(fsys:sos);
-var lip:ip; tosym:boolean; endlab,looplab,savlb:integer;
+var lip:ip; tosym:boolean; endlab,looplab(* ,savlb *):integer;
av,at1,at2:attr; lsp:sp;
procedure forbound(fsys:sos; var fa:attr; fsp:sp);
end
end;
-begin with b do begin savlb:=reglb; tosym:=false;
+begin with b do begin (* savlb:=reglb; *) tosym:=false;
ilbno:=ilbno+1; looplab:=ilbno; ilbno:=ilbno+1; endlab:=ilbno;
inita(nil,0);
if sy<>ident then error(+0240) else
a:=av; load; if tosym then genop(op_inc) else genop(op_dec);
a.asp:=lsp; checkbnds(av.asp); a:=av; store;
gencst(op_bra,looplab); newilb(endlab);
- reglb:=savlb
+ (* reglb:=savlb *)
end end;
procedure withstatement(fsys:sos);
-var lnp,savtop:np; savlb:integer; pbit:boolean;
+var lnp,savtop:np; (* savlb:integer; *) pbit:boolean;
begin with b do begin
- savlb:=reglb; savtop:=top;
+ (* savlb:=reglb;*) savtop:=top;
repeat variable(fsys+[comma,dosy]);
if not formof(a.asp,[records]) then errasp(+0247) else
begin pbit:=spack in a.asp^.sflag;
end;
until endofloop(fsys+[dosy],[ident],comma,+0248); {+0249}
nextif(dosy,+0250); statement(fsys);
- top:=savtop; reglb:=savlb;
+ top:=savtop; (* reglb:=savlb; *)
end end;
procedure assertion(fsys:sos);
{produce PRO}
genpnam(ps_pro,fip); argend;
gencst(ps_mes,ms_par);argcst(fip^.maxlb); argend;
- l0:=lino; dlb:=0; trace('procentr',fip,dlb);
+ l0:=newmark; dlb:=0; trace('procentr',fip,dlb);
{global labels}
llp:=lchain; spset:=false;
while llp<>nil do
{finish and close files}
treewalk(top^.fname);
if level=1 then
- begin l1:=lino;
+ begin l1:=newmark;
genop(op_fil); argdlb(fildlb); {temporarily}
dlb:=newdlb; gencst(ps_con,argc+1);
for i:=0 to argc do with argv[i] do
end;
argend; gencst(op_lxl,0); laedlb(dlb); gencst(op_lae,0);
gencst(op_lxa,0); gensp(INI,4*sz_addr);
- exchange(l0,l1); gencst(op_loc,0); gensp(HLT,0)
+ exchange(l0,l1); relmark(l1); gencst(op_loc,0); gensp(HLT,0)
end
else
begin inita(fip^.idtype,fip^.pfpos.ad);
if fip^.klass=func then
begin load;
if not (assigned in fip^.iflag) then
- errid(-(+0265),fip^.name);
+ errid(-(+0265),fip^.name)
end;
- genasp(op_ret);
+ genasp(op_ret)
end;
- gencst(ps_end,-minlb);
+ relmark(l0);
+ gencst(ps_end,-minlb)
end end;
{===================================================================}
iop[true]:=nil;
argv[0].ad:=-1;
argv[1].ad:=-1;
+#ifdef NO_EXC
+ ohead := nil;
+ bcnt := 0;
+ mhead := nil;
+#endif NO_EXC
end;
procedure init2;
public / ack.git / commitdiff