dummy_foundation/lib/Parse/Yapp/Driver.pm
changeset 4 60053dab7e2a
parent 3 8b87ea768cb8
child 5 842a773e65f2
child 6 c34a018f3291
equal deleted inserted replaced
3:8b87ea768cb8 4:60053dab7e2a
     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