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