Move pidl to top-level directory.

1 files changed, 471 insertions, 0 deletions

diff --git a/pidl/lib/Parse/Yapp/Driver.pm b/pidl/lib/Parse/Yapp/Driver.pm
new file mode 100644
index 0000000000..d0dcbf54eb
--- /dev/null
+++ b/pidl/lib/Parse/Yapp/Driver.pm
@@ -0,0 +1,471 @@
+#
+# 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;
+