diff -r 8b87ea768cb8 -r 60053dab7e2a dummy_foundation/lib/Parse/Yapp/Lalr.pm --- a/dummy_foundation/lib/Parse/Yapp/Lalr.pm Wed Jun 03 18:33:51 2009 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,939 +0,0 @@ -# -# 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); - - 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 # -######################################################### -=for nobody - 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 -=cut -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; -} - -=for noboby - 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) -=cut -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}; - my(%reduces,$default,$nodefault); - - 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; - - $default=( map { $$_[0] } - sort { $$b[1] <=> $$a[1] or $$b[0] <=> $$a[0] } - map { [ $_, scalar(@{$reduces{$_}}) ] } - keys(%reduces))[0]; - - delete(@$actions{ @{$reduces{$default}} }); - $$state{ACTIONS}{''}=$default; - } -} - -sub _LALR { - my($grammar,$states) = @_; - my($conflicts,$inconsistent); - - $inconsistent = _ComputeLA($grammar,$states); - - $conflicts = _SolveConflicts($grammar,$states,$inconsistent); - _SetDefaults($states); - - $conflicts -} - - -1;