|
1 # |
|
2 # Module Parse::Yapp::Lalr |
|
3 # |
|
4 # (c) Copyright 1998-2001 Francois Desarmenien, all rights reserved. |
|
5 # (see the pod text in Parse::Yapp module for use and distribution rights) |
|
6 # |
|
7 package Parse::Yapp::Lalr; |
|
8 @ISA=qw( Parse::Yapp::Grammar ); |
|
9 |
|
10 require 5.004; |
|
11 |
|
12 use Parse::Yapp::Grammar; |
|
13 |
|
14 =for nobody |
|
15 |
|
16 Parse::Yapp::Compile Object Structure: |
|
17 -------------------------------------- |
|
18 { |
|
19 GRAMMAR => Parse::Yapp::Grammar, |
|
20 STATES => [ { CORE => [ items... ], |
|
21 ACTIONS => { term => action } |
|
22 GOTOS => { nterm => stateno } |
|
23 }... ] |
|
24 CONFLICTS=>{ SOLVED => { stateno => [ ruleno, token, solved ] }, |
|
25 FORCED => { TOTAL => [ nbsr, nbrr ], |
|
26 DETAIL => { stateno => { TOTAL => [ nbsr, nbrr ] } |
|
27 LIST => [ ruleno, token ] |
|
28 } |
|
29 } |
|
30 } |
|
31 } |
|
32 |
|
33 'items' are of form: [ ruleno, dotpos ] |
|
34 'term' in ACTIONS is '' means default action |
|
35 'action' may be: |
|
36 undef: explicit error (nonassociativity) |
|
37 0 : accept |
|
38 >0 : shift and go to state 'action' |
|
39 <0 : reduce using rule -'action' |
|
40 'solved' may have values of: |
|
41 'shift' if solved as Shift |
|
42 'reduce' if solved as Reduce |
|
43 'error' if solved by discarding both Shift and Reduce (nonassoc) |
|
44 |
|
45 SOLVED is a set of states containing Solved conflicts |
|
46 FORCED are forced conflict resolutions |
|
47 |
|
48 nbsr and nbrr are number of shift/reduce and reduce/reduce conflicts |
|
49 |
|
50 TOTAL is the total number of SR/RR conflicts for the parser |
|
51 |
|
52 DETAIL is the detail of conflicts for each state |
|
53 TOTAL is the total number of SR/RR conflicts for a state |
|
54 LIST is the list of discarded reductions (for display purpose only) |
|
55 |
|
56 |
|
57 =cut |
|
58 |
|
59 use strict; |
|
60 |
|
61 use Carp; |
|
62 |
|
63 ############### |
|
64 # Constructor # |
|
65 ############### |
|
66 sub new { |
|
67 my($class)=shift; |
|
68 |
|
69 ref($class) |
|
70 and $class=ref($class); |
|
71 |
|
72 my($self)=$class->SUPER::new(@_); |
|
73 $self->_Compile(); |
|
74 bless($self,$class); |
|
75 } |
|
76 ########### |
|
77 # Methods # |
|
78 ########### |
|
79 |
|
80 ########################### |
|
81 # Method To View Warnings # |
|
82 ########################### |
|
83 sub Warnings { |
|
84 my($self)=shift; |
|
85 my($text); |
|
86 my($nbsr,$nbrr)=@{$$self{CONFLICTS}{FORCED}{TOTAL}}; |
|
87 |
|
88 $text=$self->SUPER::Warnings(); |
|
89 |
|
90 $nbsr != $$self{GRAMMAR}{EXPECT} |
|
91 and $text.="$nbsr shift/reduce conflict".($nbsr > 1 ? "s" : ""); |
|
92 |
|
93 $nbrr |
|
94 and do { |
|
95 $nbsr |
|
96 and $text.=" and "; |
|
97 $text.="$nbrr reduce/reduce conflict".($nbrr > 1 ? "s" : ""); |
|
98 }; |
|
99 |
|
100 ( $nbsr != $$self{GRAMMAR}{EXPECT} |
|
101 or $nbrr) |
|
102 and $text.="\n"; |
|
103 |
|
104 $text; |
|
105 } |
|
106 ############################# |
|
107 # Method To View DFA States # |
|
108 ############################# |
|
109 sub ShowDfa { |
|
110 my($self)=shift; |
|
111 my($text); |
|
112 my($grammar,$states)=($$self{GRAMMAR}, $$self{STATES}); |
|
113 |
|
114 for my $stateno (0..$#$states) { |
|
115 my(@shifts,@reduces,@errors,$default); |
|
116 |
|
117 $text.="State $stateno:\n\n"; |
|
118 |
|
119 #Dump Kernel Items |
|
120 for (sort { $$a[0] <=> $$b[0] |
|
121 or $$a[1] <=> $$b[1] } @{$$states[$stateno]{'CORE'}}) { |
|
122 my($ruleno,$pos)=@$_; |
|
123 my($lhs,$rhs)=@{$$grammar{RULES}[$ruleno]}[0,1]; |
|
124 my(@rhscopy)=@$rhs; |
|
125 |
|
126 $ruleno |
|
127 or $rhscopy[-1] = '$end'; |
|
128 |
|
129 splice(@rhscopy,$pos,0,'.'); |
|
130 $text.= "\t$lhs -> ".join(' ',@rhscopy)."\t(Rule $ruleno)\n"; |
|
131 } |
|
132 |
|
133 #Prepare Actions |
|
134 for (keys(%{$$states[$stateno]{ACTIONS}})) { |
|
135 my($term,$action)=($_,$$states[$stateno]{ACTIONS}{$_}); |
|
136 |
|
137 $term eq chr(0) |
|
138 and $term = '$end'; |
|
139 |
|
140 not defined($action) |
|
141 and do { |
|
142 push(@errors,$term); |
|
143 next; |
|
144 }; |
|
145 |
|
146 $action > 0 |
|
147 and do { |
|
148 push(@shifts,[ $term, $action ]); |
|
149 next; |
|
150 }; |
|
151 |
|
152 $action = -$action; |
|
153 |
|
154 $term |
|
155 or do { |
|
156 $default= [ '$default', $action ]; |
|
157 next; |
|
158 }; |
|
159 |
|
160 push(@reduces,[ $term, $action ]); |
|
161 } |
|
162 |
|
163 #Dump shifts |
|
164 @shifts |
|
165 and do { |
|
166 $text.="\n"; |
|
167 for (sort { $$a[0] cmp $$b[0] } @shifts) { |
|
168 my($term,$shift)=@$_; |
|
169 |
|
170 $text.="\t$term\tshift, and go to state $shift\n"; |
|
171 } |
|
172 }; |
|
173 |
|
174 #Dump errors |
|
175 @errors |
|
176 and do { |
|
177 $text.="\n"; |
|
178 for my $term (sort { $a cmp $b } @errors) { |
|
179 $text.="\t$term\terror (nonassociative)\n"; |
|
180 } |
|
181 }; |
|
182 |
|
183 #Prepare reduces |
|
184 exists($$self{CONFLICTS}{FORCED}{DETAIL}{$stateno}) |
|
185 and push(@reduces,@{$$self{CONFLICTS}{FORCED}{DETAIL}{$stateno}{LIST}}); |
|
186 |
|
187 @reduces=sort { $$a[0] cmp $$b[0] or $$a[1] <=> $$b[1] } @reduces; |
|
188 |
|
189 defined($default) |
|
190 and push(@reduces,$default); |
|
191 |
|
192 #Dump reduces |
|
193 @reduces |
|
194 and do { |
|
195 $text.="\n"; |
|
196 for (@reduces) { |
|
197 my($term,$ruleno)=@$_; |
|
198 my($discard); |
|
199 |
|
200 $ruleno < 0 |
|
201 and do { |
|
202 ++$discard; |
|
203 $ruleno = -$ruleno; |
|
204 }; |
|
205 |
|
206 $text.= "\t$term\t".($discard ? "[" : ""); |
|
207 if($ruleno) { |
|
208 $text.= "reduce using rule $ruleno ". |
|
209 "($$grammar{RULES}[$ruleno][0])"; |
|
210 } |
|
211 else { |
|
212 $text.='accept'; |
|
213 } |
|
214 $text.=($discard ? "]" : "")."\n"; |
|
215 } |
|
216 }; |
|
217 |
|
218 #Dump gotos |
|
219 exists($$states[$stateno]{GOTOS}) |
|
220 and do { |
|
221 $text.= "\n"; |
|
222 for (keys(%{$$states[$stateno]{GOTOS}})) { |
|
223 $text.= "\t$_\tgo to state $$states[$stateno]{GOTOS}{$_}\n"; |
|
224 } |
|
225 }; |
|
226 |
|
227 $text.="\n"; |
|
228 } |
|
229 $text; |
|
230 } |
|
231 |
|
232 ###################################### |
|
233 # Method to get summary about parser # |
|
234 ###################################### |
|
235 sub Summary { |
|
236 my($self)=shift; |
|
237 my($text); |
|
238 |
|
239 $text=$self->SUPER::Summary(); |
|
240 $text.="Number of states : ". |
|
241 scalar(@{$$self{STATES}})."\n"; |
|
242 $text; |
|
243 } |
|
244 |
|
245 ####################################### |
|
246 # Method To Get Infos about conflicts # |
|
247 ####################################### |
|
248 sub Conflicts { |
|
249 my($self)=shift; |
|
250 my($states)=$$self{STATES}; |
|
251 my($conflicts)=$$self{CONFLICTS}; |
|
252 my($text); |
|
253 |
|
254 for my $stateno ( sort { $a <=> $b } keys(%{$$conflicts{SOLVED}})) { |
|
255 |
|
256 for (@{$$conflicts{SOLVED}{$stateno}}) { |
|
257 my($ruleno,$token,$how)=@$_; |
|
258 |
|
259 $token eq chr(0) |
|
260 and $token = '$end'; |
|
261 |
|
262 $text.="Conflict in state $stateno between rule ". |
|
263 "$ruleno and token $token resolved as $how.\n"; |
|
264 } |
|
265 }; |
|
266 |
|
267 for my $stateno ( sort { $a <=> $b } keys(%{$$conflicts{FORCED}{DETAIL}})) { |
|
268 my($nbsr,$nbrr)=@{$$conflicts{FORCED}{DETAIL}{$stateno}{TOTAL}}; |
|
269 |
|
270 $text.="State $stateno contains "; |
|
271 |
|
272 $nbsr |
|
273 and $text.="$nbsr shift/reduce conflict". |
|
274 ($nbsr > 1 ? "s" : ""); |
|
275 |
|
276 $nbrr |
|
277 and do { |
|
278 $nbsr |
|
279 and $text.=" and "; |
|
280 |
|
281 $text.="$nbrr reduce/reduce conflict". |
|
282 ($nbrr > 1 ? "s" : ""); |
|
283 }; |
|
284 $text.="\n"; |
|
285 }; |
|
286 |
|
287 $text; |
|
288 } |
|
289 |
|
290 ################################# |
|
291 # Method to dump parsing tables # |
|
292 ################################# |
|
293 sub DfaTable { |
|
294 my($self)=shift; |
|
295 my($states)=$$self{STATES}; |
|
296 my($stateno); |
|
297 my($text); |
|
298 |
|
299 $text="[\n\t{"; |
|
300 |
|
301 $text.=join("\n\t},\n\t{", |
|
302 map { |
|
303 my($state)=$_; |
|
304 my($text); |
|
305 |
|
306 $text="#State ".$stateno++."\n\t\t"; |
|
307 |
|
308 ( not exists($$state{ACTIONS}{''}) |
|
309 or keys(%{$$state{ACTIONS}}) > 1) |
|
310 and do { |
|
311 |
|
312 $text.="ACTIONS => {\n\t\t\t"; |
|
313 |
|
314 $text.=join(",\n\t\t\t", |
|
315 map { |
|
316 my($term,$action)=($_,$$state{ACTIONS}{$_}); |
|
317 my($text); |
|
318 |
|
319 if(substr($term,0,1) eq "'") { |
|
320 $term=~s/([\@\$\"])/\\$1/g; |
|
321 $term=~s/^'|'$/"/g; |
|
322 } |
|
323 else { |
|
324 $term= $term eq chr(0) |
|
325 ? "''" |
|
326 : "'$term'"; |
|
327 } |
|
328 |
|
329 if(defined($action)) { |
|
330 $action=int($action); |
|
331 } |
|
332 else { |
|
333 $action='undef'; |
|
334 } |
|
335 |
|
336 "$term => $action"; |
|
337 |
|
338 } grep { $_ } keys(%{$$state{ACTIONS}})); |
|
339 |
|
340 $text.="\n\t\t}"; |
|
341 }; |
|
342 |
|
343 exists($$state{ACTIONS}{''}) |
|
344 and do { |
|
345 keys(%{$$state{ACTIONS}}) > 1 |
|
346 and $text.=",\n\t\t"; |
|
347 |
|
348 $text.="DEFAULT => $$state{ACTIONS}{''}"; |
|
349 }; |
|
350 |
|
351 exists($$state{GOTOS}) |
|
352 and do { |
|
353 $text.=",\n\t\tGOTOS => {\n\t\t\t"; |
|
354 $text.=join(",\n\t\t\t", |
|
355 map { |
|
356 my($nterm,$stateno)=($_,$$state{GOTOS}{$_}); |
|
357 my($text); |
|
358 |
|
359 "'$nterm' => $stateno"; |
|
360 |
|
361 } keys(%{$$state{GOTOS}})); |
|
362 $text.="\n\t\t}"; |
|
363 }; |
|
364 |
|
365 $text; |
|
366 |
|
367 }@$states); |
|
368 |
|
369 $text.="\n\t}\n]"; |
|
370 |
|
371 $text; |
|
372 |
|
373 } |
|
374 |
|
375 |
|
376 #################################### |
|
377 # Method to build Dfa from Grammar # |
|
378 #################################### |
|
379 sub _Compile { |
|
380 my($self)=shift; |
|
381 my($grammar,$states); |
|
382 |
|
383 $grammar=$self->{GRAMMAR}; |
|
384 |
|
385 $states = _LR0($grammar); |
|
386 |
|
387 $self->{CONFLICTS} = _LALR($grammar,$states); |
|
388 |
|
389 $self->{STATES}=$states; |
|
390 } |
|
391 |
|
392 ######################### |
|
393 # LR0 States Generation # |
|
394 ######################### |
|
395 # |
|
396 ########################### |
|
397 # General digraph routine # |
|
398 ########################### |
|
399 sub _Digraph { |
|
400 my($rel,$F)=@_; |
|
401 my(%N,@S); |
|
402 my($infinity)=(~(1<<31)); |
|
403 my($Traverse); |
|
404 |
|
405 $Traverse = sub { |
|
406 my($x,$d)=@_; |
|
407 my($y); |
|
408 |
|
409 push(@S,$x); |
|
410 $N{$x}=$d; |
|
411 |
|
412 exists($$rel{$x}) |
|
413 and do { |
|
414 for $y (keys(%{$$rel{$x}})) { |
|
415 exists($N{$y}) |
|
416 or &$Traverse($y,$d+1); |
|
417 |
|
418 $N{$y} < $N{$x} |
|
419 and $N{$x} = $N{$y}; |
|
420 |
|
421 $$F{$x}|=$$F{$y}; |
|
422 } |
|
423 }; |
|
424 |
|
425 $N{$x} == $d |
|
426 and do { |
|
427 for(;;) { |
|
428 $y=pop(@S); |
|
429 $N{$y}=$infinity; |
|
430 $y eq $x |
|
431 and last; |
|
432 $$F{$y}=$$F{$x}; |
|
433 } |
|
434 }; |
|
435 }; |
|
436 |
|
437 for (keys(%$rel)) { |
|
438 exists($N{$_}) |
|
439 or &$Traverse($_,1); |
|
440 } |
|
441 } |
|
442 ####################### |
|
443 # Generate LR0 states # |
|
444 ####################### |
|
445 =for nobody |
|
446 Formula used for closures: |
|
447 |
|
448 CLOSE(A) = DCLOSE(A) u U (CLOSE(B) | A close B) |
|
449 |
|
450 where: |
|
451 |
|
452 DCLOSE(A) = { [ A -> alpha ] in P } |
|
453 |
|
454 A close B iff [ A -> B gamma ] in P |
|
455 |
|
456 =cut |
|
457 sub _SetClosures { |
|
458 my($grammar)=@_; |
|
459 my($rel,$closures); |
|
460 |
|
461 for my $symbol (keys(%{$$grammar{NTERM}})) { |
|
462 $closures->{$symbol}=pack('b'.@{$$grammar{RULES}}); |
|
463 |
|
464 for my $ruleno (@{$$grammar{NTERM}{$symbol}}) { |
|
465 my($rhs)=$$grammar{RULES}[$ruleno][1]; |
|
466 |
|
467 vec($closures->{$symbol},$ruleno,1)=1; |
|
468 |
|
469 @$rhs > 0 |
|
470 and exists($$grammar{NTERM}{$$rhs[0]}) |
|
471 and ++$rel->{$symbol}{$$rhs[0]}; |
|
472 } |
|
473 } |
|
474 _Digraph($rel,$closures); |
|
475 |
|
476 $closures |
|
477 } |
|
478 |
|
479 sub _Closures { |
|
480 my($grammar,$core,$closures)=@_; |
|
481 my($ruleset)=pack('b'.@{$$grammar{RULES}}); |
|
482 |
|
483 for (@$core) { |
|
484 my($ruleno,$pos)=@$_; |
|
485 my($rhs)=$$grammar{RULES}[$ruleno][1]; |
|
486 |
|
487 $pos < @$rhs |
|
488 and exists($closures->{$$rhs[$pos]}) |
|
489 and $ruleset|=$closures->{$$rhs[$pos]}; |
|
490 } |
|
491 [ @$core, map { [ $_, 0 ] } |
|
492 grep { vec($ruleset,$_,1) } |
|
493 0..$#{$$grammar{RULES}} ]; |
|
494 } |
|
495 |
|
496 sub _Transitions { |
|
497 my($grammar,$cores,$closures,$states,$stateno)=@_; |
|
498 my($core)=$$states[$stateno]{'CORE'}; |
|
499 my(%transitions); |
|
500 |
|
501 for (@{_Closures($grammar,$core,$closures)}) { |
|
502 my($ruleno,$pos)=@$_; |
|
503 my($rhs)=$$grammar{RULES}[$ruleno][1]; |
|
504 |
|
505 $pos == @$rhs |
|
506 and do { |
|
507 push(@{$$states[$stateno]{ACTIONS}{''}},$ruleno); |
|
508 next; |
|
509 }; |
|
510 push(@{$transitions{$$rhs[$pos]}},[ $ruleno, $pos+1 ]); |
|
511 } |
|
512 |
|
513 for (keys(%transitions)) { |
|
514 my($symbol,$core)=($_,$transitions{$_}); |
|
515 my($corekey)=join(',',map { join('.',@$_) } |
|
516 sort { $$a[0] <=> $$b[0] |
|
517 or $$a[1] <=> $$b[1] } |
|
518 @$core); |
|
519 my($tostateno); |
|
520 |
|
521 exists($cores->{$corekey}) |
|
522 or do { |
|
523 push(@$states,{ 'CORE' => $core }); |
|
524 $cores->{$corekey}=$#$states; |
|
525 }; |
|
526 |
|
527 $tostateno=$cores->{$corekey}; |
|
528 push(@{$$states[$tostateno]{FROM}},$stateno); |
|
529 |
|
530 exists($$grammar{TERM}{$_}) |
|
531 and do { |
|
532 $$states[$stateno]{ACTIONS}{$_} = [ $tostateno ]; |
|
533 next; |
|
534 }; |
|
535 $$states[$stateno]{GOTOS}{$_} = $tostateno; |
|
536 } |
|
537 } |
|
538 |
|
539 sub _LR0 { |
|
540 my($grammar)=@_; |
|
541 my($states) = []; |
|
542 my($stateno); |
|
543 my($closures); #$closures={ nterm => ruleset,... } |
|
544 my($cores)={}; # { "itemlist" => stateno, ... } |
|
545 # where "itemlist" has the form: |
|
546 # "ruleno.pos,ruleno.pos" ordered by ruleno,pos |
|
547 |
|
548 $closures = _SetClosures($grammar); |
|
549 push(@$states,{ 'CORE' => [ [ 0, 0 ] ] }); |
|
550 for($stateno=0;$stateno<@$states;++$stateno) { |
|
551 _Transitions($grammar,$cores,$closures,$states,$stateno); |
|
552 } |
|
553 |
|
554 $states |
|
555 } |
|
556 |
|
557 ######################################################### |
|
558 # Add Lookahead tokens where needed to make LALR states # |
|
559 ######################################################### |
|
560 =for nobody |
|
561 Compute First sets for non-terminal using the following formula: |
|
562 |
|
563 FIRST(A) = { a in T u { epsilon } | A l a } |
|
564 u |
|
565 U { FIRST(B) | B in V and A l B } |
|
566 |
|
567 where: |
|
568 |
|
569 A l x iff [ A -> X1 X2 .. Xn x alpha ] in P and Xi =>* epsilon, 1 <= i <= n |
|
570 =cut |
|
571 sub _SetFirst { |
|
572 my($grammar,$termlst,$terminx)=@_; |
|
573 my($rel,$first)=( {}, {} ); |
|
574 |
|
575 for my $symbol (keys(%{$$grammar{NTERM}})) { |
|
576 $first->{$symbol}=pack('b'.@$termlst); |
|
577 |
|
578 RULE: |
|
579 for my $ruleno (@{$$grammar{NTERM}{$symbol}}) { |
|
580 my($rhs)=$$grammar{RULES}[$ruleno][1]; |
|
581 |
|
582 for (@$rhs) { |
|
583 exists($terminx->{$_}) |
|
584 and do { |
|
585 vec($first->{$symbol},$terminx->{$_},1)=1; |
|
586 next RULE; |
|
587 }; |
|
588 ++$rel->{$symbol}{$_}; |
|
589 exists($$grammar{NULLABLE}{$_}) |
|
590 or next RULE; |
|
591 } |
|
592 vec($first->{$symbol},0,1)=1; |
|
593 } |
|
594 } |
|
595 _Digraph($rel,$first); |
|
596 |
|
597 $first |
|
598 } |
|
599 |
|
600 sub _Preds { |
|
601 my($states,$stateno,$len)=@_; |
|
602 my($queue, $preds); |
|
603 |
|
604 $len |
|
605 or return [ $stateno ]; |
|
606 |
|
607 $queue=[ [ $stateno, $len ] ]; |
|
608 while(@$queue) { |
|
609 my($pred) = shift(@$queue); |
|
610 my($stateno, $len) = @$pred; |
|
611 |
|
612 $len == 1 |
|
613 and do { |
|
614 push(@$preds,@{$states->[$stateno]{FROM}}); |
|
615 next; |
|
616 }; |
|
617 |
|
618 push(@$queue, map { [ $_, $len - 1 ] } |
|
619 @{$states->[$stateno]{FROM}}); |
|
620 } |
|
621 |
|
622 # Pass @$preds through a hash to ensure unicity |
|
623 [ keys( %{ +{ map { ($_,1) } @$preds } } ) ]; |
|
624 } |
|
625 |
|
626 sub _FirstSfx { |
|
627 my($grammar,$firstset,$termlst,$terminx,$ruleno,$pos,$key)=@_; |
|
628 my($first)=pack('b'.@$termlst); |
|
629 my($rhs)=$$grammar{RULES}[$ruleno][1]; |
|
630 |
|
631 for (;$pos < @$rhs;++$pos) { |
|
632 exists($terminx->{$$rhs[$pos]}) |
|
633 and do { |
|
634 vec($first,$terminx->{$$rhs[$pos]},1)=1; |
|
635 return($first); |
|
636 }; |
|
637 $first|=$firstset->{$$rhs[$pos]}; |
|
638 |
|
639 vec($first,0,1) |
|
640 and vec($first,0,1)=0; |
|
641 |
|
642 exists($$grammar{NULLABLE}{$$rhs[$pos]}) |
|
643 or return($first); |
|
644 |
|
645 } |
|
646 vec($first,0,1)=1; |
|
647 $first; |
|
648 } |
|
649 |
|
650 =for noboby |
|
651 Compute Follow sets using following formula: |
|
652 |
|
653 FOLLOW(p,A) = READ(p,A) |
|
654 u |
|
655 U { FOLLOW(q,B) | (p,A) include (q,B) |
|
656 |
|
657 where: |
|
658 |
|
659 READ(p,A) = U { FIRST(beta) | [ A -> alpha A . beta ] in KERNEL(GOTO(p,A)) |
|
660 } - { epsilon } |
|
661 |
|
662 (p,a) include (q,B) iff [ B -> alpha A . beta ] in KERNEL(GOTO(p,A), |
|
663 epsilon in FIRST(beta) and |
|
664 q in PRED(p,alpha) |
|
665 =cut |
|
666 sub _ComputeFollows { |
|
667 my($grammar,$states,$termlst)=@_; |
|
668 my($firstset,$terminx); |
|
669 my($inconsistent, $rel, $follows, $sfx)= ( {}, {}, {}, {} ); |
|
670 |
|
671 %$terminx= map { ($termlst->[$_],$_) } 0..$#$termlst; |
|
672 |
|
673 $firstset=_SetFirst($grammar,$termlst,$terminx); |
|
674 |
|
675 for my $stateno (0..$#$states) { |
|
676 my($state)=$$states[$stateno]; |
|
677 |
|
678 exists($$state{ACTIONS}{''}) |
|
679 and ( @{$$state{ACTIONS}{''}} > 1 |
|
680 or keys(%{$$state{ACTIONS}}) > 1 ) |
|
681 and do { |
|
682 ++$inconsistent->{$stateno}; |
|
683 |
|
684 for my $ruleno (@{$$state{ACTIONS}{''}}) { |
|
685 my($lhs,$rhs)=@{$$grammar{RULES}[$ruleno]}[0,1]; |
|
686 |
|
687 for my $predno (@{_Preds($states,$stateno,scalar(@$rhs))}) { |
|
688 ++$rel->{"$stateno.$ruleno"}{"$predno.$lhs"}; |
|
689 } |
|
690 } |
|
691 }; |
|
692 |
|
693 exists($$state{GOTOS}) |
|
694 or next; |
|
695 |
|
696 for my $symbol (keys(%{$$state{GOTOS}})) { |
|
697 my($tostate)=$$states[$$state{GOTOS}{$symbol}]; |
|
698 my($goto)="$stateno.$symbol"; |
|
699 |
|
700 $follows->{$goto}=pack('b'.@$termlst); |
|
701 |
|
702 for my $item (@{$$tostate{'CORE'}}) { |
|
703 my($ruleno,$pos)=@$item; |
|
704 my($key)="$ruleno.$pos"; |
|
705 |
|
706 exists($sfx->{$key}) |
|
707 or $sfx->{$key} = _FirstSfx($grammar,$firstset, |
|
708 $termlst,$terminx, |
|
709 $ruleno,$pos,$key); |
|
710 |
|
711 $follows->{$goto}|=$sfx->{$key}; |
|
712 |
|
713 vec($follows->{$goto},0,1) |
|
714 and do { |
|
715 my($lhs)=$$grammar{RULES}[$ruleno][0]; |
|
716 |
|
717 vec($follows->{$goto},0,1)=0; |
|
718 |
|
719 for my $predno (@{_Preds($states,$stateno,$pos-1)}) { |
|
720 ++$rel->{$goto}{"$predno.$lhs"}; |
|
721 } |
|
722 }; |
|
723 } |
|
724 } |
|
725 } |
|
726 _Digraph($rel,$follows); |
|
727 |
|
728 ($follows,$inconsistent) |
|
729 } |
|
730 |
|
731 sub _ComputeLA { |
|
732 my($grammar,$states)=@_; |
|
733 my($termlst)= [ '',keys(%{$$grammar{TERM}}) ]; |
|
734 |
|
735 my($follows,$inconsistent) = _ComputeFollows($grammar,$states,$termlst); |
|
736 |
|
737 for my $stateno ( keys(%$inconsistent ) ) { |
|
738 my($state)=$$states[$stateno]; |
|
739 my($conflict); |
|
740 |
|
741 #NB the sort is VERY important for conflicts resolution order |
|
742 for my $ruleno (sort { $a <=> $b } |
|
743 @{$$state{ACTIONS}{''}}) { |
|
744 for my $term ( map { $termlst->[$_] } grep { |
|
745 vec($follows->{"$stateno.$ruleno"},$_,1) } |
|
746 0..$#$termlst) { |
|
747 exists($$state{ACTIONS}{$term}) |
|
748 and ++$conflict; |
|
749 push(@{$$state{ACTIONS}{$term}},-$ruleno); |
|
750 } |
|
751 } |
|
752 delete($$state{ACTIONS}{''}); |
|
753 $conflict |
|
754 or delete($inconsistent->{$stateno}); |
|
755 } |
|
756 |
|
757 $inconsistent |
|
758 } |
|
759 |
|
760 ############################# |
|
761 # Solve remaining conflicts # |
|
762 ############################# |
|
763 |
|
764 sub _SolveConflicts { |
|
765 my($grammar,$states,$inconsistent)=@_; |
|
766 my(%rulesprec,$RulePrec); |
|
767 my($conflicts)={ SOLVED => {}, |
|
768 FORCED => { TOTAL => [ 0, 0 ], |
|
769 DETAIL => {} |
|
770 } |
|
771 }; |
|
772 |
|
773 $RulePrec = sub { |
|
774 my($ruleno)=@_; |
|
775 my($rhs,$rprec)=@{$$grammar{RULES}[$ruleno]}[1,2]; |
|
776 my($lastterm); |
|
777 |
|
778 defined($rprec) |
|
779 and return($rprec); |
|
780 |
|
781 exists($rulesprec{$ruleno}) |
|
782 and return($rulesprec{$ruleno}); |
|
783 |
|
784 $lastterm=(grep { exists($$grammar{TERM}{$_}) } @$rhs)[-1]; |
|
785 |
|
786 defined($lastterm) |
|
787 and ref($$grammar{TERM}{$lastterm}) |
|
788 and do { |
|
789 $rulesprec{$ruleno}=$$grammar{TERM}{$lastterm}[1]; |
|
790 return($rulesprec{$ruleno}); |
|
791 }; |
|
792 |
|
793 undef; |
|
794 }; |
|
795 |
|
796 for my $stateno (keys(%$inconsistent)) { |
|
797 my($state)=$$states[$stateno]; |
|
798 my($actions)=$$state{ACTIONS}; |
|
799 my($nbsr,$nbrr); |
|
800 |
|
801 for my $term ( keys(%$actions) ) { |
|
802 my($act)=$$actions{$term}; |
|
803 |
|
804 @$act > 1 |
|
805 or next; |
|
806 |
|
807 $$act[0] > 0 |
|
808 and ref($$grammar{TERM}{$term}) |
|
809 and do { |
|
810 my($assoc,$tprec)=@{$$grammar{TERM}{$term}}; |
|
811 my($k,$error); |
|
812 |
|
813 for ($k=1;$k<@$act;++$k) { |
|
814 my($ruleno)=-$$act[$k]; |
|
815 my($rprec)=&$RulePrec($ruleno); |
|
816 |
|
817 defined($rprec) |
|
818 or next; |
|
819 |
|
820 ( $tprec > $rprec |
|
821 or ( $tprec == $rprec and $assoc eq 'RIGHT')) |
|
822 and do { |
|
823 push(@{$$conflicts{SOLVED}{$stateno}}, |
|
824 [ $ruleno, $term, 'shift' ]); |
|
825 splice(@$act,$k--,1); |
|
826 next; |
|
827 }; |
|
828 ( $tprec < $rprec |
|
829 or $assoc eq 'LEFT') |
|
830 and do { |
|
831 push(@{$$conflicts{SOLVED}{$stateno}}, |
|
832 [ $ruleno, $term, 'reduce' ]); |
|
833 $$act[0] > 0 |
|
834 and do { |
|
835 splice(@$act,0,1); |
|
836 --$k; |
|
837 }; |
|
838 next; |
|
839 }; |
|
840 push(@{$$conflicts{SOLVED}{$stateno}}, |
|
841 [ $ruleno, $term, 'error' ]); |
|
842 splice(@$act,$k--,1); |
|
843 $$act[0] > 0 |
|
844 and do { |
|
845 splice(@$act,0,1); |
|
846 ++$error; |
|
847 --$k; |
|
848 }; |
|
849 } |
|
850 $error |
|
851 and unshift(@$act,undef); |
|
852 }; |
|
853 |
|
854 @$act > 1 |
|
855 and do { |
|
856 $nbrr += @$act - 2; |
|
857 ($$act[0] > 0 ? $nbsr : $nbrr) += 1; |
|
858 push(@{$$conflicts{FORCED}{DETAIL}{$stateno}{LIST}}, |
|
859 map { [ $term, $_ ] } splice(@$act,1)); |
|
860 }; |
|
861 } |
|
862 |
|
863 $nbsr |
|
864 and do { |
|
865 $$conflicts{FORCED}{TOTAL}[0]+=$nbsr; |
|
866 $$conflicts{FORCED}{DETAIL}{$stateno}{TOTAL}[0]+=$nbsr; |
|
867 }; |
|
868 |
|
869 $nbrr |
|
870 and do { |
|
871 $$conflicts{FORCED}{TOTAL}[1]+=$nbrr; |
|
872 $$conflicts{FORCED}{DETAIL}{$stateno}{TOTAL}[1]+=$nbrr; |
|
873 }; |
|
874 |
|
875 } |
|
876 |
|
877 $conflicts |
|
878 } |
|
879 |
|
880 ############################### |
|
881 # Make default reduce actions # |
|
882 ############################### |
|
883 sub _SetDefaults { |
|
884 my($states)=@_; |
|
885 |
|
886 for my $state (@$states) { |
|
887 my($actions)=$$state{ACTIONS}; |
|
888 my(%reduces,$default,$nodefault); |
|
889 |
|
890 exists($$actions{''}) |
|
891 and do { |
|
892 $$actions{''}[0] = -$$actions{''}[0]; |
|
893 ++$nodefault; |
|
894 }; |
|
895 |
|
896 #shift error token => no default |
|
897 exists($$actions{error}) |
|
898 and $$actions{error}[0] > 0 |
|
899 and ++$nodefault; |
|
900 |
|
901 for my $term (keys(%$actions)) { |
|
902 |
|
903 $$actions{$term}=$$actions{$term}[0]; |
|
904 |
|
905 ( not defined($$actions{$term}) |
|
906 or $$actions{$term} > 0 |
|
907 or $nodefault) |
|
908 and next; |
|
909 |
|
910 push(@{$reduces{$$actions{$term}}},$term); |
|
911 } |
|
912 |
|
913 keys(%reduces) > 0 |
|
914 or next; |
|
915 |
|
916 $default=( map { $$_[0] } |
|
917 sort { $$b[1] <=> $$a[1] or $$b[0] <=> $$a[0] } |
|
918 map { [ $_, scalar(@{$reduces{$_}}) ] } |
|
919 keys(%reduces))[0]; |
|
920 |
|
921 delete(@$actions{ @{$reduces{$default}} }); |
|
922 $$state{ACTIONS}{''}=$default; |
|
923 } |
|
924 } |
|
925 |
|
926 sub _LALR { |
|
927 my($grammar,$states) = @_; |
|
928 my($conflicts,$inconsistent); |
|
929 |
|
930 $inconsistent = _ComputeLA($grammar,$states); |
|
931 |
|
932 $conflicts = _SolveConflicts($grammar,$states,$inconsistent); |
|
933 _SetDefaults($states); |
|
934 |
|
935 $conflicts |
|
936 } |
|
937 |
|
938 |
|
939 1; |