File Coverage

blib/lib/Parse/Yapp/Grammar.pm
Criterion Covered Total %
statement 149 199 74.8
branch 40 62 64.5
condition 10 12 83.3
subroutine 12 15 80.0
pod 0 7 0.0
total 211 295 71.5


line stmt bran cond sub pod time code
1             #
2             # Module Parse::Yapp::Grammar
3             #
4             # Copyright © 1998, 1999, 2000, 2001, Francois Desarmenien.
5             # Copyright © 2017 William N. Braswell, Jr.
6             # (see the pod text in Parse::Yapp module for use and distribution rights)
7             #
8             package Parse::Yapp::Grammar;
9             @ISA=qw( Parse::Yapp::Options );
10              
11             require 5.004;
12              
13 3     3   21 use Carp;
  3         6  
  3         237  
14 3     3   20 use strict;
  3         5  
  3         63  
15 3     3   1171 use Parse::Yapp::Options;
  3         9  
  3         108  
16 3     3   1325 use Parse::Yapp::Parse;
  3         8  
  3         4435  
17              
18             ###############
19             # Constructor #
20             ###############
21             sub new {
22 10     10 0 19 my($class)=shift;
23 10         17 my($values);
24              
25 10         46 my($self)=$class->SUPER::new(@_);
26              
27 10         56 my($parser)=new Parse::Yapp::Parse;
28              
29 10 50       47 defined($self->Option('input'))
30             or croak "No input grammar";
31              
32 10         31 $values = $parser->Parse($self->Option('input'));
33              
34 10         724 undef($parser);
35              
36 10         38 $$self{GRAMMAR}=_ReduceGrammar($values);
37              
38 10 50       30 ref($class)
39             and $class=ref($class);
40              
41 10         192 bless($self, $class);
42             }
43              
44             ###########
45             # Methods #
46             ###########
47             ##########################
48             # Method To View Grammar #
49             ##########################
50             sub ShowRules {
51 0     0 0 0 my($self)=shift;
52 0         0 my($rules)=$$self{GRAMMAR}{RULES};
53 0         0 my($ruleno)=-1;
54 0         0 my($text);
55              
56 0         0 for (@$rules) {
57 0         0 my($lhs,$rhs)=@$_;
58              
59 0         0 $text.=++$ruleno.":\t".$lhs." -> ";
60 0 0       0 if(@$rhs) {
61 0 0       0 $text.=join(' ',map { $_ eq chr(0) ? '$end' : $_ } @$rhs);
  0         0  
62             }
63             else {
64 0         0 $text.="/* empty */";
65             }
66 0         0 $text.="\n";
67             }
68 0         0 $text;
69             }
70              
71             ###########################
72             # Method To View Warnings #
73             ###########################
74             sub Warnings {
75 0     0 0 0 my($self)=shift;
76 0         0 my($text);
77 0         0 my($grammar)=$$self{GRAMMAR};
78              
79             exists($$grammar{UUTERM})
80 0 0       0 and do {
81 0         0 $text="Unused terminals:\n\n";
82 0         0 for (@{$$grammar{UUTERM}}) {
  0         0  
83 0         0 $text.="\t$$_[0], declared line $$_[1]\n";
84             }
85 0         0 $text.="\n";
86             };
87             exists($$grammar{UUNTERM})
88 0 0       0 and do {
89 0         0 $text.="Useless non-terminals:\n\n";
90 0         0 for (@{$$grammar{UUNTERM}}) {
  0         0  
91 0         0 $text.="\t$$_[0], declared line $$_[1]\n";
92             }
93 0         0 $text.="\n";
94             };
95             exists($$grammar{UURULES})
96 0 0       0 and do {
97 0         0 $text.="Useless rules:\n\n";
98 0         0 for (@{$$grammar{UURULES}}) {
  0         0  
99 0         0 $text.="\t$$_[0] -> ".join(' ',@{$$_[1]})."\n";
  0         0  
100             }
101 0         0 $text.="\n";
102             };
103 0         0 $text;
104             }
105              
106             ######################################
107             # Method to get summary about parser #
108             ######################################
109             sub Summary {
110 0     0 0 0 my($self)=shift;
111 0         0 my($text);
112              
113             $text ="Number of rules : ".
114 0         0 scalar(@{$$self{GRAMMAR}{RULES}})."\n";
  0         0  
115             $text.="Number of terminals : ".
116 0         0 scalar(keys(%{$$self{GRAMMAR}{TERM}}))."\n";
  0         0  
117             $text.="Number of non-terminals : ".
118 0         0 scalar(keys(%{$$self{GRAMMAR}{NTERM}}))."\n";
  0         0  
119 0         0 $text;
120             }
121              
122             ###############################
123             # Method to Ouput rules table #
124             ###############################
125             sub RulesTable {
126 9     9 0 17 my($self)=shift;
127 9         25 my($inputfile)=$self->Option('inputfile');
128 9         22 my($linenums)=$self->Option('linenumbers');
129 9         22 my($rules)=$$self{GRAMMAR}{RULES};
130 9         19 my($ruleno);
131             my($text);
132              
133 9 50       23 defined($inputfile)
134             or $inputfile = 'unkown';
135              
136 9         17 $text="[\n\t";
137              
138             $text.=join(",\n\t",
139             map {
140 9         23 my($lhs,$rhs,$code)=@$_[0,1,3];
  63         125  
141 63         90 my($len)=scalar(@$rhs);
142 63         76 my($text);
143              
144 63         141 $text.="[#Rule ".$ruleno++."\n\t\t '$lhs', $len,";
145 63 100       120 if($code) {
146 32 50       105 $text.= "\nsub".
147             ( $linenums
148             ? qq(\n#line $$code[1] "$inputfile"\n)
149             : " ").
150             "{$$code[0]}";
151             }
152             else {
153 31         40 $text.=' undef';
154             }
155 63         90 $text.="\n\t]";
156              
157 63         131 $text;
158             } @$rules);
159              
160 9         24 $text.="\n]";
161              
162 9         22 $text;
163             }
164              
165             ################################
166             # Methods to get HEAD and TAIL #
167             ################################
168             sub Head {
169 9     9 0 20 my($self)=shift;
170 9         26 my($inputfile)=$self->Option('inputfile');
171 9         25 my($linenums)=$self->Option('linenumbers');
172 9         15 my($text);
173              
174 9 100       35 $$self{GRAMMAR}{HEAD}[0]
175             or return '';
176              
177 8 50       21 defined($inputfile)
178             or $inputfile = 'unkown';
179              
180 8         10 for (@{$$self{GRAMMAR}{HEAD}}) {
  8         21  
181 8 50       33 $linenums
182             and $text.=qq(#line $$_[1] "$inputfile"\n);
183 8         16 $text.=$$_[0];
184             }
185             $text
186 8         21 }
187              
188             sub Tail {
189 9     9 0 20 my($self)=shift;
190 9         27 my($inputfile)=$self->Option('inputfile');
191 9         24 my($linenums)=$self->Option('linenumbers');
192 9         13 my($text);
193              
194 9 50       24 $$self{GRAMMAR}{TAIL}[0]
195             or return '';
196              
197 9 50       21 defined($inputfile)
198             or $inputfile = 'unkown';
199              
200 9 50       38 $linenums
201             and $text=qq(#line $$self{GRAMMAR}{TAIL}[1] "$inputfile"\n);
202 9         21 $text.=$$self{GRAMMAR}{TAIL}[0];
203              
204 9         22 $text
205             }
206              
207              
208             #################
209             # Private Stuff #
210             #################
211              
212             sub _UsefulRules {
213 10     10   23 my($rules,$nterm) = @_;
214 10         27 my($ufrules,$ufnterm);
215 10         0 my($done);
216              
217 10         47 $ufrules=pack('b'.@$rules);
218 10         23 $ufnterm={};
219              
220 10         34 vec($ufrules,0,1)=1; #start rules IS always useful
221              
222             RULE:
223 10         39 for (1..$#$rules) { # Ignore start rule
224 878         1110 for my $sym (@{$$rules[$_][1]}) {
  878         1565  
225 1084 100       2269 exists($$nterm{$sym})
226             and next RULE;
227             }
228 169         294 vec($ufrules,$_,1)=1;
229 169         380 ++$$ufnterm{$$rules[$_][0]};
230             }
231              
232 10         19 do {
233 27         39 $done=1;
234              
235             RULE:
236 27         90 for (grep { vec($ufrules,$_,1) == 0 } 1..$#$rules) {
  3422         5088  
237 1157         1538 for my $sym (@{$$rules[$_][1]}) {
  1157         1826  
238             exists($$nterm{$sym})
239 2570 100 100     8088 and not exists($$ufnterm{$sym})
240             and next RULE;
241             }
242 709         1239 vec($ufrules,$_,1)=1;
243             exists($$ufnterm{$$rules[$_][0]})
244 709 100       1774 or do {
245 150         206 $done=0;
246 150         294 ++$$ufnterm{$$rules[$_][0]};
247             };
248             }
249              
250             }until($done);
251              
252 10         35 ($ufrules,$ufnterm)
253              
254             }#_UsefulRules
255              
256             sub _Reachable {
257 10     10   43 my($rules,$nterm,$term,$ufrules,$ufnterm)=@_;
258 10         17 my($reachable);
259 10         25 my(@fifo)=( 0 );
260              
261 10         29 $reachable={ '$start' => 1 }; #$start is always reachable
262              
263 10         30 while(@fifo) {
264 885         1273 my($ruleno)=shift(@fifo);
265              
266 885         1117 for my $sym (@{$$rules[$ruleno][1]}) {
  885         1459  
267              
268             exists($$term{$sym})
269 2029 100       3832 and do {
270 784         1095 ++$$reachable{$sym};
271 784         1289 next;
272             };
273              
274             ( not exists($$ufnterm{$sym})
275 1245 100 100     4536 or exists($$reachable{$sym}) )
276             and next;
277              
278 260         418 ++$$reachable{$sym};
279 260         352 push(@fifo, grep { vec($ufrules,$_,1) } @{$$nterm{$sym}});
  875         1425  
  260         432  
280             }
281             }
282              
283             $reachable
284              
285 10         26 }#_Reachable
286              
287             sub _SetNullable {
288 10     10   27 my($rules,$term,$nullable) = @_;
289 10         21 my(@nrules);
290             my($done);
291              
292             RULE:
293 10         23 for (@$rules) {
294 888         1332 my($lhs,$rhs)=@$_;
295              
296 888 100       1699 exists($$nullable{$lhs})
297             and next;
298              
299 799         1111 for (@$rhs) {
300 1285 100       2629 exists($$term{$_})
301             and next RULE;
302             }
303 288         605 push(@nrules,[$lhs,$rhs]);
304             }
305              
306 10         20 do {
307 12         22 $done=1;
308              
309             RULE:
310 12         25 for (@nrules) {
311 567         854 my($lhs,$rhs)=@$_;
312              
313 567 100       1059 exists($$nullable{$lhs})
314             and next;
315              
316 559         766 for (@$rhs) {
317 558 100       1194 exists($$nullable{$_})
318             or next RULE;
319             }
320 6         9 $done=0;
321 6         13 ++$$nullable{$lhs};
322             }
323              
324             }until($done);
325             }
326              
327             sub _ReduceGrammar {
328 10     10   28 my($values)=@_;
329 10         20 my($ufrules,$ufnterm,$reachable);
330             my($grammar)={ HEAD => $values->{HEAD},
331             TAIL => $values->{TAIL},
332 10         49 EXPECT => $values->{EXPECT} };
333 10         36 my($rules,$nterm,$term) = @$values {'RULES', 'NTERM', 'TERM'};
334              
335 10         38 ($ufrules,$ufnterm) = _UsefulRules($rules,$nterm);
336              
337             exists($$ufnterm{$values->{START}})
338 10 50       32 or die "*Fatal* Start symbol $values->{START} derives nothing, at eof\n";
339              
340 10         32 $reachable = _Reachable($rules,$nterm,$term,$ufrules,$ufnterm);
341              
342 10         29 $$grammar{TERM}{chr(0)}=undef;
343 10         55 for my $sym (keys %$term) {
344             ( exists($$reachable{$sym})
345             or exists($values->{PREC}{$sym}) )
346 157 100 100     350 and do {
347             $$grammar{TERM}{$sym}
348 154 100       304 = defined($$term{$sym}[0]) ? $$term{$sym} : undef;
349 154         222 next;
350             };
351 3         5 push(@{$$grammar{UUTERM}},[ $sym, $values->{SYMS}{$sym} ]);
  3         10  
352             }
353              
354 10         63 $$grammar{NTERM}{'$start'}=[];
355 10         52 for my $sym (keys %$nterm) {
356             exists($$reachable{$sym})
357 260 50       477 and do {
358             exists($values->{NULL}{$sym})
359 260 100       484 and ++$$grammar{NULLABLE}{$sym};
360 260         404 $$grammar{NTERM}{$sym}=[];
361 260         406 next;
362             };
363 0         0 push(@{$$grammar{UUNTERM}},[ $sym, $values->{SYMS}{$sym} ]);
  0         0  
364             }
365              
366 10         36 for my $ruleno (0..$#$rules) {
367             vec($ufrules,$ruleno,1)
368             and exists($$grammar{NTERM}{$$rules[$ruleno][0]})
369 888 50 33     3061 and do {
370 888         1150 push(@{$$grammar{RULES}},$$rules[$ruleno]);
  888         1295  
371 888         1108 push(@{$$grammar{NTERM}{$$rules[$ruleno][0]}},$#{$$grammar{RULES}});
  888         1352  
  888         1315  
372 888         1279 next;
373             };
374 0         0 push(@{$$grammar{UURULES}},[ @{$$rules[$ruleno]}[0,1] ]);
  0         0  
  0         0  
375             }
376              
377 10         40 _SetNullable(@$grammar{'RULES', 'TERM', 'NULLABLE'});
378              
379 10         98 $grammar;
380             }#_ReduceGrammar
381              
382             1;