1 | { Source: http://pascal.hansotten.com/niklaus-wirth/pl0/ }
|
---|
2 |
|
---|
3 | program pl0(input,output);
|
---|
4 | {pl/0 compiler with code generation}
|
---|
5 | label 99;
|
---|
6 | const norw = 11; {no. of reserved words}
|
---|
7 | txmax = 100; {length of identifier table}
|
---|
8 | nmax = 14; {max. no. of digits in numbers}
|
---|
9 | al = 10; {length of identifiers}
|
---|
10 | amax = 2047; {maximum address}
|
---|
11 | levmax = 3; {maximum depth of block nesting}
|
---|
12 | cxmax = 200; {size of code array}
|
---|
13 | type symbol =
|
---|
14 | (nul,ident,number,plus,minus,times,slash,oddsym,
|
---|
15 | eql,neq,lss,leq,gtr,geq,lparen,rparen,comma,semicolon,
|
---|
16 | period,becomes,beginsym,endsym,ifsym,thensym,
|
---|
17 | whilesym,dosym,callsym,constsym,varsym,procsym);
|
---|
18 | alfa = packed array [1..al] of char;
|
---|
19 | object = (constant,varible,proc);
|
---|
20 | symset = set of symbol;
|
---|
21 | fct = (lit,opr,lod,sto,cal,int,jmp,jpc); {functions}
|
---|
22 | instruction = packed record
|
---|
23 | f: fct; {function code}
|
---|
24 | l: 0..levmax; {level}
|
---|
25 | a: 0..amax {displacement address}
|
---|
26 | end;
|
---|
27 | { lit 0,a : load constant a
|
---|
28 | opr 0,a : execute operation a
|
---|
29 | lod l,a : load varible l,a
|
---|
30 | sto l,a : store varible l,a
|
---|
31 | cal l,a : call procedure a at level l
|
---|
32 | int 0,a : increment t-register by a
|
---|
33 | jmp 0,a : jump to a
|
---|
34 | jpc 0,a : jump conditional to a }
|
---|
35 | var ch: char; {last character read}
|
---|
36 | sym: symbol; {last symbol read}
|
---|
37 | id: alfa; {last identifier read}
|
---|
38 | num: integer; {last number read}
|
---|
39 | cc: integer; {character count}
|
---|
40 | ll: integer; {line length}
|
---|
41 | kk, err: integer;
|
---|
42 | cx: integer; {code allocation index}
|
---|
43 | line: array [1..81] of char;
|
---|
44 | a: alfa;
|
---|
45 | code: array [0..cxmax] of instruction;
|
---|
46 | word: array [1..norw] of alfa;
|
---|
47 | wsym: array [1..norw] of symbol;
|
---|
48 | ssym: array [char] of symbol;
|
---|
49 | mnemonic: array [fct] of
|
---|
50 | packed array [1..5] of char;
|
---|
51 | declbegsys, statbegsys, facbegsys: symset;
|
---|
52 | table: array [0..txmax] of
|
---|
53 | record name: alfa;
|
---|
54 | case kind: object of
|
---|
55 | constant: (val: integer);
|
---|
56 | varible, proc: (level, adr: integer)
|
---|
57 | end;
|
---|
58 | procedure error(n: integer);
|
---|
59 | begin writeln(' ****',' ': cc-1, '^',n: 2); err := err+1
|
---|
60 | end {error};
|
---|
61 |
|
---|
62 | procedure getsym;
|
---|
63 | var i,j,k: integer;
|
---|
64 |
|
---|
65 | procedure getch;
|
---|
66 | begin if cc = ll then
|
---|
67 | begin if eof(input) then
|
---|
68 | begin write(' program incomplete'); goto 99
|
---|
69 | end;
|
---|
70 | ll := 0; cc := 0; write(cx: 5,' ');
|
---|
71 | while not eoln(input) do
|
---|
72 | begin ll := ll+1; read(ch); write(ch); line[ll]:=ch
|
---|
73 | end;
|
---|
74 | writeln; readln; ll := ll + 1; line[ll] := ' ';
|
---|
75 | end;
|
---|
76 | cc := cc+1; ch := line[cc]
|
---|
77 | end {getch};
|
---|
78 |
|
---|
79 | begin {getsym}
|
---|
80 | while ch = ' ' do getch;
|
---|
81 | if ch in ['a'..'z'] then
|
---|
82 | begin {identifier or reserved word} k := 0;
|
---|
83 | repeat if k < al then begin k := k+1; a[k] := ch end; getch; until not(ch in ['a'..'z','0'..'9']); if k >= kk then kk := k else
|
---|
84 | repeat a[kk] := ' '; kk := kk-1
|
---|
85 | until kk = k;
|
---|
86 | id := a; i := 1; j := norw;
|
---|
87 | repeat k := (i+j) div 2;
|
---|
88 | if id <= word[k] then j := k-1; if id >= word[k] then i := k+1
|
---|
89 | until i > j;
|
---|
90 | if i-1 > j then sym := wsym[k] else sym := ident
|
---|
91 | end else
|
---|
92 | if ch in ['0'..'9'] then
|
---|
93 | begin {number} k := 0; num := 0; sym := number;
|
---|
94 | repeat num := 10*num + (ord(ch)-ord('0'));
|
---|
95 | k := k+1; getch
|
---|
96 | until not(ch in ['0'..'9']);
|
---|
97 | if k > nmax then error(30)
|
---|
98 | end else
|
---|
99 | if ch = ':' then
|
---|
100 | begin getch;
|
---|
101 | if ch = '=' then
|
---|
102 | begin sym := becomes; getch
|
---|
103 | end else sym := nul;
|
---|
104 | end else
|
---|
105 | begin sym := ssym[ch]; getch
|
---|
106 | end
|
---|
107 | end {getsym};
|
---|
108 |
|
---|
109 | procedure gen(x: fct; y,z: integer);
|
---|
110 | begin if cx > cxmax then
|
---|
111 | begin write(' program too long'); goto 99
|
---|
112 | end;
|
---|
113 | with code[cx] do
|
---|
114 | begin f := x; l := y; a := z
|
---|
115 | end;
|
---|
116 | cx := cx + 1
|
---|
117 | end {gen};
|
---|
118 |
|
---|
119 | procedure test(s1,s2: symset; n: integer);
|
---|
120 | begin if not(sym in s1) then
|
---|
121 | begin error(n); s1 := s1 + s2;
|
---|
122 | while not(sym in s1) do getsym
|
---|
123 | end
|
---|
124 | end {test};
|
---|
125 |
|
---|
126 | procedure block(lev,tx: integer; fsys: symset);
|
---|
127 | var dx: integer; {data allocation index}
|
---|
128 | tx0: integer; {initial table index}
|
---|
129 | cx0: integer; {initial code index}
|
---|
130 | procedure enter(k: object);
|
---|
131 | begin {enter object into table}
|
---|
132 | tx := tx + 1;
|
---|
133 | with table[tx] do
|
---|
134 | begin name := id; kind := k;
|
---|
135 | case k of
|
---|
136 | constant: begin if num > amax then
|
---|
137 | begin error(30); num :=0 end;
|
---|
138 | val := num
|
---|
139 | end;
|
---|
140 | varible: begin level := lev; adr := dx; dx := dx + 1;
|
---|
141 | end;
|
---|
142 | proc: level := lev
|
---|
143 | end
|
---|
144 | end
|
---|
145 | end {enter};
|
---|
146 |
|
---|
147 | function position(id: alfa): integer;
|
---|
148 | var i: integer;
|
---|
149 | begin {find indentifier id in table}
|
---|
150 | table[0].name := id; i := tx;
|
---|
151 | while table[i].name <> id do i := i-1;
|
---|
152 | position := i
|
---|
153 | end {position};
|
---|
154 |
|
---|
155 | procedure constdeclaration;
|
---|
156 | begin if sym = ident then
|
---|
157 | begin getsym;
|
---|
158 | if sym in [eql, becomes] then
|
---|
159 | begin if sym = becomes then error(1);
|
---|
160 | getsym;
|
---|
161 | if sym = number then
|
---|
162 | begin enter(constant); getsym
|
---|
163 | end
|
---|
164 | else error(2)
|
---|
165 | end else error(3)
|
---|
166 | end else error(4)
|
---|
167 | end {constdeclaration};
|
---|
168 |
|
---|
169 | procedure vardeclaration;
|
---|
170 | begin if sym = ident then
|
---|
171 | begin enter(varible); getsym
|
---|
172 | end else error(4)
|
---|
173 | end {vardeclaration};
|
---|
174 |
|
---|
175 | procedure listcode;
|
---|
176 | var i: integer;
|
---|
177 | begin {list code generated for this block}
|
---|
178 | for i := cx0 to cx-1 do
|
---|
179 | with code[i] do
|
---|
180 | writeln(i:5, mnemonic[f]:5, 1:3, a:5)
|
---|
181 | end {listcode};
|
---|
182 |
|
---|
183 | procedure statement(fsys: symset);
|
---|
184 | var i, cx1, cx2: integer;
|
---|
185 | procedure expression(fsys: symset);
|
---|
186 | var addop: symbol;
|
---|
187 | procedure term(fsys: symset);
|
---|
188 | var mulop: symbol;
|
---|
189 | procedure factor(fsys: symset);
|
---|
190 | var i: integer;
|
---|
191 | begin test(facbegsys, fsys, 24);
|
---|
192 | while sym in facbegsys do
|
---|
193 | begin
|
---|
194 | if sym = ident then
|
---|
195 | begin i:= position(id);
|
---|
196 | if i = 0 then error(11) else
|
---|
197 | with table[i] do
|
---|
198 | case kind of
|
---|
199 | constant: gen(lit, 0, val);
|
---|
200 | varible: gen(lod, lev-level, adr);
|
---|
201 | proc: error(21)
|
---|
202 | end;
|
---|
203 | getsym
|
---|
204 | end else
|
---|
205 | if sym = number then
|
---|
206 | begin if num > amax then
|
---|
207 | begin error(30); num := 0
|
---|
208 | end;
|
---|
209 | gen(lit, 0, num); getsym
|
---|
210 | end else
|
---|
211 | if sym = lparen then
|
---|
212 | begin getsym; expression([rparen]+fsys);
|
---|
213 | if sym = rparen then getsym else error(22)
|
---|
214 | end;
|
---|
215 | test(fsys, [lparen], 23)
|
---|
216 | end
|
---|
217 | end {factor};
|
---|
218 |
|
---|
219 | begin {term} factor(fsys+[times, slash]);
|
---|
220 | while sym in [times, slash] do
|
---|
221 | begin mulop:=sym;getsym;factor(fsys+[times,slash]);
|
---|
222 | if mulop=times then gen(opr,0,4) else gen(opr,0,5)
|
---|
223 | end
|
---|
224 | end {term};
|
---|
225 | begin {expression}
|
---|
226 | if sym in [plus, minus] then
|
---|
227 | begin addop := sym; getsym; term(fsys+[plus,minus]);
|
---|
228 | if addop = minus then gen(opr, 0,1)
|
---|
229 | end else term(fsys+[plus, minus]);
|
---|
230 | while sym in [plus, minus] do
|
---|
231 | begin addop := sym; getsym; term(fsys+[plus,minus]);
|
---|
232 | if addop=plus then gen(opr,0,2) else gen(opr,0,3)
|
---|
233 | end
|
---|
234 | end {expression};
|
---|
235 |
|
---|
236 | procedure condition(fsys: symset);
|
---|
237 | var relop: symbol;
|
---|
238 | begin
|
---|
239 | if sym = oddsym then
|
---|
240 | begin getsym; expression(fsys); gen(opr, 0, 6)
|
---|
241 | end else
|
---|
242 | begin expression([eql, neq, lss, gtr, leq, geq]+fsys);
|
---|
243 | if not(sym in [eql, neq, lss, leq, gtr, geq]) then
|
---|
244 | error(20) else
|
---|
245 | begin relop := sym; getsym; expression(fsys);
|
---|
246 | case relop of
|
---|
247 | eql: gen(opr, 0, 8);
|
---|
248 | neq: gen(opr, 0, 9);
|
---|
249 | lss: gen(opr, 0, 10);
|
---|
250 | geq: gen(opr, 0, 11);
|
---|
251 | gtr: gen(opr, 0, 12);
|
---|
252 | leq: gen(opr, 0, 13);
|
---|
253 | end
|
---|
254 | end
|
---|
255 | end
|
---|
256 | end {condition};
|
---|
257 |
|
---|
258 | begin {statement}
|
---|
259 | if sym = ident then
|
---|
260 | begin i := position(id);
|
---|
261 | if i = 0 then error(11) else
|
---|
262 | if table[i].kind <> varible then
|
---|
263 | begin {assignment to non-varible} error(12); i := 0
|
---|
264 | end;
|
---|
265 | getsym; if sym = becomes then getsym else error(13);
|
---|
266 | expression(fsys);
|
---|
267 | if i <> 0 then
|
---|
268 | with table[i] do gen(sto, lev-level, adr)
|
---|
269 | end else
|
---|
270 | if sym = callsym then
|
---|
271 | begin getsym;
|
---|
272 | if sym <> ident then error(14) else
|
---|
273 | begin i := position(id);
|
---|
274 | if i = 0 then error(11) else
|
---|
275 | with table[i] do
|
---|
276 | if kind=proc then gen(cal, lev-level, adr)
|
---|
277 | else error(15);
|
---|
278 | getsym
|
---|
279 | end
|
---|
280 | end else
|
---|
281 | if sym = ifsym then
|
---|
282 | begin getsym; condition([thensym, dosym]+fsys);
|
---|
283 | if sym = thensym then getsym else error(16);
|
---|
284 | cx1 := cx; gen(jpc, 0, 0);
|
---|
285 | statement(fsys); code[cx1].a := cx
|
---|
286 | end else
|
---|
287 | if sym = beginsym then
|
---|
288 | begin getsym; statement([semicolon, endsym]+fsys);
|
---|
289 | while sym in [semicolon]+statbegsys do
|
---|
290 | begin
|
---|
291 | if sym = semicolon then getsym else error(10);
|
---|
292 | statement([semicolon, endsym]+fsys)
|
---|
293 | end;
|
---|
294 | if sym = endsym then getsym else error(17)
|
---|
295 | end else
|
---|
296 | if sym = whilesym then
|
---|
297 | begin cx1 := cx; getsym; condition([dosym]+fsys);
|
---|
298 | cx2 := cx; gen(jpc, 0, 0);
|
---|
299 | if sym = dosym then getsym else error(18);
|
---|
300 | statement(fsys); gen(jmp, 0, cx1); code[cx2].a := cx
|
---|
301 | end;
|
---|
302 | test(fsys, [], 19)
|
---|
303 | end {statement};
|
---|
304 |
|
---|
305 | begin {block} dx:=3; tx0:=tx; table[tx].adr:=cx; gen(jmp,0,0);
|
---|
306 | if lev > levmax then error(32);
|
---|
307 | repeat
|
---|
308 | if sym = constsym then
|
---|
309 | begin getsym;
|
---|
310 | repeat constdeclaration;
|
---|
311 | while sym = comma do
|
---|
312 | begin getsym; constdeclaration
|
---|
313 | end;
|
---|
314 | if sym = semicolon then getsym else error(5)
|
---|
315 | until sym <> ident
|
---|
316 | end;
|
---|
317 | if sym = varsym then
|
---|
318 | begin getsym;
|
---|
319 | repeat vardeclaration;
|
---|
320 | while sym = comma do
|
---|
321 | begin getsym; vardeclaration
|
---|
322 | end;
|
---|
323 | if sym = semicolon then getsym else error(5)
|
---|
324 | until sym <> ident;
|
---|
325 | end;
|
---|
326 | while sym = procsym do
|
---|
327 | begin getsym;
|
---|
328 | if sym = ident then
|
---|
329 | begin enter(proc); getsym
|
---|
330 | end
|
---|
331 | else error(4);
|
---|
332 | if sym = semicolon then getsym else error(5);
|
---|
333 | block(lev+1, tx, [semicolon]+fsys);
|
---|
334 | if sym = semicolon then
|
---|
335 | begin getsym;test(statbegsys+[ident,procsym],fsys,6)
|
---|
336 | end
|
---|
337 | else error(5)
|
---|
338 | end;
|
---|
339 | test(statbegsys+[ident], declbegsys, 7)
|
---|
340 | until not(sym in declbegsys);
|
---|
341 | code[table[tx0].adr].a := cx;
|
---|
342 | with table[tx0] do
|
---|
343 | begin adr := cx; {start adr of code}
|
---|
344 | end;
|
---|
345 | cx0 := 0{cx}; gen(int, 0, dx);
|
---|
346 | statement([semicolon, endsym]+fsys);
|
---|
347 | gen(opr, 0, 0); {return}
|
---|
348 | test(fsys, [], 8);
|
---|
349 | listcode;
|
---|
350 | end {block};
|
---|
351 |
|
---|
352 | procedure interpret;
|
---|
353 | const stacksize = 500;
|
---|
354 | var p,b,t: integer; {program-, base-, topstack-registers}
|
---|
355 | i: instruction; {instruction register}
|
---|
356 | s: array [1..stacksize] of integer; {datastore}
|
---|
357 | function base(l: integer): integer;
|
---|
358 | var b1: integer;
|
---|
359 | begin b1 := b; {find base l levels down}
|
---|
360 | while l > 0 do
|
---|
361 | begin b1 := s[b1]; l := l - 1
|
---|
362 | end;
|
---|
363 | base := b1
|
---|
364 | end {base};
|
---|
365 |
|
---|
366 | begin writeln(' start pl/0');
|
---|
367 | t := 0; b := 1; p := 0;
|
---|
368 | s[1] := 0; s[2] := 0; s[3] := 0;
|
---|
369 | repeat i := code[p]; p := p + 1;
|
---|
370 | with i do
|
---|
371 | case f of
|
---|
372 | lit: begin t := t + 1; s[t] := a
|
---|
373 | end;
|
---|
374 | opr: case a of {operator}
|
---|
375 | 0: begin {return}
|
---|
376 | t := b - 1; p := s[t + 3]; b := s[t + 2];
|
---|
377 | end;
|
---|
378 | 1: s[t] := -s[t];
|
---|
379 | 2: begin t := t - 1; s[t] := s[t] + s[t + 1]
|
---|
380 | end;
|
---|
381 | 3: begin t := t - 1; s[t] := s[t] - s[t + 1]
|
---|
382 | end;
|
---|
383 | 4: begin t := t - 1; s[t] := s[t] * s[t + 1]
|
---|
384 | end;
|
---|
385 | 5: begin t := t - 1; s[t] := s[t] div s[t + 1]
|
---|
386 | end;
|
---|
387 | 6: s[t] := ord(odd(s[t]));
|
---|
388 | 8: begin t := t - 1; s[t] := ord(s[t] = s[t + 1])
|
---|
389 | end;
|
---|
390 | 9: begin t := t - 1; s[t] := ord(s[t] <> s[t + 1])
|
---|
391 | end;
|
---|
392 | 10: begin t := t - 1; s[t] := ord(s[t] < s[t + 1]) end; 11: begin t := t - 1; s[t] := ord(s[t] >= s[t + 1])
|
---|
393 | end;
|
---|
394 | 12: begin t := t - 1; s[t] := ord(s[t] > s[t + 1])
|
---|
395 | end;
|
---|
396 | 13: begin t := t - 1; s[t] := ord(s[t] <= s[t + 1])
|
---|
397 | end;
|
---|
398 | end;
|
---|
399 | lod: begin t := t + 1; s[t] := s[base(l) + a]
|
---|
400 | end;
|
---|
401 | sto: begin s[base(l)+a] := s[t]; writeln(s[t]); t := t - 1
|
---|
402 | end;
|
---|
403 | cal: begin {generate new block mark}
|
---|
404 | s[t + 1] := base(l); s[t + 2] := b; s[t + 3] := p;
|
---|
405 | b := t + 1; p := a
|
---|
406 | end;
|
---|
407 | int: t := t + a;
|
---|
408 | jmp: p := a;
|
---|
409 | jpc: begin if s[t] = 0 then p := a; t := t - 1
|
---|
410 | end
|
---|
411 | end {with, case}
|
---|
412 | until p = 0;
|
---|
413 | write(' end pl/0');
|
---|
414 | end {interpret};
|
---|
415 |
|
---|
416 | begin {main program}
|
---|
417 | for ch := chr(0) to chr(255) do ssym[ch] := nul;
|
---|
418 | word[ 1] := 'begin '; word[ 2] := 'call ';
|
---|
419 | word[ 3] := 'const '; word[ 4] := 'do ';
|
---|
420 | word[ 5] := 'end '; word[ 6] := 'if ';
|
---|
421 | word[ 7] := 'odd '; word[ 8] := 'procedure ';
|
---|
422 | word[ 9] := 'then '; word[10] := 'var ';
|
---|
423 | word[11] := 'while ';
|
---|
424 | wsym[ 1] := beginsym; wsym[ 2] := callsym;
|
---|
425 | wsym[ 3] := constsym; wsym[ 4] := dosym;
|
---|
426 | wsym[ 5] := endsym; wsym[ 6] := ifsym;
|
---|
427 | wsym[ 7] := oddsym; wsym[ 8] := procsym;
|
---|
428 | wsym[ 9] := thensym; wsym[10] := varsym;
|
---|
429 | wsym[11] := whilesym;
|
---|
430 | ssym[ '+'] := plus; ssym[ '-'] := minus;
|
---|
431 | ssym[ '*'] := times; ssym[ '/'] := slash;
|
---|
432 | ssym[ '('] := lparen; ssym[ ')'] := rparen;
|
---|
433 | ssym[ '='] := eql; ssym[ ','] := comma;
|
---|
434 | ssym[ '.'] := period; ssym[ '#'] := neq;
|
---|
435 | ssym[ '<'] := lss; ssym[ '>'] := gtr;
|
---|
436 | ssym[ '['] := leq; ssym[ ']'] := geq;
|
---|
437 | ssym[ ';'] := semicolon;
|
---|
438 | mnemonic[lit] := ' lit'; mnemonic[opr] := ' opr';
|
---|
439 | mnemonic[lod] := ' lod'; mnemonic[sto] := ' sto';
|
---|
440 | mnemonic[cal] := ' cal'; mnemonic[int] := ' int';
|
---|
441 | mnemonic[jmp] := ' jmp'; mnemonic[jpc] := ' jpc';
|
---|
442 | declbegsys := [constsym, varsym, procsym];
|
---|
443 | statbegsys := [beginsym, callsym, ifsym, whilesym];
|
---|
444 | facbegsys := [ident, number, lparen];
|
---|
445 | page(output); err := 0;
|
---|
446 | cc := 0; cx := 0; ll := 0; ch := ' '; kk := al; getsym;
|
---|
447 | block(0, 0, [period]+declbegsys+statbegsys);
|
---|
448 | if sym <> period then error(9);
|
---|
449 | if err=0 then interpret else write(' errors in pl/0 program');
|
---|
450 | 99: writeln
|
---|
451 | end.
|
---|