1#
2# Module Parse::Yapp::Driver
3#
4# This module is part of the Parse::Yapp package available on your
5# nearest CPAN
6#
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.
9#
10# This notice should remain unchanged.
11#
12# (c) Copyright 1998-2001 Francois Desarmenien, all rights reserved.
13# (see the pod text in Parse::Yapp module for use and distribution rights)
14#
15
16package Parse::Yapp::Driver;
17
18require 5.004;
19
20use strict;
21
22use vars qw ( $VERSION $COMPATIBLE $FILENAME );
23
24$VERSION = '1.05';
25$COMPATIBLE = '0.07';
26$FILENAME=__FILE__;
27
28use Carp;
29
30#Known parameters, all starting with YY (leading YY will be discarded)
31my(%params)=(YYLEX => 'CODE', 'YYERROR' => 'CODE', YYVERSION => '',
32			 YYRULES => 'ARRAY', YYSTATES => 'ARRAY', YYDEBUG => '');
33#Mandatory parameters
34my(@params)=('LEX','RULES','STATES');
35
36sub new {
37    my($class)=shift;
38	my($errst,$nberr,$token,$value,$check,$dotpos);
39    my($self)={ ERROR => \&_Error,
40				ERRST => \$errst,
41                NBERR => \$nberr,
42				TOKEN => \$token,
43				VALUE => \$value,
44				DOTPOS => \$dotpos,
45				STACK => [],
46				DEBUG => 0,
47				CHECK => \$check };
48
49	_CheckParams( [], \%params, \@_, $self );
50
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.";
56
57        ref($class)
58    and $class=ref($class);
59
60    bless($self,$class);
61}
62
63sub YYParse {
64    my($self)=shift;
65    my($retval);
66
67	_CheckParams( \@params, \%params, \@_, $self );
68
69	if($$self{DEBUG}) {
70		_DBLoad();
71		$retval = eval '$self->_DBParse()';#Do not create stab entry on compile
72        $@ and die $@;
73	}
74	else {
75		$retval = $self->_Parse();
76	}
77    $retval
78}
79
80sub YYData {
81	my($self)=shift;
82
83		exists($$self{USER})
84	or	$$self{USER}={};
85
86	$$self{USER};
87
88}
89
90sub YYErrok {
91	my($self)=shift;
92
93	${$$self{ERRST}}=0;
94    undef;
95}
96
97sub YYNberr {
98	my($self)=shift;
99
100	${$$self{NBERR}};
101}
102
103sub YYRecovering {
104	my($self)=shift;
105
106	${$$self{ERRST}} != 0;
107}
108
109sub YYAbort {
110	my($self)=shift;
111
112	${$$self{CHECK}}='ABORT';
113    undef;
114}
115
116sub YYAccept {
117	my($self)=shift;
118
119	${$$self{CHECK}}='ACCEPT';
120    undef;
121}
122
123sub YYError {
124	my($self)=shift;
125
126	${$$self{CHECK}}='ERROR';
127    undef;
128}
129
130sub YYSemval {
131	my($self)=shift;
132	my($index)= $_[0] - ${$$self{DOTPOS}} - 1;
133
134		$index < 0
135	and	-$index <= @{$$self{STACK}}
136	and	return $$self{STACK}[$index][1];
137
138	undef;	#Invalid index
139}
140
141sub YYCurtok {
142	my($self)=shift;
143
144        @_
145    and ${$$self{TOKEN}}=$_[0];
146    ${$$self{TOKEN}};
147}
148
149sub YYCurval {
150	my($self)=shift;
151
152        @_
153    and ${$$self{VALUE}}=$_[0];
154    ${$$self{VALUE}};
155}
156
157sub YYExpect {
158    my($self)=shift;
159
160    keys %{$self->{STATES}[$self->{STACK}[-1][0]]{ACTIONS}}
161}
162
163sub YYLexer {
164    my($self)=shift;
165
166	$$self{LEX};
167}
168
169
170#################
171# Private stuff #
172#################
173
174
175sub _CheckParams {
176	my($mandatory,$checklist,$inarray,$outhash)=@_;
177	my($prm,$value);
178	my($prmlst)={};
179
180	while(($prm,$value)=splice(@$inarray,0,2)) {
181        $prm=uc($prm);
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;
188	}
189	for (@$mandatory) {
190			exists($$outhash{$_})
191		or	croak("Missing mandatory parameter '".lc($_)."'");
192	}
193}
194
195sub _Error {
196	print "Parse error.\n";
197}
198
199sub _DBLoad {
200	{
201		no strict 'refs';
202
203			exists(${__PACKAGE__.'::'}{_DBParse})#Already loaded ?
204		and	return;
205	}
206	my($fname)=__FILE__;
207	my(@drv);
208	open(DRV,"<$fname") or die "Report this as a BUG: Cannot open $fname";
209	while(<DRV>) {
210                	/^\s*sub\s+_Parse\s*{\s*$/ .. /^\s*}\s*#\s*_Parse\s*$/
211        	and     do {
212                	s/^#DBG>//;
213                	push(@drv,$_);
214        	}
215	}
216	close(DRV);
217
218	$drv[0]=~s/_P/_DBP/;
219	eval join('',@drv);
220}
221
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 !!!
225sub _Parse {
226    my($self)=shift;
227
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' };
232
233#DBG>	my($debug)=$$self{DEBUG};
234#DBG>	my($dbgerror)=0;
235
236#DBG>	my($ShowCurToken) = sub {
237#DBG>		my($tok)='>';
238#DBG>		for (split('',$$token)) {
239#DBG>			$tok.=		(ord($_) < 32 or ord($_) > 126)
240#DBG>					?	sprintf('<%02X>',ord($_))
241#DBG>					:	$_;
242#DBG>		}
243#DBG>		$tok.='<';
244#DBG>	};
245
246	$$errstatus=0;
247	$$nberror=0;
248	($$token,$$value)=(undef,undef);
249	@$stack=( [ 0, undef ] );
250	$$check='';
251
252    while(1) {
253        my($actions,$act,$stateno);
254
255        $stateno=$$stack[-1][0];
256        $actions=$$states[$stateno];
257
258#DBG>	print STDERR ('-' x 40),"\n";
259#DBG>		$debug & 0x2
260#DBG>	and	print STDERR "In state $stateno:\n";
261#DBG>		$debug & 0x08
262#DBG>	and	print STDERR "Stack:[".
263#DBG>					 join(',',map { $$_[0] } @$stack).
264#DBG>					 "]\n";
265
266
267        if  (exists($$actions{ACTIONS})) {
268
269				defined($$token)
270            or	do {
271				($$token,$$value)=&$lex($self);
272#DBG>				$debug & 0x01
273#DBG>			and	print STDERR "Need token. Got ".&$ShowCurToken."\n";
274			};
275
276            $act=   exists($$actions{ACTIONS}{$$token})
277                    ?   $$actions{ACTIONS}{$$token}
278                    :   exists($$actions{DEFAULT})
279                        ?   $$actions{DEFAULT}
280                        :   undef;
281        }
282        else {
283            $act=$$actions{DEFAULT};
284#DBG>			$debug & 0x01
285#DBG>		and	print STDERR "Don't need token.\n";
286        }
287
288            defined($act)
289        and do {
290
291                $act > 0
292            and do {        #shift
293
294#DBG>				$debug & 0x04
295#DBG>			and	print STDERR "Shift and go to state $act.\n";
296
297					$$errstatus
298				and	do {
299					--$$errstatus;
300
301#DBG>					$debug & 0x10
302#DBG>				and	$dbgerror
303#DBG>				and	$$errstatus == 0
304#DBG>				and	do {
305#DBG>					print STDERR "**End of Error recovery.\n";
306#DBG>					$dbgerror=0;
307#DBG>				};
308				};
309
310
311                push(@$stack,[ $act, $$value ]);
312
313					$$token ne ''	#Don't eat the eof
314				and	$$token=$$value=undef;
315                next;
316            };
317
318            #reduce
319            my($lhs,$len,$code,@sempar,$semval);
320            ($lhs,$len,$code)=@{$$rules[-$act]};
321
322#DBG>			$debug & 0x04
323#DBG>		and	$act
324#DBG>		and	print STDERR "Reduce using rule ".-$act." ($lhs,$len): ";
325
326                $act
327            or  $self->YYAccept();
328
329            $$dotpos=$len;
330
331                unpack('A1',$lhs) eq '@'    #In line rule
332            and do {
333                    $lhs =~ /^\@[0-9]+\-([0-9]+)$/
334                or  die "In line rule name '$lhs' ill formed: ".
335                        "report it as a BUG.\n";
336                $$dotpos = $1;
337            };
338
339            @sempar =       $$dotpos
340                        ?   map { $$_[1] } @$stack[ -$$dotpos .. -1 ]
341                        :   ();
342
343            $semval = $code ? &$code( $self, @sempar )
344                            : @sempar ? $sempar[0] : undef;
345
346            splice(@$stack,-$len,$len);
347
348                $$check eq 'ACCEPT'
349            and do {
350
351#DBG>			$debug & 0x04
352#DBG>		and	print STDERR "Accept.\n";
353
354				return($semval);
355			};
356
357                $$check eq 'ABORT'
358            and	do {
359
360#DBG>			$debug & 0x04
361#DBG>		and	print STDERR "Abort.\n";
362
363				return(undef);
364
365			};
366
367#DBG>			$debug & 0x04
368#DBG>		and	print STDERR "Back to state $$stack[-1][0], then ";
369
370                $$check eq 'ERROR'
371            or  do {
372#DBG>				$debug & 0x04
373#DBG>			and	print STDERR
374#DBG>				    "go to state $$states[$$stack[-1][0]]{GOTOS}{$lhs}.\n";
375
376#DBG>				$debug & 0x10
377#DBG>			and	$dbgerror
378#DBG>			and	$$errstatus == 0
379#DBG>			and	do {
380#DBG>				print STDERR "**End of Error recovery.\n";
381#DBG>				$dbgerror=0;
382#DBG>			};
383
384			    push(@$stack,
385                     [ $$states[$$stack[-1][0]]{GOTOS}{$lhs}, $semval ]);
386                $$check='';
387                next;
388            };
389
390#DBG>			$debug & 0x04
391#DBG>		and	print STDERR "Forced Error recovery.\n";
392
393            $$check='';
394
395        };
396
397        #Error
398            $$errstatus
399        or   do {
400
401            $$errstatus = 1;
402            &$error($self);
403                $$errstatus # if 0, then YYErrok has been called
404            or  next;       # so continue parsing
405
406#DBG>			$debug & 0x10
407#DBG>		and	do {
408#DBG>			print STDERR "**Entering Error recovery.\n";
409#DBG>			++$dbgerror;
410#DBG>		};
411
412            ++$$nberror;
413
414        };
415
416			$$errstatus == 3	#The next token is not valid: discard it
417		and	do {
418				$$token eq ''	# End of input: no hope
419			and	do {
420#DBG>				$debug & 0x10
421#DBG>			and	print STDERR "**At eof: aborting.\n";
422				return(undef);
423			};
424
425#DBG>			$debug & 0x10
426#DBG>		and	print STDERR "**Dicard invalid token ".&$ShowCurToken.".\n";
427
428			$$token=$$value=undef;
429		};
430
431        $$errstatus=3;
432
433		while(	  @$stack
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)) {
437
438#DBG>			$debug & 0x10
439#DBG>		and	print STDERR "**Pop state $$stack[-1][0].\n";
440
441			pop(@$stack);
442		}
443
444			@$stack
445		or	do {
446
447#DBG>			$debug & 0x10
448#DBG>		and	print STDERR "**No state left on stack: aborting.\n";
449
450			return(undef);
451		};
452
453		#shift the error token
454
455#DBG>			$debug & 0x10
456#DBG>		and	print STDERR "**Shift \$error token and go to state ".
457#DBG>						 $$states[$$stack[-1][0]]{ACTIONS}{error}.
458#DBG>						 ".\n";
459
460		push(@$stack, [ $$states[$$stack[-1][0]]{ACTIONS}{error}, undef ]);
461
462    }
463
464    #never reached
465	croak("Error in driver logic. Please, report it as a BUG");
466
467}#_Parse
468#DO NOT remove comment
469
4701;
471
472