File Coverage

blib/lib/Parse/Eyapp/Lalr.pm

Criterion	Covered	Total	%
statement	349	554	63.0
branch	104	196	53.0
condition	37	45	82.2
subroutine	24	31	77.4
pod	0	9	0.0
total	514	835	61.5

package Parse::Eyapp::Lalr;
@ISA=qw( Parse::Eyapp::Grammar );

require 5.004;

use Parse::Eyapp::Grammar;
use Data::Dumper;

# Parse::Eyapp::Compile Object Structure:
# --------------------------------------
# {
#    GRAMMAR =>    Parse::Eyapp::Grammar,
#    STATES  =>    [ { CORE    => [ items... ],
#                      ACTIONS  => { term => action }
#                      GOTOS   => { nterm => stateno }
#                    }... ]
#    CONFLICTS=>{ SOLVED => { stateno  => [ ruleno, token, solved ] },
#                 FORCED => { TOTAL => [ nbsr, nbrr ],
#                             DETAIL => { stateno => { TOTAL => [ nbsr, nbrr ] }
#                                                      LIST => [ ruleno, token ]
#                                                    }
#                                       }
#                           }
# }
#
# 'items' are of form: [ ruleno, dotpos ]
# 'term' in ACTIONS is '' means default action
# 'action' may be:
#     undef:  explicit error (nonassociativity)
#     0    :  accept
#     >0   :  shift and go to state 'action'
#     <0   :  reduce using rule -'action'
# 'solved' may have values of:
#          'shift'  if solved as Shift
#          'reduce' if solved as Reduce
#          'error'  if solved by discarding both Shift and Reduce (nonassoc)
#
# SOLVED is a set of states containing Solved conflicts
# FORCED are forced conflict resolutions
#
# nbsr and nbrr are number of shift/reduce and reduce/reduce conflicts
#
# TOTAL is the total number of SR/RR conflicts for the parser
#
# DETAIL is the detail of conflicts for each state
# TOTAL is the total number of SR/RR conflicts for a state
# LIST is the list of discarded reductions (for display purpose only)


use strict;

use Carp;

###############
# Constructor #
###############
sub new {
    my($class)=shift;

		ref($class)
	and	$class=ref($class);

	my($self)=$class->SUPER::new(@_);
    $self->_Compile();
    $self->_DynamicConflicts(); # call it only if dynamic conflict handlers

    if ($self->Option('prefix')) {
      # weak accept for nested parsing !!!!!!!!!!!!
      # substitute End Of Input by DEFAULT for each state
      for (@{$self->{STATES}}) {
        if (exists($_->{ACTIONS}{"\c@"})) {
          # what if DEFAULT action already exists ?
          # Shall I have to use an option in eyapp????
          $_->{ACTIONS}{''} = $_->{ACTIONS}{"\c@"};
          delete($_->{ACTIONS}{"\c@"});
        }
      }
    }

    bless($self,$class);
}
###########
# Methods #
###########

###########################
# Method To View Warnings #
###########################
sub Warnings {
    my($self)=shift;
    my($text) = '';

    # $nbsr = number of shift-reduce conflicts
    # $nbrr = number of reduce-reduce conflicts
    my($nbsr,$nbrr)=@{$$self{CONFLICTS}{FORCED}{TOTAL}};

    $text=$self->SUPER::Warnings();

    my $expected = $$self{GRAMMAR}{EXPECT};
    my ($sre, $rre) = ref($expected) ? @$expected : ($expected, 0);

    $nbsr != $sre and $nbsr > 0 and do {
      $text.="$nbsr shift/reduce conflict".($nbsr > 1 ? "s " : " ");
    };  # end of $nbsr != $sre There were shift-reduce conflicts

    $nbrr != $rre and $nbrr > 0 and do {
      $nbsr != $sre and $text.="and ";
      $text.="$nbrr reduce/reduce conflict".($nbrr > 1 ? "s" : "");
    };

    $text;
}
#############################
# Method To View DFA States #
#############################
sub ShowDfa {
    my($self)=shift;
    my($text) = '';
    my($grammar,$states)=($$self{GRAMMAR}, $$self{STATES});

    for my $stateno (0..$#$states) {
        my(@shifts,@reduces,@errors,$default);

        $text.="State $stateno:\n\n";

        #Dump Kernel Items
        for (sort {     $$a[0] <=> $$b[0]
                    or  $$a[1] <=> $$b[1] } @{$$states[$stateno]{'CORE'}}) {
            my($ruleno,$pos)=@$_;
            my($lhs,$rhs)=@{$$grammar{RULES}[$ruleno]}[0,1];
            my(@rhscopy)=@$rhs;

                $ruleno
            or  $rhscopy[-1] = '$end';

            splice(@rhscopy,$pos,0,'.');
            $text.= "\t$lhs -> ".join(' ',@rhscopy)."\t(Rule $ruleno)\n";
        }

        #Prepare Actions
        for (keys(%{$$states[$stateno]{ACTIONS}})) {
            my($term,$action)=($_,$$states[$stateno]{ACTIONS}{$_});

                $term eq chr(0)
            and $term = '$end';

                not defined($action)
            and do {
                push(@errors,$term);
                next;
            };

                $action > 0
            and do {
                push(@shifts,[ $term, $action ]);
                next;
            };

            $action = -$action;

                $term
            or  do {
                $default= [ '$default', $action ];
                next;
            };

            push(@reduces,[ $term, $action ]);
        }

            #Dump shifts
            @shifts
        and do {
            $text.="\n";
            for (sort { $$a[0] cmp $$b[0] } @shifts) {
                my($term,$shift)=@$_;

                $text.="\t$term\tshift, and go to state $shift\n";
            }
        };

            #Dump errors
            @errors
        and do {
            $text.="\n";
            for my $term (sort { $a cmp $b } @errors) {
                $text.="\t$term\terror (nonassociative)\n";
            }
        };

        #Prepare reduces
            exists($$self{CONFLICTS}{FORCED}{DETAIL}{$stateno})
        and push(@reduces,@{$$self{CONFLICTS}{FORCED}{DETAIL}{$stateno}{LIST}});

        @reduces=sort { $$a[0] cmp $$b[0] or $$a[1] <=> $$b[1] } @reduces;

            defined($default)
        and push(@reduces,$default);

        #Dump reduces
            @reduces
        and do {
            $text.="\n";
            for (@reduces) {
                my($term,$ruleno)=@$_;
                my($discard);

                    $ruleno < 0
                and do {
                    ++$discard;
                    $ruleno = -$ruleno;
                };

                    $term eq chr(0)
                and $term = '$end';

                $text.= "\t$term\t".($discard  ? "[" : "");
                if($ruleno) {
                    $text.= "reduce using rule $ruleno ".
                            "($$grammar{RULES}[$ruleno][0])";
                }
                else {
                    $text.='accept';
                }
                $text.=($discard  ? "]" : "")."\n";
            }
        };

            #Dump gotos
            exists($$states[$stateno]{GOTOS})
        and    do {
                $text.= "\n";
                for (keys(%{$$states[$stateno]{GOTOS}})) {
                    $text.= "\t$_\tgo to state $$states[$stateno]{GOTOS}{$_}\n";
                }
            };

        $text.="\n";
    }
    $text;
}

####################################################################
# Usage      : $parser->outputtables($path, $base)
# Purpose    : Gives support to eyapp option -v
# Parameters : The parser object plus the $path and $base names for the .output
#              file

sub outputtables {
  my ($parser, $path, $base) = @_;

  my($output)=$base?"$path$base.output":"STDOUT";
  my($tmp);

          open(my $OUT,">$output")
  or	die "Cannot create $base.output for writing.\n";

          $tmp=$parser->Warnings()
  and	print	$OUT "Warnings:\n---------\n$tmp\n";
          $tmp=$parser->Conflicts()
  and	print	$OUT "Conflicts:\n----------\n$tmp\n";
  print	$OUT "Rules:\n------\n";
  print	$OUT $parser->ShowRules()."\n";
  print	$OUT "States:\n-------\n";
  print	$OUT $parser->ShowDfa()."\n";
  print	$OUT "Summary:\n--------\n";
  print	$OUT $parser->Summary();

  close($OUT);
}

sub outputDot {
  my ($parser, $path, $base, $labelWithCore) = @_;

  my ($output)=$base?"$path$base.dot":"STDOUT";

          open(my $OUT,">$output")
  or	die "Cannot create $base.dot for writing.\n";

  my $graph = '';

  my $dfa = $parser->ShowDfa();

  #warn "$dfa\n";

  my $grammar = $parser->ShowRules()."\n";

  #warn "$grammar\n";

  # make an array from the grammar

  my %grammar = $grammar =~ m{(\d+):\s+(.*)}gx;

  # escape double quotes inside %grammar
  $graph .= qq{  "g0" [label="0: $grammar{0}", shape = doubleoctagon, fontcolor=blue, color=blue ]\n};
  for (1 .. (keys %grammar)-1) {
    $grammar{$_} =~ s/\\/\\\\/g;  # escape escapes
    $grammar{$_} =~ s/"/\\"/g;    # escape double quotes

    #warn "$_ => $grammar{$_}\n";

    $graph .= qq{  "g$_" [label="$_: $grammar{$_}", shape = box, fontcolor=blue, color=blue ]\n};
  }

  for (0 .. (keys %grammar)-2) {
    my $n = $_+1;
    $graph .= qq{  g$_ ->g$n [style=dotted];\n};
  }

  my $conflicts = $parser->Conflicts();

  #warn $conflicts;

  # State 13 contains 5 shift/reduce conflicts
  # State 23 contains 5 shift/reduce conflicts
  my @conflictstates = $conflicts =~ m{State\s+(\d+)\s+contains\s+\d+\s+(?:shift|reduce)/reduce\s+conflicts?\s*}gx;

  #warn "(@conflictstates)\n";

  $graph .= qq{$_ [shape = diamond, fontcolor=red, color=red]\n} for @conflictstates;

  my %states = ($dfa =~ m{State\s*(\d+)\s*:\n\s*
                          (
                          (?:
                           .*->.*       | # a production line
                           .*go\s+to.*  | # a shift or a goto line
                           .*reduce.*   | # a reduce line
                           .*accept.*   | # an accept line
                           \s+          | # white lines
                          )+
                          )
                         }gx);

  for (sort { $a <=> $b } keys %states) {
    my $desc = $states{$_};
    my @LRitems = $desc =~ m{(\S.*->.*[^\s.])\s+\(Rule\s+\d+\)}g;     # remove productions

    # label states with core LR-0 items
    if ($labelWithCore) { # this is optional
      local $" = "\\n";
      $graph .= qq{$_ [ label = "$_\\n@LRitems"}; #shape = plaintext,
      my $s = $_;
      $graph .= qq{, shape = plaintext} unless (grep { $_ eq $s}  @conflictstates);
      $graph .= "]\n";
    }

    #warn "LRitems in $_:\n@LRitems\n";

    $desc =~ s/\n\s*\n/\n/g;  # remove white lines

    # build digraph
    # ID  shift, and go to state 4
    while ($desc =~ m{\t(.*)\s+shift,\s+and\s+go\s+to\s+state\s+(\d+)}gx) {
      my ($label, $state)  = ($1, $2);
      $label =~ s/\\(?!")/\\\\/g;
      $graph .=  qq{$_ -> $state [label = "$label"]\n};
    }

    # decl    go to state 1
    while ($desc =~ m{\t(\S+)\s+go\s+to\s+state\s+(\d+)}gx) {
      $graph .=  qq{$_ -> $2 [label = "$1", arrowhead = odot, color = "red", fontcolor = "red"]\n};
    }

    # $default	reduce using rule 1 (prog)
    # ID	reduce using rule 15 (decORexp_explorer)
    while ($desc =~ m{\t(\S+)\s+reduce\s+using\s+rule\s+(\d+)}gx) {
      $graph .=  qq{$_ -> "g$2" [label = "$1", arrowhead=dot, color = "blue", fontcolor = "blue"]\n};
    }

    # shift-reduce conflicts
    # ';'	[reduce using rule 4 (ds)]
    while ($desc =~ m{\t(\S+)\s+\[\s*reduce\s+using\s+rule\s+(\d+)}gx) {
      $graph .=
        qq{$_ -> "g$2" [label = "$1", arrowhead=dot, style=dotted, color = "red", fontcolor = "red"]\n};
    }

    # $default    accept
    if ($desc =~ m{\t\$default\s+accept\s*}gx) {
      $graph .=  qq{$_ [shape = doublecircle]\n};
      $graph .=  qq{$_ -> "g0" [arrowhead = dot, color = blue]\n};
    }

    #warn "$_ => $desc\n";

  }
  print $OUT <<"EOGRAPH";
digraph G {
#concentrate = true

$graph
}
EOGRAPH
  close $OUT;
}

sub qtables {
  my ($parser) = @_;

  my($tmp);

  my $warnings  = $parser->Warnings();
  my $conflicts = $parser->Conflicts();
  my $rules     = $parser->ShowRules();
  my $states    = $parser->ShowDfa();
  my $summary    =	$parser->Summary();

  my $tables =<<"ENDOFLALAR"
Warnings:
---------
$warnings
Conflicts:
----------
$conflicts
Rules:
------
$rules
States:
------
$states
$states
Summary:
--------
$summary
ENDOFLALAR
}

######################################
# Method to get summary about parser #
######################################
sub Summary {
    my($self)=shift;
    my($text) = '';

	$text=$self->SUPER::Summary();
    $text.="Number of states        : ".
            scalar(@{$$self{STATES}})."\n";
    $text;
}

#######################################
# Method To Get Infos about conflicts #
#######################################
sub Conflicts {
    my($self)=shift;
    my($states)=$$self{STATES};
    my($conflicts)=$$self{CONFLICTS};
    my($text) = '';

    for my $stateno ( sort { $a <=> $b } keys(%{$$conflicts{SOLVED}})) {

        for (@{$$conflicts{SOLVED}{$stateno}}) {
            my($ruleno,$token,$how)=@$_;

                $token eq chr(0)
            and $token = '$end';

            $text.="Conflict in state $stateno between rule ".
                   "$ruleno and token $token resolved as $how.\n";
        }
    };

    for my $stateno ( sort { $a <=> $b } keys(%{$$conflicts{FORCED}{DETAIL}})) {
        my($nbsr,$nbrr)=@{$$conflicts{FORCED}{DETAIL}{$stateno}{TOTAL}};

        $text.="State $stateno contains ";

            $nbsr
        and $text.="$nbsr shift/reduce conflict".
                   ($nbsr > 1 ? "s" : "");

            $nbrr
        and do {
                $nbsr
            and $text.=" and ";

            $text.="$nbrr reduce/reduce conflict".
                   ($nbrr > 1 ? "s" : "");
        };
        $text.="\n";
    };

    $text;
}

#################################
# Method to dump parsing tables #
#################################
sub DfaTable {
    my($self)=shift;
    my($states)=$$self{STATES};
    my($stateno);
    my($text);

    $text="[\n\t{";

    $text.=join("\n\t},\n\t{",
                map {
                    my($state)=$_;
                    my($text);

                    $text="#State ".$stateno++."\n\t\t";

                       (    not exists($$state{ACTIONS}{''})
                        or  keys(%{$$state{ACTIONS}}) > 1)
                    and do {

                        $text.="ACTIONS => {\n\t\t\t";

                        $text.=join(",\n\t\t\t",
                                map {
                                    my($term,$action)=($_,$$state{ACTIONS}{$_});
                                    my($text);

                                    if(substr($term,0,1) eq "'") {
									    $term=~s/([\@\$\"])/\\$1/g;
                                        $term=~s/^'|'$/"/g;
                                    }
                                    else {
                                        $term=      $term eq chr(0)
                                                ?   "''"
                                                :   "'$term'";
                                    }

                                    if(defined($action)) {
                                        $action=int($action);
                                    }
                                    else {
                                        $action='undef';
                                    }

                                    "$term => $action";

                                } grep { $_ } keys(%{$$state{ACTIONS}}));

                        $text.="\n\t\t}";
                    };

                        exists($$state{ACTIONS}{''})
                    and do {
                            keys(%{$$state{ACTIONS}}) > 1
                        and $text.=",\n\t\t";

                        $text.="DEFAULT => $$state{ACTIONS}{''}";
                    };

                        exists($$state{GOTOS})
                    and do {
                        $text.=",\n\t\tGOTOS => {\n\t\t\t";
                        $text.=join(",\n\t\t\t",
                                map {
                                    my($nterm,$stateno)=($_,$$state{GOTOS}{$_});
                                    my($text);

                                    "'$nterm' => $stateno";

                                } keys(%{$$state{GOTOS}}));
                        $text.="\n\t\t}";
                    };

                    $text;

                }@$states);

    $text.="\n\t}\n]";

    $text;

}

sub _DynamicConflicts {
  my $self = shift;
  my $ch = $self->{GRAMMAR}{CONFLICTHANDLERS};

  return unless %$ch;

  my $co = $self->{CONFLICTS}{FORCED}{DETAIL};

  my %C; # keys:
         #     conflictive grammar productions.
         # Values:
         #     tokens for which there is a conflict with this production
  for my $state (keys %$co) {
    my @conList = @{$co->{$state}{LIST}};

    for my $c (@conList) {
      my ($token, $production) = @$c;

      # the action chosen is in: $self->{STATES}[$state]{ACTIONS}{$token}
      push @{$C{($production)}{$state}}, $token;
    }
  }

  for my $c (keys %$ch) {                 # for each conflict handler
    my $d = $ch->{$c}{production};        # hash ref of productions managed by this handler
    for my $p (keys %$d) {                # for each production
  #    # if $p reduce or shift?
  #    # find the conflictive states where $p appears
  #    # if $p is reduce and appears in state $s as -$p it is a state of conflict (the other is in the action table)

       if ($C{$p}) {
         push @{$ch->{$c}{states}}, $C{$p}
       }
       else {
         #  check that it is a shift with this production.
       }
    }
  }
}

####################################
# Method to build Dfa from Grammar #
####################################
sub _Compile {
	my($self)=shift;
	my($grammar,$states);

	$grammar=$self->{GRAMMAR};

    $states = _LR0($grammar);

    $self->{CONFLICTS} = _LALR($grammar,$states);

    $self->{STATES}=$states;
}

#########################
# LR0 States Generation #
#########################
#
###########################
# General digraph routine #
###########################
sub _Digraph {
    my($rel,$F)=@_;
    my(%N,@S);
    my($infinity)=(~(1<<31));
    my($Traverse);

    $Traverse = sub {
        my($x,$d)=@_;
        my($y);

        push(@S,$x);
        $N{$x}=$d;

            exists($$rel{$x})
        and do {
            for $y (keys(%{$$rel{$x}})) {
                    exists($N{$y})
                or  &$Traverse($y,$d+1);

                    $N{$y} < $N{$x}
                and $N{$x} = $N{$y};

                $$F{$x}|=$$F{$y};
            }
        };

            $N{$x} == $d
        and do {
            for(;;) {
                $y=pop(@S);
                $N{$y}=$infinity;
                    $y eq $x
                and last;
                $$F{$y}=$$F{$x};
            }
        };
    };

    for (keys(%$rel)) {
            exists($N{$_})
        or  &$Traverse($_,1);
    }
}
#######################
# Generate LR0 states #
#######################
# Formula used for closures:
#
#     CLOSE(A) = DCLOSE(A) u U (CLOSE(B) | A close B)
#
# where:
#
#     DCLOSE(A) = { [ A -> alpha ] in P }
#
#     A close B iff [ A -> B gamma ] in P

sub _SetClosures {
	my($grammar)=@_;
    my($rel,$closures);

    for my $symbol (keys(%{$$grammar{NTERM}})) {
        $closures->{$symbol}=pack('b'.@{$$grammar{RULES}});

        for my $ruleno (@{$$grammar{NTERM}{$symbol}}) {
            my($rhs)=$$grammar{RULES}[$ruleno][1];

            vec($closures->{$symbol},$ruleno,1)=1;

                @$rhs > 0
            and exists($$grammar{NTERM}{$$rhs[0]})
            and ++$rel->{$symbol}{$$rhs[0]};
        }
    }
    _Digraph($rel,$closures);

	$closures
}

sub _Closures {
    my($grammar,$core,$closures)=@_;
    my($ruleset)=pack('b'.@{$$grammar{RULES}});

    for (@$core) {
        my($ruleno,$pos)=@$_;
        my($rhs)=$$grammar{RULES}[$ruleno][1];

            $pos < @$rhs
        and exists($closures->{$$rhs[$pos]})
        and $ruleset|=$closures->{$$rhs[$pos]};
    }
    [ @$core, map  { [ $_, 0 ] }
              grep { vec($ruleset,$_,1) }
              0..$#{$$grammar{RULES}} ];
}

sub _Transitions {
    my($grammar,$cores,$closures,$states,$stateno)=@_;
    my($core)=$$states[$stateno]{'CORE'};
    my(%transitions);

    for (@{_Closures($grammar,$core,$closures)}) {
        my($ruleno,$pos)=@$_;
        my($rhs)=$$grammar{RULES}[$ruleno][1];

            $pos == @$rhs
        and do {
            push(@{$$states[$stateno]{ACTIONS}{''}},$ruleno);
            next;
        };
        push(@{$transitions{$$rhs[$pos]}},[ $ruleno, $pos+1 ]);
    }

    for (keys(%transitions)) {
        my($symbol,$core)=($_,$transitions{$_});
        my($corekey)=join(',',map  { join('.',@$_) }
                              sort {    $$a[0] <=> $$b[0]
                                    or  $$a[1] <=> $$b[1] }
                              @$core);
        my($tostateno);

            exists($cores->{$corekey})
        or  do {
            push(@$states,{ 'CORE' => $core });
            $cores->{$corekey}=$#$states;
        };

        $tostateno=$cores->{$corekey};
        push(@{$$states[$tostateno]{FROM}},$stateno);

			exists($$grammar{TERM}{$_})
		and	do {
            $$states[$stateno]{ACTIONS}{$_} = [ $tostateno ];
			next;
		};
        $$states[$stateno]{GOTOS}{$_} = $tostateno;
    }
}

sub _LR0 {
	my($grammar)=@_;
	my($states) = [];
    my($stateno);
    my($closures);  #$closures={ nterm => ruleset,... }
	my($cores)={};  # { "itemlist" => stateno, ... }
					# where "itemlist" has the form:
					# "ruleno.pos,ruleno.pos" ordered by ruleno,pos

    $closures = _SetClosures($grammar);
    push(@$states,{ 'CORE' => [ [ 0, 0 ] ] });
    for($stateno=0;$stateno<@$states;++$stateno) {
        _Transitions($grammar,$cores,$closures,$states,$stateno);
    }

	$states
}

#########################################################
# Add Lookahead tokens where needed to make LALR states #
#########################################################
#     Compute First sets for non-terminal using the following formula:
#
#     FIRST(A) =      { a in T u { epsilon } | A l a }
#                 u
#                 U   { FIRST(B) | B in V and A l B }
#
#     where:
#
#     A l x iff [ A -> X1 X2 .. Xn x alpha ] in P and Xi =>* epsilon, 1 <= i <= n

sub _SetFirst {
	my($grammar,$termlst,$terminx)=@_;
    my($rel,$first)=( {}, {} );

    for my $symbol (keys(%{$$grammar{NTERM}})) {
        $first->{$symbol}=pack('b'.@$termlst);

        RULE:
        for my $ruleno (@{$$grammar{NTERM}{$symbol}}) {
            my($rhs)=$$grammar{RULES}[$ruleno][1];

            for (@$rhs) {
                    exists($terminx->{$_})
                and do {
                    vec($first->{$symbol},$terminx->{$_},1)=1;
                    next RULE;
                };
                ++$rel->{$symbol}{$_};
                    exists($$grammar{NULLABLE}{$_})
                or  next RULE;
            }
            vec($first->{$symbol},0,1)=1;
        }
    }
    _Digraph($rel,$first);

	$first
}

sub _Preds {
    my($states,$stateno,$len)=@_;
    my($queue, $preds);

        $len
    or  return [ $stateno ];

    $queue=[ [ $stateno, $len ] ];
    while(@$queue) {
        my($pred) = shift(@$queue);
        my($stateno, $len) = @$pred;

            $len == 1
        and do {
			push(@$preds,@{$states->[$stateno]{FROM}});
            next;
        };

        push(@$queue, map { [ $_, $len - 1 ] }
					  @{$states->[$stateno]{FROM}});
    }

    # Pass @$preds through a hash to ensure unicity
    [ keys( %{ +{ map { ($_,1) } @$preds } } ) ];
}

sub _FirstSfx {
    my($grammar,$firstset,$termlst,$terminx,$ruleno,$pos,$key)=@_;
    my($first)=pack('b'.@$termlst);
    my($rhs)=$$grammar{RULES}[$ruleno][1];

    for (;$pos < @$rhs;++$pos) {
            exists($terminx->{$$rhs[$pos]})
        and do {
            vec($first,$terminx->{$$rhs[$pos]},1)=1;
            return($first);
        };
        $first|=$firstset->{$$rhs[$pos]};

            vec($first,0,1)
        and vec($first,0,1)=0;

            exists($$grammar{NULLABLE}{$$rhs[$pos]})
        or  return($first);

    }
    vec($first,0,1)=1;
    $first;
}

#     Compute Follow sets using following formula:
#
#     FOLLOW(p,A) =       READ(p,A)
#                     u
#                     U   { FOLLOW(q,B) | (p,A) include (q,B)
#
#     where:
#
#     READ(p,A) = U { FIRST(beta) | [ A -> alpha A . beta ] in KERNEL(GOTO(p,A))
#                   } - { epsilon }
#
#     (p,a) include (q,B) iff [ B -> alpha A . beta ] in KERNEL(GOTO(p,A),
#                             epsilon in FIRST(beta) and
#                             q in PRED(p,alpha)

# >> x $firstset
# 0  HASH(0x1f7af60)
#    '$start' => "\cG"
#    'a' => "\cB"
#    'b' => "\cH"
#    's' => "\cC"
# >> x $firstset->{'a'} # firstset es una string compactada de 0 y 1 que es trratada como un conjunto
# 0  "\cB"
# >> x unpack ("b*", $firstset->{'a'})
# 0  01000000
# >> x unpack ("b*", $firstset->{'b'})
# 0  00010000
# >> x unpack ("b*", $firstset->{'s'})
# 0  11000000

sub _ComputeFollows {
	my($grammar,$states,$termlst)=@_;
	my($firstset,$terminx);
	my($inconsistent, $rel, $follows, $sfx)= ( {}, {}, {}, {} );

    %$terminx= map { ($termlst->[$_],$_) } 0..$#$termlst;

    $firstset=_SetFirst($grammar,$termlst,$terminx);

    for my $stateno (0..$#$states) {
		my($state)=$$states[$stateno];

           	exists($$state{ACTIONS}{''})
        and (   @{$$state{ACTIONS}{''}} > 1
             or keys(%{$$state{ACTIONS}}) > 1 )
		and do {
			++$inconsistent->{$stateno};

			for my $ruleno (@{$$state{ACTIONS}{''}}) {
				my($lhs,$rhs)=@{$$grammar{RULES}[$ruleno]}[0,1];

                for my $predno (@{_Preds($states,$stateno,scalar(@$rhs))}) {
                    ++$rel->{"$stateno.$ruleno"}{"$predno.$lhs"};
                }
			}
		};

    		exists($$state{GOTOS})
		or	next;

        for my $symbol (keys(%{$$state{GOTOS}})) {
            my($tostate)=$$states[$$state{GOTOS}{$symbol}];
            my($goto)="$stateno.$symbol";

            $follows->{$goto}=pack('b'.@$termlst);

            for my $item (@{$$tostate{'CORE'}}) {
                my($ruleno,$pos)=@$item;
				my($key)="$ruleno.$pos";

					exists($sfx->{$key})
				or	$sfx->{$key} = _FirstSfx($grammar,$firstset,
											 $termlst,$terminx,
											 $ruleno,$pos,$key);

                $follows->{$goto}|=$sfx->{$key};

                    vec($follows->{$goto},0,1)
                and do {
                    my($lhs)=$$grammar{RULES}[$ruleno][0];

                    vec($follows->{$goto},0,1)=0;

                    for my $predno (@{_Preds($states,$stateno,$pos-1)}) {
                        ++$rel->{$goto}{"$predno.$lhs"};
                    }
                };
            }
        }
    }
    _Digraph($rel,$follows);

	($follows,$inconsistent)
}

sub _ComputeLA {
	my($grammar,$states)=@_;
	my($termlst)= [ '',keys(%{$$grammar{TERM}}) ];

    my($follows,$inconsistent) = _ComputeFollows($grammar,$states,$termlst);

    for my $stateno ( keys(%$inconsistent ) ) {
        my($state)=$$states[$stateno];
        my($conflict);

        #NB the sort is VERY important for conflicts resolution order
        for my $ruleno (sort { $a <=> $b }
                        @{$$state{ACTIONS}{''}}) {
            for my $term ( map { $termlst->[$_] } grep {
                           vec($follows->{"$stateno.$ruleno"},$_,1) }
                           0..$#$termlst) {
                    exists($$state{ACTIONS}{$term})
                and ++$conflict;
                push(@{$$state{ACTIONS}{$term}},-$ruleno);
            }
        }
        delete($$state{ACTIONS}{''});
            $conflict
        or  delete($inconsistent->{$stateno});
    }

	$inconsistent
}

#############################
# Solve remaining conflicts #
#############################

sub _SolveConflicts {
	my($grammar,$states,$inconsistent)=@_;
    my(%rulesprec,$RulePrec);
    my($conflicts)={    SOLVED  =>  {},
                    	FORCED  =>  {   TOTAL   =>  [ 0, 0 ],
                                    	DETAIL  =>  {}
                                 	}
                };

    $RulePrec = sub {
        my($ruleno)=@_;
        my($rhs,$rprec)=@{$$grammar{RULES}[$ruleno]}[1,2];
        my($lastterm);

            defined($rprec)
        and return($rprec);

            exists($rulesprec{$ruleno})
        and return($rulesprec{$ruleno});

        $lastterm=(grep { exists($$grammar{TERM}{$_}) } @$rhs)[-1];

            defined($lastterm)
        and ref($$grammar{TERM}{$lastterm})
        and do {
            $rulesprec{$ruleno}=$$grammar{TERM}{$lastterm}[1];
            return($rulesprec{$ruleno});
        };

        undef;
    };

    for my $stateno (keys(%$inconsistent)) {
        my($state)=$$states[$stateno];
        my($actions)=$$state{ACTIONS};
        my($nbsr,$nbrr);

        for my $term ( keys(%$actions) ) {
            my($act)=$$actions{$term};

                @$act > 1
            or  next;

                $$act[0] > 0
            and ref($$grammar{TERM}{$term})
            and do {
                my($assoc,$tprec)=@{$$grammar{TERM}{$term}};
                my($k,$error);

                for ($k=1;$k<@$act;++$k) {
                    my($ruleno)=-$$act[$k];
                    my($rprec)=&$RulePrec($ruleno);

                        defined($rprec)
                    or  next;

                        (     $tprec > $rprec
                         or ( $tprec == $rprec and $assoc eq 'RIGHT'))
                    and do {
                        push(@{$$conflicts{SOLVED}{$stateno}},
                             [ $ruleno, $term, 'shift' ]);
                        splice(@$act,$k--,1);
                        next;
                    };
                        (   $tprec < $rprec
                         or $assoc eq 'LEFT')
                    and do {
                        push(@{$$conflicts{SOLVED}{$stateno}},
                             [ $ruleno, $term, 'reduce' ]);
                            $$act[0] > 0
                        and do {
                            splice(@$act,0,1);
                            --$k;
                        };
                        next;
                    };
                    push(@{$$conflicts{SOLVED}{$stateno}},
                         [ $ruleno, $term, 'error' ]);
                    splice(@$act,$k--,1);
                        $$act[0] > 0
                    and do {
                        splice(@$act,0,1);
                        ++$error;
                        --$k;
                    };
                }
                    $error
                and unshift(@$act,undef);
            };

                @$act > 1
            and do {
                $nbrr += @$act - 2;
                ($$act[0] > 0 ? $nbsr : $nbrr) += 1;
                push(@{$$conflicts{FORCED}{DETAIL}{$stateno}{LIST}},
                    map { [ $term, $_ ] } splice(@$act,1));
            };
        }

            $nbsr
        and do {
            $$conflicts{FORCED}{TOTAL}[0]+=$nbsr;
            $$conflicts{FORCED}{DETAIL}{$stateno}{TOTAL}[0]+=$nbsr;
        };

            $nbrr
        and do {
            $$conflicts{FORCED}{TOTAL}[1]+=$nbrr;
            $$conflicts{FORCED}{DETAIL}{$stateno}{TOTAL}[1]+=$nbrr;
        };

    }

	$conflicts
}

###############################
# Make default reduce actions #
###############################
sub _SetDefaults {
	my($states)=@_;

  for my $state (@$states) {
    my($actions)=$$state{ACTIONS};

    # %reduces: - rule number => array of tokens to reduce
    # $nodefault is true if no default can be derived
    my(%reduces,$default,$nodefault);

    #If action with ''=> no default
    exists($$actions{''})
      and do {
        $$actions{''}[0] = -$$actions{''}[0];
        ++$nodefault;
      };

    #shift error token => no default
    exists($$actions{error})
      and $$actions{error}[0] > 0
        and ++$nodefault;

    for my $term (keys(%$actions)) {

      $$actions{$term}=$$actions{$term}[0];

      (not defined($$actions{$term}) or $$actions{$term} > 0 or $nodefault)
        and next;

      push(@{$reduces{$$actions{$term}}},$term);
    }

    keys(%reduces) > 0 or next;

    # Find the production rule with the largest reduce set, i.e.
    # the largest number of tokens

#   OLD CODE:
#   $default=(
#     # take the largest ...
#     map { $$_[0] }
#       # sort them by cardinal (in reverse)
#       sort { $$b[1] <=> $$a[1] or $$b[0] <=> $$a[0] }
#         # list of [ - rule number, number of tokens for that rule ]
#         map { [ $_, scalar(@{$reduces{$_}}) ] }
#           keys(%reduces) # list of - rule numbers
#   )[0];

    my $max = 0;
    for (keys(%reduces)) {
      my $t = @{$reduces{$_}};
      ($max, $default) = ($t, $_) if $t > $max;
    }

    delete(@$actions{ @{$reduces{$default}} });
    $$state{ACTIONS}{''}=$default;
  }
}

sub _dereference {
	my($states)=@_;

  for my $state (@$states) {
    my($actions)=$$state{ACTIONS};

    exists($$actions{''})
      and do {
        $$actions{''}[0] = -$$actions{''}[0];
      };

    for my $term (keys(%$actions)) {
      $$actions{$term}=$$actions{$term}[0];
    }

  }
}

sub _LALR {
	my($grammar,$states) = @_;
	my($conflicts,$inconsistent);

  $inconsistent = _ComputeLA($grammar,$states);

  $conflicts = _SolveConflicts($grammar,$states,$inconsistent);

  if ($grammar->{NOCOMPACT}) {
    _dereference($states);
  }
  else {
    _SetDefaults($states);
  }

	$conflicts
}


1;