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;