File Coverage

blib/lib/Parse/Eyapp/Driver.pm
Criterion Covered Total %
statement 347 869 39.9
branch 125 446 28.0
condition 16 103 15.5
subroutine 46 101 45.5
pod 0 81 0.0
total 534 1600 33.3


line stmt bran cond sub pod time code
1             #
2             # Module Parse::Eyapp::Driver
3             #
4             # This module is part of the Parse::Eyapp package available on your
5             # nearest CPAN
6             #
7             # Copyright © 2006, 2007, 2008, 2009, 2010, 2011, 2012 Casiano Rodriguez-Leon.
8             # Copyright © 2017 William N. Braswell, Jr.
9             # All Rights Reserved.
10             #
11             # Based on Parse::Yapp.
12             #
13             # Parse::Yapp is Copyright © 1998, 1999, 2000, 2001, Francois Desarmenien.
14             # Parse::Yapp is Copyright © 2017 William N. Braswell, Jr.
15             # All Rights Reserved.
16              
17             package Parse::Eyapp::Driver;
18              
19             require 5.006;
20              
21 61     61   343 use strict;
  61         123  
  61         3407  
22              
23             our ( $VERSION, $COMPATIBLE, $FILENAME );
24              
25              
26             # $VERSION is also in Parse/Eyapp.pm
27             $VERSION = "1.21";
28             $COMPATIBLE = '0.07';
29             $FILENAME =__FILE__;
30              
31 61     61   331 use Carp;
  61         136  
  61         3225  
32 61     61   364 use Scalar::Util qw{blessed reftype looks_like_number};
  61         130  
  61         3940  
33              
34 61     61   36487 use Getopt::Long;
  61         498300  
  61         275  
35              
36             #Known parameters, all starting with YY (leading YY will be discarded)
37             my (%params)=(YYLEX => 'CODE', 'YYERROR' => 'CODE', YYVERSION => '',
38             YYRULES => 'ARRAY', YYSTATES => 'ARRAY', YYDEBUG => '',
39             # added by Casiano
40             #YYPREFIX => '', # Not allowed at YYParse time but in new
41             YYFILENAME => '',
42             YYBYPASS => '',
43             YYGRAMMAR => 'ARRAY',
44             YYTERMS => 'HASH',
45             YYBUILDINGTREE => '',
46             YYACCESSORS => 'HASH',
47             YYCONFLICTHANDLERS => 'HASH',
48             YYSTATECONFLICT => 'HASH',
49             YYLABELS => 'HASH',
50             );
51             my (%newparams) = (%params, YYPREFIX => '',);
52              
53             #Mandatory parameters
54             my (@params)=('LEX','RULES','STATES');
55              
56             sub new {
57 133     133 0 3451 my($class)=shift;
58              
59 133         417 my($errst,$nberr,$token,$value,$check,$dotpos);
60              
61 133         1513 my($self)={
62             ERRST => \$errst,
63             NBERR => \$nberr,
64             TOKEN => \$token,
65             VALUE => \$value,
66             DOTPOS => \$dotpos,
67             STACK => [],
68             DEBUG => 0,
69             PREFIX => "",
70             CHECK => \$check,
71             };
72              
73 133         873 _CheckParams( [], \%newparams, \@_, $self );
74              
75             exists($$self{VERSION})
76 133 50 33     1448 and $$self{VERSION} < $COMPATIBLE
77             and croak "Eyapp driver version $VERSION ".
78             "incompatible with version $$self{VERSION}:\n".
79             "Please recompile parser module.";
80              
81 133 50       460 ref($class)
82             and $class=ref($class);
83              
84 133 100       521 unless($self->{ERROR}) {
85 132         876 $self->{ERROR} = $class->error;
86 132 50       533 $self->{ERROR} = \&_Error unless ($self->{ERROR});
87             }
88              
89 133 100       454 unless ($self->{LEX}) {
90 132         979 $self->{LEX} = $class->YYLexer;
91 132         616 @params = ('RULES','STATES');
92             }
93              
94 133         356 my $parser = bless($self,$class);
95              
96 133         633 $parser;
97             }
98              
99             sub YYParse {
100 158     158 0 31535 my($self)=shift;
101 158         308 my($retval);
102              
103 158         708 _CheckParams( \@params, \%params, \@_, $self );
104              
105 158 50       628 unless($self->{ERROR}) {
106 0         0 $self->{ERROR} = $self->error;
107 0 0       0 $self->{ERROR} = \&_Error unless ($self->{ERROR});
108             }
109              
110 158 50       741 unless($self->{LEX}) {
111 0         0 $self->{LEX} = $self->YYLexer;
112 0 0 0     0 croak "Missing parameter 'yylex' " unless $self->{LEX} && reftype($self->{LEX}) eq 'CODE';
113             }
114              
115 158 50       566 if($$self{DEBUG}) {
116 0         0 _DBLoad();
117 0         0 $retval = eval '$self->_DBParse()';#Do not create stab entry on compile
118 0 0       0 $@ and die $@;
119             }
120             else {
121 158         911 $retval = $self->_Parse();
122             }
123 158         619 return $retval;
124             }
125              
126             sub YYData {
127 2027     2027 0 19497 my($self)=shift;
128              
129             exists($$self{USER})
130 2027 100       4442 or $$self{USER}={};
131              
132 2027         5089 $$self{USER};
133            
134             }
135              
136             sub YYErrok {
137 2     2 0 13 my($self)=shift;
138              
139 2         4 ${$$self{ERRST}}=0;
  2         6  
140 2         4 undef;
141             }
142              
143             sub YYNberr {
144 1     1 0 3 my($self)=shift;
145              
146 1         3 ${$$self{NBERR}};
  1         5  
147             }
148              
149             sub YYRecovering {
150 0     0 0 0 my($self)=shift;
151              
152 0         0 ${$$self{ERRST}} != 0;
  0         0  
153             }
154              
155             sub YYAbort {
156 0     0 0 0 my($self)=shift;
157              
158 0         0 ${$$self{CHECK}}='ABORT';
  0         0  
159 0         0 undef;
160             }
161              
162             sub YYAccept {
163 158     158 0 384 my($self)=shift;
164              
165 158         322 ${$$self{CHECK}}='ACCEPT';
  158         461  
166 158         358 undef;
167             }
168              
169             # Used to set that we are in "error recovery" state
170             sub YYError {
171 0     0 0 0 my($self)=shift;
172              
173 0         0 ${$$self{CHECK}}='ERROR';
  0         0  
174 0         0 undef;
175             }
176              
177             sub YYSemval {
178 0     0 0 0 my($self)=shift;
179 0         0 my($index)= $_[0] - ${$$self{DOTPOS}} - 1;
  0         0  
180              
181             $index < 0
182 0         0 and -$index <= @{$$self{STACK}}
183 0 0 0     0 and return $$self{STACK}[$index][1];
184              
185 0         0 undef; #Invalid index
186             }
187              
188             ### Casiano methods
189              
190             sub YYRule {
191             # returns the list of rules
192             # counting the super rule as rule 0
193 0     0 0 0 my $self = shift;
194 0         0 my $index = shift;
195              
196 0 0       0 if ($index) {
197 0 0       0 $index = $self->YYIndex($index) unless (looks_like_number($index));
198 0 0       0 return wantarray? @{$self->{RULES}[$index]} : $self->{RULES}[$index]
  0         0  
199             }
200              
201 0         0 return wantarray? @{$self->{RULES}} : $self->{RULES}
202 0 0       0 }
203              
204             # YYState returns the list of states. Each state is an anonymous hash
205             # DB<4> x $parser->YYState(2)
206             # 0 HASH(0xfa7120)
207             # 'ACTIONS' => HASH(0xfa70f0) # token => state
208             # ':' => '-7'
209             # 'DEFAULT' => '-6'
210             # There are three keys: ACTIONS, GOTOS and DEFAULT
211             # DB<7> x $parser->YYState(13)
212             # 0 HASH(0xfa8b50)
213             # 'ACTIONS' => HASH(0xfa7530)
214             # 'VAR' => 17
215             # 'GOTOS' => HASH(0xfa8b20)
216             # 'type' => 19
217             sub YYState {
218 0     0 0 0 my $self = shift;
219 0         0 my $index = shift;
220              
221 0 0       0 if ($index) {
222             # Comes from the stack: a pair [state number, attribute]
223 0 0       0 $index = $index->[0] if 'ARRAY' eq reftype($index);
224 0 0       0 die "YYState error. Expecting a number, found <$index>" unless (looks_like_number($index));
225 0         0 return $self->{STATES}[$index]
226             }
227              
228             return $self->{STATES}
229 0         0 }
230              
231             sub YYGoto {
232 0     0 0 0 my ($self, $state, $symbol) = @_;
233            
234 0         0 my $stateLRactions = $self->YYState($state);
235              
236 0         0 $stateLRactions->{GOTOS}{$symbol};
237             }
238              
239             sub YYRHSLength {
240 0     0 0 0 my $self = shift;
241             # If no production index is given, is the production begin used in the current reduction
242 0   0     0 my $index = shift || $self->YYRuleindex;
243              
244             # If the production was given by its name, compute its index
245 0 0       0 $index = $self->YYIndex($index) unless looks_like_number($index);
246            
247 0 0       0 return unless looks_like_number($index);
248              
249 0         0 my $currentprod = $self->YYRule($index);
250              
251 0 0       0 $currentprod->[1] if reftype($currentprod);
252             }
253              
254             # To be used in a semantic action, when reducing ...
255             # It gives the next state after reduction
256             sub YYNextState {
257 0     0 0 0 my $self = shift;
258              
259 0         0 my $lhs = $self->YYLhs;
260              
261 0 0       0 if ($lhs) { # reduce
262 0         0 my $length = $self->YYRHSLength;
263              
264 0         0 my $state = $self->YYTopState($length);
265             #print "state = $$state[0]\n";
266 0         0 $self->YYGoto($state, $lhs);
267             }
268             else { # shift: a token must be provided as argument
269 0         0 my $token = shift;
270            
271 0         0 my $state = $self->YYTopState;
272 0         0 $self->YYGetLRAction($state, $token);
273             }
274             }
275              
276             # TODO: make it work with a list of indices ...
277             sub YYGrammar {
278 0     0 0 0 my $self = shift;
279 0         0 my $index = shift;
280              
281 0 0       0 if ($index) {
282 0 0       0 $index = $self->YYIndex($index) unless (looks_like_number($index));
283 0 0       0 return wantarray? @{$self->{GRAMMAR}[$index]} : $self->{GRAMMAR}[$index]
  0         0  
284             }
285 0         0 return wantarray? @{$self->{GRAMMAR}} : $self->{GRAMMAR}
286 0 0       0 }
287              
288             # Return the list of production names
289             sub YYNames {
290 0     0 0 0 my $self = shift;
291              
292 0         0 my @names = map { $_->[0] } @{$self->{GRAMMAR}};
  0         0  
  0         0  
293              
294 0 0       0 return wantarray? @names : \@names;
295             }
296              
297             # Return the hash of indices for each production name
298             # Initializes the INDICES attribute of the parser
299             # Returns the index of the production rule with name $name
300             sub YYIndex {
301 0     0 0 0 my $self = shift;
302              
303 0 0       0 if (@_) {
304 0         0 my @indices = map { $self->{LABELS}{$_} } @_;
  0         0  
305 0 0       0 return wantarray? @indices : $indices[0];
306             }
307 0 0       0 return wantarray? %{$self->{LABELS}} : $self->{LABELS};
  0         0  
308              
309             }
310              
311             sub YYTopState {
312 0     0 0 0 my $self = shift;
313 0   0     0 my $length = shift || 0;
314              
315 0 0       0 $length = -$length unless $length <= 0;
316 0         0 $length--;
317              
318 0 0       0 $_[1] and $self->{STACK}[$length] = $_[1];
319 0         0 $self->{STACK}[$length];
320             }
321              
322             sub YYStack {
323 0     0 0 0 my $self = shift;
324              
325 0         0 return $self->{STACK};
326             }
327              
328             # To dynamically set syntactic actions
329             # Change it to state, token, action
330             # it is more natural
331             sub YYSetLRAction {
332 0     0 0 0 my ($self, $state, $token, $action) = @_;
333              
334 0 0       0 die "YYLRAction: Provide a state " unless defined($state);
335              
336             # Action can be given using the name of the production
337 0 0       0 $action = -$self->YYIndex($action) unless looks_like_number($action);
338 0 0       0 $token = [ $token ] unless ref($token);
339 0         0 for (@$token) {
340 0         0 $self->{STATES}[$state]{ACTIONS}{$_} = $action;
341             }
342             }
343              
344             sub YYRestoreLRAction {
345 0     0 0 0 my $self = shift;
346 0         0 my $conflictname = shift;
347 0         0 my @tokens = @_;
348              
349 0         0 for (@tokens) {
350 0         0 my ($conflictstate, $action) = @{$self->{CONFLICT}{$conflictname}{$_}};
  0         0  
351 0         0 $self->{STATES}[$conflictstate]{ACTIONS}{$_} = $action;
352             }
353             }
354              
355             # Fools the lexer to get a new token
356             # without modifying the parsing position (pos)
357             # Warning, warning! this and YYLookaheads assume
358             # that the input comes from the string
359             # referenced by $self->input.
360             # It will not work for a stream
361             sub YYLookahead {
362 0     0 0 0 my $self = shift;
363              
364 0         0 my $pos = pos(${$self->input});
  0         0  
365 0         0 my ($nextToken, $val) = $self->YYLexer->($self);
366             # restore pos
367 0         0 pos(${$self->input}) = $pos;
  0         0  
368 0         0 return $nextToken;
369             }
370              
371             # Fools the lexer to get $spec new tokens
372             sub YYLookaheads {
373 0     0 0 0 my $self = shift;
374 0   0     0 my $spec = shift || 1; # a number
375              
376 0         0 my $pos = pos(${$self->input});
  0         0  
377 0         0 my @r; # list of lookahead tokens
378              
379 0         0 my ($t, $v);
380 0 0       0 if (looks_like_number($spec)) {
381 0         0 for my $i (1..$spec) {
382 0         0 ($t, $v) = $self->YYLexer->($self);
383 0         0 push @r, $t;
384 0 0       0 last if $t eq '';
385             }
386             }
387             else { # if string
388 0   0     0 do {
389 0         0 ($t, $v) = $self->YYLexer->($self);
390 0         0 push @r, $t;
391             } while ($t ne $spec && $t ne '');
392             }
393              
394             # restore pos
395 0         0 pos(${$self->input}) = $pos;
  0         0  
396              
397 0         0 return @r;
398             }
399              
400              
401             # more parameters: debug, etc, ...
402             #sub YYNestedParse {
403             sub YYPreParse {
404 0     0 0 0 my $self = shift;
405 0         0 my $parser = shift;
406 0   0     0 my $file = shift() || $parser;
407              
408             # Check for errors!
409 0         0 eval "require $file";
410            
411             # optimize to state variable for 5.10
412 0     0   0 my $rp = $parser->new( yyerror => sub {});
413              
414 0         0 my $pos = pos(${$self->input});
  0         0  
415 0         0 my $rpos = $self->{POS};
416              
417             #print "pos = $pos\n";
418 0         0 $rp->input($self->input);
419 0         0 pos(${$rp->input}) = $rpos;
  0         0  
420              
421 0         0 my $t = $rp->Run(@_);
422 0         0 my $ne = $rp->YYNberr;
423              
424             #print "After nested parsing\n";
425              
426 0         0 pos(${$self->input}) = $pos;
  0         0  
427              
428 0 0       0 return (wantarray ? ($t, !$ne) : !$ne);
429             }
430              
431             sub YYNestedParse {
432 0     0 0 0 my $self = shift;
433 0         0 my $parser = shift;
434 0         0 my $conflictName = shift;
435              
436 0 0       0 $conflictName = $self->YYLhs unless $conflictName;
437              
438 0         0 my ($t, $ok) = $self->YYPreParse($parser, @_);
439              
440 0         0 $self->{CONFLICTHANDLERS}{$conflictName}{".".$parser} = [$ok, $t];
441              
442 0         0 return $ok;
443             }
444              
445             sub YYNestedRegexp {
446 0     0 0 0 my $self = shift;
447 0         0 my $regexp = shift;
448 0         0 my $conflictName = $self->YYLhs;
449              
450 0         0 my $ok = $_ =~ /$regexp/gc;
451              
452 0         0 $self->{CONFLICTHANDLERS}{$conflictName}{'..regexp'} = [$ok, undef];
453              
454 0         0 return $ok;
455             }
456              
457             sub YYIs {
458 0     0 0 0 my $self = shift;
459             # this is ungly and dangeorus. Don't use the dot. Change it!
460 0         0 my $syntaxVariable = '.'.(shift());
461 0         0 my $conflictName = $self->YYLhs;
462 0         0 my $v = $self->{CONFLICTHANDLERS}{$conflictName};
463              
464 0 0       0 $v->{$syntaxVariable}[0] = shift if @_;
465 0         0 return $v->{$syntaxVariable}[0];
466             }
467              
468              
469             sub YYVal {
470 0     0 0 0 my $self = shift;
471             # this is ungly and dangeorus. Don't use the dot. Change it!
472 0         0 my $syntaxVariable = '.'.(shift());
473 0         0 my $conflictName = $self->YYLhs;
474 0         0 my $v = $self->{CONFLICTHANDLERS}{$conflictName};
475              
476 0 0       0 $v->{$syntaxVariable}[1] = shift if @_;
477 0         0 return $v->{$syntaxVariable}[1];
478             }
479              
480             #x $self->{CONFLICTHANDLERS}
481             #0 HASH(0x100b306c0)
482             # 'rangeORenum' => HASH(0x100b30660)
483             # 'explorerline' => 12
484             # 'line' => 5
485             # 'production' => HASH(0x100b30580)
486             # '-13' => ARRAY(0x100b30520)
487             # 0 1 <------- mark: conflictive position in the rhs
488             # '-5' => ARRAY(0x100b30550)
489             # 0 1 <------- mark: conflictive position in the rhs
490             # 'states' => ARRAY(0x100b30630)
491             # 0 HASH(0x100b30600)
492             # 25 => ARRAY(0x100b305c0)
493             # 0 '\',\''
494             # 1 '\')\''
495             sub YYSetReduceXXXXX {
496 0     0 0 0 my $self = shift;
497 0         0 my $action = pop;
498 0         0 my $token = shift;
499            
500              
501 0 0       0 croak "YYSetReduce error: specify a production" unless defined($action);
502              
503             # Conflict state
504 0         0 my $conflictstate = $self->YYNextState();
505              
506 0         0 my $conflictName = $self->YYLhs;
507              
508             #$self->{CONFLICTHANDLERS}{conflictName}{states}
509             # is a hash
510             # statenumber => [ tokens, '\'-\'' ]
511 0         0 my $cS = $self->{CONFLICTHANDLERS}{$conflictName}{states};
512 0 0       0 my @conflictStates = $cS ? @$cS : ();
513              
514             # Perform the action to change the LALR tables only if the next state
515             # is listed as a conflictstate
516 0         0 my ($cs) = (grep { exists $_->{$conflictstate}} @conflictStates);
  0         0  
517 0 0       0 return unless $cs;
518              
519             # Action can be given using the name of the production
520 0 0       0 unless (looks_like_number($action)) {
521 0         0 my $actionnum = $self->{LABELS}{$action};
522 0 0       0 unless (looks_like_number($actionnum)) {
523 0         0 croak "YYSetReduce error: can't find production '$action'. Did you forget to name it?";
524             }
525 0         0 $action = -$actionnum;
526             }
527              
528 0 0       0 $token = $cs->{$conflictstate} unless defined($token);
529 0 0       0 $token = [ $token ] unless ref($token);
530 0         0 for (@$token) {
531             # save if shift
532 0 0 0     0 if (exists($self->{STATES}[$conflictstate]{ACTIONS}) and $self->{STATES}[$conflictstate]{ACTIONS}{$_} >= 0) {
533 0         0 $self->{CONFLICT}{$conflictName}{$_} = [ $conflictstate, $self->{STATES}[$conflictstate]{ACTIONS}{$_} ];
534             }
535 0         0 $self->{STATES}[$conflictstate]{ACTIONS}{$_} = $action;
536             }
537             }
538              
539             sub YYSetReduce {
540 0     0 0 0 my $self = shift;
541 0         0 my $action = pop;
542 0         0 my $token = shift;
543            
544              
545 0 0       0 croak "YYSetReduce error: specify a production" unless defined($action);
546              
547 0         0 my $conflictName = $self->YYLhs;
548              
549             #$self->{CONFLICTHANDLERS}{conflictName}{states}
550             # is a hash
551             # statenumber => [ tokens, '\'-\'' ]
552 0         0 my $cS = $self->{CONFLICTHANDLERS}{$conflictName}{states};
553 0 0       0 my @conflictStates = $cS ? @$cS : ();
554            
555 0 0       0 return unless @conflictStates;
556              
557             # Conflict state
558 0         0 my $cs = $conflictStates[0];
559              
560              
561 0         0 my ($conflictstate) = keys %{$cs};
  0         0  
562              
563             # Action can be given using the name of the production
564 0 0       0 unless (looks_like_number($action)) {
565 0         0 my $actionnum = $self->{LABELS}{$action};
566 0 0       0 unless (looks_like_number($actionnum)) {
567 0         0 croak "YYSetReduce error: can't find production '$action'. Did you forget to name it?";
568             }
569 0         0 $action = -$actionnum;
570             }
571              
572 0 0       0 $token = $cs->{$conflictstate} unless defined($token);
573 0 0       0 $token = [ $token ] unless ref($token);
574 0         0 for (@$token) {
575             # save if shift
576 0 0 0     0 if (exists($self->{STATES}[$conflictstate]{ACTIONS}) and $self->{STATES}[$conflictstate]{ACTIONS}{$_} >= 0) {
577 0         0 $self->{CONFLICT}{$conflictName}{$_} = [ $conflictstate, $self->{STATES}[$conflictstate]{ACTIONS}{$_} ];
578             }
579 0         0 $self->{STATES}[$conflictstate]{ACTIONS}{$_} = $action;
580             }
581             }
582              
583             sub YYSetShift {
584 0     0 0 0 my ($self, $token) = @_;
585              
586             # my ($self, $token, $action) = @_;
587             # $action is syntactic sugar ...
588              
589              
590 0         0 my $conflictName = $self->YYLhs;
591              
592 0         0 my $cS = $self->{CONFLICTHANDLERS}{$conflictName}{states};
593 0 0       0 my @conflictStates = $cS ? @$cS : ();
594            
595 0 0       0 return unless @conflictStates;
596              
597 0         0 my $cs = $conflictStates[0];
598              
599 0         0 my ($conflictstate) = keys %{$cs};
  0         0  
600              
601 0 0       0 $token = $cs->{$conflictstate} unless defined($token);
602 0 0       0 $token = [ $token ] unless ref($token);
603              
604 0         0 for (@$token) {
605 0 0       0 if (defined($self->{CONFLICT}{$conflictName}{$_})) {
606 0         0 my ($conflictstate2, $action) = @{$self->{CONFLICT}{$conflictName}{$_}};
  0         0  
607             # assert($conflictstate == $conflictstate2)
608              
609 0         0 $self->{STATES}[$conflictstate]{ACTIONS}{$_} = $self->{CONFLICT}{$conflictName}{$_}[1];
610             }
611             else {
612             #croak "YYSetShift error. No shift action found";
613             # shift is the default ... hope to be lucky!
614             }
615             }
616             }
617              
618              
619             # if is reduce ...
620             # x $self->{CONFLICTHANDLERS}{$conflictName}{production}{$action} $action is a number
621             #0 ARRAY(0x100b3f930)
622             # 0 2
623             # has the position in the item, starting at 0
624             # DB<19> x $self->YYRHSLength(4)
625             # 0 3
626             # if pos is length -1 then is reduce otherwise is shift
627              
628              
629             # It does YYSetReduce or YYSetshift according to the
630             # decision variable
631             # I need to know the kind of conflict that there is
632             # shift-reduce or reduce-reduce
633             sub YYIf {
634 0     0 0 0 my $self = shift;
635 0         0 my $syntaxVariable = shift;
636              
637 0 0       0 if ($self->YYIs($syntaxVariable)) {
638 0 0       0 if ($_[0] eq 'shift') {
639 0         0 $self->YYSetShift(@_);
640             }
641             else {
642 0         0 $self->YYSetReduce($_[0]);
643             }
644             }
645             else {
646 0 0       0 if ($_[1] eq 'shift') {
647 0         0 $self->YYSetShift(@_);
648             }
649             else {
650 0         0 $self->YYSetReduce($_[1]);
651             }
652             }
653 0         0 $self->YYIs($syntaxVariable, 0);
654             }
655              
656             sub YYGetLRAction {
657 0     0 0 0 my ($self, $state, $token) = @_;
658              
659 0 0 0     0 $state = $state->[0] if reftype($state) && (reftype($state) eq 'ARRAY');
660 0         0 my $stateentry = $self->{STATES}[$state];
661              
662 0 0       0 if (defined($token)) {
663 0 0       0 return $stateentry->{ACTIONS}{$token} if exists $stateentry->{ACTIONS}{$token};
664             }
665              
666 0 0       0 return $stateentry->{DEFAULT} if exists $stateentry->{DEFAULT};
667              
668 0         0 return;
669             }
670              
671             # to dynamically set semantic actions
672             sub YYAction {
673 0     0 0 0 my $self = shift;
674 0         0 my $index = shift;
675 0         0 my $newaction = shift;
676              
677 0 0       0 croak "YYAction error: Expecting an index" unless $index;
678              
679             # If $index is the production 'name' find the actual index
680 0 0       0 $index = $self->YYIndex($index) unless looks_like_number($index);
681 0         0 my $rule = $self->{RULES}->[$index];
682 0 0 0     0 $rule->[2] = $newaction if $newaction && (reftype($newaction) eq 'CODE');
683              
684 0         0 return $rule->[2];
685             }
686              
687             sub YYSetaction {
688 0     0 0 0 my $self = shift;
689 0         0 my %newaction = @_;
690              
691 0         0 for my $n (keys(%newaction)) {
692 0 0       0 my $m = looks_like_number($n) ? $n : $self->YYIndex($n);
693 0         0 my $rule = $self->{RULES}->[$m];
694 0 0 0     0 $rule->[2] = $newaction{$n} if ($newaction{$n} && (reftype($newaction{$n}) eq 'CODE'));
695             }
696             }
697              
698             #sub YYDebugtree {
699             # my ($self, $i, $e) = @_;
700             #
701             # my ($name, $lhs, $rhs) = @$e;
702             # my @rhs = @$rhs;
703             #
704             # return if $name =~ /_SUPERSTART/;
705             # $name = $lhs."::"."@rhs";
706             # $name =~ s/\W/_/g;
707             # return $name;
708             #}
709             #
710             #sub YYSetnames {
711             # my $self = shift;
712             # my $newname = shift || \&YYDebugtree;
713             #
714             # die "YYSetnames error. Exected a CODE reference found <$newname>"
715             # unless $newname && (reftype($newname) eq 'CODE');
716             #
717             # my $i = 0;
718             # for my $e (@{$self->{GRAMMAR}}) {
719             # my $nn= $newname->($self, $i, $e);
720             # $e->[0] = $nn if defined($nn);
721             # $i++;
722             # }
723             #}
724              
725             sub YYLhs {
726             # returns the syntax variable on
727             # the left hand side of the current production
728 696     696 0 1206 my $self = shift;
729              
730             return $self->{CURRENT_LHS}
731 696         1295 }
732              
733             sub YYRuleindex {
734             # returns the index of the rule
735             # counting the super rule as rule 0
736 10     10 0 26 my $self = shift;
737              
738             return $self->{CURRENT_RULE}
739 10         17 }
740              
741             sub YYRightside {
742             # returns the rule
743             # counting the super rule as rule 0
744 1257     1257 0 2036 my $self = shift;
745 1257   33     4798 my $index = shift || $self->{CURRENT_RULE};
746 1257 50       4002 $index = $self->YYIndex($index) unless looks_like_number($index);
747              
748 1257         1962 return @{$self->{GRAMMAR}->[$index]->[2]};
  1257         4076  
749             }
750              
751             sub YYTerms {
752 0     0 0 0 my $self = shift;
753              
754 0         0 return $self->{TERMS};
755             }
756              
757              
758             sub YYIsterm {
759 1352     1352 0 2181 my $self = shift;
760 1352         1968 my $symbol = shift;
761              
762 1352         4066 return exists ($self->{TERMS}->{$symbol});
763             }
764              
765             sub YYIssemantic {
766 1426     1426 0 2274 my $self = shift;
767 1426         2231 my $symbol = shift;
768              
769 1426 100       4251 return 0 unless exists($self->{TERMS}{$symbol});
770 871 50       1973 $self->{TERMS}{$symbol}{ISSEMANTIC} = shift if @_;
771 871         2671 return ($self->{TERMS}{$symbol}{ISSEMANTIC});
772             }
773              
774             sub YYName {
775 1262     1262 0 1982 my $self = shift;
776              
777 1262         2330 my $current_rule = $self->{GRAMMAR}->[$self->{CURRENT_RULE}];
778 1262 50       2880 $current_rule->[0] = shift if @_;
779 1262         2514 return $current_rule->[0];
780             }
781              
782             sub YYPrefix {
783 1717     1717 0 3551 my $self = shift;
784              
785 1717 50       4093 $self->{PREFIX} = $_[0] if @_;
786 1717         4459 $self->{PREFIX};
787             }
788              
789             sub YYAccessors {
790 133     133 0 308 my $self = shift;
791              
792             $self->{ACCESSORS}
793 133         410 }
794              
795             # name of the file containing
796             # the source grammar
797             sub YYFilename {
798 0     0 0 0 my $self = shift;
799              
800 0 0       0 $self->{FILENAME} = $_[0] if @_;
801 0         0 $self->{FILENAME};
802             }
803              
804             sub YYBypass {
805 0     0 0 0 my $self = shift;
806              
807 0 0       0 $self->{BYPASS} = $_[0] if @_;
808 0         0 $self->{BYPASS};
809             }
810              
811             sub YYBypassrule {
812 499     499 0 816 my $self = shift;
813              
814 499 50       1155 $self->{GRAMMAR}->[$self->{CURRENT_RULE}][3] = $_[0] if @_;
815 499         1132 return $self->{GRAMMAR}->[$self->{CURRENT_RULE}][3];
816             }
817              
818             sub YYFirstline {
819 0     0 0 0 my $self = shift;
820              
821 0 0       0 $self->{FIRSTLINE} = $_[0] if @_;
822 0         0 $self->{FIRSTLINE};
823             }
824              
825             # Used as default action when writing a reusable grammar.
826             # See files examples/recycle/NoacInh.eyp
827             # and examples/recycle/icalcu_and_ipost.pl
828             # in the Parse::Eyapp distribution
829             sub YYDelegateaction {
830 0     0 0 0 my $self = shift;
831              
832 0         0 my $action = $self->YYName;
833            
834 0         0 $self->$action(@_);
835             }
836              
837             # Influences the behavior of YYActionforT_X1X2
838             # YYActionforT_single and YYActionforT_empty
839             # If true these methods will build simple lists of attributes
840             # for the lists operators X*, X+ and X? and parenthesis (X Y)
841             # Otherwise the classic node construction for the
842             # syntax tree is used
843             sub YYBuildingTree {
844 1075     1075 0 1902 my $self = shift;
845              
846 1075 50       2556 $self->{BUILDINGTREE} = $_[0] if @_;
847 1075         4422 $self->{BUILDINGTREE};
848             }
849              
850             sub BeANode {
851 8621     8621 0 12841 my $class = shift;
852              
853 61     61   195147 no strict 'refs';
  61         173  
  61         6969  
854 8621 100       34101 push @{$class."::ISA"}, "Parse::Eyapp::Node" unless $class->isa("Parse::Eyapp::Node");
  7032         53437  
855             }
856              
857             #sub BeATranslationScheme {
858             # my $class = shift;
859             #
860             # no strict 'refs';
861             # push @{$class."::ISA"}, "Parse::Eyapp::TranslationScheme" unless $class->isa("Parse::Eyapp::TranslationScheme");
862             #}
863              
864             {
865             my $attr = sub {
866 2 50   2   10 $_[0]{attr} = $_[1] if @_ > 1;
867             $_[0]{attr}
868 2         21 };
869              
870             sub make_node_classes {
871 133     133 0 803 my $self = shift;
872 133   100     804 my $prefix = $self->YYPrefix() || '';
873              
874 61     61   412 { no strict 'refs';
  61         143  
  61         6253  
  133         293  
875 133         292 *{$prefix."TERMINAL::attr"} = $attr;
  133         840  
876             }
877              
878 133         419 for (@_) {
879 8533         19123 my ($class) = split /:/, $_;
880 8533         18999 BeANode("$prefix$class");
881             }
882              
883 133         838 my $accessors = $self->YYAccessors();
884 133         681 for (keys %$accessors) {
885 52         83 my $position = $accessors->{$_};
886 61     61   396 no strict 'refs';
  61         144  
  61         22572  
887 52         169 *{$prefix.$_} = sub {
888 12     12   6725 my $self = shift;
889              
890 12         81 return $self->child($position, @_)
891             }
892 52         119 } # for
893             }
894             }
895              
896             ####################################################################
897             # Usage : ????
898             # Purpose : Responsible for the %tree directive
899             # On each production the default action becomes:
900             # sub { goto &Parse::Eyapp::Driver::YYBuildAST }
901             #
902             # Returns : ????
903             # Parameters : ????
904             # Throws : no exceptions
905             # Comments : none
906             # See Also : n/a
907             # To Do : many things: Optimize this!!!!
908             sub YYBuildAST {
909 499     499 0 1921 my $self = shift;
910 499         1174 my $PREFIX = $self->YYPrefix();
911 499         1289 my @right = $self->YYRightside(); # Symbols on the right hand side of the production
912 499         1558 my $lhs = $self->YYLhs;
913 499         1156 my $fullname = $self->YYName();
914 499         1460 my ($name) = split /:/, $fullname;
915 499         1335 my $bypass = $self->YYBypassrule; # Boolean: shall we do bypassing of lonely nodes?
916 499         1109 my $class = "$PREFIX$name";
917 499         759 my @children;
918              
919 499         1193 my $node = bless {}, $class;
920              
921 499         1486 for(my $i = 0; $i < @right; $i++) {
922 992         1821 local $_ = $right[$i]; # The symbol
923 992         1668 my $ch = $_[$i]; # The attribute/reference
924              
925             # is $ch already a Parse::Eyapp::Node. May be a terminal and a syntax variable share the same name?
926 992 100       3466 unless (UNIVERSAL::isa($ch, 'Parse::Eyapp::Node')) {
927 723 100       1652 if ($self->YYIssemantic($_)) {
928 417         852 my $class = $PREFIX.'TERMINAL';
929 417         1605 my $node = bless { token => $_, attr => $ch, children => [] }, $class;
930 417         886 push @children, $node;
931 417         1282 next;
932             }
933              
934 306 100       834 if ($self->YYIsterm($_)) {
935 304 50       1452 TERMINAL::save_attributes($ch, $node) if UNIVERSAL::can($PREFIX."TERMINAL", "save_attributes");
936 304         954 next;
937             }
938             }
939              
940 271 50       1170 if (UNIVERSAL::isa($ch, $PREFIX."_PAREN")) { # Warning: weak code!!!
941 0         0 push @children, @{$ch->{children}};
  0         0  
942 0         0 next;
943             }
944              
945             # If it is an intermediate semantic action skip it
946 271 50       1641 next if $_ =~ qr{@}; # intermediate rule
947 271 100       952 next unless ref($ch);
948 269         847 push @children, $ch;
949             }
950              
951            
952 499 100 100     1486 if ($bypass and @children == 1) {
953 8         17 $node = $children[0];
954              
955 8         59 my $childisterminal = ref($node) =~ /TERMINAL$/;
956             # Re-bless unless is "an automatically named node", but the characterization of this is
957 8 50       61 bless $node, $class unless $name =~ /${lhs}_\d+$/; # lazy, weak (and wicked).
958              
959            
960 8         20 my $finalclass = ref($node);
961             $childisterminal and !$finalclass->isa($PREFIX.'TERMINAL')
962 8 100 66     110 and do {
963 61     61   429 no strict 'refs';
  61         153  
  61         76552  
964 2         5 push @{$finalclass."::ISA"}, $PREFIX.'TERMINAL'
  2         32  
965             };
966              
967 8         31 return $node;
968             }
969 491         1564 $node->{children} = \@children;
970 491         1295 return $node;
971             }
972              
973             sub YYBuildTS {
974 187     187 0 1440 my $self = shift;
975 187         429 my $PREFIX = $self->YYPrefix();
976 187         454 my @right = $self->YYRightside(); # Symbols on the right hand side of the production
977 187         465 my $lhs = $self->YYLhs;
978 187         432 my $fullname = $self->YYName();
979 187         485 my ($name) = split /:/, $fullname;
980 187         350 my $class;
981             my @children;
982              
983 187         495 for(my $i = 0; $i < @right; $i++) {
984 331         547 local $_ = $right[$i]; # The symbol
985 331         537 my $ch = $_[$i]; # The attribute/reference
986              
987 331 100       636 if ($self->YYIsterm($_)) {
988 175         302 $class = $PREFIX.'TERMINAL';
989 175         610 push @children, bless { token => $_, attr => $ch, children => [] }, $class;
990 175         507 next;
991             }
992              
993 156 50       695 if (UNIVERSAL::isa($ch, $PREFIX."_PAREN")) { # Warning: weak code!!!
994 0         0 push @children, @{$ch->{children}};
  0         0  
995 0         0 next;
996             }
997              
998             # Substitute intermediate code node _CODE(CODE()) by CODE()
999 156 100       587 if (UNIVERSAL::isa($ch, $PREFIX."_CODE")) { # Warning: weak code!!!
1000 10         47 push @children, $ch->child(0);
1001 10         30 next;
1002             }
1003              
1004 146 50       375 next unless ref($ch);
1005 146         415 push @children, $ch;
1006             }
1007              
1008 187 100       585 if (unpack('A1',$lhs) eq '@') { # class has to be _CODE check
1009 10 50       52 $lhs =~ /^\@[0-9]+\-([0-9]+)$/
1010             or croak "In line rule name '$lhs' ill formed: report it as a BUG.\n";
1011 10         55 my $dotpos = $1;
1012            
1013 10 50 33     69 croak "Fatal error building metatree when processing $lhs -> @right"
1014             unless exists($_[$dotpos]) and UNIVERSAL::isa($_[$dotpos], 'CODE') ;
1015 10         28 push @children, $_[$dotpos];
1016             }
1017             else {
1018 177         344 my $code = $_[@right];
1019 177 100       481 if (UNIVERSAL::isa($code, 'CODE')) {
1020 169         313 push @children, $code;
1021             }
1022             else {
1023 8 50       23 croak "Fatal error building translation scheme. Code or undef expected" if (defined($code));
1024             }
1025             }
1026              
1027 187         323 $class = "$PREFIX$name";
1028 187         529 my $node = bless { children => \@children }, $class;
1029 187         499 $node;
1030             }
1031              
1032             sub YYActionforT_TX1X2_tree {
1033 322     322 0 577 my $self = shift;
1034 322         533 my $head = shift;
1035 322         753 my $PREFIX = $self->YYPrefix();
1036 322         814 my @right = $self->YYRightside();
1037 322         621 my $class;
1038              
1039 322         975 for(my $i = 1; $i < @right; $i++) {
1040 464         896 local $_ = $right[$i];
1041 464         910 my $ch = $_[$i-1];
1042 464 100       1097 if ($self->YYIssemantic($_)) {
1043 5         14 $class = $PREFIX.'TERMINAL';
1044 5         10 push @{$head->{children}}, bless { token => $_, attr => $ch, children => [] }, $class;
  5         38  
1045            
1046 5         19 next;
1047             }
1048 459 100       1068 next if $self->YYIsterm($_);
1049 317 100       1138 if (ref($ch) eq $PREFIX."_PAREN") { # Warning: weak code!!!
1050 77         131 push @{$head->{children}}, @{$ch->{children}};
  77         143  
  77         156  
1051 77         250 next;
1052             }
1053 240 100       659 next unless ref($ch);
1054 237         405 push @{$head->{children}}, $ch;
  237         1075  
1055             }
1056              
1057 322         795 return $head;
1058             }
1059              
1060             # For * and + lists
1061             # S2 -> S2 X { push @$_[1] the node associated with X; $_[1] }
1062             # S2 -> /* empty */ { a node with empty children }
1063             sub YYActionforT_TX1X2 {
1064 322 50   322 0 1320 goto &YYActionforT_TX1X2_tree if $_[0]->YYBuildingTree;
1065              
1066 0         0 my $self = shift;
1067 0         0 my $head = shift;
1068              
1069 0         0 push @$head, @_;
1070 0         0 return $head;
1071             }
1072              
1073             sub YYActionforParenthesis {
1074 177 50   177 0 792 goto &YYBuildAST if $_[0]->YYBuildingTree;
1075              
1076 0         0 my $self = shift;
1077              
1078 0         0 return [ @_ ];
1079             }
1080              
1081              
1082             sub YYActionforT_empty_tree {
1083 337     337 0 640 my $self = shift;
1084 337         815 my $PREFIX = $self->YYPrefix();
1085 337         899 my $name = $self->YYName();
1086              
1087             # Allow use of %name
1088 337         770 my $class = $PREFIX.$name;
1089 337         1093 my $node = bless { children => [] }, $class;
1090             #BeANode($class);
1091 337         752 $node;
1092             }
1093              
1094             sub YYActionforT_empty {
1095 337 50   337 0 1317 goto &YYActionforT_empty_tree if $_[0]->YYBuildingTree;
1096              
1097 0         0 [];
1098             }
1099              
1100             sub YYActionforT_single_tree {
1101 239     239 0 479 my $self = shift;
1102 239         632 my $PREFIX = $self->YYPrefix();
1103 239         618 my $name = $self->YYName();
1104 239         672 my @right = $self->YYRightside();
1105 239         503 my $class;
1106              
1107             # Allow use of %name
1108             my @t;
1109 239         818 for(my $i = 0; $i < @right; $i++) {
1110 239         505 local $_ = $right[$i];
1111 239         464 my $ch = $_[$i];
1112 239 100       627 if ($self->YYIssemantic($_)) {
1113 3         10 $class = $PREFIX.'TERMINAL';
1114 3         24 push @t, bless { token => $_, attr => $ch, children => [] }, $class;
1115             #BeANode($class);
1116 3         13 next;
1117             }
1118 236 50       672 next if $self->YYIsterm($_);
1119 236 100       927 if (ref($ch) eq $PREFIX."_PAREN") { # Warning: weak code!!!
1120 100         217 push @t, @{$ch->{children}};
  100         261  
1121 100         351 next;
1122             }
1123 136 100       435 next unless ref($ch);
1124 128         496 push @t, $ch;
1125             }
1126 239         509 $class = $PREFIX.$name;
1127 239         756 my $node = bless { children => \@t }, $class;
1128             #BeANode($class);
1129 239         643 $node;
1130             }
1131              
1132             sub YYActionforT_single {
1133 239 50   239 0 968 goto &YYActionforT_single_tree if $_[0]->YYBuildingTree;
1134              
1135 0         0 my $self = shift;
1136 0         0 [ @_ ];
1137             }
1138              
1139             ### end Casiano methods
1140              
1141             sub YYCurtok {
1142 0     0 0 0 my($self)=shift;
1143              
1144             @_
1145 0 0       0 and ${$$self{TOKEN}}=$_[0];
  0         0  
1146 0         0 ${$$self{TOKEN}};
  0         0  
1147             }
1148              
1149             sub YYCurval {
1150 0     0 0 0 my($self)=shift;
1151              
1152             @_
1153 0 0       0 and ${$$self{VALUE}}=$_[0];
  0         0  
1154 0         0 ${$$self{VALUE}};
  0         0  
1155             }
1156              
1157             {
1158             sub YYSimStack {
1159 0     0 0 0 my $self = shift;
1160 0         0 my $stack = shift;
1161 0         0 my @reduce = @_;
1162 0         0 my @expected;
1163              
1164 0         0 for my $index (@reduce) {
1165 0         0 my ($lhs, $length) = @{$self->{RULES}[-$index]};
  0         0  
1166 0 0       0 if (@$stack > $length) {
1167 0         0 my @auxstack = @$stack;
1168 0 0       0 splice @auxstack, -$length if $length;
1169              
1170 0         0 my $state = $auxstack[-1]->[0];
1171 0         0 my $nextstate = $self->{STATES}[$state]{GOTOS}{$lhs};
1172 0 0       0 if (defined($nextstate)) {
1173 0         0 push @auxstack, [$nextstate, undef];
1174 0         0 push @expected, $self->YYExpected(\@auxstack);
1175             }
1176             }
1177             # else something went wrong!!! See Frank Leray report
1178             }
1179              
1180 0         0 return map { $_ => 1 } @expected;
  0         0  
1181             }
1182              
1183             sub YYExpected {
1184 0     0 0 0 my($self)=shift;
1185 0         0 my $stack = shift;
1186              
1187             # The state in the top of the stack
1188 0         0 my $state = $self->{STATES}[$stack->[-1][0]];
1189              
1190 0         0 my %actions;
1191 0 0       0 %actions = %{$state->{ACTIONS}} if exists $state->{ACTIONS};
  0         0  
1192              
1193             # The keys of %reduction are the -production numbers
1194             # Use hashes and not lists to guarantee that no tokens are repeated
1195 0         0 my (%expected, %reduce);
1196 0         0 for (keys(%actions)) {
1197 0 0       0 if ($actions{$_} > 0) { # shift
1198 0         0 $expected{$_} = 1;
1199 0         0 next;
1200             }
1201 0         0 $reduce{$actions{$_}} = 1;
1202             }
1203 0 0       0 $reduce{$state->{DEFAULT}} = 1 if exists($state->{DEFAULT});
1204              
1205 0 0       0 if (keys %reduce) {
1206 0         0 %expected = (%expected, $self->YYSimStack($stack, keys %reduce));
1207             }
1208            
1209 0         0 return keys %expected;
1210             }
1211              
1212             sub YYExpect {
1213 0     0 0 0 my $self = shift;
1214 0         0 $self->YYExpected($self->{STACK}, @_);
1215             }
1216             }
1217              
1218             # $self->expects($token) : returns true if the token is among the expected ones
1219             sub expects {
1220 0     0 0 0 my $self = shift;
1221 0         0 my $token = shift;
1222              
1223 0         0 my @expected = $self->YYExpect;
1224 0         0 return grep { $_ eq $token } @expected;
  0         0  
1225             }
1226              
1227             BEGIN {
1228 61     61   2490 *YYExpects = \&expects;
1229             }
1230              
1231             # Set/Get a static/class attribute for $class
1232             # Searches the $class ancestor tree for an ancestor
1233             # having defined such attribute. If found, that value is returned
1234             sub static_attribute {
1235 21293     21293 0 33310 my $class = shift;
1236 21293 100       48650 $class = ref($class) if ref($class);
1237 21293         32206 my $attributename = shift;
1238              
1239             # class/static method
1240 61     61   434 no strict 'refs';
  61         137  
  61         70621  
1241 21293         29866 my $classlexer;
1242 21293         41490 my $classname = $classlexer = $class.'::'.$attributename;
1243 21293 50       43927 if (@_) {
1244 0         0 ${$classlexer} = shift;
  0         0  
1245             }
1246              
1247 21293 100       58754 return ${$classlexer} if defined($$classlexer);
  21028         61915  
1248            
1249             # Traverse the inheritance tree for a defined
1250             # version of the attribute
1251 265         503 my @classes = @{$class.'::ISA'};
  265         1164  
1252 265         629 my %classes = map { $_ => undef } @classes;
  265         1057  
1253 265         1989 while (@classes) {
1254 265   50     848 my $c = shift @classes || return;
1255 265         670 $classlexer = $c.'::'.$attributename;
1256 265 50       1111 if (defined($$classlexer)) {
1257 265         976 $$classname = $$classlexer;
1258 265         1285 return $$classlexer;
1259             }
1260             # push those that aren't already there
1261 0         0 push @classes, grep { !exists $classes{$_} } @{$c.'::ISA'};
  0         0  
  0         0  
1262             }
1263 0         0 return undef;
1264             }
1265              
1266             sub YYEndOfInput {
1267 0     0 0 0 my $self = shift;
1268              
1269 0         0 for (${$self->input}) {
  0         0  
1270 0   0     0 return !defined($_) || ($_ eq '') || (defined(pos($_)) && (pos($_) >= length($_)));
1271             }
1272             }
1273              
1274             #################
1275             # Private stuff #
1276             #################
1277              
1278              
1279             sub _CheckParams {
1280 291     291   781 my ($mandatory,$checklist,$inarray,$outhash)=@_;
1281 291         554 my ($prm,$value);
1282 291         606 my ($prmlst)={};
1283              
1284 291         1356 while(($prm,$value)=splice(@$inarray,0,2)) {
1285 2075         3714 $prm=uc($prm);
1286 2075 50       4918 exists($$checklist{$prm})
1287             or croak("Unknown parameter '$prm'");
1288 2075 50       5198 ref($value) eq $$checklist{$prm}
1289             or croak("Invalid value for parameter '$prm'");
1290 2075         5204 $prm=unpack('@2A*',$prm);
1291 2075         6831 $$outhash{$prm}=$value;
1292             }
1293 291         983 for (@$mandatory) {
1294 316 50       1097 exists($$outhash{$_})
1295             or croak("Missing mandatory parameter '".lc($_)."'");
1296             }
1297             }
1298              
1299             #################### TailSupport ######################
1300             sub line {
1301 0     0 0 0 my $self = shift;
1302              
1303 0 0       0 if (ref($self)) {
1304 0 0       0 $self->{TOKENLINE} = shift if @_;
1305              
1306 0 0       0 return $self->static_attribute('TOKENLINE', @_,) unless defined($self->{TOKENLINE}); # class/static method
1307 0         0 return $self->{TOKENLINE};
1308             }
1309             else { # class/static method
1310 0         0 return $self->static_attribute('TOKENLINE', @_,); # class/static method
1311             }
1312             }
1313              
1314             # attribute to count the lines
1315             sub tokenline {
1316 0     0 0 0 my $self = shift;
1317              
1318 0 0       0 if (ref($self)) {
1319 0 0       0 $self->{TOKENLINE} += shift if @_;
1320              
1321 0 0       0 return $self->static_attribute('TOKENLINE', @_,) unless defined($self->{TOKENLINE}); # class/static method
1322 0         0 return $self->{TOKENLINE};
1323             }
1324             else { # class/static method
1325 0         0 return $self->static_attribute('TOKENLINE', @_,); # class/static method
1326             }
1327             }
1328              
1329             our $ERROR = \&_Error;
1330             sub error {
1331 132     132 0 339 my $self = shift;
1332              
1333 132 50       462 if (ref $self) { # instance method
1334 0 0       0 $self->{ERROR} = shift if @_;
1335              
1336 0 0       0 return $self->static_attribute('ERROR', @_,) unless defined($self->{ERROR}); # class/static method
1337 0         0 return $self->{ERROR};
1338             }
1339             else { # class/static method
1340 132         984 return $self->static_attribute('ERROR', @_,); # class/static method
1341             }
1342             }
1343              
1344             # attribute with the input
1345             # is a reference to the actual input
1346             # slurp_file.
1347             # Parameters: object or class, filename, prompt messagge, mode (interactive or not: undef or "\n")
1348             *YYSlurpFile = \&slurp_file;
1349             sub slurp_file {
1350 0     0 0 0 my $self = shift;
1351 0         0 my $fn = shift;
1352 0         0 my $f;
1353              
1354 0         0 my $mode = undef;
1355 0 0 0     0 if ($fn && -r $fn) {
1356 0 0       0 open $f, $fn or die "Can't find file '$fn'!\n";
1357             }
1358             else {
1359 0         0 $f = \*STDIN;
1360 0         0 my $msg = $self->YYPrompt();
1361 0         0 $mode = shift;
1362 0 0       0 print($msg) if $msg;
1363             }
1364 0         0 $self->YYInputFile($f);
1365              
1366 0         0 local $/ = $mode;
1367 0         0 my $input = <$f>;
1368              
1369 0 0       0 if (ref($self)) { # called as object method
1370 0         0 $self->input(\$input);
1371             }
1372             else { # class/static method
1373 0         0 my $classinput = $self.'::input';
1374 0         0 ${$classinput}->input(\$input);
  0         0  
1375             }
1376             }
1377              
1378             our $INPUT = \undef;
1379             *Parse::Eyapp::Driver::YYInput = \&input;
1380             sub input {
1381 21029     21029 0 31331 my $self = shift;
1382              
1383 21029 50       45300 $self->line(1) if @_; # used as setter
1384 21029 50       42511 if (ref $self) { # instance method
1385 21029 50       42600 if (@_) {
1386 0 0       0 if (ref $_[0]) {
1387 0         0 $self->{INPUT} = shift;
1388             }
1389             else {
1390 0         0 my $input = shift;
1391 0         0 $self->{INPUT} = \$input;
1392             }
1393             }
1394              
1395 21029 50       60232 return $self->static_attribute('INPUT', @_,) unless defined($self->{INPUT}); # class/static method
1396 0         0 return $self->{INPUT};
1397             }
1398             else { # class/static method
1399 0         0 return $self->static_attribute('INPUT', @_,); # class/static method
1400             }
1401             }
1402             *YYInput = \&input; # alias
1403              
1404             # Opened file used to get the input
1405             # static and instance method
1406             our $INPUTFILE = \*STDIN;
1407             sub YYInputFile {
1408 0     0 0 0 my $self = shift;
1409              
1410 0 0       0 if (ref($self)) { # object method
1411 0         0 my $file = shift;
1412 0 0       0 if ($file) { # setter
1413 0         0 $self->{INPUTFILE} = $file;
1414             }
1415            
1416 0 0       0 return $self->static_attribute('INPUTFILE', @_,) unless defined($self->{INPUTFILE}); # class/static method
1417 0         0 return $self->{INPUTFILE};
1418             }
1419             else { # static
1420 0         0 return $self->static_attribute('INPUTFILE', @_,); # class/static method
1421             }
1422             }
1423              
1424              
1425             our $PROMPT;
1426             sub YYPrompt {
1427 0     0 0 0 my $self = shift;
1428              
1429 0 0       0 if (ref($self)) { # object method
1430 0         0 my $prompt = shift;
1431 0 0       0 if ($prompt) { # setter
1432 0         0 $self->{PROMPT} = $prompt;
1433             }
1434            
1435 0 0       0 return $self->static_attribute('PROMPT', @_,) unless defined($self->{PROMPT}); # class/static method
1436 0         0 return $self->{PROMPT};
1437             }
1438             else { # static
1439 0         0 return $self->static_attribute('PROMPT', @_,); # class/static method
1440             }
1441             }
1442              
1443             # args: parser, debug and optionally the input or a reference to the input
1444             sub Run {
1445 0     0 0 0 my ($self) = shift;
1446 0         0 my $yydebug = shift;
1447            
1448 0 0       0 if (defined($_[0])) {
1449 0 0       0 if (ref($_[0])) { # if arg is a reference
1450 0         0 $self->input(shift());
1451             }
1452             else { # arg isn't a ref: make a copy
1453 0         0 my $x = shift();
1454 0         0 $self->input(\$x);
1455             }
1456             }
1457 0 0 0     0 croak "Provide some input for parsing" unless ($self->input && defined(${$self->input()}));
  0         0  
1458 0         0 return $self->YYParse(
1459             #yylex => $self->lexer(),
1460             #yyerror => $self->error(),
1461             yydebug => $yydebug, # 0xF
1462             );
1463             }
1464             *Parse::Eyapp::Driver::YYRun = \&run;
1465              
1466             # args: class, prompt, file, optionally input (ref or not)
1467             # return the abstract syntax tree (or whatever was returned by the parser)
1468             *Parse::Eyapp::Driver::YYMain = \&main;
1469             sub main {
1470 0     0 0 0 my $package = shift;
1471 0         0 my $prompt = shift;
1472              
1473 0         0 my $debug = 0;
1474 0         0 my $file = '';
1475 0         0 my $showtree = 0;
1476 0         0 my $TERMINALinfo;
1477             my $help;
1478 0         0 my $slurp;
1479 0         0 my $inputfromfile = 1;
1480 0         0 my $commandinput = '';
1481 0         0 my $quotedcommandinput = '';
1482 0         0 my $yaml = 0;
1483 0         0 my $dot = 0;
1484              
1485 0         0 my $result = GetOptions (
1486             "debug!" => \$debug, # sets yydebug on
1487             "file=s" => \$file, # read input from that file
1488             "commandinput=s" => \$commandinput, # read input from command line arg
1489             "tree!" => \$showtree, # prints $tree->str
1490             "info" => \$TERMINALinfo, # prints $tree->str and provides default TERMINAL::info
1491             "help" => \$help, # shows SYNOPSIS section from the script pod
1492             "slurp!" => \$slurp, # read until EOF or CR is reached
1493             "argfile!" => \$inputfromfile, # take input string from @_
1494             "yaml" => \$yaml, # dumps YAML for $tree: YAML must be installed
1495             "dot=s" => \$dot, # dumps YAML for $tree: YAML must be installed
1496             "margin=i" => \$Parse::Eyapp::Node::INDENT,
1497             );
1498              
1499 0 0       0 $package->_help() if $help;
1500              
1501 0 0       0 $debug = 0x1F if $debug;
1502 0 0 0     0 $file = shift if !$file && @ARGV; # file is taken from the @ARGV unless already defined
1503 0 0       0 $slurp = "\n" if defined($slurp);
1504              
1505 0         0 my $parser = $package->new();
1506 0 0       0 $parser->YYPrompt($prompt) if defined($prompt);
1507              
1508 0 0       0 if ($commandinput) {
    0          
1509 0         0 $parser->input(\$commandinput);
1510             }
1511             elsif ($inputfromfile) {
1512 0         0 $parser->slurp_file( $file, $slurp);
1513             }
1514             else { # input must be a string argument
1515 0 0       0 croak "No input provided for parsing! " unless defined($_[0]);
1516 0 0       0 if (ref($_[0])) {
1517 0         0 $parser->input(shift());
1518             }
1519             else {
1520 0         0 my $x = shift();
1521 0         0 $parser->input(\$x);
1522             }
1523             }
1524              
1525 0 0       0 if (defined($TERMINALinfo)) {
1526 0   0     0 my $prefix = ($parser->YYPrefix || '');
1527 61     61   490 no strict 'refs';
  61         143  
  61         93585  
1528 0         0 *{$prefix.'TERMINAL::info'} = sub {
1529 0 0   0   0 (ref($_[0]->attr) eq 'ARRAY')? $_[0]->attr->[0] : $_[0]->attr
1530 0         0 };
1531             }
1532              
1533 0         0 my $tree = $parser->Run( $debug, @_ );
1534              
1535 0 0       0 if (my $ne = $parser->YYNberr > 0) {
1536 0         0 print "There were $ne errors during parsing\n";
1537 0         0 return undef;
1538             }
1539             else {
1540 0 0       0 if ($showtree) {
1541 0 0 0     0 if ($tree && blessed $tree && $tree->isa('Parse::Eyapp::Node')) {
    0 0        
    0 0        
1542              
1543 0         0 print $tree->str()."\n";
1544             }
1545             elsif ($tree && ref $tree) {
1546 0         0 require Data::Dumper;
1547 0         0 print Data::Dumper::Dumper($tree)."\n";
1548             }
1549             elsif (defined($tree)) {
1550 0         0 print "$tree\n";
1551             }
1552             }
1553 0 0 0     0 if ($yaml && ref($tree)) {
1554 0         0 eval {
1555 0         0 require YAML;
1556             };
1557 0 0       0 if ($@) {
1558 0         0 print "You must install 'YAML' to use this option\n";
1559             }
1560             else {
1561 0         0 YAML->import;
1562 0         0 print Dump($tree);
1563             }
1564             }
1565 0 0 0     0 if ($dot && blessed($tree)) {
1566 0         0 my ($sfile, $extension) = $dot =~ /^(.*)\.([^.]*)$/;
1567 0 0 0     0 $extension = 'png' unless (defined($extension) and $tree->can($extension));
1568 0 0 0     0 ($sfile) = $file =~ m{(.*[^.])} if !defined($sfile) and defined($file);
1569 0         0 $tree->$extension($sfile);
1570             }
1571              
1572 0         0 return $tree
1573             }
1574             }
1575              
1576             sub _help {
1577 0     0   0 my $package = shift;
1578              
1579 0         0 print << 'AYUDA';
1580             Available options:
1581             --debug sets yydebug on
1582             --nodebug sets yydebug off
1583             --file filepath read input from filepath
1584             --commandinput string read input from string
1585             --tree prints $tree->str
1586             --notree does not print $tree->str
1587             --info When printing $tree->str shows the value of TERMINALs
1588             --help shows this help
1589             --slurp read until EOF reached
1590             --noslurp read until CR is reached
1591             --argfile main() will take the input string from its @_
1592             --noargfile main() will not take the input string from its @_
1593             --yaml dumps YAML for $tree: YAML module must be installed
1594             --margin=i controls the indentation of $tree->str (i.e. $Parse::Eyapp::Node::INDENT)
1595             --dot format produces a .dot and .format file (png,jpg,bmp, etc.)
1596             AYUDA
1597              
1598 0 0       0 $package->help() if ($package & $package->can("help"));
1599              
1600 0         0 exit(0);
1601             }
1602              
1603             # Generic error handler
1604             # Convention adopted: if the attribute of a token is an object
1605             # assume it has 'line' and 'str' methods. Otherwise, if it
1606             # is an array, follows the convention [ str, line, ...]
1607             # otherwise is just an string representing the value of the token
1608             sub _Error {
1609 0     0   0 my $parser = shift;
1610              
1611 0         0 my $yydata = $parser->YYData;
1612              
1613             exists $yydata->{ERRMSG}
1614 0 0       0 and do {
1615 0         0 warn $yydata->{ERRMSG};
1616 0         0 delete $yydata->{ERRMSG};
1617 0         0 return;
1618             };
1619              
1620 0         0 my ($attr)=$parser->YYCurval;
1621              
1622 0         0 my $stoken = '';
1623              
1624 0 0 0     0 if (blessed($attr) && $attr->can('str')) {
    0          
1625 0         0 $stoken = " near '".$attr->str."'"
1626             }
1627             elsif (ref($attr) eq 'ARRAY') {
1628 0         0 $stoken = " near '".$attr->[0]."'";
1629             }
1630             else {
1631 0 0       0 if ($attr) {
1632 0         0 $stoken = " near '$attr'";
1633             }
1634             else {
1635 0         0 $stoken = " near end of input";
1636             }
1637             }
1638              
1639 0 0       0 my @expected = map { ($_ ne '')? "'$_'" : q{'end of input'}} $parser->YYExpect();
  0         0  
1640 0         0 my $expected = '';
1641 0 0       0 if (@expected) {
1642 0 0       0 $expected = (@expected >1) ? "Expected one of these terminals: @expected"
1643             : "Expected terminal: @expected"
1644             }
1645              
1646 0         0 my $tline = '';
1647 0 0 0     0 if (blessed($attr) && $attr->can('line')) {
    0          
1648 0         0 $tline = " (line number ".$attr->line.")"
1649             }
1650             elsif (ref($attr) eq 'ARRAY') {
1651 0         0 $tline = " (line number ".$attr->[1].")";
1652             }
1653             else {
1654             # May be the parser object knows the line number ?
1655 0         0 my $lineno = $parser->line;
1656 0 0       0 $tline = " (line number $lineno)" if $lineno > 1;
1657             }
1658              
1659 0         0 local $" = ', ';
1660 0         0 warn << "ERRMSG";
1661              
1662             Syntax error$stoken$tline.
1663             $expected
1664             ERRMSG
1665             };
1666              
1667             ################ end TailSupport #####################
1668              
1669             sub _DBLoad {
1670              
1671             #Already loaded ?
1672 0 0   0   0 __PACKAGE__->can('_DBParse') and return;
1673            
1674 0         0 my($fname)=__FILE__;
1675 0         0 my(@drv);
1676 0         0 local $/ = "\n";
1677 0 0       0 if (open(DRV,"<$fname")) {
1678 0         0 local $_;
1679 0         0 while() {
1680             #/^\s*sub\s+_Parse\s*{\s*$/ .. /^\s*}\s*#\s*_Parse\s*$/ and do {
1681 0 0       0 /^my\s+\$lex;##!!##$/ .. /^\s*}\s*#\s*_Parse\s*$/ and do {
1682 0         0 s/^#DBG>//;
1683 0         0 push(@drv,$_);
1684             }
1685             }
1686 0         0 close(DRV);
1687              
1688 0         0 $drv[1]=~s/_P/_DBP/;
1689 0         0 eval join('',@drv);
1690             }
1691             else {
1692             # TODO: debugging for standalone modules isn't supported yet
1693 0         0 *Parse::Eyapp::Driver::_DBParse = \&_Parse;
1694             }
1695             }
1696              
1697             ### Receives an index for the parsing stack: -1 is the top
1698             ### Returns the symbol associated with the state $index
1699             sub YYSymbol {
1700 0     0 0 0 my $self = shift;
1701 0         0 my $index = shift;
1702            
1703 0         0 return $self->{STACK}[$index][2];
1704             }
1705              
1706             # # YYSymbolStack(0,-k) string with symbols from 0 to last-k
1707             # # YYSymbolStack(-k-2,-k) string with symbols from last-k-2 to last-k
1708             # # YYSymbolStack(-k-2,-k, filter) string with symbols from last-k-2 to last-k that match with filter
1709             # # YYSymbolStack('SYMBOL',-k, filter) string with symbols from the last occurrence of SYMBOL to last-k
1710             # # where filter can be code, regexp or string
1711             # sub YYSymbolStack {
1712             # my $self = shift;
1713             # my ($a, $b, $filter) = @_;
1714             #
1715             # # $b must be negative
1716             # croak "Error: Second index in YYSymbolStack must be negative\n" unless $b < 0;
1717             #
1718             # my $stack = $self->{STACK};
1719             # my $bottom = -@{$stack};
1720             # unless (looks_like_number($a)) {
1721             # # $a is a string: search from the top to the bottom for $a. Return empty list if not found
1722             # # $b must be a negative number
1723             # # $b must be a negative number
1724             # my $p = $b;
1725             # while ($p >= $bottom) {
1726             # last if (defined($stack->[$p][2]) && ($stack->[$p][2] eq $a));
1727             # $p--;
1728             # }
1729             # return () if $p < $bottom;
1730             # $a = $p;
1731             # }
1732             # # If positive, $a is an offset from the bottom of the stack
1733             # $a = $bottom+$a if $a >= 0;
1734             #
1735             # my @a = map { $self->YYSymbol($_) or '' } $a..$b;
1736             #
1737             # return @a unless defined $filter; # no filter
1738             # return (grep { $filter->{$_} } @a) if reftype($filter) && (reftype($filter) eq 'CODE'); # sub
1739             # return (grep /$filter/, @a) if reftype($filter) && (reftype($filter) eq 'SCALAR'); # regexp
1740             # return (grep { $_ eq $filter } @a); # string
1741             # }
1742              
1743             #Note that for loading debugging version of the driver,
1744             #this file will be parsed from 'sub _Parse' up to '}#_Parse' inclusive.
1745             #So, DO NOT remove comment at end of sub !!!
1746             my $lex;##!!##
1747             sub _Parse {
1748 158     158   373 my($self)=shift;
1749              
1750             #my $lex = $self->{LEX};
1751              
1752             my($rules,$states,$error)
1753 158         594 = @$self{ 'RULES', 'STATES', 'ERROR' };
1754             my($errstatus,$nberror,$token,$value,$stack,$check,$dotpos)
1755 158         633 = @$self{ 'ERRST', 'NBERR', 'TOKEN', 'VALUE', 'STACK', 'CHECK', 'DOTPOS' };
1756              
1757 158         308 my %conflictiveStates = %{$self->{STATECONFLICT}};
  158         603  
1758             #DBG> my($debug)=$$self{DEBUG};
1759             #DBG> my($dbgerror)=0;
1760              
1761             #DBG> my($ShowCurToken) = sub {
1762             #DBG> my($tok)='>';
1763             #DBG> for (split('',$$token)) {
1764             #DBG> $tok.= (ord($_) < 32 or ord($_) > 126)
1765             #DBG> ? sprintf('<%02X>',ord($_))
1766             #DBG> : $_;
1767             #DBG> }
1768             #DBG> $tok.='<';
1769             #DBG> };
1770              
1771 158         386 $$errstatus=0;
1772 158         311 $$nberror=0;
1773 158         386 ($$token,$$value)=(undef,undef);
1774 158         533 @$stack=( [ 0, undef, ] );
1775             #DBG> push(@{$stack->[-1]}, undef);
1776             #@$stack=( [ 0, undef, undef ] );
1777 158         349 $$check='';
1778              
1779 158         350 while(1) {
1780 21029         33139 my($actions,$act,$stateno);
1781              
1782 21029         29562 $self->{POS} = pos(${$self->input()});
  21029         42485  
1783 21029         37502 $stateno=$$stack[-1][0];
1784 21029 50       46468 if (exists($conflictiveStates{$stateno})) {
1785             #warn "Conflictive state $stateno managed by conflict handler '$conflictiveStates{$stateno}{name}'\n"
1786 0         0 for my $h (@{$conflictiveStates{$stateno}}) {
  0         0  
1787 0         0 $self->{CURRENT_LHS} = $h->{name};
1788 0         0 $h->{codeh}($self);
1789             }
1790             }
1791              
1792             # check if the state is a conflictive one,
1793             # if so, execute its conflict handlers
1794 21029         32057 $actions=$$states[$stateno];
1795              
1796             #DBG> print STDERR ('-' x 40),"\n";
1797             #DBG> $debug & 0x2
1798             #DBG> and print STDERR "In state $stateno:\n";
1799             #DBG> $debug & 0x08
1800             #DBG> and print STDERR "Stack: ".
1801             #DBG> join('->',map { defined($$_[2])? "'$$_[2]'->".$$_[0] : $$_[0] } @$stack).
1802             #DBG> "\n";
1803              
1804              
1805 21029 100       40731 if (exists($$actions{ACTIONS})) {
1806              
1807             defined($$token)
1808 10796 100       23423 or do {
1809 6807         17953 ($$token,$$value)=$self->{LEX}->($self); # original line
1810             #($$token,$$value)=$self->$lex; # to make it a method call
1811             #($$token,$$value) = $self->{LEX}->($self); # sensitive to the lexer changes
1812             #DBG> $debug & 0x01
1813             #DBG> and do {
1814             #DBG> print STDERR "Need token. Got ".&$ShowCurToken."\n";
1815             #DBG> };
1816             };
1817              
1818             $act= exists($$actions{ACTIONS}{$$token})
1819             ? $$actions{ACTIONS}{$$token}
1820             : exists($$actions{DEFAULT})
1821             ? $$actions{DEFAULT}
1822 10796 100       47867 : undef;
    100          
1823             }
1824             else {
1825 10233         16343 $act=$$actions{DEFAULT};
1826             #DBG> $debug & 0x01
1827             #DBG> and print STDERR "Don't need token.\n";
1828             }
1829              
1830             defined($act)
1831 21029 100       44179 and do {
1832              
1833             $act > 0
1834 21017 100       44013 and do { #shift
1835              
1836             #DBG> $debug & 0x04
1837             #DBG> and print STDERR "Shift and go to state $act.\n";
1838              
1839             $$errstatus
1840 6797 100       14188 and do {
1841 2         5 --$$errstatus;
1842              
1843             #DBG> $debug & 0x10
1844             #DBG> and $dbgerror
1845             #DBG> and $$errstatus == 0
1846             #DBG> and do {
1847             #DBG> print STDERR "**End of Error recovery.\n";
1848             #DBG> $dbgerror=0;
1849             #DBG> };
1850             };
1851              
1852              
1853 6797         14897 push(@$stack,[ $act, $$value ]);
1854             #DBG> push(@{$stack->[-1]},$$token);
1855              
1856 6797 100 66     30154 defined($$token) and ($$token ne '') #Don't eat the eof
1857             and $$token=$$value=undef;
1858 6797         12158 next;
1859             };
1860              
1861             #reduce
1862 14220         23114 my($lhs,$len,$code,@sempar,$semval);
1863 14220         19838 ($lhs,$len,$code)=@{$$rules[-$act]};
  14220         31572  
1864              
1865             #DBG> $debug & 0x04
1866             #DBG> and $act
1867             #DBG> #and print STDERR "Reduce using rule ".-$act." ($lhs,$len): "; # old Parse::Yapp line
1868             #DBG> and do { my @rhs = @{$self->{GRAMMAR}->[-$act]->[2]};
1869             #DBG> @rhs = ( '/* empty */' ) unless @rhs;
1870             #DBG> my $rhs = "@rhs";
1871             #DBG> $rhs = substr($rhs, 0, 30).'...' if length($rhs) > 30; # chomp if too large
1872             #DBG> print STDERR "Reduce using rule ".-$act." ($lhs --> $rhs): ";
1873             #DBG> };
1874              
1875 14220 100       31895 $act
1876             or $self->YYAccept();
1877              
1878 14220         21206 $$dotpos=$len;
1879              
1880             unpack('A1',$lhs) eq '@' #In line rule
1881 14220 100       43724 and do {
1882 104 50       677 $lhs =~ /^\@[0-9]+\-([0-9]+)$/
1883             or die "In line rule name '$lhs' ill formed: ".
1884             "report it as a BUG.\n";
1885 104         308 $$dotpos = $1;
1886             };
1887              
1888             @sempar = $$dotpos
1889 14220 100       40498 ? map { $$_[1] } @$stack[ -$$dotpos .. -1 ]
  21009         48719  
1890             : ();
1891              
1892 14220         26524 $self->{CURRENT_LHS} = $lhs;
1893 14220         22499 $self->{CURRENT_RULE} = -$act; # count the super-rule?
1894 14220 100       43128 $semval = $code ? $self->$code( @sempar )
    100          
1895             : @sempar ? $sempar[0] : undef;
1896              
1897 14220         29889 splice(@$stack,-$len,$len);
1898              
1899             $$check eq 'ACCEPT'
1900 14220 100       35051 and do {
1901              
1902             #DBG> $debug & 0x04
1903             #DBG> and print STDERR "Accept.\n";
1904              
1905 158         704 return($semval);
1906             };
1907              
1908             $$check eq 'ABORT'
1909 14062 50       29343 and do {
1910              
1911             #DBG> $debug & 0x04
1912             #DBG> and print STDERR "Abort.\n";
1913              
1914 0         0 return(undef);
1915              
1916             };
1917              
1918             #DBG> $debug & 0x04
1919             #DBG> and print STDERR "Back to state $$stack[-1][0], then ";
1920              
1921             $$check eq 'ERROR'
1922 14062 50       29632 or do {
1923             #DBG> $debug & 0x04
1924             #DBG> and print STDERR
1925             #DBG> "go to state $$states[$$stack[-1][0]]{GOTOS}{$lhs}.\n";
1926              
1927             #DBG> $debug & 0x10
1928             #DBG> and $dbgerror
1929             #DBG> and $$errstatus == 0
1930             #DBG> and do {
1931             #DBG> print STDERR "**End of Error recovery.\n";
1932             #DBG> $dbgerror=0;
1933             #DBG> };
1934              
1935             push(@$stack,
1936 14062         36686 [ $$states[$$stack[-1][0]]{GOTOS}{$lhs}, $semval, ]);
1937             #[ $$states[$$stack[-1][0]]{GOTOS}{$lhs}, $semval, $lhs ]);
1938             #DBG> push(@{$stack->[-1]},$lhs);
1939 14062         23802 $$check='';
1940 14062         22504 $self->{CURRENT_LHS} = undef;
1941 14062         29297 next;
1942             };
1943              
1944             #DBG> $debug & 0x04
1945             #DBG> and print STDERR "Forced Error recovery.\n";
1946              
1947 0         0 $$check='';
1948              
1949             };
1950              
1951             #Error
1952             $$errstatus
1953 12 100       28 or do {
1954              
1955 2         6 $$errstatus = 1;
1956 2         7 &$error($self);
1957 2 50       6 $$errstatus # if 0, then YYErrok has been called
1958             or next; # so continue parsing
1959              
1960             #DBG> $debug & 0x10
1961             #DBG> and do {
1962             #DBG> print STDERR "**Entering Error recovery.\n";
1963             #DBG> {
1964             #DBG> local $" = ", ";
1965             #DBG> my @expect = map { ">$_<" } $self->YYExpect();
1966             #DBG> print STDERR "Expecting one of: @expect\n";
1967             #DBG> };
1968             #DBG> ++$dbgerror;
1969             #DBG> };
1970              
1971 2         5 ++$$nberror;
1972              
1973             };
1974              
1975             $$errstatus == 3 #The next token is not valid: discard it
1976 12 100       28 and do {
1977             $$token eq '' # End of input: no hope
1978 10 50       23 and do {
1979             #DBG> $debug & 0x10
1980             #DBG> and print STDERR "**At eof: aborting.\n";
1981 0         0 return(undef);
1982             };
1983              
1984             #DBG> $debug & 0x10
1985             #DBG> and print STDERR "**Discard invalid token ".&$ShowCurToken.".\n";
1986              
1987 10         18 $$token=$$value=undef;
1988             };
1989              
1990 12         16 $$errstatus=3;
1991              
1992 12   66     75 while( @$stack
      33        
1993             and ( not exists($$states[$$stack[-1][0]]{ACTIONS})
1994             or not exists($$states[$$stack[-1][0]]{ACTIONS}{error})
1995             or $$states[$$stack[-1][0]]{ACTIONS}{error} <= 0)) {
1996              
1997             #DBG> $debug & 0x10
1998             #DBG> and print STDERR "**Pop state $$stack[-1][0].\n";
1999              
2000 13         95 pop(@$stack);
2001             }
2002              
2003             @$stack
2004 12 50       28 or do {
2005              
2006             #DBG> $debug & 0x10
2007             #DBG> and print STDERR "**No state left on stack: aborting.\n";
2008              
2009 0         0 return(undef);
2010             };
2011              
2012             #shift the error token
2013              
2014             #DBG> $debug & 0x10
2015             #DBG> and print STDERR "**Shift \$error token and go to state ".
2016             #DBG> $$states[$$stack[-1][0]]{ACTIONS}{error}.
2017             #DBG> ".\n";
2018              
2019 12         26 push(@$stack, [ $$states[$$stack[-1][0]]{ACTIONS}{error}, undef, 'error' ]);
2020              
2021             }
2022              
2023             #never reached
2024 0         0 croak("Error in driver logic. Please, report it as a BUG");
2025              
2026             }#_Parse
2027             #DO NOT remove comment
2028              
2029             *Parse::Eyapp::Driver::lexer = \&Parse::Eyapp::Driver::YYLexer;
2030             sub YYLexer {
2031 132     132 0 319 my $self = shift;
2032              
2033 132 50       419 if (ref $self) { # instance method
2034             # The class attribute isn't changed, only the instance
2035 0 0       0 $self->{LEX} = shift if @_;
2036              
2037 0 0       0 return $self->static_attribute('LEX', @_,) unless defined($self->{LEX}); # class/static method
2038 0         0 return $self->{LEX};
2039             }
2040             else {
2041 132         439 return $self->static_attribute('LEX', @_,);
2042             }
2043             }
2044              
2045              
2046             1;
2047