ad758df90b
Please note that the Alphatronics implementation does not follow the Vebon specification. An extra padding byte had to be added to the idl..
471 lines
9.5 KiB
Perl
471 lines
9.5 KiB
Perl
#
|
|
# Module Parse::Yapp::Driver
|
|
#
|
|
# This module is part of the Parse::Yapp package available on your
|
|
# nearest CPAN
|
|
#
|
|
# Any use of this module in a standalone parser make the included
|
|
# text under the same copyright as the Parse::Yapp module itself.
|
|
#
|
|
# This notice should remain unchanged.
|
|
#
|
|
# (c) Copyright 1998-2001 Francois Desarmenien, all rights reserved.
|
|
# (see the pod text in Parse::Yapp module for use and distribution rights)
|
|
#
|
|
|
|
package Parse::Yapp::Driver;
|
|
|
|
require 5.004;
|
|
|
|
use strict;
|
|
|
|
use vars qw ( $VERSION $COMPATIBLE $FILENAME );
|
|
|
|
$VERSION = '1.05';
|
|
$COMPATIBLE = '0.07';
|
|
$FILENAME=__FILE__;
|
|
|
|
use Carp;
|
|
|
|
#Known parameters, all starting with YY (leading YY will be discarded)
|
|
my(%params)=(YYLEX => 'CODE', 'YYERROR' => 'CODE', YYVERSION => '',
|
|
YYRULES => 'ARRAY', YYSTATES => 'ARRAY', YYDEBUG => '');
|
|
#Mandatory parameters
|
|
my(@params)=('LEX','RULES','STATES');
|
|
|
|
sub new {
|
|
my($class)=shift;
|
|
my($errst,$nberr,$token,$value,$check,$dotpos);
|
|
my($self)={ ERROR => \&_Error,
|
|
ERRST => \$errst,
|
|
NBERR => \$nberr,
|
|
TOKEN => \$token,
|
|
VALUE => \$value,
|
|
DOTPOS => \$dotpos,
|
|
STACK => [],
|
|
DEBUG => 0,
|
|
CHECK => \$check };
|
|
|
|
_CheckParams( [], \%params, \@_, $self );
|
|
|
|
exists($$self{VERSION})
|
|
and $$self{VERSION} < $COMPATIBLE
|
|
and croak "Yapp driver version $VERSION ".
|
|
"incompatible with version $$self{VERSION}:\n".
|
|
"Please recompile parser module.";
|
|
|
|
ref($class)
|
|
and $class=ref($class);
|
|
|
|
bless($self,$class);
|
|
}
|
|
|
|
sub YYParse {
|
|
my($self)=shift;
|
|
my($retval);
|
|
|
|
_CheckParams( \@params, \%params, \@_, $self );
|
|
|
|
if($$self{DEBUG}) {
|
|
_DBLoad();
|
|
$retval = eval '$self->_DBParse()';#Do not create stab entry on compile
|
|
$@ and die $@;
|
|
}
|
|
else {
|
|
$retval = $self->_Parse();
|
|
}
|
|
$retval
|
|
}
|
|
|
|
sub YYData {
|
|
my($self)=shift;
|
|
|
|
exists($$self{USER})
|
|
or $$self{USER}={};
|
|
|
|
$$self{USER};
|
|
|
|
}
|
|
|
|
sub YYErrok {
|
|
my($self)=shift;
|
|
|
|
${$$self{ERRST}}=0;
|
|
undef;
|
|
}
|
|
|
|
sub YYNberr {
|
|
my($self)=shift;
|
|
|
|
${$$self{NBERR}};
|
|
}
|
|
|
|
sub YYRecovering {
|
|
my($self)=shift;
|
|
|
|
${$$self{ERRST}} != 0;
|
|
}
|
|
|
|
sub YYAbort {
|
|
my($self)=shift;
|
|
|
|
${$$self{CHECK}}='ABORT';
|
|
undef;
|
|
}
|
|
|
|
sub YYAccept {
|
|
my($self)=shift;
|
|
|
|
${$$self{CHECK}}='ACCEPT';
|
|
undef;
|
|
}
|
|
|
|
sub YYError {
|
|
my($self)=shift;
|
|
|
|
${$$self{CHECK}}='ERROR';
|
|
undef;
|
|
}
|
|
|
|
sub YYSemval {
|
|
my($self)=shift;
|
|
my($index)= $_[0] - ${$$self{DOTPOS}} - 1;
|
|
|
|
$index < 0
|
|
and -$index <= @{$$self{STACK}}
|
|
and return $$self{STACK}[$index][1];
|
|
|
|
undef; #Invalid index
|
|
}
|
|
|
|
sub YYCurtok {
|
|
my($self)=shift;
|
|
|
|
@_
|
|
and ${$$self{TOKEN}}=$_[0];
|
|
${$$self{TOKEN}};
|
|
}
|
|
|
|
sub YYCurval {
|
|
my($self)=shift;
|
|
|
|
@_
|
|
and ${$$self{VALUE}}=$_[0];
|
|
${$$self{VALUE}};
|
|
}
|
|
|
|
sub YYExpect {
|
|
my($self)=shift;
|
|
|
|
keys %{$self->{STATES}[$self->{STACK}[-1][0]]{ACTIONS}}
|
|
}
|
|
|
|
sub YYLexer {
|
|
my($self)=shift;
|
|
|
|
$$self{LEX};
|
|
}
|
|
|
|
|
|
#################
|
|
# Private stuff #
|
|
#################
|
|
|
|
|
|
sub _CheckParams {
|
|
my($mandatory,$checklist,$inarray,$outhash)=@_;
|
|
my($prm,$value);
|
|
my($prmlst)={};
|
|
|
|
while(($prm,$value)=splice(@$inarray,0,2)) {
|
|
$prm=uc($prm);
|
|
exists($$checklist{$prm})
|
|
or croak("Unknow parameter '$prm'");
|
|
ref($value) eq $$checklist{$prm}
|
|
or croak("Invalid value for parameter '$prm'");
|
|
$prm=unpack('@2A*',$prm);
|
|
$$outhash{$prm}=$value;
|
|
}
|
|
for (@$mandatory) {
|
|
exists($$outhash{$_})
|
|
or croak("Missing mandatory parameter '".lc($_)."'");
|
|
}
|
|
}
|
|
|
|
sub _Error {
|
|
print "Parse error.\n";
|
|
}
|
|
|
|
sub _DBLoad {
|
|
{
|
|
no strict 'refs';
|
|
|
|
exists(${__PACKAGE__.'::'}{_DBParse})#Already loaded ?
|
|
and return;
|
|
}
|
|
my($fname)=__FILE__;
|
|
my(@drv);
|
|
open(DRV,"<$fname") or die "Report this as a BUG: Cannot open $fname";
|
|
while(<DRV>) {
|
|
/^\s*sub\s+_Parse\s*{\s*$/ .. /^\s*}\s*#\s*_Parse\s*$/
|
|
and do {
|
|
s/^#DBG>//;
|
|
push(@drv,$_);
|
|
}
|
|
}
|
|
close(DRV);
|
|
|
|
$drv[0]=~s/_P/_DBP/;
|
|
eval join('',@drv);
|
|
}
|
|
|
|
#Note that for loading debugging version of the driver,
|
|
#this file will be parsed from 'sub _Parse' up to '}#_Parse' inclusive.
|
|
#So, DO NOT remove comment at end of sub !!!
|
|
sub _Parse {
|
|
my($self)=shift;
|
|
|
|
my($rules,$states,$lex,$error)
|
|
= @$self{ 'RULES', 'STATES', 'LEX', 'ERROR' };
|
|
my($errstatus,$nberror,$token,$value,$stack,$check,$dotpos)
|
|
= @$self{ 'ERRST', 'NBERR', 'TOKEN', 'VALUE', 'STACK', 'CHECK', 'DOTPOS' };
|
|
|
|
#DBG> my($debug)=$$self{DEBUG};
|
|
#DBG> my($dbgerror)=0;
|
|
|
|
#DBG> my($ShowCurToken) = sub {
|
|
#DBG> my($tok)='>';
|
|
#DBG> for (split('',$$token)) {
|
|
#DBG> $tok.= (ord($_) < 32 or ord($_) > 126)
|
|
#DBG> ? sprintf('<%02X>',ord($_))
|
|
#DBG> : $_;
|
|
#DBG> }
|
|
#DBG> $tok.='<';
|
|
#DBG> };
|
|
|
|
$$errstatus=0;
|
|
$$nberror=0;
|
|
($$token,$$value)=(undef,undef);
|
|
@$stack=( [ 0, undef ] );
|
|
$$check='';
|
|
|
|
while(1) {
|
|
my($actions,$act,$stateno);
|
|
|
|
$stateno=$$stack[-1][0];
|
|
$actions=$$states[$stateno];
|
|
|
|
#DBG> print STDERR ('-' x 40),"\n";
|
|
#DBG> $debug & 0x2
|
|
#DBG> and print STDERR "In state $stateno:\n";
|
|
#DBG> $debug & 0x08
|
|
#DBG> and print STDERR "Stack:[".
|
|
#DBG> join(',',map { $$_[0] } @$stack).
|
|
#DBG> "]\n";
|
|
|
|
|
|
if (exists($$actions{ACTIONS})) {
|
|
|
|
defined($$token)
|
|
or do {
|
|
($$token,$$value)=&$lex($self);
|
|
#DBG> $debug & 0x01
|
|
#DBG> and print STDERR "Need token. Got ".&$ShowCurToken."\n";
|
|
};
|
|
|
|
$act= exists($$actions{ACTIONS}{$$token})
|
|
? $$actions{ACTIONS}{$$token}
|
|
: exists($$actions{DEFAULT})
|
|
? $$actions{DEFAULT}
|
|
: undef;
|
|
}
|
|
else {
|
|
$act=$$actions{DEFAULT};
|
|
#DBG> $debug & 0x01
|
|
#DBG> and print STDERR "Don't need token.\n";
|
|
}
|
|
|
|
defined($act)
|
|
and do {
|
|
|
|
$act > 0
|
|
and do { #shift
|
|
|
|
#DBG> $debug & 0x04
|
|
#DBG> and print STDERR "Shift and go to state $act.\n";
|
|
|
|
$$errstatus
|
|
and do {
|
|
--$$errstatus;
|
|
|
|
#DBG> $debug & 0x10
|
|
#DBG> and $dbgerror
|
|
#DBG> and $$errstatus == 0
|
|
#DBG> and do {
|
|
#DBG> print STDERR "**End of Error recovery.\n";
|
|
#DBG> $dbgerror=0;
|
|
#DBG> };
|
|
};
|
|
|
|
|
|
push(@$stack,[ $act, $$value ]);
|
|
|
|
$$token ne '' #Don't eat the eof
|
|
and $$token=$$value=undef;
|
|
next;
|
|
};
|
|
|
|
#reduce
|
|
my($lhs,$len,$code,@sempar,$semval);
|
|
($lhs,$len,$code)=@{$$rules[-$act]};
|
|
|
|
#DBG> $debug & 0x04
|
|
#DBG> and $act
|
|
#DBG> and print STDERR "Reduce using rule ".-$act." ($lhs,$len): ";
|
|
|
|
$act
|
|
or $self->YYAccept();
|
|
|
|
$$dotpos=$len;
|
|
|
|
unpack('A1',$lhs) eq '@' #In line rule
|
|
and do {
|
|
$lhs =~ /^\@[0-9]+\-([0-9]+)$/
|
|
or die "In line rule name '$lhs' ill formed: ".
|
|
"report it as a BUG.\n";
|
|
$$dotpos = $1;
|
|
};
|
|
|
|
@sempar = $$dotpos
|
|
? map { $$_[1] } @$stack[ -$$dotpos .. -1 ]
|
|
: ();
|
|
|
|
$semval = $code ? &$code( $self, @sempar )
|
|
: @sempar ? $sempar[0] : undef;
|
|
|
|
splice(@$stack,-$len,$len);
|
|
|
|
$$check eq 'ACCEPT'
|
|
and do {
|
|
|
|
#DBG> $debug & 0x04
|
|
#DBG> and print STDERR "Accept.\n";
|
|
|
|
return($semval);
|
|
};
|
|
|
|
$$check eq 'ABORT'
|
|
and do {
|
|
|
|
#DBG> $debug & 0x04
|
|
#DBG> and print STDERR "Abort.\n";
|
|
|
|
return(undef);
|
|
|
|
};
|
|
|
|
#DBG> $debug & 0x04
|
|
#DBG> and print STDERR "Back to state $$stack[-1][0], then ";
|
|
|
|
$$check eq 'ERROR'
|
|
or do {
|
|
#DBG> $debug & 0x04
|
|
#DBG> and print STDERR
|
|
#DBG> "go to state $$states[$$stack[-1][0]]{GOTOS}{$lhs}.\n";
|
|
|
|
#DBG> $debug & 0x10
|
|
#DBG> and $dbgerror
|
|
#DBG> and $$errstatus == 0
|
|
#DBG> and do {
|
|
#DBG> print STDERR "**End of Error recovery.\n";
|
|
#DBG> $dbgerror=0;
|
|
#DBG> };
|
|
|
|
push(@$stack,
|
|
[ $$states[$$stack[-1][0]]{GOTOS}{$lhs}, $semval ]);
|
|
$$check='';
|
|
next;
|
|
};
|
|
|
|
#DBG> $debug & 0x04
|
|
#DBG> and print STDERR "Forced Error recovery.\n";
|
|
|
|
$$check='';
|
|
|
|
};
|
|
|
|
#Error
|
|
$$errstatus
|
|
or do {
|
|
|
|
$$errstatus = 1;
|
|
&$error($self);
|
|
$$errstatus # if 0, then YYErrok has been called
|
|
or next; # so continue parsing
|
|
|
|
#DBG> $debug & 0x10
|
|
#DBG> and do {
|
|
#DBG> print STDERR "**Entering Error recovery.\n";
|
|
#DBG> ++$dbgerror;
|
|
#DBG> };
|
|
|
|
++$$nberror;
|
|
|
|
};
|
|
|
|
$$errstatus == 3 #The next token is not valid: discard it
|
|
and do {
|
|
$$token eq '' # End of input: no hope
|
|
and do {
|
|
#DBG> $debug & 0x10
|
|
#DBG> and print STDERR "**At eof: aborting.\n";
|
|
return(undef);
|
|
};
|
|
|
|
#DBG> $debug & 0x10
|
|
#DBG> and print STDERR "**Dicard invalid token ".&$ShowCurToken.".\n";
|
|
|
|
$$token=$$value=undef;
|
|
};
|
|
|
|
$$errstatus=3;
|
|
|
|
while( @$stack
|
|
and ( not exists($$states[$$stack[-1][0]]{ACTIONS})
|
|
or not exists($$states[$$stack[-1][0]]{ACTIONS}{error})
|
|
or $$states[$$stack[-1][0]]{ACTIONS}{error} <= 0)) {
|
|
|
|
#DBG> $debug & 0x10
|
|
#DBG> and print STDERR "**Pop state $$stack[-1][0].\n";
|
|
|
|
pop(@$stack);
|
|
}
|
|
|
|
@$stack
|
|
or do {
|
|
|
|
#DBG> $debug & 0x10
|
|
#DBG> and print STDERR "**No state left on stack: aborting.\n";
|
|
|
|
return(undef);
|
|
};
|
|
|
|
#shift the error token
|
|
|
|
#DBG> $debug & 0x10
|
|
#DBG> and print STDERR "**Shift \$error token and go to state ".
|
|
#DBG> $$states[$$stack[-1][0]]{ACTIONS}{error}.
|
|
#DBG> ".\n";
|
|
|
|
push(@$stack, [ $$states[$$stack[-1][0]]{ACTIONS}{error}, undef ]);
|
|
|
|
}
|
|
|
|
#never reached
|
|
croak("Error in driver logic. Please, report it as a BUG");
|
|
|
|
}#_Parse
|
|
#DO NOT remove comment
|
|
|
|
1;
|
|
|