附录A1_附录一程序

附录A1由刀豆文库小编整理，希望给你工作、学习、生活带来方便，猜你可能喜欢“附录一程序”。

附录A-1 PL/0编译程序文本(Pascal)

program pl0(fa,fa1,fa2);(*PL0 compiler with code generation*)

label 99;

const norw=13;(*of reserved words*)txmax=100;(*length of identifier table*)nmax=14;(*max number of digits in numbers*)al=10;(*length of identifiers*)amax=2047;(*maximum addre*)levmax=3;(*max depth of block nesting*)cxmax=200;(*size of code array*)

type symbol=(nul,ident,number,plus,minus,times,slash,oddsym, eql,neq,l,leq,gtr,geq,lparen,rparen,comma, semicolon,period,becomes,beginsym,endsym,ifsym, thensym,whilesym,writesym,readsym,dosym,callsym, constsym,varsym,procsym);alfa= packed array［1..al］ of char;object =(constant,variable,procedur);(*wirth used the word “procedure” there,which won't work!*)symset = set of symbol;fct =(lit, opr,lod,sto, cal, int, jmp, jpc);instruction = packed record f:fct;(*function code*)l:0..levmax;(*level*)a:0..amax;(*displacement addr*)end;(*lit 0,a load constant a opr 0,a execute opr a lod l,a load variable l,a sto l,a store variable l,a cal l,a call procedure a at level l int 0,a increment t-register by a jmp 0,a jump to a jpc 0,a jump conditional to a *)

var fa:text;fa1,fa2:text;listswitch:boolean;(*true set list object code*)ch:char;(*last char read*)sym:symbol;(*last symbol read*)id:alfa;(*last identifier read*)num:integer;(*last number read*)cc:integer;(*character count*)ll:integer;(*line length*)kk:integer;cx:integer;(*code allocation index*)line:array［1..81］ of char;a:alfa;code:array［0..cxmax］ of instruction;word:array［1..norw］ of alfa;wsym:array［1..norw］ of symbol;ym:array［′ ′..′^′］ of symbol;(*wirth uses “arrar［char］” here*)mnemonic:array［fct］ of packed array［1..5］ of char;declbegsys, statbegsys, facbegsys:symset;table:array［0..txmax］ of record name:alfa;case kind:object of constant:(val:integer);variable,procedur:(level,adr,size:integer)(*“size” lacking in original.I think it belongs here*)end;fin,fout:text;fname:alfa;err:integer;

procedure error(n:integer);begin writeln(′****′,′ ′:cc-1,′!′,n:2);writeln(fa1,′****′,′ ′:cc-1,′!′,n:2);err∶=err+1 end(*error*);

procedure getsym;var i,j,k:integer;

procedure getch;begin if cc=ll then begin if eof(fin)then begin write(′program incomplete′);goto 99 end;ll∶=0;cc∶=0;write(cx:4,′ ′);write(fa1,cx:4,′ ′);while not eoln(fin)do begin ll∶=ll+1;read(fin,ch);write(ch);write(fa1,ch);line［ll］∶=ch end;writeln;ll∶=ll+1;read(fin,line［ll］);writeln(fa1);end;cc∶=cc+1;ch∶=line［cc］ end(*getch*);

begin(*getsym*)while ch=′ ′ do getch;if ch in ［′a′..′z′］ then begin(*id or reserved word*)k∶=0;repeat if k=kk then kk∶=k else repeat a［kk］∶=′ ′;kk∶=kk-1 untilkk=k;id∶=a;i∶=1;j∶=norw;repeat k∶=(i+j)div 2;if id= word［k］ then i∶=k+1 until i>j;if i-1 > j then sym∶=wsym［k］ else sym∶=ident end else if ch in ［′0′..′9′］ then begin(*number*)k∶=0;num∶=0;sym∶=number;repeat num∶=10*num+(ord(ch)-ord(′0′));k∶=k+1;getch until not(ch in ［′0′..′9′］);if k>nmax then error(30)end else if ch=′:′ then begin getch;if ch=′=′ then begin sym∶=becomes;getch end else sym∶=nul;end else if ch=′′ then begin getch;if ch=′=′ then begin sym∶=geq;getch end else sym∶=gtr end else begin sym∶=ym［ch］;getch end end(*getsym*);

procedure gen(x:fct;y, z:integer);begin if cx>cxmax then begin write(′program too long′);goto 99 end;with code［cx］ do begin f∶=x;l∶=y;a∶=z end;cx∶=cx+1 end(*gen*);

procedure test(s1,s2:symset;n:integer);begin if not(sym in s1)then begin error(n);s1∶=s1+s2;while not(sym in s1)do getsym end end(*test*);

procedure block(lev,tx:integer;fsys:symset);var dx:integer;(*data allocation index*)tx0:integer;(*initial table index*)cx0:integer;(*initial code index*)

procedure enter(k:object);begin(*enter object into table*)tx∶=tx+1;with table［tx］ do begin name∶=id;kind∶=k;case k of constant: begin if num>amax then begin error(31);num∶=0;end;val∶=num end;variable: begin level∶=lev;adr∶=dx;dx∶=dx+1;end;procedur: level∶=lev end end end(*enter*);

function position(id:alfa):integer;var i:integer;begin(*find identifier in table*)table［0］.name∶=id;i∶=tx;while table［i］.nameid do i∶=i-1;position∶=i end(*position*);

procedure constdeclaration;begin if sym=ident then begin getsym;if sym in ［eql,becomes］ then begin if sym= becomes then error(1);getsym;if sym = number then begin enter(constant);getsym end else error(2)end else error(3)end else error(4)end;(* constdeclaration *)

procedure vardeclaration;begin if sym=ident then begin enter(variable);getsym end else error(4)end(*vardeclaration*);

procedure listcode;var i:integer;begin(*list code generated for this block*)if listswitch then begin for i∶=cx0 to cx-1 do with code［i］ do begin writeln(i,mnemonic［f］:5,l:3,a:5);writeln(fa,i:4,mnemonic［f］:5,l:3,a:5)end;end end(*listcode*);

procedure statement(fsys:symset);var i,cx1,cx2:integer;

procedureexpreion(fsys:symset);var addop:symbol;

procedure term(fsys:symset);var mulop:symbol;

procedure factor(fsys:symset);var i:integer;begin test(facbegsys,fsys,24);while sym in facbegsys do begin if sym=ident then begin i∶=position(id);if i=0 then error(11)else with table［i］ do case kind of constant:gen(lit,0,val);variable:gen(lod,lev-level,adr);procedur:error(21)end;getsym end else if sym=number then begin if num>amax then begin error(31);num∶=0 end;gen(lit,0,num);getsym end else if sym=lparen then begin getsym;expreion(［rparen］+fsys);if sym=rparen then getsym else error(22)end;test(fsys,facbegsys,23)end end(*factor*);

begin(*term*)factor(［times,slash］+fsys);while sym in ［times,slash］ do begin mulop∶=sym;getsym;factor(fsys+［times,slash］);if mulop=times then gen(opr,0,4)else gen(opr,0,5)end end(*term*);

begin(*expreion*)if sym in ［plus,minus］ then begin addop∶=sym;getsym;term(fsys+［plus,minus］);if addop=minus then gen(opr,0,1)end else term(fsys+［plus,minus］);while sym in ［plus,minus］ do begin addop∶=sym;getsym;term(fsys+［plus,minus］);if addop=plus then gen(opr,0,2)else gen(opr,0,3)end end(*expreion*);

procedure condition(fsys:symset);var relop:symbol;begin if sym=oddsym then begin getsym;expreion(fsys);gen(opr,0,6)end else begin expreion(［eql,neq,l,leq,gtr,geq］+fsys);if not(sym in ［eql,neq,l,leq,gtr,geq］)then error(20)else begin relop∶=sym;getsym;expreion(fsys);case relop of eql:gen(opr,0,8);neq:gen(opr,0,9);l:gen(opr,0,10);geq:gen(opr,0,11);gtr:gen(opr,0,12);leq:gen(opr,0,13);end end end end(*condition*);

begin(*statement*)if sym=ident then begin i∶=position(id);if i=0 then error(11)else if table［i］.kindvariable then begin error(12);i∶=0 end;getsym;if sym=becomes then getsym else error(13);expreion(fsys);if i0 then with table［i］ do gen(sto,lev-level,adr)end else if sym=readsym then begin getsym;if symlparen then error(34)else repeat getsym;if sym=ident then i∶=position(id)else i∶=0;if i=0 then error(35)else with table［i］ do begin gen(opr,0,16);gen(sto,lev-level,adr)end;getsym until symcomma;if symrparen then begin error(33);while not(sym in fsys)do getsym end else getsym end else if sym=writesym then begin getsym;if sym=lparen then begin repeat getsym;expreion(［rparen,comma］+fsys);gen(opr,0,14)until symcomma;if symrparen then error(33)else getsym end;gen(opr,0,15)end else if sym=callsym then begin getsym;if symident then error(14)else begin i∶=position(id);if i=0 then error(11)else with table［i］ do if kind=procedur then gen(cal,lev-level,adr)else error(15);getsym end end else if sym=ifsym then begin getsym;condition(［thensym,dosym］+fsys);if sym=thensym then getsym else error(16);cx1∶=cx;gen(jpc,0,0);statement(fsys);code［cx1］.a∶=cx end else if sym=beginsym then begin getsym;statement(［semicolon,endsym］+fsys);while sym in ［semicolon］+statbegsys do begin if sym=semicolon then getsym else error(10);statement(［semicolon,endsym］+fsys)end;if sym=endsym then getsym else error(17)end else if sym=whilesym then begin cx1∶=cx;getsym;condition(［dosym］+fsys);cx2∶=cx;gen(jpc,0,0);if sym=dosym then getsym else error(18);statement(fsys);gen(jmp,0,cx1);code［cx2］.a∶=cx end;test(fsys,［］,19)end(*statement*);

begin(*block*)dx∶=3;tx0∶=tx;table［tx］.adr∶=cx;gen(jmp,0,0);if lev>levmax then error(32);repeat if sym=constsym then begin getsym;repeat constdeclaration;while sym=comma do begin getsym;constdeclaration end;if sym=semicolon then getsym else error(5)until symident end;if sym=varsym then begin getsym;repeat vardeclaration;while sym=comma do begin getsym;vardeclaration end;if sym=semicolon then getsym else error(5)until symident;end;while sym=procsym do begin getsym;if sym=ident then begin enter(procedur);getsym end else error(4);if sym=semicolon then getsym else error(5);block(lev+1,tx,［semicolon］+fsys);if sym=semicolon then begin getsym;test(statbegsys+［ident,procsym］,fsys,6);end else error(5)end;test(statbegsys+［ident］,declbegsys,7)until not(sym in declbegsys);code［table［tx0］.adr］.a∶=cx;with table［tx0］ do begin adr∶=cx;size∶=dx;end;cx0∶=cx;gen(int,0,dx);statement(［semicolon,endsym］+fsys);gen(opr,0,0);test(fsys,［］,8);listcode end(*block*);

procedure interpret;const stacksize = 500;var p,b,t:integer;(*program base topstack registers*)i:instruction;s:array［1..stacksize］ of integer;(*datastore*)

function base(l:integer): integer;var b1:integer;begin b1∶=b;(*find base l level down*)while l>0 do begin b1∶=s［b1］;l∶=l-1 end;base∶=b1 end(*base*);begin writeln(′start pl0′);t∶=0;b∶=1;p∶=0;s［1］∶=0;s［2］∶=0;s［3］∶=0;repeat i∶=code［p］;p∶=p+1;with i do case f of lit: begin t∶=t+1;s［t］∶=a end;opr: case a of(*operator*)0: begin(*return*)t∶=b-1;p∶=s［t+3］;b∶=s［t+2］ end;1: s［t］∶=-s［t］;2: begin t∶=t-1;s［t］∶=s［t］+s［t+1］ end;3: begin t∶=t-1;s［t］∶=s［t］-s［t+1］ end;4: begin t∶=t-1;s［t］∶=s［t］*s［t+1］ end;5: begin t∶=t-1;s［t］∶=s［t］ div s［t+1］ end;6: s［t］∶=ord(odd(s［t］));8: begin t∶=t-1;s［t］∶=ord(s［t］=s［t+1］)end;9: begin t∶=t-1;s［t］∶=ord(s［t］s［t+1］)end;10: begin t∶=t-1;s［t］∶=ord(s［t］=s［t+1］)end;12: begin t∶=t-1;s［t］∶=ord(s［t］>s［t+1］)end;13: begin t∶=t-1;s［t］∶=ord(s［t］

begin(*main*)for ch∶=′ ′ to ′!′ do ym［ch］∶=nul;(*changed because of different character set note the typos below in the original where the alfas were not given the correct space*)word［1］∶=′begin′;word［2］∶=′call ′;word［3］∶=′const′;word［4］∶=′do ′;

word［5］∶=′end′;word［6］∶=′if ′;

word［7］∶=′odd ′;word［8］∶=′procedur e ′;word［9］∶=′read′;word［10］∶=′then ′;word［11］∶=′var ′;word［12］∶=′while ′;word［13］∶=′write ′;

wsym［1］∶=beginsym;wsym［2］∶=callsym;wsym［3］∶=constsym;wsym［4］∶=dosym;wsym［5］∶=endsym;wsym［6］∶=ifsym;wsym［7］∶=oddsym;wsym［8］∶=procsym;wsym［9］∶=readsym;wsym［10］∶=thensym;wsym［11］∶=varsym;wsym［12］∶=whilesym;wsym［13］∶=writesym;

ym［′+′］∶=plus;ym［′-′］∶=minus;ym［′*′］∶=times;ym［′/′］∶=slash;ym［′(′］∶=lparen;ym［′)′］∶=rparen;ym［′=′］∶=eql;ym［′,′］∶=comma;ym［′.′］∶=period;ym［′#′］∶=neq;ym［′;′］∶=semicolon;

mnemonic［lit］∶=′lit′;mnemonic［opr］∶ =′o pr′;mnemonic［lod］∶=′lod′;mnemonic［sto］∶= ′sto ′;mnemonic［cal］∶=′cal′;mnemonic［int］∶= ′int ′;mnemonic［jmp］∶=′jmp′;mnemonic［jpc］∶= ′jpc ′;

declbegsys∶=［constsym,varsym,procsym］;statbegsys∶=［beginsym,callsym,ifsym,whilesym］;facbegsys∶=［ident,number,lparen］;

(*page(output)*)rewrite(fa1);write(′input file?′);write(fa1,′input file? ′);readln(fname);writeln(fa1,fname);openf(fin,fname,′r′);write(′list object code?′);readln(fname);write(fa1,′list object code?′);listswitch∶=(fname［1］=′y′);err∶=0;cc∶=0;cx∶=0;ll∶=0;ch∶=′ ′;kk∶=al;getsym;rewrite(fa);rewrite(fa2);block(0,0,［period］+declbegsys+statbegsys);closef(fa);closef(fa1);if symperiod then error(9);if err=0 then interpret else write(′errors in pl/0 program′);99: closef(fin);writeln end.