/usr/local/CPAN/Parse-Eyapp/Parse/Eyapp/Driver.pm
#
# Module Parse::Eyapp::Driver
#
# This module is part of the Parse::Eyapp package available on your
# nearest CPAN
#
# This module is based on Francois Desarmenien Parse::Yapp module
# (c) Parse::Yapp Copyright 1998-2001 Francois Desarmenien, all rights reserved.
# (c) Parse::Eyapp Copyright 2006-2010 Casiano Rodriguez-Leon, all rights reserved.
our $SVNREVISION = '$Rev: 2399M $';
our $SVNDATE = '$Date: 2009-01-06 12:28:04 +0000 (mar, 06 ene 2009) $';
package Parse::Eyapp::Driver;
require 5.006;
use strict;
our ( $VERSION, $COMPATIBLE, $FILENAME );
# $VERSION is also in Parse/Eyapp.pm
$VERSION = "1.181";
$COMPATIBLE = '0.07';
$FILENAME =__FILE__;
use Carp;
use Scalar::Util qw{blessed reftype looks_like_number};
use Getopt::Long;
#Known parameters, all starting with YY (leading YY will be discarded)
my (%params)=(YYLEX => 'CODE', 'YYERROR' => 'CODE', YYVERSION => '',
YYRULES => 'ARRAY', YYSTATES => 'ARRAY', YYDEBUG => '',
# added by Casiano
#YYPREFIX => '', # Not allowed at YYParse time but in new
YYFILENAME => '',
YYBYPASS => '',
YYGRAMMAR => 'ARRAY',
YYTERMS => 'HASH',
YYBUILDINGTREE => '',
YYACCESSORS => 'HASH',
YYCONFLICTHANDLERS => 'HASH',
YYSTATECONFLICT => 'HASH',
YYLABELS => 'HASH',
);
my (%newparams) = (%params, YYPREFIX => '',);
#Mandatory parameters
my (@params)=('LEX','RULES','STATES');
sub new {
my($class)=shift;
my($errst,$nberr,$token,$value,$check,$dotpos);
my($self)={
ERRST => \$errst,
NBERR => \$nberr,
TOKEN => \$token,
VALUE => \$value,
DOTPOS => \$dotpos,
STACK => [],
DEBUG => 0,
PREFIX => "",
CHECK => \$check,
};
_CheckParams( [], \%newparams, \@_, $self );
exists($$self{VERSION})
and $$self{VERSION} < $COMPATIBLE
and croak "Eyapp driver version $VERSION ".
"incompatible with version $$self{VERSION}:\n".
"Please recompile parser module.";
ref($class)
and $class=ref($class);
unless($self->{ERROR}) {
$self->{ERROR} = $class->error;
$self->{ERROR} = \&_Error unless ($self->{ERROR});
}
unless ($self->{LEX}) {
$self->{LEX} = $class->YYLexer;
@params = ('RULES','STATES');
}
my $parser = bless($self,$class);
$parser;
}
sub YYParse {
my($self)=shift;
my($retval);
_CheckParams( \@params, \%params, \@_, $self );
unless($self->{ERROR}) {
$self->{ERROR} = $self->error;
$self->{ERROR} = \&_Error unless ($self->{ERROR});
}
unless($self->{LEX}) {
$self->{LEX} = $self->YYLexer;
croak "Missing parameter 'yylex' " unless $self->{LEX} && reftype($self->{LEX}) eq 'CODE';
}
if($$self{DEBUG}) {
_DBLoad();
$retval = eval '$self->_DBParse()';#Do not create stab entry on compile
$@ and die $@;
}
else {
$retval = $self->_Parse();
}
return $retval;
}
sub YYData {
my($self)=shift;
exists($$self{USER})
or $$self{USER}={};
$$self{USER};
}
sub YYErrok {
my($self)=shift;
${$$self{ERRST}}=0;
undef;
}
sub YYNberr {
my($self)=shift;
${$$self{NBERR}};
}
sub YYRecovering {
my($self)=shift;
${$$self{ERRST}} != 0;
}
sub YYAbort {
my($self)=shift;
${$$self{CHECK}}='ABORT';
undef;
}
sub YYAccept {
my($self)=shift;
${$$self{CHECK}}='ACCEPT';
undef;
}
# Used to set that we are in "error recovery" state
sub YYError {
my($self)=shift;
${$$self{CHECK}}='ERROR';
undef;
}
sub YYSemval {
my($self)=shift;
my($index)= $_[0] - ${$$self{DOTPOS}} - 1;
$index < 0
and -$index <= @{$$self{STACK}}
and return $$self{STACK}[$index][1];
undef; #Invalid index
}
### Casiano methods
sub YYRule {
# returns the list of rules
# counting the super rule as rule 0
my $self = shift;
my $index = shift;
if ($index) {
$index = $self->YYIndex($index) unless (looks_like_number($index));
return wantarray? @{$self->{RULES}[$index]} : $self->{RULES}[$index]
}
return wantarray? @{$self->{RULES}} : $self->{RULES}
}
# YYState returns the list of states. Each state is an anonymous hash
# DB<4> x $parser->YYState(2)
# 0 HASH(0xfa7120)
# 'ACTIONS' => HASH(0xfa70f0) # token => state
# ':' => '-7'
# 'DEFAULT' => '-6'
# There are three keys: ACTIONS, GOTOS and DEFAULT
# DB<7> x $parser->YYState(13)
# 0 HASH(0xfa8b50)
# 'ACTIONS' => HASH(0xfa7530)
# 'VAR' => 17
# 'GOTOS' => HASH(0xfa8b20)
# 'type' => 19
sub YYState {
my $self = shift;
my $index = shift;
if ($index) {
# Comes from the stack: a pair [state number, attribute]
$index = $index->[0] if 'ARRAY' eq reftype($index);
die "YYState error. Expecting a number, found <$index>" unless (looks_like_number($index));
return $self->{STATES}[$index]
}
return $self->{STATES}
}
sub YYGoto {
my ($self, $state, $symbol) = @_;
my $stateLRactions = $self->YYState($state);
$stateLRactions->{GOTOS}{$symbol};
}
sub YYRHSLength {
my $self = shift;
# If no production index is given, is the production begin used in the current reduction
my $index = shift || $self->YYRuleindex;
# If the production was given by its name, compute its index
$index = $self->YYIndex($index) unless looks_like_number($index);
return unless looks_like_number($index);
my $currentprod = $self->YYRule($index);
$currentprod->[1] if reftype($currentprod);
}
# To be used in a semantic action, when reducing ...
# It gives the next state after reduction
sub YYNextState {
my $self = shift;
my $lhs = $self->YYLhs;
if ($lhs) { # reduce
my $length = $self->YYRHSLength;
my $state = $self->YYTopState($length);
#print "state = $$state[0]\n";
$self->YYGoto($state, $lhs);
}
else { # shift: a token must be provided as argument
my $token = shift;
my $state = $self->YYTopState;
$self->YYGetLRAction($state, $token);
}
}
# TODO: make it work with a list of indices ...
sub YYGrammar {
my $self = shift;
my $index = shift;
if ($index) {
$index = $self->YYIndex($index) unless (looks_like_number($index));
return wantarray? @{$self->{GRAMMAR}[$index]} : $self->{GRAMMAR}[$index]
}
return wantarray? @{$self->{GRAMMAR}} : $self->{GRAMMAR}
}
# Return the list of production names
sub YYNames {
my $self = shift;
my @names = map { $_->[0] } @{$self->{GRAMMAR}};
return wantarray? @names : \@names;
}
# Return the hash of indices for each production name
# Initializes the INDICES attribute of the parser
# Returns the index of the production rule with name $name
sub YYIndex {
my $self = shift;
if (@_) {
my @indices = map { $self->{LABELS}{$_} } @_;
return wantarray? @indices : $indices[0];
}
return wantarray? %{$self->{LABELS}} : $self->{LABELS};
}
sub YYTopState {
my $self = shift;
my $length = shift || 0;
$length = -$length unless $length <= 0;
$length--;
$_[1] and $self->{STACK}[$length] = $_[1];
$self->{STACK}[$length];
}
sub YYStack {
my $self = shift;
return $self->{STACK};
}
# To dynamically set syntactic actions
# Change it to state, token, action
# it is more natural
sub YYSetLRAction {
my ($self, $state, $token, $action) = @_;
die "YYLRAction: Provide a state " unless defined($state);
# Action can be given using the name of the production
$action = -$self->YYIndex($action) unless looks_like_number($action);
$token = [ $token ] unless ref($token);
for (@$token) {
$self->{STATES}[$state]{ACTIONS}{$_} = $action;
}
}
sub YYRestoreLRAction {
my $self = shift;
my $conflictname = shift;
my @tokens = @_;
for (@tokens) {
my ($conflictstate, $action) = @{$self->{CONFLICT}{$conflictname}{$_}};
$self->{STATES}[$conflictstate]{ACTIONS}{$_} = $action;
}
}
# Fools the lexer to get a new token
# without modifying the parsing position (pos)
# Warning, warning! this and YYLookaheads assume
# that the input comes from the string
# referenced by $self->input.
# It will not work for a stream
sub YYLookahead {
my $self = shift;
my $pos = pos(${$self->input});
my ($nextToken, $val) = $self->YYLexer->($self);
# restore pos
pos(${$self->input}) = $pos;
return $nextToken;
}
# Fools the lexer to get $spec new tokens
sub YYLookaheads {
my $self = shift;
my $spec = shift || 1; # a number
my $pos = pos(${$self->input});
my @r; # list of lookahead tokens
my ($t, $v);
if (looks_like_number($spec)) {
for my $i (1..$spec) {
($t, $v) = $self->YYLexer->($self);
push @r, $t;
last if $t eq '';
}
}
else { # if string
do {
($t, $v) = $self->YYLexer->($self);
push @r, $t;
} while ($t ne $spec && $t ne '');
}
# restore pos
pos(${$self->input}) = $pos;
return @r;
}
# more parameters: debug, etc, ...
#sub YYNestedParse {
sub YYPreParse {
my $self = shift;
my $parser = shift;
my $file = shift() || $parser;
# Check for errors!
eval "require $file";
# optimize to state variable for 5.10
my $rp = $parser->new( yyerror => sub {});
my $pos = pos(${$self->input});
my $rpos = $self->{POS};
#print "pos = $pos\n";
$rp->input($self->input);
pos(${$rp->input}) = $rpos;
my $t = $rp->Run(@_);
my $ne = $rp->YYNberr;
#print "After nested parsing\n";
pos(${$self->input}) = $pos;
return (wantarray ? ($t, !$ne) : !$ne);
}
sub YYNestedParse {
my $self = shift;
my $parser = shift;
my $conflictName = shift;
$conflictName = $self->YYLhs unless $conflictName;
my ($t, $ok) = $self->YYPreParse($parser, @_);
$self->{CONFLICTHANDLERS}{$conflictName}{".".$parser} = [$ok, $t];
return $ok;
}
sub YYNestedRegexp {
my $self = shift;
my $regexp = shift;
my $conflictName = $self->YYLhs;
my $ok = $_ =~ /$regexp/gc;
$self->{CONFLICTHANDLERS}{$conflictName}{'..regexp'} = [$ok, undef];
return $ok;
}
sub YYIs {
my $self = shift;
# this is ungly and dangeorus. Don't use the dot. Change it!
my $syntaxVariable = '.'.(shift());
my $conflictName = $self->YYLhs;
my $v = $self->{CONFLICTHANDLERS}{$conflictName};
$v->{$syntaxVariable}[0] = shift if @_;
return $v->{$syntaxVariable}[0];
}
sub YYVal {
my $self = shift;
# this is ungly and dangeorus. Don't use the dot. Change it!
my $syntaxVariable = '.'.(shift());
my $conflictName = $self->YYLhs;
my $v = $self->{CONFLICTHANDLERS}{$conflictName};
$v->{$syntaxVariable}[1] = shift if @_;
return $v->{$syntaxVariable}[1];
}
#x $self->{CONFLICTHANDLERS}
#0 HASH(0x100b306c0)
# 'rangeORenum' => HASH(0x100b30660)
# 'explorerline' => 12
# 'line' => 5
# 'production' => HASH(0x100b30580)
# '-13' => ARRAY(0x100b30520)
# 0 1 <------- mark: conflictive position in the rhs
# '-5' => ARRAY(0x100b30550)
# 0 1 <------- mark: conflictive position in the rhs
# 'states' => ARRAY(0x100b30630)
# 0 HASH(0x100b30600)
# 25 => ARRAY(0x100b305c0)
# 0 '\',\''
# 1 '\')\''
sub YYSetReduceXXXXX {
my $self = shift;
my $action = pop;
my $token = shift;
croak "YYSetReduce error: specify a production" unless defined($action);
# Conflict state
my $conflictstate = $self->YYNextState();
my $conflictName = $self->YYLhs;
#$self->{CONFLICTHANDLERS}{conflictName}{states}
# is a hash
# statenumber => [ tokens, '\'-\'' ]
my $cS = $self->{CONFLICTHANDLERS}{$conflictName}{states};
my @conflictStates = $cS ? @$cS : ();
# Perform the action to change the LALR tables only if the next state
# is listed as a conflictstate
my ($cs) = (grep { exists $_->{$conflictstate}} @conflictStates);
return unless $cs;
# Action can be given using the name of the production
unless (looks_like_number($action)) {
my $actionnum = $self->{LABELS}{$action};
unless (looks_like_number($actionnum)) {
croak "YYSetReduce error: can't find production '$action'. Did you forget to name it?";
}
$action = -$actionnum;
}
$token = $cs->{$conflictstate} unless defined($token);
$token = [ $token ] unless ref($token);
for (@$token) {
# save if shift
if (exists($self->{STATES}[$conflictstate]{ACTIONS}) and $self->{STATES}[$conflictstate]{ACTIONS}{$_} >= 0) {
$self->{CONFLICT}{$conflictName}{$_} = [ $conflictstate, $self->{STATES}[$conflictstate]{ACTIONS}{$_} ];
}
$self->{STATES}[$conflictstate]{ACTIONS}{$_} = $action;
}
}
sub YYSetReduce {
my $self = shift;
my $action = pop;
my $token = shift;
croak "YYSetReduce error: specify a production" unless defined($action);
my $conflictName = $self->YYLhs;
#$self->{CONFLICTHANDLERS}{conflictName}{states}
# is a hash
# statenumber => [ tokens, '\'-\'' ]
my $cS = $self->{CONFLICTHANDLERS}{$conflictName}{states};
my @conflictStates = $cS ? @$cS : ();
return unless @conflictStates;
# Conflict state
my $cs = $conflictStates[0];
my ($conflictstate) = keys %{$cs};
# Action can be given using the name of the production
unless (looks_like_number($action)) {
my $actionnum = $self->{LABELS}{$action};
unless (looks_like_number($actionnum)) {
croak "YYSetReduce error: can't find production '$action'. Did you forget to name it?";
}
$action = -$actionnum;
}
$token = $cs->{$conflictstate} unless defined($token);
$token = [ $token ] unless ref($token);
for (@$token) {
# save if shift
if (exists($self->{STATES}[$conflictstate]{ACTIONS}) and $self->{STATES}[$conflictstate]{ACTIONS}{$_} >= 0) {
$self->{CONFLICT}{$conflictName}{$_} = [ $conflictstate, $self->{STATES}[$conflictstate]{ACTIONS}{$_} ];
}
$self->{STATES}[$conflictstate]{ACTIONS}{$_} = $action;
}
}
sub YYSetShift {
my ($self, $token) = @_;
# my ($self, $token, $action) = @_;
# $action is syntactic sugar ...
my $conflictName = $self->YYLhs;
my $cS = $self->{CONFLICTHANDLERS}{$conflictName}{states};
my @conflictStates = $cS ? @$cS : ();
return unless @conflictStates;
my $cs = $conflictStates[0];
my ($conflictstate) = keys %{$cs};
$token = $cs->{$conflictstate} unless defined($token);
$token = [ $token ] unless ref($token);
for (@$token) {
if (defined($self->{CONFLICT}{$conflictName}{$_})) {
my ($conflictstate2, $action) = @{$self->{CONFLICT}{$conflictName}{$_}};
# assert($conflictstate == $conflictstate2)
$self->{STATES}[$conflictstate]{ACTIONS}{$_} = $self->{CONFLICT}{$conflictName}{$_}[1];
}
else {
#croak "YYSetShift error. No shift action found";
# shift is the default ... hope to be lucky!
}
}
}
# if is reduce ...
# x $self->{CONFLICTHANDLERS}{$conflictName}{production}{$action} $action is a number
#0 ARRAY(0x100b3f930)
# 0 2
# has the position in the item, starting at 0
# DB<19> x $self->YYRHSLength(4)
# 0 3
# if pos is length -1 then is reduce otherwise is shift
# It does YYSetReduce or YYSetshift according to the
# decision variable
# I need to know the kind of conflict that there is
# shift-reduce or reduce-reduce
sub YYIf {
my $self = shift;
my $syntaxVariable = shift;
if ($self->YYIs($syntaxVariable)) {
if ($_[0] eq 'shift') {
$self->YYSetShift(@_);
}
else {
$self->YYSetReduce($_[0]);
}
}
else {
if ($_[1] eq 'shift') {
$self->YYSetShift(@_);
}
else {
$self->YYSetReduce($_[1]);
}
}
$self->YYIs($syntaxVariable, 0);
}
sub YYGetLRAction {
my ($self, $state, $token) = @_;
$state = $state->[0] if reftype($state) && (reftype($state) eq 'ARRAY');
my $stateentry = $self->{STATES}[$state];
if (defined($token)) {
return $stateentry->{ACTIONS}{$token} if exists $stateentry->{ACTIONS}{$token};
}
return $stateentry->{DEFAULT} if exists $stateentry->{DEFAULT};
return;
}
# to dynamically set semantic actions
sub YYAction {
my $self = shift;
my $index = shift;
my $newaction = shift;
croak "YYAction error: Expecting an index" unless $index;
# If $index is the production 'name' find the actual index
$index = $self->YYIndex($index) unless looks_like_number($index);
my $rule = $self->{RULES}->[$index];
$rule->[2] = $newaction if $newaction && (reftype($newaction) eq 'CODE');
return $rule->[2];
}
sub YYSetaction {
my $self = shift;
my %newaction = @_;
for my $n (keys(%newaction)) {
my $m = looks_like_number($n) ? $n : $self->YYIndex($n);
my $rule = $self->{RULES}->[$m];
$rule->[2] = $newaction{$n} if ($newaction{$n} && (reftype($newaction{$n}) eq 'CODE'));
}
}
#sub YYDebugtree {
# my ($self, $i, $e) = @_;
#
# my ($name, $lhs, $rhs) = @$e;
# my @rhs = @$rhs;
#
# return if $name =~ /_SUPERSTART/;
# $name = $lhs."::"."@rhs";
# $name =~ s/\W/_/g;
# return $name;
#}
#
#sub YYSetnames {
# my $self = shift;
# my $newname = shift || \&YYDebugtree;
#
# die "YYSetnames error. Exected a CODE reference found <$newname>"
# unless $newname && (reftype($newname) eq 'CODE');
#
# my $i = 0;
# for my $e (@{$self->{GRAMMAR}}) {
# my $nn= $newname->($self, $i, $e);
# $e->[0] = $nn if defined($nn);
# $i++;
# }
#}
sub YYLhs {
# returns the syntax variable on
# the left hand side of the current production
my $self = shift;
return $self->{CURRENT_LHS}
}
sub YYRuleindex {
# returns the index of the rule
# counting the super rule as rule 0
my $self = shift;
return $self->{CURRENT_RULE}
}
sub YYRightside {
# returns the rule
# counting the super rule as rule 0
my $self = shift;
my $index = shift || $self->{CURRENT_RULE};
$index = $self->YYIndex($index) unless looks_like_number($index);
return @{$self->{GRAMMAR}->[$index]->[2]};
}
sub YYTerms {
my $self = shift;
return $self->{TERMS};
}
sub YYIsterm {
my $self = shift;
my $symbol = shift;
return exists ($self->{TERMS}->{$symbol});
}
sub YYIssemantic {
my $self = shift;
my $symbol = shift;
return 0 unless exists($self->{TERMS}{$symbol});
$self->{TERMS}{$symbol}{ISSEMANTIC} = shift if @_;
return ($self->{TERMS}{$symbol}{ISSEMANTIC});
}
sub YYName {
my $self = shift;
my $current_rule = $self->{GRAMMAR}->[$self->{CURRENT_RULE}];
$current_rule->[0] = shift if @_;
return $current_rule->[0];
}
sub YYPrefix {
my $self = shift;
$self->{PREFIX} = $_[0] if @_;
$self->{PREFIX};
}
sub YYAccessors {
my $self = shift;
$self->{ACCESSORS}
}
# name of the file containing
# the source grammar
sub YYFilename {
my $self = shift;
$self->{FILENAME} = $_[0] if @_;
$self->{FILENAME};
}
sub YYBypass {
my $self = shift;
$self->{BYPASS} = $_[0] if @_;
$self->{BYPASS};
}
sub YYBypassrule {
my $self = shift;
$self->{GRAMMAR}->[$self->{CURRENT_RULE}][3] = $_[0] if @_;
return $self->{GRAMMAR}->[$self->{CURRENT_RULE}][3];
}
sub YYFirstline {
my $self = shift;
$self->{FIRSTLINE} = $_[0] if @_;
$self->{FIRSTLINE};
}
# Used as default action when writing a reusable grammar.
# See files examples/recycle/NoacInh.eyp
# and examples/recycle/icalcu_and_ipost.pl
# in the Parse::Eyapp distribution
sub YYDelegateaction {
my $self = shift;
my $action = $self->YYName;
$self->$action(@_);
}
# Influences the behavior of YYActionforT_X1X2
# YYActionforT_single and YYActionforT_empty
# If true these methods will build simple lists of attributes
# for the lists operators X*, X+ and X? and parenthesis (X Y)
# Otherwise the classic node construction for the
# syntax tree is used
sub YYBuildingTree {
my $self = shift;
$self->{BUILDINGTREE} = $_[0] if @_;
$self->{BUILDINGTREE};
}
sub BeANode {
my $class = shift;
no strict 'refs';
push @{$class."::ISA"}, "Parse::Eyapp::Node" unless $class->isa("Parse::Eyapp::Node");
}
#sub BeATranslationScheme {
# my $class = shift;
#
# no strict 'refs';
# push @{$class."::ISA"}, "Parse::Eyapp::TranslationScheme" unless $class->isa("Parse::Eyapp::TranslationScheme");
#}
{
my $attr = sub {
$_[0]{attr} = $_[1] if @_ > 1;
$_[0]{attr}
};
sub make_node_classes {
my $self = shift;
my $prefix = $self->YYPrefix() || '';
{ no strict 'refs';
*{$prefix."TERMINAL::attr"} = $attr;
}
for (@_) {
my ($class) = split /:/, $_;
BeANode("$prefix$class");
}
my $accessors = $self->YYAccessors();
for (keys %$accessors) {
my $position = $accessors->{$_};
no strict 'refs';
*{$prefix.$_} = sub {
my $self = shift;
return $self->child($position, @_)
}
} # for
}
}
####################################################################
# Usage : ????
# Purpose : Responsible for the %tree directive
# On each production the default action becomes:
# sub { goto &Parse::Eyapp::Driver::YYBuildAST }
#
# Returns : ????
# Parameters : ????
# Throws : no exceptions
# Comments : none
# See Also : n/a
# To Do : many things: Optimize this!!!!
sub YYBuildAST {
my $self = shift;
my $PREFIX = $self->YYPrefix();
my @right = $self->YYRightside(); # Symbols on the right hand side of the production
my $lhs = $self->YYLhs;
my $fullname = $self->YYName();
my ($name) = split /:/, $fullname;
my $bypass = $self->YYBypassrule; # Boolean: shall we do bypassing of lonely nodes?
my $class = "$PREFIX$name";
my @children;
my $node = bless {}, $class;
for(my $i = 0; $i < @right; $i++) {
local $_ = $right[$i]; # The symbol
my $ch = $_[$i]; # The attribute/reference
# is $ch already a Parse::Eyapp::Node. May be a terminal and a syntax variable share the same name?
unless (UNIVERSAL::isa($ch, 'Parse::Eyapp::Node')) {
if ($self->YYIssemantic($_)) {
my $class = $PREFIX.'TERMINAL';
my $node = bless { token => $_, attr => $ch, children => [] }, $class;
push @children, $node;
next;
}
if ($self->YYIsterm($_)) {
TERMINAL::save_attributes($ch, $node) if UNIVERSAL::can($PREFIX."TERMINAL", "save_attributes");
next;
}
}
if (UNIVERSAL::isa($ch, $PREFIX."_PAREN")) { # Warning: weak code!!!
push @children, @{$ch->{children}};
next;
}
# If it is an intermediate semantic action skip it
next if $_ =~ qr{@}; # intermediate rule
next unless ref($ch);
push @children, $ch;
}
if ($bypass and @children == 1) {
$node = $children[0];
my $childisterminal = ref($node) =~ /TERMINAL$/;
# Re-bless unless is "an automatically named node", but the characterization of this is
bless $node, $class unless $name =~ /${lhs}_\d+$/; # lazy, weak (and wicked).
my $finalclass = ref($node);
$childisterminal and !$finalclass->isa($PREFIX.'TERMINAL')
and do {
no strict 'refs';
push @{$finalclass."::ISA"}, $PREFIX.'TERMINAL'
};
return $node;
}
$node->{children} = \@children;
return $node;
}
sub YYBuildTS {
my $self = shift;
my $PREFIX = $self->YYPrefix();
my @right = $self->YYRightside(); # Symbols on the right hand side of the production
my $lhs = $self->YYLhs;
my $fullname = $self->YYName();
my ($name) = split /:/, $fullname;
my $class;
my @children;
for(my $i = 0; $i < @right; $i++) {
local $_ = $right[$i]; # The symbol
my $ch = $_[$i]; # The attribute/reference
if ($self->YYIsterm($_)) {
$class = $PREFIX.'TERMINAL';
push @children, bless { token => $_, attr => $ch, children => [] }, $class;
next;
}
if (UNIVERSAL::isa($ch, $PREFIX."_PAREN")) { # Warning: weak code!!!
push @children, @{$ch->{children}};
next;
}
# Substitute intermediate code node _CODE(CODE()) by CODE()
if (UNIVERSAL::isa($ch, $PREFIX."_CODE")) { # Warning: weak code!!!
push @children, $ch->child(0);
next;
}
next unless ref($ch);
push @children, $ch;
}
if (unpack('A1',$lhs) eq '@') { # class has to be _CODE check
$lhs =~ /^\@[0-9]+\-([0-9]+)$/
or croak "In line rule name '$lhs' ill formed: report it as a BUG.\n";
my $dotpos = $1;
croak "Fatal error building metatree when processing $lhs -> @right"
unless exists($_[$dotpos]) and UNIVERSAL::isa($_[$dotpos], 'CODE') ;
push @children, $_[$dotpos];
}
else {
my $code = $_[@right];
if (UNIVERSAL::isa($code, 'CODE')) {
push @children, $code;
}
else {
croak "Fatal error building translation scheme. Code or undef expected" if (defined($code));
}
}
$class = "$PREFIX$name";
my $node = bless { children => \@children }, $class;
$node;
}
sub YYActionforT_TX1X2_tree {
my $self = shift;
my $head = shift;
my $PREFIX = $self->YYPrefix();
my @right = $self->YYRightside();
my $class;
for(my $i = 1; $i < @right; $i++) {
local $_ = $right[$i];
my $ch = $_[$i-1];
if ($self->YYIssemantic($_)) {
$class = $PREFIX.'TERMINAL';
push @{$head->{children}}, bless { token => $_, attr => $ch, children => [] }, $class;
next;
}
next if $self->YYIsterm($_);
if (ref($ch) eq $PREFIX."_PAREN") { # Warning: weak code!!!
push @{$head->{children}}, @{$ch->{children}};
next;
}
next unless ref($ch);
push @{$head->{children}}, $ch;
}
return $head;
}
# For * and + lists
# S2 -> S2 X { push @$_[1] the node associated with X; $_[1] }
# S2 -> /* empty */ { a node with empty children }
sub YYActionforT_TX1X2 {
goto &YYActionforT_TX1X2_tree if $_[0]->YYBuildingTree;
my $self = shift;
my $head = shift;
push @$head, @_;
return $head;
}
sub YYActionforParenthesis {
goto &YYBuildAST if $_[0]->YYBuildingTree;
my $self = shift;
return [ @_ ];
}
sub YYActionforT_empty_tree {
my $self = shift;
my $PREFIX = $self->YYPrefix();
my $name = $self->YYName();
# Allow use of %name
my $class = $PREFIX.$name;
my $node = bless { children => [] }, $class;
#BeANode($class);
$node;
}
sub YYActionforT_empty {
goto &YYActionforT_empty_tree if $_[0]->YYBuildingTree;
[];
}
sub YYActionforT_single_tree {
my $self = shift;
my $PREFIX = $self->YYPrefix();
my $name = $self->YYName();
my @right = $self->YYRightside();
my $class;
# Allow use of %name
my @t;
for(my $i = 0; $i < @right; $i++) {
local $_ = $right[$i];
my $ch = $_[$i];
if ($self->YYIssemantic($_)) {
$class = $PREFIX.'TERMINAL';
push @t, bless { token => $_, attr => $ch, children => [] }, $class;
#BeANode($class);
next;
}
next if $self->YYIsterm($_);
if (ref($ch) eq $PREFIX."_PAREN") { # Warning: weak code!!!
push @t, @{$ch->{children}};
next;
}
next unless ref($ch);
push @t, $ch;
}
$class = $PREFIX.$name;
my $node = bless { children => \@t }, $class;
#BeANode($class);
$node;
}
sub YYActionforT_single {
goto &YYActionforT_single_tree if $_[0]->YYBuildingTree;
my $self = shift;
[ @_ ];
}
### end Casiano methods
sub YYCurtok {
my($self)=shift;
@_
and ${$$self{TOKEN}}=$_[0];
${$$self{TOKEN}};
}
sub YYCurval {
my($self)=shift;
@_
and ${$$self{VALUE}}=$_[0];
${$$self{VALUE}};
}
{
sub YYSimStack {
my $self = shift;
my $stack = shift;
my @reduce = @_;
my @expected;
for my $index (@reduce) {
my ($lhs, $length) = @{$self->{RULES}[-$index]};
if (@$stack > $length) {
my @auxstack = @$stack;
splice @auxstack, -$length if $length;
my $state = $auxstack[-1]->[0];
my $nextstate = $self->{STATES}[$state]{GOTOS}{$lhs};
if (defined($nextstate)) {
push @auxstack, [$nextstate, undef];
push @expected, $self->YYExpected(\@auxstack);
}
}
# else something went wrong!!! See Frank Leray report
}
return map { $_ => 1 } @expected;
}
sub YYExpected {
my($self)=shift;
my $stack = shift;
# The state in the top of the stack
my $state = $self->{STATES}[$stack->[-1][0]];
my %actions;
%actions = %{$state->{ACTIONS}} if exists $state->{ACTIONS};
# The keys of %reduction are the -production numbers
# Use hashes and not lists to guarantee that no tokens are repeated
my (%expected, %reduce);
for (keys(%actions)) {
if ($actions{$_} > 0) { # shift
$expected{$_} = 1;
next;
}
$reduce{$actions{$_}} = 1;
}
$reduce{$state->{DEFAULT}} = 1 if exists($state->{DEFAULT});
if (keys %reduce) {
%expected = (%expected, $self->YYSimStack($stack, keys %reduce));
}
return keys %expected;
}
sub YYExpect {
my $self = shift;
$self->YYExpected($self->{STACK}, @_);
}
}
# $self->expects($token) : returns true if the token is among the expected ones
sub expects {
my $self = shift;
my $token = shift;
my @expected = $self->YYExpect;
return grep { $_ eq $token } @expected;
}
BEGIN {
*YYExpects = \&expects;
}
# Set/Get a static/class attribute for $class
# Searches the $class ancestor tree for an ancestor
# having defined such attribute. If found, that value is returned
sub static_attribute {
my $class = shift;
$class = ref($class) if ref($class);
my $attributename = shift;
# class/static method
no strict 'refs';
my $classlexer;
my $classname = $classlexer = $class.'::'.$attributename;
if (@_) {
${$classlexer} = shift;
}
return ${$classlexer} if defined($$classlexer);
# Traverse the inheritance tree for a defined
# version of the attribute
my @classes = @{$class.'::ISA'};
my %classes = map { $_ => undef } @classes;
while (@classes) {
my $c = shift @classes || return;
$classlexer = $c.'::'.$attributename;
if (defined($$classlexer)) {
$$classname = $$classlexer;
return $$classlexer;
}
# push those that aren't already there
push @classes, grep { !exists $classes{$_} } @{$c.'::ISA'};
}
return undef;
}
sub YYEndOfInput {
my $self = shift;
for (${$self->input}) {
return !defined($_) || ($_ eq '') || (defined(pos($_)) && (pos($_) >= length($_)));
}
}
#################
# Private stuff #
#################
sub _CheckParams {
my ($mandatory,$checklist,$inarray,$outhash)=@_;
my ($prm,$value);
my ($prmlst)={};
while(($prm,$value)=splice(@$inarray,0,2)) {
$prm=uc($prm);
exists($$checklist{$prm})
or croak("Unknown parameter '$prm'");
ref($value) eq $$checklist{$prm}
or croak("Invalid value for parameter '$prm'");
$prm=unpack('@2A*',$prm);
$$outhash{$prm}=$value;
}
for (@$mandatory) {
exists($$outhash{$_})
or croak("Missing mandatory parameter '".lc($_)."'");
}
}
#################### TailSupport ######################
sub line {
my $self = shift;
if (ref($self)) {
$self->{TOKENLINE} = shift if @_;
return $self->static_attribute('TOKENLINE', @_,) unless defined($self->{TOKENLINE}); # class/static method
return $self->{TOKENLINE};
}
else { # class/static method
return $self->static_attribute('TOKENLINE', @_,); # class/static method
}
}
# attribute to count the lines
sub tokenline {
my $self = shift;
if (ref($self)) {
$self->{TOKENLINE} += shift if @_;
return $self->static_attribute('TOKENLINE', @_,) unless defined($self->{TOKENLINE}); # class/static method
return $self->{TOKENLINE};
}
else { # class/static method
return $self->static_attribute('TOKENLINE', @_,); # class/static method
}
}
our $ERROR = \&_Error;
sub error {
my $self = shift;
if (ref $self) { # instance method
$self->{ERROR} = shift if @_;
return $self->static_attribute('ERROR', @_,) unless defined($self->{ERROR}); # class/static method
return $self->{ERROR};
}
else { # class/static method
return $self->static_attribute('ERROR', @_,); # class/static method
}
}
# attribute with the input
# is a reference to the actual input
# slurp_file.
# Parameters: object or class, filename, prompt messagge, mode (interactive or not: undef or "\n")
*YYSlurpFile = \&slurp_file;
sub slurp_file {
my $self = shift;
my $fn = shift;
my $f;
my $mode = undef;
if ($fn && -r $fn) {
open $f, $fn or die "Can't find file '$fn'!\n";
}
else {
$f = \*STDIN;
my $msg = $self->YYPrompt();
$mode = shift;
print($msg) if $msg;
}
$self->YYInputFile($f);
local $/ = $mode;
my $input = <$f>;
if (ref($self)) { # called as object method
$self->input(\$input);
}
else { # class/static method
my $classinput = $self.'::input';
${$classinput}->input(\$input);
}
}
our $INPUT = \undef;
*Parse::Eyapp::Driver::YYInput = \&input;
sub input {
my $self = shift;
$self->line(1) if @_; # used as setter
if (ref $self) { # instance method
if (@_) {
if (ref $_[0]) {
$self->{INPUT} = shift;
}
else {
my $input = shift;
$self->{INPUT} = \$input;
}
}
return $self->static_attribute('INPUT', @_,) unless defined($self->{INPUT}); # class/static method
return $self->{INPUT};
}
else { # class/static method
return $self->static_attribute('INPUT', @_,); # class/static method
}
}
*YYInput = \&input; # alias
# Opened file used to get the input
# static and instance method
our $INPUTFILE = \*STDIN;
sub YYInputFile {
my $self = shift;
if (ref($self)) { # object method
my $file = shift;
if ($file) { # setter
$self->{INPUTFILE} = $file;
}
return $self->static_attribute('INPUTFILE', @_,) unless defined($self->{INPUTFILE}); # class/static method
return $self->{INPUTFILE};
}
else { # static
return $self->static_attribute('INPUTFILE', @_,); # class/static method
}
}
our $PROMPT;
sub YYPrompt {
my $self = shift;
if (ref($self)) { # object method
my $prompt = shift;
if ($prompt) { # setter
$self->{PROMPT} = $prompt;
}
return $self->static_attribute('PROMPT', @_,) unless defined($self->{PROMPT}); # class/static method
return $self->{PROMPT};
}
else { # static
return $self->static_attribute('PROMPT', @_,); # class/static method
}
}
# args: parser, debug and optionally the input or a reference to the input
sub Run {
my ($self) = shift;
my $yydebug = shift;
if (defined($_[0])) {
if (ref($_[0])) { # if arg is a reference
$self->input(shift());
}
else { # arg isn't a ref: make a copy
my $x = shift();
$self->input(\$x);
}
}
croak "Provide some input for parsing" unless ($self->input && defined(${$self->input()}));
return $self->YYParse(
#yylex => $self->lexer(),
#yyerror => $self->error(),
yydebug => $yydebug, # 0xF
);
}
*Parse::Eyapp::Driver::YYRun = \&run;
# args: class, prompt, file, optionally input (ref or not)
# return the abstract syntax tree (or whatever was returned by the parser)
*Parse::Eyapp::Driver::YYMain = \&main;
sub main {
my $package = shift;
my $prompt = shift;
my $debug = 0;
my $file = '';
my $showtree = 0;
my $TERMINALinfo;
my $help;
my $slurp;
my $inputfromfile = 1;
my $commandinput = '';
my $quotedcommandinput = '';
my $yaml = 0;
my $dot = 0;
my $result = GetOptions (
"debug!" => \$debug, # sets yydebug on
"file=s" => \$file, # read input from that file
"commandinput=s" => \$commandinput, # read input from command line arg
"tree!" => \$showtree, # prints $tree->str
"info" => \$TERMINALinfo, # prints $tree->str and provides default TERMINAL::info
"help" => \$help, # shows SYNOPSIS section from the script pod
"slurp!" => \$slurp, # read until EOF or CR is reached
"argfile!" => \$inputfromfile, # take input string from @_
"yaml" => \$yaml, # dumps YAML for $tree: YAML must be installed
"dot=s" => \$dot, # dumps YAML for $tree: YAML must be installed
"margin=i" => \$Parse::Eyapp::Node::INDENT,
);
$package->_help() if $help;
$debug = 0x1F if $debug;
$file = shift if !$file && @ARGV; # file is taken from the @ARGV unless already defined
$slurp = "\n" if defined($slurp);
my $parser = $package->new();
$parser->YYPrompt($prompt) if defined($prompt);
if ($commandinput) {
$parser->input(\$commandinput);
}
elsif ($inputfromfile) {
$parser->slurp_file( $file, $slurp);
}
else { # input must be a string argument
croak "No input provided for parsing! " unless defined($_[0]);
if (ref($_[0])) {
$parser->input(shift());
}
else {
my $x = shift();
$parser->input(\$x);
}
}
if (defined($TERMINALinfo)) {
my $prefix = ($parser->YYPrefix || '');
no strict 'refs';
*{$prefix.'TERMINAL::info'} = sub {
(ref($_[0]->attr) eq 'ARRAY')? $_[0]->attr->[0] : $_[0]->attr
};
}
my $tree = $parser->Run( $debug, @_ );
if (my $ne = $parser->YYNberr > 0) {
print "There were $ne errors during parsing\n";
return undef;
}
else {
if ($showtree) {
if ($tree && blessed $tree && $tree->isa('Parse::Eyapp::Node')) {
print $tree->str()."\n";
}
elsif ($tree && ref $tree) {
require Data::Dumper;
print Data::Dumper::Dumper($tree)."\n";
}
elsif (defined($tree)) {
print "$tree\n";
}
}
if ($yaml && ref($tree)) {
eval {
require YAML;
};
if ($@) {
print "You must install 'YAML' to use this option\n";
}
else {
YAML->import;
print Dump($tree);
}
}
if ($dot && blessed($tree)) {
my ($sfile, $extension) = $dot =~ /^(.*)\.([^.]*)$/;
$extension = 'png' unless (defined($extension) and $tree->can($extension));
($sfile) = $file =~ m{(.*[^.])} if !defined($sfile) and defined($file);
$tree->$extension($sfile);
}
return $tree
}
}
sub _help {
my $package = shift;
print << 'AYUDA';
Available options:
--debug sets yydebug on
--nodebug sets yydebug off
--file filepath read input from filepath
--commandinput string read input from string
--tree prints $tree->str
--notree does not print $tree->str
--info When printing $tree->str shows the value of TERMINALs
--help shows this help
--slurp read until EOF reached
--noslurp read until CR is reached
--argfile main() will take the input string from its @_
--noargfile main() will not take the input string from its @_
--yaml dumps YAML for $tree: YAML module must be installed
--margin=i controls the indentation of $tree->str (i.e. $Parse::Eyapp::Node::INDENT)
--dot format produces a .dot and .format file (png,jpg,bmp, etc.)
AYUDA
$package->help() if ($package & $package->can("help"));
exit(0);
}
# Generic error handler
# Convention adopted: if the attribute of a token is an object
# assume it has 'line' and 'str' methods. Otherwise, if it
# is an array, follows the convention [ str, line, ...]
# otherwise is just an string representing the value of the token
sub _Error {
my $parser = shift;
my $yydata = $parser->YYData;
exists $yydata->{ERRMSG}
and do {
warn $yydata->{ERRMSG};
delete $yydata->{ERRMSG};
return;
};
my ($attr)=$parser->YYCurval;
my $stoken = '';
if (blessed($attr) && $attr->can('str')) {
$stoken = " near '".$attr->str."'"
}
elsif (ref($attr) eq 'ARRAY') {
$stoken = " near '".$attr->[0]."'";
}
else {
if ($attr) {
$stoken = " near '$attr'";
}
else {
$stoken = " near end of input";
}
}
my @expected = map { ($_ ne '')? "'$_'" : q{'end of input'}} $parser->YYExpect();
my $expected = '';
if (@expected) {
$expected = (@expected >1) ? "Expected one of these terminals: @expected"
: "Expected terminal: @expected"
}
my $tline = '';
if (blessed($attr) && $attr->can('line')) {
$tline = " (line number ".$attr->line.")"
}
elsif (ref($attr) eq 'ARRAY') {
$tline = " (line number ".$attr->[1].")";
}
else {
# May be the parser object knows the line number ?
my $lineno = $parser->line;
$tline = " (line number $lineno)" if $lineno > 1;
}
local $" = ', ';
warn << "ERRMSG";
Syntax error$stoken$tline.
$expected
ERRMSG
};
################ end TailSupport #####################
sub _DBLoad {
#Already loaded ?
__PACKAGE__->can('_DBParse') and return;
my($fname)=__FILE__;
my(@drv);
local $/ = "\n";
if (open(DRV,"<$fname")) {
local $_;
while(<DRV>) {
#/^\s*sub\s+_Parse\s*{\s*$/ .. /^\s*}\s*#\s*_Parse\s*$/ and do {
/^my\s+\$lex;##!!##$/ .. /^\s*}\s*#\s*_Parse\s*$/ and do {
s/^#DBG>//;
push(@drv,$_);
}
}
close(DRV);
$drv[1]=~s/_P/_DBP/;
eval join('',@drv);
}
else {
# TODO: debugging for standalone modules isn't supported yet
*Parse::Eyapp::Driver::_DBParse = \&_Parse;
}
}
### Receives an index for the parsing stack: -1 is the top
### Returns the symbol associated with the state $index
sub YYSymbol {
my $self = shift;
my $index = shift;
return $self->{STACK}[$index][2];
}
# # YYSymbolStack(0,-k) string with symbols from 0 to last-k
# # YYSymbolStack(-k-2,-k) string with symbols from last-k-2 to last-k
# # YYSymbolStack(-k-2,-k, filter) string with symbols from last-k-2 to last-k that match with filter
# # YYSymbolStack('SYMBOL',-k, filter) string with symbols from the last occurrence of SYMBOL to last-k
# # where filter can be code, regexp or string
# sub YYSymbolStack {
# my $self = shift;
# my ($a, $b, $filter) = @_;
#
# # $b must be negative
# croak "Error: Second index in YYSymbolStack must be negative\n" unless $b < 0;
#
# my $stack = $self->{STACK};
# my $bottom = -@{$stack};
# unless (looks_like_number($a)) {
# # $a is a string: search from the top to the bottom for $a. Return empty list if not found
# # $b must be a negative number
# # $b must be a negative number
# my $p = $b;
# while ($p >= $bottom) {
# last if (defined($stack->[$p][2]) && ($stack->[$p][2] eq $a));
# $p--;
# }
# return () if $p < $bottom;
# $a = $p;
# }
# # If positive, $a is an offset from the bottom of the stack
# $a = $bottom+$a if $a >= 0;
#
# my @a = map { $self->YYSymbol($_) or '' } $a..$b;
#
# return @a unless defined $filter; # no filter
# return (grep { $filter->{$_} } @a) if reftype($filter) && (reftype($filter) eq 'CODE'); # sub
# return (grep /$filter/, @a) if reftype($filter) && (reftype($filter) eq 'SCALAR'); # regexp
# return (grep { $_ eq $filter } @a); # string
# }
#Note that for loading debugging version of the driver,
#this file will be parsed from 'sub _Parse' up to '}#_Parse' inclusive.
#So, DO NOT remove comment at end of sub !!!
my $lex;##!!##
sub _Parse {
my($self)=shift;
#my $lex = $self->{LEX};
my($rules,$states,$error)
= @$self{ 'RULES', 'STATES', 'ERROR' };
my($errstatus,$nberror,$token,$value,$stack,$check,$dotpos)
= @$self{ 'ERRST', 'NBERR', 'TOKEN', 'VALUE', 'STACK', 'CHECK', 'DOTPOS' };
my %conflictiveStates = %{$self->{STATECONFLICT}};
#DBG> my($debug)=$$self{DEBUG};
#DBG> my($dbgerror)=0;
#DBG> my($ShowCurToken) = sub {
#DBG> my($tok)='>';
#DBG> for (split('',$$token)) {
#DBG> $tok.= (ord($_) < 32 or ord($_) > 126)
#DBG> ? sprintf('<%02X>',ord($_))
#DBG> : $_;
#DBG> }
#DBG> $tok.='<';
#DBG> };
$$errstatus=0;
$$nberror=0;
($$token,$$value)=(undef,undef);
@$stack=( [ 0, undef, ] );
#DBG> push(@{$stack->[-1]}, undef);
#@$stack=( [ 0, undef, undef ] );
$$check='';
while(1) {
my($actions,$act,$stateno);
$self->{POS} = pos(${$self->input()});
$stateno=$$stack[-1][0];
if (exists($conflictiveStates{$stateno})) {
#warn "Conflictive state $stateno managed by conflict handler '$conflictiveStates{$stateno}{name}'\n"
for my $h (@{$conflictiveStates{$stateno}}) {
$self->{CURRENT_LHS} = $h->{name};
$h->{codeh}($self);
}
}
# check if the state is a conflictive one,
# if so, execute its conflict handlers
$actions=$$states[$stateno];
#DBG> print STDERR ('-' x 40),"\n";
#DBG> $debug & 0x2
#DBG> and print STDERR "In state $stateno:\n";
#DBG> $debug & 0x08
#DBG> and print STDERR "Stack: ".
#DBG> join('->',map { defined($$_[2])? "'$$_[2]'->".$$_[0] : $$_[0] } @$stack).
#DBG> "\n";
if (exists($$actions{ACTIONS})) {
defined($$token)
or do {
($$token,$$value)=$self->{LEX}->($self); # original line
#($$token,$$value)=$self->$lex; # to make it a method call
#($$token,$$value) = $self->{LEX}->($self); # sensitive to the lexer changes
#DBG> $debug & 0x01
#DBG> and do {
#DBG> print STDERR "Need token. Got ".&$ShowCurToken."\n";
#DBG> };
};
$act= exists($$actions{ACTIONS}{$$token})
? $$actions{ACTIONS}{$$token}
: exists($$actions{DEFAULT})
? $$actions{DEFAULT}
: undef;
}
else {
$act=$$actions{DEFAULT};
#DBG> $debug & 0x01
#DBG> and print STDERR "Don't need token.\n";
}
defined($act)
and do {
$act > 0
and do { #shift
#DBG> $debug & 0x04
#DBG> and print STDERR "Shift and go to state $act.\n";
$$errstatus
and do {
--$$errstatus;
#DBG> $debug & 0x10
#DBG> and $dbgerror
#DBG> and $$errstatus == 0
#DBG> and do {
#DBG> print STDERR "**End of Error recovery.\n";
#DBG> $dbgerror=0;
#DBG> };
};
push(@$stack,[ $act, $$value ]);
#DBG> push(@{$stack->[-1]},$$token);
defined($$token) and ($$token ne '') #Don't eat the eof
and $$token=$$value=undef;
next;
};
#reduce
my($lhs,$len,$code,@sempar,$semval);
($lhs,$len,$code)=@{$$rules[-$act]};
#DBG> $debug & 0x04
#DBG> and $act
#DBG> #and print STDERR "Reduce using rule ".-$act." ($lhs,$len): "; # old Parse::Yapp line
#DBG> and do { my @rhs = @{$self->{GRAMMAR}->[-$act]->[2]};
#DBG> @rhs = ( '/* empty */' ) unless @rhs;
#DBG> my $rhs = "@rhs";
#DBG> $rhs = substr($rhs, 0, 30).'...' if length($rhs) > 30; # chomp if too large
#DBG> print STDERR "Reduce using rule ".-$act." ($lhs --> $rhs): ";
#DBG> };
$act
or $self->YYAccept();
$$dotpos=$len;
unpack('A1',$lhs) eq '@' #In line rule
and do {
$lhs =~ /^\@[0-9]+\-([0-9]+)$/
or die "In line rule name '$lhs' ill formed: ".
"report it as a BUG.\n";
$$dotpos = $1;
};
@sempar = $$dotpos
? map { $$_[1] } @$stack[ -$$dotpos .. -1 ]
: ();
$self->{CURRENT_LHS} = $lhs;
$self->{CURRENT_RULE} = -$act; # count the super-rule?
$semval = $code ? $self->$code( @sempar )
: @sempar ? $sempar[0] : undef;
splice(@$stack,-$len,$len);
$$check eq 'ACCEPT'
and do {
#DBG> $debug & 0x04
#DBG> and print STDERR "Accept.\n";
return($semval);
};
$$check eq 'ABORT'
and do {
#DBG> $debug & 0x04
#DBG> and print STDERR "Abort.\n";
return(undef);
};
#DBG> $debug & 0x04
#DBG> and print STDERR "Back to state $$stack[-1][0], then ";
$$check eq 'ERROR'
or do {
#DBG> $debug & 0x04
#DBG> and print STDERR
#DBG> "go to state $$states[$$stack[-1][0]]{GOTOS}{$lhs}.\n";
#DBG> $debug & 0x10
#DBG> and $dbgerror
#DBG> and $$errstatus == 0
#DBG> and do {
#DBG> print STDERR "**End of Error recovery.\n";
#DBG> $dbgerror=0;
#DBG> };
push(@$stack,
[ $$states[$$stack[-1][0]]{GOTOS}{$lhs}, $semval, ]);
#[ $$states[$$stack[-1][0]]{GOTOS}{$lhs}, $semval, $lhs ]);
#DBG> push(@{$stack->[-1]},$lhs);
$$check='';
$self->{CURRENT_LHS} = undef;
next;
};
#DBG> $debug & 0x04
#DBG> and print STDERR "Forced Error recovery.\n";
$$check='';
};
#Error
$$errstatus
or do {
$$errstatus = 1;
&$error($self);
$$errstatus # if 0, then YYErrok has been called
or next; # so continue parsing
#DBG> $debug & 0x10
#DBG> and do {
#DBG> print STDERR "**Entering Error recovery.\n";
#DBG> {
#DBG> local $" = ", ";
#DBG> my @expect = map { ">$_<" } $self->YYExpect();
#DBG> print STDERR "Expecting one of: @expect\n";
#DBG> };
#DBG> ++$dbgerror;
#DBG> };
++$$nberror;
};
$$errstatus == 3 #The next token is not valid: discard it
and do {
$$token eq '' # End of input: no hope
and do {
#DBG> $debug & 0x10
#DBG> and print STDERR "**At eof: aborting.\n";
return(undef);
};
#DBG> $debug & 0x10
#DBG> and print STDERR "**Discard invalid token ".&$ShowCurToken.".\n";
$$token=$$value=undef;
};
$$errstatus=3;
while( @$stack
and ( not exists($$states[$$stack[-1][0]]{ACTIONS})
or not exists($$states[$$stack[-1][0]]{ACTIONS}{error})
or $$states[$$stack[-1][0]]{ACTIONS}{error} <= 0)) {
#DBG> $debug & 0x10
#DBG> and print STDERR "**Pop state $$stack[-1][0].\n";
pop(@$stack);
}
@$stack
or do {
#DBG> $debug & 0x10
#DBG> and print STDERR "**No state left on stack: aborting.\n";
return(undef);
};
#shift the error token
#DBG> $debug & 0x10
#DBG> and print STDERR "**Shift \$error token and go to state ".
#DBG> $$states[$$stack[-1][0]]{ACTIONS}{error}.
#DBG> ".\n";
push(@$stack, [ $$states[$$stack[-1][0]]{ACTIONS}{error}, undef, 'error' ]);
}
#never reached
croak("Error in driver logic. Please, report it as a BUG");
}#_Parse
#DO NOT remove comment
*Parse::Eyapp::Driver::lexer = \&Parse::Eyapp::Driver::YYLexer;
sub YYLexer {
my $self = shift;
if (ref $self) { # instance method
# The class attribute isn't changed, only the instance
$self->{LEX} = shift if @_;
return $self->static_attribute('LEX', @_,) unless defined($self->{LEX}); # class/static method
return $self->{LEX};
}
else {
return $self->static_attribute('LEX', @_,);
}
}
1;