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#
7package Parse::Yapp::Grammar;
8@ISA=qw( Parse::Yapp::Options );
9
10require 5.004;
11
12use Carp;
13use strict;
14use Parse::Yapp::Options;
15use Parse::Yapp::Parse;
16
17###############
18# Constructor #
19###############
20sub 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##########################
49sub 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###########################
73sub 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######################################
108sub 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###############################
124sub 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################################
167sub 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
187sub 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
211sub _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
255sub _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
286sub _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
326sub _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
3811;
382