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 |
|
16 package Parse::Yapp::Driver; |
|
17 |
|
18 require 5.004; |
|
19 |
|
20 use strict; |
|
21 |
|
22 use vars qw ( $VERSION $COMPATIBLE $FILENAME ); |
|
23 |
|
24 $VERSION = '1.05'; |
|
25 $COMPATIBLE = '0.07'; |
|
26 $FILENAME=__FILE__; |
|
27 |
|
28 use Carp; |
|
29 |
|
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 => ''); |
|
33 #Mandatory parameters |
|
34 my(@params)=('LEX','RULES','STATES'); |
|
35 |
|
36 sub 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 |
|
63 sub 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 |
|
80 sub YYData { |
|
81 my($self)=shift; |
|
82 |
|
83 exists($$self{USER}) |
|
84 or $$self{USER}={}; |
|
85 |
|
86 $$self{USER}; |
|
87 |
|
88 } |
|
89 |
|
90 sub YYErrok { |
|
91 my($self)=shift; |
|
92 |
|
93 ${$$self{ERRST}}=0; |
|
94 undef; |
|
95 } |
|
96 |
|
97 sub YYNberr { |
|
98 my($self)=shift; |
|
99 |
|
100 ${$$self{NBERR}}; |
|
101 } |
|
102 |
|
103 sub YYRecovering { |
|
104 my($self)=shift; |
|
105 |
|
106 ${$$self{ERRST}} != 0; |
|
107 } |
|
108 |
|
109 sub YYAbort { |
|
110 my($self)=shift; |
|
111 |
|
112 ${$$self{CHECK}}='ABORT'; |
|
113 undef; |
|
114 } |
|
115 |
|
116 sub YYAccept { |
|
117 my($self)=shift; |
|
118 |
|
119 ${$$self{CHECK}}='ACCEPT'; |
|
120 undef; |
|
121 } |
|
122 |
|
123 sub YYError { |
|
124 my($self)=shift; |
|
125 |
|
126 ${$$self{CHECK}}='ERROR'; |
|
127 undef; |
|
128 } |
|
129 |
|
130 sub 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 |
|
141 sub YYCurtok { |
|
142 my($self)=shift; |
|
143 |
|
144 @_ |
|
145 and ${$$self{TOKEN}}=$_[0]; |
|
146 ${$$self{TOKEN}}; |
|
147 } |
|
148 |
|
149 sub YYCurval { |
|
150 my($self)=shift; |
|
151 |
|
152 @_ |
|
153 and ${$$self{VALUE}}=$_[0]; |
|
154 ${$$self{VALUE}}; |
|
155 } |
|
156 |
|
157 sub YYExpect { |
|
158 my($self)=shift; |
|
159 |
|
160 keys %{$self->{STATES}[$self->{STACK}[-1][0]]{ACTIONS}} |
|
161 } |
|
162 |
|
163 sub YYLexer { |
|
164 my($self)=shift; |
|
165 |
|
166 $$self{LEX}; |
|
167 } |
|
168 |
|
169 |
|
170 ################# |
|
171 # Private stuff # |
|
172 ################# |
|
173 |
|
174 |
|
175 sub _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 |
|
195 sub _Error { |
|
196 print "Parse error.\n"; |
|
197 } |
|
198 |
|
199 sub _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 !!! |
|
225 sub _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 |
|
470 1; |
|
471 |
|