pidl/lib/Parse/Yapp/Driver.pm

   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("Unknown 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