1 {
2 Semantic routines for the Yacc parser.
3
4
5 Copyright (c) 1990-92 Albert Graef <ag@muwiinfa.geschichte.uni-mainz.de>
6 Copyright (C) 1996 Berend de Boer <berend@pobox.com>
7
8 This program is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 2 of the License, or
11 (at your option) any later version.
12
13 This program is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
17
18 You should have received a copy of the GNU General Public License
19 along with this program; if not, write to the Free Software
20 Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
21
22
23 $Revision: 1.2 $
24 $Modtime: 96-08-01 6:03 $
25
26 $History: YACCSEM.PAS $
27 *
28 * ***************** Version 2 *****************
29 * User: Berend Date: 96-10-10 Time: 21:16
30 * Updated in $/Lex and Yacc/tply
31 * Updated for protected mode, windows and Delphi 1.X and 2.X.
32
33 }
34
35
36 unit YaccSem;
37
38 interface
39
40
41 var
42
43 act_prec : Integer;
44 (* active precedence level in token and precedence declarations (0 in
45 %token declaration) *)
46 act_type : Integer;
47 (* active type tag in token, precedence and type declarations *)
48
49 procedure yyerror ( msg : String );
50 (* YaccLib.yyerror redefined to ignore 'syntax error' message; the parser
51 does its own error handling *)
52
symnull53 function sym ( k : Integer ) : Integer;
54 (* returns internal symbol number for the symbol k; if k is yet undefined,
55 a new nonterminal or literal symbol is created, according to the
56 appearance of symbol k (nonterminal if an ordinary identifier, literal
57 otherwise) *)
58
ntsymnull59 function ntsym ( k : Integer ) : Integer;
60 (* like sym, but requires symbol k to be a nonterminal symbol; if it
61 is already defined a literal, an error message is issued, and a dummy
62 nonterminal symbol returned *)
63
litsymnull64 function litsym ( k : Integer; n : Integer ) : Integer;
65 (* same for literal symbols; if n>0 it denotes the literal number to be
66 assigned to the symbol; when a new literal identifier is defined, a
67 corresponding constant definition is also written to the definition
68 file *)
69
70 procedure next_section;
71 (* find next section mark (%%) in code template *)
72
73 procedure definitions;
74 (* if necessary, write out definition of the semantic value type YYSType *)
75
76 procedure copy_code;
77 (* copy Turbo Pascal code section ( %{ ... %} ) to output file *)
78
79 procedure copy_action;
80 (* copy an action to the output file *)
81
82 procedure copy_single_action;
83 (* like copy_action, but action must be single statement terminated
84 with `;' *)
85
86 procedure copy_rest_of_file;
87 (* copies the rest of the source file to the output file *)
88
89 procedure start_rule ( sym : Integer );
90 (* start a new rule with lhs nonterminal symbol sym *)
91
92 procedure start_body;
93 (* start a new rule body (rhs) *)
94
95 procedure end_body;
96 (* end a rule body *)
97
98 procedure add_symbol ( sym : Integer );
99 (* add the denoted symbol to the current rule body *)
100
101 procedure add_action;
102 (* add an action to the current rule body *)
103
104 procedure add_rule_prec ( sym : Integer );
105 (* add the precedence of terminal symbol sym to the current rule *)
106
107 procedure generate_parser;
108 (* generate the parse table *)
109
110 implementation
111
112 uses YaccBase, YaccTabl, YaccClos, YaccLR0, YaccLook,
113 YaccPars, YaccMsgs;
114
115 procedure yyerror ( msg : String );
116 begin
117 if msg='syntax error' then
118 (* ignore *)
119 else
120 fatal(msg)
121 end(*yyerror*);
122
act_charnull123 function act_char : char;
124 begin
125 if cno>length(line) then
126 if eof(yyin) then
127 act_char := #0
128 else
129 act_char := nl
130 else
131 act_char := line[cno]
132 end(*act_char*);
133
lookahead_charnull134 function lookahead_char : char;
135 begin
136 if succ(cno)>length(line) then
137 if eof(yyin) then
138 lookahead_char := #0
139 else
140 lookahead_char := nl
141 else
142 lookahead_char := line[succ(cno)]
143 end(*lookahead_char*);
144
145 procedure next_char;
146 begin
147 if cno>length(line) then
148 if eof(yyin) then
149 { nop }
150 else
151 begin
152 readln(yyin, line);
153 inc(lno); cno := 1
154 end
155 else
156 inc(cno)
157 end(*next_char*);
158
159 var
160
161 (* Current rule: *)
162
163 act_rule : RuleRec;
164
165 (* Actions: *)
166
167 n_act : Integer;
168 p_act : Boolean;
169
symnull170 function sym ( k : Integer ) : Integer;
171 var s : Integer;
172 begin
173 if is_def_key(k, s) then
174 sym := s
175 else if sym_table^[k].pname^[1]='''' then
176 begin
177 s := new_lit;
178 def_key(k, s);
179 sym := s;
180 end
181 else
182 begin
183 s := new_nt;
184 def_key(k, s);
185 sym := s;
186 end
187 end(*sym*);
188
ntsymnull189 function ntsym ( k : Integer ) : Integer;
190 var s : Integer;
191 begin
192 if is_def_key(k, s) then
193 if s<0 then
194 ntsym := s
195 else
196 begin
197 error(nonterm_expected);
198 ntsym := -1;
199 end
200 else if sym_table^[k].pname^[1]='''' then
201 begin
202 error(nonterm_expected);
203 ntsym := -1;
204 end
205 else
206 begin
207 s := new_nt;
208 def_key(k, s);
209 ntsym := s;
210 end
211 end(*ntsym*);
212
litsymnull213 function litsym ( k : Integer; n : Integer ) : Integer;
214 var s : Integer;
215 begin
216 if is_def_key(k, s) then
217 if s>=0 then
218 begin
219 if n>0 then error(double_tokennum_def);
220 litsym := s;
221 end
222 else
223 begin
224 error(literal_expected);
225 litsym := 1;
226 end
227 else if sym_table^[k].pname^[1]='''' then
228 begin
229 if n>0 then
230 begin
231 add_lit(n);
232 s := n;
233 end
234 else
235 s := new_lit;
236 def_key(k, s);
237 litsym := s;
238 end
239 else
240 begin
241 if n>0 then
242 begin
243 add_lit(n);
244 s := n;
245 end
246 else
247 s := new_lit;
248 def_key(k, s);
249 writeln(yyout, 'const ', pname(s), ' = ', s, ';');
250 litsym := s;
251 end;
252 end(*litsym*);
253
254 procedure next_section;
255 var line : String;
256 begin
257 while not eof(yycod) do
258 begin
259 readln(yycod, line);
260 if line='%%' then exit;
261 writeln(yyout, line);
262 end;
263 end(*next_section*);
264
265 procedure definitions;
266 var i : Integer;
267 begin
268 if n_types>0 then
269 begin
270 writeln(yyout);
271 writeln(yyout, 'type YYSType = record case Integer of');
272 for i := 1 to n_types do
273 writeln(yyout, ' ':15, i:3, ' : ( ',
274 'yy', sym_table^[type_table^[i]].pname^, ' : ',
275 sym_table^[type_table^[i]].pname^, ' );');
276 writeln(yyout, ' ':15, 'end(*YYSType*);');
277 end;
278 end(*definitions*);
279
280 procedure copy_code;
281 var str_state : Boolean;
282 begin
283 str_state := false;
284 while act_char<>#0 do
285 if act_char=nl then
286 begin
287 writeln(yyout);
288 next_char;
289 end
290 else if act_char='''' then
291 begin
292 write(yyout, '''');
293 str_state := not str_state;
294 next_char;
295 end
296 else if not str_state and (act_char='%') and (lookahead_char='}') then
297 exit
298 else
299 begin
300 write(yyout, act_char);
301 next_char;
302 end;
303 end(*copy_code*);
304
305 procedure scan_val;
306 (* process a $ value in an action
307 (not very pretty, but it does its job) *)
308 var tag, numstr : String; i, code : Integer;
309 begin
310 tokleng := 0;
311 next_char;
312 if act_char='<' then
313 begin
314 (* process type tag: *)
315 next_char;
316 tag := '';
317 while (act_char<>nl) and (act_char<>#0) and (act_char<>'>') do
318 begin
319 tag := tag+act_char;
320 next_char;
321 end;
322 if act_char='>' then
323 begin
324 if not search_type(tag) then
325 begin
326 tokleng := length(tag);
327 error(unknown_identifier);
328 end;
329 next_char;
330 end
331 else
332 error(syntax_error);
333 end
334 else
335 tag := '';
336 tokleng := 0;
337 if act_char='$' then
338 begin
339 (* left-hand side value: *)
340 write(yyout, 'yyval');
341 (* check for value type: *)
342 if (tag='') and (n_types>0) then with act_rule do
343 if sym_type^[lhs_sym]>0 then
344 tag := sym_table^[sym_type^[lhs_sym]].pname^
345 else
346 begin
347 tokleng := 1;
348 error(type_error);
349 end;
350 if tag<>'' then write(yyout, '.yy', tag);
351 next_char;
352 end
353 else
354 begin
355 (* right-hand side value: *)
356 if act_char='-' then
357 begin
358 numstr := '-';
359 next_char;
360 end
361 else
362 numstr := '';
363 while ('0'<=act_char) and (act_char<='9') do
364 begin
365 numstr := numstr+act_char;
366 next_char;
367 end;
368 if numstr<>'' then
369 begin
370 val(numstr, i, code);
371 if code=0 then
372 if i<=act_rule.rhs_len then
373 begin
374 write(yyout, 'yyv[yysp-', act_rule.rhs_len-i, ']');
375 (* check for value type: *)
376 if (tag='') and (n_types>0) then with act_rule do
377 if i<=0 then
378 begin
379 tokleng := length(numstr)+1;
380 error(type_error);
381 end
382 else if sym_type^[rhs_sym[i]]>0 then
383 tag := sym_table^[sym_type^[rhs_sym[i]]].pname^
384 else
385 begin
386 tokleng := length(numstr)+1;
387 error(type_error);
388 end;
389 if tag<>'' then write(yyout, '.yy', tag);
390 end
391 else
392 begin
393 tokleng := length(numstr);
394 error(range_error);
395 end
396 else
397 error(syntax_error)
398 end
399 else
400 error(syntax_error)
401 end
402 end(*scan_val*);
403
404 procedure copy_action;
405 var str_state : Boolean;
406 begin
407 str_state := false;
408 while act_char=' ' do next_char;
409 write(yyout, ' ':9);
410 while act_char<>#0 do
411 if act_char=nl then
412 begin
413 writeln(yyout);
414 next_char;
415 while act_char=' ' do next_char;
416 write(yyout, ' ':9);
417 end
418 else if act_char='''' then
419 begin
420 write(yyout, '''');
421 str_state := not str_state;
422 next_char;
423 end
424 else if not str_state and (act_char='}') then
425 begin
426 writeln(yyout);
427 exit;
428 end
429 else if not str_state and (act_char='$') then
430 scan_val
431 else
432 begin
433 write(yyout, act_char);
434 next_char;
435 end;
436 end(*copy_action*);
437
438 procedure copy_single_action;
439 var str_state : Boolean;
440 begin
441 str_state := false;
442 while act_char=' ' do next_char;
443 write(yyout, ' ':9);
444 while act_char<>#0 do
445 if act_char=nl then
446 begin
447 writeln(yyout);
448 next_char;
449 while act_char=' ' do next_char;
450 write(yyout, ' ':9);
451 end
452 else if act_char='''' then
453 begin
454 write(yyout, '''');
455 str_state := not str_state;
456 next_char;
457 end
458 else if not str_state and (act_char=';') then
459 begin
460 writeln(yyout, ';');
461 exit;
462 end
463 else if not str_state and (act_char='$') then
464 scan_val
465 else
466 begin
467 write(yyout, act_char);
468 next_char;
469 end;
470 end(*copy_single_action*);
471
472 procedure copy_rest_of_file;
473 begin
474 while act_char<>#0 do
475 if act_char=nl then
476 begin
477 writeln(yyout);
478 next_char;
479 end
480 else
481 begin
482 write(yyout, act_char);
483 next_char;
484 end;
485 end(*copy_rest_of_file*);
486
487 procedure start_rule ( sym : Integer );
488 begin
489 if n_rules=0 then
490 begin
491 (* fix start nonterminal of the grammar: *)
492 if startnt=0 then startnt := sym;
493 (* add augmented start production: *)
494 with act_rule do
495 begin
496 lhs_sym := -1;
497 rhs_len := 2;
498 rhs_sym[1] := startnt;
499 rhs_sym[2] := 0; (* end marker *)
500 end;
501 add_rule(newRuleRec(act_rule));
502 end;
503 act_rule.lhs_sym := sym;
504 end(*start_rule*);
505
506 procedure start_body;
507 begin
508 act_rule.rhs_len := 0;
509 p_act := false;
510 writeln(yyout, n_rules:4, ' : begin');
511 end(*start_body*);
512
513 procedure end_body;
514 begin
515 if not p_act and (act_rule.rhs_len>0) then
516 (* add default action: *)
517 writeln(yyout, ' ':9, 'yyval := yyv[yysp-',
518 act_rule.rhs_len-1, '];');
519 add_rule(newRuleRec(act_rule));
520 writeln(yyout, ' ':7, 'end;');
521 end(*end_body*);
522
523 procedure add_rule_action;
524 (* process an action inside a rule *)
525 var k : Integer; r : RuleRec;
526 begin
527 writeln(yyout, ' ':7, 'end;');
528 inc(n_act);
529 k := get_key('$$'+intStr(n_act));
530 with r do
531 begin
532 lhs_sym := new_nt;
533 def_key(k, lhs_sym);
534 rhs_len := 0;
535 end;
536 with act_rule do
537 begin
538 inc(rhs_len);
539 if rhs_len>max_rule_len then fatal(rule_table_overflow);
540 rhs_sym[rhs_len] := r.lhs_sym;
541 end;
542 add_rule(newRuleRec(r));
543 rule_prec^[n_rules+1] := rule_prec^[n_rules];
544 rule_prec^[n_rules] := 0;
545 writeln(yyout, n_rules:4, ' : begin');
546 end(*add_rule_action*);
547
548 procedure add_symbol ( sym : Integer );
549 begin
550 if p_act then add_rule_action;
551 p_act := false;
552 with act_rule do
553 begin
554 inc(rhs_len);
555 if rhs_len>max_rule_len then fatal(rule_table_overflow);
556 rhs_sym[rhs_len] := sym;
557 if sym>=0 then rule_prec^[n_rules+1] := sym_prec^[sym]
558 end
559 end(*add_symbol*);
560
561 procedure add_action;
562 begin
563 if p_act then add_rule_action;
564 p_act := true;
565 end(*add_action*);
566
567 procedure add_rule_prec ( sym : Integer );
568 begin
569 rule_prec^[n_rules+1] := sym_prec^[sym];
570 end(*add_rule_prec*);
571
572 procedure generate_parser;
573 begin
574 if startnt=0 then error(empty_grammar);
575 if errors=0 then
576 begin
577 write('sort ... ');
578 sort_rules; rule_offsets;
579 write('closures ... ');
580 closures;
581 write('first sets ... ');
582 first_sets;
583 write('LR0 set ... ');
584 LR0Set;
585 write('lookaheads ... ');
586 lookaheads;
587 writeln;
588 write('code generation ... ');
589 parse_table;
590 end;
591 end(*generate_parser*);
592
593 begin
594 n_act := 0;
595 end(*YaccSem*).
596