#

# Module Parse::Yapp::Lalr

#

# (c) Copyright 1998-2001 Francois Desarmenien, all rights reserved.

# (see the pod text in Parse::Yapp module for use and distribution rights)

#

package Parse::Yapp::Lalr;

@ISA=qw( Parse::Yapp::Grammar );

require 5.004;

use Parse::Yapp::Grammar;

=for nobody

Parse::Yapp::Compile Object Structure:

--------------------------------------

{

   GRAMMAR =>    Parse::Yapp::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)

=cut

use strict;

use Carp;

###############

# Constructor #

###############

sub new {

    my($class)=shift;

		ref($class)

	and	$class=ref($class);

	my($self)=$class->SUPER::new(@_);

    $self->_Compile();

    bless($self,$class);

}

###########

# Methods #

###########

###########################

# Method To View Warnings #

###########################

sub Warnings {

    my($self)=shift;

    my($text);

    my($nbsr,$nbrr)=@{$$self{CONFLICTS}{FORCED}{TOTAL}};

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

        $nbsr != $$self{GRAMMAR}{EXPECT}

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

        $nbrr

    and do {

            $nbsr

        and $text.=" and ";

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

    };

       (    $nbsr != $$self{GRAMMAR}{EXPECT}

        or  $nbrr)

    and $text.="\n";

    $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;

                };

                $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;

}

######################################

# 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;

}

####################################

# 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 # 

#######################

=for nobody

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

=cut

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);