2 # Module Parse::Yapp::Driver
4 # This module is part of the Parse::Yapp package available on your
7 # Any use of this module in a standalone parser make the included
8 # text under the same copyright as the Parse::Yapp module itself.
10 # This notice should remain unchanged.
12 # (c) Copyright 1998-2001 Francois Desarmenien, all rights reserved.
13 # (see the pod text in Parse::Yapp module for use and distribution rights)
16 package Parse::Yapp::Driver;
22 use vars qw ( $VERSION $COMPATIBLE $FILENAME );
30 #Known parameters, all starting with YY (leading YY will be discarded)
31 my(%params)=(YYLEX => 'CODE', 'YYERROR' => 'CODE', YYVERSION => '',
32 YYRULES => 'ARRAY', YYSTATES => 'ARRAY', YYDEBUG => '');
34 my(@params)=('LEX','RULES','STATES');
38 my($errst,$nberr,$token,$value,$check,$dotpos);
39 my($self)={ ERROR => \&_Error,
49 _CheckParams( [], \%params, \@_, $self );
51 exists($$self{VERSION})
52 and $$self{VERSION} < $COMPATIBLE
53 and croak "Yapp driver version $VERSION ".
54 "incompatible with version $$self{VERSION}:\n".
55 "Please recompile parser module.";
58 and $class=ref($class);
67 _CheckParams( \@params, \%params, \@_, $self );
71 $retval = eval '$self->_DBParse()';#Do not create stab entry on compile
75 $retval = $self->_Parse();
106 ${$$self{ERRST}} != 0;
112 ${$$self{CHECK}}='ABORT';
119 ${$$self{CHECK}}='ACCEPT';
126 ${$$self{CHECK}}='ERROR';
132 my($index)= $_[0] - ${$$self{DOTPOS}} - 1;
135 and -$index <= @{$$self{STACK}}
136 and return $$self{STACK}[$index][1];
138 undef; #Invalid index
145 and ${$$self{TOKEN}}=$_[0];
153 and ${$$self{VALUE}}=$_[0];
160 keys %{$self->{STATES}[$self->{STACK}[-1][0]]{ACTIONS}}
176 my($mandatory,$checklist,$inarray,$outhash)=@_;
180 while(($prm,$value)=splice(@$inarray,0,2)) {
182 exists($$checklist{$prm})
183 or croak("Unknow parameter '$prm'");
184 ref($value) eq $$checklist{$prm}
185 or croak("Invalid value for parameter '$prm'");
186 $prm=unpack('@2A*',$prm);
187 $$outhash{$prm}=$value;
190 exists($$outhash{$_})
191 or croak("Missing mandatory parameter '".lc($_)."'");
196 print "Parse error.\n";
203 exists(${__PACKAGE__.'::'}{_DBParse})#Already loaded ?
208 open(DRV,"<$fname") or die "Report this as a BUG: Cannot open $fname";
210 /^\s*sub\s+_Parse\s*{\s*$/ .. /^\s*}\s*#\s*_Parse\s*$/
222 #Note that for loading debugging version of the driver,
223 #this file will be parsed from 'sub _Parse' up to '}#_Parse' inclusive.
224 #So, DO NOT remove comment at end of sub !!!
228 my($rules,$states,$lex,$error)
229 = @$self{ 'RULES', 'STATES', 'LEX', 'ERROR' };
230 my($errstatus,$nberror,$token,$value,$stack,$check,$dotpos)
231 = @$self{ 'ERRST', 'NBERR', 'TOKEN', 'VALUE', 'STACK', 'CHECK', 'DOTPOS' };
233 #DBG> my($debug)=$$self{DEBUG};
234 #DBG> my($dbgerror)=0;
236 #DBG> my($ShowCurToken) = sub {
238 #DBG> for (split('',$$token)) {
239 #DBG> $tok.= (ord($_) < 32 or ord($_) > 126)
240 #DBG> ? sprintf('<%02X>',ord($_))
248 ($$token,$$value)=(undef,undef);
249 @$stack=( [ 0, undef ] );
253 my($actions,$act,$stateno);
255 $stateno=$$stack[-1][0];
256 $actions=$$states[$stateno];
258 #DBG> print STDERR ('-' x 40),"\n";
260 #DBG> and print STDERR "In state $stateno:\n";
262 #DBG> and print STDERR "Stack:[".
263 #DBG> join(',',map { $$_[0] } @$stack).
267 if (exists($$actions{ACTIONS})) {
271 ($$token,$$value)=&$lex($self);
273 #DBG> and print STDERR "Need token. Got ".&$ShowCurToken."\n";
276 $act= exists($$actions{ACTIONS}{$$token})
277 ? $$actions{ACTIONS}{$$token}
278 : exists($$actions{DEFAULT})
283 $act=$$actions{DEFAULT};
285 #DBG> and print STDERR "Don't need token.\n";
295 #DBG> and print STDERR "Shift and go to state $act.\n";
303 #DBG> and $$errstatus == 0
305 #DBG> print STDERR "**End of Error recovery.\n";
311 push(@$stack,[ $act, $$value ]);
313 $$token ne '' #Don't eat the eof
314 and $$token=$$value=undef;
319 my($lhs,$len,$code,@sempar,$semval);
320 ($lhs,$len,$code)=@{$$rules[-$act]};
324 #DBG> and print STDERR "Reduce using rule ".-$act." ($lhs,$len): ";
327 or $self->YYAccept();
331 unpack('A1',$lhs) eq '@' #In line rule
333 $lhs =~ /^\@[0-9]+\-([0-9]+)$/
334 or die "In line rule name '$lhs' ill formed: ".
335 "report it as a BUG.\n";
340 ? map { $$_[1] } @$stack[ -$$dotpos .. -1 ]
343 $semval = $code ? &$code( $self, @sempar )
344 : @sempar ? $sempar[0] : undef;
346 splice(@$stack,-$len,$len);
352 #DBG> and print STDERR "Accept.\n";
361 #DBG> and print STDERR "Abort.\n";
368 #DBG> and print STDERR "Back to state $$stack[-1][0], then ";
373 #DBG> and print STDERR
374 #DBG> "go to state $$states[$$stack[-1][0]]{GOTOS}{$lhs}.\n";
378 #DBG> and $$errstatus == 0
380 #DBG> print STDERR "**End of Error recovery.\n";
385 [ $$states[$$stack[-1][0]]{GOTOS}{$lhs}, $semval ]);
391 #DBG> and print STDERR "Forced Error recovery.\n";
403 $$errstatus # if 0, then YYErrok has been called
404 or next; # so continue parsing
408 #DBG> print STDERR "**Entering Error recovery.\n";
416 $$errstatus == 3 #The next token is not valid: discard it
418 $$token eq '' # End of input: no hope
421 #DBG> and print STDERR "**At eof: aborting.\n";
426 #DBG> and print STDERR "**Dicard invalid token ".&$ShowCurToken.".\n";
428 $$token=$$value=undef;
434 and ( not exists($$states[$$stack[-1][0]]{ACTIONS})
435 or not exists($$states[$$stack[-1][0]]{ACTIONS}{error})
436 or $$states[$$stack[-1][0]]{ACTIONS}{error} <= 0)) {
439 #DBG> and print STDERR "**Pop state $$stack[-1][0].\n";
448 #DBG> and print STDERR "**No state left on stack: aborting.\n";
453 #shift the error token
456 #DBG> and print STDERR "**Shift \$error token and go to state ".
457 #DBG> $$states[$$stack[-1][0]]{ACTIONS}{error}.
460 push(@$stack, [ $$states[$$stack[-1][0]]{ACTIONS}{error}, undef ]);
465 croak("Error in driver logic. Please, report it as a BUG");
468 #DO NOT remove comment